INTEGER FUNCTION ieeeck ( ispec, zero, one ) ! Code converted using TO_F90 by Alan Miller ! Date: 2001-03-28 Time: 09:33:51 ! ! ! -- 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, INTENT(IN) :: ispec REAL, INTENT(IN) :: zero REAL, INTENT(IN) :: one ! .. ! ! 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 <= one ) THEN ieeeck = 0 RETURN END IF ! neginf = -one / zero IF( neginf >= zero ) THEN ieeeck = 0 RETURN END IF negzro = one / ( neginf+one ) IF( negzro /= zero ) THEN ieeeck = 0 RETURN END IF neginf = one / negzro IF( neginf >= zero ) THEN ieeeck = 0 RETURN END IF newzro = negzro + zero IF( newzro /= zero ) THEN ieeeck = 0 RETURN END IF posinf = one / newzro IF( posinf <= one ) THEN ieeeck = 0 RETURN END IF neginf = neginf*posinf IF( neginf >= zero ) THEN ieeeck = 0 RETURN END IF posinf = posinf*posinf IF( posinf <= one ) THEN ieeeck = 0 RETURN END IF ! ! Return if we were only asked to check infinity arithmetic. ! IF( ispec == 0 ) THEN RETURN END IF nan1 = posinf + neginf nan2 = posinf / neginf nan3 = posinf / posinf nan4 = posinf*zero nan5 = neginf*negzro nan6 = nan5*0.0 IF( nan1 == nan1 ) THEN ieeeck = 0 RETURN END IF IF( nan2 == nan2 ) THEN ieeeck = 0 RETURN END IF IF( nan3 == nan3 ) THEN ieeeck = 0 RETURN END IF IF( nan4 == nan4 ) THEN ieeeck = 0 RETURN END IF IF( nan5 == nan5 ) THEN ieeeck = 0 RETURN END IF IF( nan6 == nan6 ) THEN ieeeck = 0 RETURN END IF RETURN END FUNCTION ieeeck 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 .. INTEGER, INTENT(IN OUT) :: ispec CHARACTER (LEN= * ), INTENT(IN) :: NAME CHARACTER (LEN= * ), INTENT(IN OUT) :: opts INTEGER, INTENT(IN) :: n1 INTEGER, INTENT(IN) :: n2 INTEGER, INTENT(IN) :: n3 INTEGER, INTENT(IN) :: 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 (LEN=1) :: c1 CHARACTER (LEN=2) :: c2, c4 CHARACTER (LEN=3) :: c3 CHARACTER (LEN=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 .. ! SELECT CASE ( ispec ) CASE ( 1) GO TO 100 CASE ( 2) GO TO 100 CASE ( 3) GO TO 100 CASE ( 4) GO TO 400 CASE ( 5) GO TO 500 CASE ( 6) GO TO 600 CASE ( 7) GO TO 700 CASE ( 8) GO TO 800 CASE ( 9) GO TO 900 CASE ( 10) GO TO 1000 CASE ( 11) GO TO 1100 END SELECT ! ! 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 == 90 .OR. iz == 122 ) THEN ! ! ASCII character set ! IF( ic >= 97 .AND. ic <= 122 ) THEN subnam( 1:1 ) = CHAR( ic-32 ) DO i = 2, 6 ic = ICHAR( subnam( i:i ) ) IF( ic >= 97 .AND. ic <= 122 ) THEN subnam( i:i ) = CHAR( ic-32 ) END IF END DO END IF ELSE IF( iz == 233 .OR. iz == 169 ) THEN ! ! EBCDIC character set ! IF( ( ic >= 129 .AND. ic <= 137 ) .OR. & ( ic >= 145 .AND. ic <= 153 ) .OR. ( ic >= 162 .AND. ic <= 169 ) ) THEN subnam( 1:1 ) = CHAR( ic+64 ) DO i = 2, 6 ic = ICHAR( subnam( i:i ) ) IF( ( ic >= 129 .AND. ic <= 137 ) .OR. & ( ic >= 145 .AND. ic <= 153 ) .OR. ( ic >= 162 .AND. ic <= 169 ) ) & subnam( i:i ) = CHAR( ic+64 ) END DO END IF ! ELSE IF( iz == 218 .OR. iz == 250 ) THEN ! ! Prime machines: ASCII+128 ! IF( ic >= 225 .AND. ic <= 250 ) THEN subnam( 1:1 ) = CHAR( ic-32 ) DO i = 2, 6 ic = ICHAR( subnam( i:i ) ) IF( ic >= 225 .AND. ic <= 250 ) subnam( i:i ) = CHAR( ic-32 ) END DO END IF END IF ! c1 = subnam( 1:1 ) sname = c1 == 'S' .OR. c1 == 'D' cname = c1 == 'C' .OR. c1 == 'Z' IF( .NOT.( cname .OR. sname ) ) THEN RETURN END IF c2 = subnam( 2:3 ) c3 = subnam( 4:6 ) c4 = c3( 2:3 ) SELECT CASE ( ispec ) CASE ( 1) GO TO 110 CASE ( 2) GO TO 200 CASE ( 3) GO TO 300 END SELECT 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 == 'GE' ) THEN IF( c3 == 'TRF' ) THEN IF( sname ) THEN nb = 64 ELSE nb = 64 END IF ELSE IF( c3 == 'QRF' .OR. c3 == 'RQF' .OR. c3 == 'LQF' .OR. & c3 == 'QLF' ) THEN IF( sname ) THEN nb = 32 ELSE nb = 32 END IF ELSE IF( c3 == 'HRD' ) THEN IF( sname ) THEN nb = 32 ELSE nb = 32 END IF ELSE IF( c3 == 'BRD' ) THEN IF( sname ) THEN nb = 32 ELSE nb = 32 END IF ELSE IF( c3 == 'TRI' ) THEN IF( sname ) THEN nb = 64 ELSE nb = 64 END IF END IF ELSE IF( c2 == 'PO' ) THEN IF( c3 == 'TRF' ) THEN IF( sname ) THEN nb = 64 ELSE nb = 64 END IF END IF ELSE IF( c2 == 'SY' ) THEN IF( c3 == 'TRF' ) THEN IF( sname ) THEN nb = 64 ELSE nb = 64 END IF ELSE IF( sname .AND. c3 == 'TRD' ) THEN nb = 32 ELSE IF( sname .AND. c3 == 'GST' ) THEN nb = 64 END IF ELSE IF( cname .AND. c2 == 'HE' ) THEN IF( c3 == 'TRF' ) THEN nb = 64 ELSE IF( c3 == 'TRD' ) THEN nb = 32 ELSE IF( c3 == 'GST' ) THEN nb = 64 END IF ELSE IF( sname .AND. c2 == 'OR' ) THEN IF( c3( 1:1 ) == 'G' ) THEN IF( c4 == 'QR' .OR. c4 == 'RQ' .OR. c4 == 'LQ' .OR. & c4 == 'QL' .OR. c4 == 'HR' .OR. c4 == 'TR' .OR. c4 == 'BR' ) THEN nb = 32 END IF ELSE IF( c3( 1:1 ) == 'M' ) THEN IF( c4 == 'QR' .OR. c4 == 'RQ' .OR. c4 == 'LQ' .OR. & c4 == 'QL' .OR. c4 == 'HR' .OR. c4 == 'TR' .OR. c4 == 'BR' ) THEN nb = 32 END IF END IF ELSE IF( cname .AND. c2 == 'UN' ) THEN IF( c3( 1:1 ) == 'G' ) THEN IF( c4 == 'QR' .OR. c4 == 'RQ' .OR. c4 == 'LQ' .OR. & c4 == 'QL' .OR. c4 == 'HR' .OR. c4 == 'TR' .OR. c4 == 'BR' ) THEN nb = 32 END IF ELSE IF( c3( 1:1 ) == 'M' ) THEN IF( c4 == 'QR' .OR. c4 == 'RQ' .OR. c4 == 'LQ' .OR. & c4 == 'QL' .OR. c4 == 'HR' .OR. c4 == 'TR' .OR. c4 == 'BR' ) THEN nb = 32 END IF END IF ELSE IF( c2 == 'GB' ) THEN IF( c3 == 'TRF' ) THEN IF( sname ) THEN IF( n4 <= 64 ) THEN nb = 1 ELSE nb = 32 END IF ELSE IF( n4 <= 64 ) THEN nb = 1 ELSE nb = 32 END IF END IF END IF ELSE IF( c2 == 'PB' ) THEN IF( c3 == 'TRF' ) THEN IF( sname ) THEN IF( n2 <= 64 ) THEN nb = 1 ELSE nb = 32 END IF ELSE IF( n2 <= 64 ) THEN nb = 1 ELSE nb = 32 END IF END IF END IF ELSE IF( c2 == 'TR' ) THEN IF( c3 == 'TRI' ) THEN IF( sname ) THEN nb = 64 ELSE nb = 64 END IF END IF ELSE IF( c2 == 'LA' ) THEN IF( c3 == 'UUM' ) THEN IF( sname ) THEN nb = 64 ELSE nb = 64 END IF END IF ELSE IF( sname .AND. c2 == 'ST' ) THEN IF( c3 == 'EBZ' ) THEN nb = 1 END IF END IF ilaenv = nb RETURN ! 200 CONTINUE ! ! ISPEC = 2: minimum block size ! nbmin = 2 IF( c2 == 'GE' ) THEN IF( c3 == 'QRF' .OR. c3 == 'RQF' .OR. c3 == 'LQF' .OR. c3 == 'QLF' ) THEN IF( sname ) THEN nbmin = 2 ELSE nbmin = 2 END IF ELSE IF( c3 == 'HRD' ) THEN IF( sname ) THEN nbmin = 2 ELSE nbmin = 2 END IF ELSE IF( c3 == 'BRD' ) THEN IF( sname ) THEN nbmin = 2 ELSE nbmin = 2 END IF ELSE IF( c3 == 'TRI' ) THEN IF( sname ) THEN nbmin = 2 ELSE nbmin = 2 END IF END IF ELSE IF( c2 == 'SY' ) THEN IF( c3 == 'TRF' ) THEN IF( sname ) THEN nbmin = 8 ELSE nbmin = 8 END IF ELSE IF( sname .AND. c3 == 'TRD' ) THEN nbmin = 2 END IF ELSE IF( cname .AND. c2 == 'HE' ) THEN IF( c3 == 'TRD' ) THEN nbmin = 2 END IF ELSE IF( sname .AND. c2 == 'OR' ) THEN IF( c3( 1:1 ) == 'G' ) THEN IF( c4 == 'QR' .OR. c4 == 'RQ' .OR. c4 == 'LQ' .OR. & c4 == 'QL' .OR. c4 == 'HR' .OR. c4 == 'TR' .OR. c4 == 'BR' ) THEN nbmin = 2 END IF ELSE IF( c3( 1:1 ) == 'M' ) THEN IF( c4 == 'QR' .OR. c4 == 'RQ' .OR. c4 == 'LQ' .OR. & c4 == 'QL' .OR. c4 == 'HR' .OR. c4 == 'TR' .OR. c4 == 'BR' ) THEN nbmin = 2 END IF END IF ELSE IF( cname .AND. c2 == 'UN' ) THEN IF( c3( 1:1 ) == 'G' ) THEN IF( c4 == 'QR' .OR. c4 == 'RQ' .OR. c4 == 'LQ' .OR. & c4 == 'QL' .OR. c4 == 'HR' .OR. c4 == 'TR' .OR. c4 == 'BR' ) THEN nbmin = 2 END IF ELSE IF( c3( 1:1 ) == 'M' ) THEN IF( c4 == 'QR' .OR. c4 == 'RQ' .OR. c4 == 'LQ' .OR. & c4 == 'QL' .OR. c4 == 'HR' .OR. c4 == 'TR' .OR. c4 == 'BR' ) THEN nbmin = 2 END IF END IF END IF ilaenv = nbmin RETURN ! 300 CONTINUE ! ! ISPEC = 3: crossover point ! nx = 0 IF( c2 == 'GE' ) THEN IF( c3 == 'QRF' .OR. c3 == 'RQF' .OR. c3 == 'LQF' .OR. c3 == 'QLF' ) THEN IF( sname ) THEN nx = 128 ELSE nx = 128 END IF ELSE IF( c3 == 'HRD' ) THEN IF( sname ) THEN nx = 128 ELSE nx = 128 END IF ELSE IF( c3 == 'BRD' ) THEN IF( sname ) THEN nx = 128 ELSE nx = 128 END IF END IF ELSE IF( c2 == 'SY' ) THEN IF( sname .AND. c3 == 'TRD' ) THEN nx = 32 END IF ELSE IF( cname .AND. c2 == 'HE' ) THEN IF( c3 == 'TRD' ) THEN nx = 32 END IF ELSE IF( sname .AND. c2 == 'OR' ) THEN IF( c3( 1:1 ) == 'G' ) THEN IF( c4 == 'QR' .OR. c4 == 'RQ' .OR. c4 == 'LQ' .OR. & c4 == 'QL' .OR. c4 == 'HR' .OR. c4 == 'TR' .OR. c4 == 'BR' ) THEN nx = 128 END IF END IF ELSE IF( cname .AND. c2 == 'UN' ) THEN IF( c3( 1:1 ) == 'G' ) THEN IF( c4 == 'QR' .OR. c4 == 'RQ' .OR. c4 == 'LQ' .OR. & c4 == 'QL' .OR. c4 == 'HR' .OR. c4 == 'TR' .OR. c4 == '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 ! ! ILAENV = 0 ilaenv = 1 IF( ilaenv == 1 ) THEN ilaenv = ieeeck( 0, 0.0, 1.0 ) END IF RETURN ! 1100 CONTINUE ! ! ISPEC = 11: infinity arithmetic can be trusted not to trap ! ! ILAENV = 0 ilaenv = 1 IF( ilaenv == 1 ) THEN ilaenv = ieeeck( 1, 0.0, 1.0 ) END IF RETURN ! ! End of ILAENV ! END FUNCTION ilaenv LOGICAL FUNCTION lsame( ca, cb ) ! ! -- 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 (LEN=1), INTENT(IN) :: ca CHARACTER (LEN=1), INTENT(IN) :: 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 == 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 == 90 .OR. zcode == 122 ) THEN ! ! ASCII is assumed - ZCODE is the ASCII code of either lower or ! upper case 'Z'. ! IF( inta >= 97 .AND. inta <= 122 ) inta = inta - 32 IF( intb >= 97 .AND. intb <= 122 ) intb = intb - 32 ! ELSE IF( zcode == 233 .OR. zcode == 169 ) THEN ! ! EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or ! upper case 'Z'. ! IF( inta >= 129 .AND. inta <= 137 .OR. & inta >= 145 .AND. inta <= 153 .OR. & inta >= 162 .AND. inta <= 169 ) inta = inta + 64 IF( intb >= 129 .AND. intb <= 137 .OR. & intb >= 145 .AND. intb <= 153 .OR. & intb >= 162 .AND. intb <= 169 ) intb = intb + 64 ! ELSE IF( zcode == 218 .OR. zcode == 250 ) THEN ! ! ASCII is assumed, on Prime machines - ZCODE is the ASCII code ! plus 128 of either lower or upper case 'Z'. ! IF( inta >= 225 .AND. inta <= 250 ) inta = inta - 32 IF( intb >= 225 .AND. intb <= 250 ) intb = intb - 32 END IF lsame = inta == intb ! ! RETURN ! ! End of LSAME ! END FUNCTION lsame LOGICAL FUNCTION lsamen( n, ca, cb ) ! ! -- 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, INTENT(IN) :: n CHARACTER (LEN= * ), INTENT(IN) :: ca CHARACTER (LEN= * ), INTENT(IN) :: cb ! .. ! ! Purpose ! ======= ! ! LSAMEN tests if the first N letters of CA are the same as the ! first N letters of CB, regardless of case. ! LSAMEN returns .TRUE. if CA and CB are equivalent except for case ! and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA ) ! or LEN( CB ) is less than N. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The number of characters in CA and CB to be compared. ! ! CA (input) CHARACTER*(*) ! CB (input) CHARACTER*(*) ! CA and CB specify two character strings of length at least N. ! Only the first N characters of each string will be accessed. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER :: i ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Intrinsic Functions .. INTRINSIC LEN ! .. ! .. Executable Statements .. ! lsamen = .false. IF( LEN( ca ) < n .OR. LEN( cb ) < n ) THEN GO TO 20 END IF ! ! Do for each character in the two strings. ! DO i = 1, n ! ! Test if the characters are equal using LSAME. ! IF( .NOT.lsame( ca( i: i ), cb( i: i ) ) ) THEN GO TO 20 END IF END DO lsamen = .true. ! 20 CONTINUE RETURN ! ! End of LSAMEN ! END FUNCTION lsamen SUBROUTINE sbdsdc ( uplo, compq, n, d, e, u, ldu, vt, ldvt, q, iq, & 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 (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: compq INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(OUT) :: e( * ) REAL, INTENT(OUT) :: u( ldu, * ) INTEGER, INTENT(IN OUT) :: ldu REAL, INTENT(OUT) :: vt( ldvt, * ) INTEGER, INTENT(IN OUT) :: ldvt REAL, INTENT(OUT) :: q( * ) INTEGER, INTENT(OUT) :: iq( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SBDSDC computes the singular value decomposition (SVD) of a real ! N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT, ! using a divide and conquer method, where S is a diagonal matrix ! with non-negative diagonal elements (the singular values of B), and ! U and VT are orthogonal matrices of left and right singular vectors, ! respectively. SBDSDC can be used to compute all singular values, ! and optionally, singular vectors or singular vectors in compact form. ! ! This code makes very mild assumptions about floating point ! arithmetic. It will work on machines with a guard digit in ! add/subtract, or on those binary machines without guard digits ! which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. ! It could conceivably fail on hexadecimal or decimal machines ! without guard digits, but we know of none. See SLASD3 for details. ! ! The code currently call SLASDQ if singular values only are desired. ! However, it can be slightly modified to compute singular values ! using the divide and conquer method. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! = 'U': B is upper bidiagonal. ! = 'L': B is lower bidiagonal. ! ! COMPQ (input) CHARACTER*1 ! Specifies whether singular vectors are to be computed ! as follows: ! = 'N': Compute singular values only; ! = 'P': Compute singular values and compute singular ! vectors in compact form; ! = 'I': Compute singular values and singular vectors. ! ! N (input) INTEGER ! The order of the matrix B. N >= 0. ! ! D (input/output) REAL array, dimension (N) ! On entry, the n diagonal elements of the bidiagonal matrix B. ! On exit, if INFO=0, the singular values of B. ! ! E (input/output) REAL array, dimension (N) ! On entry, the elements of E contain the offdiagonal ! elements of the bidiagonal matrix whose SVD is desired. ! On exit, E has been destroyed. ! ! U (output) REAL array, dimension (LDU,N) ! If COMPQ = 'I', then: ! On exit, if INFO = 0, U contains the left singular vectors ! of the bidiagonal matrix. ! For other values of COMPQ, U is not referenced. ! ! LDU (input) INTEGER ! The leading dimension of the array U. LDU >= 1. ! If singular vectors are desired, then LDU >= max( 1, N ). ! ! VT (output) REAL array, dimension (LDVT,N) ! If COMPQ = 'I', then: ! On exit, if INFO = 0, VT' contains the right singular ! vectors of the bidiagonal matrix. ! For other values of COMPQ, VT is not referenced. ! ! LDVT (input) INTEGER ! The leading dimension of the array VT. LDVT >= 1. ! If singular vectors are desired, then LDVT >= max( 1, N ). ! ! Q (output) REAL array, dimension (LDQ) ! If COMPQ = 'P', then: ! On exit, if INFO = 0, Q and IQ contain the left ! and right singular vectors in a compact form, ! requiring O(N log N) space instead of 2*N**2. ! In particular, Q contains all the REAL data in ! LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1)))) ! words of memory, where SMLSIZ is returned by ILAENV and ! is equal to the maximum size of the subproblems at the ! bottom of the computation tree (usually about 25). ! For other values of COMPQ, Q is not referenced. ! ! IQ (output) INTEGER array, dimension (LDIQ) ! If COMPQ = 'P', then: ! On exit, if INFO = 0, Q and IQ contain the left ! and right singular vectors in a compact form, ! requiring O(N log N) space instead of 2*N**2. ! In particular, IQ contains all INTEGER data in ! LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1)))) ! words of memory, where SMLSIZ is returned by ILAENV and ! is equal to the maximum size of the subproblems at the ! bottom of the computation tree (usually about 25). ! For other values of COMPQ, IQ is not referenced. ! ! WORK (workspace) REAL array, dimension (LWORK) ! If COMPQ = 'N' then LWORK >= (2 * N). ! If COMPQ = 'P' then LWORK >= (6 * N). ! If COMPQ = 'I' then LWORK >= (3 * N**2 + 2 * N). ! ! IWORK (workspace) INTEGER array, dimension (7*N) ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: The algorithm failed to compute an singular value. ! The update process of divide and conquer failed. ! ! Further Details ! =============== ! ! Based on contributions by ! Ming Gu and Huan Ren, Computer Science Division, University of ! California at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 ! .. ! .. Local Scalars .. INTEGER :: difl, difr, givcol, givnum, givptr, i, ic, & icompq, ierr, ii, is, iu, iuplo, ivt, j, k, kk, & mlvl, nm1, nsize, perm, poles, qstart, smlsiz, smlszp, sqre, start, wstart, z REAL :: cs, eps, orgnrm, p, r, sn ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slanst EXTERNAL slamch, slanst, ilaenv, lsame ! .. ! .. External Subroutines .. EXTERNAL scopy, slartg, slascl, slasd0, slasda, slasdq, & slaset, slasr, sswap, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC REAL, ABS, INT, LOG, SIGN ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! iuplo = 0 IF( lsame( uplo, 'U' ) ) iuplo = 1 IF( lsame( uplo, 'L' ) ) iuplo = 2 IF( lsame( compq, 'N' ) ) THEN icompq = 0 ELSE IF( lsame( compq, 'P' ) ) THEN icompq = 1 ELSE IF( lsame( compq, 'I' ) ) THEN icompq = 2 ELSE icompq = -1 END IF IF( iuplo == 0 ) THEN info = -1 ELSE IF( icompq < 0 ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( ( ldu < 1 ) .OR. ( ( icompq == 2 ) .AND. ( ldu < & n ) ) ) THEN info = -7 ELSE IF( ( ldvt < 1 ) .OR. ( ( icompq == 2 ) .AND. ( ldvt < & n ) ) ) THEN info = -9 END IF IF( info /= 0 ) THEN CALL xerbla( 'SBDSDC', -info ) RETURN END IF ! ! Quick return if possible ! IF ( n == 0 ) THEN RETURN END IF smlsiz = ilaenv( 9, 'SBDSDC', ' ', 0, 0, 0, 0 ) IF( n == 1 ) THEN IF( icompq == 1 ) THEN q( 1 ) = SIGN( one, d( 1 ) ) q( 1+smlsiz*n ) = one ELSE IF( icompq == 2 ) THEN u( 1, 1 ) = SIGN( one, d( 1 ) ) vt( 1, 1 ) = one END IF d( 1 ) = ABS( d( 1 ) ) RETURN END IF nm1 = n - 1 ! ! If matrix lower bidiagonal, rotate to be upper bidiagonal ! by applying Givens rotations on the left ! wstart = 1 qstart = 3 IF( icompq == 1 ) THEN CALL scopy( n, d, 1, q( 1 ), 1 ) CALL scopy( n-1, e, 1, q( n+1 ), 1 ) END IF IF( iuplo == 2 ) THEN qstart = 5 wstart = 2*n - 1 DO i = 1, n - 1 CALL slartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) IF( icompq == 1 ) THEN q( i+2*n ) = cs q( i+3*n ) = sn ELSE IF( icompq == 2 ) THEN work( i ) = cs work( nm1+i ) = -sn END IF END DO END IF ! ! If ICOMPQ = 0, use SLASDQ to compute the singular values. ! IF( icompq == 0 ) THEN CALL slasdq( 'U', 0, n, 0, 0, 0, d, e, vt, ldvt, u, ldu, u, & ldu, work( wstart ), info ) GO TO 40 END IF ! ! If N is smaller than the minimum divide size SMLSIZ, then solve ! the problem with another solver. ! IF( n <= smlsiz ) THEN IF( icompq == 2 ) THEN CALL slaset( 'A', n, n, zero, one, u, ldu ) CALL slaset( 'A', n, n, zero, one, vt, ldvt ) CALL slasdq( 'U', 0, n, n, n, 0, d, e, vt, ldvt, u, ldu, u, & ldu, work( wstart ), info ) ELSE IF( icompq == 1 ) THEN iu = 1 ivt = iu + n CALL slaset( 'A', n, n, zero, one, q( iu+( qstart-1 )*n ), n ) CALL slaset( 'A', n, n, zero, one, q( ivt+( qstart-1 )*n ), n ) CALL slasdq( 'U', 0, n, n, n, 0, d, e, q( ivt+( qstart-1 )*n ), n, & q( iu+( qstart-1 )*n ), n, q( iu+( qstart-1 )*n ), n, work( wstart ), & info ) END IF GO TO 40 END IF IF( icompq == 2 ) THEN CALL slaset( 'A', n, n, zero, one, u, ldu ) CALL slaset( 'A', n, n, zero, one, vt, ldvt ) END IF ! ! Scale. ! orgnrm = slanst( 'M', n, d, e ) IF( orgnrm == zero ) RETURN CALL slascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, ierr ) CALL slascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, ierr ) ! eps = slamch( 'Epsilon' ) ! mlvl = INT( LOG( REAL( n ) / REAL( smlsiz+1 ) ) / LOG( two ) ) + 1 smlszp = smlsiz + 1 ! IF( icompq == 1 ) THEN iu = 1 ivt = 1 + smlsiz difl = ivt + smlszp difr = difl + mlvl z = difr + mlvl*2 ic = z + mlvl is = ic + 1 poles = is + 1 givnum = poles + 2*mlvl k = 1 givptr = 2 perm = 3 givcol = perm + mlvl END IF DO i = 1, n IF( ABS( d( i ) ) < eps ) THEN d( i ) = SIGN( eps, d( i ) ) END IF END DO start = 1 sqre = 0 ! DO i = 1, nm1 IF( ( ABS( e( i ) ) < eps ) .OR. ( i == nm1 ) ) THEN ! ! Subproblem found. First determine its size and then ! apply divide and conquer on it. ! IF( i < nm1 ) THEN ! ! A subproblem with E(I) small for I < NM1. ! nsize = i - start + 1 ELSE IF( ABS( e( i ) ) >= eps ) THEN ! ! A subproblem with E(NM1) not too small but I = NM1. ! nsize = n - start + 1 ELSE ! ! A subproblem with E(NM1) small. This implies an ! 1-by-1 subproblem at D(N). Solve this 1-by-1 problem ! first. ! nsize = i - start + 1 IF( icompq == 2 ) THEN u( n, n ) = SIGN( one, d( n ) ) vt( n, n ) = one ELSE IF( icompq == 1 ) THEN q( n+( qstart-1 )*n ) = SIGN( one, d( n ) ) q( n+( smlsiz+qstart-1 )*n ) = one END IF d( n ) = ABS( d( n ) ) END IF IF( icompq == 2 ) THEN CALL slasd0( nsize, sqre, d( start ), e( start ), & u( start, start ), ldu, vt( start, start ), & ldvt, smlsiz, iwork, work( wstart ), info ) ELSE CALL slasda( icompq, smlsiz, nsize, sqre, d( start ), & e( start ), q( start+( iu+qstart-2 )*n ), n, & q( start+( ivt+qstart-2 )*n ), & iq( start+k*n ), q( start+( difl+qstart-2 )* & n ), q( start+( difr+qstart-2 )*n ), q( start+( z+qstart-2 )*n ), & q( start+( poles+qstart-2 )*n ), & iq( start+givptr*n ), iq( start+givcol*n ), n, iq( start+perm*n ), & q( start+( givnum+qstart-2 )*n ), q( start+( ic+qstart-2 )*n ), & q( start+( is+qstart-2 )*n ), work( wstart ), iwork, info ) IF( info /= 0 ) THEN RETURN END IF END IF start = i + 1 END IF END DO ! ! Unscale ! CALL slascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, ierr ) 40 CONTINUE ! ! Use Selection Sort to minimize swaps of singular vectors ! DO ii = 2, n i = ii - 1 kk = i p = d( i ) DO j = ii, n IF( d( j ) > p ) THEN kk = j p = d( j ) END IF END DO IF( kk /= i ) THEN d( kk ) = d( i ) d( i ) = p IF( icompq == 1 ) THEN iq( i ) = kk ELSE IF( icompq == 2 ) THEN CALL sswap( n, u( 1, i ), 1, u( 1, kk ), 1 ) CALL sswap( n, vt( i, 1 ), ldvt, vt( kk, 1 ), ldvt ) END IF ELSE IF( icompq == 1 ) THEN iq( i ) = i END IF END DO ! ! If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO ! IF( icompq == 1 ) THEN IF( iuplo == 1 ) THEN iq( n ) = 1 ELSE iq( n ) = 0 END IF END IF ! ! If B is lower bidiagonal, update U by those Givens rotations ! which rotated B to be upper bidiagonal ! IF( ( iuplo == 2 ) .AND. ( icompq == 2 ) ) & CALL slasr( 'L', 'V', 'B', n, n, work( 1 ), work( n ), u, ldu ) ! RETURN ! ! End of SBDSDC ! END SUBROUTINE sbdsdc SUBROUTINE sbdsqr( uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u, & ldu, 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 ! June 30, 1999 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: ncvt INTEGER, INTENT(IN) :: nru INTEGER, INTENT(IN) :: ncc REAL, INTENT(OUT) :: d( * ) REAL, INTENT(OUT) :: e( * ) REAL, INTENT(IN OUT) :: vt( ldvt, * ) INTEGER, INTENT(IN OUT) :: ldvt REAL, INTENT(IN OUT) :: u( ldu, * ) INTEGER, INTENT(IN OUT) :: ldu REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SBDSQR 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 real 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) REAL 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) REAL array, dimension (N) ! On entry, the elements of E contain the ! offdiagonal elements 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) REAL 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) REAL 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) REAL 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. ! ! WORK (workspace) REAL array, dimension ! 2*N if only singular values wanted (NCVT = NRU = NCC = 0) ! max( 1, 4*N-4 ) otherwise ! ! 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 REAL, 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 .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: negone = -1.0E0 REAL, PARAMETER :: hndrth = 0.01E0 REAL, PARAMETER :: ten = 10.0E0 REAL, PARAMETER :: hndrd = 100.0E0 REAL, PARAMETER :: meigth = -0.125E0 INTEGER, PARAMETER :: maxitr = 6 ! .. ! .. Local Scalars .. LOGICAL :: lower, rotate INTEGER :: i, idir, isub, iter, j, ll, lll, m, maxit, nm1, & nm12, nm13, oldll, oldm REAL :: 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 REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. External Subroutines .. EXTERNAL slartg, slas2, slasq1, slasr, slasv2, srot, & sscal, sswap, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, REAL, 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 < 0 ) THEN info = -2 ELSE IF( ncvt < 0 ) THEN info = -3 ELSE IF( nru < 0 ) THEN info = -4 ELSE IF( ncc < 0 ) THEN info = -5 ELSE IF( ( ncvt == 0 .AND. ldvt < 1 ) .OR. & ( ncvt > 0 .AND. ldvt < MAX( 1, n ) ) ) THEN info = -9 ELSE IF( ldu < MAX( 1, nru ) ) THEN info = -11 ELSE IF( ( ncc == 0 .AND. ldc < 1 ) .OR. & ( ncc > 0 .AND. ldc < MAX( 1, n ) ) ) THEN info = -13 END IF IF( info /= 0 ) THEN CALL xerbla( 'SBDSQR', -info ) RETURN END IF IF( n == 0 ) RETURN IF( n == 1 ) GO TO 160 ! ! ROTATE is true if any singular vectors desired, false otherwise ! rotate = ( ncvt > 0 ) .OR. ( nru > 0 ) .OR. ( ncc > 0 ) ! ! If no singular vectors desired, use qd algorithm ! IF( .NOT.rotate ) THEN CALL slasq1( n, d, e, work, info ) RETURN END IF ! nm1 = n - 1 nm12 = nm1 + nm1 nm13 = nm12 + nm1 idir = 0 ! ! Get machine constants ! eps = slamch( 'Epsilon' ) unfl = slamch( 'Safe minimum' ) ! ! If matrix lower bidiagonal, rotate to be upper bidiagonal ! by applying Givens rotations on the left ! IF( lower ) THEN DO i = 1, n - 1 CALL slartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) work( i ) = cs work( nm1+i ) = sn END DO ! ! Update singular vectors if desired ! IF( nru > 0 ) & CALL slasr( 'R', 'V', 'F', nru, n, work( 1 ), work( n ), u, ldu ) IF( ncc > 0 ) & CALL slasr( 'L', 'V', 'F', n, ncc, work( 1 ), work( 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 i = 1, n smax = MAX( smax, ABS( d( i ) ) ) END DO DO i = 1, n - 1 smax = MAX( smax, ABS( e( i ) ) ) END DO sminl = zero IF( tol >= zero ) THEN ! ! Relative accuracy desired ! sminoa = ABS( d( 1 ) ) IF( sminoa == zero ) GO TO 50 mu = sminoa DO i = 2, n mu = ABS( d( i ) )*( mu / ( mu+ABS( e( i-1 ) ) ) ) sminoa = MIN( sminoa, mu ) IF( sminoa == zero ) EXIT END DO 50 CONTINUE sminoa = sminoa / SQRT( REAL( 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 <= 1 ) GO TO 160 IF( iter > maxit ) GO TO 200 ! ! Find diagonal block of matrix to work on ! IF( tol < zero .AND. ABS( d( m ) ) <= thresh ) d( m ) = zero smax = ABS( d( m ) ) smin = smax DO lll = 1, m - 1 ll = m - lll abss = ABS( d( ll ) ) abse = ABS( e( ll ) ) IF( tol < zero .AND. abss <= thresh ) d( ll ) = zero IF( abse <= thresh ) GO TO 80 smin = MIN( smin, abss ) smax = MAX( smax, abss, abse ) END DO ll = 0 GO TO 90 80 CONTINUE e( ll ) = zero ! ! Matrix splits since E(LL) = 0 ! IF( ll == 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 == m-1 ) THEN ! ! 2 by 2 block, handle separately ! CALL slasv2( 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 > 0 ) & CALL srot( ncvt, vt( m-1, 1 ), ldvt, vt( m, 1 ), ldvt, cosr, sinr ) IF( nru > 0 ) CALL srot( nru, u( 1, m-1 ), 1, u( 1, m ), 1, cosl, sinl ) IF( ncc > 0 ) CALL srot( 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 > oldm .OR. m < oldll ) THEN IF( ABS( d( ll ) ) >= 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 == 1 ) THEN ! ! Run convergence test in forward direction ! First apply standard test to bottom of matrix ! IF( ABS( e( m-1 ) ) <= ABS( tol )*ABS( d( m ) ) .OR. & ( tol < zero .AND. ABS( e( m-1 ) ) <= thresh ) ) THEN e( m-1 ) = zero GO TO 60 END IF ! IF( tol >= zero ) THEN ! ! If relative accuracy desired, ! apply convergence criterion forward ! mu = ABS( d( ll ) ) sminl = mu DO lll = ll, m - 1 IF( ABS( e( lll ) ) <= 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 ) END DO END IF ! ELSE ! ! Run convergence test in backward direction ! First apply standard test to top of matrix ! IF( ABS( e( ll ) ) <= ABS( tol )*ABS( d( ll ) ) .OR. & ( tol < zero .AND. ABS( e( ll ) ) <= thresh ) ) THEN e( ll ) = zero GO TO 60 END IF ! IF( tol >= zero ) THEN ! ! If relative accuracy desired, ! apply convergence criterion backward ! mu = ABS( d( m ) ) sminl = mu DO lll = m - 1, ll, -1 IF( ABS( e( lll ) ) <= 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 ) END DO 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 >= zero .AND. n*tol*( sminl / smax ) <= 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 == 1 ) THEN sll = ABS( d( ll ) ) CALL slas2( d( m-1 ), e( m-1 ), d( m ), shift, r ) ELSE sll = ABS( d( m ) ) CALL slas2( d( ll ), e( ll ), d( ll+1 ), shift, r ) END IF ! ! Test if shift negligible, and if so set to zero ! IF( sll > zero ) THEN IF( ( shift / sll )**2 < eps ) shift = zero END IF END IF ! ! Increment iteration count ! iter = iter + m - ll ! ! If SHIFT = 0, do simplified QR iteration ! IF( shift == zero ) THEN IF( idir == 1 ) THEN ! ! Chase bulge from top to bottom ! Save cosines and sines for later singular vector updates ! cs = one oldcs = one DO i = ll, m - 1 CALL slartg( d( i )*cs, e( i ), cs, sn, r ) IF( i > ll ) e( i-1 ) = oldsn*r CALL slartg( oldcs*r, d( i+1 )*sn, oldcs, oldsn, d( i ) ) work( i-ll+1 ) = cs work( i-ll+1+nm1 ) = sn work( i-ll+1+nm12 ) = oldcs work( i-ll+1+nm13 ) = oldsn END DO h = d( m )*cs d( m ) = h*oldcs e( m-1 ) = h*oldsn ! ! Update singular vectors ! IF( ncvt > 0 ) CALL slasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1 ), & work( n ), vt( ll, 1 ), ldvt ) IF( nru > 0 ) CALL slasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ), & work( nm13+1 ), u( 1, ll ), ldu ) IF( ncc > 0 ) CALL slasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ), & work( nm13+1 ), c( ll, 1 ), ldc ) ! ! Test convergence ! IF( ABS( e( m-1 ) ) <= 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 i = m, ll + 1, -1 CALL slartg( d( i )*cs, e( i-1 ), cs, sn, r ) IF( i < m ) e( i ) = oldsn*r CALL slartg( oldcs*r, d( i-1 )*sn, oldcs, oldsn, d( i ) ) work( i-ll ) = cs work( i-ll+nm1 ) = -sn work( i-ll+nm12 ) = oldcs work( i-ll+nm13 ) = -oldsn END DO h = d( ll )*cs d( ll ) = h*oldcs e( ll ) = h*oldsn ! ! Update singular vectors ! IF( ncvt > 0 ) & CALL slasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ), & work( nm13+1 ), vt( ll, 1 ), ldvt ) IF( nru > 0 ) CALL slasr( 'R', 'V', 'B', nru, m-ll+1, work( 1 ), & work( n ), u( 1, ll ), ldu ) IF( ncc > 0 ) CALL slasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1 ), & work( n ), c( ll, 1 ), ldc ) ! ! Test convergence ! IF( ABS( e( ll ) ) <= thresh ) e( ll ) = zero END IF ELSE ! ! Use nonzero shift ! IF( idir == 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 i = ll, m - 1 CALL slartg( f, g, cosr, sinr, r ) IF( i > 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 slartg( 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 < m-1 ) THEN g = sinl*e( i+1 ) e( i+1 ) = cosl*e( i+1 ) END IF work( i-ll+1 ) = cosr work( i-ll+1+nm1 ) = sinr work( i-ll+1+nm12 ) = cosl work( i-ll+1+nm13 ) = sinl END DO e( m-1 ) = f ! ! Update singular vectors ! IF( ncvt > 0 ) CALL slasr( 'L', 'V', 'F', m-ll+1, ncvt, work( 1 ), & work( n ), vt( ll, 1 ), ldvt ) IF( nru > 0 ) CALL slasr( 'R', 'V', 'F', nru, m-ll+1, work( nm12+1 ), & work( nm13+1 ), u( 1, ll ), ldu ) IF( ncc > 0 ) CALL slasr( 'L', 'V', 'F', m-ll+1, ncc, work( nm12+1 ), & work( nm13+1 ), c( ll, 1 ), ldc ) ! ! Test convergence ! IF( ABS( e( m-1 ) ) <= 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 i = m, ll + 1, -1 CALL slartg( f, g, cosr, sinr, r ) IF( i < 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 slartg( 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 > ll+1 ) THEN g = sinl*e( i-2 ) e( i-2 ) = cosl*e( i-2 ) END IF work( i-ll ) = cosr work( i-ll+nm1 ) = -sinr work( i-ll+nm12 ) = cosl work( i-ll+nm13 ) = -sinl END DO e( ll ) = f ! ! Test convergence ! IF( ABS( e( ll ) ) <= thresh ) e( ll ) = zero ! ! Update singular vectors if desired ! IF( ncvt > 0 ) & CALL slasr( 'L', 'V', 'B', m-ll+1, ncvt, work( nm12+1 ), & work( nm13+1 ), vt( ll, 1 ), ldvt ) IF( nru > 0 ) CALL slasr( 'R', 'V', 'B', nru, m-ll+1, work( 1 ), & work( n ), u( 1, ll ), ldu ) IF( ncc > 0 ) CALL slasr( 'L', 'V', 'B', m-ll+1, ncc, work( 1 ), & work( 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 i = 1, n IF( d( i ) < zero ) THEN d( i ) = -d( i ) ! ! Change sign of singular vectors, if desired ! IF( ncvt > 0 ) CALL sscal( ncvt, negone, vt( i, 1 ), ldvt ) END IF END DO ! ! Sort the singular values into decreasing order (insertion sort on ! singular values, but only one transposition per singular vector) ! DO i = 1, n - 1 ! ! Scan for smallest D(I) ! isub = 1 smin = d( 1 ) DO j = 2, n + 1 - i IF( d( j ) <= smin ) THEN isub = j smin = d( j ) END IF END DO IF( isub /= n+1-i ) THEN ! ! Swap singular values and vectors ! d( isub ) = d( n+1-i ) d( n+1-i ) = smin IF( ncvt > 0 ) CALL sswap( ncvt, vt( isub, 1 ), ldvt, vt( n+1-i, 1 ), & ldvt ) IF( nru > 0 ) CALL sswap( nru, u( 1, isub ), 1, u( 1, n+1-i ), 1 ) IF( ncc > 0 ) CALL sswap( ncc, c( isub, 1 ), ldc, c( n+1-i, 1 ), ldc ) END IF END DO GO TO 220 ! ! Maximum number of iterations exceeded, failure to converge ! 200 CONTINUE info = 0 DO i = 1, n - 1 IF( e( i ) /= zero ) info = info + 1 END DO 220 CONTINUE RETURN ! ! End of SBDSQR ! END SUBROUTINE sbdsqr SUBROUTINE sdisna( job, m, n, d, sep, 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 (LEN=1), INTENT(IN) :: job INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: d( * ) REAL, INTENT(OUT) :: sep( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SDISNA computes the reciprocal condition numbers for the eigenvectors ! of a real symmetric or complex Hermitian matrix or for the left or ! right singular vectors of a general m-by-n matrix. The reciprocal ! condition number is the 'gap' between the corresponding eigenvalue or ! singular value and the nearest other one. ! ! The bound on the error, measured by angle in radians, in the I-th ! computed vector is given by ! ! SLAMCH( 'E' ) * ( ANORM / SEP( I ) ) ! ! where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed ! to be smaller than SLAMCH( 'E' )*ANORM in order to limit the size of ! the error bound. ! ! SDISNA may also be used to compute error bounds for eigenvectors of ! the generalized symmetric definite eigenproblem. ! ! Arguments ! ========= ! ! JOB (input) CHARACTER*1 ! Specifies for which problem the reciprocal condition numbers ! should be computed: ! = 'E': the eigenvectors of a symmetric/Hermitian matrix; ! = 'L': the left singular vectors of a general matrix; ! = 'R': the right singular vectors of a general matrix. ! ! M (input) INTEGER ! The number of rows of the matrix. M >= 0. ! ! N (input) INTEGER ! If JOB = 'L' or 'R', the number of columns of the matrix, ! in which case N >= 0. Ignored if JOB = 'E'. ! ! D (input) REAL array, dimension (M) if JOB = 'E' ! dimension (min(M,N)) if JOB = 'L' or 'R' ! The eigenvalues (if JOB = 'E') or singular values (if JOB = ! 'L' or 'R') of the matrix, in either increasing or decreasing ! order. If singular values, they must be non-negative. ! ! SEP (output) REAL array, dimension (M) if JOB = 'E' ! dimension (min(M,N)) if JOB = 'L' or 'R' ! The reciprocal condition numbers of the vectors. ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: decr, eigen, incr, left, right, sing INTEGER :: i, k REAL :: anorm, eps, newgap, oldgap, safmin, thresh ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. External Subroutines .. EXTERNAL xerbla ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 eigen = lsame( job, 'E' ) left = lsame( job, 'L' ) right = lsame( job, 'R' ) sing = left .OR. right IF( eigen ) THEN k = m ELSE IF( sing ) THEN k = MIN( m, n ) END IF IF( .NOT.eigen .AND. .NOT.sing ) THEN info = -1 ELSE IF( m < 0 ) THEN info = -2 ELSE IF( k < 0 ) THEN info = -3 ELSE incr = .true. decr = .true. DO i = 1, k - 1 IF( incr ) incr = incr .AND. d( i ) <= d( i+1 ) IF( decr ) decr = decr .AND. d( i ) >= d( i+1 ) END DO IF( sing .AND. k > 0 ) THEN IF( incr ) incr = incr .AND. zero <= d( 1 ) IF( decr ) decr = decr .AND. d( k ) >= zero END IF IF( .NOT.( incr .OR. decr ) ) info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SDISNA', -info ) RETURN END IF ! ! Quick return if possible ! IF( k == 0 ) RETURN ! ! Compute reciprocal condition numbers ! IF( k == 1 ) THEN sep( 1 ) = slamch( 'O' ) ELSE oldgap = ABS( d( 2 )-d( 1 ) ) sep( 1 ) = oldgap DO i = 2, k - 1 newgap = ABS( d( i+1 )-d( i ) ) sep( i ) = MIN( oldgap, newgap ) oldgap = newgap END DO sep( k ) = oldgap END IF IF( sing ) THEN IF( ( left .AND. m > n ) .OR. ( right .AND. m < n ) ) THEN IF( incr ) sep( 1 ) = MIN( sep( 1 ), d( 1 ) ) IF( decr ) sep( k ) = MIN( sep( k ), d( k ) ) END IF END IF ! ! Ensure that reciprocal condition numbers are not less than ! threshold, in order to limit the size of the error bound ! eps = slamch( 'E' ) safmin = slamch( 'S' ) anorm = MAX( ABS( d( 1 ) ), ABS( d( k ) ) ) IF( anorm == zero ) THEN thresh = eps ELSE thresh = MAX( eps*anorm, safmin ) END IF DO i = 1, k sep( i ) = MAX( sep( i ), thresh ) END DO ! RETURN ! ! End of SDISNA ! END SUBROUTINE sdisna REAL FUNCTION second( ) ! ! -- 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 ! ! Purpose ! ======= ! ! SECOND returns the user time for a process in seconds. ! This version gets the time from the system function ETIME. ! ! ===================================================================== ! ! .. Local Scalars .. REAL :: t1 ! .. ! .. Local Arrays .. REAL :: tarray( 2 ) ! .. ! .. External Functions .. REAL :: etime EXTERNAL etime ! .. ! .. Executable Statements .. ! t1 = etime( tarray ) second = tarray( 1 ) RETURN ! ! End of SECOND ! END FUNCTION second SUBROUTINE sgbbrd( vect, m, n, ncc, kl, ku, ab, ldab, d, e, q, & ldq, pt, ldpt, 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 (LEN=1), INTENT(IN) :: vect INTEGER, INTENT(IN OUT) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: ncc INTEGER, INTENT(IN) :: kl INTEGER, INTENT(IN OUT) :: ku REAL, INTENT(OUT) :: ab( ldab, * ) INTEGER, INTENT(IN) :: ldab REAL, INTENT(OUT) :: d( * ) REAL, INTENT(OUT) :: e( * ) REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq REAL, INTENT(IN OUT) :: pt( ldpt, * ) INTEGER, INTENT(IN OUT) :: ldpt REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGBBRD reduces a real general m-by-n band matrix A to upper ! bidiagonal form B by an orthogonal transformation: Q' * A * P = B. ! ! The routine computes B, and optionally forms Q or P', or computes ! Q'*C for a given matrix C. ! ! Arguments ! ========= ! ! VECT (input) CHARACTER*1 ! Specifies whether or not the matrices Q and P' are to be ! formed. ! = 'N': do not form Q or P'; ! = 'Q': form Q only; ! = 'P': form P' only; ! = 'B': form both. ! ! 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. ! ! NCC (input) INTEGER ! The number of columns of the matrix C. NCC >= 0. ! ! KL (input) INTEGER ! The number of subdiagonals of the matrix A. KL >= 0. ! ! KU (input) INTEGER ! The number of superdiagonals of the matrix A. KU >= 0. ! ! AB (input/output) REAL array, dimension (LDAB,N) ! On entry, the m-by-n band matrix A, stored in rows 1 to ! KL+KU+1. The j-th column of A is stored in the j-th column of ! the array AB as follows: ! AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). ! On exit, A is overwritten by values generated during the ! reduction. ! ! LDAB (input) INTEGER ! The leading dimension of the array A. LDAB >= KL+KU+1. ! ! D (output) REAL array, dimension (min(M,N)) ! The diagonal elements of the bidiagonal matrix B. ! ! E (output) REAL array, dimension (min(M,N)-1) ! The superdiagonal elements of the bidiagonal matrix B. ! ! Q (output) REAL array, dimension (LDQ,M) ! If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q. ! If VECT = 'N' or 'P', the array Q is not referenced. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. ! LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. ! ! PT (output) REAL array, dimension (LDPT,N) ! If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'. ! If VECT = 'N' or 'Q', the array PT is not referenced. ! ! LDPT (input) INTEGER ! The leading dimension of the array PT. ! LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. ! ! C (input/output) REAL array, dimension (LDC,NCC) ! On entry, an m-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,M) if NCC > 0; LDC >= 1 if NCC = 0. ! ! WORK (workspace) REAL array, dimension (2*max(M,N)) ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: wantb, wantc, wantpt, wantq INTEGER :: i, inca, j, j1, j2, kb, kb1, kk, klm, klu1, & kun, l, minmn, ml, ml0, mn, mu, mu0, nr, nrt REAL :: ra, rb, rc, rs ! .. ! .. External Subroutines .. EXTERNAL slargv, slartg, slartv, slaset, srot, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Executable Statements .. ! ! Test the input parameters ! wantb = lsame( vect, 'B' ) wantq = lsame( vect, 'Q' ) .OR. wantb wantpt = lsame( vect, 'P' ) .OR. wantb wantc = ncc > 0 klu1 = kl + ku + 1 info = 0 IF( .NOT.wantq .AND. .NOT.wantpt .AND. .NOT.lsame( vect, 'N' ) ) THEN info = -1 ELSE IF( m < 0 ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( ncc < 0 ) THEN info = -4 ELSE IF( kl < 0 ) THEN info = -5 ELSE IF( ku < 0 ) THEN info = -6 ELSE IF( ldab < klu1 ) THEN info = -8 ELSE IF( ldq < 1 .OR. wantq .AND. ldq < MAX( 1, m ) ) THEN info = -12 ELSE IF( ldpt < 1 .OR. wantpt .AND. ldpt < MAX( 1, n ) ) THEN info = -14 ELSE IF( ldc < 1 .OR. wantc .AND. ldc < MAX( 1, m ) ) THEN info = -16 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGBBRD', -info ) RETURN END IF ! ! Initialize Q and P' to the unit matrix, if needed ! IF( wantq ) CALL slaset( 'Full', m, m, zero, one, q, ldq ) IF( wantpt ) CALL slaset( 'Full', n, n, zero, one, pt, ldpt ) ! ! Quick return if possible. ! IF( m == 0 .OR. n == 0 ) RETURN ! minmn = MIN( m, n ) ! IF( kl+ku > 1 ) THEN ! ! Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce ! first to lower bidiagonal form and then transform to upper ! bidiagonal ! IF( ku > 0 ) THEN ml0 = 1 mu0 = 2 ELSE ml0 = 2 mu0 = 1 END IF ! ! Wherever possible, plane rotations are generated and applied in ! vector operations of length NR over the index set J1:J2:KLU1. ! ! The sines of the plane rotations are stored in WORK(1:max(m,n)) ! and the cosines in WORK(max(m,n)+1:2*max(m,n)). ! mn = MAX( m, n ) klm = MIN( m-1, kl ) kun = MIN( n-1, ku ) kb = klm + kun kb1 = kb + 1 inca = kb1*ldab nr = 0 j1 = klm + 2 j2 = 1 - kun ! DO i = 1, minmn ! ! Reduce i-th column and i-th row of matrix to bidiagonal form ! ml = klm + 1 mu = kun + 1 DO kk = 1, kb j1 = j1 + kb j2 = j2 + kb ! ! generate plane rotations to annihilate nonzero elements ! which have been created below the band ! IF( nr > 0 ) CALL slargv( nr, ab( klu1, j1-klm-1 ), inca, & work( j1 ), kb1, work( mn+j1 ), kb1 ) ! ! apply plane rotations from the left ! DO l = 1, kb IF( j2-klm+l-1 > n ) THEN nrt = nr - 1 ELSE nrt = nr END IF IF( nrt > 0 ) CALL slartv( nrt, ab( klu1-l, j1-klm+l-1 ), inca, & ab( klu1-l+1, j1-klm+l-1 ), inca, work( mn+j1 ), work( j1 ), kb1 ) END DO ! IF( ml > ml0 ) THEN IF( ml <= m-i+1 ) THEN ! ! generate plane rotation to annihilate a(i+ml-1,i) ! within the band, and apply rotation from the left ! CALL slartg( ab( ku+ml-1, i ), ab( ku+ml, i ), & work( mn+i+ml-1 ), work( i+ml-1 ), ra ) ab( ku+ml-1, i ) = ra IF( i < n ) CALL srot( MIN( ku+ml-2, n-i ), & ab( ku+ml-2, i+1 ), ldab-1, ab( ku+ml-1, i+1 ), ldab-1, & work( mn+i+ml-1 ), work( i+ml-1 ) ) END IF nr = nr + 1 j1 = j1 - kb1 END IF ! IF( wantq ) THEN ! ! accumulate product of plane rotations in Q ! DO j = j1, j2, kb1 CALL srot( m, q( 1, j-1 ), 1, q( 1, j ), 1, & work( mn+j ), work( j ) ) END DO END IF ! IF( wantc ) THEN ! ! apply plane rotations to C ! DO j = j1, j2, kb1 CALL srot( ncc, c( j-1, 1 ), ldc, c( j, 1 ), ldc, & work( mn+j ), work( j ) ) END DO END IF ! IF( j2+kun > n ) THEN ! ! adjust J2 to keep within the bounds of the matrix ! nr = nr - 1 j2 = j2 - kb1 END IF ! DO j = j1, j2, kb1 ! ! create nonzero element a(j-1,j+ku) above the band ! and store it in WORK(n+1:2*n) ! work( j+kun ) = work( j )*ab( 1, j+kun ) ab( 1, j+kun ) = work( mn+j )*ab( 1, j+kun ) END DO ! ! generate plane rotations to annihilate nonzero elements ! which have been generated above the band ! IF( nr > 0 ) CALL slargv( nr, ab( 1, j1+kun-1 ), inca, & work( j1+kun ), kb1, work( mn+j1+kun ), kb1 ) ! ! apply plane rotations from the right ! DO l = 1, kb IF( j2+l-1 > m ) THEN nrt = nr - 1 ELSE nrt = nr END IF IF( nrt > 0 ) CALL slartv( nrt, ab( l+1, j1+kun-1 ), inca, & ab( l, j1+kun ), inca, work( mn+j1+kun ), work( j1+kun ), & kb1 ) END DO ! IF( ml == ml0 .AND. mu > mu0 ) THEN IF( mu <= n-i+1 ) THEN ! ! generate plane rotation to annihilate a(i,i+mu-1) ! within the band, and apply rotation from the right ! CALL slartg( ab( ku-mu+3, i+mu-2 ), ab( ku-mu+2, i+mu-1 ), & work( mn+i+mu-1 ), work( i+mu-1 ), ra ) ab( ku-mu+3, i+mu-2 ) = ra CALL srot( MIN( kl+mu-2, m-i ), ab( ku-mu+4, i+mu-2 ), 1, & ab( ku-mu+3, i+mu-1 ), 1, work( mn+i+mu-1 ), work( i+mu-1 ) ) END IF nr = nr + 1 j1 = j1 - kb1 END IF ! IF( wantpt ) THEN ! ! accumulate product of plane rotations in P' ! DO j = j1, j2, kb1 CALL srot( n, pt( j+kun-1, 1 ), ldpt, & pt( j+kun, 1 ), ldpt, work( mn+j+kun ), work( j+kun ) ) END DO END IF ! IF( j2+kb > m ) THEN ! ! adjust J2 to keep within the bounds of the matrix ! nr = nr - 1 j2 = j2 - kb1 END IF ! DO j = j1, j2, kb1 ! ! create nonzero element a(j+kl+ku,j+ku-1) below the ! band and store it in WORK(1:n) ! work( j+kb ) = work( j+kun )*ab( klu1, j+kun ) ab( klu1, j+kun ) = work( mn+j+kun )*ab( klu1, j+kun ) END DO ! IF( ml > ml0 ) THEN ml = ml - 1 ELSE mu = mu - 1 END IF END DO END DO END IF ! IF( ku == 0 .AND. kl > 0 ) THEN ! ! A has been reduced to lower bidiagonal form ! ! Transform lower bidiagonal form to upper bidiagonal by applying ! plane rotations from the left, storing diagonal elements in D ! and off-diagonal elements in E ! DO i = 1, MIN( m-1, n ) CALL slartg( ab( 1, i ), ab( 2, i ), rc, rs, ra ) d( i ) = ra IF( i < n ) THEN e( i ) = rs*ab( 1, i+1 ) ab( 1, i+1 ) = rc*ab( 1, i+1 ) END IF IF( wantq ) CALL srot( m, q( 1, i ), 1, q( 1, i+1 ), 1, rc, rs ) IF( wantc ) CALL srot( ncc, c( i, 1 ), ldc, c( i+1, 1 ), ldc, rc, & rs ) END DO IF( m <= n ) d( m ) = ab( 1, m ) ELSE IF( ku > 0 ) THEN ! ! A has been reduced to upper bidiagonal form ! IF( m < n ) THEN ! ! Annihilate a(m,m+1) by applying plane rotations from the ! right, storing diagonal elements in D and off-diagonal ! elements in E ! rb = ab( ku, m+1 ) DO i = m, 1, -1 CALL slartg( ab( ku+1, i ), rb, rc, rs, ra ) d( i ) = ra IF( i > 1 ) THEN rb = -rs*ab( ku, i ) e( i-1 ) = rc*ab( ku, i ) END IF IF( wantpt ) CALL srot( n, pt( i, 1 ), ldpt, pt( m+1, 1 ), ldpt, & rc, rs ) END DO ELSE ! ! Copy off-diagonal elements to E and diagonal elements to D ! DO i = 1, minmn - 1 e( i ) = ab( ku, i+1 ) END DO DO i = 1, minmn d( i ) = ab( ku+1, i ) END DO END IF ELSE ! ! A is diagonal. Set elements of E to zero and copy diagonal ! elements to D. ! DO i = 1, minmn - 1 e( i ) = zero END DO DO i = 1, minmn d( i ) = ab( 1, i ) END DO END IF RETURN ! ! End of SGBBRD ! END SUBROUTINE sgbbrd SUBROUTINE sgbcon( norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond, & 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 ! September 30, 1994 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: norm INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: kl INTEGER, INTENT(IN) :: ku REAL, INTENT(IN) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab INTEGER, INTENT(IN) :: ipiv( * ) REAL, INTENT(IN) :: anorm REAL, INTENT(OUT) :: rcond REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGBCON estimates the reciprocal of the condition number of a real ! general band matrix A, in either the 1-norm or the infinity-norm, ! using the LU factorization computed by SGBTRF. ! ! An estimate is obtained for norm(inv(A)), and the reciprocal of the ! condition number is computed as ! RCOND = 1 / ( norm(A) * norm(inv(A)) ). ! ! Arguments ! ========= ! ! NORM (input) CHARACTER*1 ! Specifies whether the 1-norm condition number or the ! infinity-norm condition number is required: ! = '1' or 'O': 1-norm; ! = 'I': Infinity-norm. ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! KL (input) INTEGER ! The number of subdiagonals within the band of A. KL >= 0. ! ! KU (input) INTEGER ! The number of superdiagonals within the band of A. KU >= 0. ! ! AB (input) REAL array, dimension (LDAB,N) ! Details of the LU factorization of the band matrix A, as ! computed by SGBTRF. U is stored as an upper triangular band ! matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and ! the multipliers used during the factorization are stored in ! rows KL+KU+2 to 2*KL+KU+1. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= 2*KL+KU+1. ! ! IPIV (input) INTEGER array, dimension (N) ! The pivot indices; for 1 <= i <= N, row i of the matrix was ! interchanged with row IPIV(i). ! ! ANORM (input) REAL ! If NORM = '1' or 'O', the 1-norm of the original matrix A. ! If NORM = 'I', the infinity-norm of the original matrix A. ! ! RCOND (output) REAL ! The reciprocal of the condition number of the matrix A, ! computed as RCOND = 1/(norm(A) * norm(inv(A))). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lnoti, onenrm CHARACTER (LEN=1) :: normin INTEGER :: ix, j, jp, kase, kase1, kd, lm REAL :: ainvnm, scale, smlnum, t ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: isamax REAL :: sdot, slamch EXTERNAL lsame, isamax, sdot, slamch ! .. ! .. External Subroutines .. EXTERNAL saxpy, slacon, slatbs, srscl, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 onenrm = norm == '1' .OR. lsame( norm, 'O' ) IF( .NOT.onenrm .AND. .NOT.lsame( norm, 'I' ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( kl < 0 ) THEN info = -3 ELSE IF( ku < 0 ) THEN info = -4 ELSE IF( ldab < 2*kl+ku+1 ) THEN info = -6 ELSE IF( anorm < zero ) THEN info = -8 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGBCON', -info ) RETURN END IF ! ! Quick return if possible ! rcond = zero IF( n == 0 ) THEN rcond = one RETURN ELSE IF( anorm == zero ) THEN RETURN END IF ! smlnum = slamch( 'Safe minimum' ) ! ! Estimate the norm of inv(A). ! ainvnm = zero normin = 'N' IF( onenrm ) THEN kase1 = 1 ELSE kase1 = 2 END IF kd = kl + ku + 1 lnoti = kl > 0 kase = 0 10 CONTINUE CALL slacon( n, work( n+1 ), work, iwork, ainvnm, kase ) IF( kase /= 0 ) THEN IF( kase == kase1 ) THEN ! ! Multiply by inv(L). ! IF( lnoti ) THEN DO j = 1, n - 1 lm = MIN( kl, n-j ) jp = ipiv( j ) t = work( jp ) IF( jp /= j ) THEN work( jp ) = work( j ) work( j ) = t END IF CALL saxpy( lm, -t, ab( kd+1, j ), 1, work( j+1 ), 1 ) END DO END IF ! ! Multiply by inv(U). ! CALL slatbs( 'Upper', 'No transpose', 'Non-unit', normin, n, & kl+ku, ab, ldab, work, scale, work( 2*n+1 ), info ) ELSE ! ! Multiply by inv(U'). ! CALL slatbs( 'Upper', 'Transpose', 'Non-unit', normin, n, & kl+ku, ab, ldab, work, scale, work( 2*n+1 ), info ) ! ! Multiply by inv(L'). ! IF( lnoti ) THEN DO j = n - 1, 1, -1 lm = MIN( kl, n-j ) work( j ) = work( j ) - sdot( lm, ab( kd+1, j ), 1, work( j+1 ), 1 ) jp = ipiv( j ) IF( jp /= j ) THEN t = work( jp ) work( jp ) = work( j ) work( j ) = t END IF END DO END IF END IF ! ! Divide X by 1/SCALE if doing so will not cause overflow. ! normin = 'Y' IF( scale /= one ) THEN ix = isamax( n, work, 1 ) IF( scale < ABS( work( ix ) )*smlnum .OR. scale == zero ) GO TO 40 CALL srscl( n, scale, work, 1 ) END IF GO TO 10 END IF ! ! Compute the estimate of the reciprocal condition number. ! IF( ainvnm /= zero ) rcond = ( one / ainvnm ) / anorm ! 40 CONTINUE RETURN ! ! End of SGBCON ! END SUBROUTINE sgbcon SUBROUTINE sgbequ( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: kl INTEGER, INTENT(IN) :: ku REAL, INTENT(IN) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(OUT) :: r( * ) REAL, INTENT(OUT) :: c( * ) REAL, INTENT(OUT) :: rowcnd REAL, INTENT(OUT) :: colcnd REAL, INTENT(OUT) :: amax INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGBEQU computes row and column scalings intended to equilibrate an ! M-by-N band matrix A and reduce its condition number. R returns the ! row scale factors and C the column scale factors, chosen to try to ! make the largest element in each row and column of the matrix B with ! elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. ! ! R(i) and C(j) are restricted to be between SMLNUM = smallest safe ! number and BIGNUM = largest safe number. Use of these scaling ! factors is not guaranteed to reduce the condition number of A but ! works well in practice. ! ! 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. ! ! KL (input) INTEGER ! The number of subdiagonals within the band of A. KL >= 0. ! ! KU (input) INTEGER ! The number of superdiagonals within the band of A. KU >= 0. ! ! AB (input) REAL array, dimension (LDAB,N) ! The band matrix A, stored in rows 1 to KL+KU+1. The j-th ! column of A is stored in the j-th column of the array AB as ! follows: ! AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KL+KU+1. ! ! R (output) REAL array, dimension (M) ! If INFO = 0, or INFO > M, R contains the row scale factors ! for A. ! ! C (output) REAL array, dimension (N) ! If INFO = 0, C contains the column scale factors for A. ! ! ROWCND (output) REAL ! If INFO = 0 or INFO > M, ROWCND contains the ratio of the ! smallest R(i) to the largest R(i). If ROWCND >= 0.1 and ! AMAX is neither too large nor too small, it is not worth ! scaling by R. ! ! COLCND (output) REAL ! If INFO = 0, COLCND contains the ratio of the smallest ! C(i) to the largest C(i). If COLCND >= 0.1, it is not ! worth scaling by C. ! ! AMAX (output) REAL ! Absolute value of largest matrix element. If AMAX is very ! close to overflow or very close to underflow, the matrix ! should be scaled. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! > 0: if INFO = i, and i is ! <= M: the i-th row of A is exactly zero ! > M: the (i-M)-th column of A is exactly zero ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j, kd REAL :: bignum, rcmax, rcmin, smlnum ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. External Subroutines .. EXTERNAL xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( kl < 0 ) THEN info = -3 ELSE IF( ku < 0 ) THEN info = -4 ELSE IF( ldab < kl+ku+1 ) THEN info = -6 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGBEQU', -info ) RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 ) THEN rowcnd = one colcnd = one amax = zero RETURN END IF ! ! Get machine constants. ! smlnum = slamch( 'S' ) bignum = one / smlnum ! ! Compute row scale factors. ! DO i = 1, m r( i ) = zero END DO ! ! Find the maximum element in each row. ! kd = ku + 1 DO j = 1, n DO i = MAX( j-ku, 1 ), MIN( j+kl, m ) r( i ) = MAX( r( i ), ABS( ab( kd+i-j, j ) ) ) END DO END DO ! ! Find the maximum and minimum scale factors. ! rcmin = bignum rcmax = zero DO i = 1, m rcmax = MAX( rcmax, r( i ) ) rcmin = MIN( rcmin, r( i ) ) END DO amax = rcmax ! IF( rcmin == zero ) THEN ! ! Find the first zero scale factor and return an error code. ! DO i = 1, m IF( r( i ) == zero ) THEN info = i RETURN END IF END DO ELSE ! ! Invert the scale factors. ! DO i = 1, m r( i ) = one / MIN( MAX( r( i ), smlnum ), bignum ) END DO ! ! Compute ROWCND = min(R(I)) / max(R(I)) ! rowcnd = MAX( rcmin, smlnum ) / MIN( rcmax, bignum ) END IF ! ! Compute column scale factors ! DO j = 1, n c( j ) = zero END DO ! ! Find the maximum element in each column, ! assuming the row scaling computed above. ! kd = ku + 1 DO j = 1, n DO i = MAX( j-ku, 1 ), MIN( j+kl, m ) c( j ) = MAX( c( j ), ABS( ab( kd+i-j, j ) )*r( i ) ) END DO END DO ! ! Find the maximum and minimum scale factors. ! rcmin = bignum rcmax = zero DO j = 1, n rcmin = MIN( rcmin, c( j ) ) rcmax = MAX( rcmax, c( j ) ) END DO ! IF( rcmin == zero ) THEN ! ! Find the first zero scale factor and return an error code. ! DO j = 1, n IF( c( j ) == zero ) THEN info = m + j RETURN END IF END DO ELSE ! ! Invert the scale factors. ! DO j = 1, n c( j ) = one / MIN( MAX( c( j ), smlnum ), bignum ) END DO ! ! Compute COLCND = min(C(J)) / max(C(J)) ! colcnd = MAX( rcmin, smlnum ) / MIN( rcmax, bignum ) END IF ! RETURN ! ! End of SGBEQU ! END SUBROUTINE sgbequ SUBROUTINE sgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, & ipiv, b, ldb, x, ldx, ferr, berr, 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 ! September 30, 1994 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: kl INTEGER, INTENT(IN) :: ku INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(IN OUT) :: afb( ldafb, * ) INTEGER, INTENT(IN OUT) :: ldafb INTEGER, INTENT(IN OUT) :: ipiv( * ) REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: ferr( * ) REAL, INTENT(OUT) :: berr( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGBRFS improves the computed solution to a system of linear ! equations when the coefficient matrix is banded, and provides ! error bounds and backward error estimates for the solution. ! ! 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 = Transpose) ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! KL (input) INTEGER ! The number of subdiagonals within the band of A. KL >= 0. ! ! KU (input) INTEGER ! The number of superdiagonals within the band of A. KU >= 0. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of columns ! of the matrices B and X. NRHS >= 0. ! ! AB (input) REAL array, dimension (LDAB,N) ! The original band matrix A, stored in rows 1 to KL+KU+1. ! The j-th column of A is stored in the j-th column of the ! array AB as follows: ! AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KL+KU+1. ! ! AFB (input) REAL array, dimension (LDAFB,N) ! Details of the LU factorization of the band matrix A, as ! computed by SGBTRF. U is stored as an upper triangular band ! matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and ! the multipliers used during the factorization are stored in ! rows KL+KU+2 to 2*KL+KU+1. ! ! LDAFB (input) INTEGER ! The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. ! ! IPIV (input) INTEGER array, dimension (N) ! The pivot indices from SGBTRF; for 1<=i<=N, row i of the ! matrix was interchanged with row IPIV(i). ! ! B (input) REAL array, dimension (LDB,NRHS) ! The right hand side matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (input/output) REAL array, dimension (LDX,NRHS) ! On entry, the solution matrix X, as computed by SGBTRS. ! On exit, the improved solution matrix X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! Internal Parameters ! =================== ! ! ITMAX is the maximum number of steps of iterative refinement. ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: itmax = 5 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 REAL, PARAMETER :: three = 3.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: notran CHARACTER (LEN=1) :: transt INTEGER :: count, i, j, k, kase, kk, nz REAL :: eps, lstres, s, safe1, safe2, safmin, xk ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, sgbmv, sgbtrs, slacon, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. 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 < 0 ) THEN info = -2 ELSE IF( kl < 0 ) THEN info = -3 ELSE IF( ku < 0 ) THEN info = -4 ELSE IF( nrhs < 0 ) THEN info = -5 ELSE IF( ldab < kl+ku+1 ) THEN info = -7 ELSE IF( ldafb < 2*kl+ku+1 ) THEN info = -9 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -12 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -14 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGBRFS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) THEN DO j = 1, nrhs ferr( j ) = zero berr( j ) = zero END DO RETURN END IF ! IF( notran ) THEN transt = 'T' ELSE transt = 'N' END IF ! ! NZ = maximum number of nonzero elements in each row of A, plus 1 ! nz = MIN( kl+ku+2, n+1 ) eps = slamch( 'Epsilon' ) safmin = slamch( 'Safe minimum' ) safe1 = nz*safmin safe2 = safe1 / eps ! ! Do for each right hand side ! DO j = 1, nrhs ! count = 1 lstres = three 20 CONTINUE ! ! Loop until stopping criterion is satisfied. ! ! Compute residual R = B - op(A) * X, ! where op(A) = A, A**T, or A**H, depending on TRANS. ! CALL scopy( n, b( 1, j ), 1, work( n+1 ), 1 ) CALL sgbmv( trans, n, n, kl, ku, -one, ab, ldab, x( 1, j ), 1, & one, work( n+1 ), 1 ) ! ! Compute componentwise relative backward error from formula ! ! max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) ! ! where abs(Z) is the componentwise absolute value of the matrix ! or vector Z. If the i-th component of the denominator is less ! than SAFE2, then SAFE1 is added to the i-th components of the ! numerator and denominator before dividing. ! DO i = 1, n work( i ) = ABS( b( i, j ) ) END DO ! ! Compute abs(op(A))*abs(X) + abs(B). ! IF( notran ) THEN DO k = 1, n kk = ku + 1 - k xk = ABS( x( k, j ) ) DO i = MAX( 1, k-ku ), MIN( n, k+kl ) work( i ) = work( i ) + ABS( ab( kk+i, k ) )*xk END DO END DO ELSE DO k = 1, n s = zero kk = ku + 1 - k DO i = MAX( 1, k-ku ), MIN( n, k+kl ) s = s + ABS( ab( kk+i, k ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + s END DO END IF s = zero DO i = 1, n IF( work( i ) > safe2 ) THEN s = MAX( s, ABS( work( n+i ) ) / work( i ) ) ELSE s = MAX( s, ( ABS( work( n+i ) )+safe1 ) / ( work( i )+safe1 ) ) END IF END DO berr( j ) = s ! ! Test stopping criterion. Continue iterating if ! 1) The residual BERR(J) is larger than machine epsilon, and ! 2) BERR(J) decreased by at least a factor of 2 during the ! last iteration, and ! 3) At most ITMAX iterations tried. ! IF( berr( j ) > eps .AND. two*berr( j ) <= lstres .AND. & count <= itmax ) THEN ! ! Update solution and try again. ! CALL sgbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv, work( n+1 ), n, info ) CALL saxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 GO TO 20 END IF ! ! Bound error from formula ! ! norm(X - XTRUE) / norm(X) .le. FERR = ! norm( abs(inv(op(A)))* ! ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) ! ! where ! norm(Z) is the magnitude of the largest component of Z ! inv(op(A)) is the inverse of op(A) ! abs(Z) is the componentwise absolute value of the matrix or ! vector Z ! NZ is the maximum number of nonzeros in any row of A, plus 1 ! EPS is machine epsilon ! ! The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) ! is incremented by SAFE1 if the i-th component of ! abs(op(A))*abs(X) + abs(B) is less than SAFE2. ! ! Use SLACON to estimate the infinity-norm of the matrix ! inv(op(A)) * diag(W), ! where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) ! DO i = 1, n IF( work( i ) > safe2 ) THEN work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) ELSE work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) + safe1 END IF END DO ! kase = 0 100 CONTINUE CALL slacon( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ), kase ) IF( kase /= 0 ) THEN IF( kase == 1 ) THEN ! ! Multiply by diag(W)*inv(op(A)**T). ! CALL sgbtrs( transt, n, kl, ku, 1, afb, ldafb, ipiv, & work( n+1 ), n, info ) DO i = 1, n work( n+i ) = work( n+i )*work( i ) END DO ELSE ! ! Multiply by inv(op(A))*diag(W). ! DO i = 1, n work( n+i ) = work( n+i )*work( i ) END DO CALL sgbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv, & work( n+1 ), n, info ) END IF GO TO 100 END IF ! ! Normalize error. ! lstres = zero DO i = 1, n lstres = MAX( lstres, ABS( x( i, j ) ) ) END DO IF( lstres /= zero ) ferr( j ) = ferr( j ) / lstres ! END DO ! RETURN ! ! End of SGBRFS ! END SUBROUTINE sgbrfs SUBROUTINE sgbsv( n, kl, ku, nrhs, ab, ldab, 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, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: kl INTEGER, INTENT(IN OUT) :: ku INTEGER, INTENT(IN OUT) :: nrhs REAL, INTENT(IN OUT) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab INTEGER, INTENT(IN OUT) :: ipiv( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGBSV computes the solution to a real system of linear equations ! A * X = B, where A is a band matrix of order N with KL subdiagonals ! and KU superdiagonals, 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 = L * U, where L is a product of permutation ! and unit lower triangular matrices with KL subdiagonals, and U is ! upper triangular with KL+KU superdiagonals. 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. ! ! KL (input) INTEGER ! The number of subdiagonals within the band of A. KL >= 0. ! ! KU (input) INTEGER ! The number of superdiagonals within the band of A. KU >= 0. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of columns ! of the matrix B. NRHS >= 0. ! ! AB (input/output) REAL array, dimension (LDAB,N) ! On entry, the matrix A in band storage, in rows KL+1 to ! 2*KL+KU+1; rows 1 to KL of the array need not be set. ! The j-th column of A is stored in the j-th column of the ! array AB as follows: ! AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL) ! On exit, details of the factorization: U is stored as an ! upper triangular band matrix with KL+KU superdiagonals in ! rows 1 to KL+KU+1, and the multipliers used during the ! factorization are stored in rows KL+KU+2 to 2*KL+KU+1. ! See below for further details. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= 2*KL+KU+1. ! ! 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) REAL 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, U(i,i) is exactly zero. The factorization ! has been completed, but the factor U is exactly ! singular, and the solution has not been computed. ! ! Further Details ! =============== ! ! The band storage scheme is illustrated by the following example, when ! M = N = 6, KL = 2, KU = 1: ! ! On entry: On exit: ! ! * * * + + + * * * u14 u25 u36 ! * * + + + + * * u13 u24 u35 u46 ! * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 ! a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 ! a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * ! a31 a42 a53 a64 * * m31 m42 m53 m64 * * ! ! Array elements marked * are not used by the routine; elements marked ! + need not be set on entry, but are required by the routine to store ! elements of U because of fill-in resulting from the row interchanges. ! ! ===================================================================== ! ! .. External Subroutines .. EXTERNAL sgbtrf, sgbtrs, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 IF( n < 0 ) THEN info = -1 ELSE IF( kl < 0 ) THEN info = -2 ELSE IF( ku < 0 ) THEN info = -3 ELSE IF( nrhs < 0 ) THEN info = -4 ELSE IF( ldab < 2*kl+ku+1 ) THEN info = -6 ELSE IF( ldb < MAX( n, 1 ) ) THEN info = -9 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGBSV ', -info ) RETURN END IF ! ! Compute the LU factorization of the band matrix A. ! CALL sgbtrf( n, n, kl, ku, ab, ldab, ipiv, info ) IF( info == 0 ) THEN ! ! Solve the system A*X = B, overwriting B with X. ! CALL sgbtrs( 'No transpose', n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info ) END IF RETURN ! ! End of SGBSV ! END SUBROUTINE sgbsv SUBROUTINE sgbsvx( fact, trans, n, kl, ku, nrhs, ab, ldab, afb, & ldafb, ipiv, equed, r, c, b, ldb, x, ldx, & rcond, ferr, berr, work, iwork, 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 (LEN=1), INTENT(IN) :: fact CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: kl INTEGER, INTENT(IN) :: ku INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: ab( ldab, * ) INTEGER, INTENT(IN) :: ldab REAL, INTENT(IN) :: afb( ldafb, * ) INTEGER, INTENT(IN) :: ldafb INTEGER, INTENT(IN OUT) :: ipiv( * ) CHARACTER (LEN=1), INTENT(OUT) :: equed REAL, INTENT(IN) :: r( * ) REAL, INTENT(IN) :: c( * ) REAL, INTENT(OUT) :: b( ldb, * ) INTEGER, INTENT(IN) :: ldb REAL, INTENT(OUT) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: rcond REAL, INTENT(OUT) :: ferr( * ) REAL, INTENT(IN OUT) :: berr( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGBSVX uses the LU factorization to compute the solution to a real ! system of linear equations A * X = B, A**T * X = B, or A**H * X = B, ! where A is a band matrix of order N with KL subdiagonals and KU ! superdiagonals, and X and B are N-by-NRHS matrices. ! ! Error bounds on the solution and a condition estimate are also ! provided. ! ! Description ! =========== ! ! The following steps are performed by this subroutine: ! ! 1. If FACT = 'E', real scaling factors are computed to equilibrate ! the system: ! TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B ! TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B ! TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B ! Whether or not the system will be equilibrated depends on the ! scaling of the matrix A, but if equilibration is used, A is ! overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') ! or diag(C)*B (if TRANS = 'T' or 'C'). ! ! 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the ! matrix A (after equilibration if FACT = 'E') as ! A = L * U, ! where L is a product of permutation and unit lower triangular ! matrices with KL subdiagonals, and U is upper triangular with ! KL+KU superdiagonals. ! ! 3. If some U(i,i)=0, so that U is exactly singular, then the routine ! returns with INFO = i. Otherwise, the factored form of A is used ! to estimate the condition number of the matrix A. If the ! reciprocal of the condition number is less than machine precision, ! INFO = N+1 is returned as a warning, but the routine still goes on ! to solve for X and compute error bounds as described below. ! ! 4. The system of equations is solved for X using the factored form ! of A. ! ! 5. Iterative refinement is applied to improve the computed solution ! matrix and calculate error bounds and backward error estimates ! for it. ! ! 6. If equilibration was used, the matrix X is premultiplied by ! diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so ! that it solves the original system before equilibration. ! ! Arguments ! ========= ! ! FACT (input) CHARACTER*1 ! Specifies whether or not the factored form of the matrix A is ! supplied on entry, and if not, whether the matrix A should be ! equilibrated before it is factored. ! = 'F': On entry, AFB and IPIV contain the factored form of ! A. If EQUED is not 'N', the matrix A has been ! equilibrated with scaling factors given by R and C. ! AB, AFB, and IPIV are not modified. ! = 'N': The matrix A will be copied to AFB and factored. ! = 'E': The matrix A will be equilibrated if necessary, then ! copied to AFB and factored. ! ! 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 (Transpose) ! ! N (input) INTEGER ! The number of linear equations, i.e., the order of the ! matrix A. N >= 0. ! ! KL (input) INTEGER ! The number of subdiagonals within the band of A. KL >= 0. ! ! KU (input) INTEGER ! The number of superdiagonals within the band of A. KU >= 0. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of columns ! of the matrices B and X. NRHS >= 0. ! ! AB (input/output) REAL array, dimension (LDAB,N) ! On entry, the matrix A in band storage, in rows 1 to KL+KU+1. ! The j-th column of A is stored in the j-th column of the ! array AB as follows: ! AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl) ! ! If FACT = 'F' and EQUED is not 'N', then A must have been ! equilibrated by the scaling factors in R and/or C. AB is not ! modified if FACT = 'F' or 'N', or if FACT = 'E' and ! EQUED = 'N' on exit. ! ! On exit, if EQUED .ne. 'N', A is scaled as follows: ! EQUED = 'R': A := diag(R) * A ! EQUED = 'C': A := A * diag(C) ! EQUED = 'B': A := diag(R) * A * diag(C). ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KL+KU+1. ! ! AFB (input or output) REAL array, dimension (LDAFB,N) ! If FACT = 'F', then AFB is an input argument and on entry ! contains details of the LU factorization of the band matrix ! A, as computed by SGBTRF. U is stored as an upper triangular ! band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, ! and the multipliers used during the factorization are stored ! in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is ! the factored form of the equilibrated matrix A. ! ! If FACT = 'N', then AFB is an output argument and on exit ! returns details of the LU factorization of A. ! ! If FACT = 'E', then AFB is an output argument and on exit ! returns details of the LU factorization of the equilibrated ! matrix A (see the description of AB for the form of the ! equilibrated matrix). ! ! LDAFB (input) INTEGER ! The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. ! ! IPIV (input or output) INTEGER array, dimension (N) ! If FACT = 'F', then IPIV is an input argument and on entry ! contains the pivot indices from the factorization A = L*U ! as computed by SGBTRF; row i of the matrix was interchanged ! with row IPIV(i). ! ! If FACT = 'N', then IPIV is an output argument and on exit ! contains the pivot indices from the factorization A = L*U ! of the original matrix A. ! ! If FACT = 'E', then IPIV is an output argument and on exit ! contains the pivot indices from the factorization A = L*U ! of the equilibrated matrix A. ! ! EQUED (input or output) CHARACTER*1 ! Specifies the form of equilibration that was done. ! = 'N': No equilibration (always true if FACT = 'N'). ! = 'R': Row equilibration, i.e., A has been premultiplied by ! diag(R). ! = 'C': Column equilibration, i.e., A has been postmultiplied ! by diag(C). ! = 'B': Both row and column equilibration, i.e., A has been ! replaced by diag(R) * A * diag(C). ! EQUED is an input argument if FACT = 'F'; otherwise, it is an ! output argument. ! ! R (input or output) REAL array, dimension (N) ! The row scale factors for A. If EQUED = 'R' or 'B', A is ! multiplied on the left by diag(R); if EQUED = 'N' or 'C', R ! is not accessed. R is an input argument if FACT = 'F'; ! otherwise, R is an output argument. If FACT = 'F' and ! EQUED = 'R' or 'B', each element of R must be positive. ! ! C (input or output) REAL array, dimension (N) ! The column scale factors for A. If EQUED = 'C' or 'B', A is ! multiplied on the right by diag(C); if EQUED = 'N' or 'R', C ! is not accessed. C is an input argument if FACT = 'F'; ! otherwise, C is an output argument. If FACT = 'F' and ! EQUED = 'C' or 'B', each element of C must be positive. ! ! B (input/output) REAL array, dimension (LDB,NRHS) ! On entry, the right hand side matrix B. ! On exit, ! if EQUED = 'N', B is not modified; ! if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by ! diag(R)*B; ! if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is ! overwritten by diag(C)*B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (output) REAL array, dimension (LDX,NRHS) ! If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X ! to the original system of equations. Note that A and B are ! modified on exit if EQUED .ne. 'N', and the solution to the ! equilibrated system is inv(diag(C))*X if TRANS = 'N' and ! EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' ! and EQUED = 'R' or 'B'. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! RCOND (output) REAL ! The estimate of the reciprocal condition number of the matrix ! A after equilibration (if done). If RCOND is less than the ! machine precision (in particular, if RCOND = 0), the matrix ! is singular to working precision. This condition is ! indicated by a return code of INFO > 0. ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace/output) REAL array, dimension (3*N) ! On exit, WORK(1) contains the reciprocal pivot growth ! factor norm(A)/norm(U). The "max absolute element" norm is ! used. If WORK(1) is much less than 1, then the stability ! of the LU factorization of the (equilibrated) matrix A ! could be poor. This also means that the solution X, condition ! estimator RCOND, and forward error bound FERR could be ! unreliable. If factorization fails with 0 0: if INFO = i, and i is ! <= N: U(i,i) is exactly zero. The factorization ! has been completed, but the factor U is exactly ! singular, so the solution and error bounds ! could not be computed. RCOND = 0 is returned. ! = N+1: U is nonsingular, but RCOND is less than machine ! precision, meaning that the matrix is singular ! to working precision. Nevertheless, the ! solution and error bounds are computed because ! there are a number of situations where the ! computed solution can be more accurate than the ! value of RCOND would suggest. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: colequ, equil, nofact, notran, rowequ CHARACTER (LEN=1) :: norm INTEGER :: i, infequ, j, j1, j2 REAL :: amax, anorm, bignum, colcnd, rcmax, rcmin, rowcnd, rpvgrw, smlnum ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slangb, slantb EXTERNAL lsame, slamch, slangb, slantb ! .. ! .. External Subroutines .. EXTERNAL scopy, sgbcon, sgbequ, sgbrfs, sgbtrf, sgbtrs, & slacpy, slaqgb, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. Executable Statements .. ! info = 0 nofact = lsame( fact, 'N' ) equil = lsame( fact, 'E' ) notran = lsame( trans, 'N' ) IF( nofact .OR. equil ) THEN equed = 'N' rowequ = .false. colequ = .false. ELSE rowequ = lsame( equed, 'R' ) .OR. lsame( equed, 'B' ) colequ = lsame( equed, 'C' ) .OR. lsame( equed, 'B' ) smlnum = slamch( 'Safe minimum' ) bignum = one / smlnum END IF ! ! Test the input parameters. ! IF( .NOT.nofact .AND. .NOT.equil .AND. .NOT.lsame( fact, 'F' ) ) THEN info = -1 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT. & lsame( trans, 'C' ) ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( kl < 0 ) THEN info = -4 ELSE IF( ku < 0 ) THEN info = -5 ELSE IF( nrhs < 0 ) THEN info = -6 ELSE IF( ldab < kl+ku+1 ) THEN info = -8 ELSE IF( ldafb < 2*kl+ku+1 ) THEN info = -10 ELSE IF( lsame( fact, 'F' ) .AND. .NOT. & ( rowequ .OR. colequ .OR. lsame( equed, 'N' ) ) ) THEN info = -12 ELSE IF( rowequ ) THEN rcmin = bignum rcmax = zero DO j = 1, n rcmin = MIN( rcmin, r( j ) ) rcmax = MAX( rcmax, r( j ) ) END DO IF( rcmin <= zero ) THEN info = -13 ELSE IF( n > 0 ) THEN rowcnd = MAX( rcmin, smlnum ) / MIN( rcmax, bignum ) ELSE rowcnd = one END IF END IF IF( colequ .AND. info == 0 ) THEN rcmin = bignum rcmax = zero DO j = 1, n rcmin = MIN( rcmin, c( j ) ) rcmax = MAX( rcmax, c( j ) ) END DO IF( rcmin <= zero ) THEN info = -14 ELSE IF( n > 0 ) THEN colcnd = MAX( rcmin, smlnum ) / MIN( rcmax, bignum ) ELSE colcnd = one END IF END IF IF( info == 0 ) THEN IF( ldb < MAX( 1, n ) ) THEN info = -16 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -18 END IF END IF END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SGBSVX', -info ) RETURN END IF ! IF( equil ) THEN ! ! Compute row and column scalings to equilibrate the matrix A. ! CALL sgbequ( n, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, infequ ) IF( infequ == 0 ) THEN ! ! Equilibrate the matrix. ! CALL slaqgb( n, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, equed ) rowequ = lsame( equed, 'R' ) .OR. lsame( equed, 'B' ) colequ = lsame( equed, 'C' ) .OR. lsame( equed, 'B' ) END IF END IF ! ! Scale the right hand side. ! IF( notran ) THEN IF( rowequ ) THEN DO j = 1, nrhs DO i = 1, n b( i, j ) = r( i )*b( i, j ) END DO END DO END IF ELSE IF( colequ ) THEN DO j = 1, nrhs DO i = 1, n b( i, j ) = c( i )*b( i, j ) END DO END DO END IF ! IF( nofact .OR. equil ) THEN ! ! Compute the LU factorization of the band matrix A. ! DO j = 1, n j1 = MAX( j-ku, 1 ) j2 = MIN( j+kl, n ) CALL scopy( j2-j1+1, ab( ku+1-j+j1, j ), 1, afb( kl+ku+1-j+j1, j ), 1 ) END DO ! CALL sgbtrf( n, n, kl, ku, afb, ldafb, ipiv, info ) ! ! Return if INFO is non-zero. ! IF( info /= 0 ) THEN IF( info > 0 ) THEN ! ! Compute the reciprocal pivot growth factor of the ! leading rank-deficient INFO columns of A. ! anorm = zero DO j = 1, info DO i = MAX( ku+2-j, 1 ), & MIN( n+ku+1-j, kl+ku+1 ) anorm = MAX( anorm, ABS( ab( i, j ) ) ) END DO END DO rpvgrw = slantb( 'M', 'U', 'N', info, & MIN( info-1, kl+ku ), afb( MAX( 1, kl+ku+2-info ), 1 ), ldafb, work ) IF( rpvgrw == zero ) THEN rpvgrw = one ELSE rpvgrw = anorm / rpvgrw END IF work( 1 ) = rpvgrw rcond = zero END IF RETURN END IF END IF ! ! Compute the norm of the matrix A and the ! reciprocal pivot growth factor RPVGRW. ! IF( notran ) THEN norm = '1' ELSE norm = 'I' END IF anorm = slangb( norm, n, kl, ku, ab, ldab, work ) rpvgrw = slantb( 'M', 'U', 'N', n, kl+ku, afb, ldafb, work ) IF( rpvgrw == zero ) THEN rpvgrw = one ELSE rpvgrw = slangb( 'M', n, kl, ku, ab, ldab, work ) / rpvgrw END IF ! ! Compute the reciprocal of the condition number of A. ! CALL sgbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond, & work, iwork, info ) ! ! Set INFO = N+1 if the matrix is singular to working precision. ! IF( rcond < slamch( 'Epsilon' ) ) info = n + 1 ! ! Compute the solution matrix X. ! CALL slacpy( 'Full', n, nrhs, b, ldb, x, ldx ) CALL sgbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx, info ) ! ! Use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. ! CALL sgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, & b, ldb, x, ldx, ferr, berr, work, iwork, info ) ! ! Transform the solution matrix X to a solution of the original ! system. ! IF( notran ) THEN IF( colequ ) THEN DO j = 1, nrhs DO i = 1, n x( i, j ) = c( i )*x( i, j ) END DO END DO DO j = 1, nrhs ferr( j ) = ferr( j ) / colcnd END DO END IF ELSE IF( rowequ ) THEN DO j = 1, nrhs DO i = 1, n x( i, j ) = r( i )*x( i, j ) END DO END DO DO j = 1, nrhs ferr( j ) = ferr( j ) / rowcnd END DO END IF ! work( 1 ) = rpvgrw RETURN ! ! End of SGBSVX ! END SUBROUTINE sgbsvx SUBROUTINE sgbtf2( m, n, kl, ku, ab, ldab, ipiv, 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 .. INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: kl INTEGER, INTENT(IN) :: ku REAL, INTENT(OUT) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab INTEGER, INTENT(OUT) :: ipiv( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGBTF2 computes an LU factorization of a real m-by-n band matrix A ! using partial pivoting with row interchanges. ! ! This is the unblocked version of the algorithm, calling Level 2 BLAS. ! ! 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. ! ! KL (input) INTEGER ! The number of subdiagonals within the band of A. KL >= 0. ! ! KU (input) INTEGER ! The number of superdiagonals within the band of A. KU >= 0. ! ! AB (input/output) REAL array, dimension (LDAB,N) ! On entry, the matrix A in band storage, in rows KL+1 to ! 2*KL+KU+1; rows 1 to KL of the array need not be set. ! The j-th column of A is stored in the j-th column of the ! array AB as follows: ! AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) ! ! On exit, details of the factorization: U is stored as an ! upper triangular band matrix with KL+KU superdiagonals in ! rows 1 to KL+KU+1, and the multipliers used during the ! factorization are stored in rows KL+KU+2 to 2*KL+KU+1. ! See below for further details. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= 2*KL+KU+1. ! ! 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. ! ! Further Details ! =============== ! ! The band storage scheme is illustrated by the following example, when ! M = N = 6, KL = 2, KU = 1: ! ! On entry: On exit: ! ! * * * + + + * * * u14 u25 u36 ! * * + + + + * * u13 u24 u35 u46 ! * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 ! a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 ! a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * ! a31 a42 a53 a64 * * m31 m42 m53 m64 * * ! ! Array elements marked * are not used by the routine; elements marked ! + need not be set on entry, but are required by the routine to store ! elements of U, because of fill-in resulting from the row ! interchanges. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j, jp, ju, km, kv ! .. ! .. External Functions .. INTEGER :: isamax EXTERNAL isamax ! .. ! .. External Subroutines .. EXTERNAL sger, sscal, sswap, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! KV is the number of superdiagonals in the factor U, allowing for ! fill-in. ! kv = ku + kl ! ! Test the input parameters. ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( kl < 0 ) THEN info = -3 ELSE IF( ku < 0 ) THEN info = -4 ELSE IF( ldab < kl+kv+1 ) THEN info = -6 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGBTF2', -info ) RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 ) RETURN ! ! Gaussian elimination with partial pivoting ! ! Set fill-in elements in columns KU+2 to KV to zero. ! DO j = ku + 2, MIN( kv, n ) DO i = kv - j + 2, kl ab( i, j ) = zero END DO END DO ! ! JU is the index of the last column affected by the current stage ! of the factorization. ! ju = 1 ! DO j = 1, MIN( m, n ) ! ! Set fill-in elements in column J+KV to zero. ! IF( j+kv <= n ) THEN DO i = 1, kl ab( i, j+kv ) = zero END DO END IF ! ! Find pivot and test for singularity. KM is the number of ! subdiagonal elements in the current column. ! km = MIN( kl, m-j ) jp = isamax( km+1, ab( kv+1, j ), 1 ) ipiv( j ) = jp + j - 1 IF( ab( kv+jp, j ) /= zero ) THEN ju = MAX( ju, MIN( j+ku+jp-1, n ) ) ! ! Apply interchange to columns J to JU. ! IF( jp /= 1 ) CALL sswap( ju-j+1, ab( kv+jp, j ), ldab-1, & ab( kv+1, j ), ldab-1 ) ! IF( km > 0 ) THEN ! ! Compute multipliers. ! CALL sscal( km, one / ab( kv+1, j ), ab( kv+2, j ), 1 ) ! ! Update trailing submatrix within the band. ! IF( ju > j ) CALL sger( km, ju-j, -one, ab( kv+2, j ), 1, & ab( kv, j+1 ), ldab-1, ab( kv+1, j+1 ), ldab-1 ) END IF ELSE ! ! If pivot is zero, set INFO to the index of the pivot ! unless a zero pivot has already been found. ! IF( info == 0 ) info = j END IF END DO RETURN ! ! End of SGBTF2 ! END SUBROUTINE sgbtf2 SUBROUTINE sgbtrf( m, n, kl, ku, ab, ldab, ipiv, 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 .. INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: kl INTEGER, INTENT(IN) :: ku REAL, INTENT(OUT) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab INTEGER, INTENT(OUT) :: ipiv( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGBTRF computes an LU factorization of a real m-by-n band matrix A ! using partial pivoting with row interchanges. ! ! This is the blocked version of the algorithm, calling Level 3 BLAS. ! ! 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. ! ! KL (input) INTEGER ! The number of subdiagonals within the band of A. KL >= 0. ! ! KU (input) INTEGER ! The number of superdiagonals within the band of A. KU >= 0. ! ! AB (input/output) REAL array, dimension (LDAB,N) ! On entry, the matrix A in band storage, in rows KL+1 to ! 2*KL+KU+1; rows 1 to KL of the array need not be set. ! The j-th column of A is stored in the j-th column of the ! array AB as follows: ! AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) ! ! On exit, details of the factorization: U is stored as an ! upper triangular band matrix with KL+KU superdiagonals in ! rows 1 to KL+KU+1, and the multipliers used during the ! factorization are stored in rows KL+KU+2 to 2*KL+KU+1. ! See below for further details. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= 2*KL+KU+1. ! ! 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. ! ! Further Details ! =============== ! ! The band storage scheme is illustrated by the following example, when ! M = N = 6, KL = 2, KU = 1: ! ! On entry: On exit: ! ! * * * + + + * * * u14 u25 u36 ! * * + + + + * * u13 u24 u35 u46 ! * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 ! a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 ! a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * ! a31 a42 a53 a64 * * m31 m42 m53 m64 * * ! ! Array elements marked * are not used by the routine; elements marked ! + need not be set on entry, but are required by the routine to store ! elements of U because of fill-in resulting from the row interchanges. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 INTEGER, PARAMETER :: nbmax = 64 INTEGER, PARAMETER :: ldwork = nbmax+1 ! .. ! .. Local Scalars .. INTEGER :: i, i2, i3, ii, ip, j, j2, j3, jb, jj, jm, jp, & ju, k2, km, kv, nb, nw REAL :: temp ! .. ! .. Local Arrays .. REAL :: work13( ldwork, nbmax ), work31( ldwork, nbmax ) ! .. ! .. External Functions .. INTEGER :: ilaenv, isamax EXTERNAL ilaenv, isamax ! .. ! .. External Subroutines .. EXTERNAL scopy, sgbtf2, sgemm, sger, slaswp, sscal, & sswap, strsm, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! KV is the number of superdiagonals in the factor U, allowing for ! fill-in ! kv = ku + kl ! ! Test the input parameters. ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( kl < 0 ) THEN info = -3 ELSE IF( ku < 0 ) THEN info = -4 ELSE IF( ldab < kl+kv+1 ) THEN info = -6 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGBTRF', -info ) RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 ) RETURN ! ! Determine the block size for this environment ! nb = ilaenv( 1, 'SGBTRF', ' ', m, n, kl, ku ) ! ! The block size must not exceed the limit set by the size of the ! local arrays WORK13 and WORK31. ! nb = MIN( nb, nbmax ) ! IF( nb <= 1 .OR. nb > kl ) THEN ! ! Use unblocked code ! CALL sgbtf2( m, n, kl, ku, ab, ldab, ipiv, info ) ELSE ! ! Use blocked code ! ! Zero the superdiagonal elements of the work array WORK13 ! DO j = 1, nb DO i = 1, j - 1 work13( i, j ) = zero END DO END DO ! ! Zero the subdiagonal elements of the work array WORK31 ! DO j = 1, nb DO i = j + 1, nb work31( i, j ) = zero END DO END DO ! ! Gaussian elimination with partial pivoting ! ! Set fill-in elements in columns KU+2 to KV to zero ! DO j = ku + 2, MIN( kv, n ) DO i = kv - j + 2, kl ab( i, j ) = zero END DO END DO ! ! JU is the index of the last column affected by the current ! stage of the factorization ! ju = 1 ! DO j = 1, MIN( m, n ), nb jb = MIN( nb, MIN( m, n )-j+1 ) ! ! The active part of the matrix is partitioned ! ! A11 A12 A13 ! A21 A22 A23 ! A31 A32 A33 ! ! Here A11, A21 and A31 denote the current block of JB columns ! which is about to be factorized. The number of rows in the ! partitioning are JB, I2, I3 respectively, and the numbers ! of columns are JB, J2, J3. The superdiagonal elements of A13 ! and the subdiagonal elements of A31 lie outside the band. ! i2 = MIN( kl-jb, m-j-jb+1 ) i3 = MIN( jb, m-j-kl+1 ) ! ! J2 and J3 are computed after JU has been updated. ! ! Factorize the current block of JB columns ! DO jj = j, j + jb - 1 ! ! Set fill-in elements in column JJ+KV to zero ! IF( jj+kv <= n ) THEN DO i = 1, kl ab( i, jj+kv ) = zero END DO END IF ! ! Find pivot and test for singularity. KM is the number of ! subdiagonal elements in the current column. ! km = MIN( kl, m-jj ) jp = isamax( km+1, ab( kv+1, jj ), 1 ) ipiv( jj ) = jp + jj - j IF( ab( kv+jp, jj ) /= zero ) THEN ju = MAX( ju, MIN( jj+ku+jp-1, n ) ) IF( jp /= 1 ) THEN ! ! Apply interchange to columns J to J+JB-1 ! IF( jp+jj-1 < j+kl ) THEN ! CALL sswap( jb, ab( kv+1+jj-j, j ), ldab-1, & ab( kv+jp+jj-j, j ), ldab-1 ) ELSE ! ! The interchange affects columns J to JJ-1 of A31 ! which are stored in the work array WORK31 ! CALL sswap( jj-j, ab( kv+1+jj-j, j ), ldab-1, & work31( jp+jj-j-kl, 1 ), ldwork ) CALL sswap( j+jb-jj, ab( kv+1, jj ), ldab-1, & ab( kv+jp, jj ), ldab-1 ) END IF END IF ! ! Compute multipliers ! CALL sscal( km, one / ab( kv+1, jj ), ab( kv+2, jj ), 1 ) ! ! Update trailing submatrix within the band and within ! the current block. JM is the index of the last column ! which needs to be updated. ! jm = MIN( ju, j+jb-1 ) IF( jm > jj ) CALL sger( km, jm-jj, -one, ab( kv+2, jj ), 1, & ab( kv, jj+1 ), ldab-1, ab( kv+1, jj+1 ), ldab-1 ) ELSE ! ! If pivot is zero, set INFO to the index of the pivot ! unless a zero pivot has already been found. ! IF( info == 0 ) info = jj END IF ! ! Copy current column of A31 into the work array WORK31 ! nw = MIN( jj-j+1, i3 ) IF( nw > 0 ) CALL scopy( nw, ab( kv+kl+1-jj+j, jj ), 1, & work31( 1, jj-j+1 ), 1 ) END DO IF( j+jb <= n ) THEN ! ! Apply the row interchanges to the other blocks. ! j2 = MIN( ju-j+1, kv ) - jb j3 = MAX( 0, ju-j-kv+1 ) ! ! Use SLASWP to apply the row interchanges to A12, A22, and ! A32. ! CALL slaswp( j2, ab( kv+1-jb, j+jb ), ldab-1, 1, jb, ipiv( j ), 1 ) ! ! Adjust the pivot indices. ! DO i = j, j + jb - 1 ipiv( i ) = ipiv( i ) + j - 1 END DO ! ! Apply the row interchanges to A13, A23, and A33 ! columnwise. ! k2 = j - 1 + jb + j2 DO i = 1, j3 jj = k2 + i DO ii = j + i - 1, j + jb - 1 ip = ipiv( ii ) IF( ip /= ii ) THEN temp = ab( kv+1+ii-jj, jj ) ab( kv+1+ii-jj, jj ) = ab( kv+1+ip-jj, jj ) ab( kv+1+ip-jj, jj ) = temp END IF END DO END DO ! ! Update the relevant part of the trailing submatrix ! IF( j2 > 0 ) THEN ! ! Update A12 ! CALL strsm( 'Left', 'Lower', 'No transpose', 'Unit', & jb, j2, one, ab( kv+1, j ), ldab-1, ab( kv+1-jb, j+jb ), ldab-1 ) ! IF( i2 > 0 ) THEN ! ! Update A22 ! CALL sgemm( 'No transpose', 'No transpose', i2, j2, & jb, -one, ab( kv+1+jb, j ), ldab-1, & ab( kv+1-jb, j+jb ), ldab-1, one, ab( kv+1, j+jb ), ldab-1 ) END IF ! IF( i3 > 0 ) THEN ! ! Update A32 ! CALL sgemm( 'No transpose', 'No transpose', i3, j2, & jb, -one, work31, ldwork, ab( kv+1-jb, j+jb ), ldab-1, one, & ab( kv+kl+1-jb, j+jb ), ldab-1 ) END IF END IF ! IF( j3 > 0 ) THEN ! ! Copy the lower triangle of A13 into the work array ! WORK13 ! DO jj = 1, j3 DO ii = jj, jb work13( ii, jj ) = ab( ii-jj+1, jj+j+kv-1 ) END DO END DO ! ! Update A13 in the work array ! CALL strsm( 'Left', 'Lower', 'No transpose', 'Unit', & jb, j3, one, ab( kv+1, j ), ldab-1, work13, ldwork ) ! IF( i2 > 0 ) THEN ! ! Update A23 ! CALL sgemm( 'No transpose', 'No transpose', i2, j3, & jb, -one, ab( kv+1+jb, j ), ldab-1, & work13, ldwork, one, ab( 1+jb, j+kv ), ldab-1 ) END IF ! IF( i3 > 0 ) THEN ! ! Update A33 ! CALL sgemm( 'No transpose', 'No transpose', i3, j3, & jb, -one, work31, ldwork, work13, & ldwork, one, ab( 1+kl, j+kv ), ldab-1 ) END IF ! ! Copy the lower triangle of A13 back into place ! DO jj = 1, j3 DO ii = jj, jb ab( ii-jj+1, jj+j+kv-1 ) = work13( ii, jj ) END DO END DO END IF ELSE ! ! Adjust the pivot indices. ! DO i = j, j + jb - 1 ipiv( i ) = ipiv( i ) + j - 1 END DO END IF ! ! Partially undo the interchanges in the current block to ! restore the upper triangular form of A31 and copy the upper ! triangle of A31 back into place ! DO jj = j + jb - 1, j, -1 jp = ipiv( jj ) - jj + 1 IF( jp /= 1 ) THEN ! ! Apply interchange to columns J to JJ-1 ! IF( jp+jj-1 < j+kl ) THEN ! ! The interchange does not affect A31 ! CALL sswap( jj-j, ab( kv+1+jj-j, j ), ldab-1, & ab( kv+jp+jj-j, j ), ldab-1 ) ELSE ! ! The interchange does affect A31 ! CALL sswap( jj-j, ab( kv+1+jj-j, j ), ldab-1, & work31( jp+jj-j-kl, 1 ), ldwork ) END IF END IF ! ! Copy the current column of A31 back into place ! nw = MIN( i3, jj-j+1 ) IF( nw > 0 ) CALL scopy( nw, work31( 1, jj-j+1 ), 1, & ab( kv+kl+1-jj+j, jj ), 1 ) END DO END DO END IF ! RETURN ! ! End of SGBTRF ! END SUBROUTINE sgbtrf SUBROUTINE sgbtrs( trans, n, kl, ku, nrhs, ab, ldab, 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 (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: kl INTEGER, INTENT(IN) :: ku INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN OUT) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab INTEGER, INTENT(IN) :: ipiv( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGBTRS solves a system of linear equations ! A * X = B or A' * X = B ! with a general band matrix A using the LU factorization computed ! by SGBTRF. ! ! 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. ! ! KL (input) INTEGER ! The number of subdiagonals within the band of A. KL >= 0. ! ! KU (input) INTEGER ! The number of superdiagonals within the band of A. KU >= 0. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of columns ! of the matrix B. NRHS >= 0. ! ! AB (input) REAL array, dimension (LDAB,N) ! Details of the LU factorization of the band matrix A, as ! computed by SGBTRF. U is stored as an upper triangular band ! matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and ! the multipliers used during the factorization are stored in ! rows KL+KU+2 to 2*KL+KU+1. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= 2*KL+KU+1. ! ! IPIV (input) INTEGER array, dimension (N) ! The pivot indices; for 1 <= i <= N, row i of the matrix was ! interchanged with row IPIV(i). ! ! B (input/output) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lnoti, notran INTEGER :: i, j, kd, l, lm ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL sgemv, sger, sswap, stbsv, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. 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 < 0 ) THEN info = -2 ELSE IF( kl < 0 ) THEN info = -3 ELSE IF( ku < 0 ) THEN info = -4 ELSE IF( nrhs < 0 ) THEN info = -5 ELSE IF( ldab < ( 2*kl+ku+1 ) ) THEN info = -7 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -10 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGBTRS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) RETURN ! kd = ku + kl + 1 lnoti = kl > 0 ! IF( notran ) THEN ! ! Solve A*X = B. ! ! Solve L*X = B, overwriting B with X. ! ! L is represented as a product of permutations and unit lower ! triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), ! where each transformation L(i) is a rank-one modification of ! the identity matrix. ! IF( lnoti ) THEN DO j = 1, n - 1 lm = MIN( kl, n-j ) l = ipiv( j ) IF( l /= j ) CALL sswap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) CALL sger( lm, nrhs, -one, ab( kd+1, j ), 1, b( j, 1 ), & ldb, b( j+1, 1 ), ldb ) END DO END IF ! DO i = 1, nrhs ! ! Solve U*X = B, overwriting B with X. ! CALL stbsv( 'Upper', 'No transpose', 'Non-unit', n, kl+ku, & ab, ldab, b( 1, i ), 1 ) END DO ! ELSE ! ! Solve A'*X = B. ! DO i = 1, nrhs ! ! Solve U'*X = B, overwriting B with X. ! CALL stbsv( 'Upper', 'Transpose', 'Non-unit', n, kl+ku, ab, & ldab, b( 1, i ), 1 ) END DO ! ! Solve L'*X = B, overwriting B with X. ! IF( lnoti ) THEN DO j = n - 1, 1, -1 lm = MIN( kl, n-j ) CALL sgemv( 'Transpose', lm, nrhs, -one, b( j+1, 1 ), & ldb, ab( kd+1, j ), 1, one, b( j, 1 ), ldb ) l = ipiv( j ) IF( l /= j ) CALL sswap( nrhs, b( l, 1 ), ldb, b( j, 1 ), ldb ) END DO END IF END IF RETURN ! ! End of SGBTRS ! END SUBROUTINE sgbtrs SUBROUTINE sgebak( job, side, n, ilo, ihi, scale, 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 (LEN=1), INTENT(IN) :: job CHARACTER (LEN=1), INTENT(IN) :: side INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: ilo INTEGER, INTENT(IN) :: ihi REAL, INTENT(IN) :: scale( * ) INTEGER, INTENT(IN) :: m REAL, INTENT(IN OUT) :: v( ldv, * ) INTEGER, INTENT(IN OUT) :: ldv INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGEBAK forms the right or left eigenvectors of a real general matrix ! by backward transformation on the computed eigenvectors of the ! balanced matrix output by SGEBAL. ! ! 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 SGEBAL. ! ! 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 SGEBAL. ! 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. ! ! SCALE (input) REAL array, dimension (N) ! Details of the permutation and scaling factors, as returned ! by SGEBAL. ! ! M (input) INTEGER ! The number of columns of the matrix V. M >= 0. ! ! V (input/output) REAL array, dimension (LDV,M) ! On entry, the matrix of right or left eigenvectors to be ! transformed, as returned by SHSEIN or STREVC. ! On exit, V is overwritten by the transformed eigenvectors. ! ! LDV (input) INTEGER ! The leading dimension of the array V. LDV >= max(1,N). ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: leftv, rightv INTEGER :: i, ii, k REAL :: s ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL sscal, sswap, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Decode and 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 < 0 ) THEN info = -3 ELSE IF( ilo < 1 .OR. ilo > MAX( 1, n ) ) THEN info = -4 ELSE IF( ihi < MIN( ilo, n ) .OR. ihi > n ) THEN info = -5 ELSE IF( m < 0 ) THEN info = -7 ELSE IF( ldv < MAX( 1, n ) ) THEN info = -9 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGEBAK', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN IF( m == 0 ) RETURN IF( lsame( job, 'N' ) ) RETURN ! IF( ilo == ihi ) GO TO 30 ! ! Backward balance ! IF( lsame( job, 'S' ) .OR. lsame( job, 'B' ) ) THEN ! IF( rightv ) THEN DO i = ilo, ihi s = scale( i ) CALL sscal( m, s, v( i, 1 ), ldv ) END DO END IF ! IF( leftv ) THEN DO i = ilo, ihi s = one / scale( i ) CALL sscal( m, s, v( i, 1 ), ldv ) END DO END IF ! END IF ! ! Backward permutation ! ! For I = ILO-1 step -1 until 1, ! IHI+1 step 1 until N do -- ! 30 CONTINUE IF( lsame( job, 'P' ) .OR. lsame( job, 'B' ) ) THEN IF( rightv ) THEN DO ii = 1, n i = ii IF( i >= ilo .AND. i <= ihi ) CYCLE IF( i < ilo ) i = ilo - ii k = scale( i ) IF( k == i ) CYCLE CALL sswap( m, v( i, 1 ), ldv, v( k, 1 ), ldv ) END DO END IF ! IF( leftv ) THEN DO ii = 1, n i = ii IF( i >= ilo .AND. i <= ihi ) CYCLE IF( i < ilo ) i = ilo - ii k = scale( i ) IF( k == i ) CYCLE CALL sswap( m, v( i, 1 ), ldv, v( k, 1 ), ldv ) END DO END IF END IF ! RETURN ! ! End of SGEBAK ! END SUBROUTINE sgebak SUBROUTINE sgebal( job, n, a, lda, ilo, ihi, scale, 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 (LEN=1), INTENT(IN) :: job INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda INTEGER, INTENT(OUT) :: ilo INTEGER, INTENT(OUT) :: ihi REAL, INTENT(OUT) :: scale( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGEBAL balances a general real matrix A. This involves, first, ! permuting A by a similarity transformation 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 matrix, and improve the ! accuracy of the computed eigenvalues and/or eigenvectors. ! ! Arguments ! ========= ! ! JOB (input) CHARACTER*1 ! Specifies the operations to be performed on A: ! = 'N': none: simply set ILO = 1, IHI = N, SCALE(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 matrix A. N >= 0. ! ! A (input/output) REAL 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. ! See Further Details. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! ILO (output) INTEGER ! IHI (output) INTEGER ! ILO and IHI are set to integers such that on exit ! A(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. ! ! SCALE (output) REAL array, dimension (N) ! Details of the permutations and scaling factors applied to ! A. If P(j) is the index of the row and column interchanged ! with row and column j and D(j) is the scaling factor ! applied to row and column j, then ! SCALE(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. ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! ! Further Details ! =============== ! ! The permutations consist of row and column interchanges which put ! the matrix in the form ! ! ( T1 X Y ) ! P A P = ( 0 B Z ) ! ( 0 0 T2 ) ! ! where T1 and T2 are upper triangular matrices whose eigenvalues lie ! along the diagonal. The column indices ILO and IHI mark the starting ! and ending columns of the submatrix B. Balancing consists of applying ! a diagonal similarity transformation inv(D) * B * D to make the ! 1-norms of each row of B and its corresponding column nearly equal. ! The output matrix is ! ! ( T1 X*D Y ) ! ( 0 inv(D)*B*D inv(D)*Z ). ! ( 0 0 T2 ) ! ! Information about the permutations P and the diagonal matrix D is ! returned in the vector SCALE. ! ! This subroutine is based on the EISPACK routine BALANC. ! ! Modified by Tzu-Yi Chen, Computer Science Division, University of ! California at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: sclfac = 0.8E+1 REAL, PARAMETER :: factor = 0.95E+0 ! .. ! .. Local Scalars .. LOGICAL :: noconv INTEGER :: i, ica, iexc, ira, j, k, l, m REAL :: c, ca, f, g, r, ra, s, sfmax1, sfmax2, sfmin1, sfmin2 ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: isamax REAL :: slamch EXTERNAL lsame, isamax, slamch ! .. ! .. External Subroutines .. EXTERNAL sscal, sswap, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. 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 < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, n ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGEBAL', -info ) RETURN END IF ! k = 1 l = n ! IF( n == 0 ) GO TO 210 ! IF( lsame( job, 'N' ) ) THEN DO i = 1, n scale( i ) = one END DO GO TO 210 END IF ! IF( lsame( job, 'S' ) ) GO TO 120 ! ! Permutation to isolate eigenvalues if possible ! GO TO 50 ! ! Row and column exchange. ! 20 CONTINUE scale( m ) = j IF( j == m ) GO TO 30 ! CALL sswap( l, a( 1, j ), 1, a( 1, m ), 1 ) CALL sswap( n-k+1, a( j, k ), lda, a( m, k ), lda ) ! 30 CONTINUE SELECT CASE ( iexc ) CASE ( 1) GO TO 40 CASE ( 2) GO TO 80 END SELECT ! ! Search for rows isolating an eigenvalue and push them down. ! 40 CONTINUE IF( l == 1 ) GO TO 210 l = l - 1 ! 50 CONTINUE loop70: DO j = l, 1, -1 ! DO i = 1, l IF( i == j ) CYCLE IF( a( j, i ) /= zero ) CYCLE loop70 END DO ! m = l iexc = 1 GO TO 20 END DO loop70 ! GO TO 90 ! ! Search for columns isolating an eigenvalue and push them left. ! 80 CONTINUE k = k + 1 ! 90 CONTINUE loop110: DO j = k, l ! DO i = k, l IF( i == j ) CYCLE IF( a( i, j ) /= zero ) CYCLE loop110 END DO ! m = k iexc = 2 GO TO 20 END DO loop110 ! 120 CONTINUE DO i = k, l scale( i ) = one END DO ! IF( lsame( job, 'P' ) ) GO TO 210 ! ! Balance the submatrix in rows K to L. ! ! Iterative loop for norm reduction ! sfmin1 = slamch( 'S' ) / slamch( 'P' ) sfmax1 = one / sfmin1 sfmin2 = sfmin1*sclfac sfmax2 = one / sfmin2 140 CONTINUE noconv = .false. ! DO i = k, l c = zero r = zero ! DO j = k, l IF( j == i ) CYCLE c = c + ABS( a( j, i ) ) r = r + ABS( a( i, j ) ) END DO ica = isamax( l, a( 1, i ), 1 ) ca = ABS( a( ica, i ) ) ira = isamax( n-k+1, a( i, k ), lda ) ra = ABS( a( i, ira+k-1 ) ) ! ! Guard against zero C or R due to underflow. ! IF( c == zero .OR. r == zero ) CYCLE g = r / sclfac f = one s = c + r 160 CONTINUE IF( c >= g .OR. MAX( f, c, ca ) >= sfmax2 .OR. & MIN( r, g, ra ) <= sfmin2 )GO TO 170 f = f*sclfac c = c*sclfac ca = ca*sclfac r = r / sclfac g = g / sclfac ra = ra / sclfac GO TO 160 ! 170 CONTINUE g = c / sclfac 180 CONTINUE IF( g < r .OR. MAX( r, ra ) >= sfmax2 .OR. & MIN( f, c, g, ca ) <= sfmin2 )GO TO 190 f = f / sclfac c = c / sclfac g = g / sclfac ca = ca / sclfac r = r*sclfac ra = ra*sclfac GO TO 180 ! ! Now balance. ! 190 CONTINUE IF( ( c+r ) >= factor*s ) CYCLE IF( f < one .AND. scale( i ) < one ) THEN IF( f*scale( i ) <= sfmin1 ) CYCLE END IF IF( f > one .AND. scale( i ) > one ) THEN IF( scale( i ) >= sfmax1 / f ) CYCLE END IF g = one / f scale( i ) = scale( i )*f noconv = .true. ! CALL sscal( n-k+1, g, a( i, k ), lda ) CALL sscal( l, f, a( 1, i ), 1 ) ! END DO ! IF( noconv ) GO TO 140 ! 210 CONTINUE ilo = k ihi = l ! RETURN ! ! End of SGEBAL ! END SUBROUTINE sgebal SUBROUTINE sgebd2( 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 ! February 29, 1992 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: d( * ) REAL, INTENT(OUT) :: e( * ) REAL, INTENT(OUT) :: tauq( * ) REAL, INTENT(OUT) :: taup( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGEBD2 reduces a real general m by n matrix A to upper or lower ! bidiagonal form B by an orthogonal 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) REAL 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 orthogonal matrix Q as a product of elementary ! reflectors, and the elements above the first superdiagonal, ! with the array TAUP, represent the orthogonal 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 orthogonal matrix Q as a product of ! elementary reflectors, and the elements above the diagonal, ! with the array TAUP, represent the orthogonal 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) REAL array, dimension (min(M,N)) ! The diagonal elements of the bidiagonal matrix B: ! D(i) = A(i,i). ! ! E (output) REAL 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) REAL array dimension (min(M,N)) ! The scalar factors of the elementary reflectors which ! represent the orthogonal matrix Q. See Further Details. ! ! TAUP (output) REAL array, dimension (min(M,N)) ! The scalar factors of the elementary reflectors which ! represent the orthogonal matrix P. See Further Details. ! ! WORK (workspace) REAL 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 real scalars, and v and u are real 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 real scalars, and v and u are real 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 .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i ! .. ! .. External Subroutines .. EXTERNAL slarf, slarfg, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, m ) ) THEN info = -4 END IF IF( info < 0 ) THEN CALL xerbla( 'SGEBD2', -info ) RETURN END IF ! IF( m >= n ) THEN ! ! Reduce to upper bidiagonal form ! DO i = 1, n ! ! Generate elementary reflector H(i) to annihilate A(i+1:m,i) ! CALL slarfg( m-i+1, a( i, i ), a( MIN( i+1, m ), i ), 1, tauq( i ) ) d( i ) = a( i, i ) a( i, i ) = one ! ! Apply H(i) to A(i:m,i+1:n) from the left ! CALL slarf( 'Left', m-i+1, n-i, a( i, i ), 1, tauq( i ), & a( i, i+1 ), lda, work ) a( i, i ) = d( i ) ! IF( i < n ) THEN ! ! Generate elementary reflector G(i) to annihilate ! A(i,i+2:n) ! CALL slarfg( n-i, a( i, i+1 ), a( i, MIN( i+2, n ) ), lda, taup( i ) ) e( i ) = a( i, i+1 ) a( i, i+1 ) = one ! ! Apply G(i) to A(i+1:m,i+1:n) from the right ! CALL slarf( 'Right', m-i, n-i, a( i, i+1 ), lda, & taup( i ), a( i+1, i+1 ), lda, work ) a( i, i+1 ) = e( i ) ELSE taup( i ) = zero END IF END DO ELSE ! ! Reduce to lower bidiagonal form ! DO i = 1, m ! ! Generate elementary reflector G(i) to annihilate A(i,i+1:n) ! CALL slarfg( n-i+1, a( i, i ), a( i, MIN( i+1, n ) ), lda, taup( i ) ) d( i ) = a( i, i ) a( i, i ) = one ! ! Apply G(i) to A(i+1:m,i:n) from the right ! CALL slarf( 'Right', m-i, n-i+1, a( i, i ), lda, taup( i ), & a( MIN( i+1, m ), i ), lda, work ) a( i, i ) = d( i ) ! IF( i < m ) THEN ! ! Generate elementary reflector H(i) to annihilate ! A(i+2:m,i) ! CALL slarfg( m-i, a( i+1, i ), a( MIN( i+2, m ), i ), 1, tauq( i ) ) e( i ) = a( i+1, i ) a( i+1, i ) = one ! ! Apply H(i) to A(i+1:m,i+1:n) from the left ! CALL slarf( 'Left', m-i, n-i, a( i+1, i ), 1, tauq( i ), & a( i+1, i+1 ), lda, work ) a( i+1, i ) = e( i ) ELSE tauq( i ) = zero END IF END DO END IF RETURN ! ! End of SGEBD2 ! END SUBROUTINE sgebd2 SUBROUTINE sgebrd( 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: e( * ) REAL, INTENT(IN OUT) :: tauq( * ) REAL, INTENT(IN OUT) :: taup( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGEBRD reduces a general real M-by-N matrix A to upper or lower ! bidiagonal form B by an orthogonal transformation: Q**T * 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) REAL 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 orthogonal matrix Q as a product of elementary ! reflectors, and the elements above the first superdiagonal, ! with the array TAUP, represent the orthogonal 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 orthogonal matrix Q as a product of ! elementary reflectors, and the elements above the diagonal, ! with the array TAUP, represent the orthogonal 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) REAL array, dimension (min(M,N)) ! The diagonal elements of the bidiagonal matrix B: ! D(i) = A(i,i). ! ! E (output) REAL 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) REAL array dimension (min(M,N)) ! The scalar factors of the elementary reflectors which ! represent the orthogonal matrix Q. See Further Details. ! ! TAUP (output) REAL array, dimension (min(M,N)) ! The scalar factors of the elementary reflectors which ! represent the orthogonal matrix P. See Further Details. ! ! WORK (workspace/output) REAL 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 real scalars, and v and u are real 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 real scalars, and v and u are real 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: i, iinfo, j, ldwrkx, ldwrky, lwkopt, minmn, nb, nbmin, nx REAL :: ws ! .. ! .. External Subroutines .. EXTERNAL sgebd2, sgemm, slabrd, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, REAL ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Executable Statements .. ! ! Test the input parameters ! info = 0 nb = MAX( 1, ilaenv( 1, 'SGEBRD', ' ', m, n, -1, -1 ) ) lwkopt = ( m+n )*nb work( 1 ) = REAL( lwkopt ) lquery = ( lwork == -1 ) IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, m ) ) THEN info = -4 ELSE IF( lwork < MAX( 1, m, n ) .AND. .NOT.lquery ) THEN info = -10 END IF IF( info < 0 ) THEN CALL xerbla( 'SGEBRD', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! minmn = MIN( m, n ) IF( minmn == 0 ) THEN work( 1 ) = 1 RETURN END IF ! ws = MAX( m, n ) ldwrkx = m ldwrky = n ! IF( nb > 1 .AND. nb < minmn ) THEN ! ! Set the crossover point NX. ! nx = MAX( nb, ilaenv( 3, 'SGEBRD', ' ', m, n, -1, -1 ) ) ! ! Determine when to switch from blocked to unblocked code. ! IF( nx < minmn ) THEN ws = ( m+n )*nb IF( lwork < ws ) THEN ! ! Not enough work space for the optimal NB, consider using ! a smaller block size. ! nbmin = ilaenv( 2, 'SGEBRD', ' ', m, n, -1, -1 ) IF( lwork >= ( 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 i = 1, minmn - nx, nb ! ! Reduce rows and columns i:i+nb-1 to bidiagonal form and return ! the matrices X and Y which are needed to update the unreduced ! part of the matrix ! CALL slabrd( 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+nb:m,i+nb:n), using an update ! of the form A := A - V*Y' - X*U' ! CALL sgemm( 'No transpose', '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 sgemm( '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 >= n ) THEN DO j = i, i + nb - 1 a( j, j ) = d( j ) a( j, j+1 ) = e( j ) END DO ELSE DO j = i, i + nb - 1 a( j, j ) = d( j ) a( j+1, j ) = e( j ) END DO END IF END DO ! ! Use unblocked code to reduce the remainder of the matrix ! CALL sgebd2( 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 SGEBRD ! END SUBROUTINE sgebrd SUBROUTINE sgecon( norm, n, a, lda, anorm, rcond, 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 ! February 29, 1992 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: norm INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: anorm REAL, INTENT(OUT) :: rcond REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGECON estimates the reciprocal of the condition number of a general ! real matrix A, in either the 1-norm or the infinity-norm, using ! the LU factorization computed by SGETRF. ! ! An estimate is obtained for norm(inv(A)), and the reciprocal of the ! condition number is computed as ! RCOND = 1 / ( norm(A) * norm(inv(A)) ). ! ! Arguments ! ========= ! ! NORM (input) CHARACTER*1 ! Specifies whether the 1-norm condition number or the ! infinity-norm condition number is required: ! = '1' or 'O': 1-norm; ! = 'I': Infinity-norm. ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! A (input) REAL array, dimension (LDA,N) ! The factors L and U from the factorization A = P*L*U ! as computed by SGETRF. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! ANORM (input) REAL ! If NORM = '1' or 'O', the 1-norm of the original matrix A. ! If NORM = 'I', the infinity-norm of the original matrix A. ! ! RCOND (output) REAL ! The reciprocal of the condition number of the matrix A, ! computed as RCOND = 1/(norm(A) * norm(inv(A))). ! ! WORK (workspace) REAL array, dimension (4*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: onenrm CHARACTER (LEN=1) :: normin INTEGER :: ix, kase, kase1 REAL :: ainvnm, scale, sl, smlnum, su ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: isamax REAL :: slamch EXTERNAL lsame, isamax, slamch ! .. ! .. External Subroutines .. EXTERNAL slacon, slatrs, srscl, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 onenrm = norm == '1' .OR. lsame( norm, 'O' ) IF( .NOT.onenrm .AND. .NOT.lsame( norm, 'I' ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, n ) ) THEN info = -4 ELSE IF( anorm < zero ) THEN info = -5 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGECON', -info ) RETURN END IF ! ! Quick return if possible ! rcond = zero IF( n == 0 ) THEN rcond = one RETURN ELSE IF( anorm == zero ) THEN RETURN END IF ! smlnum = slamch( 'Safe minimum' ) ! ! Estimate the norm of inv(A). ! ainvnm = zero normin = 'N' IF( onenrm ) THEN kase1 = 1 ELSE kase1 = 2 END IF kase = 0 10 CONTINUE CALL slacon( n, work( n+1 ), work, iwork, ainvnm, kase ) IF( kase /= 0 ) THEN IF( kase == kase1 ) THEN ! ! Multiply by inv(L). ! CALL slatrs( 'Lower', 'No transpose', 'Unit', normin, n, a, & lda, work, sl, work( 2*n+1 ), info ) ! ! Multiply by inv(U). ! CALL slatrs( 'Upper', 'No transpose', 'Non-unit', normin, n, & a, lda, work, su, work( 3*n+1 ), info ) ELSE ! ! Multiply by inv(U'). ! CALL slatrs( 'Upper', 'Transpose', 'Non-unit', normin, n, a, & lda, work, su, work( 3*n+1 ), info ) ! ! Multiply by inv(L'). ! CALL slatrs( 'Lower', 'Transpose', 'Unit', normin, n, a, & lda, work, sl, work( 2*n+1 ), info ) END IF ! ! Divide X by 1/(SL*SU) if doing so will not cause overflow. ! scale = sl*su normin = 'Y' IF( scale /= one ) THEN ix = isamax( n, work, 1 ) IF( scale < ABS( work( ix ) )*smlnum .OR. scale == zero ) GO TO 20 CALL srscl( n, scale, work, 1 ) END IF GO TO 10 END IF ! ! Compute the estimate of the reciprocal condition number. ! IF( ainvnm /= zero ) rcond = ( one / ainvnm ) / anorm ! 20 CONTINUE RETURN ! ! End of SGECON ! END SUBROUTINE sgecon SUBROUTINE sgeequ( m, n, a, lda, r, c, rowcnd, colcnd, amax, 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: r( * ) REAL, INTENT(OUT) :: c( * ) REAL, INTENT(OUT) :: rowcnd REAL, INTENT(OUT) :: colcnd REAL, INTENT(OUT) :: amax INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGEEQU computes row and column scalings intended to equilibrate an ! M-by-N matrix A and reduce its condition number. R returns the row ! scale factors and C the column scale factors, chosen to try to make ! the largest element in each row and column of the matrix B with ! elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. ! ! R(i) and C(j) are restricted to be between SMLNUM = smallest safe ! number and BIGNUM = largest safe number. Use of these scaling ! factors is not guaranteed to reduce the condition number of A but ! works well in practice. ! ! 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) REAL array, dimension (LDA,N) ! The M-by-N matrix whose equilibration factors are ! to be computed. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! R (output) REAL array, dimension (M) ! If INFO = 0 or INFO > M, R contains the row scale factors ! for A. ! ! C (output) REAL array, dimension (N) ! If INFO = 0, C contains the column scale factors for A. ! ! ROWCND (output) REAL ! If INFO = 0 or INFO > M, ROWCND contains the ratio of the ! smallest R(i) to the largest R(i). If ROWCND >= 0.1 and ! AMAX is neither too large nor too small, it is not worth ! scaling by R. ! ! COLCND (output) REAL ! If INFO = 0, COLCND contains the ratio of the smallest ! C(i) to the largest C(i). If COLCND >= 0.1, it is not ! worth scaling by C. ! ! AMAX (output) REAL ! Absolute value of largest matrix element. If AMAX is very ! close to overflow or very close to underflow, the matrix ! should be scaled. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! > 0: if INFO = i, and i is ! <= M: the i-th row of A is exactly zero ! > M: the (i-M)-th column of A is exactly zero ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j REAL :: bignum, rcmax, rcmin, smlnum ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. External Subroutines .. EXTERNAL xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, m ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGEEQU', -info ) RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 ) THEN rowcnd = one colcnd = one amax = zero RETURN END IF ! ! Get machine constants. ! smlnum = slamch( 'S' ) bignum = one / smlnum ! ! Compute row scale factors. ! DO i = 1, m r( i ) = zero END DO ! ! Find the maximum element in each row. ! DO j = 1, n DO i = 1, m r( i ) = MAX( r( i ), ABS( a( i, j ) ) ) END DO END DO ! ! Find the maximum and minimum scale factors. ! rcmin = bignum rcmax = zero DO i = 1, m rcmax = MAX( rcmax, r( i ) ) rcmin = MIN( rcmin, r( i ) ) END DO amax = rcmax ! IF( rcmin == zero ) THEN ! ! Find the first zero scale factor and return an error code. ! DO i = 1, m IF( r( i ) == zero ) THEN info = i RETURN END IF END DO ELSE ! ! Invert the scale factors. ! DO i = 1, m r( i ) = one / MIN( MAX( r( i ), smlnum ), bignum ) END DO ! ! Compute ROWCND = min(R(I)) / max(R(I)) ! rowcnd = MAX( rcmin, smlnum ) / MIN( rcmax, bignum ) END IF ! ! Compute column scale factors ! DO j = 1, n c( j ) = zero END DO ! ! Find the maximum element in each column, ! assuming the row scaling computed above. ! DO j = 1, n DO i = 1, m c( j ) = MAX( c( j ), ABS( a( i, j ) )*r( i ) ) END DO END DO ! ! Find the maximum and minimum scale factors. ! rcmin = bignum rcmax = zero DO j = 1, n rcmin = MIN( rcmin, c( j ) ) rcmax = MAX( rcmax, c( j ) ) END DO ! IF( rcmin == zero ) THEN ! ! Find the first zero scale factor and return an error code. ! DO j = 1, n IF( c( j ) == zero ) THEN info = m + j RETURN END IF END DO ELSE ! ! Invert the scale factors. ! DO j = 1, n c( j ) = one / MIN( MAX( c( j ), smlnum ), bignum ) END DO ! ! Compute COLCND = min(C(J)) / max(C(J)) ! colcnd = MAX( rcmin, smlnum ) / MIN( rcmax, bignum ) END IF ! RETURN ! ! End of SGEEQU ! END SUBROUTINE sgeequ SUBROUTINE sgees( jobvs, sort, select, n, a, lda, sdim, wr, wi, & vs, ldvs, work, lwork, bwork, 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 (LEN=1), INTENT(IN) :: jobvs CHARACTER (LEN=1), INTENT(IN) :: sort LOGICAL :: select INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN) :: lda INTEGER, INTENT(OUT) :: sdim REAL, INTENT(IN) :: wr( * ) REAL, INTENT(IN OUT) :: wi( * ) REAL, INTENT(IN OUT) :: vs( ldvs, * ) INTEGER, INTENT(IN OUT) :: ldvs REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork LOGICAL, INTENT(OUT) :: bwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! .. Function Arguments .. EXTERNAL select ! .. ! ! Purpose ! ======= ! ! SGEES computes for an N-by-N real nonsymmetric matrix A, the ! eigenvalues, the real Schur form T, and, optionally, the matrix of ! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). ! ! Optionally, it also orders the eigenvalues on the diagonal of the ! real Schur form so that selected eigenvalues are at the top left. ! The leading columns of Z then form an orthonormal basis for the ! invariant subspace corresponding to the selected eigenvalues. ! ! A matrix is in real Schur form if it is upper quasi-triangular with ! 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the ! form ! [ a b ] ! [ c a ] ! ! where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). ! ! Arguments ! ========= ! ! JOBVS (input) CHARACTER*1 ! = 'N': Schur vectors are not computed; ! = 'V': Schur vectors are computed. ! ! SORT (input) CHARACTER*1 ! Specifies whether or not to order the eigenvalues on the ! diagonal of the Schur form. ! = 'N': Eigenvalues are not ordered; ! = 'S': Eigenvalues are ordered (see SELECT). ! ! SELECT (input) LOGICAL FUNCTION of two REAL arguments ! SELECT must be declared EXTERNAL in the calling subroutine. ! If SORT = 'S', SELECT is used to select eigenvalues to sort ! to the top left of the Schur form. ! If SORT = 'N', SELECT is not referenced. ! An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if ! SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex ! conjugate pair of eigenvalues is selected, then both complex ! eigenvalues are selected. ! Note that a selected complex eigenvalue may no longer ! satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since ! ordering may change the value of complex eigenvalues ! (especially if the eigenvalue is ill-conditioned); in this ! case INFO is set to N+2 (see INFO below). ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the N-by-N matrix A. ! On exit, A has been overwritten by its real Schur form T. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! SDIM (output) INTEGER ! If SORT = 'N', SDIM = 0. ! If SORT = 'S', SDIM = number of eigenvalues (after sorting) ! for which SELECT is true. (Complex conjugate ! pairs for which SELECT is true for either ! eigenvalue count as 2.) ! ! WR (output) REAL array, dimension (N) ! WI (output) REAL array, dimension (N) ! WR and WI contain the real and imaginary parts, ! respectively, of the computed eigenvalues in the same order ! that they appear on the diagonal of the output Schur form T. ! Complex conjugate pairs of eigenvalues will appear ! consecutively with the eigenvalue having the positive ! imaginary part first. ! ! VS (output) REAL array, dimension (LDVS,N) ! If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur ! vectors. ! If JOBVS = 'N', VS is not referenced. ! ! LDVS (input) INTEGER ! The leading dimension of the array VS. LDVS >= 1; if ! JOBVS = 'V', LDVS >= N. ! ! WORK (workspace/output) REAL array, dimension (LWORK) ! On exit, if INFO = 0, WORK(1) contains the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. LWORK >= max(1,3*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. ! ! BWORK (workspace) LOGICAL array, dimension (N) ! Not referenced if SORT = 'N'. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if INFO = i, and i is ! <= N: the QR algorithm failed to compute all the ! eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI ! contain those eigenvalues which have converged; if ! JOBVS = 'V', VS contains the matrix which reduces A ! to its partially converged Schur form. ! = N+1: the eigenvalues could not be reordered because some ! eigenvalues were too close to separate (the problem ! is very ill-conditioned); ! = N+2: after reordering, roundoff changed values of some ! complex eigenvalues so that leading eigenvalues in ! the Schur form no longer satisfy SELECT=.TRUE. This ! could also be caused by underflow due to scaling. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: cursl, lastsl, lquery, lst2sl, scalea, wantst, wantvs INTEGER :: hswork, i, i1, i2, ibal, icond, ierr, ieval, & ihi, ilo, inxt, ip, itau, iwrk, k, maxb, maxwrk, minwrk REAL :: anrm, bignum, cscale, eps, s, sep, smlnum ! .. ! .. Local Arrays .. INTEGER :: idum( 1 ) REAL :: dum( 1 ) ! .. ! .. External Subroutines .. EXTERNAL scopy, sgebak, sgebal, sgehrd, shseqr, slabad, & slacpy, slascl, sorghr, sswap, strsen, xerbla ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slange EXTERNAL lsame, ilaenv, slamch, slange ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 lquery = ( lwork == -1 ) wantvs = lsame( jobvs, 'V' ) wantst = lsame( sort, 'S' ) IF( ( .NOT.wantvs ) .AND. ( .NOT.lsame( jobvs, 'N' ) ) ) THEN info = -1 ELSE IF( ( .NOT.wantst ) .AND. ( .NOT.lsame( sort, 'N' ) ) ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( lda < MAX( 1, n ) ) THEN info = -6 ELSE IF( ldvs < 1 .OR. ( wantvs .AND. ldvs < n ) ) 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. ! NB refers to the optimal block size for the immediately ! following subroutine, as returned by ILAENV. ! HSWORK refers to the workspace preferred by SHSEQR, as ! calculated below. HSWORK is computed assuming ILO=1 and IHI=N, ! the worst case.) ! minwrk = 1 IF( info == 0 .AND. ( lwork >= 1 .OR. lquery ) ) THEN maxwrk = 2*n + n*ilaenv( 1, 'SGEHRD', ' ', n, 1, n, 0 ) minwrk = MAX( 1, 3*n ) IF( .NOT.wantvs ) THEN maxb = MAX( ilaenv( 8, 'SHSEQR', 'SN', n, 1, n, -1 ), 2 ) k = MIN( maxb, n, MAX( 2, ilaenv( 4, 'SHSEQR', 'SN', n, 1, n, -1 ) ) ) hswork = MAX( k*( k+2 ), 2*n ) maxwrk = MAX( maxwrk, n+hswork, 1 ) ELSE maxwrk = MAX( maxwrk, 2*n+( n-1 )* & ilaenv( 1, 'SORGHR', ' ', n, 1, n, -1 ) ) maxb = MAX( ilaenv( 8, 'SHSEQR', 'EN', n, 1, n, -1 ), 2 ) k = MIN( maxb, n, MAX( 2, ilaenv( 4, 'SHSEQR', 'EN', n, 1, n, -1 ) ) ) hswork = MAX( k*( k+2 ), 2*n ) maxwrk = MAX( maxwrk, n+hswork, 1 ) END IF work( 1 ) = maxwrk END IF IF( lwork < minwrk .AND. .NOT.lquery ) THEN info = -13 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGEES ', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) THEN sdim = 0 RETURN END IF ! ! Get machine constants ! eps = slamch( 'P' ) smlnum = slamch( 'S' ) bignum = one / smlnum CALL slabad( smlnum, bignum ) smlnum = SQRT( smlnum ) / eps bignum = one / smlnum ! ! Scale A if max element outside range [SMLNUM,BIGNUM] ! anrm = slange( 'M', n, n, a, lda, dum ) scalea = .false. IF( anrm > zero .AND. anrm < smlnum ) THEN scalea = .true. cscale = smlnum ELSE IF( anrm > bignum ) THEN scalea = .true. cscale = bignum END IF IF( scalea ) CALL slascl( 'G', 0, 0, anrm, cscale, n, n, a, lda, ierr ) ! ! Permute the matrix to make it more nearly triangular ! (Workspace: need N) ! ibal = 1 CALL sgebal( 'P', n, a, lda, ilo, ihi, work( ibal ), ierr ) ! ! Reduce to upper Hessenberg form ! (Workspace: need 3*N, prefer 2*N+N*NB) ! itau = n + ibal iwrk = n + itau CALL sgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ), & lwork-iwrk+1, ierr ) ! IF( wantvs ) THEN ! ! Copy Householder vectors to VS ! CALL slacpy( 'L', n, n, a, lda, vs, ldvs ) ! ! Generate orthogonal matrix in VS ! (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) ! CALL sorghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ), & lwork-iwrk+1, ierr ) END IF ! sdim = 0 ! ! Perform QR iteration, accumulating Schur vectors in VS if desired ! (Workspace: need N+1, prefer N+HSWORK (see comments) ) ! iwrk = itau CALL shseqr( 'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs, & work( iwrk ), lwork-iwrk+1, ieval ) IF( ieval > 0 ) info = ieval ! ! Sort eigenvalues if desired ! IF( wantst .AND. info == 0 ) THEN IF( scalea ) THEN CALL slascl( 'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr ) CALL slascl( 'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr ) END IF DO i = 1, n bwork( i ) = select( wr( i ), wi( i ) ) END DO ! ! Reorder eigenvalues and transform Schur vectors ! (Workspace: none needed) ! CALL strsen( 'N', jobvs, bwork, n, a, lda, vs, ldvs, wr, wi, & sdim, s, sep, work( iwrk ), lwork-iwrk+1, idum, 1, icond ) IF( icond > 0 ) info = n + icond END IF ! IF( wantvs ) THEN ! ! Undo balancing ! (Workspace: need N) ! CALL sgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs, ierr ) END IF ! IF( scalea ) THEN ! ! Undo scaling for the Schur form of A ! CALL slascl( 'H', 0, 0, cscale, anrm, n, n, a, lda, ierr ) CALL scopy( n, a, lda+1, wr, 1 ) IF( cscale == smlnum ) THEN ! ! If scaling back towards underflow, adjust WI if an ! offdiagonal element of a 2-by-2 block in the Schur form ! underflows. ! IF( ieval > 0 ) THEN i1 = ieval + 1 i2 = ihi - 1 CALL slascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, & MAX( ilo-1, 1 ), ierr ) ELSE IF( wantst ) THEN i1 = 1 i2 = n - 1 ELSE i1 = ilo i2 = ihi - 1 END IF inxt = i1 - 1 DO i = i1, i2 IF( i < inxt ) CYCLE IF( wi( i ) == zero ) THEN inxt = i + 1 ELSE IF( a( i+1, i ) == zero ) THEN wi( i ) = zero wi( i+1 ) = zero ELSE IF( a( i+1, i ) /= zero .AND. a( i, i+1 ) == & zero ) THEN wi( i ) = zero wi( i+1 ) = zero IF( i > 1 ) CALL sswap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 ) IF( n > i+1 ) CALL sswap( n-i-1, a( i, i+2 ), lda, & a( i+1, i+2 ), lda ) CALL sswap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 ) a( i, i+1 ) = a( i+1, i ) a( i+1, i ) = zero END IF inxt = i + 2 END IF END DO END IF ! ! Undo scaling for the imaginary part of the eigenvalues ! CALL slascl( 'G', 0, 0, cscale, anrm, n-ieval, 1, & wi( ieval+1 ), MAX( n-ieval, 1 ), ierr ) END IF ! IF( wantst .AND. info == 0 ) THEN ! ! Check if reordering successful ! lastsl = .true. lst2sl = .true. sdim = 0 ip = 0 DO i = 1, n cursl = select( wr( i ), wi( i ) ) IF( wi( i ) == zero ) THEN IF( cursl ) sdim = sdim + 1 ip = 0 IF( cursl .AND. .NOT.lastsl ) info = n + 2 ELSE IF( ip == 1 ) THEN ! ! Last eigenvalue of conjugate pair ! cursl = cursl .OR. lastsl lastsl = cursl IF( cursl ) sdim = sdim + 2 ip = -1 IF( cursl .AND. .NOT.lst2sl ) info = n + 2 ELSE ! ! First eigenvalue of conjugate pair ! ip = 1 END IF END IF lst2sl = lastsl lastsl = cursl END DO END IF ! work( 1 ) = maxwrk RETURN ! ! End of SGEES ! END SUBROUTINE sgees SUBROUTINE sgeesx( jobvs, sort, select, sense, n, a, lda, sdim, & wr, wi, vs, ldvs, rconde, rcondv, work, lwork, iwork, liwork, bwork, 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 .. INTEGER, INTENT(IN) :: lda INTEGER, INTENT(IN OUT) :: ldvs CHARACTER (LEN=1), INTENT(IN) :: jobvs CHARACTER (LEN=1), INTENT(IN) :: sort LOGICAL :: select CHARACTER (LEN=1), INTENT(IN) :: sense INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(OUT) :: sdim REAL, INTENT(IN) :: wr( * ) REAL, INTENT(IN OUT) :: wi( * ) REAL, INTENT(IN OUT) :: vs( ldvs, * ) REAL, INTENT(IN OUT) :: rconde REAL, INTENT(IN OUT) :: rcondv REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(IN) :: liwork LOGICAL, INTENT(OUT) :: bwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! .. Function Arguments .. EXTERNAL select ! .. ! ! Purpose ! ======= ! ! SGEESX computes for an N-by-N real nonsymmetric matrix A, the ! eigenvalues, the real Schur form T, and, optionally, the matrix of ! Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T). ! ! Optionally, it also orders the eigenvalues on the diagonal of the ! real Schur form so that selected eigenvalues are at the top left; ! computes a reciprocal condition number for the average of the ! selected eigenvalues (RCONDE); and computes a reciprocal condition ! number for the right invariant subspace corresponding to the ! selected eigenvalues (RCONDV). The leading columns of Z form an ! orthonormal basis for this invariant subspace. ! ! For further explanation of the reciprocal condition numbers RCONDE ! and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where ! these quantities are called s and sep respectively). ! ! A real matrix is in real Schur form if it is upper quasi-triangular ! with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in ! the form ! [ a b ] ! [ c a ] ! ! where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc). ! ! Arguments ! ========= ! ! JOBVS (input) CHARACTER*1 ! = 'N': Schur vectors are not computed; ! = 'V': Schur vectors are computed. ! ! SORT (input) CHARACTER*1 ! Specifies whether or not to order the eigenvalues on the ! diagonal of the Schur form. ! = 'N': Eigenvalues are not ordered; ! = 'S': Eigenvalues are ordered (see SELECT). ! ! SELECT (input) LOGICAL FUNCTION of two REAL arguments ! SELECT must be declared EXTERNAL in the calling subroutine. ! If SORT = 'S', SELECT is used to select eigenvalues to sort ! to the top left of the Schur form. ! If SORT = 'N', SELECT is not referenced. ! An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if ! SELECT(WR(j),WI(j)) is true; i.e., if either one of a ! complex conjugate pair of eigenvalues is selected, then both ! are. Note that a selected complex eigenvalue may no longer ! satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since ! ordering may change the value of complex eigenvalues ! (especially if the eigenvalue is ill-conditioned); in this ! case INFO may be set to N+3 (see INFO below). ! ! SENSE (input) CHARACTER*1 ! Determines which reciprocal condition numbers are computed. ! = 'N': None are computed; ! = 'E': Computed for average of selected eigenvalues only; ! = 'V': Computed for selected right invariant subspace only; ! = 'B': Computed for both. ! If SENSE = 'E', 'V' or 'B', SORT must equal 'S'. ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! A (input/output) REAL array, dimension (LDA, N) ! On entry, the N-by-N matrix A. ! On exit, A is overwritten by its real Schur form T. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! SDIM (output) INTEGER ! If SORT = 'N', SDIM = 0. ! If SORT = 'S', SDIM = number of eigenvalues (after sorting) ! for which SELECT is true. (Complex conjugate ! pairs for which SELECT is true for either ! eigenvalue count as 2.) ! ! WR (output) REAL array, dimension (N) ! WI (output) REAL array, dimension (N) ! WR and WI contain the real and imaginary parts, respectively, ! of the computed eigenvalues, in the same order that they ! appear on the diagonal of the output Schur form T. Complex ! conjugate pairs of eigenvalues appear consecutively with the ! eigenvalue having the positive imaginary part first. ! ! VS (output) REAL array, dimension (LDVS,N) ! If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur ! vectors. ! If JOBVS = 'N', VS is not referenced. ! ! LDVS (input) INTEGER ! The leading dimension of the array VS. LDVS >= 1, and if ! JOBVS = 'V', LDVS >= N. ! ! RCONDE (output) REAL ! If SENSE = 'E' or 'B', RCONDE contains the reciprocal ! condition number for the average of the selected eigenvalues. ! Not referenced if SENSE = 'N' or 'V'. ! ! RCONDV (output) REAL ! If SENSE = 'V' or 'B', RCONDV contains the reciprocal ! condition number for the selected right invariant subspace. ! Not referenced if SENSE = 'N' or 'E'. ! ! WORK (workspace/output) REAL 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,3*N). ! Also, if SENSE = 'E' or 'V' or 'B', ! LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of ! selected eigenvalues computed by this routine. Note that ! N+2*SDIM*(N-SDIM) <= N+N*N/2. ! For good performance, LWORK must generally be larger. ! ! IWORK (workspace/output) INTEGER array, dimension (LIWORK) ! Not referenced if SENSE = 'N' or 'E'. ! On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. ! ! LIWORK (input) INTEGER ! The dimension of the array IWORK. ! LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM). ! ! BWORK (workspace) LOGICAL array, dimension (N) ! Not referenced if SORT = 'N'. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if INFO = i, and i is ! <= N: the QR algorithm failed to compute all the ! eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI ! contain those eigenvalues which have converged; if ! JOBVS = 'V', VS contains the transformation which ! reduces A to its partially converged Schur form. ! = N+1: the eigenvalues could not be reordered because some ! eigenvalues were too close to separate (the problem ! is very ill-conditioned); ! = N+2: after reordering, roundoff changed values of some ! complex eigenvalues so that leading eigenvalues in ! the Schur form no longer satisfy SELECT=.TRUE. This ! could also be caused by underflow due to scaling. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: cursl, lastsl, lst2sl, scalea, wantsb, & wantse, wantsn, wantst, wantsv, wantvs INTEGER :: hswork, i, i1, i2, ibal, icond, ierr, ieval, & ihi, ilo, inxt, ip, itau, iwrk, k, maxb, maxwrk, minwrk REAL :: anrm, bignum, cscale, eps, smlnum ! .. ! .. Local Arrays .. REAL :: dum( 1 ) ! .. ! .. External Subroutines .. EXTERNAL scopy, sgebak, sgebal, sgehrd, shseqr, slabad, & slacpy, slascl, sorghr, sswap, strsen, xerbla ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slange EXTERNAL lsame, ilaenv, slamch, slange ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 wantvs = lsame( jobvs, 'V' ) wantst = lsame( sort, 'S' ) wantsn = lsame( sense, 'N' ) wantse = lsame( sense, 'E' ) wantsv = lsame( sense, 'V' ) wantsb = lsame( sense, 'B' ) IF( ( .NOT.wantvs ) .AND. ( .NOT.lsame( jobvs, 'N' ) ) ) THEN info = -1 ELSE IF( ( .NOT.wantst ) .AND. ( .NOT.lsame( sort, 'N' ) ) ) THEN info = -2 ELSE IF( .NOT.( wantsn .OR. wantse .OR. wantsv .OR. wantsb ) .OR. & ( .NOT.wantst .AND. .NOT.wantsn ) ) THEN info = -4 ELSE IF( n < 0 ) THEN info = -5 ELSE IF( lda < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldvs < 1 .OR. ( wantvs .AND. ldvs < n ) ) THEN info = -12 END IF ! ! Compute workspace ! (Note: Comments in the code beginning "RWorkspace:" describe the ! minimal amount of real workspace needed at that point in the ! code, as well as the preferred amount for good performance. ! IWorkspace refers to integer workspace. ! NB refers to the optimal block size for the immediately ! following subroutine, as returned by ILAENV. ! HSWORK refers to the workspace preferred by SHSEQR, as ! calculated below. HSWORK is computed assuming ILO=1 and IHI=N, ! the worst case. ! If SENSE = 'E', 'V' or 'B', then the amount of workspace needed ! depends on SDIM, which is computed by the routine STRSEN later ! in the code.) ! minwrk = 1 IF( info == 0 .AND. lwork >= 1 ) THEN maxwrk = 2*n + n*ilaenv( 1, 'SGEHRD', ' ', n, 1, n, 0 ) minwrk = MAX( 1, 3*n ) IF( .NOT.wantvs ) THEN maxb = MAX( ilaenv( 8, 'SHSEQR', 'SN', n, 1, n, -1 ), 2 ) k = MIN( maxb, n, MAX( 2, ilaenv( 4, 'SHSEQR', 'SN', n, 1, n, -1 ) ) ) hswork = MAX( k*( k+2 ), 2*n ) maxwrk = MAX( maxwrk, n+hswork, 1 ) ELSE maxwrk = MAX( maxwrk, 2*n+( n-1 )* & ilaenv( 1, 'SORGHR', ' ', n, 1, n, -1 ) ) maxb = MAX( ilaenv( 8, 'SHSEQR', 'SV', n, 1, n, -1 ), 2 ) k = MIN( maxb, n, MAX( 2, ilaenv( 4, 'SHSEQR', 'SV', n, 1, n, -1 ) ) ) hswork = MAX( k*( k+2 ), 2*n ) maxwrk = MAX( maxwrk, n+hswork, 1 ) END IF work( 1 ) = maxwrk END IF IF( lwork < minwrk ) THEN info = -16 END IF IF( liwork < 1 ) THEN info = -18 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGEESX', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) THEN sdim = 0 RETURN END IF ! ! Get machine constants ! eps = slamch( 'P' ) smlnum = slamch( 'S' ) bignum = one / smlnum CALL slabad( smlnum, bignum ) smlnum = SQRT( smlnum ) / eps bignum = one / smlnum ! ! Scale A if max element outside range [SMLNUM,BIGNUM] ! anrm = slange( 'M', n, n, a, lda, dum ) scalea = .false. IF( anrm > zero .AND. anrm < smlnum ) THEN scalea = .true. cscale = smlnum ELSE IF( anrm > bignum ) THEN scalea = .true. cscale = bignum END IF IF( scalea ) CALL slascl( 'G', 0, 0, anrm, cscale, n, n, a, lda, ierr ) ! ! Permute the matrix to make it more nearly triangular ! (RWorkspace: need N) ! ibal = 1 CALL sgebal( 'P', n, a, lda, ilo, ihi, work( ibal ), ierr ) ! ! Reduce to upper Hessenberg form ! (RWorkspace: need 3*N, prefer 2*N+N*NB) ! itau = n + ibal iwrk = n + itau CALL sgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ), & lwork-iwrk+1, ierr ) ! IF( wantvs ) THEN ! ! Copy Householder vectors to VS ! CALL slacpy( 'L', n, n, a, lda, vs, ldvs ) ! ! Generate orthogonal matrix in VS ! (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) ! CALL sorghr( n, ilo, ihi, vs, ldvs, work( itau ), work( iwrk ), & lwork-iwrk+1, ierr ) END IF ! sdim = 0 ! ! Perform QR iteration, accumulating Schur vectors in VS if desired ! (RWorkspace: need N+1, prefer N+HSWORK (see comments) ) ! iwrk = itau CALL shseqr( 'S', jobvs, n, ilo, ihi, a, lda, wr, wi, vs, ldvs, & work( iwrk ), lwork-iwrk+1, ieval ) IF( ieval > 0 ) info = ieval ! ! Sort eigenvalues if desired ! IF( wantst .AND. info == 0 ) THEN IF( scalea ) THEN CALL slascl( 'G', 0, 0, cscale, anrm, n, 1, wr, n, ierr ) CALL slascl( 'G', 0, 0, cscale, anrm, n, 1, wi, n, ierr ) END IF DO i = 1, n bwork( i ) = select( wr( i ), wi( i ) ) END DO ! ! Reorder eigenvalues, transform Schur vectors, and compute ! reciprocal condition numbers ! (RWorkspace: if SENSE is not 'N', need N+2*SDIM*(N-SDIM) ! otherwise, need N ) ! (IWorkspace: if SENSE is 'V' or 'B', need SDIM*(N-SDIM) ! otherwise, need 0 ) ! CALL strsen( sense, jobvs, bwork, n, a, lda, vs, ldvs, wr, wi, & sdim, rconde, rcondv, work( iwrk ), lwork-iwrk+1, iwork, liwork, icond ) IF( .NOT.wantsn ) maxwrk = MAX( maxwrk, n+2*sdim*( n-sdim ) ) IF( icond == -15 ) THEN ! ! Not enough real workspace ! info = -16 ELSE IF( icond == -17 ) THEN ! ! Not enough integer workspace ! info = -18 ELSE IF( icond > 0 ) THEN ! ! STRSEN failed to reorder or to restore standard Schur form ! info = icond + n END IF END IF ! IF( wantvs ) THEN ! ! Undo balancing ! (RWorkspace: need N) ! CALL sgebak( 'P', 'R', n, ilo, ihi, work( ibal ), n, vs, ldvs, ierr ) END IF ! IF( scalea ) THEN ! ! Undo scaling for the Schur form of A ! CALL slascl( 'H', 0, 0, cscale, anrm, n, n, a, lda, ierr ) CALL scopy( n, a, lda+1, wr, 1 ) IF( ( wantsv .OR. wantsb ) .AND. info == 0 ) THEN dum( 1 ) = rcondv CALL slascl( 'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr ) rcondv = dum( 1 ) END IF IF( cscale == smlnum ) THEN ! ! If scaling back towards underflow, adjust WI if an ! offdiagonal element of a 2-by-2 block in the Schur form ! underflows. ! IF( ieval > 0 ) THEN i1 = ieval + 1 i2 = ihi - 1 CALL slascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n, ierr ) ELSE IF( wantst ) THEN i1 = 1 i2 = n - 1 ELSE i1 = ilo i2 = ihi - 1 END IF inxt = i1 - 1 DO i = i1, i2 IF( i < inxt ) CYCLE IF( wi( i ) == zero ) THEN inxt = i + 1 ELSE IF( a( i+1, i ) == zero ) THEN wi( i ) = zero wi( i+1 ) = zero ELSE IF( a( i+1, i ) /= zero .AND. a( i, i+1 ) == & zero ) THEN wi( i ) = zero wi( i+1 ) = zero IF( i > 1 ) CALL sswap( i-1, a( 1, i ), 1, a( 1, i+1 ), 1 ) IF( n > i+1 ) CALL sswap( n-i-1, a( i, i+2 ), lda, & a( i+1, i+2 ), lda ) CALL sswap( n, vs( 1, i ), 1, vs( 1, i+1 ), 1 ) a( i, i+1 ) = a( i+1, i ) a( i+1, i ) = zero END IF inxt = i + 2 END IF END DO END IF CALL slascl( 'G', 0, 0, cscale, anrm, n-ieval, 1, & wi( ieval+1 ), MAX( n-ieval, 1 ), ierr ) END IF ! IF( wantst .AND. info == 0 ) THEN ! ! Check if reordering successful ! lastsl = .true. lst2sl = .true. sdim = 0 ip = 0 DO i = 1, n cursl = select( wr( i ), wi( i ) ) IF( wi( i ) == zero ) THEN IF( cursl ) sdim = sdim + 1 ip = 0 IF( cursl .AND. .NOT.lastsl ) info = n + 2 ELSE IF( ip == 1 ) THEN ! ! Last eigenvalue of conjugate pair ! cursl = cursl .OR. lastsl lastsl = cursl IF( cursl ) sdim = sdim + 2 ip = -1 IF( cursl .AND. .NOT.lst2sl ) info = n + 2 ELSE ! ! First eigenvalue of conjugate pair ! ip = 1 END IF END IF lst2sl = lastsl lastsl = cursl END DO END IF ! work( 1 ) = maxwrk IF( wantsv .OR. wantsb ) THEN iwork( 1 ) = sdim*(n-sdim) ELSE iwork( 1 ) = 1 END IF ! RETURN ! ! End of SGEESX ! END SUBROUTINE sgeesx SUBROUTINE sgeev( jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr, & ldvr, 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 (LEN=1), INTENT(IN) :: jobvl CHARACTER (LEN=1), INTENT(IN) :: jobvr INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN OUT) :: wr( * ) REAL, INTENT(IN) :: wi( * ) REAL, INTENT(IN OUT) :: vl( ldvl, * ) INTEGER, INTENT(IN OUT) :: ldvl REAL, INTENT(IN OUT) :: vr( ldvr, * ) INTEGER, INTENT(IN OUT) :: ldvr REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGEEV computes for an N-by-N real nonsymmetric matrix A, the ! eigenvalues and, optionally, the left and/or right eigenvectors. ! ! The right eigenvector v(j) of A satisfies ! A * v(j) = lambda(j) * v(j) ! where lambda(j) is its eigenvalue. ! The left eigenvector u(j) of A satisfies ! u(j)**H * A = lambda(j) * u(j)**H ! where u(j)**H denotes the conjugate transpose of u(j). ! ! The computed eigenvectors are normalized to have Euclidean norm ! equal to 1 and largest component real. ! ! Arguments ! ========= ! ! JOBVL (input) CHARACTER*1 ! = 'N': left eigenvectors of A are not computed; ! = 'V': left eigenvectors of A are computed. ! ! JOBVR (input) CHARACTER*1 ! = 'N': right eigenvectors of A are not computed; ! = 'V': right eigenvectors of A are computed. ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the N-by-N matrix A. ! On exit, A has been overwritten. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! WR (output) REAL array, dimension (N) ! WI (output) REAL array, dimension (N) ! WR and WI contain the real and imaginary parts, ! respectively, of the computed eigenvalues. Complex ! conjugate pairs of eigenvalues appear consecutively ! with the eigenvalue having the positive imaginary part ! first. ! ! VL (output) REAL array, dimension (LDVL,N) ! If JOBVL = 'V', the left eigenvectors u(j) are stored one ! after another in the columns of VL, in the same order ! as their eigenvalues. ! If JOBVL = 'N', VL is not referenced. ! If the j-th eigenvalue is real, then u(j) = VL(:,j), ! the j-th column of VL. ! If the j-th and (j+1)-st eigenvalues form a complex ! conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and ! u(j+1) = VL(:,j) - i*VL(:,j+1). ! ! LDVL (input) INTEGER ! The leading dimension of the array VL. LDVL >= 1; if ! JOBVL = 'V', LDVL >= N. ! ! VR (output) REAL array, dimension (LDVR,N) ! If JOBVR = 'V', the right eigenvectors v(j) are stored one ! after another in the columns of VR, in the same order ! as their eigenvalues. ! If JOBVR = 'N', VR is not referenced. ! If the j-th eigenvalue is real, then v(j) = VR(:,j), ! the j-th column of VR. ! If the j-th and (j+1)-st eigenvalues form a complex ! conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and ! v(j+1) = VR(:,j) - i*VR(:,j+1). ! ! LDVR (input) INTEGER ! The leading dimension of the array VR. LDVR >= 1; if ! JOBVR = 'V', LDVR >= N. ! ! WORK (workspace/output) REAL 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,3*N), and ! if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*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. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if INFO = i, the QR algorithm failed to compute all the ! eigenvalues, and no eigenvectors have been computed; ! elements i+1:N of WR and WI contain eigenvalues which ! have converged. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, scalea, wantvl, wantvr CHARACTER (LEN=1) :: side INTEGER :: hswork, i, ibal, ierr, ihi, ilo, itau, iwrk, k, & maxb, maxwrk, minwrk, nout REAL :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn ! .. ! .. Local Arrays .. LOGICAL :: select( 1 ) REAL :: dum( 1 ) ! .. ! .. External Subroutines .. EXTERNAL sgebak, sgebal, sgehrd, shseqr, slabad, slacpy, & slartg, slascl, sorghr, srot, sscal, strevc, xerbla ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv, isamax REAL :: slamch, slange, slapy2, snrm2 EXTERNAL lsame, ilaenv, isamax, slamch, slange, slapy2, snrm2 ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 lquery = ( lwork == -1 ) wantvl = lsame( jobvl, 'V' ) wantvr = lsame( jobvr, 'V' ) IF( ( .NOT.wantvl ) .AND. ( .NOT.lsame( jobvl, 'N' ) ) ) THEN info = -1 ELSE IF( ( .NOT.wantvr ) .AND. ( .NOT.lsame( jobvr, 'N' ) ) ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( ldvl < 1 .OR. ( wantvl .AND. ldvl < n ) ) THEN info = -9 ELSE IF( ldvr < 1 .OR. ( wantvr .AND. ldvr < n ) ) 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. ! NB refers to the optimal block size for the immediately ! following subroutine, as returned by ILAENV. ! HSWORK refers to the workspace preferred by SHSEQR, as ! calculated below. HSWORK is computed assuming ILO=1 and IHI=N, ! the worst case.) ! minwrk = 1 IF( info == 0 .AND. lwork >= 1 ) THEN maxwrk = 2*n + n*ilaenv( 1, 'SGEHRD', ' ', n, 1, n, 0 ) IF( ( .NOT.wantvl ) .AND. ( .NOT.wantvr ) ) THEN minwrk = MAX( 1, 3*n ) maxb = MAX( ilaenv( 8, 'SHSEQR', 'EN', n, 1, n, -1 ), 2 ) k = MIN( maxb, n, MAX( 2, ilaenv( 4, 'SHSEQR', 'EN', n, 1, n, -1 ) ) ) hswork = MAX( k*( k+2 ), 2*n ) maxwrk = MAX( maxwrk, n+1, n+hswork ) ELSE minwrk = MAX( 1, 4*n ) maxwrk = MAX( maxwrk, 2*n+( n-1 )* & ilaenv( 1, 'SORGHR', ' ', n, 1, n, -1 ) ) maxb = MAX( ilaenv( 8, 'SHSEQR', 'SV', n, 1, n, -1 ), 2 ) k = MIN( maxb, n, MAX( 2, ilaenv( 4, 'SHSEQR', 'SV', n, 1, n, -1 ) ) ) hswork = MAX( k*( k+2 ), 2*n ) maxwrk = MAX( maxwrk, n+1, n+hswork ) maxwrk = MAX( maxwrk, 4*n ) END IF work( 1 ) = maxwrk END IF IF( lwork < minwrk .AND. .NOT.lquery ) THEN info = -13 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGEEV ', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Get machine constants ! eps = slamch( 'P' ) smlnum = slamch( 'S' ) bignum = one / smlnum CALL slabad( smlnum, bignum ) smlnum = SQRT( smlnum ) / eps bignum = one / smlnum ! ! Scale A if max element outside range [SMLNUM,BIGNUM] ! anrm = slange( 'M', n, n, a, lda, dum ) scalea = .false. IF( anrm > zero .AND. anrm < smlnum ) THEN scalea = .true. cscale = smlnum ELSE IF( anrm > bignum ) THEN scalea = .true. cscale = bignum END IF IF( scalea ) CALL slascl( 'G', 0, 0, anrm, cscale, n, n, a, lda, ierr ) ! ! Balance the matrix ! (Workspace: need N) ! ibal = 1 CALL sgebal( 'B', n, a, lda, ilo, ihi, work( ibal ), ierr ) ! ! Reduce to upper Hessenberg form ! (Workspace: need 3*N, prefer 2*N+N*NB) ! itau = ibal + n iwrk = itau + n CALL sgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ), & lwork-iwrk+1, ierr ) ! IF( wantvl ) THEN ! ! Want left eigenvectors ! Copy Householder vectors to VL ! side = 'L' CALL slacpy( 'L', n, n, a, lda, vl, ldvl ) ! ! Generate orthogonal matrix in VL ! (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) ! CALL sorghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ), & lwork-iwrk+1, ierr ) ! ! Perform QR iteration, accumulating Schur vectors in VL ! (Workspace: need N+1, prefer N+HSWORK (see comments) ) ! iwrk = itau CALL shseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl, & work( iwrk ), lwork-iwrk+1, info ) ! IF( wantvr ) THEN ! ! Want left and right eigenvectors ! Copy Schur vectors to VR ! side = 'B' CALL slacpy( 'F', n, n, vl, ldvl, vr, ldvr ) END IF ! ELSE IF( wantvr ) THEN ! ! Want right eigenvectors ! Copy Householder vectors to VR ! side = 'R' CALL slacpy( 'L', n, n, a, lda, vr, ldvr ) ! ! Generate orthogonal matrix in VR ! (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB) ! CALL sorghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ), & lwork-iwrk+1, ierr ) ! ! Perform QR iteration, accumulating Schur vectors in VR ! (Workspace: need N+1, prefer N+HSWORK (see comments) ) ! iwrk = itau CALL shseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr, & work( iwrk ), lwork-iwrk+1, info ) ! ELSE ! ! Compute eigenvalues only ! (Workspace: need N+1, prefer N+HSWORK (see comments) ) ! iwrk = itau CALL shseqr( 'E', 'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr, & work( iwrk ), lwork-iwrk+1, info ) END IF ! ! If INFO > 0 from SHSEQR, then quit ! IF( info > 0 ) GO TO 50 ! IF( wantvl .OR. wantvr ) THEN ! ! Compute left and/or right eigenvectors ! (Workspace: need 4*N) ! CALL strevc( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr, & n, nout, work( iwrk ), ierr ) END IF ! IF( wantvl ) THEN ! ! Undo balancing of left eigenvectors ! (Workspace: need N) ! CALL sgebak( 'B', 'L', n, ilo, ihi, work( ibal ), n, vl, ldvl, ierr ) ! ! Normalize left eigenvectors and make largest component real ! DO i = 1, n IF( wi( i ) == zero ) THEN scl = one / snrm2( n, vl( 1, i ), 1 ) CALL sscal( n, scl, vl( 1, i ), 1 ) ELSE IF( wi( i ) > zero ) THEN scl = one / slapy2( snrm2( n, vl( 1, i ), 1 ), & snrm2( n, vl( 1, i+1 ), 1 ) ) CALL sscal( n, scl, vl( 1, i ), 1 ) CALL sscal( n, scl, vl( 1, i+1 ), 1 ) DO k = 1, n work( iwrk+k-1 ) = vl( k, i )**2 + vl( k, i+1 )**2 END DO k = isamax( n, work( iwrk ), 1 ) CALL slartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) CALL srot( n, vl( 1, i ), 1, vl( 1, i+1 ), 1, cs, sn ) vl( k, i+1 ) = zero END IF END DO END IF ! IF( wantvr ) THEN ! ! Undo balancing of right eigenvectors ! (Workspace: need N) ! CALL sgebak( 'B', 'R', n, ilo, ihi, work( ibal ), n, vr, ldvr, ierr ) ! ! Normalize right eigenvectors and make largest component real ! DO i = 1, n IF( wi( i ) == zero ) THEN scl = one / snrm2( n, vr( 1, i ), 1 ) CALL sscal( n, scl, vr( 1, i ), 1 ) ELSE IF( wi( i ) > zero ) THEN scl = one / slapy2( snrm2( n, vr( 1, i ), 1 ), & snrm2( n, vr( 1, i+1 ), 1 ) ) CALL sscal( n, scl, vr( 1, i ), 1 ) CALL sscal( n, scl, vr( 1, i+1 ), 1 ) DO k = 1, n work( iwrk+k-1 ) = vr( k, i )**2 + vr( k, i+1 )**2 END DO k = isamax( n, work( iwrk ), 1 ) CALL slartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) CALL srot( n, vr( 1, i ), 1, vr( 1, i+1 ), 1, cs, sn ) vr( k, i+1 ) = zero END IF END DO END IF ! ! Undo scaling if necessary ! 50 CONTINUE IF( scalea ) THEN CALL slascl( 'G', 0, 0, cscale, anrm, n-info, 1, wr( info+1 ), & MAX( n-info, 1 ), ierr ) CALL slascl( 'G', 0, 0, cscale, anrm, n-info, 1, wi( info+1 ), & MAX( n-info, 1 ), ierr ) IF( info > 0 ) THEN CALL slascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wr, n, ierr ) CALL slascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n, ierr ) END IF END IF ! work( 1 ) = maxwrk RETURN ! ! End of SGEEV ! END SUBROUTINE sgeev SUBROUTINE sgeevx( balanc, jobvl, jobvr, sense, n, a, lda, wr, wi, & vl, ldvl, vr, ldvr, ilo, ihi, scale, abnrm, & rconde, rcondv, work, lwork, iwork, 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 (LEN=1), INTENT(IN) :: balanc CHARACTER (LEN=1), INTENT(IN) :: jobvl CHARACTER (LEN=1), INTENT(IN) :: jobvr CHARACTER (LEN=1), INTENT(IN) :: sense INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN OUT) :: wr( * ) REAL, INTENT(IN) :: wi( * ) REAL, INTENT(IN OUT) :: vl( ldvl, * ) INTEGER, INTENT(IN OUT) :: ldvl REAL, INTENT(IN OUT) :: vr( ldvr, * ) INTEGER, INTENT(IN OUT) :: ldvr INTEGER, INTENT(IN OUT) :: ilo INTEGER, INTENT(IN OUT) :: ihi REAL, INTENT(IN OUT) :: scale( * ) REAL, INTENT(OUT) :: abnrm REAL, INTENT(IN OUT) :: rconde( * ) REAL, INTENT(IN OUT) :: rcondv( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGEEVX computes for an N-by-N real nonsymmetric matrix A, the ! eigenvalues and, optionally, the left and/or right eigenvectors. ! ! Optionally also, it computes a balancing transformation to improve ! the conditioning of the eigenvalues and eigenvectors (ILO, IHI, ! SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues ! (RCONDE), and reciprocal condition numbers for the right ! eigenvectors (RCONDV). ! ! The right eigenvector v(j) of A satisfies ! A * v(j) = lambda(j) * v(j) ! where lambda(j) is its eigenvalue. ! The left eigenvector u(j) of A satisfies ! u(j)**H * A = lambda(j) * u(j)**H ! where u(j)**H denotes the conjugate transpose of u(j). ! ! The computed eigenvectors are normalized to have Euclidean norm ! equal to 1 and largest component real. ! ! Balancing a matrix means permuting the rows and columns to make it ! more nearly upper triangular, and applying a diagonal similarity ! transformation D * A * D**(-1), where D is a diagonal matrix, to ! make its rows and columns closer in norm and the condition numbers ! of its eigenvalues and eigenvectors smaller. The computed ! reciprocal condition numbers correspond to the balanced matrix. ! Permuting rows and columns will not change the condition numbers ! (in exact arithmetic) but diagonal scaling will. For further ! explanation of balancing, see section 4.10.2 of the LAPACK ! Users' Guide. ! ! Arguments ! ========= ! ! BALANC (input) CHARACTER*1 ! Indicates how the input matrix should be diagonally scaled ! and/or permuted to improve the conditioning of its ! eigenvalues. ! = 'N': Do not diagonally scale or permute; ! = 'P': Perform permutations to make the matrix more nearly ! upper triangular. Do not diagonally scale; ! = 'S': Diagonally scale the matrix, i.e. replace A by ! D*A*D**(-1), where D is a diagonal matrix chosen ! to make the rows and columns of A more equal in ! norm. Do not permute; ! = 'B': Both diagonally scale and permute A. ! ! Computed reciprocal condition numbers will be for the matrix ! after balancing and/or permuting. Permuting does not change ! condition numbers (in exact arithmetic), but balancing does. ! ! JOBVL (input) CHARACTER*1 ! = 'N': left eigenvectors of A are not computed; ! = 'V': left eigenvectors of A are computed. ! If SENSE = 'E' or 'B', JOBVL must = 'V'. ! ! JOBVR (input) CHARACTER*1 ! = 'N': right eigenvectors of A are not computed; ! = 'V': right eigenvectors of A are computed. ! If SENSE = 'E' or 'B', JOBVR must = 'V'. ! ! SENSE (input) CHARACTER*1 ! Determines which reciprocal condition numbers are computed. ! = 'N': None are computed; ! = 'E': Computed for eigenvalues only; ! = 'V': Computed for right eigenvectors only; ! = 'B': Computed for eigenvalues and right eigenvectors. ! ! If SENSE = 'E' or 'B', both left and right eigenvectors ! must also be computed (JOBVL = 'V' and JOBVR = 'V'). ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the N-by-N matrix A. ! On exit, A has been overwritten. If JOBVL = 'V' or ! JOBVR = 'V', A contains the real Schur form of the balanced ! version of the input matrix A. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! WR (output) REAL array, dimension (N) ! WI (output) REAL array, dimension (N) ! WR and WI contain the real and imaginary parts, ! respectively, of the computed eigenvalues. Complex ! conjugate pairs of eigenvalues will appear consecutively ! with the eigenvalue having the positive imaginary part ! first. ! ! VL (output) REAL array, dimension (LDVL,N) ! If JOBVL = 'V', the left eigenvectors u(j) are stored one ! after another in the columns of VL, in the same order ! as their eigenvalues. ! If JOBVL = 'N', VL is not referenced. ! If the j-th eigenvalue is real, then u(j) = VL(:,j), ! the j-th column of VL. ! If the j-th and (j+1)-st eigenvalues form a complex ! conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and ! u(j+1) = VL(:,j) - i*VL(:,j+1). ! ! LDVL (input) INTEGER ! The leading dimension of the array VL. LDVL >= 1; if ! JOBVL = 'V', LDVL >= N. ! ! VR (output) REAL array, dimension (LDVR,N) ! If JOBVR = 'V', the right eigenvectors v(j) are stored one ! after another in the columns of VR, in the same order ! as their eigenvalues. ! If JOBVR = 'N', VR is not referenced. ! If the j-th eigenvalue is real, then v(j) = VR(:,j), ! the j-th column of VR. ! If the j-th and (j+1)-st eigenvalues form a complex ! conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and ! v(j+1) = VR(:,j) - i*VR(:,j+1). ! ! LDVR (input) INTEGER ! The leading dimension of the array VR. LDVR >= 1, and if ! JOBVR = 'V', LDVR >= N. ! ! ILO,IHI (output) INTEGER ! ILO and IHI are integer values determined when A was ! balanced. The balanced A(i,j) = 0 if I > J and ! J = 1,...,ILO-1 or I = IHI+1,...,N. ! ! SCALE (output) REAL array, dimension (N) ! Details of the permutations and scaling factors applied ! when balancing A. If P(j) is the index of the row and column ! interchanged with row and column j, and D(j) is the scaling ! factor applied to row and column j, then ! SCALE(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. ! ! ABNRM (output) REAL ! The one-norm of the balanced matrix (the maximum ! of the sum of absolute values of elements of any column). ! ! RCONDE (output) REAL array, dimension (N) ! RCONDE(j) is the reciprocal condition number of the j-th ! eigenvalue. ! ! RCONDV (output) REAL array, dimension (N) ! RCONDV(j) is the reciprocal condition number of the j-th ! right eigenvector. ! ! WORK (workspace/output) REAL array, dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. If SENSE = 'N' or 'E', ! LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V', ! LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6). ! 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. ! ! IWORK (workspace) INTEGER array, dimension (2*N-2) ! If SENSE = 'N' or 'E', not referenced. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if INFO = i, the QR algorithm failed to compute all the ! eigenvalues, and no eigenvectors or condition numbers ! have been computed; elements 1:ILO-1 and i+1:N of WR ! and WI contain eigenvalues which have converged. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, scalea, wantvl, wantvr, wntsnb, wntsne, wntsnn, wntsnv CHARACTER (LEN=1) :: job, side INTEGER :: hswork, i, icond, ierr, itau, iwrk, k, maxb, maxwrk, minwrk, nout REAL :: anrm, bignum, cs, cscale, eps, r, scl, smlnum, sn ! .. ! .. Local Arrays .. LOGICAL :: select( 1 ) REAL :: dum( 1 ) ! .. ! .. External Subroutines .. EXTERNAL sgebak, sgebal, sgehrd, shseqr, slabad, slacpy, & slartg, slascl, sorghr, srot, sscal, strevc, strsna, xerbla ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv, isamax REAL :: slamch, slange, slapy2, snrm2 EXTERNAL lsame, ilaenv, isamax, slamch, slange, slapy2, snrm2 ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 lquery = ( lwork == -1 ) wantvl = lsame( jobvl, 'V' ) wantvr = lsame( jobvr, 'V' ) wntsnn = lsame( sense, 'N' ) wntsne = lsame( sense, 'E' ) wntsnv = lsame( sense, 'V' ) wntsnb = lsame( sense, 'B' ) IF( .NOT.( lsame( balanc, 'N' ) .OR. lsame( balanc, 'S' ) .OR. & lsame( balanc, 'P' ) .OR. lsame( balanc, 'B' ) ) ) THEN info = -1 ELSE IF( ( .NOT.wantvl ) .AND. ( .NOT.lsame( jobvl, 'N' ) ) ) THEN info = -2 ELSE IF( ( .NOT.wantvr ) .AND. ( .NOT.lsame( jobvr, 'N' ) ) ) THEN info = -3 ELSE IF( .NOT.( wntsnn .OR. wntsne .OR. wntsnb .OR. wntsnv ) .OR. & ( ( wntsne .OR. wntsnb ) .AND. .NOT.( wantvl .AND. wantvr ) ) ) THEN info = -4 ELSE IF( n < 0 ) THEN info = -5 ELSE IF( lda < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldvl < 1 .OR. ( wantvl .AND. ldvl < n ) ) THEN info = -11 ELSE IF( ldvr < 1 .OR. ( wantvr .AND. ldvr < 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. ! HSWORK refers to the workspace preferred by SHSEQR, as ! calculated below. HSWORK is computed assuming ILO=1 and IHI=N, ! the worst case.) ! minwrk = 1 IF( info == 0 .AND. ( lwork >= 1 .OR. lquery ) ) THEN maxwrk = n + n*ilaenv( 1, 'SGEHRD', ' ', n, 1, n, 0 ) IF( ( .NOT.wantvl ) .AND. ( .NOT.wantvr ) ) THEN minwrk = MAX( 1, 2*n ) IF( .NOT.wntsnn ) minwrk = MAX( minwrk, n*n+6*n ) maxb = MAX( ilaenv( 8, 'SHSEQR', 'SN', n, 1, n, -1 ), 2 ) IF( wntsnn ) THEN k = MIN( maxb, n, MAX( 2, ilaenv( 4, 'SHSEQR', 'EN', n, 1, n, -1 ) ) ) ELSE k = MIN( maxb, n, MAX( 2, ilaenv( 4, 'SHSEQR', 'SN', n, 1, n, -1 ) ) ) END IF hswork = MAX( k*( k+2 ), 2*n ) maxwrk = MAX( maxwrk, 1, hswork ) IF( .NOT.wntsnn ) maxwrk = MAX( maxwrk, n*n+6*n ) ELSE minwrk = MAX( 1, 3*n ) IF( ( .NOT.wntsnn ) .AND. ( .NOT.wntsne ) ) & minwrk = MAX( minwrk, n*n+6*n ) maxb = MAX( ilaenv( 8, 'SHSEQR', 'SN', n, 1, n, -1 ), 2 ) k = MIN( maxb, n, MAX( 2, ilaenv( 4, 'SHSEQR', 'EN', n, 1, n, -1 ) ) ) hswork = MAX( k*( k+2 ), 2*n ) maxwrk = MAX( maxwrk, 1, hswork ) maxwrk = MAX( maxwrk, n+( n-1 )* ilaenv( 1, 'SORGHR', ' ', n, 1, n, -1 ) ) IF( ( .NOT.wntsnn ) .AND. ( .NOT.wntsne ) ) & maxwrk = MAX( maxwrk, n*n+6*n ) maxwrk = MAX( maxwrk, 3*n, 1 ) END IF work( 1 ) = maxwrk END IF IF( lwork < minwrk .AND. .NOT.lquery ) THEN info = -21 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGEEVX', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Get machine constants ! eps = slamch( 'P' ) smlnum = slamch( 'S' ) bignum = one / smlnum CALL slabad( smlnum, bignum ) smlnum = SQRT( smlnum ) / eps bignum = one / smlnum ! ! Scale A if max element outside range [SMLNUM,BIGNUM] ! icond = 0 anrm = slange( 'M', n, n, a, lda, dum ) scalea = .false. IF( anrm > zero .AND. anrm < smlnum ) THEN scalea = .true. cscale = smlnum ELSE IF( anrm > bignum ) THEN scalea = .true. cscale = bignum END IF IF( scalea ) CALL slascl( 'G', 0, 0, anrm, cscale, n, n, a, lda, ierr ) ! ! Balance the matrix and compute ABNRM ! CALL sgebal( balanc, n, a, lda, ilo, ihi, scale, ierr ) abnrm = slange( '1', n, n, a, lda, dum ) IF( scalea ) THEN dum( 1 ) = abnrm CALL slascl( 'G', 0, 0, cscale, anrm, 1, 1, dum, 1, ierr ) abnrm = dum( 1 ) END IF ! ! Reduce to upper Hessenberg form ! (Workspace: need 2*N, prefer N+N*NB) ! itau = 1 iwrk = itau + n CALL sgehrd( n, ilo, ihi, a, lda, work( itau ), work( iwrk ), & lwork-iwrk+1, ierr ) ! IF( wantvl ) THEN ! ! Want left eigenvectors ! Copy Householder vectors to VL ! side = 'L' CALL slacpy( 'L', n, n, a, lda, vl, ldvl ) ! ! Generate orthogonal matrix in VL ! (Workspace: need 2*N-1, prefer N+(N-1)*NB) ! CALL sorghr( n, ilo, ihi, vl, ldvl, work( itau ), work( iwrk ), & lwork-iwrk+1, ierr ) ! ! Perform QR iteration, accumulating Schur vectors in VL ! (Workspace: need 1, prefer HSWORK (see comments) ) ! iwrk = itau CALL shseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vl, ldvl, & work( iwrk ), lwork-iwrk+1, info ) ! IF( wantvr ) THEN ! ! Want left and right eigenvectors ! Copy Schur vectors to VR ! side = 'B' CALL slacpy( 'F', n, n, vl, ldvl, vr, ldvr ) END IF ! ELSE IF( wantvr ) THEN ! ! Want right eigenvectors ! Copy Householder vectors to VR ! side = 'R' CALL slacpy( 'L', n, n, a, lda, vr, ldvr ) ! ! Generate orthogonal matrix in VR ! (Workspace: need 2*N-1, prefer N+(N-1)*NB) ! CALL sorghr( n, ilo, ihi, vr, ldvr, work( itau ), work( iwrk ), & lwork-iwrk+1, ierr ) ! ! Perform QR iteration, accumulating Schur vectors in VR ! (Workspace: need 1, prefer HSWORK (see comments) ) ! iwrk = itau CALL shseqr( 'S', 'V', n, ilo, ihi, a, lda, wr, wi, vr, ldvr, & work( iwrk ), lwork-iwrk+1, info ) ! ELSE ! ! Compute eigenvalues only ! If condition numbers desired, compute Schur form ! IF( wntsnn ) THEN job = 'E' ELSE job = 'S' END IF ! ! (Workspace: need 1, prefer HSWORK (see comments) ) ! iwrk = itau CALL shseqr( job, 'N', n, ilo, ihi, a, lda, wr, wi, vr, ldvr, & work( iwrk ), lwork-iwrk+1, info ) END IF ! ! If INFO > 0 from SHSEQR, then quit ! IF( info > 0 ) GO TO 50 ! IF( wantvl .OR. wantvr ) THEN ! ! Compute left and/or right eigenvectors ! (Workspace: need 3*N) ! CALL strevc( side, 'B', select, n, a, lda, vl, ldvl, vr, ldvr, & n, nout, work( iwrk ), ierr ) END IF ! ! Compute condition numbers if desired ! (Workspace: need N*N+6*N unless SENSE = 'E') ! IF( .NOT.wntsnn ) THEN CALL strsna( sense, 'A', select, n, a, lda, vl, ldvl, vr, ldvr, & rconde, rcondv, n, nout, work( iwrk ), n, iwork, icond ) END IF ! IF( wantvl ) THEN ! ! Undo balancing of left eigenvectors ! CALL sgebak( balanc, 'L', n, ilo, ihi, scale, n, vl, ldvl, ierr ) ! ! Normalize left eigenvectors and make largest component real ! DO i = 1, n IF( wi( i ) == zero ) THEN scl = one / snrm2( n, vl( 1, i ), 1 ) CALL sscal( n, scl, vl( 1, i ), 1 ) ELSE IF( wi( i ) > zero ) THEN scl = one / slapy2( snrm2( n, vl( 1, i ), 1 ), & snrm2( n, vl( 1, i+1 ), 1 ) ) CALL sscal( n, scl, vl( 1, i ), 1 ) CALL sscal( n, scl, vl( 1, i+1 ), 1 ) DO k = 1, n work( k ) = vl( k, i )**2 + vl( k, i+1 )**2 END DO k = isamax( n, work, 1 ) CALL slartg( vl( k, i ), vl( k, i+1 ), cs, sn, r ) CALL srot( n, vl( 1, i ), 1, vl( 1, i+1 ), 1, cs, sn ) vl( k, i+1 ) = zero END IF END DO END IF ! IF( wantvr ) THEN ! ! Undo balancing of right eigenvectors ! CALL sgebak( balanc, 'R', n, ilo, ihi, scale, n, vr, ldvr, ierr ) ! ! Normalize right eigenvectors and make largest component real ! DO i = 1, n IF( wi( i ) == zero ) THEN scl = one / snrm2( n, vr( 1, i ), 1 ) CALL sscal( n, scl, vr( 1, i ), 1 ) ELSE IF( wi( i ) > zero ) THEN scl = one / slapy2( snrm2( n, vr( 1, i ), 1 ), & snrm2( n, vr( 1, i+1 ), 1 ) ) CALL sscal( n, scl, vr( 1, i ), 1 ) CALL sscal( n, scl, vr( 1, i+1 ), 1 ) DO k = 1, n work( k ) = vr( k, i )**2 + vr( k, i+1 )**2 END DO k = isamax( n, work, 1 ) CALL slartg( vr( k, i ), vr( k, i+1 ), cs, sn, r ) CALL srot( n, vr( 1, i ), 1, vr( 1, i+1 ), 1, cs, sn ) vr( k, i+1 ) = zero END IF END DO END IF ! ! Undo scaling if necessary ! 50 CONTINUE IF( scalea ) THEN CALL slascl( 'G', 0, 0, cscale, anrm, n-info, 1, wr( info+1 ), & MAX( n-info, 1 ), ierr ) CALL slascl( 'G', 0, 0, cscale, anrm, n-info, 1, wi( info+1 ), & MAX( n-info, 1 ), ierr ) IF( info == 0 ) THEN IF( ( wntsnv .OR. wntsnb ) .AND. icond == 0 ) & CALL slascl( 'G', 0, 0, cscale, anrm, n, 1, rcondv, n, ierr ) ELSE CALL slascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wr, n, ierr ) CALL slascl( 'G', 0, 0, cscale, anrm, ilo-1, 1, wi, n, ierr ) END IF END IF ! work( 1 ) = maxwrk RETURN ! ! End of SGEEVX ! END SUBROUTINE sgeevx SUBROUTINE sgegs( jobvsl, jobvsr, n, a, lda, b, ldb, alphar, & alphai, beta, vsl, ldvsl, vsr, ldvsr, 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 (LEN=1), INTENT(IN) :: jobvsl CHARACTER (LEN=1), INTENT(IN) :: jobvsr INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN) :: ldb REAL, INTENT(IN OUT) :: alphar( * ) REAL, INTENT(IN OUT) :: alphai( * ) REAL, INTENT(IN OUT) :: beta( * ) REAL, INTENT(IN OUT) :: vsl( ldvsl, * ) INTEGER, INTENT(IN OUT) :: ldvsl REAL, INTENT(IN OUT) :: vsr( ldvsr, * ) INTEGER, INTENT(IN OUT) :: ldvsr REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! This routine is deprecated and has been replaced by routine SGGES. ! ! SGEGS computes for a pair of N-by-N real nonsymmetric matrices A, B: ! the generalized eigenvalues (alphar +/- alphai*i, beta), the real ! Schur form (A, B), and optionally left and/or right Schur vectors ! (VSL and VSR). ! ! (If only the generalized eigenvalues are needed, use the driver SGEGV ! instead.) ! ! A generalized eigenvalue for a pair of matrices (A,B) is, roughly ! speaking, a scalar w or a ratio alpha/beta = w, such that A - w*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. A good beginning reference is the book, "Matrix ! Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press) ! ! The (generalized) Schur form of a pair of matrices is the result of ! multiplying both matrices on the left by one orthogonal matrix and ! both on the right by another orthogonal matrix, these two orthogonal ! matrices being chosen so as to bring the pair of matrices into ! (real) Schur form. ! ! A pair of matrices A, B is in generalized real Schur form if B is ! upper triangular with non-negative diagonal and A is block upper ! triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond ! to real generalized eigenvalues, while 2-by-2 blocks of A will be ! "standardized" by making the corresponding elements of B have the ! form: ! [ a 0 ] ! [ 0 b ] ! ! and the pair of corresponding 2-by-2 blocks in A and B will ! have a complex conjugate pair of generalized eigenvalues. ! ! The left and right Schur vectors are the columns of VSL and VSR, ! respectively, where VSL and VSR are the orthogonal matrices ! which reduce A and B to Schur form: ! ! Schur form of (A,B) = ( (VSL)**T A (VSR), (VSL)**T B (VSR) ) ! ! Arguments ! ========= ! ! JOBVSL (input) CHARACTER*1 ! = 'N': do not compute the left Schur vectors; ! = 'V': compute the left Schur vectors. ! ! JOBVSR (input) CHARACTER*1 ! = 'N': do not compute the right Schur vectors; ! = 'V': compute the right Schur vectors. ! ! N (input) INTEGER ! The order of the matrices A, B, VSL, and VSR. N >= 0. ! ! A (input/output) REAL array, dimension (LDA, N) ! On entry, the first of the pair of matrices whose generalized ! eigenvalues and (optionally) Schur vectors are to be ! computed. ! On exit, the generalized Schur form of A. ! Note: to avoid overflow, the Frobenius norm of the matrix ! A should be less than the overflow threshold. ! ! LDA (input) INTEGER ! The leading dimension of A. LDA >= max(1,N). ! ! B (input/output) REAL array, dimension (LDB, N) ! On entry, the second of the pair of matrices whose ! generalized eigenvalues and (optionally) Schur vectors are ! to be computed. ! On exit, the generalized Schur form of B. ! Note: to avoid overflow, the Frobenius norm of the matrix ! B should be less than the overflow threshold. ! ! LDB (input) INTEGER ! The leading dimension of B. LDB >= max(1,N). ! ! ALPHAR (output) REAL array, dimension (N) ! ALPHAI (output) REAL array, dimension (N) ! BETA (output) REAL array, dimension (N) ! On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will ! be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i, ! j=1,...,N and BETA(j),j=1,...,N are the diagonals of the ! complex Schur form (A,B) that would result if the 2-by-2 ! diagonal blocks of the real Schur form of (A,B) were further ! reduced to triangular form using 2-by-2 complex unitary ! transformations. If ALPHAI(j) is zero, then the j-th ! eigenvalue is real; if positive, then the j-th and (j+1)-st ! eigenvalues are a complex conjugate pair, with ALPHAI(j+1) ! negative. ! ! Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(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, ALPHAR and ALPHAI will be always less ! than and usually comparable with norm(A) in magnitude, and ! BETA always less than and usually comparable with norm(B). ! ! VSL (output) REAL array, dimension (LDVSL,N) ! If JOBVSL = 'V', VSL will contain the left Schur vectors. ! (See "Purpose", above.) ! Not referenced if JOBVSL = 'N'. ! ! LDVSL (input) INTEGER ! The leading dimension of the matrix VSL. LDVSL >=1, and ! if JOBVSL = 'V', LDVSL >= N. ! ! VSR (output) REAL array, dimension (LDVSR,N) ! If JOBVSR = 'V', VSR will contain the right Schur vectors. ! (See "Purpose", above.) ! Not referenced if JOBVSR = 'N'. ! ! LDVSR (input) INTEGER ! The leading dimension of the matrix VSR. LDVSR >= 1, and ! if JOBVSR = 'V', LDVSR >= N. ! ! WORK (workspace/output) REAL 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,4*N). ! For good performance, LWORK must generally be larger. ! To compute the optimal value of LWORK, call ILAENV to get ! blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute: ! NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR ! The optimal LWORK is 2*N + N*(NB+1). ! ! 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. ! = 1,...,N: ! The QZ iteration failed. (A,B) are not in Schur ! form, but ALPHAR(j), ALPHAI(j), and BETA(j) should ! be correct for j=INFO+1,...,N. ! > N: errors that usually indicate LAPACK problems: ! =N+1: error return from SGGBAL ! =N+2: error return from SGEQRF ! =N+3: error return from SORMQR ! =N+4: error return from SORGQR ! =N+5: error return from SGGHRD ! =N+6: error return from SHGEQZ (other than failed ! iteration) ! =N+7: error return from SGGBAK (computing VSL) ! =N+8: error return from SGGBAK (computing VSR) ! =N+9: error return from SLASCL (various places) ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: ilascl, ilbscl, ilvsl, ilvsr, lquery INTEGER :: icols, ihi, iinfo, ijobvl, ijobvr, ileft, & ilo, iright, irows, itau, iwork, lopt, lwkmin, lwkopt, nb, nb1, nb2, nb3 REAL :: anrm, anrmto, bignum, bnrm, bnrmto, eps, safmin, smlnum ! .. ! .. External Subroutines .. EXTERNAL sgeqrf, sggbak, sggbal, sgghrd, shgeqz, slacpy, & slascl, slaset, sorgqr, sormqr, xerbla ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slange EXTERNAL ilaenv, lsame, slamch, slange ! .. ! .. Intrinsic Functions .. INTRINSIC INT, MAX ! .. ! .. Executable Statements .. ! ! Decode the input arguments ! IF( lsame( jobvsl, 'N' ) ) THEN ijobvl = 1 ilvsl = .false. ELSE IF( lsame( jobvsl, 'V' ) ) THEN ijobvl = 2 ilvsl = .true. ELSE ijobvl = -1 ilvsl = .false. END IF ! IF( lsame( jobvsr, 'N' ) ) THEN ijobvr = 1 ilvsr = .false. ELSE IF( lsame( jobvsr, 'V' ) ) THEN ijobvr = 2 ilvsr = .true. ELSE ijobvr = -1 ilvsr = .false. END IF ! ! Test the input arguments ! lwkmin = MAX( 4*n, 1 ) lwkopt = lwkmin work( 1 ) = lwkopt lquery = ( lwork == -1 ) info = 0 IF( ijobvl <= 0 ) THEN info = -1 ELSE IF( ijobvr <= 0 ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldvsl < 1 .OR. ( ilvsl .AND. ldvsl < n ) ) THEN info = -12 ELSE IF( ldvsr < 1 .OR. ( ilvsr .AND. ldvsr < n ) ) THEN info = -14 ELSE IF( lwork < lwkmin .AND. .NOT.lquery ) THEN info = -16 END IF ! IF( info == 0 ) THEN nb1 = ilaenv( 1, 'SGEQRF', ' ', n, n, -1, -1 ) nb2 = ilaenv( 1, 'SORMQR', ' ', n, n, n, -1 ) nb3 = ilaenv( 1, 'SORGQR', ' ', n, n, n, -1 ) nb = MAX( nb1, nb2, nb3 ) lopt = 2*n+n*(nb+1) work( 1 ) = lopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SGEGS ', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Get machine constants ! eps = slamch( 'E' )*slamch( 'B' ) safmin = slamch( 'S' ) smlnum = n*safmin / eps bignum = one / smlnum ! ! Scale A if max element outside range [SMLNUM,BIGNUM] ! anrm = slange( 'M', n, n, a, lda, work ) ilascl = .false. IF( anrm > zero .AND. anrm < smlnum ) THEN anrmto = smlnum ilascl = .true. ELSE IF( anrm > bignum ) THEN anrmto = bignum ilascl = .true. END IF ! IF( ilascl ) THEN CALL slascl( 'G', -1, -1, anrm, anrmto, n, n, a, lda, iinfo ) IF( iinfo /= 0 ) THEN info = n + 9 RETURN END IF END IF ! ! Scale B if max element outside range [SMLNUM,BIGNUM] ! bnrm = slange( 'M', n, n, b, ldb, work ) ilbscl = .false. IF( bnrm > zero .AND. bnrm < smlnum ) THEN bnrmto = smlnum ilbscl = .true. ELSE IF( bnrm > bignum ) THEN bnrmto = bignum ilbscl = .true. END IF ! IF( ilbscl ) THEN CALL slascl( 'G', -1, -1, bnrm, bnrmto, n, n, b, ldb, iinfo ) IF( iinfo /= 0 ) THEN info = n + 9 RETURN END IF END IF ! ! Permute the matrix to make it more nearly triangular ! Workspace layout: (2*N words -- "work..." not actually used) ! left_permutation, right_permutation, work... ! ileft = 1 iright = n + 1 iwork = iright + n CALL sggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ), & work( iright ), work( iwork ), iinfo ) IF( iinfo /= 0 ) THEN info = n + 1 GO TO 10 END IF ! ! Reduce B to triangular form, and initialize VSL and/or VSR ! Workspace layout: ("work..." must have at least N words) ! left_permutation, right_permutation, tau, work... ! irows = ihi + 1 - ilo icols = n + 1 - ilo itau = iwork iwork = itau + irows CALL sgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ), & work( iwork ), lwork+1-iwork, iinfo ) IF( iinfo >= 0 ) lwkopt = MAX( lwkopt, INT( work( iwork ) )+iwork-1 ) IF( iinfo /= 0 ) THEN info = n + 2 GO TO 10 END IF ! CALL sormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb, & work( itau ), a( ilo, ilo ), lda, work( iwork ), lwork+1-iwork, iinfo ) IF( iinfo >= 0 ) lwkopt = MAX( lwkopt, INT( work( iwork ) )+iwork-1 ) IF( iinfo /= 0 ) THEN info = n + 3 GO TO 10 END IF ! IF( ilvsl ) THEN CALL slaset( 'Full', n, n, zero, one, vsl, ldvsl ) CALL slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb, & vsl( ilo+1, ilo ), ldvsl ) CALL sorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl, & work( itau ), work( iwork ), lwork+1-iwork, iinfo ) IF( iinfo >= 0 ) lwkopt = MAX( lwkopt, INT( work( iwork ) )+iwork-1 ) IF( iinfo /= 0 ) THEN info = n + 4 GO TO 10 END IF END IF ! IF( ilvsr ) CALL slaset( 'Full', n, n, zero, one, vsr, ldvsr ) ! ! Reduce to generalized Hessenberg form ! CALL sgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl, & ldvsl, vsr, ldvsr, iinfo ) IF( iinfo /= 0 ) THEN info = n + 5 GO TO 10 END IF ! ! Perform QZ algorithm, computing Schur vectors if desired ! Workspace layout: ("work..." must have at least 1 word) ! left_permutation, right_permutation, work... ! iwork = itau CALL shgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, & alphar, alphai, beta, vsl, ldvsl, vsr, ldvsr, & work( iwork ), lwork+1-iwork, iinfo ) IF( iinfo >= 0 ) lwkopt = MAX( lwkopt, INT( work( iwork ) )+iwork-1 ) IF( iinfo /= 0 ) THEN IF( iinfo > 0 .AND. iinfo <= n ) THEN info = iinfo ELSE IF( iinfo > n .AND. iinfo <= 2*n ) THEN info = iinfo - n ELSE info = n + 6 END IF GO TO 10 END IF ! ! Apply permutation to VSL and VSR ! IF( ilvsl ) THEN CALL sggbak( 'P', 'L', n, ilo, ihi, work( ileft ), & work( iright ), n, vsl, ldvsl, iinfo ) IF( iinfo /= 0 ) THEN info = n + 7 GO TO 10 END IF END IF IF( ilvsr ) THEN CALL sggbak( 'P', 'R', n, ilo, ihi, work( ileft ), & work( iright ), n, vsr, ldvsr, iinfo ) IF( iinfo /= 0 ) THEN info = n + 8 GO TO 10 END IF END IF ! ! Undo scaling ! IF( ilascl ) THEN CALL slascl( 'H', -1, -1, anrmto, anrm, n, n, a, lda, iinfo ) IF( iinfo /= 0 ) THEN info = n + 9 RETURN END IF CALL slascl( 'G', -1, -1, anrmto, anrm, n, 1, alphar, n, iinfo ) IF( iinfo /= 0 ) THEN info = n + 9 RETURN END IF CALL slascl( 'G', -1, -1, anrmto, anrm, n, 1, alphai, n, iinfo ) IF( iinfo /= 0 ) THEN info = n + 9 RETURN END IF END IF ! IF( ilbscl ) THEN CALL slascl( 'U', -1, -1, bnrmto, bnrm, n, n, b, ldb, iinfo ) IF( iinfo /= 0 ) THEN info = n + 9 RETURN END IF CALL slascl( 'G', -1, -1, bnrmto, bnrm, n, 1, beta, n, iinfo ) IF( iinfo /= 0 ) THEN info = n + 9 RETURN END IF END IF ! 10 CONTINUE work( 1 ) = lwkopt ! RETURN ! ! End of SGEGS ! END SUBROUTINE sgegs SUBROUTINE sgegv( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai, & beta, vl, ldvl, vr, ldvr, 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 (LEN=1), INTENT(IN) :: jobvl CHARACTER (LEN=1), INTENT(IN) :: jobvr INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN) :: ldb REAL, INTENT(IN OUT) :: alphar( * ) REAL, INTENT(IN OUT) :: alphai( * ) REAL, INTENT(IN OUT) :: beta( * ) REAL, INTENT(IN OUT) :: vl( ldvl, * ) INTEGER, INTENT(IN OUT) :: ldvl REAL, INTENT(IN OUT) :: vr( ldvr, * ) INTEGER, INTENT(IN OUT) :: ldvr REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! This routine is deprecated and has been replaced by routine SGGEV. ! ! SGEGV computes for a pair of n-by-n real nonsymmetric matrices A and ! B, the generalized eigenvalues (alphar +/- alphai*i, beta), and ! optionally, the left and/or right generalized eigenvectors (VL and ! VR). ! ! A generalized eigenvalue for a pair of matrices (A,B) is, roughly ! speaking, a scalar w or a ratio alpha/beta = w, such that A - w*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. A good beginning reference is the book, "Matrix ! Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press) ! ! A right generalized eigenvector corresponding to a generalized ! eigenvalue w for a pair of matrices (A,B) is a vector r such ! that (A - w B) r = 0 . A left generalized eigenvector is a vector ! l such that l**H * (A - w B) = 0, where l**H is the ! conjugate-transpose of l. ! ! Note: this routine performs "full balancing" on A and B -- see ! "Further Details", below. ! ! 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) REAL array, dimension (LDA, N) ! On entry, the first of the pair of matrices whose ! generalized eigenvalues and (optionally) generalized ! eigenvectors are to be computed. ! On exit, the contents will have been destroyed. (For a ! description of the contents of A on exit, see "Further ! Details", below.) ! ! LDA (input) INTEGER ! The leading dimension of A. LDA >= max(1,N). ! ! B (input/output) REAL array, dimension (LDB, N) ! On entry, the second of the pair of matrices whose ! generalized eigenvalues and (optionally) generalized ! eigenvectors are to be computed. ! On exit, the contents will have been destroyed. (For a ! description of the contents of B on exit, see "Further ! Details", below.) ! ! LDB (input) INTEGER ! The leading dimension of B. LDB >= max(1,N). ! ! ALPHAR (output) REAL array, dimension (N) ! ALPHAI (output) REAL array, dimension (N) ! BETA (output) REAL array, dimension (N) ! On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will ! be the generalized eigenvalues. If ALPHAI(j) is zero, then ! the j-th eigenvalue is real; if positive, then the j-th and ! (j+1)-st eigenvalues are a complex conjugate pair, with ! ALPHAI(j+1) negative. ! ! Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(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, ALPHAR and ALPHAI 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) REAL array, dimension (LDVL,N) ! If JOBVL = 'V', the left generalized eigenvectors. (See ! "Purpose", above.) Real eigenvectors take one column, ! complex take two columns, the first for the real part and ! the second for the imaginary part. Complex eigenvectors ! correspond to an eigenvalue with positive imaginary part. ! Each eigenvector will be scaled so the largest component ! will have abs(real part) + abs(imag. part) = 1, *except* ! that for eigenvalues with alpha=beta=0, a zero vector will ! be returned as the corresponding eigenvector. ! 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) REAL array, dimension (LDVR,N) ! If JOBVR = 'V', the right generalized eigenvectors. (See ! "Purpose", above.) Real eigenvectors take one column, ! complex take two columns, the first for the real part and ! the second for the imaginary part. Complex eigenvectors ! correspond to an eigenvalue with positive imaginary part. ! Each eigenvector will be scaled so the largest component ! will have abs(real part) + abs(imag. part) = 1, *except* ! that for eigenvalues with alpha=beta=0, a zero vector will ! be returned as the corresponding eigenvector. ! 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) REAL 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,8*N). ! For good performance, LWORK must generally be larger. ! To compute the optimal value of LWORK, call ILAENV to get ! blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute: ! NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR; ! The optimal LWORK is: ! 2*N + MAX( 6*N, N*(NB+1) ). ! ! 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. ! = 1,...,N: ! The QZ iteration failed. No eigenvectors have been ! calculated, but ALPHAR(j), ALPHAI(j), and BETA(j) ! should be correct for j=INFO+1,...,N. ! > N: errors that usually indicate LAPACK problems: ! =N+1: error return from SGGBAL ! =N+2: error return from SGEQRF ! =N+3: error return from SORMQR ! =N+4: error return from SORGQR ! =N+5: error return from SGGHRD ! =N+6: error return from SHGEQZ (other than failed ! iteration) ! =N+7: error return from STGEVC ! =N+8: error return from SGGBAK (computing VL) ! =N+9: error return from SGGBAK (computing VR) ! =N+10: error return from SLASCL (various calls) ! ! Further Details ! =============== ! ! Balancing ! --------- ! ! This driver calls SGGBAL to both permute and scale rows and columns ! of A and B. The permutations PL and PR are chosen so that PL*A*PR ! and PL*B*R will be upper triangular except for the diagonal blocks ! A(i:j,i:j) and B(i:j,i:j), with i and j as close together as ! possible. The diagonal scaling matrices DL and DR are chosen so ! that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to ! one (except for the elements that start out zero.) ! ! After the eigenvalues and eigenvectors of the balanced matrices ! have been computed, SGGBAK transforms the eigenvectors back to what ! they would have been (in perfect arithmetic) if they had not been ! balanced. ! ! Contents of A and B on Exit ! -------- -- - --- - -- ---- ! ! If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or ! both), then on exit the arrays A and B will contain the real Schur ! form[*] of the "balanced" versions of A and B. If no eigenvectors ! are computed, then only the diagonal blocks will be correct. ! ! [*] See SHGEQZ, SGEGS, or read the book "Matrix Computations", ! by Golub & van Loan, pub. by Johns Hopkins U. Press. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: ilimit, ilv, ilvl, ilvr, lquery CHARACTER (LEN=1) :: chtemp INTEGER :: icols, ihi, iinfo, ijobvl, ijobvr, ileft, ilo, & in, iright, irows, itau, iwork, jc, jr, lopt, & lwkmin, lwkopt, nb, nb1, nb2, nb3 REAL :: absai, absar, absb, anrm, anrm1, anrm2, bnrm, & bnrm1, bnrm2, eps, onepls, safmax, safmin, salfai, salfar, sbeta, scale, temp ! .. ! .. Local Arrays .. LOGICAL :: ldumma( 1 ) ! .. ! .. External Subroutines .. EXTERNAL sgeqrf, sggbak, sggbal, sgghrd, shgeqz, slacpy, & slascl, slaset, sorgqr, sormqr, stgevc, xerbla ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slange EXTERNAL ilaenv, lsame, slamch, slange ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, INT, MAX ! .. ! .. 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 ! lwkmin = MAX( 8*n, 1 ) lwkopt = lwkmin work( 1 ) = lwkopt lquery = ( lwork == -1 ) info = 0 IF( ijobvl <= 0 ) THEN info = -1 ELSE IF( ijobvr <= 0 ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldvl < 1 .OR. ( ilvl .AND. ldvl < n ) ) THEN info = -12 ELSE IF( ldvr < 1 .OR. ( ilvr .AND. ldvr < n ) ) THEN info = -14 ELSE IF( lwork < lwkmin .AND. .NOT.lquery ) THEN info = -16 END IF ! IF( info == 0 ) THEN nb1 = ilaenv( 1, 'SGEQRF', ' ', n, n, -1, -1 ) nb2 = ilaenv( 1, 'SORMQR', ' ', n, n, n, -1 ) nb3 = ilaenv( 1, 'SORGQR', ' ', n, n, n, -1 ) nb = MAX( nb1, nb2, nb3 ) lopt = 2*n + MAX( 6*n, n*(nb+1) ) work( 1 ) = lopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SGEGV ', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Get machine constants ! eps = slamch( 'E' )*slamch( 'B' ) safmin = slamch( 'S' ) safmin = safmin + safmin safmax = one / safmin onepls = one + ( 4*eps ) ! ! Scale A ! anrm = slange( 'M', n, n, a, lda, work ) anrm1 = anrm anrm2 = one IF( anrm < one ) THEN IF( safmax*anrm < one ) THEN anrm1 = safmin anrm2 = safmax*anrm END IF END IF ! IF( anrm > zero ) THEN CALL slascl( 'G', -1, -1, anrm, one, n, n, a, lda, iinfo ) IF( iinfo /= 0 ) THEN info = n + 10 RETURN END IF END IF ! ! Scale B ! bnrm = slange( 'M', n, n, b, ldb, work ) bnrm1 = bnrm bnrm2 = one IF( bnrm < one ) THEN IF( safmax*bnrm < one ) THEN bnrm1 = safmin bnrm2 = safmax*bnrm END IF END IF ! IF( bnrm > zero ) THEN CALL slascl( 'G', -1, -1, bnrm, one, n, n, b, ldb, iinfo ) IF( iinfo /= 0 ) THEN info = n + 10 RETURN END IF END IF ! ! Permute the matrix to make it more nearly triangular ! Workspace layout: (8*N words -- "work" requires 6*N words) ! left_permutation, right_permutation, work... ! ileft = 1 iright = n + 1 iwork = iright + n CALL sggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ), & work( iright ), work( iwork ), iinfo ) IF( iinfo /= 0 ) THEN info = n + 1 GO TO 120 END IF ! ! Reduce B to triangular form, and initialize VL and/or VR ! Workspace layout: ("work..." must have at least N words) ! left_permutation, right_permutation, tau, work... ! irows = ihi + 1 - ilo IF( ilv ) THEN icols = n + 1 - ilo ELSE icols = irows END IF itau = iwork iwork = itau + irows CALL sgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ), & work( iwork ), lwork+1-iwork, iinfo ) IF( iinfo >= 0 ) lwkopt = MAX( lwkopt, INT( work( iwork ) )+iwork-1 ) IF( iinfo /= 0 ) THEN info = n + 2 GO TO 120 END IF ! CALL sormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb, & work( itau ), a( ilo, ilo ), lda, work( iwork ), lwork+1-iwork, iinfo ) IF( iinfo >= 0 ) lwkopt = MAX( lwkopt, INT( work( iwork ) )+iwork-1 ) IF( iinfo /= 0 ) THEN info = n + 3 GO TO 120 END IF ! IF( ilvl ) THEN CALL slaset( 'Full', n, n, zero, one, vl, ldvl ) CALL slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb, & vl( ilo+1, ilo ), ldvl ) CALL sorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl, & work( itau ), work( iwork ), lwork+1-iwork, iinfo ) IF( iinfo >= 0 ) lwkopt = MAX( lwkopt, INT( work( iwork ) )+iwork-1 ) IF( iinfo /= 0 ) THEN info = n + 4 GO TO 120 END IF END IF ! IF( ilvr ) CALL slaset( 'Full', n, n, zero, one, vr, ldvr ) ! ! Reduce to generalized Hessenberg form ! IF( ilv ) THEN ! ! Eigenvectors requested -- work on whole matrix. ! CALL sgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl, & ldvl, vr, ldvr, iinfo ) ELSE CALL sgghrd( 'N', 'N', irows, 1, irows, a( ilo, ilo ), lda, & b( ilo, ilo ), ldb, vl, ldvl, vr, ldvr, iinfo ) END IF IF( iinfo /= 0 ) THEN info = n + 5 GO TO 120 END IF ! ! Perform QZ algorithm ! Workspace layout: ("work..." must have at least 1 word) ! left_permutation, right_permutation, work... ! iwork = itau IF( ilv ) THEN chtemp = 'S' ELSE chtemp = 'E' END IF CALL shgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, & alphar, alphai, beta, vl, ldvl, vr, ldvr, & work( iwork ), lwork+1-iwork, iinfo ) IF( iinfo >= 0 ) lwkopt = MAX( lwkopt, INT( work( iwork ) )+iwork-1 ) IF( iinfo /= 0 ) THEN IF( iinfo > 0 .AND. iinfo <= n ) THEN info = iinfo ELSE IF( iinfo > n .AND. iinfo <= 2*n ) THEN info = iinfo - n ELSE info = n + 6 END IF GO TO 120 END IF ! IF( ilv ) THEN ! ! Compute Eigenvectors (STGEVC requires 6*N words of workspace) ! IF( ilvl ) THEN IF( ilvr ) THEN chtemp = 'B' ELSE chtemp = 'L' END IF ELSE chtemp = 'R' END IF ! CALL stgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl, & vr, ldvr, n, in, work( iwork ), iinfo ) IF( iinfo /= 0 ) THEN info = n + 7 GO TO 120 END IF ! ! Undo balancing on VL and VR, rescale ! IF( ilvl ) THEN CALL sggbak( 'P', 'L', n, ilo, ihi, work( ileft ), & work( iright ), n, vl, ldvl, iinfo ) IF( iinfo /= 0 ) THEN info = n + 8 GO TO 120 END IF DO jc = 1, n IF( alphai( jc ) < zero ) CYCLE temp = zero IF( alphai( jc ) == zero ) THEN DO jr = 1, n temp = MAX( temp, ABS( vl( jr, jc ) ) ) END DO ELSE DO jr = 1, n temp = MAX( temp, ABS( vl( jr, jc ) )+ ABS( vl( jr, jc+1 ) ) ) END DO END IF IF( temp < safmin ) CYCLE temp = one / temp IF( alphai( jc ) == zero ) THEN DO jr = 1, n vl( jr, jc ) = vl( jr, jc )*temp END DO ELSE DO jr = 1, n vl( jr, jc ) = vl( jr, jc )*temp vl( jr, jc+1 ) = vl( jr, jc+1 )*temp END DO END IF END DO END IF IF( ilvr ) THEN CALL sggbak( 'P', 'R', n, ilo, ihi, work( ileft ), & work( iright ), n, vr, ldvr, iinfo ) IF( iinfo /= 0 ) THEN info = n + 9 GO TO 120 END IF DO jc = 1, n IF( alphai( jc ) < zero ) CYCLE temp = zero IF( alphai( jc ) == zero ) THEN DO jr = 1, n temp = MAX( temp, ABS( vr( jr, jc ) ) ) END DO ELSE DO jr = 1, n temp = MAX( temp, ABS( vr( jr, jc ) )+ ABS( vr( jr, jc+1 ) ) ) END DO END IF IF( temp < safmin ) CYCLE temp = one / temp IF( alphai( jc ) == zero ) THEN DO jr = 1, n vr( jr, jc ) = vr( jr, jc )*temp END DO ELSE DO jr = 1, n vr( jr, jc ) = vr( jr, jc )*temp vr( jr, jc+1 ) = vr( jr, jc+1 )*temp END DO END IF END DO END IF ! ! End of eigenvector calculation ! END IF ! ! Undo scaling in alpha, beta ! ! Note: this does not give the alpha and beta for the unscaled ! problem. ! ! Un-scaling is limited to avoid underflow in alpha and beta ! if they are significant. ! DO jc = 1, n absar = ABS( alphar( jc ) ) absai = ABS( alphai( jc ) ) absb = ABS( beta( jc ) ) salfar = anrm*alphar( jc ) salfai = anrm*alphai( jc ) sbeta = bnrm*beta( jc ) ilimit = .false. scale = one ! ! Check for significant underflow in ALPHAI ! IF( ABS( salfai ) < safmin .AND. absai >= & MAX( safmin, eps*absar, eps*absb ) ) THEN ilimit = .true. scale = ( onepls*safmin / anrm1 ) / MAX( onepls*safmin, anrm2*absai ) ! ELSE IF( salfai == zero ) THEN ! ! If insignificant underflow in ALPHAI, then make the ! conjugate eigenvalue real. ! IF( alphai( jc ) < zero .AND. jc > 1 ) THEN alphai( jc-1 ) = zero ELSE IF( alphai( jc ) > zero .AND. jc < n ) THEN alphai( jc+1 ) = zero END IF END IF ! ! Check for significant underflow in ALPHAR ! IF( ABS( salfar ) < safmin .AND. absar >= & MAX( safmin, eps*absai, eps*absb ) ) THEN ilimit = .true. scale = MAX( scale, ( onepls*safmin / anrm1 ) / & MAX( onepls*safmin, anrm2*absar ) ) END IF ! ! Check for significant underflow in BETA ! IF( ABS( sbeta ) < safmin .AND. absb >= & MAX( safmin, eps*absar, eps*absai ) ) THEN ilimit = .true. scale = MAX( scale, ( onepls*safmin / bnrm1 ) / & MAX( onepls*safmin, bnrm2*absb ) ) END IF ! ! Check for possible overflow when limiting scaling ! IF( ilimit ) THEN temp = ( scale*safmin )*MAX( ABS( salfar ), ABS( salfai ), ABS( sbeta ) ) IF( temp > one ) scale = scale / temp IF( scale < one ) ilimit = .false. END IF ! ! Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary. ! IF( ilimit ) THEN salfar = ( scale*alphar( jc ) )*anrm salfai = ( scale*alphai( jc ) )*anrm sbeta = ( scale*beta( jc ) )*bnrm END IF alphar( jc ) = salfar alphai( jc ) = salfai beta( jc ) = sbeta END DO ! 120 CONTINUE work( 1 ) = lwkopt ! RETURN ! ! End of SGEGV ! END SUBROUTINE sgegv SUBROUTINE sgehd2( n, ilo, ihi, 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 ! October 31, 1992 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: ilo INTEGER, INTENT(IN) :: ihi REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGEHD2 reduces a real general matrix A to upper Hessenberg form H by ! an orthogonal similarity transformation: Q' * A * Q = H . ! ! Arguments ! ========= ! ! N (input) INTEGER ! The order of the matrix A. 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 SGEBAL; otherwise they should be ! set to 1 and N respectively. See Further Details. ! 1 <= ILO <= IHI <= max(1,N). ! ! A (input/output) REAL 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 ! 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). ! ! TAU (output) REAL array, dimension (N-1) ! The scalar factors of the elementary reflectors (see Further ! Details). ! ! WORK (workspace) REAL 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 (ihi-ilo) elementary ! reflectors ! ! Q = H(ilo) H(ilo+1) . . . H(ihi-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, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on ! exit in A(i+2:ihi,i), and tau in TAU(i). ! ! The contents of A are illustrated by the following example, with ! n = 7, ilo = 2 and ihi = 6: ! ! on entry, on exit, ! ! ( a a a a a a a ) ( a a h h h h a ) ! ( a a a a a a ) ( a h h h h a ) ! ( a a a a a a ) ( h h h h h h ) ! ( a a a a a a ) ( v2 h h h h h ) ! ( a a a a a a ) ( v2 v3 h h h h ) ! ( a a a a a a ) ( v2 v3 v4 h h h ) ! ( a ) ( a ) ! ! where a denotes an element of the original matrix A, h denotes a ! modified element of the upper Hessenberg matrix H, and vi denotes an ! element of the vector defining H(i). ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i REAL :: aii ! .. ! .. External Subroutines .. EXTERNAL slarf, slarfg, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters ! info = 0 IF( n < 0 ) THEN info = -1 ELSE IF( ilo < 1 .OR. ilo > MAX( 1, n ) ) THEN info = -2 ELSE IF( ihi < MIN( ilo, n ) .OR. ihi > n ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGEHD2', -info ) RETURN END IF ! DO i = ilo, ihi - 1 ! ! Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) ! CALL slarfg( ihi-i, a( i+1, i ), a( MIN( i+2, n ), i ), 1, tau( i ) ) aii = a( i+1, i ) a( i+1, i ) = one ! ! Apply H(i) to A(1:ihi,i+1:ihi) from the right ! CALL slarf( 'Right', ihi, ihi-i, a( i+1, i ), 1, tau( i ), & a( 1, i+1 ), lda, work ) ! ! Apply H(i) to A(i+1:ihi,i+1:n) from the left ! CALL slarf( 'Left', ihi-i, n-i, a( i+1, i ), 1, tau( i ), & a( i+1, i+1 ), lda, work ) ! a( i+1, i ) = aii END DO ! RETURN ! ! End of SGEHD2 ! END SUBROUTINE sgehd2 SUBROUTINE sgehrd( n, ilo, ihi, 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, INTENT(IN) :: n INTEGER, INTENT(IN) :: ilo INTEGER, INTENT(IN) :: ihi REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: tau( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGEHRD reduces a real general matrix A to upper Hessenberg form H by ! an orthogonal similarity transformation: Q' * A * Q = H . ! ! Arguments ! ========= ! ! N (input) INTEGER ! The order of the matrix A. 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 SGEBAL; otherwise they should be ! set to 1 and N respectively. See Further Details. ! 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. ! ! A (input/output) REAL 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 ! 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). ! ! TAU (output) REAL array, dimension (N-1) ! The scalar factors of the elementary reflectors (see Further ! Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to ! zero. ! ! WORK (workspace/output) REAL 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,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 (ihi-ilo) elementary ! reflectors ! ! Q = H(ilo) H(ilo+1) . . . H(ihi-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, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on ! exit in A(i+2:ihi,i), and tau in TAU(i). ! ! The contents of A are illustrated by the following example, with ! n = 7, ilo = 2 and ihi = 6: ! ! on entry, on exit, ! ! ( a a a a a a a ) ( a a h h h h a ) ! ( a a a a a a ) ( a h h h h a ) ! ( a a a a a a ) ( h h h h h h ) ! ( a a a a a a ) ( v2 h h h h h ) ! ( a a a a a a ) ( v2 v3 h h h h ) ! ( a a a a a a ) ( v2 v3 v4 h h h ) ! ( a ) ( a ) ! ! where a denotes an element of the original matrix A, h denotes a ! modified element of the upper Hessenberg matrix H, and vi denotes an ! element of the vector defining H(i). ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: nbmax = 64 INTEGER, PARAMETER :: ldt = nbmax+1 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: i, ib, iinfo, iws, ldwork, lwkopt, nb, nbmin, nh, nx REAL :: ei ! .. ! .. Local Arrays .. REAL :: t( ldt, nbmax ) ! .. ! .. External Subroutines .. EXTERNAL sgehd2, sgemm, slahrd, slarfb, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Executable Statements .. ! ! Test the input parameters ! info = 0 nb = MIN( nbmax, ilaenv( 1, 'SGEHRD', ' ', n, ilo, ihi, -1 ) ) lwkopt = n*nb work( 1 ) = lwkopt lquery = ( lwork == -1 ) IF( n < 0 ) THEN info = -1 ELSE IF( ilo < 1 .OR. ilo > MAX( 1, n ) ) THEN info = -2 ELSE IF( ihi < MIN( ilo, n ) .OR. ihi > n ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( lwork < MAX( 1, n ) .AND. .NOT.lquery ) THEN info = -8 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGEHRD', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Set elements 1:ILO-1 and IHI:N-1 of TAU to zero ! DO i = 1, ilo - 1 tau( i ) = zero END DO DO i = MAX( 1, ihi ), n - 1 tau( i ) = zero END DO ! ! Quick return if possible ! nh = ihi - ilo + 1 IF( nh <= 1 ) THEN work( 1 ) = 1 RETURN END IF ! ! Determine the block size. ! nb = MIN( nbmax, ilaenv( 1, 'SGEHRD', ' ', n, ilo, ihi, -1 ) ) nbmin = 2 iws = 1 IF( nb > 1 .AND. nb < nh ) THEN ! ! Determine when to cross over from blocked to unblocked code ! (last block is always handled by unblocked code). ! nx = MAX( nb, ilaenv( 3, 'SGEHRD', ' ', n, ilo, ihi, -1 ) ) IF( nx < nh ) THEN ! ! Determine if workspace is large enough for blocked code. ! iws = n*nb IF( lwork < iws ) THEN ! ! Not enough workspace to use optimal NB: determine the ! minimum value of NB, and reduce NB or force use of ! unblocked code. ! nbmin = MAX( 2, ilaenv( 2, 'SGEHRD', ' ', n, ilo, ihi, -1 ) ) IF( lwork >= n*nbmin ) THEN nb = lwork / n ELSE nb = 1 END IF END IF END IF END IF ldwork = n ! IF( nb < nbmin .OR. nb >= nh ) THEN ! ! Use unblocked code below ! i = ilo ! ELSE ! ! Use blocked code ! DO i = ilo, ihi - 1 - nx, nb ib = MIN( nb, ihi-i ) ! ! Reduce columns i:i+ib-1 to Hessenberg form, returning the ! matrices V and T of the block reflector H = I - V*T*V' ! which performs the reduction, and also the matrix Y = A*V*T ! CALL slahrd( ihi, i, ib, a( 1, i ), lda, tau( i ), t, ldt, work, ldwork ) ! ! Apply the block reflector H to A(1:ihi,i+ib:ihi) from the ! right, computing A := A - Y * V'. V(i+ib,ib-1) must be set ! to 1. ! ei = a( i+ib, i+ib-1 ) a( i+ib, i+ib-1 ) = one CALL sgemm( 'No transpose', 'Transpose', ihi, ihi-i-ib+1, & ib, -one, work, ldwork, a( i+ib, i ), lda, one, a( 1, i+ib ), lda ) a( i+ib, i+ib-1 ) = ei ! ! Apply the block reflector H to A(i+1:ihi,i+ib:n) from the ! left ! CALL slarfb( 'Left', 'Transpose', 'Forward', 'Columnwise', & ihi-i, n-i-ib+1, ib, a( i+1, i ), lda, t, ldt, & a( i+1, i+ib ), lda, work, ldwork ) END DO END IF ! ! Use unblocked code to reduce the rest of the matrix ! CALL sgehd2( n, i, ihi, a, lda, tau, work, iinfo ) work( 1 ) = iws ! RETURN ! ! End of SGEHRD ! END SUBROUTINE sgehrd SUBROUTINE sgelq2( 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 ! February 29, 1992 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGELQ2 computes an LQ factorization of a real 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) REAL 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 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,M). ! ! TAU (output) REAL array, dimension (min(M,N)) ! The scalar factors of the elementary reflectors (see Further ! Details). ! ! WORK (workspace) REAL 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 real scalar, and v is a real vector with ! v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), ! and tau in TAU(i). ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, k REAL :: aii ! .. ! .. External Subroutines .. EXTERNAL slarf, slarfg, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, m ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGELQ2', -info ) RETURN END IF ! k = MIN( m, n ) ! DO i = 1, k ! ! Generate elementary reflector H(i) to annihilate A(i,i+1:n) ! CALL slarfg( n-i+1, a( i, i ), a( i, MIN( i+1, n ) ), lda, tau( i ) ) IF( i < m ) THEN ! ! Apply H(i) to A(i+1:m,i:n) from the right ! aii = a( i, i ) a( i, i ) = one CALL slarf( 'Right', m-i, n-i+1, a( i, i ), lda, tau( i ), & a( i+1, i ), lda, work ) a( i, i ) = aii END IF END DO RETURN ! ! End of SGELQ2 ! END SUBROUTINE sgelq2 SUBROUTINE sgelqf( 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGELQF computes an LQ factorization of a real 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) REAL 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 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,M). ! ! TAU (output) REAL array, dimension (min(M,N)) ! The scalar factors of the elementary reflectors (see Further ! Details). ! ! WORK (workspace/output) REAL 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 real scalar, and v is a real vector with ! v(1:i-1) = 0 and v(i) = 1; 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 sgelq2, slarfb, slarft, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 nb = ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) lwkopt = m*nb work( 1 ) = lwkopt lquery = ( lwork == -1 ) IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, m ) ) THEN info = -4 ELSE IF( lwork < MAX( 1, m ) .AND. .NOT.lquery ) THEN info = -7 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGELQF', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! k = MIN( m, n ) IF( k == 0 ) THEN work( 1 ) = 1 RETURN END IF ! nbmin = 2 nx = 0 iws = m IF( nb > 1 .AND. nb < k ) THEN ! ! Determine when to cross over from blocked to unblocked code. ! nx = MAX( 0, ilaenv( 3, 'SGELQF', ' ', m, n, -1, -1 ) ) IF( nx < k ) THEN ! ! Determine if workspace is large enough for blocked code. ! ldwork = m iws = ldwork*nb IF( lwork < 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, 'SGELQF', ' ', m, n, -1, -1 ) ) END IF END IF END IF ! IF( nb >= nbmin .AND. nb < k .AND. nx < k ) THEN ! ! Use blocked code initially ! DO 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 sgelq2( ib, n-i+1, a( i, i ), lda, tau( i ), work, iinfo ) IF( i+ib <= m ) THEN ! ! Form the triangular factor of the block reflector ! H = H(i) H(i+1) . . . H(i+ib-1) ! CALL slarft( '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 slarfb( '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 END DO ELSE i = 1 END IF ! ! Use unblocked code to factor the last or only block. ! IF( i <= k ) CALL sgelq2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work, & iinfo ) ! work( 1 ) = iws RETURN ! ! End of SGELQF ! END SUBROUTINE sgelqf SUBROUTINE sgels( trans, m, n, nrhs, a, lda, b, ldb, 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 (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN) :: ldb REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGELS solves overdetermined or underdetermined real linear systems ! involving an M-by-N matrix A, or its transpose, using a QR or LQ ! factorization of A. It is assumed that A has full rank. ! ! The following options are provided: ! ! 1. If TRANS = 'N' and m >= n: find the least squares solution of ! an overdetermined system, i.e., solve the least squares problem ! minimize || B - A*X ||. ! ! 2. If TRANS = 'N' and m < n: find the minimum norm solution of ! an underdetermined system A * X = B. ! ! 3. If TRANS = 'T' and m >= n: find the minimum norm solution of ! an undetermined system A**T * X = B. ! ! 4. If TRANS = 'T' and m < n: find the least squares solution of ! an overdetermined system, i.e., solve the least squares problem ! minimize || B - A**T * X ||. ! ! Several right hand side vectors b and solution vectors x can be ! handled in a single call; they are stored as the columns of the ! M-by-NRHS right hand side matrix B and the N-by-NRHS solution ! matrix X. ! ! Arguments ! ========= ! ! TRANS (input) CHARACTER ! = 'N': the linear system involves A; ! = 'T': the linear system involves A**T. ! ! 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. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of ! columns of the matrices B and X. NRHS >=0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the M-by-N matrix A. ! On exit, ! if M >= N, A is overwritten by details of its QR ! factorization as returned by SGEQRF; ! if M < N, A is overwritten by details of its LQ ! factorization as returned by SGELQF. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! B (input/output) REAL array, dimension (LDB,NRHS) ! On entry, the matrix B of right hand side vectors, stored ! columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS ! if TRANS = 'T'. ! On exit, B is overwritten by the solution vectors, stored ! columnwise: ! if TRANS = 'N' and m >= n, rows 1 to n of B contain the least ! squares solution vectors; the residual sum of squares for the ! solution in each column is given by the sum of squares of ! elements N+1 to M in that column; ! if TRANS = 'N' and m < n, rows 1 to N of B contain the ! minimum norm solution vectors; ! if TRANS = 'T' and m >= n, rows 1 to M of B contain the ! minimum norm solution vectors; ! if TRANS = 'T' and m < n, rows 1 to M of B contain the ! least squares solution vectors; the residual sum of squares ! for the solution in each column is given by the sum of ! squares of elements M+1 to N in that column. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= MAX(1,M,N). ! ! WORK (workspace/output) REAL 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, MN + max( MN, NRHS ) ). ! For optimal performance, ! LWORK >= max( 1, MN + max( MN, NRHS )*NB ). ! where MN = min(M,N) and NB is the optimum block size. ! ! 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 .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, tpsd INTEGER :: brow, i, iascl, ibscl, j, mn, nb, scllen, wsize REAL :: anrm, bignum, bnrm, smlnum ! .. ! .. Local Arrays .. REAL :: rwork( 1 ) ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slange EXTERNAL lsame, ilaenv, slamch, slange ! .. ! .. External Subroutines .. EXTERNAL sgelqf, sgeqrf, slabad, slascl, slaset, sormlq, & sormqr, strsm, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, REAL ! .. ! .. Executable Statements .. ! ! Test the input arguments. ! info = 0 mn = MIN( m, n ) lquery = ( lwork == -1 ) IF( .NOT.( lsame( trans, 'N' ) .OR. lsame( trans, 'T' ) ) ) THEN info = -1 ELSE IF( m < 0 ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( nrhs < 0 ) THEN info = -4 ELSE IF( lda < MAX( 1, m ) ) THEN info = -6 ELSE IF( ldb < MAX( 1, m, n ) ) THEN info = -8 ELSE IF( lwork < MAX( 1, mn + MAX( mn, nrhs ) ) .AND. & .NOT.lquery ) THEN info = -10 END IF ! ! Figure out optimal block size ! IF( info == 0 .OR. info == -10 ) THEN ! tpsd = .true. IF( lsame( trans, 'N' ) ) tpsd = .false. ! IF( m >= n ) THEN nb = ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) IF( tpsd ) THEN nb = MAX( nb, ilaenv( 1, 'SORMQR', 'LN', m, nrhs, n, -1 ) ) ELSE nb = MAX( nb, ilaenv( 1, 'SORMQR', 'LT', m, nrhs, n, -1 ) ) END IF ELSE nb = ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) IF( tpsd ) THEN nb = MAX( nb, ilaenv( 1, 'SORMLQ', 'LT', n, nrhs, m, -1 ) ) ELSE nb = MAX( nb, ilaenv( 1, 'SORMLQ', 'LN', n, nrhs, m, -1 ) ) END IF END IF ! wsize = MAX( 1, mn + MAX( mn, nrhs )*nb ) work( 1 ) = REAL( wsize ) ! END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SGELS ', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( MIN( m, n, nrhs ) == 0 ) THEN CALL slaset( 'Full', MAX( m, n ), nrhs, zero, zero, b, ldb ) RETURN END IF ! ! Get machine parameters ! smlnum = slamch( 'S' ) / slamch( 'P' ) bignum = one / smlnum CALL slabad( smlnum, bignum ) ! ! Scale A, B if max element outside range [SMLNUM,BIGNUM] ! anrm = slange( 'M', m, n, a, lda, rwork ) iascl = 0 IF( anrm > zero .AND. anrm < smlnum ) THEN ! ! Scale matrix norm up to SMLNUM ! CALL slascl( 'G', 0, 0, anrm, smlnum, m, n, a, lda, info ) iascl = 1 ELSE IF( anrm > bignum ) THEN ! ! Scale matrix norm down to BIGNUM ! CALL slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) iascl = 2 ELSE IF( anrm == zero ) THEN ! ! Matrix all zero. Return zero solution. ! CALL slaset( 'F', MAX( m, n ), nrhs, zero, zero, b, ldb ) GO TO 50 END IF ! brow = m IF( tpsd ) brow = n bnrm = slange( 'M', brow, nrhs, b, ldb, rwork ) ibscl = 0 IF( bnrm > zero .AND. bnrm < smlnum ) THEN ! ! Scale matrix norm up to SMLNUM ! CALL slascl( 'G', 0, 0, bnrm, smlnum, brow, nrhs, b, ldb, info ) ibscl = 1 ELSE IF( bnrm > bignum ) THEN ! ! Scale matrix norm down to BIGNUM ! CALL slascl( 'G', 0, 0, bnrm, bignum, brow, nrhs, b, ldb, info ) ibscl = 2 END IF ! IF( m >= n ) THEN ! ! compute QR factorization of A ! CALL sgeqrf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn, info ) ! ! workspace at least N, optimally N*NB ! IF( .NOT.tpsd ) THEN ! ! Least-Squares Problem min || A * X - B || ! ! B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) ! CALL sormqr( 'Left', 'Transpose', m, nrhs, n, a, lda, & work( 1 ), b, ldb, work( mn+1 ), lwork-mn, info ) ! ! workspace at least NRHS, optimally NRHS*NB ! ! B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) ! CALL strsm( 'Left', 'Upper', 'No transpose', 'Non-unit', n, & nrhs, one, a, lda, b, ldb ) ! scllen = n ! ELSE ! ! Overdetermined system of equations A' * X = B ! ! B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) ! CALL strsm( 'Left', 'Upper', 'Transpose', 'Non-unit', n, & nrhs, one, a, lda, b, ldb ) ! ! B(N+1:M,1:NRHS) = ZERO ! DO j = 1, nrhs DO i = n + 1, m b( i, j ) = zero END DO END DO ! ! B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) ! CALL sormqr( 'Left', 'No transpose', m, nrhs, n, a, lda, & work( 1 ), b, ldb, work( mn+1 ), lwork-mn, info ) ! ! workspace at least NRHS, optimally NRHS*NB ! scllen = m ! END IF ! ELSE ! ! Compute LQ factorization of A ! CALL sgelqf( m, n, a, lda, work( 1 ), work( mn+1 ), lwork-mn, info ) ! ! workspace at least M, optimally M*NB. ! IF( .NOT.tpsd ) THEN ! ! underdetermined system of equations A * X = B ! ! B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) ! CALL strsm( 'Left', 'Lower', 'No transpose', 'Non-unit', m, & nrhs, one, a, lda, b, ldb ) ! ! B(M+1:N,1:NRHS) = 0 ! DO j = 1, nrhs DO i = m + 1, n b( i, j ) = zero END DO END DO ! ! B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) ! CALL sormlq( 'Left', 'Transpose', n, nrhs, m, a, lda, & work( 1 ), b, ldb, work( mn+1 ), lwork-mn, info ) ! ! workspace at least NRHS, optimally NRHS*NB ! scllen = n ! ELSE ! ! overdetermined system min || A' * X - B || ! ! B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) ! CALL sormlq( 'Left', 'No transpose', n, nrhs, m, a, lda, & work( 1 ), b, ldb, work( mn+1 ), lwork-mn, info ) ! ! workspace at least NRHS, optimally NRHS*NB ! ! B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) ! CALL strsm( 'Left', 'Lower', 'Transpose', 'Non-unit', m, & nrhs, one, a, lda, b, ldb ) ! scllen = m ! END IF ! END IF ! ! Undo scaling ! IF( iascl == 1 ) THEN CALL slascl( 'G', 0, 0, anrm, smlnum, scllen, nrhs, b, ldb, info ) ELSE IF( iascl == 2 ) THEN CALL slascl( 'G', 0, 0, anrm, bignum, scllen, nrhs, b, ldb, info ) END IF IF( ibscl == 1 ) THEN CALL slascl( 'G', 0, 0, smlnum, bnrm, scllen, nrhs, b, ldb, info ) ELSE IF( ibscl == 2 ) THEN CALL slascl( 'G', 0, 0, bignum, bnrm, scllen, nrhs, b, ldb, info ) END IF ! 50 CONTINUE work( 1 ) = REAL( wsize ) ! RETURN ! ! End of SGELS ! END SUBROUTINE sgels SUBROUTINE sgelsd( m, n, nrhs, a, lda, b, ldb, s, rcond, & rank, work, lwork, iwork, 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 .. INTEGER, INTENT(IN OUT) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: nrhs REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN) :: ldb REAL, INTENT(IN OUT) :: s( * ) REAL, INTENT(IN OUT) :: rcond INTEGER, INTENT(OUT) :: rank REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGELSD computes the minimum-norm solution to a real linear least ! squares problem: ! minimize 2-norm(| b - A*x |) ! using the singular value decomposition (SVD) of A. A is an M-by-N ! matrix which may be rank-deficient. ! ! Several right hand side vectors b and solution vectors x can be ! handled in a single call; they are stored as the columns of the ! M-by-NRHS right hand side matrix B and the N-by-NRHS solution ! matrix X. ! ! The problem is solved in three steps: ! (1) Reduce the coefficient matrix A to bidiagonal form with ! Householder transformations, reducing the original problem ! into a "bidiagonal least squares problem" (BLS) ! (2) Solve the BLS using a divide and conquer approach. ! (3) Apply back all the Householder tranformations to solve ! the original least squares problem. ! ! The effective rank of A is determined by treating as zero those ! singular values which are less than RCOND times the largest singular ! value. ! ! The divide and conquer algorithm makes very mild assumptions about ! floating point arithmetic. It will work on machines with a guard ! digit in add/subtract, or on those binary machines without guard ! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or ! Cray-2. It could conceivably fail on hexadecimal or decimal machines ! without guard digits, but we know of none. ! ! Arguments ! ========= ! ! M (input) INTEGER ! The number of rows of A. M >= 0. ! ! N (input) INTEGER ! The number of columns of A. N >= 0. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of columns ! of the matrices B and X. NRHS >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the M-by-N matrix A. ! On exit, the first min(m,n) rows of A are overwritten with ! its right singular vectors, stored rowwise. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! B (input/output) REAL array, dimension (LDB,NRHS) ! On entry, the M-by-NRHS right hand side matrix B. ! On exit, B is overwritten by the N-by-NRHS solution ! matrix X. If m >= n and RANK = n, the residual ! sum-of-squares for the solution in the i-th column is given ! by the sum of squares of elements n+1:m in that column. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,max(M,N)). ! ! S (output) REAL array, dimension (min(M,N)) ! The singular values of A in decreasing order. ! The condition number of A in the 2-norm = S(1)/S(min(m,n)). ! ! RCOND (input) REAL ! RCOND is used to determine the effective rank of A. ! Singular values S(i) <= RCOND*S(1) are treated as zero. ! If RCOND < 0, machine precision is used instead. ! ! RANK (output) INTEGER ! The effective rank of A, i.e., the number of singular values ! which are greater than RCOND*S(1). ! ! WORK (workspace/output) REAL 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. ! The exact minimum amount of workspace needed depends on M, ! N and NRHS. ! If M >= N, LWORK >= 11*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS. ! If M < N, LWORK >= 11*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS. ! SMLSIZ is returned by ILAENV and is equal to the maximum ! size of the subproblems at the bottom of the computation ! tree (usually about 25), and ! NLVL = INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ! 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. ! ! IWORK (workspace) INTEGER array, dimension (LIWORK) ! LIWORK >= 3 * MINMN * NLVL + 11 * MINMN, ! where MINMN = MIN( M,N ). ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: the algorithm for computing the SVD failed to converge; ! if INFO = i, i off-diagonal elements of an intermediate ! bidiagonal form did not converge to zero. ! ! Further Details ! =============== ! ! Based on contributions by ! Ming Gu and Ren-Cang Li, Computer Science Division, University of ! California at Berkeley, USA ! Osni Marques, LBNL/NERSC, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 ! .. ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: iascl, ibscl, ie, il, itau, itaup, itauq, & ldwork, maxmn, maxwrk, minmn, minwrk, mm, mnthr, nlvl, nwork, smlsiz REAL :: anrm, bignum, bnrm, eps, sfmin, smlnum ! .. ! .. External Subroutines .. EXTERNAL sgebrd, sgelqf, sgeqrf, slabad, slacpy, slalsd, & slascl, slaset, sormbr, sormlq, sormqr, xerbla ! .. ! .. External Functions .. INTEGER :: ilaenv REAL :: slamch, slange EXTERNAL slamch, slange, ilaenv ! .. ! .. Intrinsic Functions .. INTRINSIC REAL, INT, LOG, MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input arguments. ! info = 0 minmn = MIN( m, n ) maxmn = MAX( m, n ) mnthr = ilaenv( 6, 'SGELSD', ' ', m, n, nrhs, -1 ) lquery = ( lwork == -1 ) IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, m ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, maxmn ) ) THEN info = -7 END IF ! smlsiz = ilaenv( 9, 'SGELSD', ' ', 0, 0, 0, 0 ) ! ! 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.) ! minwrk = 1 minmn = MAX( 1, minmn ) nlvl = INT( LOG( REAL( minmn ) / REAL( smlsiz+1 ) ) / LOG( two ) ) + 1 ! IF( info == 0 ) THEN maxwrk = 0 mm = m IF( m >= n .AND. m >= mnthr ) THEN ! ! Path 1a - overdetermined, with many more rows than columns. ! mm = n maxwrk = MAX( maxwrk, n+n*ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) ) maxwrk = MAX( maxwrk, n+nrhs* & ilaenv( 1, 'SORMQR', 'LT', m, nrhs, n, -1 ) ) END IF IF( m >= n ) THEN ! ! Path 1 - overdetermined or exactly determined. ! maxwrk = MAX( maxwrk, 3*n+( mm+n )* & ilaenv( 1, 'SGEBRD', ' ', mm, n, -1, -1 ) ) maxwrk = MAX( maxwrk, 3*n+nrhs* & ilaenv( 1, 'SORMBR', 'QLT', mm, nrhs, n, -1 ) ) maxwrk = MAX( maxwrk, 3*n+( n-1 )* & ilaenv( 1, 'SORMBR', 'PLN', n, nrhs, n, -1 ) ) maxwrk = MAX( maxwrk, 3*n+8*n+2*n*smlsiz+8*n*nlvl+n*nrhs ) minwrk = MAX( 3*n+mm, 3*n+nrhs, 3*n+8*n+2*n*smlsiz+8*n*nlvl+n*nrhs ) END IF IF( n > m ) THEN IF( n >= mnthr ) THEN ! ! Path 2a - underdetermined, with many more columns ! than rows. ! maxwrk = m + m*ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) maxwrk = MAX( maxwrk, m*m+4*m+2*m* & ilaenv( 1, 'SGEBRD', ' ', m, m, -1, -1 ) ) maxwrk = MAX( maxwrk, m*m+4*m+nrhs* & ilaenv( 1, 'SORMBR', 'QLT', m, nrhs, m, -1 ) ) maxwrk = MAX( maxwrk, m*m+4*m+( m-1 )* & ilaenv( 1, 'SORMBR', 'PLN', m, nrhs, m, -1 ) ) IF( nrhs > 1 ) THEN maxwrk = MAX( maxwrk, m*m+m+m*nrhs ) ELSE maxwrk = MAX( maxwrk, m*m+2*m ) END IF maxwrk = MAX( maxwrk, m+nrhs* & ilaenv( 1, 'SORMLQ', 'LT', n, nrhs, m, -1 ) ) maxwrk = MAX( maxwrk, m*m+4*m+8*m+2*m*smlsiz+8*m*nlvl+m* nrhs ) ELSE ! ! Path 2 - remaining underdetermined cases. ! maxwrk = 3*m + ( n+m )*ilaenv( 1, 'SGEBRD', ' ', m, n, -1, -1 ) maxwrk = MAX( maxwrk, 3*m+nrhs* & ilaenv( 1, 'SORMBR', 'QLT', m, nrhs, n, -1 ) ) maxwrk = MAX( maxwrk, 3*m+m* & ilaenv( 1, 'SORMBR', 'PLN', n, nrhs, m, -1 ) ) maxwrk = MAX( maxwrk, 3*m+8*m+2*m*smlsiz+8*m*nlvl+m* nrhs ) END IF minwrk = MAX( 3*m+nrhs, 3*m+m, 3*m+8*m+2*m*smlsiz+8*m*nlvl+m*nrhs ) END IF minwrk = MIN( minwrk, maxwrk ) work( 1 ) = maxwrk IF( lwork < minwrk .AND. .NOT.lquery ) THEN info = -12 END IF END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SGELSD', -info ) RETURN ELSE IF( lquery ) THEN GO TO 10 END IF ! ! Quick return if possible. ! IF( m == 0 .OR. n == 0 ) THEN rank = 0 RETURN END IF ! ! Get machine parameters. ! eps = slamch( 'P' ) sfmin = slamch( 'S' ) smlnum = sfmin / eps bignum = one / smlnum CALL slabad( smlnum, bignum ) ! ! Scale A if max entry outside range [SMLNUM,BIGNUM]. ! anrm = slange( 'M', m, n, a, lda, work ) iascl = 0 IF( anrm > zero .AND. anrm < smlnum ) THEN ! ! Scale matrix norm up to SMLNUM. ! CALL slascl( 'G', 0, 0, anrm, smlnum, m, n, a, lda, info ) iascl = 1 ELSE IF( anrm > bignum ) THEN ! ! Scale matrix norm down to BIGNUM. ! CALL slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) iascl = 2 ELSE IF( anrm == zero ) THEN ! ! Matrix all zero. Return zero solution. ! CALL slaset( 'F', MAX( m, n ), nrhs, zero, zero, b, ldb ) CALL slaset( 'F', minmn, 1, zero, zero, s, 1 ) rank = 0 GO TO 10 END IF ! ! Scale B if max entry outside range [SMLNUM,BIGNUM]. ! bnrm = slange( 'M', m, nrhs, b, ldb, work ) ibscl = 0 IF( bnrm > zero .AND. bnrm < smlnum ) THEN ! ! Scale matrix norm up to SMLNUM. ! CALL slascl( 'G', 0, 0, bnrm, smlnum, m, nrhs, b, ldb, info ) ibscl = 1 ELSE IF( bnrm > bignum ) THEN ! ! Scale matrix norm down to BIGNUM. ! CALL slascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) ibscl = 2 END IF ! ! If M < N make sure certain entries of B are zero. ! IF( m < n ) CALL slaset( 'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb ) ! ! Overdetermined case. ! IF( m >= n ) THEN ! ! Path 1 - overdetermined or exactly determined. ! mm = m IF( m >= mnthr ) THEN ! ! Path 1a - overdetermined, with many more rows than columns. ! mm = n itau = 1 nwork = itau + n ! ! Compute A=Q*R. ! (Workspace: need 2*N, prefer N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), work( nwork ), & lwork-nwork+1, info ) ! ! Multiply B by transpose(Q). ! (Workspace: need N+NRHS, prefer N+NRHS*NB) ! CALL sormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b, & ldb, work( nwork ), lwork-nwork+1, info ) ! ! Zero out below R. ! IF( n > 1 ) THEN CALL slaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) END IF END IF ! ie = 1 itauq = ie + n itaup = itauq + n nwork = itaup + n ! ! Bidiagonalize R in A. ! (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) ! CALL sgebrd( mm, n, a, lda, s, work( ie ), work( itauq ), & work( itaup ), work( nwork ), lwork-nwork+1, info ) ! ! Multiply B by transpose of left bidiagonalizing vectors of R. ! (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) ! CALL sormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ), & b, ldb, work( nwork ), lwork-nwork+1, info ) ! ! Solve the bidiagonal least squares problem. ! CALL slalsd( 'U', smlsiz, n, nrhs, s, work( ie ), b, ldb, & rcond, rank, work( nwork ), iwork, info ) IF( info /= 0 ) THEN GO TO 10 END IF ! ! Multiply B by right bidiagonalizing vectors of R. ! CALL sormbr( 'P', 'L', 'N', n, nrhs, n, a, lda, work( itaup ), & b, ldb, work( nwork ), lwork-nwork+1, info ) ! ELSE IF( n >= mnthr .AND. lwork >= 4*m+m*m+ & MAX( m, 2*m-4, nrhs, n-3*m ) ) THEN ! ! Path 2a - underdetermined, with many more columns than rows ! and sufficient workspace for an efficient algorithm. ! ldwork = m IF( lwork >= MAX( 4*m+m*lda+MAX( m, 2*m-4, nrhs, n-3*m ), & m*lda+m+m*nrhs ) )ldwork = lda itau = 1 nwork = m + 1 ! ! Compute A=L*Q. ! (Workspace: need 2*M, prefer M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), work( nwork ), & lwork-nwork+1, info ) il = nwork ! ! Copy L to WORK(IL), zeroing out above its diagonal. ! CALL slacpy( 'L', m, m, a, lda, work( il ), ldwork ) CALL slaset( 'U', m-1, m-1, zero, zero, work( il+ldwork ), ldwork ) ie = il + ldwork*m itauq = ie + m itaup = itauq + m nwork = itaup + m ! ! Bidiagonalize L in WORK(IL). ! (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) ! CALL sgebrd( m, m, work( il ), ldwork, s, work( ie ), & work( itauq ), work( itaup ), work( nwork ), lwork-nwork+1, info ) ! ! Multiply B by transpose of left bidiagonalizing vectors of L. ! (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) ! CALL sormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork, & work( itauq ), b, ldb, work( nwork ), lwork-nwork+1, info ) ! ! Solve the bidiagonal least squares problem. ! CALL slalsd( 'U', smlsiz, m, nrhs, s, work( ie ), b, ldb, & rcond, rank, work( nwork ), iwork, info ) IF( info /= 0 ) THEN GO TO 10 END IF ! ! Multiply B by right bidiagonalizing vectors of L. ! CALL sormbr( 'P', 'L', 'N', m, nrhs, m, work( il ), ldwork, & work( itaup ), b, ldb, work( nwork ), lwork-nwork+1, info ) ! ! Zero out below first M rows of B. ! CALL slaset( 'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb ) nwork = itau + m ! ! Multiply transpose(Q) by B. ! (Workspace: need M+NRHS, prefer M+NRHS*NB) ! CALL sormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b, & ldb, work( nwork ), lwork-nwork+1, info ) ! ELSE ! ! Path 2 - remaining underdetermined cases. ! ie = 1 itauq = ie + m itaup = itauq + m nwork = itaup + m ! ! Bidiagonalize A. ! (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) ! CALL sgebrd( m, n, a, lda, s, work( ie ), work( itauq ), & work( itaup ), work( nwork ), lwork-nwork+1, info ) ! ! Multiply B by transpose of left bidiagonalizing vectors. ! (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) ! CALL sormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ), & b, ldb, work( nwork ), lwork-nwork+1, info ) ! ! Solve the bidiagonal least squares problem. ! CALL slalsd( 'L', smlsiz, m, nrhs, s, work( ie ), b, ldb, & rcond, rank, work( nwork ), iwork, info ) IF( info /= 0 ) THEN GO TO 10 END IF ! ! Multiply B by right bidiagonalizing vectors of A. ! CALL sormbr( 'P', 'L', 'N', n, nrhs, m, a, lda, work( itaup ), & b, ldb, work( nwork ), lwork-nwork+1, info ) ! END IF ! ! Undo scaling. ! IF( iascl == 1 ) THEN CALL slascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) CALL slascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn, info ) ELSE IF( iascl == 2 ) THEN CALL slascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) CALL slascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn, info ) END IF IF( ibscl == 1 ) THEN CALL slascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) ELSE IF( ibscl == 2 ) THEN CALL slascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) END IF ! 10 CONTINUE work( 1 ) = maxwrk RETURN ! ! End of SGELSD ! END SUBROUTINE sgelsd SUBROUTINE sgelss( m, n, nrhs, a, lda, b, ldb, s, rcond, rank, & 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 .. INTEGER, INTENT(IN OUT) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: nrhs REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN) :: ldb REAL, INTENT(IN) :: s( * ) REAL, INTENT(IN) :: rcond INTEGER, INTENT(OUT) :: rank REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGELSS computes the minimum norm solution to a real linear least ! squares problem: ! ! Minimize 2-norm(| b - A*x |). ! ! using the singular value decomposition (SVD) of A. A is an M-by-N ! matrix which may be rank-deficient. ! ! Several right hand side vectors b and solution vectors x can be ! handled in a single call; they are stored as the columns of the ! M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix ! X. ! ! The effective rank of A is determined by treating as zero those ! singular values which are less than RCOND times the largest singular ! value. ! ! 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. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of columns ! of the matrices B and X. NRHS >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the M-by-N matrix A. ! On exit, the first min(m,n) rows of A are overwritten with ! its right singular vectors, stored rowwise. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! B (input/output) REAL array, dimension (LDB,NRHS) ! On entry, the M-by-NRHS right hand side matrix B. ! On exit, B is overwritten by the N-by-NRHS solution ! matrix X. If m >= n and RANK = n, the residual ! sum-of-squares for the solution in the i-th column is given ! by the sum of squares of elements n+1:m in that column. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,max(M,N)). ! ! S (output) REAL array, dimension (min(M,N)) ! The singular values of A in decreasing order. ! The condition number of A in the 2-norm = S(1)/S(min(m,n)). ! ! RCOND (input) REAL ! RCOND is used to determine the effective rank of A. ! Singular values S(i) <= RCOND*S(1) are treated as zero. ! If RCOND < 0, machine precision is used instead. ! ! RANK (output) INTEGER ! The effective rank of A, i.e., the number of singular values ! which are greater than RCOND*S(1). ! ! WORK (workspace/output) REAL 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, and also: ! LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) ! 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. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: the algorithm for computing the SVD failed to converge; ! if INFO = i, i off-diagonal elements of an intermediate ! bidiagonal form did not converge to zero. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: bdspac, bl, chunk, i, iascl, ibscl, ie, il, & itau, itaup, itauq, iwork, ldwork, maxmn, maxwrk, minmn, minwrk, mm, mnthr REAL :: anrm, bignum, bnrm, eps, sfmin, smlnum, thr ! .. ! .. Local Arrays .. REAL :: vdum( 1 ) ! .. ! .. External Subroutines .. EXTERNAL sbdsqr, scopy, sgebrd, sgelqf, sgemm, sgemv, & sgeqrf, slabad, slacpy, slascl, slaset, sorgbr, & sormbr, sormlq, sormqr, srscl, xerbla ! .. ! .. External Functions .. INTEGER :: ilaenv REAL :: slamch, slange EXTERNAL ilaenv, slamch, slange ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 minmn = MIN( m, n ) maxmn = MAX( m, n ) mnthr = ilaenv( 6, 'SGELSS', ' ', m, n, nrhs, -1 ) lquery = ( lwork == -1 ) IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, m ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, maxmn ) ) THEN info = -7 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.) ! minwrk = 1 IF( info == 0 .AND. ( lwork >= 1 .OR. lquery ) ) THEN maxwrk = 0 mm = m IF( m >= n .AND. m >= mnthr ) THEN ! ! Path 1a - overdetermined, with many more rows than columns ! mm = n maxwrk = MAX( maxwrk, n+n*ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) ) maxwrk = MAX( maxwrk, n+nrhs* & ilaenv( 1, 'SORMQR', 'LT', m, nrhs, n, -1 ) ) END IF IF( m >= n ) THEN ! ! Path 1 - overdetermined or exactly determined ! ! Compute workspace needed for SBDSQR ! bdspac = MAX( 1, 5*n-4 ) maxwrk = MAX( maxwrk, 3*n+( mm+n )* & ilaenv( 1, 'SGEBRD', ' ', mm, n, -1, -1 ) ) maxwrk = MAX( maxwrk, 3*n+nrhs* & ilaenv( 1, 'SORMBR', 'QLT', mm, nrhs, n, -1 ) ) maxwrk = MAX( maxwrk, 3*n+( n-1 )* & ilaenv( 1, 'SORGBR', 'P', n, n, n, -1 ) ) maxwrk = MAX( maxwrk, bdspac ) maxwrk = MAX( maxwrk, n*nrhs ) minwrk = MAX( 3*n+mm, 3*n+nrhs, bdspac ) maxwrk = MAX( minwrk, maxwrk ) END IF IF( n > m ) THEN ! ! Compute workspace needed for SBDSQR ! bdspac = MAX( 1, 5*m-4 ) minwrk = MAX( 3*m+nrhs, 3*m+n, bdspac ) IF( n >= mnthr ) THEN ! ! Path 2a - underdetermined, with many more columns ! than rows ! maxwrk = m + m*ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) maxwrk = MAX( maxwrk, m*m+4*m+2*m* & ilaenv( 1, 'SGEBRD', ' ', m, m, -1, -1 ) ) maxwrk = MAX( maxwrk, m*m+4*m+nrhs* & ilaenv( 1, 'SORMBR', 'QLT', m, nrhs, m, -1 ) ) maxwrk = MAX( maxwrk, m*m+4*m+( m-1 )* & ilaenv( 1, 'SORGBR', 'P', m, m, m, -1 ) ) maxwrk = MAX( maxwrk, m*m+m+bdspac ) IF( nrhs > 1 ) THEN maxwrk = MAX( maxwrk, m*m+m+m*nrhs ) ELSE maxwrk = MAX( maxwrk, m*m+2*m ) END IF maxwrk = MAX( maxwrk, m+nrhs* & ilaenv( 1, 'SORMLQ', 'LT', n, nrhs, m, -1 ) ) ELSE ! ! Path 2 - underdetermined ! maxwrk = 3*m + ( n+m )*ilaenv( 1, 'SGEBRD', ' ', m, n, -1, -1 ) maxwrk = MAX( maxwrk, 3*m+nrhs* & ilaenv( 1, 'SORMBR', 'QLT', m, nrhs, m, -1 ) ) maxwrk = MAX( maxwrk, 3*m+m* ilaenv( 1, 'SORGBR', 'P', m, n, m, -1 ) ) maxwrk = MAX( maxwrk, bdspac ) maxwrk = MAX( maxwrk, n*nrhs ) END IF END IF maxwrk = MAX( minwrk, maxwrk ) work( 1 ) = maxwrk END IF ! minwrk = MAX( minwrk, 1 ) IF( lwork < minwrk .AND. .NOT.lquery ) info = -12 IF( info /= 0 ) THEN CALL xerbla( 'SGELSS', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 ) THEN rank = 0 RETURN END IF ! ! Get machine parameters ! eps = slamch( 'P' ) sfmin = slamch( 'S' ) smlnum = sfmin / eps bignum = one / smlnum CALL slabad( smlnum, bignum ) ! ! Scale A if max element outside range [SMLNUM,BIGNUM] ! anrm = slange( 'M', m, n, a, lda, work ) iascl = 0 IF( anrm > zero .AND. anrm < smlnum ) THEN ! ! Scale matrix norm up to SMLNUM ! CALL slascl( 'G', 0, 0, anrm, smlnum, m, n, a, lda, info ) iascl = 1 ELSE IF( anrm > bignum ) THEN ! ! Scale matrix norm down to BIGNUM ! CALL slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) iascl = 2 ELSE IF( anrm == zero ) THEN ! ! Matrix all zero. Return zero solution. ! CALL slaset( 'F', MAX( m, n ), nrhs, zero, zero, b, ldb ) CALL slaset( 'F', minmn, 1, zero, zero, s, 1 ) rank = 0 GO TO 70 END IF ! ! Scale B if max element outside range [SMLNUM,BIGNUM] ! bnrm = slange( 'M', m, nrhs, b, ldb, work ) ibscl = 0 IF( bnrm > zero .AND. bnrm < smlnum ) THEN ! ! Scale matrix norm up to SMLNUM ! CALL slascl( 'G', 0, 0, bnrm, smlnum, m, nrhs, b, ldb, info ) ibscl = 1 ELSE IF( bnrm > bignum ) THEN ! ! Scale matrix norm down to BIGNUM ! CALL slascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) ibscl = 2 END IF ! ! Overdetermined case ! IF( m >= n ) THEN ! ! Path 1 - overdetermined or exactly determined ! mm = m IF( m >= mnthr ) THEN ! ! Path 1a - overdetermined, with many more rows than columns ! mm = n itau = 1 iwork = itau + n ! ! Compute A=Q*R ! (Workspace: need 2*N, prefer N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), work( iwork ), & lwork-iwork+1, info ) ! ! Multiply B by transpose(Q) ! (Workspace: need N+NRHS, prefer N+NRHS*NB) ! CALL sormqr( 'L', 'T', m, nrhs, n, a, lda, work( itau ), b, & ldb, work( iwork ), lwork-iwork+1, info ) ! ! Zero out below R ! IF( n > 1 ) CALL slaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) END IF ! ie = 1 itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Bidiagonalize R in A ! (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) ! CALL sgebrd( mm, n, a, lda, s, work( ie ), work( itauq ), & work( itaup ), work( iwork ), lwork-iwork+1, info ) ! ! Multiply B by transpose of left bidiagonalizing vectors of R ! (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) ! CALL sormbr( 'Q', 'L', 'T', mm, nrhs, n, a, lda, work( itauq ), & b, ldb, work( iwork ), lwork-iwork+1, info ) ! ! Generate right bidiagonalizing vectors of R in A ! (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) ! CALL sorgbr( 'P', n, n, n, a, lda, work( itaup ), & work( iwork ), lwork-iwork+1, info ) iwork = ie + n ! ! Perform bidiagonal QR iteration ! multiply B by transpose of left singular vectors ! compute right singular vectors in A ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', n, n, 0, nrhs, s, work( ie ), a, lda, vdum, & 1, b, ldb, work( iwork ), info ) IF( info /= 0 ) GO TO 70 ! ! Multiply B by reciprocals of singular values ! thr = MAX( rcond*s( 1 ), sfmin ) IF( rcond < zero ) thr = MAX( eps*s( 1 ), sfmin ) rank = 0 DO i = 1, n IF( s( i ) > thr ) THEN CALL srscl( nrhs, s( i ), b( i, 1 ), ldb ) rank = rank + 1 ELSE CALL slaset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) END IF END DO ! ! Multiply B by right singular vectors ! (Workspace: need N, prefer N*NRHS) ! IF( lwork >= ldb*nrhs .AND. nrhs > 1 ) THEN CALL sgemm( 'T', 'N', n, nrhs, n, one, a, lda, b, ldb, zero, work, ldb ) CALL slacpy( 'G', n, nrhs, work, ldb, b, ldb ) ELSE IF( nrhs > 1 ) THEN chunk = lwork / n DO i = 1, nrhs, chunk bl = MIN( nrhs-i+1, chunk ) CALL sgemm( 'T', 'N', n, bl, n, one, a, lda, b( 1, i ), & ldb, zero, work, n ) CALL slacpy( 'G', n, bl, work, n, b( 1, i ), ldb ) END DO ELSE CALL sgemv( 'T', n, n, one, a, lda, b, 1, zero, work, 1 ) CALL scopy( n, work, 1, b, 1 ) END IF ! ELSE IF( n >= mnthr .AND. lwork >= 4*m+m*m+ & MAX( m, 2*m-4, nrhs, n-3*m ) ) THEN ! ! Path 2a - underdetermined, with many more columns than rows ! and sufficient workspace for an efficient algorithm ! ldwork = m IF( lwork >= MAX( 4*m+m*lda+MAX( m, 2*m-4, nrhs, n-3*m ), & m*lda+m+m*nrhs ) )ldwork = lda itau = 1 iwork = m + 1 ! ! Compute A=L*Q ! (Workspace: need 2*M, prefer M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), work( iwork ), & lwork-iwork+1, info ) il = iwork ! ! Copy L to WORK(IL), zeroing out above it ! CALL slacpy( 'L', m, m, a, lda, work( il ), ldwork ) CALL slaset( 'U', m-1, m-1, zero, zero, work( il+ldwork ), ldwork ) ie = il + ldwork*m itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Bidiagonalize L in WORK(IL) ! (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) ! CALL sgebrd( m, m, work( il ), ldwork, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, info ) ! ! Multiply B by transpose of left bidiagonalizing vectors of L ! (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) ! CALL sormbr( 'Q', 'L', 'T', m, nrhs, m, work( il ), ldwork, & work( itauq ), b, ldb, work( iwork ), lwork-iwork+1, info ) ! ! Generate right bidiagonalizing vectors of R in WORK(IL) ! (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB) ! CALL sorgbr( 'P', m, m, m, work( il ), ldwork, work( itaup ), & work( iwork ), lwork-iwork+1, info ) iwork = ie + m ! ! Perform bidiagonal QR iteration, ! computing right singular vectors of L in WORK(IL) and ! multiplying B by transpose of left singular vectors ! (Workspace: need M*M+M+BDSPAC) ! CALL sbdsqr( 'U', m, m, 0, nrhs, s, work( ie ), work( il ), & ldwork, a, lda, b, ldb, work( iwork ), info ) IF( info /= 0 ) GO TO 70 ! ! Multiply B by reciprocals of singular values ! thr = MAX( rcond*s( 1 ), sfmin ) IF( rcond < zero ) thr = MAX( eps*s( 1 ), sfmin ) rank = 0 DO i = 1, m IF( s( i ) > thr ) THEN CALL srscl( nrhs, s( i ), b( i, 1 ), ldb ) rank = rank + 1 ELSE CALL slaset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) END IF END DO iwork = ie ! ! Multiply B by right singular vectors of L in WORK(IL) ! (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS) ! IF( lwork >= ldb*nrhs+iwork-1 .AND. nrhs > 1 ) THEN CALL sgemm( 'T', 'N', m, nrhs, m, one, work( il ), ldwork, & b, ldb, zero, work( iwork ), ldb ) CALL slacpy( 'G', m, nrhs, work( iwork ), ldb, b, ldb ) ELSE IF( nrhs > 1 ) THEN chunk = ( lwork-iwork+1 ) / m DO i = 1, nrhs, chunk bl = MIN( nrhs-i+1, chunk ) CALL sgemm( 'T', 'N', m, bl, m, one, work( il ), ldwork, & b( 1, i ), ldb, zero, work( iwork ), n ) CALL slacpy( 'G', m, bl, work( iwork ), n, b( 1, i ), ldb ) END DO ELSE CALL sgemv( 'T', m, m, one, work( il ), ldwork, b( 1, 1 ), & 1, zero, work( iwork ), 1 ) CALL scopy( m, work( iwork ), 1, b( 1, 1 ), 1 ) END IF ! ! Zero out below first M rows of B ! CALL slaset( 'F', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb ) iwork = itau + m ! ! Multiply transpose(Q) by B ! (Workspace: need M+NRHS, prefer M+NRHS*NB) ! CALL sormlq( 'L', 'T', n, nrhs, m, a, lda, work( itau ), b, & ldb, work( iwork ), lwork-iwork+1, info ) ! ELSE ! ! Path 2 - remaining underdetermined cases ! ie = 1 itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Bidiagonalize A ! (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) ! CALL sgebrd( m, n, a, lda, s, work( ie ), work( itauq ), & work( itaup ), work( iwork ), lwork-iwork+1, info ) ! ! Multiply B by transpose of left bidiagonalizing vectors ! (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) ! CALL sormbr( 'Q', 'L', 'T', m, nrhs, n, a, lda, work( itauq ), & b, ldb, work( iwork ), lwork-iwork+1, info ) ! ! Generate right bidiagonalizing vectors in A ! (Workspace: need 4*M, prefer 3*M+M*NB) ! CALL sorgbr( 'P', m, n, m, a, lda, work( itaup ), & work( iwork ), lwork-iwork+1, info ) iwork = ie + m ! ! Perform bidiagonal QR iteration, ! computing right singular vectors of A in A and ! multiplying B by transpose of left singular vectors ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'L', m, n, 0, nrhs, s, work( ie ), a, lda, vdum, & 1, b, ldb, work( iwork ), info ) IF( info /= 0 ) GO TO 70 ! ! Multiply B by reciprocals of singular values ! thr = MAX( rcond*s( 1 ), sfmin ) IF( rcond < zero ) thr = MAX( eps*s( 1 ), sfmin ) rank = 0 DO i = 1, m IF( s( i ) > thr ) THEN CALL srscl( nrhs, s( i ), b( i, 1 ), ldb ) rank = rank + 1 ELSE CALL slaset( 'F', 1, nrhs, zero, zero, b( i, 1 ), ldb ) END IF END DO ! ! Multiply B by right singular vectors of A ! (Workspace: need N, prefer N*NRHS) ! IF( lwork >= ldb*nrhs .AND. nrhs > 1 ) THEN CALL sgemm( 'T', 'N', n, nrhs, m, one, a, lda, b, ldb, zero, work, ldb ) CALL slacpy( 'F', n, nrhs, work, ldb, b, ldb ) ELSE IF( nrhs > 1 ) THEN chunk = lwork / n DO i = 1, nrhs, chunk bl = MIN( nrhs-i+1, chunk ) CALL sgemm( 'T', 'N', n, bl, m, one, a, lda, b( 1, i ), & ldb, zero, work, n ) CALL slacpy( 'F', n, bl, work, n, b( 1, i ), ldb ) END DO ELSE CALL sgemv( 'T', m, n, one, a, lda, b, 1, zero, work, 1 ) CALL scopy( n, work, 1, b, 1 ) END IF END IF ! ! Undo scaling ! IF( iascl == 1 ) THEN CALL slascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) CALL slascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn, info ) ELSE IF( iascl == 2 ) THEN CALL slascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) CALL slascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn, info ) END IF IF( ibscl == 1 ) THEN CALL slascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) ELSE IF( ibscl == 2 ) THEN CALL slascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) END IF ! 70 CONTINUE work( 1 ) = maxwrk RETURN ! ! End of SGELSS ! END SUBROUTINE sgelss SUBROUTINE sgelsx( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank, work, 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN) :: ldb INTEGER, INTENT(IN OUT) :: jpvt( * ) REAL, INTENT(IN) :: rcond INTEGER, INTENT(OUT) :: rank REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! This routine is deprecated and has been replaced by routine SGELSY. ! ! SGELSX computes the minimum-norm solution to a real linear least ! squares problem: ! minimize || A * X - B || ! using a complete orthogonal factorization of A. A is an M-by-N ! matrix which may be rank-deficient. ! ! Several right hand side vectors b and solution vectors x can be ! handled in a single call; they are stored as the columns of the ! M-by-NRHS right hand side matrix B and the N-by-NRHS solution ! matrix X. ! ! The routine first computes a QR factorization with column pivoting: ! A * P = Q * [ R11 R12 ] ! [ 0 R22 ] ! with R11 defined as the largest leading submatrix whose estimated ! condition number is less than 1/RCOND. The order of R11, RANK, ! is the effective rank of A. ! ! Then, R22 is considered to be negligible, and R12 is annihilated ! by orthogonal transformations from the right, arriving at the ! complete orthogonal factorization: ! A * P = Q * [ T11 0 ] * Z ! [ 0 0 ] ! The minimum-norm solution is then ! X = P * Z' [ inv(T11)*Q1'*B ] ! [ 0 ] ! where Q1 consists of the first RANK columns of 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. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of ! columns of matrices B and X. NRHS >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the M-by-N matrix A. ! On exit, A has been overwritten by details of its ! complete orthogonal factorization. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! B (input/output) REAL array, dimension (LDB,NRHS) ! On entry, the M-by-NRHS right hand side matrix B. ! On exit, the N-by-NRHS solution matrix X. ! If m >= n and RANK = n, the residual sum-of-squares for ! the solution in the i-th column is given by the sum of ! squares of elements N+1:M in that column. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,M,N). ! ! JPVT (input/output) INTEGER array, dimension (N) ! On entry, if JPVT(i) .ne. 0, the i-th column of A is an ! initial column, otherwise it is a free column. Before ! the QR factorization of A, all initial columns are ! permuted to the leading positions; only the remaining ! free columns are moved as a result of column pivoting ! during the factorization. ! On exit, if JPVT(i) = k, then the i-th column of A*P ! was the k-th column of A. ! ! RCOND (input) REAL ! RCOND is used to determine the effective rank of A, which ! is defined as the order of the largest leading triangular ! submatrix R11 in the QR factorization with pivoting of A, ! whose estimated condition number < 1/RCOND. ! ! RANK (output) INTEGER ! The effective rank of A, i.e., the order of the submatrix ! R11. This is the same as the order of the submatrix T11 ! in the complete orthogonal factorization of A. ! ! WORK (workspace) REAL array, dimension ! (max( min(M,N)+3*N, 2*min(M,N)+NRHS )), ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: imax = 1 INTEGER, PARAMETER :: imin = 2 REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: done = zero REAL, PARAMETER :: ntdone = one ! .. ! .. Local Scalars .. INTEGER :: i, iascl, ibscl, ismax, ismin, j, k, mn REAL :: anrm, bignum, bnrm, c1, c2, s1, s2, smax, & smaxpr, smin, sminpr, smlnum, t1, t2 ! .. ! .. External Functions .. REAL :: slamch, slange EXTERNAL slamch, slange ! .. ! .. External Subroutines .. EXTERNAL sgeqpf, slabad, slaic1, slascl, slaset, slatzm, & sorm2r, strsm, stzrqf, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. Executable Statements .. ! mn = MIN( m, n ) ismin = mn + 1 ismax = 2*mn + 1 ! ! Test the input arguments. ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, m ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, m, n ) ) THEN info = -7 END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SGELSX', -info ) RETURN END IF ! ! Quick return if possible ! IF( MIN( m, n, nrhs ) == 0 ) THEN rank = 0 RETURN END IF ! ! Get machine parameters ! smlnum = slamch( 'S' ) / slamch( 'P' ) bignum = one / smlnum CALL slabad( smlnum, bignum ) ! ! Scale A, B if max elements outside range [SMLNUM,BIGNUM] ! anrm = slange( 'M', m, n, a, lda, work ) iascl = 0 IF( anrm > zero .AND. anrm < smlnum ) THEN ! ! Scale matrix norm up to SMLNUM ! CALL slascl( 'G', 0, 0, anrm, smlnum, m, n, a, lda, info ) iascl = 1 ELSE IF( anrm > bignum ) THEN ! ! Scale matrix norm down to BIGNUM ! CALL slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) iascl = 2 ELSE IF( anrm == zero ) THEN ! ! Matrix all zero. Return zero solution. ! CALL slaset( 'F', MAX( m, n ), nrhs, zero, zero, b, ldb ) rank = 0 GO TO 100 END IF ! bnrm = slange( 'M', m, nrhs, b, ldb, work ) ibscl = 0 IF( bnrm > zero .AND. bnrm < smlnum ) THEN ! ! Scale matrix norm up to SMLNUM ! CALL slascl( 'G', 0, 0, bnrm, smlnum, m, nrhs, b, ldb, info ) ibscl = 1 ELSE IF( bnrm > bignum ) THEN ! ! Scale matrix norm down to BIGNUM ! CALL slascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) ibscl = 2 END IF ! ! Compute QR factorization with column pivoting of A: ! A * P = Q * R ! CALL sgeqpf( m, n, a, lda, jpvt, work( 1 ), work( mn+1 ), info ) ! ! workspace 3*N. Details of Householder rotations stored ! in WORK(1:MN). ! ! Determine RANK using incremental condition estimation ! work( ismin ) = one work( ismax ) = one smax = ABS( a( 1, 1 ) ) smin = smax IF( ABS( a( 1, 1 ) ) == zero ) THEN rank = 0 CALL slaset( 'F', MAX( m, n ), nrhs, zero, zero, b, ldb ) GO TO 100 ELSE rank = 1 END IF ! 10 CONTINUE IF( rank < mn ) THEN i = rank + 1 CALL slaic1( imin, rank, work( ismin ), smin, a( 1, i ), & a( i, i ), sminpr, s1, c1 ) CALL slaic1( imax, rank, work( ismax ), smax, a( 1, i ), & a( i, i ), smaxpr, s2, c2 ) ! IF( smaxpr*rcond <= sminpr ) THEN DO i = 1, rank work( ismin+i-1 ) = s1*work( ismin+i-1 ) work( ismax+i-1 ) = s2*work( ismax+i-1 ) END DO work( ismin+rank ) = c1 work( ismax+rank ) = c2 smin = sminpr smax = smaxpr rank = rank + 1 GO TO 10 END IF END IF ! ! Logically partition R = [ R11 R12 ] ! [ 0 R22 ] ! where R11 = R(1:RANK,1:RANK) ! ! [R11,R12] = [ T11, 0 ] * Y ! IF( rank < n ) CALL stzrqf( rank, n, a, lda, work( mn+1 ), info ) ! ! Details of Householder rotations stored in WORK(MN+1:2*MN) ! ! B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) ! CALL sorm2r( 'Left', 'Transpose', m, nrhs, mn, a, lda, work( 1 ), & b, ldb, work( 2*mn+1 ), info ) ! ! workspace NRHS ! ! B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) ! CALL strsm( 'Left', 'Upper', 'No transpose', 'Non-unit', rank, & nrhs, one, a, lda, b, ldb ) ! DO i = rank + 1, n DO j = 1, nrhs b( i, j ) = zero END DO END DO ! ! B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) ! IF( rank < n ) THEN DO i = 1, rank CALL slatzm( 'Left', n-rank+1, nrhs, a( i, rank+1 ), lda, & work( mn+i ), b( i, 1 ), b( rank+1, 1 ), ldb, work( 2*mn+1 ) ) END DO END IF ! ! workspace NRHS ! ! B(1:N,1:NRHS) := P * B(1:N,1:NRHS) ! DO j = 1, nrhs DO i = 1, n work( 2*mn+i ) = ntdone END DO DO i = 1, n IF( work( 2*mn+i ) == ntdone ) THEN IF( jpvt( i ) /= i ) THEN k = i t1 = b( k, j ) t2 = b( jpvt( k ), j ) 70 CONTINUE b( jpvt( k ), j ) = t1 work( 2*mn+k ) = done t1 = t2 k = jpvt( k ) t2 = b( jpvt( k ), j ) IF( jpvt( k ) /= i ) GO TO 70 b( i, j ) = t1 work( 2*mn+k ) = done END IF END IF END DO END DO ! ! Undo scaling ! IF( iascl == 1 ) THEN CALL slascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) CALL slascl( 'U', 0, 0, smlnum, anrm, rank, rank, a, lda, info ) ELSE IF( iascl == 2 ) THEN CALL slascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) CALL slascl( 'U', 0, 0, bignum, anrm, rank, rank, a, lda, info ) END IF IF( ibscl == 1 ) THEN CALL slascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) ELSE IF( ibscl == 2 ) THEN CALL slascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) END IF ! 100 CONTINUE ! RETURN ! ! End of SGELSX ! END SUBROUTINE sgelsx SUBROUTINE sgelsy( m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank, & 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 .. INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN) :: ldb INTEGER, INTENT(OUT) :: jpvt( * ) REAL, INTENT(IN) :: rcond INTEGER, INTENT(OUT) :: rank REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGELSY computes the minimum-norm solution to a real linear least ! squares problem: ! minimize || A * X - B || ! using a complete orthogonal factorization of A. A is an M-by-N ! matrix which may be rank-deficient. ! ! Several right hand side vectors b and solution vectors x can be ! handled in a single call; they are stored as the columns of the ! M-by-NRHS right hand side matrix B and the N-by-NRHS solution ! matrix X. ! ! The routine first computes a QR factorization with column pivoting: ! A * P = Q * [ R11 R12 ] ! [ 0 R22 ] ! with R11 defined as the largest leading submatrix whose estimated ! condition number is less than 1/RCOND. The order of R11, RANK, ! is the effective rank of A. ! ! Then, R22 is considered to be negligible, and R12 is annihilated ! by orthogonal transformations from the right, arriving at the ! complete orthogonal factorization: ! A * P = Q * [ T11 0 ] * Z ! [ 0 0 ] ! The minimum-norm solution is then ! X = P * Z' [ inv(T11)*Q1'*B ] ! [ 0 ] ! where Q1 consists of the first RANK columns of Q. ! ! This routine is basically identical to the original xGELSX except ! three differences: ! o The call to the subroutine xGEQPF has been substituted by the ! the call to the subroutine xGEQP3. This subroutine is a Blas-3 ! version of the QR factorization with column pivoting. ! o Matrix B (the right hand side) is updated with Blas-3. ! o The permutation of matrix B (the right hand side) is faster and ! more simple. ! ! 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. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of ! columns of matrices B and X. NRHS >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the M-by-N matrix A. ! On exit, A has been overwritten by details of its ! complete orthogonal factorization. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! B (input/output) REAL array, dimension (LDB,NRHS) ! On entry, the M-by-NRHS right hand side matrix B. ! On exit, the N-by-NRHS solution matrix X. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,M,N). ! ! JPVT (input/output) INTEGER array, dimension (N) ! On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted ! to the front of AP, otherwise column i is a free column. ! On exit, if JPVT(i) = k, then the i-th column of AP ! was the k-th column of A. ! ! RCOND (input) REAL ! RCOND is used to determine the effective rank of A, which ! is defined as the order of the largest leading triangular ! submatrix R11 in the QR factorization with pivoting of A, ! whose estimated condition number < 1/RCOND. ! ! RANK (output) INTEGER ! The effective rank of A, i.e., the order of the submatrix ! R11. This is the same as the order of the submatrix T11 ! in the complete orthogonal factorization of A. ! ! WORK (workspace/output) REAL array, dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. ! The unblocked strategy requires that: ! LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ), ! where MN = min( M, N ). ! The block algorithm requires that: ! LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ), ! where NB is an upper bound on the blocksize returned ! by ILAENV for the routines SGEQP3, STZRZF, STZRQF, SORMQR, ! and SORMRZ. ! ! 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 ! =============== ! ! Based on contributions by ! A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA ! E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain ! G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: imax = 1 INTEGER, PARAMETER :: imin = 2 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: i, iascl, ibscl, ismax, ismin, j, lwkopt, mn, & nb, nb1, nb2, nb3, nb4 REAL :: anrm, bignum, bnrm, c1, c2, s1, s2, smax, & smaxpr, smin, sminpr, smlnum, wsize ! .. ! .. External Functions .. INTEGER :: ilaenv REAL :: slamch, slange EXTERNAL ilaenv, slamch, slange ! .. ! .. External Subroutines .. EXTERNAL scopy, sgeqp3, slabad, slaic1, slascl, slaset, & sormqr, sormrz, strsm, stzrzf, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, REAL ! .. ! .. Executable Statements .. ! mn = MIN( m, n ) ismin = mn + 1 ismax = 2*mn + 1 ! ! Test the input arguments. ! info = 0 nb1 = ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) nb2 = ilaenv( 1, 'SGERQF', ' ', m, n, -1, -1 ) nb3 = ilaenv( 1, 'SORMQR', ' ', m, n, nrhs, -1 ) nb4 = ilaenv( 1, 'SORMRQ', ' ', m, n, nrhs, -1 ) nb = MAX( nb1, nb2, nb3, nb4 ) lwkopt = MAX( 1, mn+2*n+nb*(n+1), 2*mn+nb*nrhs ) work( 1 ) = REAL( lwkopt ) lquery = ( lwork == -1 ) IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, m ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, m, n ) ) THEN info = -7 ELSE IF( lwork < MAX( 1, mn+3*n+1, 2*mn+nrhs ) .AND. & .NOT.lquery ) THEN info = -12 END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SGELSY', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( MIN( m, n, nrhs ) == 0 ) THEN rank = 0 RETURN END IF ! ! Get machine parameters ! smlnum = slamch( 'S' ) / slamch( 'P' ) bignum = one / smlnum CALL slabad( smlnum, bignum ) ! ! Scale A, B if max entries outside range [SMLNUM,BIGNUM] ! anrm = slange( 'M', m, n, a, lda, work ) iascl = 0 IF( anrm > zero .AND. anrm < smlnum ) THEN ! ! Scale matrix norm up to SMLNUM ! CALL slascl( 'G', 0, 0, anrm, smlnum, m, n, a, lda, info ) iascl = 1 ELSE IF( anrm > bignum ) THEN ! ! Scale matrix norm down to BIGNUM ! CALL slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, info ) iascl = 2 ELSE IF( anrm == zero ) THEN ! ! Matrix all zero. Return zero solution. ! CALL slaset( 'F', MAX( m, n ), nrhs, zero, zero, b, ldb ) rank = 0 GO TO 70 END IF ! bnrm = slange( 'M', m, nrhs, b, ldb, work ) ibscl = 0 IF( bnrm > zero .AND. bnrm < smlnum ) THEN ! ! Scale matrix norm up to SMLNUM ! CALL slascl( 'G', 0, 0, bnrm, smlnum, m, nrhs, b, ldb, info ) ibscl = 1 ELSE IF( bnrm > bignum ) THEN ! ! Scale matrix norm down to BIGNUM ! CALL slascl( 'G', 0, 0, bnrm, bignum, m, nrhs, b, ldb, info ) ibscl = 2 END IF ! ! Compute QR factorization with column pivoting of A: ! A * P = Q * R ! CALL sgeqp3( m, n, a, lda, jpvt, work( 1 ), work( mn+1 ), lwork-mn, info ) wsize = mn + work( mn+1 ) ! ! workspace: MN+2*N+NB*(N+1). ! Details of Householder rotations stored in WORK(1:MN). ! ! Determine RANK using incremental condition estimation ! work( ismin ) = one work( ismax ) = one smax = ABS( a( 1, 1 ) ) smin = smax IF( ABS( a( 1, 1 ) ) == zero ) THEN rank = 0 CALL slaset( 'F', MAX( m, n ), nrhs, zero, zero, b, ldb ) GO TO 70 ELSE rank = 1 END IF ! 10 CONTINUE IF( rank < mn ) THEN i = rank + 1 CALL slaic1( imin, rank, work( ismin ), smin, a( 1, i ), & a( i, i ), sminpr, s1, c1 ) CALL slaic1( imax, rank, work( ismax ), smax, a( 1, i ), & a( i, i ), smaxpr, s2, c2 ) ! IF( smaxpr*rcond <= sminpr ) THEN DO i = 1, rank work( ismin+i-1 ) = s1*work( ismin+i-1 ) work( ismax+i-1 ) = s2*work( ismax+i-1 ) END DO work( ismin+rank ) = c1 work( ismax+rank ) = c2 smin = sminpr smax = smaxpr rank = rank + 1 GO TO 10 END IF END IF ! ! workspace: 3*MN. ! ! Logically partition R = [ R11 R12 ] ! [ 0 R22 ] ! where R11 = R(1:RANK,1:RANK) ! ! [R11,R12] = [ T11, 0 ] * Y ! IF( rank < n ) CALL stzrzf( rank, n, a, lda, work( mn+1 ), work( 2*mn+1 ), & lwork-2*mn, info ) ! ! workspace: 2*MN. ! Details of Householder rotations stored in WORK(MN+1:2*MN) ! ! B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) ! CALL sormqr( 'Left', 'Transpose', m, nrhs, mn, a, lda, work( 1 ), & b, ldb, work( 2*mn+1 ), lwork-2*mn, info ) wsize = MAX( wsize, 2*mn+work( 2*mn+1 ) ) ! ! workspace: 2*MN+NB*NRHS. ! ! B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) ! CALL strsm( 'Left', 'Upper', 'No transpose', 'Non-unit', rank, & nrhs, one, a, lda, b, ldb ) ! DO j = 1, nrhs DO i = rank + 1, n b( i, j ) = zero END DO END DO ! ! B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS) ! IF( rank < n ) THEN CALL sormrz( 'Left', 'Transpose', n, nrhs, rank, n-rank, a, & lda, work( mn+1 ), b, ldb, work( 2*mn+1 ), lwork-2*mn, info ) END IF ! ! workspace: 2*MN+NRHS. ! ! B(1:N,1:NRHS) := P * B(1:N,1:NRHS) ! DO j = 1, nrhs DO i = 1, n work( jpvt( i ) ) = b( i, j ) END DO CALL scopy( n, work( 1 ), 1, b( 1, j ), 1 ) END DO ! ! workspace: N. ! ! Undo scaling ! IF( iascl == 1 ) THEN CALL slascl( 'G', 0, 0, anrm, smlnum, n, nrhs, b, ldb, info ) CALL slascl( 'U', 0, 0, smlnum, anrm, rank, rank, a, lda, info ) ELSE IF( iascl == 2 ) THEN CALL slascl( 'G', 0, 0, anrm, bignum, n, nrhs, b, ldb, info ) CALL slascl( 'U', 0, 0, bignum, anrm, rank, rank, a, lda, info ) END IF IF( ibscl == 1 ) THEN CALL slascl( 'G', 0, 0, smlnum, bnrm, n, nrhs, b, ldb, info ) ELSE IF( ibscl == 2 ) THEN CALL slascl( 'G', 0, 0, bignum, bnrm, n, nrhs, b, ldb, info ) END IF ! 70 CONTINUE work( 1 ) = REAL( lwkopt ) ! RETURN ! ! End of SGELSY ! END SUBROUTINE sgelsy SUBROUTINE sgeql2( 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 ! February 29, 1992 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN OUT) :: m INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGEQL2 computes a QL factorization of a real m by n matrix A: ! A = Q * L. ! ! 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) REAL array, dimension (LDA,N) ! On entry, the m by n matrix A. ! On exit, if m >= n, the lower triangle of the subarray ! A(m-n+1:m,1:n) contains the n by n lower triangular matrix L; ! if m <= n, the elements on and below the (n-m)-th ! superdiagonal contain the m by n lower trapezoidal matrix L; ! the remaining elements, 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,M). ! ! TAU (output) REAL array, dimension (min(M,N)) ! The scalar factors of the elementary reflectors (see Further ! Details). ! ! WORK (workspace) REAL 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(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 real scalar, and v is a real vector with ! v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in ! A(1:m-k+i-1,n-k+i), and tau in TAU(i). ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, k REAL :: aii ! .. ! .. External Subroutines .. EXTERNAL slarf, slarfg, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, m ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGEQL2', -info ) RETURN END IF ! k = MIN( m, n ) ! DO i = k, 1, -1 ! ! Generate elementary reflector H(i) to annihilate ! A(1:m-k+i-1,n-k+i) ! CALL slarfg( m-k+i, a( m-k+i, n-k+i ), a( 1, n-k+i ), 1, tau( i ) ) ! ! Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left ! aii = a( m-k+i, n-k+i ) a( m-k+i, n-k+i ) = one CALL slarf( 'Left', m-k+i, n-k+i-1, a( 1, n-k+i ), 1, tau( i ), & a, lda, work ) a( m-k+i, n-k+i ) = aii END DO RETURN ! ! End of SGEQL2 ! END SUBROUTINE sgeql2 SUBROUTINE sgeqlf( 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGEQLF computes a QL factorization of a real M-by-N matrix A: ! A = Q * L. ! ! 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) REAL array, dimension (LDA,N) ! On entry, the M-by-N matrix A. ! On exit, ! if m >= n, the lower triangle of the subarray ! A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L; ! if m <= n, the elements on and below the (n-m)-th ! superdiagonal contain the M-by-N lower trapezoidal matrix L; ! the remaining elements, 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,M). ! ! TAU (output) REAL array, dimension (min(M,N)) ! The scalar factors of the elementary reflectors (see Further ! Details). ! ! WORK (workspace/output) REAL 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(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 real scalar, and v is a real vector with ! v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in ! A(1:m-k+i-1,n-k+i), and tau in TAU(i). ! ! ===================================================================== ! ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: i, ib, iinfo, iws, k, ki, kk, ldwork, lwkopt, mu, nb, nbmin, nu, nx ! .. ! .. External Subroutines .. EXTERNAL sgeql2, slarfb, slarft, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 nb = ilaenv( 1, 'SGEQLF', ' ', m, n, -1, -1 ) lwkopt = n*nb work( 1 ) = lwkopt lquery = ( lwork == -1 ) IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, m ) ) THEN info = -4 ELSE IF( lwork < MAX( 1, n ) .AND. .NOT.lquery ) THEN info = -7 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGEQLF', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! k = MIN( m, n ) IF( k == 0 ) THEN work( 1 ) = 1 RETURN END IF ! nbmin = 2 nx = 1 iws = n IF( nb > 1 .AND. nb < k ) THEN ! ! Determine when to cross over from blocked to unblocked code. ! nx = MAX( 0, ilaenv( 3, 'SGEQLF', ' ', m, n, -1, -1 ) ) IF( nx < k ) THEN ! ! Determine if workspace is large enough for blocked code. ! ldwork = n iws = ldwork*nb IF( lwork < 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, 'SGEQLF', ' ', m, n, -1, -1 ) ) END IF END IF END IF ! IF( nb >= nbmin .AND. nb < k .AND. nx < k ) THEN ! ! Use blocked code initially. ! The last kk columns are handled by the block method. ! ki = ( ( k-nx-1 ) / nb )*nb kk = MIN( k, ki+nb ) ! DO i = k - kk + ki + 1, k - kk + 1, -nb ib = MIN( k-i+1, nb ) ! ! Compute the QL factorization of the current block ! A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1) ! CALL sgeql2( m-k+i+ib-1, ib, a( 1, n-k+i ), lda, tau( i ), work, iinfo ) IF( n-k+i > 1 ) THEN ! ! Form the triangular factor of the block reflector ! H = H(i+ib-1) . . . H(i+1) H(i) ! CALL slarft( '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 slarfb( 'Left', '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 END DO mu = m - k + i + nb - 1 nu = n - k + i + nb - 1 ELSE mu = m nu = n END IF ! ! Use unblocked code to factor the last or only block ! IF( mu > 0 .AND. nu > 0 ) CALL sgeql2( mu, nu, a, lda, tau, work, iinfo ) ! work( 1 ) = iws RETURN ! ! End of SGEQLF ! END SUBROUTINE sgeqlf SUBROUTINE sgeqp3( m, n, a, lda, jpvt, 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, INTENT(IN) :: m INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(IN OUT) :: jpvt( * ) REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGEQP3 computes a QR factorization with column pivoting of a ! matrix A: A*P = Q*R using Level 3 BLAS. ! ! 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) REAL array, dimension (LDA,N) ! On entry, the M-by-N matrix A. ! On exit, the upper triangle of the array contains the ! min(M,N)-by-N upper trapezoidal matrix R; the elements below ! the diagonal, together with the array TAU, represent the ! orthogonal matrix Q as a product of min(M,N) elementary ! reflectors. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! JPVT (input/output) INTEGER array, dimension (N) ! On entry, if JPVT(J).ne.0, the J-th column of A is permuted ! to the front of A*P (a leading column); if JPVT(J)=0, ! the J-th column of A is a free column. ! On exit, if JPVT(J)=K, then the J-th column of A*P was the ! the K-th column of A. ! ! TAU (output) REAL array, dimension (min(M,N)) ! The scalar factors of the elementary reflectors. ! ! WORK (workspace/output) REAL array, dimension (LWORK) ! On exit, if INFO=0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. LWORK >= 3*N+1. ! For optimal performance LWORK >= 2*N+( 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. ! ! 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 real/complex scalar, and v is a real/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). ! ! Based on contributions by ! G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain ! X. Sun, Computer Science Dept., Duke University, USA ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: inb = 1 INTEGER, PARAMETER :: inbmin = 2 INTEGER, PARAMETER :: ixover = 3 ! .. ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: fjb, iws, j, jb, lwkopt, minmn, minws, na, nb, & nbmin, nfxd, nx, sm, sminmn, sn, topbmn ! .. ! .. External Subroutines .. EXTERNAL sgeqrf, slaqp2, slaqps, sormqr, sswap, xerbla ! .. ! .. External Functions .. INTEGER :: ilaenv REAL :: snrm2 EXTERNAL ilaenv, snrm2 ! .. ! .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN ! .. ! .. Executable Statements .. ! iws = 3*n + 1 minmn = MIN( m, n ) ! ! Test input arguments ! ==================== ! info = 0 nb = ilaenv( inb, 'SGEQRF', ' ', m, n, -1, -1 ) lwkopt = 2*n+( n+1 )*nb work( 1 ) = lwkopt lquery = ( lwork == -1 ) IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, m ) ) THEN info = -4 ELSE IF( ( lwork < iws ) .AND. .NOT.lquery ) THEN info = -8 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGEQP3', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible. ! IF( minmn == 0 ) THEN work( 1 ) = 1 RETURN END IF ! ! Move initial columns up front. ! nfxd = 1 DO j = 1, n IF( jpvt( j ) /= 0 ) THEN IF( j /= nfxd ) THEN CALL sswap( m, a( 1, j ), 1, a( 1, nfxd ), 1 ) jpvt( j ) = jpvt( nfxd ) jpvt( nfxd ) = j ELSE jpvt( j ) = j END IF nfxd = nfxd + 1 ELSE jpvt( j ) = j END IF END DO nfxd = nfxd - 1 ! ! Factorize fixed columns ! ======================= ! ! Compute the QR factorization of fixed columns and update ! remaining columns. ! IF( nfxd > 0 ) THEN na = MIN( m, nfxd ) !CC CALL SGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) CALL sgeqrf( m, na, a, lda, tau, work, lwork, info ) iws = MAX( iws, INT( work( 1 ) ) ) IF( na < n ) THEN !CC CALL SORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA, !CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO ) CALL sormqr( 'Left', 'Transpose', m, n-na, na, a, lda, tau, & a( 1, na+1 ), lda, work, lwork, info ) iws = MAX( iws, INT( work( 1 ) ) ) END IF END IF ! ! Factorize free columns ! ====================== ! IF( nfxd < minmn ) THEN ! sm = m - nfxd sn = n - nfxd sminmn = minmn - nfxd ! ! Determine the block size. ! nb = ilaenv( inb, 'SGEQRF', ' ', sm, sn, -1, -1 ) nbmin = 2 nx = 0 ! IF( ( nb > 1 ) .AND. ( nb < sminmn ) ) THEN ! ! Determine when to cross over from blocked to unblocked code. ! nx = MAX( 0, ilaenv( ixover, 'SGEQRF', ' ', sm, sn, -1, -1 ) ) ! ! IF( nx < sminmn ) THEN ! ! Determine if workspace is large enough for blocked code. ! minws = 2*sn + ( sn+1 )*nb iws = MAX( iws, minws ) IF( lwork < minws ) THEN ! ! Not enough workspace to use optimal NB: Reduce NB and ! determine the minimum value of NB. ! nb = ( lwork-2*sn ) / ( sn+1 ) nbmin = MAX( 2, ilaenv( inbmin, 'SGEQRF', ' ', sm, sn, -1, -1 ) ) ! ! END IF END IF END IF ! ! Initialize partial column norms. The first N elements of work ! store the exact column norms. ! DO j = nfxd + 1, n work( j ) = snrm2( sm, a( nfxd+1, j ), 1 ) work( n+j ) = work( j ) END DO ! IF( ( nb >= nbmin ) .AND. ( nb < sminmn ) .AND. ( nx < sminmn ) ) THEN ! ! Use blocked code initially. ! j = nfxd + 1 ! ! Compute factorization: while loop. ! ! topbmn = minmn - nx 30 CONTINUE IF( j <= topbmn ) THEN jb = MIN( nb, topbmn-j+1 ) ! ! Factorize JB columns among columns J:N. ! CALL slaqps( m, n-j+1, j-1, jb, fjb, a( 1, j ), lda, & jpvt( j ), tau( j ), work( j ), work( n+j ), & work( 2*n+1 ), work( 2*n+jb+1 ), n-j+1 ) ! j = j + fjb GO TO 30 END IF ELSE j = nfxd + 1 END IF ! ! Use unblocked code to factor the last or only block. ! ! IF( j <= minmn ) CALL slaqp2( m, n-j+1, j-1, a( 1, j ), lda, jpvt( j ), & tau( j ), work( j ), work( n+j ), work( 2*n+1 ) ) ! END IF ! work( 1 ) = iws RETURN ! ! End of SGEQP3 ! END SUBROUTINE sgeqp3 SUBROUTINE sgeqpf( m, n, a, lda, jpvt, tau, work, info ) ! ! -- LAPACK test 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, INTENT(IN) :: m INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(IN OUT) :: jpvt( * ) REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! This routine is deprecated and has been replaced by routine SGEQP3. ! ! SGEQPF computes a QR factorization with column pivoting of a ! real M-by-N matrix A: A*P = 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) REAL array, dimension (LDA,N) ! On entry, the M-by-N matrix A. ! On exit, the upper triangle of the array contains the ! min(M,N)-by-N upper triangular matrix R; the elements ! below the diagonal, together with the array TAU, ! represent the orthogonal matrix Q as a product of ! min(m,n) elementary reflectors. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! JPVT (input/output) INTEGER array, dimension (N) ! On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted ! to the front of A*P (a leading column); if JPVT(i) = 0, ! the i-th column of A is a free column. ! On exit, if JPVT(i) = k, then the i-th column of A*P ! was the k-th column of A. ! ! TAU (output) REAL array, dimension (min(M,N)) ! The scalar factors of the elementary reflectors. ! ! WORK (workspace) REAL array, dimension (3*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(n) ! ! Each H(i) has the form ! ! H = I - tau * v * v' ! ! where tau is a real scalar, and v is a real 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). ! ! The matrix P is represented in jpvt as follows: If ! jpvt(j) = i ! then the jth column of P is the ith canonical unit vector. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, itemp, j, ma, mn, pvt REAL :: aii, temp, temp2 ! .. ! .. External Subroutines .. EXTERNAL sgeqr2, slarf, slarfg, sorm2r, sswap, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT ! .. ! .. External Functions .. INTEGER :: isamax REAL :: snrm2 EXTERNAL isamax, snrm2 ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, m ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGEQPF', -info ) RETURN END IF ! mn = MIN( m, n ) ! ! Move initial columns up front ! itemp = 1 DO i = 1, n IF( jpvt( i ) /= 0 ) THEN IF( i /= itemp ) THEN CALL sswap( m, a( 1, i ), 1, a( 1, itemp ), 1 ) jpvt( i ) = jpvt( itemp ) jpvt( itemp ) = i ELSE jpvt( i ) = i END IF itemp = itemp + 1 ELSE jpvt( i ) = i END IF END DO itemp = itemp - 1 ! ! Compute the QR factorization and update remaining columns ! IF( itemp > 0 ) THEN ma = MIN( itemp, m ) CALL sgeqr2( m, ma, a, lda, tau, work, info ) IF( ma < n ) THEN CALL sorm2r( 'Left', 'Transpose', m, n-ma, ma, a, lda, tau, & a( 1, ma+1 ), lda, work, info ) END IF END IF ! IF( itemp < mn ) THEN ! ! Initialize partial column norms. The first n elements of ! work store the exact column norms. ! DO i = itemp + 1, n work( i ) = snrm2( m-itemp, a( itemp+1, i ), 1 ) work( n+i ) = work( i ) END DO ! ! Compute factorization ! DO i = itemp + 1, mn ! ! Determine ith pivot column and swap if necessary ! pvt = ( i-1 ) + isamax( n-i+1, work( i ), 1 ) ! IF( pvt /= i ) THEN CALL sswap( m, a( 1, pvt ), 1, a( 1, i ), 1 ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( i ) jpvt( i ) = itemp work( pvt ) = work( i ) work( n+pvt ) = work( n+i ) END IF ! ! Generate elementary reflector H(i) ! IF( i < m ) THEN CALL slarfg( m-i+1, a( i, i ), a( i+1, i ), 1, tau( i ) ) ELSE CALL slarfg( 1, a( m, m ), a( m, m ), 1, tau( m ) ) END IF ! IF( i < n ) THEN ! ! Apply H(i) to A(i:m,i+1:n) from the left ! aii = a( i, i ) a( i, i ) = one CALL slarf( 'LEFT', m-i+1, n-i, a( i, i ), 1, tau( i ), & a( i, i+1 ), lda, work( 2*n+1 ) ) a( i, i ) = aii END IF ! ! Update partial column norms ! DO j = i + 1, n IF( work( j ) /= zero ) THEN temp = one - ( ABS( a( i, j ) ) / work( j ) )**2 temp = MAX( temp, zero ) temp2 = one + 0.05*temp*( work( j ) / work( n+j ) )**2 IF( temp2 == one ) THEN IF( m-i > 0 ) THEN work( j ) = snrm2( m-i, a( i+1, j ), 1 ) work( n+j ) = work( j ) ELSE work( j ) = zero work( n+j ) = zero END IF ELSE work( j ) = work( j )*SQRT( temp ) END IF END IF END DO ! END DO END IF RETURN ! ! End of SGEQPF ! END SUBROUTINE sgeqpf SUBROUTINE sgeqr2( 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 ! February 29, 1992 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGEQR2 computes a QR factorization of a real 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) REAL 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 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,M). ! ! TAU (output) REAL array, dimension (min(M,N)) ! The scalar factors of the elementary reflectors (see Further ! Details). ! ! WORK (workspace) REAL 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 real scalar, and v is a real 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, k REAL :: aii ! .. ! .. External Subroutines .. EXTERNAL slarf, slarfg, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, m ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGEQR2', -info ) RETURN END IF ! k = MIN( m, n ) ! DO i = 1, k ! ! Generate elementary reflector H(i) to annihilate A(i+1:m,i) ! CALL slarfg( m-i+1, a( i, i ), a( MIN( i+1, m ), i ), 1, tau( i ) ) IF( i < n ) THEN ! ! Apply H(i) to A(i:m,i+1:n) from the left ! aii = a( i, i ) a( i, i ) = one CALL slarf( 'Left', m-i+1, n-i, a( i, i ), 1, tau( i ), & a( i, i+1 ), lda, work ) a( i, i ) = aii END IF END DO RETURN ! ! End of SGEQR2 ! END SUBROUTINE sgeqr2 SUBROUTINE sgeqrf( 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGEQRF computes a QR factorization of a real 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) REAL 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 orthogonal 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) REAL array, dimension (min(M,N)) ! The scalar factors of the elementary reflectors (see Further ! Details). ! ! WORK (workspace/output) REAL 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 real scalar, and v is a real 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 sgeqr2, slarfb, slarft, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 nb = ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) lwkopt = n*nb work( 1 ) = lwkopt lquery = ( lwork == -1 ) IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, m ) ) THEN info = -4 ELSE IF( lwork < MAX( 1, n ) .AND. .NOT.lquery ) THEN info = -7 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGEQRF', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! k = MIN( m, n ) IF( k == 0 ) THEN work( 1 ) = 1 RETURN END IF ! nbmin = 2 nx = 0 iws = n IF( nb > 1 .AND. nb < k ) THEN ! ! Determine when to cross over from blocked to unblocked code. ! nx = MAX( 0, ilaenv( 3, 'SGEQRF', ' ', m, n, -1, -1 ) ) IF( nx < k ) THEN ! ! Determine if workspace is large enough for blocked code. ! ldwork = n iws = ldwork*nb IF( lwork < 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, 'SGEQRF', ' ', m, n, -1, -1 ) ) END IF END IF END IF ! IF( nb >= nbmin .AND. nb < k .AND. nx < k ) THEN ! ! Use blocked code initially ! DO 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 sgeqr2( m-i+1, ib, a( i, i ), lda, tau( i ), work, iinfo ) IF( i+ib <= n ) THEN ! ! Form the triangular factor of the block reflector ! H = H(i) H(i+1) . . . H(i+ib-1) ! CALL slarft( '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 slarfb( 'Left', '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 END DO ELSE i = 1 END IF ! ! Use unblocked code to factor the last or only block. ! IF( i <= k ) CALL sgeqr2( m-i+1, n-i+1, a( i, i ), lda, tau( i ), work, & iinfo ) ! work( 1 ) = iws RETURN ! ! End of SGEQRF ! END SUBROUTINE sgeqrf SUBROUTINE sgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, & x, ldx, ferr, berr, 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 ! September 30, 1994 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: af( ldaf, * ) INTEGER, INTENT(IN OUT) :: ldaf INTEGER, INTENT(IN OUT) :: ipiv( * ) REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: ferr( * ) REAL, INTENT(OUT) :: berr( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGERFS improves the computed solution to a system of linear ! equations and provides error bounds and backward error estimates for ! the solution. ! ! 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 = 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 matrices B and X. NRHS >= 0. ! ! A (input) REAL array, dimension (LDA,N) ! The original N-by-N matrix A. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! AF (input) REAL array, dimension (LDAF,N) ! The factors L and U from the factorization A = P*L*U ! as computed by SGETRF. ! ! LDAF (input) INTEGER ! The leading dimension of the array AF. LDAF >= max(1,N). ! ! IPIV (input) INTEGER array, dimension (N) ! The pivot indices from SGETRF; for 1<=i<=N, row i of the ! matrix was interchanged with row IPIV(i). ! ! B (input) REAL array, dimension (LDB,NRHS) ! The right hand side matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (input/output) REAL array, dimension (LDX,NRHS) ! On entry, the solution matrix X, as computed by SGETRS. ! On exit, the improved solution matrix X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! Internal Parameters ! =================== ! ! ITMAX is the maximum number of steps of iterative refinement. ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: itmax = 5 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 REAL, PARAMETER :: three = 3.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: notran CHARACTER (LEN=1) :: transt INTEGER :: count, i, j, k, kase, nz REAL :: eps, lstres, s, safe1, safe2, safmin, xk ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, sgemv, sgetrs, slacon, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. 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 < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( ldaf < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -10 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -12 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGERFS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) THEN DO j = 1, nrhs ferr( j ) = zero berr( j ) = zero END DO RETURN END IF ! IF( notran ) THEN transt = 'T' ELSE transt = 'N' END IF ! ! NZ = maximum number of nonzero elements in each row of A, plus 1 ! nz = n + 1 eps = slamch( 'Epsilon' ) safmin = slamch( 'Safe minimum' ) safe1 = nz*safmin safe2 = safe1 / eps ! ! Do for each right hand side ! DO j = 1, nrhs ! count = 1 lstres = three 20 CONTINUE ! ! Loop until stopping criterion is satisfied. ! ! Compute residual R = B - op(A) * X, ! where op(A) = A, A**T, or A**H, depending on TRANS. ! CALL scopy( n, b( 1, j ), 1, work( n+1 ), 1 ) CALL sgemv( trans, n, n, -one, a, lda, x( 1, j ), 1, one, work( n+1 ), 1 ) ! ! Compute componentwise relative backward error from formula ! ! max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) ! ! where abs(Z) is the componentwise absolute value of the matrix ! or vector Z. If the i-th component of the denominator is less ! than SAFE2, then SAFE1 is added to the i-th components of the ! numerator and denominator before dividing. ! DO i = 1, n work( i ) = ABS( b( i, j ) ) END DO ! ! Compute abs(op(A))*abs(X) + abs(B). ! IF( notran ) THEN DO k = 1, n xk = ABS( x( k, j ) ) DO i = 1, n work( i ) = work( i ) + ABS( a( i, k ) )*xk END DO END DO ELSE DO k = 1, n s = zero DO i = 1, n s = s + ABS( a( i, k ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + s END DO END IF s = zero DO i = 1, n IF( work( i ) > safe2 ) THEN s = MAX( s, ABS( work( n+i ) ) / work( i ) ) ELSE s = MAX( s, ( ABS( work( n+i ) )+safe1 ) / ( work( i )+safe1 ) ) END IF END DO berr( j ) = s ! ! Test stopping criterion. Continue iterating if ! 1) The residual BERR(J) is larger than machine epsilon, and ! 2) BERR(J) decreased by at least a factor of 2 during the ! last iteration, and ! 3) At most ITMAX iterations tried. ! IF( berr( j ) > eps .AND. two*berr( j ) <= lstres .AND. & count <= itmax ) THEN ! ! Update solution and try again. ! CALL sgetrs( trans, n, 1, af, ldaf, ipiv, work( n+1 ), n, info ) CALL saxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 GO TO 20 END IF ! ! Bound error from formula ! ! norm(X - XTRUE) / norm(X) .le. FERR = ! norm( abs(inv(op(A)))* ! ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) ! ! where ! norm(Z) is the magnitude of the largest component of Z ! inv(op(A)) is the inverse of op(A) ! abs(Z) is the componentwise absolute value of the matrix or ! vector Z ! NZ is the maximum number of nonzeros in any row of A, plus 1 ! EPS is machine epsilon ! ! The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) ! is incremented by SAFE1 if the i-th component of ! abs(op(A))*abs(X) + abs(B) is less than SAFE2. ! ! Use SLACON to estimate the infinity-norm of the matrix ! inv(op(A)) * diag(W), ! where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) ! DO i = 1, n IF( work( i ) > safe2 ) THEN work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) ELSE work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) + safe1 END IF END DO ! kase = 0 100 CONTINUE CALL slacon( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ), kase ) IF( kase /= 0 ) THEN IF( kase == 1 ) THEN ! ! Multiply by diag(W)*inv(op(A)**T). ! CALL sgetrs( transt, n, 1, af, ldaf, ipiv, work( n+1 ), n, info ) DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO ELSE ! ! Multiply by inv(op(A))*diag(W). ! DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO CALL sgetrs( trans, n, 1, af, ldaf, ipiv, work( n+1 ), n, info ) END IF GO TO 100 END IF ! ! Normalize error. ! lstres = zero DO i = 1, n lstres = MAX( lstres, ABS( x( i, j ) ) ) END DO IF( lstres /= zero ) ferr( j ) = ferr( j ) / lstres ! END DO ! RETURN ! ! End of SGERFS ! END SUBROUTINE sgerfs SUBROUTINE sgerq2( 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 ! February 29, 1992 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN OUT) :: m INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGERQ2 computes an RQ factorization of a real m by n matrix A: ! A = R * 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) REAL array, dimension (LDA,N) ! On entry, the m by n matrix A. ! On exit, if m <= n, the upper triangle of the subarray ! A(1:m,n-m+1:n) contains the m by m upper triangular matrix R; ! if m >= n, the elements on and above the (m-n)-th subdiagonal ! contain the m by n upper trapezoidal matrix R; the remaining ! elements, 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,M). ! ! TAU (output) REAL array, dimension (min(M,N)) ! The scalar factors of the elementary reflectors (see Further ! Details). ! ! WORK (workspace) REAL 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(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 real scalar, and v is a real vector with ! v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in ! A(m-k+i,1:n-k+i-1), and tau in TAU(i). ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, k REAL :: aii ! .. ! .. External Subroutines .. EXTERNAL slarf, slarfg, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, m ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGERQ2', -info ) RETURN END IF ! k = MIN( m, n ) ! DO i = k, 1, -1 ! ! Generate elementary reflector H(i) to annihilate ! A(m-k+i,1:n-k+i-1) ! CALL slarfg( n-k+i, a( m-k+i, n-k+i ), a( m-k+i, 1 ), lda, tau( i ) ) ! ! Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right ! aii = a( m-k+i, n-k+i ) a( m-k+i, n-k+i ) = one CALL slarf( 'Right', m-k+i-1, n-k+i, a( m-k+i, 1 ), lda, & tau( i ), a, lda, work ) a( m-k+i, n-k+i ) = aii END DO RETURN ! ! End of SGERQ2 ! END SUBROUTINE sgerq2 SUBROUTINE sgerqf( 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGERQF computes an RQ factorization of a real M-by-N matrix A: ! A = R * 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) REAL array, dimension (LDA,N) ! On entry, the M-by-N matrix A. ! On exit, ! if m <= n, the upper triangle of the subarray ! A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R; ! if m >= n, the elements on and above the (m-n)-th subdiagonal ! contain the M-by-N upper trapezoidal matrix R; ! the remaining elements, with the array TAU, represent the ! orthogonal 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) REAL array, dimension (min(M,N)) ! The scalar factors of the elementary reflectors (see Further ! Details). ! ! WORK (workspace/output) REAL 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(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 real scalar, and v is a real vector with ! v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in ! A(m-k+i,1:n-k+i-1), and tau in TAU(i). ! ! ===================================================================== ! ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: i, ib, iinfo, iws, k, ki, kk, ldwork, lwkopt, mu, nb, nbmin, nu, nx ! .. ! .. External Subroutines .. EXTERNAL sgerq2, slarfb, slarft, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 nb = ilaenv( 1, 'SGERQF', ' ', m, n, -1, -1 ) lwkopt = m*nb work( 1 ) = lwkopt lquery = ( lwork == -1 ) IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, m ) ) THEN info = -4 ELSE IF( lwork < MAX( 1, m ) .AND. .NOT.lquery ) THEN info = -7 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGERQF', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! k = MIN( m, n ) IF( k == 0 ) THEN work( 1 ) = 1 RETURN END IF ! nbmin = 2 nx = 1 iws = m IF( nb > 1 .AND. nb < k ) THEN ! ! Determine when to cross over from blocked to unblocked code. ! nx = MAX( 0, ilaenv( 3, 'SGERQF', ' ', m, n, -1, -1 ) ) IF( nx < k ) THEN ! ! Determine if workspace is large enough for blocked code. ! ldwork = m iws = ldwork*nb IF( lwork < 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, 'SGERQF', ' ', m, n, -1, -1 ) ) END IF END IF END IF ! IF( nb >= nbmin .AND. nb < k .AND. nx < k ) THEN ! ! Use blocked code initially. ! The last kk rows are handled by the block method. ! ki = ( ( k-nx-1 ) / nb )*nb kk = MIN( k, ki+nb ) ! DO i = k - kk + ki + 1, k - kk + 1, -nb ib = MIN( k-i+1, nb ) ! ! Compute the RQ factorization of the current block ! A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1) ! CALL sgerq2( ib, n-k+i+ib-1, a( m-k+i, 1 ), lda, tau( i ), work, iinfo ) IF( m-k+i > 1 ) THEN ! ! Form the triangular factor of the block reflector ! H = H(i+ib-1) . . . H(i+1) H(i) ! CALL slarft( 'Backward', 'Rowwise', n-k+i+ib-1, ib, & a( m-k+i, 1 ), lda, tau( i ), work, ldwork ) ! ! Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right ! CALL slarfb( 'Right', 'No transpose', 'Backward', & 'Rowwise', m-k+i-1, n-k+i+ib-1, ib, & a( m-k+i, 1 ), lda, work, ldwork, a, lda, work( ib+1 ), ldwork ) END IF END DO mu = m - k + i + nb - 1 nu = n - k + i + nb - 1 ELSE mu = m nu = n END IF ! ! Use unblocked code to factor the last or only block ! IF( mu > 0 .AND. nu > 0 ) CALL sgerq2( mu, nu, a, lda, tau, work, iinfo ) ! work( 1 ) = iws RETURN ! ! End of SGERQF ! END SUBROUTINE sgerqf SUBROUTINE sgesc2( n, a, lda, rhs, ipiv, jpiv, scale ) ! ! -- 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, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: rhs( * ) INTEGER, INTENT(IN OUT) :: ipiv( * ) INTEGER, INTENT(IN OUT) :: jpiv( * ) REAL, INTENT(OUT) :: scale ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGESC2 solves a system of linear equations ! ! A * X = scale* RHS ! ! with a general N-by-N matrix A using the LU factorization with ! complete pivoting computed by SGETC2. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The order of the matrix A. ! ! A (input) REAL array, dimension (LDA,N) ! On entry, the LU part of the factorization of the n-by-n ! matrix A computed by SGETC2: A = P * L * U * Q ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1, N). ! ! RHS (input/output) REAL array, dimension (N). ! On entry, the right hand side vector b. ! On exit, the solution vector X. ! ! IPIV (iput) INTEGER array, dimension (N). ! The pivot indices; for 1 <= i <= N, row i of the ! matrix has been interchanged with row IPIV(i). ! ! JPIV (iput) INTEGER array, dimension (N). ! The pivot indices; for 1 <= j <= N, column j of the ! matrix has been interchanged with column JPIV(j). ! ! SCALE (output) REAL ! On exit, SCALE contains the scale factor. SCALE is chosen ! 0 <= SCALE <= 1 to prevent owerflow in the solution. ! ! Further Details ! =============== ! ! Based on contributions by ! Bo Kagstrom and Peter Poromaa, Department of Computing Science, ! Umea University, S-901 87 Umea, Sweden. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j REAL :: bignum, eps, smlnum, temp ! .. ! .. External Subroutines .. EXTERNAL slabad, slaswp, sscal ! .. ! .. External Functions .. INTEGER :: isamax REAL :: slamch EXTERNAL isamax, slamch ! .. ! .. Intrinsic Functions .. INTRINSIC ABS ! .. ! .. Executable Statements .. ! ! Set constant to control owerflow ! eps = slamch( 'P' ) smlnum = slamch( 'S' ) / eps bignum = one / smlnum CALL slabad( smlnum, bignum ) ! ! Apply permutations IPIV to RHS ! CALL slaswp( 1, rhs, lda, 1, n-1, ipiv, 1 ) ! ! Solve for L part ! DO i = 1, n - 1 DO j = i + 1, n rhs( j ) = rhs( j ) - a( j, i )*rhs( i ) END DO END DO ! ! Solve for U part ! scale = one ! ! Check for scaling ! i = isamax( n, rhs, 1 ) IF( two*smlnum*ABS( rhs( i ) ) > ABS( a( n, n ) ) ) THEN temp = ( one / two ) / ABS( rhs( i ) ) CALL sscal( n, temp, rhs( 1 ), 1 ) scale = scale*temp END IF ! DO i = n, 1, -1 temp = one / a( i, i ) rhs( i ) = rhs( i )*temp DO j = i + 1, n rhs( i ) = rhs( i ) - rhs( j )*( a( i, j )*temp ) END DO END DO ! ! Apply permutations JPIV to the solution (RHS) ! CALL slaswp( 1, rhs, lda, 1, n-1, jpiv, -1 ) RETURN ! ! End of SGESC2 ! END SUBROUTINE sgesc2 SUBROUTINE sgesdd( jobz, m, n, a, lda, s, u, ldu, vt, ldvt, & work, lwork, iwork, 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 (LEN=1), INTENT(IN) :: jobz INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN OUT) :: s( * ) REAL, INTENT(IN OUT) :: u( ldu, * ) INTEGER, INTENT(IN OUT) :: ldu REAL, INTENT(IN OUT) :: vt( ldvt, * ) INTEGER, INTENT(IN OUT) :: ldvt REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGESDD computes the singular value decomposition (SVD) of a real ! M-by-N matrix A, optionally computing the left and right singular ! vectors. If singular vectors are desired, it uses a ! divide-and-conquer algorithm. ! ! The SVD is written ! ! A = U * SIGMA * 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 orthogonal matrix, and ! V is an N-by-N orthogonal 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 VT = V**T, not V. ! ! The divide and conquer algorithm makes very mild assumptions about ! floating point arithmetic. It will work on machines with a guard ! digit in add/subtract, or on those binary machines without guard ! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or ! Cray-2. It could conceivably fail on hexadecimal or decimal machines ! without guard digits, but we know of none. ! ! Arguments ! ========= ! ! JOBZ (input) CHARACTER*1 ! Specifies options for computing all or part of the matrix U: ! = 'A': all M columns of U and all N rows of V**T are ! returned in the arrays U and VT; ! = 'S': the first min(M,N) columns of U and the first ! min(M,N) rows of V**T are returned in the arrays U ! and VT; ! = 'O': If M >= N, the first N columns of U are overwritten ! on the array A and all rows of V**T are returned in ! the array VT; ! otherwise, all columns of U are returned in the ! array U and the first M rows of V**T are overwritten ! in the array VT; ! = 'N': no columns of U or rows of V**T are computed. ! ! 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) REAL array, dimension (LDA,N) ! On entry, the M-by-N matrix A. ! On exit, ! if JOBZ = 'O', A is overwritten with the first N columns ! of U (the left singular vectors, stored ! columnwise) if M >= N; ! A is overwritten with the first M rows ! of V**T (the right singular vectors, stored ! rowwise) otherwise. ! if JOBZ .ne. 'O', the contents of A are destroyed. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! S (output) REAL array, dimension (min(M,N)) ! The singular values of A, sorted so that S(i) >= S(i+1). ! ! U (output) REAL array, dimension (LDU,UCOL) ! UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N; ! UCOL = min(M,N) if JOBZ = 'S'. ! If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M ! orthogonal matrix U; ! if JOBZ = 'S', U contains the first min(M,N) columns of U ! (the left singular vectors, stored columnwise); ! if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced. ! ! LDU (input) INTEGER ! The leading dimension of the array U. LDU >= 1; if ! JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M. ! ! VT (output) REAL array, dimension (LDVT,N) ! If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the ! N-by-N orthogonal matrix V**T; ! if JOBZ = 'S', VT contains the first min(M,N) rows of ! V**T (the right singular vectors, stored rowwise); ! if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced. ! ! LDVT (input) INTEGER ! The leading dimension of the array VT. LDVT >= 1; if ! JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N; ! if JOBZ = 'S', LDVT >= min(M,N). ! ! WORK (workspace/output) REAL 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. ! If JOBZ = 'N', ! LWORK >= max(14*min(M,N)+4, 10*min(M,N)+2+ ! SMLSIZ*(SMLSIZ+8)) + max(M,N) ! where SMLSIZ is returned by ILAENV and is equal to the ! maximum size of the subproblems at the bottom of the ! computation tree (usually about 25). ! If JOBZ = 'O', ! LWORK >= 5*min(M,N)*min(M,N) + max(M,N) + 9*min(M,N). ! If JOBZ = 'S' or 'A' ! LWORK >= 4*min(M,N)*min(M,N) + max(M,N) + 9*min(M,N). ! For good performance, LWORK should generally be larger. ! If LWORK < 0 but other input arguments are legal, WORK(1) ! returns optimal LWORK. ! ! IWORK (workspace) INTEGER array, dimension (8*min(M,N)) ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: SBDSDC did not converge, updating process failed. ! ! Further Details ! =============== ! ! Based on contributions by ! Ming Gu and Huan Ren, Computer Science Division, University of ! California at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: wntqa, wntqas, wntqn, wntqo, wntqs INTEGER :: bdspac, bdspan, blk, chunk, i, ie, ierr, il, & ir, iscl, itau, itaup, itauq, iu, ivt, ldwkvt, & ldwrkl, ldwrkr, ldwrku, maxwrk, minmn, minwrk, mnthr, nwork, smlsiz, wrkbl REAL :: anrm, bignum, eps, smlnum ! .. ! .. Local Arrays .. INTEGER :: idum( 1 ) REAL :: dum( 1 ) ! .. ! .. External Subroutines .. EXTERNAL sbdsdc, sgebrd, sgelqf, sgemm, sgeqrf, slacpy, & slascl, slaset, sorgbr, sorglq, sorgqr, sormbr, xerbla ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slange EXTERNAL slamch, slange, ilaenv, lsame ! .. ! .. Intrinsic Functions .. INTRINSIC REAL, INT, MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 minmn = MIN( m, n ) mnthr = INT( minmn*11.0 / 6.0 ) wntqa = lsame( jobz, 'A' ) wntqs = lsame( jobz, 'S' ) wntqas = wntqa .OR. wntqs wntqo = lsame( jobz, 'O' ) wntqn = lsame( jobz, 'N' ) minwrk = 1 ! IF( .NOT.( wntqa .OR. wntqs .OR. wntqo .OR. wntqn ) ) THEN info = -1 ELSE IF( m < 0 ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, m ) ) THEN info = -5 ELSE IF( ldu < 1 .OR. ( wntqas .AND. ldu < m ) .OR. & ( wntqo .AND. m < n .AND. ldu < m ) ) THEN info = -8 ELSE IF( ldvt < 1 .OR. ( wntqa .AND. ldvt < n ) .OR. & ( wntqs .AND. ldvt < minmn ) .OR. & ( wntqo .AND. m >= n .AND. ldvt < n ) ) THEN info = -10 END IF ! smlsiz = ilaenv( 9, 'SGESDD', ' ', 0, 0, 0, 0 ) ! ! 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.) ! IF( info == 0 .AND. lwork >= 1 .AND. m > 0 .AND. n > 0 ) THEN IF( m >= n ) THEN ! ! Compute space needed for SBDSDC ! bdspac = 3*n*n + 7*n bdspan = MAX( 12*n+4, 8*n+2+smlsiz*( smlsiz+8 ) ) IF( m >= mnthr ) THEN IF( wntqn ) THEN ! ! Path 1 (M much larger than N, JOBZ='N') ! maxwrk = n + n*ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) maxwrk = MAX( maxwrk, 3*n+2*n* & ilaenv( 1, 'SGEBRD', ' ', n, n, -1, -1 ) ) maxwrk = MAX( maxwrk, bdspac ) minwrk = bdspac ELSE IF( wntqo ) THEN ! ! Path 2 (M much larger than N, JOBZ='O') ! wrkbl = n + n*ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, n+n*ilaenv( 1, 'SORGQR', ' ', m, n, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+2*n* & ilaenv( 1, 'SGEBRD', ' ', n, n, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*n+n* ilaenv( 1, 'SORMBR', 'QLN', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+n* ilaenv( 1, 'SORMBR', 'PRT', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, bdspac+2*n ) maxwrk = wrkbl + 2*n*n minwrk = bdspac + 2*n*n + 2*n ELSE IF( wntqs ) THEN ! ! Path 3 (M much larger than N, JOBZ='S') ! wrkbl = n + n*ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, n+n*ilaenv( 1, 'SORGQR', ' ', m, n, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+2*n* & ilaenv( 1, 'SGEBRD', ' ', n, n, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*n+n* ilaenv( 1, 'SORMBR', 'QLN', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+n* ilaenv( 1, 'SORMBR', 'PRT', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, bdspac+2*n ) maxwrk = wrkbl + n*n minwrk = bdspac + n*n + 2*n ELSE IF( wntqa ) THEN ! ! Path 4 (M much larger than N, JOBZ='A') ! wrkbl = n + n*ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, n+m*ilaenv( 1, 'SORGQR', ' ', m, m, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+2*n* & ilaenv( 1, 'SGEBRD', ' ', n, n, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*n+n* ilaenv( 1, 'SORMBR', 'QLN', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+n* ilaenv( 1, 'SORMBR', 'PRT', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, bdspac+2*n ) maxwrk = n*n + wrkbl minwrk = bdspac + n*n + m + n END IF ELSE ! ! Path 5 (M at least N, but not much larger) ! wrkbl = 3*n + ( m+n )*ilaenv( 1, 'SGEBRD', ' ', m, n, -1, -1 ) IF( wntqo ) THEN wrkbl = MAX( wrkbl, 3*n+n* ilaenv( 1, 'SORMBR', 'QLN', m, n, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+n* ilaenv( 1, 'SORMBR', 'PRT', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, bdspac+2*n+m ) maxwrk = wrkbl + m*n minwrk = bdspac + n*n + 2*n + m ELSE IF( wntqs ) THEN maxwrk = MAX( maxwrk, 3*n+n* & ilaenv( 1, 'SORMBR', 'QLN', m, n, n, -1 ) ) maxwrk = MAX( maxwrk, 3*n+n* & ilaenv( 1, 'SORMBR', 'PRT', n, n, n, -1 ) ) maxwrk = MAX( maxwrk, bdspac+2*n+m ) minwrk = bdspac + 2*n + m ELSE IF( wntqa ) THEN maxwrk = MAX( maxwrk, 3*n+m* & ilaenv( 1, 'SORMBR', 'QLN', m, m, n, -1 ) ) maxwrk = MAX( maxwrk, 3*n+n* & ilaenv( 1, 'SORMBR', 'PRT', n, n, n, -1 ) ) maxwrk = MAX( maxwrk, bdspac+2*n+m ) minwrk = bdspac + 2*n + m END IF END IF ELSE ! ! Compute space needed for SBDSDC ! bdspac = 3*m*m + 7*m bdspan = MAX( 12*m+4, 8*m+2+smlsiz*( smlsiz+8 ) ) IF( n >= mnthr ) THEN IF( wntqn ) THEN ! ! Path 1t (N much larger than M, JOBZ='N') ! maxwrk = m + m*ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) maxwrk = MAX( maxwrk, 3*m+2*m* & ilaenv( 1, 'SGEBRD', ' ', m, m, -1, -1 ) ) maxwrk = MAX( maxwrk, bdspac ) minwrk = bdspac ELSE IF( wntqo ) THEN ! ! Path 2t (N much larger than M, JOBZ='O') ! wrkbl = m + m*ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, m+m*ilaenv( 1, 'SORGLQ', ' ', m, n, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+2*m* & ilaenv( 1, 'SGEBRD', ' ', m, m, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*m+m* ilaenv( 1, 'SORMBR', 'QLN', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+m* ilaenv( 1, 'SORMBR', 'PRT', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, bdspac+2*m ) maxwrk = wrkbl + 2*m*m minwrk = bdspac + 2*m*m + 2*m ELSE IF( wntqs ) THEN ! ! Path 3t (N much larger than M, JOBZ='S') ! wrkbl = m + m*ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, m+m*ilaenv( 1, 'SORGLQ', ' ', m, n, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+2*m* & ilaenv( 1, 'SGEBRD', ' ', m, m, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*m+m* ilaenv( 1, 'SORMBR', 'QLN', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+m* ilaenv( 1, 'SORMBR', 'PRT', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, bdspac+2*m ) maxwrk = wrkbl + m*m minwrk = bdspac + m*m + 2*m ELSE IF( wntqa ) THEN ! ! Path 4t (N much larger than M, JOBZ='A') ! wrkbl = m + m*ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, m+n*ilaenv( 1, 'SORGLQ', ' ', n, n, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+2*m* & ilaenv( 1, 'SGEBRD', ' ', m, m, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*m+m* ilaenv( 1, 'SORMBR', 'QLN', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+m* ilaenv( 1, 'SORMBR', 'PRT', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, bdspac+2*m ) maxwrk = wrkbl + m*m minwrk = bdspac + m*m + m + n END IF ELSE ! ! Path 5t (N greater than M, but not much larger) ! wrkbl = 3*m + ( m+n )*ilaenv( 1, 'SGEBRD', ' ', m, n, -1, -1 ) IF( wntqo ) THEN wrkbl = MAX( wrkbl, 3*m+m* ilaenv( 1, 'SORMBR', 'QLN', m, m, n, -1 ) ) wrkbl = MAX( wrkbl, 3*m+m* ilaenv( 1, 'SORMBR', 'PRT', m, n, m, -1 ) ) wrkbl = MAX( wrkbl, bdspac+2*m ) maxwrk = wrkbl + m*n minwrk = bdspac + m*m + 2*m + n ELSE IF( wntqs ) THEN maxwrk = MAX( maxwrk, 3*m+m* & ilaenv( 1, 'SORMBR', 'QLN', m, m, n, -1 ) ) maxwrk = MAX( maxwrk, 3*m+m* & ilaenv( 1, 'SORMBR', 'PRT', m, n, m, -1 ) ) maxwrk = MAX( maxwrk, bdspac+2*m ) minwrk = bdspac + 2*m + n ELSE IF( wntqa ) THEN maxwrk = MAX( maxwrk, 3*m+m* & ilaenv( 1, 'SORMBR', 'QLN', m, m, n, -1 ) ) maxwrk = MAX( maxwrk, 3*m+n* & ilaenv( 1, 'SORMBR', 'PRT', n, n, m, -1 ) ) maxwrk = MAX( maxwrk, bdspac+2*m ) minwrk = bdspac + 2*m + n END IF END IF END IF work( 1 ) = maxwrk END IF ! IF( lwork < minwrk ) THEN info = -12 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGESDD', -info ) RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 ) THEN IF( lwork >= 1 ) work( 1 ) = one RETURN END IF ! ! Get machine constants ! eps = slamch( 'P' ) smlnum = SQRT( slamch( 'S' ) ) / eps bignum = one / smlnum ! ! Scale A if max element outside range [SMLNUM,BIGNUM] ! anrm = slange( 'M', m, n, a, lda, dum ) iscl = 0 IF( anrm > zero .AND. anrm < smlnum ) THEN iscl = 1 CALL slascl( 'G', 0, 0, anrm, smlnum, m, n, a, lda, ierr ) ELSE IF( anrm > bignum ) THEN iscl = 1 CALL slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) END IF ! IF( m >= 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 >= mnthr ) THEN ! IF( wntqn ) THEN ! ! Path 1 (M much larger than N, JOBZ='N') ! No singular vectors to be computed ! itau = 1 nwork = itau + n ! ! Compute A=Q*R ! (Workspace: need 2*N, prefer N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), work( nwork ), & lwork-nwork+1, ierr ) ! ! Zero out below R ! CALL slaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) ie = 1 itauq = ie + n itaup = itauq + n nwork = itaup + n ! ! Bidiagonalize R in A ! (Workspace: need 4*N, prefer 3*N+2*N*NB) ! CALL sgebrd( n, n, a, lda, s, work( ie ), work( itauq ), & work( itaup ), work( nwork ), lwork-nwork+1, ierr ) nwork = ie + n ! ! Perform bidiagonal SVD, computing singular values only ! (Workspace: need BDSPAN) ! CALL sbdsdc( 'U', 'N', n, s, work( ie ), dum, 1, dum, 1, & dum, idum, work( nwork ), iwork, info ) ! ELSE IF( wntqo ) THEN ! ! Path 2 (M much larger than N, JOBZ = 'O') ! N left singular vectors to be overwritten on A and ! N right singular vectors to be computed in VT ! ir = 1 ! ! WORK(IR) is LDWRKR by N ! IF( lwork >= lda*n+4*n*n+9*n ) THEN ldwrkr = lda ELSE ldwrkr = ( lwork-4*n*n-9*n ) / n END IF itau = ir + ldwrkr*n nwork = itau + n ! ! Compute A=Q*R ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), work( nwork ), & lwork-nwork+1, ierr ) ! ! Copy R to WORK(IR), zeroing out below it ! CALL slacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) CALL slaset( 'L', n-1, n-1, zero, zero, work( ir+1 ), ldwrkr ) ! ! Generate Q in A ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sorgqr( m, n, n, a, lda, work( itau ), & work( nwork ), lwork-nwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n nwork = itaup + n ! ! Bidiagonalize R in VT, copying result to WORK(IR) ! (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) ! CALL sgebrd( n, n, work( ir ), ldwrkr, s, work( ie ), & work( itauq ), work( itaup ), work( nwork ), lwork-nwork+1, ierr ) ! ! WORK(IU) is N by N ! iu = nwork nwork = iu + n*n ! ! Perform bidiagonal SVD, computing left singular vectors ! of bidiagonal matrix in WORK(IU) and computing right ! singular vectors of bidiagonal matrix in VT ! (Workspace: need 2*N*N+BDSPAC) ! CALL sbdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n, & vt, ldvt, dum, idum, work( nwork ), iwork, info ) ! ! Overwrite WORK(IU) by left singular vectors of R ! and VT by right singular vectors of R ! (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB) ! CALL sormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr, & work( itauq ), work( iu ), n, work( nwork ), lwork-nwork+1, ierr ) CALL sormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr, & work( itaup ), vt, ldvt, work( nwork ), lwork-nwork+1, ierr ) ! ! Multiply Q in A by left singular vectors of R in ! WORK(IU), storing result in WORK(IR) and copying to A ! (Workspace: need 2*N*N, prefer N*N+M*N) ! DO i = 1, m, ldwrkr chunk = MIN( m-i+1, ldwrkr ) CALL sgemm( 'N', 'N', chunk, n, n, one, a( i, 1 ), & lda, work( iu ), n, zero, work( ir ), ldwrkr ) CALL slacpy( 'F', chunk, n, work( ir ), ldwrkr, a( i, 1 ), lda ) END DO ! ELSE IF( wntqs ) THEN ! ! Path 3 (M much larger than N, JOBZ='S') ! N left singular vectors to be computed in U and ! N right singular vectors to be computed in VT ! ir = 1 ! ! WORK(IR) is N by N ! ldwrkr = n itau = ir + ldwrkr*n nwork = itau + n ! ! Compute A=Q*R ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), work( nwork ), & lwork-nwork+1, ierr ) ! ! Copy R to WORK(IR), zeroing out below it ! CALL slacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) CALL slaset( 'L', n-1, n-1, zero, zero, work( ir+1 ), ldwrkr ) ! ! Generate Q in A ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sorgqr( m, n, n, a, lda, work( itau ), & work( nwork ), lwork-nwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n nwork = itaup + n ! ! Bidiagonalize R in WORK(IR) ! (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) ! CALL sgebrd( n, n, work( ir ), ldwrkr, s, work( ie ), & work( itauq ), work( itaup ), work( nwork ), lwork-nwork+1, ierr ) ! ! Perform bidiagonal SVD, computing left singular vectors ! of bidiagoal matrix in U and computing right singular ! vectors of bidiagonal matrix in VT ! (Workspace: need N*N+BDSPAC) ! CALL sbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt, & ldvt, dum, idum, work( nwork ), iwork, info ) ! ! Overwrite U by left singular vectors of R and VT ! by right singular vectors of R ! (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) ! CALL sormbr( 'Q', 'L', 'N', n, n, n, work( ir ), ldwrkr, & work( itauq ), u, ldu, work( nwork ), lwork-nwork+1, ierr ) ! CALL sormbr( 'P', 'R', 'T', n, n, n, work( ir ), ldwrkr, & work( itaup ), vt, ldvt, work( nwork ), lwork-nwork+1, ierr ) ! ! Multiply Q in A by left singular vectors of R in ! WORK(IR), storing result in U ! (Workspace: need N*N) ! CALL slacpy( 'F', n, n, u, ldu, work( ir ), ldwrkr ) CALL sgemm( 'N', 'N', m, n, n, one, a, lda, work( ir ), & ldwrkr, zero, u, ldu ) ! ELSE IF( wntqa ) THEN ! ! Path 4 (M much larger than N, JOBZ='A') ! M left singular vectors to be computed in U and ! N right singular vectors to be computed in VT ! iu = 1 ! ! WORK(IU) is N by N ! ldwrku = n itau = iu + ldwrku*n nwork = itau + n ! ! Compute A=Q*R, copying result to U ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), work( nwork ), & lwork-nwork+1, ierr ) CALL slacpy( 'L', m, n, a, lda, u, ldu ) ! ! Generate Q in U ! (Workspace: need N*N+N+M, prefer N*N+N+M*NB) CALL sorgqr( m, m, n, u, ldu, work( itau ), & work( nwork ), lwork-nwork+1, ierr ) ! ! Produce R in A, zeroing out other entries ! CALL slaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) ie = itau itauq = ie + n itaup = itauq + n nwork = itaup + n ! ! Bidiagonalize R in A ! (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) ! CALL sgebrd( n, n, a, lda, s, work( ie ), work( itauq ), & work( itaup ), work( nwork ), lwork-nwork+1, ierr ) ! ! Perform bidiagonal SVD, computing left singular vectors ! of bidiagonal matrix in WORK(IU) and computing right ! singular vectors of bidiagonal matrix in VT ! (Workspace: need N*N+BDSPAC) ! CALL sbdsdc( 'U', 'I', n, s, work( ie ), work( iu ), n, & vt, ldvt, dum, idum, work( nwork ), iwork, info ) ! ! Overwrite WORK(IU) by left singular vectors of R and VT ! by right singular vectors of R ! (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB) ! CALL sormbr( 'Q', 'L', 'N', n, n, n, a, lda, & work( itauq ), work( iu ), ldwrku, work( nwork ), lwork-nwork+1, ierr ) CALL sormbr( 'P', 'R', 'T', n, n, n, a, lda, & work( itaup ), vt, ldvt, work( nwork ), lwork-nwork+1, ierr ) ! ! Multiply Q in U by left singular vectors of R in ! WORK(IU), storing result in A ! (Workspace: need N*N) ! CALL sgemm( 'N', 'N', m, n, n, one, u, ldu, work( iu ), & ldwrku, zero, a, lda ) ! ! Copy left singular vectors of A from A to U ! CALL slacpy( 'F', m, n, a, lda, u, ldu ) ! END IF ! ELSE ! ! M .LT. MNTHR ! ! Path 5 (M at least N, but not much larger) ! Reduce to bidiagonal form without QR decomposition ! ie = 1 itauq = ie + n itaup = itauq + n nwork = itaup + n ! ! Bidiagonalize A ! (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) ! CALL sgebrd( m, n, a, lda, s, work( ie ), work( itauq ), & work( itaup ), work( nwork ), lwork-nwork+1, ierr ) IF( wntqn ) THEN ! ! Perform bidiagonal SVD, only computing singular values ! (Workspace: need BDSPAN) ! CALL sbdsdc( 'U', 'N', n, s, work( ie ), dum, 1, dum, 1, & dum, idum, work( nwork ), iwork, info ) ELSE IF( wntqo ) THEN iu = nwork IF( lwork >= m*n+3*n*n+9*n ) THEN ! ! WORK( IU ) is M by N ! ldwrku = m nwork = iu + ldwrku*n CALL slaset( 'F', m, n, zero, zero, work( iu ), ldwrku ) ELSE ! ! WORK( IU ) is N by N ! ldwrku = n nwork = iu + ldwrku*n ! ! WORK(IR) is LDWRKR by N ! ir = nwork ldwrkr = ( lwork-n*n-3*n ) / n END IF nwork = iu + ldwrku*n ! ! Perform bidiagonal SVD, computing left singular vectors ! of bidiagonal matrix in WORK(IU) and computing right ! singular vectors of bidiagonal matrix in VT ! (Workspace: need N*N+BDSPAC) ! CALL sbdsdc( 'U', 'I', n, s, work( ie ), work( iu ), & ldwrku, vt, ldvt, dum, idum, work( nwork ), iwork, info ) ! ! Overwrite VT by right singular vectors of A ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sormbr( 'P', 'R', 'T', n, n, n, a, lda, & work( itaup ), vt, ldvt, work( nwork ), lwork-nwork+1, ierr ) ! IF( lwork >= m*n+3*n*n+9*n ) THEN ! ! Overwrite WORK(IU) by left singular vectors of A ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sormbr( 'Q', 'L', 'N', m, n, n, a, lda, & work( itauq ), work( iu ), ldwrku, & work( nwork ), lwork-nwork+1, ierr ) ! ! Copy left singular vectors of A from WORK(IU) to A ! CALL slacpy( 'F', m, n, work( iu ), ldwrku, a, lda ) ELSE ! ! Generate Q in A ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sorgbr( 'Q', m, n, n, a, lda, work( itauq ), & work( nwork ), lwork-nwork+1, ierr ) ! ! Multiply Q in A by left singular vectors of ! bidiagonal matrix in WORK(IU), storing result in ! WORK(IR) and copying to A ! (Workspace: need 2*N*N, prefer N*N+M*N) ! DO i = 1, m, ldwrkr chunk = MIN( m-i+1, ldwrkr ) CALL sgemm( 'N', 'N', chunk, n, n, one, a( i, 1 ), & lda, work( iu ), ldwrku, zero, work( ir ), ldwrkr ) CALL slacpy( 'F', chunk, n, work( ir ), ldwrkr, a( i, 1 ), lda ) END DO END IF ! ELSE IF( wntqs ) THEN ! ! Perform bidiagonal SVD, computing left singular vectors ! of bidiagonal matrix in U and computing right singular ! vectors of bidiagonal matrix in VT ! (Workspace: need BDSPAC) ! CALL slaset( 'F', m, n, zero, zero, u, ldu ) CALL sbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt, & ldvt, dum, idum, work( nwork ), iwork, info ) ! ! Overwrite U by left singular vectors of A and VT ! by right singular vectors of A ! (Workspace: need 3*N, prefer 2*N+N*NB) ! CALL sormbr( 'Q', 'L', 'N', m, n, n, a, lda, & work( itauq ), u, ldu, work( nwork ), lwork-nwork+1, ierr ) CALL sormbr( 'P', 'R', 'T', n, n, n, a, lda, & work( itaup ), vt, ldvt, work( nwork ), lwork-nwork+1, ierr ) ELSE ! ! Perform bidiagonal SVD, computing left singular vectors ! of bidiagonal matrix in U and computing right singular ! vectors of bidiagonal matrix in VT ! (Workspace: need BDSPAC) ! CALL slaset( 'F', m, m, zero, zero, u, ldu ) CALL sbdsdc( 'U', 'I', n, s, work( ie ), u, ldu, vt, & ldvt, dum, idum, work( nwork ), iwork, info ) ! ! Set the right corner of U to identity matrix ! CALL slaset( 'F', m-n, m-n, zero, one, u( n+1, n+1 ), ldu ) ! ! Overwrite U by left singular vectors of A and VT ! by right singular vectors of A ! (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB) ! CALL sormbr( 'Q', 'L', 'N', m, m, n, a, lda, & work( itauq ), u, ldu, work( nwork ), lwork-nwork+1, ierr ) CALL sormbr( 'P', 'R', 'T', n, n, m, a, lda, & work( itaup ), vt, ldvt, work( nwork ), lwork-nwork+1, ierr ) 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 >= mnthr ) THEN ! IF( wntqn ) THEN ! ! Path 1t (N much larger than M, JOBZ='N') ! No singular vectors to be computed ! itau = 1 nwork = itau + m ! ! Compute A=L*Q ! (Workspace: need 2*M, prefer M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), work( nwork ), & lwork-nwork+1, ierr ) ! ! Zero out above L ! CALL slaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) ie = 1 itauq = ie + m itaup = itauq + m nwork = itaup + m ! ! Bidiagonalize L in A ! (Workspace: need 4*M, prefer 3*M+2*M*NB) ! CALL sgebrd( m, m, a, lda, s, work( ie ), work( itauq ), & work( itaup ), work( nwork ), lwork-nwork+1, ierr ) nwork = ie + m ! ! Perform bidiagonal SVD, computing singular values only ! (Workspace: need BDSPAN) ! CALL sbdsdc( 'U', 'N', m, s, work( ie ), dum, 1, dum, 1, & dum, idum, work( nwork ), iwork, info ) ! ELSE IF( wntqo ) THEN ! ! Path 2t (N much larger than M, JOBZ='O') ! M right singular vectors to be overwritten on A and ! M left singular vectors to be computed in U ! ivt = 1 ! ! IVT is M by M ! il = ivt + m*m IF( lwork >= m*n+4*m*m+9*m ) THEN ! ! WORK(IL) is M by N ! ldwrkl = m chunk = n ELSE ldwrkl = m chunk = ( lwork-m*m ) / m END IF itau = il + ldwrkl*m nwork = itau + m ! ! Compute A=L*Q ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), work( nwork ), & lwork-nwork+1, ierr ) ! ! Copy L to WORK(IL), zeroing about above it ! CALL slacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) CALL slaset( 'U', m-1, m-1, zero, zero, work( il+ldwrkl ), ldwrkl ) ! ! Generate Q in A ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sorglq( m, n, m, a, lda, work( itau ), & work( nwork ), lwork-nwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m nwork = itaup + m ! ! Bidiagonalize L in WORK(IL) ! (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) ! CALL sgebrd( m, m, work( il ), ldwrkl, s, work( ie ), & work( itauq ), work( itaup ), work( nwork ), lwork-nwork+1, ierr ) ! ! Perform bidiagonal SVD, computing left singular vectors ! of bidiagonal matrix in U, and computing right singular ! vectors of bidiagonal matrix in WORK(IVT) ! (Workspace: need 2*M*M+BDSPAC) ! CALL sbdsdc( 'U', 'I', m, s, work( ie ), u, ldu, & work( ivt ), m, dum, idum, work( nwork ), iwork, info ) ! ! Overwrite U by left singular vectors of L and WORK(IVT) ! by right singular vectors of L ! (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB) ! CALL sormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl, & work( itauq ), u, ldu, work( nwork ), lwork-nwork+1, ierr ) CALL sormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl, & work( itaup ), work( ivt ), m, work( nwork ), lwork-nwork+1, ierr ) ! ! Multiply right singular vectors of L in WORK(IVT) by Q ! in A, storing result in WORK(IL) and copying to A ! (Workspace: need 2*M*M, prefer M*M+M*N) ! DO i = 1, n, chunk blk = MIN( n-i+1, chunk ) CALL sgemm( 'N', 'N', m, blk, m, one, work( ivt ), m, & a( 1, i ), lda, zero, work( il ), ldwrkl ) CALL slacpy( 'F', m, blk, work( il ), ldwrkl, a( 1, i ), lda ) END DO ! ELSE IF( wntqs ) THEN ! ! Path 3t (N much larger than M, JOBZ='S') ! M right singular vectors to be computed in VT and ! M left singular vectors to be computed in U ! il = 1 ! ! WORK(IL) is M by M ! ldwrkl = m itau = il + ldwrkl*m nwork = itau + m ! ! Compute A=L*Q ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), work( nwork ), & lwork-nwork+1, ierr ) ! ! Copy L to WORK(IL), zeroing out above it ! CALL slacpy( 'L', m, m, a, lda, work( il ), ldwrkl ) CALL slaset( 'U', m-1, m-1, zero, zero, work( il+ldwrkl ), ldwrkl ) ! ! Generate Q in A ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sorglq( m, n, m, a, lda, work( itau ), & work( nwork ), lwork-nwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m nwork = itaup + m ! ! Bidiagonalize L in WORK(IU), copying result to U ! (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) ! CALL sgebrd( m, m, work( il ), ldwrkl, s, work( ie ), & work( itauq ), work( itaup ), work( nwork ), lwork-nwork+1, ierr ) ! ! Perform bidiagonal SVD, computing left singular vectors ! of bidiagonal matrix in U and computing right singular ! vectors of bidiagonal matrix in VT ! (Workspace: need M*M+BDSPAC) ! CALL sbdsdc( 'U', 'I', m, s, work( ie ), u, ldu, vt, & ldvt, dum, idum, work( nwork ), iwork, info ) ! ! Overwrite U by left singular vectors of L and VT ! by right singular vectors of L ! (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) ! CALL sormbr( 'Q', 'L', 'N', m, m, m, work( il ), ldwrkl, & work( itauq ), u, ldu, work( nwork ), lwork-nwork+1, ierr ) CALL sormbr( 'P', 'R', 'T', m, m, m, work( il ), ldwrkl, & work( itaup ), vt, ldvt, work( nwork ), lwork-nwork+1, ierr ) ! ! Multiply right singular vectors of L in WORK(IL) by ! Q in A, storing result in VT ! (Workspace: need M*M) ! CALL slacpy( 'F', m, m, vt, ldvt, work( il ), ldwrkl ) CALL sgemm( 'N', 'N', m, n, m, one, work( il ), ldwrkl, & a, lda, zero, vt, ldvt ) ! ELSE IF( wntqa ) THEN ! ! Path 4t (N much larger than M, JOBZ='A') ! N right singular vectors to be computed in VT and ! M left singular vectors to be computed in U ! ivt = 1 ! ! WORK(IVT) is M by M ! ldwkvt = m itau = ivt + ldwkvt*m nwork = itau + m ! ! Compute A=L*Q, copying result to VT ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), work( nwork ), & lwork-nwork+1, ierr ) CALL slacpy( 'U', m, n, a, lda, vt, ldvt ) ! ! Generate Q in VT ! (Workspace: need M*M+M+N, prefer M*M+M+N*NB) ! CALL sorglq( n, n, m, vt, ldvt, work( itau ), & work( nwork ), lwork-nwork+1, ierr ) ! ! Produce L in A, zeroing out other entries ! CALL slaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) ie = itau itauq = ie + m itaup = itauq + m nwork = itaup + m ! ! Bidiagonalize L in A ! (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) ! CALL sgebrd( m, m, a, lda, s, work( ie ), work( itauq ), & work( itaup ), work( nwork ), lwork-nwork+1, ierr ) ! ! Perform bidiagonal SVD, computing left singular vectors ! of bidiagonal matrix in U and computing right singular ! vectors of bidiagonal matrix in WORK(IVT) ! (Workspace: need M*M+BDSPAC) ! CALL sbdsdc( 'U', 'I', m, s, work( ie ), u, ldu, & work( ivt ), ldwkvt, dum, idum, work( nwork ), iwork, info ) ! ! Overwrite U by left singular vectors of L and WORK(IVT) ! by right singular vectors of L ! (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB) ! CALL sormbr( 'Q', 'L', 'N', m, m, m, a, lda, & work( itauq ), u, ldu, work( nwork ), lwork-nwork+1, ierr ) CALL sormbr( 'P', 'R', 'T', m, m, m, a, lda, & work( itaup ), work( ivt ), ldwkvt, work( nwork ), lwork-nwork+1, ierr ) ! ! Multiply right singular vectors of L in WORK(IVT) by ! Q in VT, storing result in A ! (Workspace: need M*M) ! CALL sgemm( 'N', 'N', m, n, m, one, work( ivt ), ldwkvt, & vt, ldvt, zero, a, lda ) ! ! Copy right singular vectors of A from A to VT ! CALL slacpy( 'F', m, n, a, lda, vt, ldvt ) ! END IF ! ELSE ! ! N .LT. MNTHR ! ! Path 5t (N greater than M, but not much larger) ! Reduce to bidiagonal form without LQ decomposition ! ie = 1 itauq = ie + m itaup = itauq + m nwork = itaup + m ! ! Bidiagonalize A ! (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) ! CALL sgebrd( m, n, a, lda, s, work( ie ), work( itauq ), & work( itaup ), work( nwork ), lwork-nwork+1, ierr ) IF( wntqn ) THEN ! ! Perform bidiagonal SVD, only computing singular values ! (Workspace: need BDSPAN) ! CALL sbdsdc( 'L', 'N', m, s, work( ie ), dum, 1, dum, 1, & dum, idum, work( nwork ), iwork, info ) ELSE IF( wntqo ) THEN ldwkvt = m ivt = nwork IF( lwork >= m*n+3*m*m+9*m ) THEN ! ! WORK( IVT ) is M by N ! CALL slaset( 'F', m, n, zero, zero, work( ivt ), ldwkvt ) nwork = ivt + ldwkvt*n ELSE ! ! WORK( IVT ) is M by M ! nwork = ivt + ldwkvt*m il = nwork ! ! WORK(IL) is M by CHUNK ! chunk = ( lwork-m*m-3*m ) / m END IF ! ! Perform bidiagonal SVD, computing left singular vectors ! of bidiagonal matrix in U and computing right singular ! vectors of bidiagonal matrix in WORK(IVT) ! (Workspace: need M*M+BDSPAC) ! CALL sbdsdc( 'L', 'I', m, s, work( ie ), u, ldu, & work( ivt ), ldwkvt, dum, idum, work( nwork ), iwork, info ) ! ! Overwrite U by left singular vectors of A ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sormbr( 'Q', 'L', 'N', m, m, n, a, lda, & work( itauq ), u, ldu, work( nwork ), lwork-nwork+1, ierr ) ! IF( lwork >= m*n+3*m*m+9*m ) THEN ! ! Overwrite WORK(IVT) by left singular vectors of A ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sormbr( 'P', 'R', 'T', m, n, m, a, lda, & work( itaup ), work( ivt ), ldwkvt, & work( nwork ), lwork-nwork+1, ierr ) ! ! Copy right singular vectors of A from WORK(IVT) to A ! CALL slacpy( 'F', m, n, work( ivt ), ldwkvt, a, lda ) ELSE ! ! Generate P**T in A ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sorgbr( 'P', m, n, m, a, lda, work( itaup ), & work( nwork ), lwork-nwork+1, ierr ) ! ! Multiply Q in A by right singular vectors of ! bidiagonal matrix in WORK(IVT), storing result in ! WORK(IL) and copying to A ! (Workspace: need 2*M*M, prefer M*M+M*N) ! DO i = 1, n, chunk blk = MIN( n-i+1, chunk ) CALL sgemm( 'N', 'N', m, blk, m, one, work( ivt ), & ldwkvt, a( 1, i ), lda, zero, work( il ), m ) CALL slacpy( 'F', m, blk, work( il ), m, a( 1, i ), lda ) END DO END IF ELSE IF( wntqs ) THEN ! ! Perform bidiagonal SVD, computing left singular vectors ! of bidiagonal matrix in U and computing right singular ! vectors of bidiagonal matrix in VT ! (Workspace: need BDSPAC) ! CALL slaset( 'F', m, n, zero, zero, vt, ldvt ) CALL sbdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt, & ldvt, dum, idum, work( nwork ), iwork, info ) ! ! Overwrite U by left singular vectors of A and VT ! by right singular vectors of A ! (Workspace: need 3*M, prefer 2*M+M*NB) ! CALL sormbr( 'Q', 'L', 'N', m, m, n, a, lda, & work( itauq ), u, ldu, work( nwork ), lwork-nwork+1, ierr ) CALL sormbr( 'P', 'R', 'T', m, n, m, a, lda, & work( itaup ), vt, ldvt, work( nwork ), lwork-nwork+1, ierr ) ELSE ! ! Perform bidiagonal SVD, computing left singular vectors ! of bidiagonal matrix in U and computing right singular ! vectors of bidiagonal matrix in VT ! (Workspace: need BDSPAC) ! CALL slaset( 'F', n, n, zero, zero, vt, ldvt ) CALL sbdsdc( 'L', 'I', m, s, work( ie ), u, ldu, vt, & ldvt, dum, idum, work( nwork ), iwork, info ) ! ! Set the right corner of VT to identity matrix ! CALL slaset( 'F', n-m, n-m, zero, one, vt( m+1, m+1 ), ldvt ) ! ! Overwrite U by left singular vectors of A and VT ! by right singular vectors of A ! (Workspace: need 2*M+N, prefer 2*M+N*NB) ! CALL sormbr( 'Q', 'L', 'N', m, m, n, a, lda, & work( itauq ), u, ldu, work( nwork ), lwork-nwork+1, ierr ) CALL sormbr( 'P', 'R', 'T', n, n, m, a, lda, & work( itaup ), vt, ldvt, work( nwork ), lwork-nwork+1, ierr ) END IF ! END IF ! END IF ! ! Undo scaling if necessary ! IF( iscl == 1 ) THEN IF( anrm > bignum ) & CALL slascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn, ierr ) IF( info /= 0 .AND. anrm > bignum ) & CALL slascl( 'G', 0, 0, bignum, anrm, minmn-1, 1, work( 2 ), minmn, ierr ) IF( anrm < smlnum ) & CALL slascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn, ierr ) IF( info /= 0 .AND. anrm < smlnum ) & CALL slascl( 'G', 0, 0, smlnum, anrm, minmn-1, 1, work( 2 ), minmn, ierr ) END IF ! ! Return optimal workspace in WORK(1) ! work( 1 ) = REAL( maxwrk ) ! RETURN ! ! End of SGESDD ! END SUBROUTINE sgesdd SUBROUTINE sgesv( 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, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: nrhs REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(IN OUT) :: ipiv( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGESV 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) REAL 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) REAL 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 sgetrf, sgetrs, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 IF( n < 0 ) THEN info = -1 ELSE IF( nrhs < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, n ) ) THEN info = -4 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -7 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGESV ', -info ) RETURN END IF ! ! Compute the LU factorization of A. ! CALL sgetrf( n, n, a, lda, ipiv, info ) IF( info == 0 ) THEN ! ! Solve the system A*X = B, overwriting B with X. ! CALL sgetrs( 'No transpose', n, nrhs, a, lda, ipiv, b, ldb, info ) END IF RETURN ! ! End of SGESV ! END SUBROUTINE sgesv SUBROUTINE sgesvd( jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, & 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 (LEN=1), INTENT(IN) :: jobu CHARACTER (LEN=1), INTENT(IN) :: jobvt INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN OUT) :: s( * ) REAL, INTENT(IN OUT) :: u( ldu, * ) INTEGER, INTENT(IN OUT) :: ldu REAL, INTENT(IN OUT) :: vt( ldvt, * ) INTEGER, INTENT(IN OUT) :: ldvt REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGESVD computes the singular value decomposition (SVD) of a real ! M-by-N matrix A, optionally computing the left and/or right singular ! vectors. The SVD is written ! ! A = U * SIGMA * 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 orthogonal matrix, and ! V is an N-by-N orthogonal 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**T, 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**T: ! = 'A': all N rows of V**T are returned in the array VT; ! = 'S': the first min(m,n) rows of V**T (the right singular ! vectors) are returned in the array VT; ! = 'O': the first min(m,n) rows of V**T (the right singular ! vectors) are overwritten on the array A; ! = 'N': no rows of V**T (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) REAL 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**T (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) REAL array, dimension (min(M,N)) ! The singular values of A, sorted so that S(i) >= S(i+1). ! ! U (output) REAL 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 orthogonal 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) REAL array, dimension (LDVT,N) ! If JOBVT = 'A', VT contains the N-by-N orthogonal matrix ! V**T; ! if JOBVT = 'S', VT contains the first min(m,n) rows of ! V**T (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) REAL array, dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK; ! if INFO > 0, WORK(2:MIN(M,N)) 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. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. LWORK >= 1. ! LWORK >= MAX(3*MIN(M,N)+MAX(M,N),5*MIN(M,N)-4). ! 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. ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if SBDSQR did not converge, INFO specifies how many ! superdiagonals of an intermediate bidiagonal form B ! did not converge to zero. See the description of WORK ! above for details. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, wntua, wntuas, wntun, wntuo, wntus, & wntva, wntvas, wntvn, wntvo, wntvs INTEGER :: bdspac, blk, chunk, i, ie, ierr, ir, iscl, & itau, itaup, itauq, iu, iwork, ldwrkr, ldwrku, & maxwrk, minmn, minwrk, mnthr, ncu, ncvt, nru, nrvt, wrkbl REAL :: anrm, bignum, eps, smlnum ! .. ! .. Local Arrays .. REAL :: dum( 1 ) ! .. ! .. External Subroutines .. EXTERNAL sbdsqr, sgebrd, sgelqf, sgemm, sgeqrf, slacpy, & slascl, slaset, sorgbr, sorglq, sorgqr, sormbr, xerbla ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slange EXTERNAL lsame, ilaenv, slamch, slange ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 minmn = MIN( m, n ) mnthr = ilaenv( 6, 'SGESVD', 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 == -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 < 0 ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( lda < MAX( 1, m ) ) THEN info = -6 ELSE IF( ldu < 1 .OR. ( wntuas .AND. ldu < m ) ) THEN info = -9 ELSE IF( ldvt < 1 .OR. ( wntva .AND. ldvt < n ) .OR. & ( wntvs .AND. ldvt < 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. ! NB refers to the optimal block size for the immediately ! following subroutine, as returned by ILAENV.) ! IF( info == 0 .AND. ( lwork >= 1 .OR. lquery ) .AND. m > 0 .AND. n > 0 ) THEN IF( m >= n ) THEN ! ! Compute space needed for SBDSQR ! bdspac = MAX( 3*n, 5*n-4 ) IF( m >= mnthr ) THEN IF( wntun ) THEN ! ! Path 1 (M much larger than N, JOBU='N') ! maxwrk = n + n*ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) maxwrk = MAX( maxwrk, 3*n+2*n* & ilaenv( 1, 'SGEBRD', ' ', n, n, -1, -1 ) ) IF( wntvo .OR. wntvas ) maxwrk = MAX( maxwrk, 3*n+( n-1 )* & ilaenv( 1, 'SORGBR', 'P', n, n, n, -1 ) ) maxwrk = MAX( maxwrk, bdspac ) minwrk = MAX( 4*n, bdspac ) maxwrk = MAX( maxwrk, minwrk ) ELSE IF( wntuo .AND. wntvn ) THEN ! ! Path 2 (M much larger than N, JOBU='O', JOBVT='N') ! wrkbl = n + n*ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, n+n*ilaenv( 1, 'SORGQR', ' ', m, n, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+2*n* & ilaenv( 1, 'SGEBRD', ' ', n, n, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*n+n* ilaenv( 1, 'SORGBR', 'Q', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, bdspac ) maxwrk = MAX( n*n+wrkbl, n*n+m*n+n ) minwrk = MAX( 3*n+m, bdspac ) maxwrk = MAX( maxwrk, minwrk ) ELSE IF( wntuo .AND. wntvas ) THEN ! ! Path 3 (M much larger than N, JOBU='O', JOBVT='S' or ! 'A') ! wrkbl = n + n*ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, n+n*ilaenv( 1, 'SORGQR', ' ', m, n, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+2*n* & ilaenv( 1, 'SGEBRD', ' ', n, n, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*n+n* ilaenv( 1, 'SORGBR', 'Q', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+( n-1 )* & ilaenv( 1, 'SORGBR', 'P', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, bdspac ) maxwrk = MAX( n*n+wrkbl, n*n+m*n+n ) minwrk = MAX( 3*n+m, bdspac ) maxwrk = MAX( maxwrk, minwrk ) ELSE IF( wntus .AND. wntvn ) THEN ! ! Path 4 (M much larger than N, JOBU='S', JOBVT='N') ! wrkbl = n + n*ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, n+n*ilaenv( 1, 'SORGQR', ' ', m, n, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+2*n* & ilaenv( 1, 'SGEBRD', ' ', n, n, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*n+n* ilaenv( 1, 'SORGBR', 'Q', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, bdspac ) maxwrk = n*n + wrkbl minwrk = MAX( 3*n+m, bdspac ) maxwrk = MAX( maxwrk, minwrk ) ELSE IF( wntus .AND. wntvo ) THEN ! ! Path 5 (M much larger than N, JOBU='S', JOBVT='O') ! wrkbl = n + n*ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, n+n*ilaenv( 1, 'SORGQR', ' ', m, n, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+2*n* & ilaenv( 1, 'SGEBRD', ' ', n, n, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*n+n* ilaenv( 1, 'SORGBR', 'Q', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+( n-1 )* & ilaenv( 1, 'SORGBR', 'P', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, bdspac ) maxwrk = 2*n*n + wrkbl minwrk = MAX( 3*n+m, bdspac ) maxwrk = MAX( maxwrk, minwrk ) ELSE IF( wntus .AND. wntvas ) THEN ! ! Path 6 (M much larger than N, JOBU='S', JOBVT='S' or ! 'A') ! wrkbl = n + n*ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, n+n*ilaenv( 1, 'SORGQR', ' ', m, n, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+2*n* & ilaenv( 1, 'SGEBRD', ' ', n, n, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*n+n* ilaenv( 1, 'SORGBR', 'Q', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+( n-1 )* & ilaenv( 1, 'SORGBR', 'P', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, bdspac ) maxwrk = n*n + wrkbl minwrk = MAX( 3*n+m, bdspac ) maxwrk = MAX( maxwrk, minwrk ) ELSE IF( wntua .AND. wntvn ) THEN ! ! Path 7 (M much larger than N, JOBU='A', JOBVT='N') ! wrkbl = n + n*ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, n+m*ilaenv( 1, 'SORGQR', ' ', m, m, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+2*n* & ilaenv( 1, 'SGEBRD', ' ', n, n, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*n+n* ilaenv( 1, 'SORGBR', 'Q', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, bdspac ) maxwrk = n*n + wrkbl minwrk = MAX( 3*n+m, bdspac ) maxwrk = MAX( maxwrk, minwrk ) ELSE IF( wntua .AND. wntvo ) THEN ! ! Path 8 (M much larger than N, JOBU='A', JOBVT='O') ! wrkbl = n + n*ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, n+m*ilaenv( 1, 'SORGQR', ' ', m, m, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+2*n* & ilaenv( 1, 'SGEBRD', ' ', n, n, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*n+n* ilaenv( 1, 'SORGBR', 'Q', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+( n-1 )* & ilaenv( 1, 'SORGBR', 'P', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, bdspac ) maxwrk = 2*n*n + wrkbl minwrk = MAX( 3*n+m, bdspac ) maxwrk = MAX( maxwrk, minwrk ) ELSE IF( wntua .AND. wntvas ) THEN ! ! Path 9 (M much larger than N, JOBU='A', JOBVT='S' or ! 'A') ! wrkbl = n + n*ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, n+m*ilaenv( 1, 'SORGQR', ' ', m, m, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+2*n* & ilaenv( 1, 'SGEBRD', ' ', n, n, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*n+n* ilaenv( 1, 'SORGBR', 'Q', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, 3*n+( n-1 )* & ilaenv( 1, 'SORGBR', 'P', n, n, n, -1 ) ) wrkbl = MAX( wrkbl, bdspac ) maxwrk = n*n + wrkbl minwrk = MAX( 3*n+m, bdspac ) maxwrk = MAX( maxwrk, minwrk ) END IF ELSE ! ! Path 10 (M at least N, but not much larger) ! maxwrk = 3*n + ( m+n )*ilaenv( 1, 'SGEBRD', ' ', m, n, -1, -1 ) IF( wntus .OR. wntuo ) maxwrk = MAX( maxwrk, 3*n+n* & ilaenv( 1, 'SORGBR', 'Q', m, n, n, -1 ) ) IF( wntua ) maxwrk = MAX( maxwrk, 3*n+m* & ilaenv( 1, 'SORGBR', 'Q', m, m, n, -1 ) ) IF( .NOT.wntvn ) maxwrk = MAX( maxwrk, 3*n+( n-1 )* & ilaenv( 1, 'SORGBR', 'P', n, n, n, -1 ) ) maxwrk = MAX( maxwrk, bdspac ) minwrk = MAX( 3*n+m, bdspac ) maxwrk = MAX( maxwrk, minwrk ) END IF ELSE ! ! Compute space needed for SBDSQR ! bdspac = MAX( 3*m, 5*m-4 ) IF( n >= mnthr ) THEN IF( wntvn ) THEN ! ! Path 1t(N much larger than M, JOBVT='N') ! maxwrk = m + m*ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) maxwrk = MAX( maxwrk, 3*m+2*m* & ilaenv( 1, 'SGEBRD', ' ', m, m, -1, -1 ) ) IF( wntuo .OR. wntuas ) maxwrk = MAX( maxwrk, 3*m+m* & ilaenv( 1, 'SORGBR', 'Q', m, m, m, -1 ) ) maxwrk = MAX( maxwrk, bdspac ) minwrk = MAX( 4*m, bdspac ) maxwrk = MAX( maxwrk, minwrk ) ELSE IF( wntvo .AND. wntun ) THEN ! ! Path 2t(N much larger than M, JOBU='N', JOBVT='O') ! wrkbl = m + m*ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, m+m*ilaenv( 1, 'SORGLQ', ' ', m, n, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+2*m* & ilaenv( 1, 'SGEBRD', ' ', m, m, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*m+( m-1 )* & ilaenv( 1, 'SORGBR', 'P', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, bdspac ) maxwrk = MAX( m*m+wrkbl, m*m+m*n+m ) minwrk = MAX( 3*m+n, bdspac ) maxwrk = MAX( maxwrk, minwrk ) ELSE IF( wntvo .AND. wntuas ) THEN ! ! Path 3t(N much larger than M, JOBU='S' or 'A', ! JOBVT='O') ! wrkbl = m + m*ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, m+m*ilaenv( 1, 'SORGLQ', ' ', m, n, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+2*m* & ilaenv( 1, 'SGEBRD', ' ', m, m, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*m+( m-1 )* & ilaenv( 1, 'SORGBR', 'P', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+m* ilaenv( 1, 'SORGBR', 'Q', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, bdspac ) maxwrk = MAX( m*m+wrkbl, m*m+m*n+m ) minwrk = MAX( 3*m+n, bdspac ) maxwrk = MAX( maxwrk, minwrk ) ELSE IF( wntvs .AND. wntun ) THEN ! ! Path 4t(N much larger than M, JOBU='N', JOBVT='S') ! wrkbl = m + m*ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, m+m*ilaenv( 1, 'SORGLQ', ' ', m, n, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+2*m* & ilaenv( 1, 'SGEBRD', ' ', m, m, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*m+( m-1 )* & ilaenv( 1, 'SORGBR', 'P', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, bdspac ) maxwrk = m*m + wrkbl minwrk = MAX( 3*m+n, bdspac ) maxwrk = MAX( maxwrk, minwrk ) ELSE IF( wntvs .AND. wntuo ) THEN ! ! Path 5t(N much larger than M, JOBU='O', JOBVT='S') ! wrkbl = m + m*ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, m+m*ilaenv( 1, 'SORGLQ', ' ', m, n, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+2*m* & ilaenv( 1, 'SGEBRD', ' ', m, m, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*m+( m-1 )* & ilaenv( 1, 'SORGBR', 'P', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+m* ilaenv( 1, 'SORGBR', 'Q', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, bdspac ) maxwrk = 2*m*m + wrkbl minwrk = MAX( 3*m+n, bdspac ) maxwrk = MAX( maxwrk, minwrk ) ELSE IF( wntvs .AND. wntuas ) THEN ! ! Path 6t(N much larger than M, JOBU='S' or 'A', ! JOBVT='S') ! wrkbl = m + m*ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, m+m*ilaenv( 1, 'SORGLQ', ' ', m, n, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+2*m* & ilaenv( 1, 'SGEBRD', ' ', m, m, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*m+( m-1 )* & ilaenv( 1, 'SORGBR', 'P', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+m* ilaenv( 1, 'SORGBR', 'Q', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, bdspac ) maxwrk = m*m + wrkbl minwrk = MAX( 3*m+n, bdspac ) maxwrk = MAX( maxwrk, minwrk ) ELSE IF( wntva .AND. wntun ) THEN ! ! Path 7t(N much larger than M, JOBU='N', JOBVT='A') ! wrkbl = m + m*ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, m+n*ilaenv( 1, 'SORGLQ', ' ', n, n, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+2*m* & ilaenv( 1, 'SGEBRD', ' ', m, m, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*m+( m-1 )* & ilaenv( 1, 'SORGBR', 'P', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, bdspac ) maxwrk = m*m + wrkbl minwrk = MAX( 3*m+n, bdspac ) maxwrk = MAX( maxwrk, minwrk ) ELSE IF( wntva .AND. wntuo ) THEN ! ! Path 8t(N much larger than M, JOBU='O', JOBVT='A') ! wrkbl = m + m*ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, m+n*ilaenv( 1, 'SORGLQ', ' ', n, n, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+2*m* & ilaenv( 1, 'SGEBRD', ' ', m, m, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*m+( m-1 )* & ilaenv( 1, 'SORGBR', 'P', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+m* ilaenv( 1, 'SORGBR', 'Q', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, bdspac ) maxwrk = 2*m*m + wrkbl minwrk = MAX( 3*m+n, bdspac ) maxwrk = MAX( maxwrk, minwrk ) ELSE IF( wntva .AND. wntuas ) THEN ! ! Path 9t(N much larger than M, JOBU='S' or 'A', ! JOBVT='A') ! wrkbl = m + m*ilaenv( 1, 'SGELQF', ' ', m, n, -1, -1 ) wrkbl = MAX( wrkbl, m+n*ilaenv( 1, 'SORGLQ', ' ', n, n, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+2*m* & ilaenv( 1, 'SGEBRD', ' ', m, m, -1, -1 ) ) wrkbl = MAX( wrkbl, 3*m+( m-1 )* & ilaenv( 1, 'SORGBR', 'P', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, 3*m+m* ilaenv( 1, 'SORGBR', 'Q', m, m, m, -1 ) ) wrkbl = MAX( wrkbl, bdspac ) maxwrk = m*m + wrkbl minwrk = MAX( 3*m+n, bdspac ) maxwrk = MAX( maxwrk, minwrk ) END IF ELSE ! ! Path 10t(N greater than M, but not much larger) ! maxwrk = 3*m + ( m+n )*ilaenv( 1, 'SGEBRD', ' ', m, n, -1, -1 ) IF( wntvs .OR. wntvo ) maxwrk = MAX( maxwrk, 3*m+m* & ilaenv( 1, 'SORGBR', 'P', m, n, m, -1 ) ) IF( wntva ) maxwrk = MAX( maxwrk, 3*m+n* & ilaenv( 1, 'SORGBR', 'P', n, n, m, -1 ) ) IF( .NOT.wntun ) maxwrk = MAX( maxwrk, 3*m+( m-1 )* & ilaenv( 1, 'SORGBR', 'Q', m, m, m, -1 ) ) maxwrk = MAX( maxwrk, bdspac ) minwrk = MAX( 3*m+n, bdspac ) maxwrk = MAX( maxwrk, minwrk ) END IF END IF work( 1 ) = maxwrk END IF ! IF( lwork < minwrk .AND. .NOT.lquery ) THEN info = -13 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGESVD', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 ) THEN IF( lwork >= 1 ) work( 1 ) = one RETURN END IF ! ! Get machine constants ! eps = slamch( 'P' ) smlnum = SQRT( slamch( 'S' ) ) / eps bignum = one / smlnum ! ! Scale A if max element outside range [SMLNUM,BIGNUM] ! anrm = slange( 'M', m, n, a, lda, dum ) iscl = 0 IF( anrm > zero .AND. anrm < smlnum ) THEN iscl = 1 CALL slascl( 'G', 0, 0, anrm, smlnum, m, n, a, lda, ierr ) ELSE IF( anrm > bignum ) THEN iscl = 1 CALL slascl( 'G', 0, 0, anrm, bignum, m, n, a, lda, ierr ) END IF ! IF( m >= 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 >= 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 ! (Workspace: need 2*N, prefer N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), work( iwork ), & lwork-iwork+1, ierr ) ! ! Zero out below R ! CALL slaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) ie = 1 itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Bidiagonalize R in A ! (Workspace: need 4*N, prefer 3*N+2*N*NB) ! CALL sgebrd( n, n, a, lda, s, work( 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'. ! (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) ! CALL sorgbr( 'P', n, n, n, a, lda, work( itaup ), & work( iwork ), lwork-iwork+1, ierr ) ncvt = n END IF iwork = ie + n ! ! Perform bidiagonal QR iteration, computing right ! singular vectors of A in A if desired ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', n, ncvt, 0, 0, s, work( ie ), a, lda, & dum, 1, dum, 1, work( iwork ), info ) ! ! If right singular vectors desired in VT, copy them there ! IF( wntvas ) CALL slacpy( '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 >= n*n+MAX( 4*n, bdspac ) ) THEN ! ! Sufficient workspace for a fast algorithm ! ir = 1 IF( lwork >= MAX( wrkbl, lda*n+n )+lda*n ) THEN ! ! WORK(IU) is LDA by N, WORK(IR) is LDA by N ! ldwrku = lda ldwrkr = lda ELSE IF( lwork >= MAX( wrkbl, lda*n+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 ) / n ldwrkr = n END IF itau = ir + ldwrkr*n iwork = itau + n ! ! Compute A=Q*R ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy R to WORK(IR) and zero out below it ! CALL slacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) CALL slaset( 'L', n-1, n-1, zero, zero, work( ir+1 ), ldwrkr ) ! ! Generate Q in A ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sorgqr( m, n, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Bidiagonalize R in WORK(IR) ! (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) ! CALL sgebrd( n, n, work( ir ), ldwrkr, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Generate left vectors bidiagonalizing R ! (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) ! CALL sorgbr( 'Q', n, n, n, work( ir ), ldwrkr, & work( itauq ), work( iwork ), lwork-iwork+1, ierr ) iwork = ie + n ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of R in WORK(IR) ! (Workspace: need N*N+BDSPAC) ! CALL sbdsqr( 'U', n, 0, n, 0, s, work( ie ), dum, 1, & work( ir ), ldwrkr, dum, 1, work( iwork ), info ) iu = ie + n ! ! Multiply Q in A by left singular vectors of R in ! WORK(IR), storing result in WORK(IU) and copying to A ! (Workspace: need N*N+2*N, prefer N*N+M*N+N) ! DO i = 1, m, ldwrku chunk = MIN( m-i+1, ldwrku ) CALL sgemm( 'N', 'N', chunk, n, n, one, a( i, 1 ), & lda, work( ir ), ldwrkr, zero, work( iu ), ldwrku ) CALL slacpy( 'F', chunk, n, work( iu ), ldwrku, a( i, 1 ), lda ) END DO ! ELSE ! ! Insufficient workspace for a fast algorithm ! ie = 1 itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Bidiagonalize A ! (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) ! CALL sgebrd( m, n, a, lda, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Generate left vectors bidiagonalizing A ! (Workspace: need 4*N, prefer 3*N+N*NB) ! CALL sorgbr( 'Q', m, n, n, a, lda, work( itauq ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + n ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of A in A ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', n, 0, m, 0, s, work( ie ), dum, 1, & a, lda, dum, 1, work( iwork ), 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 >= n*n+MAX( 4*n, bdspac ) ) THEN ! ! Sufficient workspace for a fast algorithm ! ir = 1 IF( lwork >= MAX( wrkbl, lda*n+n )+lda*n ) THEN ! ! WORK(IU) is LDA by N and WORK(IR) is LDA by N ! ldwrku = lda ldwrkr = lda ELSE IF( lwork >= MAX( wrkbl, lda*n+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 ) / n ldwrkr = n END IF itau = ir + ldwrkr*n iwork = itau + n ! ! Compute A=Q*R ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy R to VT, zeroing out below it ! CALL slacpy( 'U', n, n, a, lda, vt, ldvt ) CALL slaset( 'L', n-1, n-1, zero, zero, vt( 2, 1 ), ldvt ) ! ! Generate Q in A ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sorgqr( m, n, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Bidiagonalize R in VT, copying result to WORK(IR) ! (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) ! CALL sgebrd( n, n, vt, ldvt, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'L', n, n, vt, ldvt, work( ir ), ldwrkr ) ! ! Generate left vectors bidiagonalizing R in WORK(IR) ! (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) ! CALL sorgbr( 'Q', n, n, n, work( ir ), ldwrkr, & work( itauq ), work( iwork ), lwork-iwork+1, ierr ) ! ! Generate right vectors bidiagonalizing R in VT ! (Workspace: need N*N+4*N-1, prefer N*N+3*N+(N-1)*NB) ! CALL sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + n ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of R in WORK(IR) and computing right ! singular vectors of R in VT ! (Workspace: need N*N+BDSPAC) ! CALL sbdsqr( 'U', n, n, n, 0, s, work( ie ), vt, ldvt, & work( ir ), ldwrkr, dum, 1, work( iwork ), info ) iu = ie + n ! ! Multiply Q in A by left singular vectors of R in ! WORK(IR), storing result in WORK(IU) and copying to A ! (Workspace: need N*N+2*N, prefer N*N+M*N+N) ! DO i = 1, m, ldwrku chunk = MIN( m-i+1, ldwrku ) CALL sgemm( 'N', 'N', chunk, n, n, one, a( i, 1 ), & lda, work( ir ), ldwrkr, zero, work( iu ), ldwrku ) CALL slacpy( 'F', chunk, n, work( iu ), ldwrku, a( i, 1 ), lda ) END DO ! ELSE ! ! Insufficient workspace for a fast algorithm ! itau = 1 iwork = itau + n ! ! Compute A=Q*R ! (Workspace: need 2*N, prefer N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy R to VT, zeroing out below it ! CALL slacpy( 'U', n, n, a, lda, vt, ldvt ) CALL slaset( 'L', n-1, n-1, zero, zero, vt( 2, 1 ), ldvt ) ! ! Generate Q in A ! (Workspace: need 2*N, prefer N+N*NB) ! CALL sorgqr( m, n, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Bidiagonalize R in VT ! (Workspace: need 4*N, prefer 3*N+2*N*NB) ! CALL sgebrd( n, n, vt, ldvt, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Multiply Q in A by left vectors bidiagonalizing R ! (Workspace: need 3*N+M, prefer 3*N+M*NB) ! CALL sormbr( '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 ! (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) ! CALL sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + n ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of A in A and computing right ! singular vectors of A in VT ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', n, n, m, 0, s, work( ie ), vt, ldvt, & a, lda, dum, 1, work( iwork ), 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 >= n*n+MAX( 4*n, bdspac ) ) THEN ! ! Sufficient workspace for a fast algorithm ! ir = 1 IF( lwork >= 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 ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy R to WORK(IR), zeroing out below it ! CALL slacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) CALL slaset( 'L', n-1, n-1, zero, zero, work( ir+1 ), ldwrkr ) ! ! Generate Q in A ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sorgqr( m, n, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Bidiagonalize R in WORK(IR) ! (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) ! CALL sgebrd( n, n, work( ir ), ldwrkr, s, & work( ie ), work( itauq ), work( itaup ), work( iwork ), & lwork-iwork+1, ierr ) ! ! Generate left vectors bidiagonalizing R in WORK(IR) ! (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) ! CALL sorgbr( 'Q', n, n, n, work( ir ), ldwrkr, & work( itauq ), work( iwork ), lwork-iwork+1, ierr ) iwork = ie + n ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of R in WORK(IR) ! (Workspace: need N*N+BDSPAC) ! CALL sbdsqr( 'U', n, 0, n, 0, s, work( ie ), dum, & 1, work( ir ), ldwrkr, dum, 1, work( iwork ), info ) ! ! Multiply Q in A by left singular vectors of R in ! WORK(IR), storing result in U ! (Workspace: need N*N) ! CALL sgemm( 'N', 'N', m, n, n, one, a, lda, & work( ir ), ldwrkr, zero, u, ldu ) ! ELSE ! ! Insufficient workspace for a fast algorithm ! itau = 1 iwork = itau + n ! ! Compute A=Q*R, copying result to U ! (Workspace: need 2*N, prefer N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'L', m, n, a, lda, u, ldu ) ! ! Generate Q in U ! (Workspace: need 2*N, prefer N+N*NB) ! CALL sorgqr( m, n, n, u, ldu, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Zero out below R in A ! CALL slaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) ! ! Bidiagonalize R in A ! (Workspace: need 4*N, prefer 3*N+2*N*NB) ! CALL sgebrd( n, n, a, lda, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Multiply Q in U by left vectors bidiagonalizing R ! (Workspace: need 3*N+M, prefer 3*N+M*NB) ! CALL sormbr( 'Q', 'R', 'N', m, n, n, a, lda, & work( itauq ), u, ldu, work( iwork ), lwork-iwork+1, ierr ) iwork = ie + n ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of A in U ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', n, 0, m, 0, s, work( ie ), dum, & 1, u, ldu, dum, 1, work( iwork ), 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 >= 2*n*n+MAX( 4*n, bdspac ) ) THEN ! ! Sufficient workspace for a fast algorithm ! iu = 1 IF( lwork >= 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 >= 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 ! (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy R to WORK(IU), zeroing out below it ! CALL slacpy( 'U', n, n, a, lda, work( iu ), ldwrku ) CALL slaset( 'L', n-1, n-1, zero, zero, work( iu+1 ), ldwrku ) ! ! Generate Q in A ! (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) ! CALL sorgqr( m, n, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Bidiagonalize R in WORK(IU), copying result to ! WORK(IR) ! (Workspace: need 2*N*N+4*N, ! prefer 2*N*N+3*N+2*N*NB) ! CALL sgebrd( n, n, work( iu ), ldwrku, s, & work( ie ), work( itauq ), work( itaup ), work( iwork ), & lwork-iwork+1, ierr ) CALL slacpy( 'U', n, n, work( iu ), ldwrku, work( ir ), ldwrkr ) ! ! Generate left bidiagonalizing vectors in WORK(IU) ! (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB) ! CALL sorgbr( 'Q', n, n, n, work( iu ), ldwrku, & work( itauq ), work( iwork ), lwork-iwork+1, ierr ) ! ! Generate right bidiagonalizing vectors in WORK(IR) ! (Workspace: need 2*N*N+4*N-1, ! prefer 2*N*N+3*N+(N-1)*NB) ! CALL sorgbr( 'P', n, n, n, work( ir ), ldwrkr, & work( itaup ), work( iwork ), lwork-iwork+1, ierr ) iwork = 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) ! (Workspace: need 2*N*N+BDSPAC) ! CALL sbdsqr( 'U', n, n, n, 0, s, work( ie ), & work( ir ), ldwrkr, work( iu ), & ldwrku, dum, 1, work( iwork ), info ) ! ! Multiply Q in A by left singular vectors of R in ! WORK(IU), storing result in U ! (Workspace: need N*N) ! CALL sgemm( 'N', 'N', m, n, n, one, a, lda, & work( iu ), ldwrku, zero, u, ldu ) ! ! Copy right singular vectors of R to A ! (Workspace: need N*N) ! CALL slacpy( '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 ! (Workspace: need 2*N, prefer N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'L', m, n, a, lda, u, ldu ) ! ! Generate Q in U ! (Workspace: need 2*N, prefer N+N*NB) ! CALL sorgqr( m, n, n, u, ldu, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Zero out below R in A ! CALL slaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) ! ! Bidiagonalize R in A ! (Workspace: need 4*N, prefer 3*N+2*N*NB) ! CALL sgebrd( n, n, a, lda, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Multiply Q in U by left vectors bidiagonalizing R ! (Workspace: need 3*N+M, prefer 3*N+M*NB) ! CALL sormbr( '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 ! (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) ! CALL sorgbr( 'P', n, n, n, a, lda, work( itaup ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + n ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of A in U and computing right ! singular vectors of A in A ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', n, n, m, 0, s, work( ie ), a, & lda, u, ldu, dum, 1, work( iwork ), 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 >= n*n+MAX( 4*n, bdspac ) ) THEN ! ! Sufficient workspace for a fast algorithm ! iu = 1 IF( lwork >= 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 ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy R to WORK(IU), zeroing out below it ! CALL slacpy( 'U', n, n, a, lda, work( iu ), ldwrku ) CALL slaset( 'L', n-1, n-1, zero, zero, work( iu+1 ), ldwrku ) ! ! Generate Q in A ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sorgqr( m, n, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Bidiagonalize R in WORK(IU), copying result to VT ! (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) ! CALL sgebrd( n, n, work( iu ), ldwrku, s, & work( ie ), work( itauq ), work( itaup ), work( iwork ), & lwork-iwork+1, ierr ) CALL slacpy( 'U', n, n, work( iu ), ldwrku, vt, ldvt ) ! ! Generate left bidiagonalizing vectors in WORK(IU) ! (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) ! CALL sorgbr( 'Q', n, n, n, work( iu ), ldwrku, & work( itauq ), work( iwork ), lwork-iwork+1, ierr ) ! ! Generate right bidiagonalizing vectors in VT ! (Workspace: need N*N+4*N-1, ! prefer N*N+3*N+(N-1)*NB) ! CALL sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + n ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of R in WORK(IU) and computing ! right singular vectors of R in VT ! (Workspace: need N*N+BDSPAC) ! CALL sbdsqr( 'U', n, n, n, 0, s, work( ie ), vt, & ldvt, work( iu ), ldwrku, dum, 1, work( iwork ), info ) ! ! Multiply Q in A by left singular vectors of R in ! WORK(IU), storing result in U ! (Workspace: need N*N) ! CALL sgemm( 'N', 'N', m, n, n, one, a, lda, & work( iu ), ldwrku, zero, u, ldu ) ! ELSE ! ! Insufficient workspace for a fast algorithm ! itau = 1 iwork = itau + n ! ! Compute A=Q*R, copying result to U ! (Workspace: need 2*N, prefer N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'L', m, n, a, lda, u, ldu ) ! ! Generate Q in U ! (Workspace: need 2*N, prefer N+N*NB) ! CALL sorgqr( m, n, n, u, ldu, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy R to VT, zeroing out below it ! CALL slacpy( 'U', n, n, a, lda, vt, ldvt ) CALL slaset( 'L', n-1, n-1, zero, zero, vt( 2, 1 ), ldvt ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Bidiagonalize R in VT ! (Workspace: need 4*N, prefer 3*N+2*N*NB) ! CALL sgebrd( n, n, vt, ldvt, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Multiply Q in U by left bidiagonalizing vectors ! in VT ! (Workspace: need 3*N+M, prefer 3*N+M*NB) ! CALL sormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt, & work( itauq ), u, ldu, work( iwork ), lwork-iwork+1, ierr ) ! ! Generate right bidiagonalizing vectors in VT ! (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) ! CALL sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + n ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of A in U and computing right ! singular vectors of A in VT ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', n, n, m, 0, s, work( ie ), vt, & ldvt, u, ldu, dum, 1, work( iwork ), 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 >= n*n+MAX( n+m, 4*n, bdspac ) ) THEN ! ! Sufficient workspace for a fast algorithm ! ir = 1 IF( lwork >= 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 ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'L', m, n, a, lda, u, ldu ) ! ! Copy R to WORK(IR), zeroing out below it ! CALL slacpy( 'U', n, n, a, lda, work( ir ), ldwrkr ) CALL slaset( 'L', n-1, n-1, zero, zero, work( ir+1 ), ldwrkr ) ! ! Generate Q in U ! (Workspace: need N*N+N+M, prefer N*N+N+M*NB) ! CALL sorgqr( m, m, n, u, ldu, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Bidiagonalize R in WORK(IR) ! (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) ! CALL sgebrd( n, n, work( ir ), ldwrkr, s, & work( ie ), work( itauq ), work( itaup ), work( iwork ), & lwork-iwork+1, ierr ) ! ! Generate left bidiagonalizing vectors in WORK(IR) ! (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) ! CALL sorgbr( 'Q', n, n, n, work( ir ), ldwrkr, & work( itauq ), work( iwork ), lwork-iwork+1, ierr ) iwork = ie + n ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of R in WORK(IR) ! (Workspace: need N*N+BDSPAC) ! CALL sbdsqr( 'U', n, 0, n, 0, s, work( ie ), dum, & 1, work( ir ), ldwrkr, dum, 1, work( iwork ), info ) ! ! Multiply Q in U by left singular vectors of R in ! WORK(IR), storing result in A ! (Workspace: need N*N) ! CALL sgemm( 'N', 'N', m, n, n, one, u, ldu, & work( ir ), ldwrkr, zero, a, lda ) ! ! Copy left singular vectors of A from A to U ! CALL slacpy( '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 ! (Workspace: need 2*N, prefer N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'L', m, n, a, lda, u, ldu ) ! ! Generate Q in U ! (Workspace: need N+M, prefer N+M*NB) ! CALL sorgqr( m, m, n, u, ldu, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Zero out below R in A ! CALL slaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) ! ! Bidiagonalize R in A ! (Workspace: need 4*N, prefer 3*N+2*N*NB) ! CALL sgebrd( n, n, a, lda, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Multiply Q in U by left bidiagonalizing vectors ! in A ! (Workspace: need 3*N+M, prefer 3*N+M*NB) ! CALL sormbr( 'Q', 'R', 'N', m, n, n, a, lda, & work( itauq ), u, ldu, work( iwork ), lwork-iwork+1, ierr ) iwork = ie + n ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of A in U ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', n, 0, m, 0, s, work( ie ), dum, & 1, u, ldu, dum, 1, work( iwork ), 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 >= 2*n*n+MAX( n+m, 4*n, bdspac ) ) THEN ! ! Sufficient workspace for a fast algorithm ! iu = 1 IF( lwork >= 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 >= 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 ! (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'L', m, n, a, lda, u, ldu ) ! ! Generate Q in U ! (Workspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB) ! CALL sorgqr( m, m, n, u, ldu, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy R to WORK(IU), zeroing out below it ! CALL slacpy( 'U', n, n, a, lda, work( iu ), ldwrku ) CALL slaset( 'L', n-1, n-1, zero, zero, work( iu+1 ), ldwrku ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Bidiagonalize R in WORK(IU), copying result to ! WORK(IR) ! (Workspace: need 2*N*N+4*N, ! prefer 2*N*N+3*N+2*N*NB) ! CALL sgebrd( n, n, work( iu ), ldwrku, s, & work( ie ), work( itauq ), work( itaup ), work( iwork ), & lwork-iwork+1, ierr ) CALL slacpy( 'U', n, n, work( iu ), ldwrku, work( ir ), ldwrkr ) ! ! Generate left bidiagonalizing vectors in WORK(IU) ! (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB) ! CALL sorgbr( 'Q', n, n, n, work( iu ), ldwrku, & work( itauq ), work( iwork ), lwork-iwork+1, ierr ) ! ! Generate right bidiagonalizing vectors in WORK(IR) ! (Workspace: need 2*N*N+4*N-1, ! prefer 2*N*N+3*N+(N-1)*NB) ! CALL sorgbr( 'P', n, n, n, work( ir ), ldwrkr, & work( itaup ), work( iwork ), lwork-iwork+1, ierr ) iwork = 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) ! (Workspace: need 2*N*N+BDSPAC) ! CALL sbdsqr( 'U', n, n, n, 0, s, work( ie ), & work( ir ), ldwrkr, work( iu ), & ldwrku, dum, 1, work( iwork ), info ) ! ! Multiply Q in U by left singular vectors of R in ! WORK(IU), storing result in A ! (Workspace: need N*N) ! CALL sgemm( 'N', 'N', m, n, n, one, u, ldu, & work( iu ), ldwrku, zero, a, lda ) ! ! Copy left singular vectors of A from A to U ! CALL slacpy( 'F', m, n, a, lda, u, ldu ) ! ! Copy right singular vectors of R from WORK(IR) to A ! CALL slacpy( '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 ! (Workspace: need 2*N, prefer N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'L', m, n, a, lda, u, ldu ) ! ! Generate Q in U ! (Workspace: need N+M, prefer N+M*NB) ! CALL sorgqr( m, m, n, u, ldu, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Zero out below R in A ! CALL slaset( 'L', n-1, n-1, zero, zero, a( 2, 1 ), lda ) ! ! Bidiagonalize R in A ! (Workspace: need 4*N, prefer 3*N+2*N*NB) ! CALL sgebrd( n, n, a, lda, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Multiply Q in U by left bidiagonalizing vectors ! in A ! (Workspace: need 3*N+M, prefer 3*N+M*NB) ! CALL sormbr( 'Q', 'R', 'N', m, n, n, a, lda, & work( itauq ), u, ldu, work( iwork ), lwork-iwork+1, ierr ) ! ! Generate right bidiagonalizing vectors in A ! (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) ! CALL sorgbr( 'P', n, n, n, a, lda, work( itaup ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + n ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of A in U and computing right ! singular vectors of A in A ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', n, n, m, 0, s, work( ie ), a, & lda, u, ldu, dum, 1, work( iwork ), 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 >= n*n+MAX( n+m, 4*n, bdspac ) ) THEN ! ! Sufficient workspace for a fast algorithm ! iu = 1 IF( lwork >= 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 ! (Workspace: need N*N+2*N, prefer N*N+N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'L', m, n, a, lda, u, ldu ) ! ! Generate Q in U ! (Workspace: need N*N+N+M, prefer N*N+N+M*NB) ! CALL sorgqr( m, m, n, u, ldu, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy R to WORK(IU), zeroing out below it ! CALL slacpy( 'U', n, n, a, lda, work( iu ), ldwrku ) CALL slaset( 'L', n-1, n-1, zero, zero, work( iu+1 ), ldwrku ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Bidiagonalize R in WORK(IU), copying result to VT ! (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB) ! CALL sgebrd( n, n, work( iu ), ldwrku, s, & work( ie ), work( itauq ), work( itaup ), work( iwork ), & lwork-iwork+1, ierr ) CALL slacpy( 'U', n, n, work( iu ), ldwrku, vt, ldvt ) ! ! Generate left bidiagonalizing vectors in WORK(IU) ! (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB) ! CALL sorgbr( 'Q', n, n, n, work( iu ), ldwrku, & work( itauq ), work( iwork ), lwork-iwork+1, ierr ) ! ! Generate right bidiagonalizing vectors in VT ! (Workspace: need N*N+4*N-1, ! prefer N*N+3*N+(N-1)*NB) ! CALL sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + n ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of R in WORK(IU) and computing ! right singular vectors of R in VT ! (Workspace: need N*N+BDSPAC) ! CALL sbdsqr( 'U', n, n, n, 0, s, work( ie ), vt, & ldvt, work( iu ), ldwrku, dum, 1, work( iwork ), info ) ! ! Multiply Q in U by left singular vectors of R in ! WORK(IU), storing result in A ! (Workspace: need N*N) ! CALL sgemm( 'N', 'N', m, n, n, one, u, ldu, & work( iu ), ldwrku, zero, a, lda ) ! ! Copy left singular vectors of A from A to U ! CALL slacpy( '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 ! (Workspace: need 2*N, prefer N+N*NB) ! CALL sgeqrf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'L', m, n, a, lda, u, ldu ) ! ! Generate Q in U ! (Workspace: need N+M, prefer N+M*NB) ! CALL sorgqr( m, m, n, u, ldu, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy R from A to VT, zeroing out below it ! CALL slacpy( 'U', n, n, a, lda, vt, ldvt ) CALL slaset( 'L', n-1, n-1, zero, zero, vt( 2, 1 ), ldvt ) ie = itau itauq = ie + n itaup = itauq + n iwork = itaup + n ! ! Bidiagonalize R in VT ! (Workspace: need 4*N, prefer 3*N+2*N*NB) ! CALL sgebrd( n, n, vt, ldvt, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Multiply Q in U by left bidiagonalizing vectors ! in VT ! (Workspace: need 3*N+M, prefer 3*N+M*NB) ! CALL sormbr( 'Q', 'R', 'N', m, n, n, vt, ldvt, & work( itauq ), u, ldu, work( iwork ), lwork-iwork+1, ierr ) ! ! Generate right bidiagonalizing vectors in VT ! (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) ! CALL sorgbr( 'P', n, n, n, vt, ldvt, work( itaup ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + n ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of A in U and computing right ! singular vectors of A in VT ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', n, n, m, 0, s, work( ie ), vt, & ldvt, u, ldu, dum, 1, work( iwork ), 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 = ie + n itaup = itauq + n iwork = itaup + n ! ! Bidiagonalize A ! (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB) ! CALL sgebrd( m, n, a, lda, s, work( 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 ! (Workspace: need 3*N+NCU, prefer 3*N+NCU*NB) ! CALL slacpy( 'L', m, n, a, lda, u, ldu ) IF( wntus ) ncu = n IF( wntua ) ncu = m CALL sorgbr( '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 ! (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) ! CALL slacpy( 'U', n, n, a, lda, vt, ldvt ) CALL sorgbr( '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 ! (Workspace: need 4*N, prefer 3*N+N*NB) ! CALL sorgbr( '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 ! (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) ! CALL sorgbr( 'P', n, n, n, a, lda, work( itaup ), & work( iwork ), lwork-iwork+1, ierr ) END IF iwork = 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 ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), vt, & ldvt, u, ldu, dum, 1, work( iwork ), 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 ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), a, lda, & u, ldu, dum, 1, work( iwork ), info ) ELSE ! ! Perform bidiagonal QR iteration, if desired, computing ! left singular vectors in A and computing right singular ! vectors in VT ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', n, ncvt, nru, 0, s, work( ie ), vt, & ldvt, a, lda, dum, 1, work( iwork ), 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 >= 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 ! (Workspace: need 2*M, prefer M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), work( iwork ), & lwork-iwork+1, ierr ) ! ! Zero out above L ! CALL slaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) ie = 1 itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Bidiagonalize L in A ! (Workspace: need 4*M, prefer 3*M+2*M*NB) ! CALL sgebrd( m, m, a, lda, s, work( ie ), work( itauq ), & work( itaup ), work( iwork ), lwork-iwork+1, ierr ) IF( wntuo .OR. wntuas ) THEN ! ! If left singular vectors desired, generate Q ! (Workspace: need 4*M, prefer 3*M+M*NB) ! CALL sorgbr( 'Q', m, m, m, a, lda, work( itauq ), & work( iwork ), lwork-iwork+1, ierr ) END IF iwork = ie + m nru = 0 IF( wntuo .OR. wntuas ) nru = m ! ! Perform bidiagonal QR iteration, computing left singular ! vectors of A in A if desired ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', m, 0, nru, 0, s, work( ie ), dum, 1, a, & lda, dum, 1, work( iwork ), info ) ! ! If left singular vectors desired in U, copy them there ! IF( wntuas ) CALL slacpy( '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 >= m*m+MAX( 4*m, bdspac ) ) THEN ! ! Sufficient workspace for a fast algorithm ! ir = 1 IF( lwork >= MAX( wrkbl, lda*n+m )+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 >= MAX( wrkbl, lda*n+m )+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 ) / m ldwrkr = m END IF itau = ir + ldwrkr*m iwork = itau + m ! ! Compute A=L*Q ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy L to WORK(IR) and zero out above it ! CALL slacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) CALL slaset( 'U', m-1, m-1, zero, zero, work( ir+ldwrkr ), ldwrkr ) ! ! Generate Q in A ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sorglq( m, n, m, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Bidiagonalize L in WORK(IR) ! (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) ! CALL sgebrd( m, m, work( ir ), ldwrkr, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Generate right vectors bidiagonalizing L ! (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) ! CALL sorgbr( 'P', m, m, m, work( ir ), ldwrkr, & work( itaup ), work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! ! Perform bidiagonal QR iteration, computing right ! singular vectors of L in WORK(IR) ! (Workspace: need M*M+BDSPAC) ! CALL sbdsqr( 'U', m, m, 0, 0, s, work( ie ), & work( ir ), ldwrkr, dum, 1, dum, 1, work( iwork ), info ) iu = ie + m ! ! Multiply right singular vectors of L in WORK(IR) by Q ! in A, storing result in WORK(IU) and copying to A ! (Workspace: need M*M+2*M, prefer M*M+M*N+M) ! DO i = 1, n, chunk blk = MIN( n-i+1, chunk ) CALL sgemm( 'N', 'N', m, blk, m, one, work( ir ), & ldwrkr, a( 1, i ), lda, zero, work( iu ), ldwrku ) CALL slacpy( 'F', m, blk, work( iu ), ldwrku, a( 1, i ), lda ) END DO ! ELSE ! ! Insufficient workspace for a fast algorithm ! ie = 1 itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Bidiagonalize A ! (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) ! CALL sgebrd( m, n, a, lda, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Generate right vectors bidiagonalizing A ! (Workspace: need 4*M, prefer 3*M+M*NB) ! CALL sorgbr( 'P', m, n, m, a, lda, work( itaup ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! ! Perform bidiagonal QR iteration, computing right ! singular vectors of A in A ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'L', m, n, 0, 0, s, work( ie ), a, lda, & dum, 1, dum, 1, work( iwork ), 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 >= m*m+MAX( 4*m, bdspac ) ) THEN ! ! Sufficient workspace for a fast algorithm ! ir = 1 IF( lwork >= MAX( wrkbl, lda*n+m )+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 >= MAX( wrkbl, lda*n+m )+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 ) / m ldwrkr = m END IF itau = ir + ldwrkr*m iwork = itau + m ! ! Compute A=L*Q ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy L to U, zeroing about above it ! CALL slacpy( 'L', m, m, a, lda, u, ldu ) CALL slaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ), ldu ) ! ! Generate Q in A ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sorglq( m, n, m, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Bidiagonalize L in U, copying result to WORK(IR) ! (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) ! CALL sgebrd( m, m, u, ldu, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'U', m, m, u, ldu, work( ir ), ldwrkr ) ! ! Generate right vectors bidiagonalizing L in WORK(IR) ! (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) ! CALL sorgbr( 'P', m, m, m, work( ir ), ldwrkr, & work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Generate left vectors bidiagonalizing L in U ! (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) ! CALL sorgbr( 'Q', m, m, m, u, ldu, work( itauq ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of L in U, and computing right ! singular vectors of L in WORK(IR) ! (Workspace: need M*M+BDSPAC) ! CALL sbdsqr( 'U', m, m, m, 0, s, work( ie ), & work( ir ), ldwrkr, u, ldu, dum, 1, work( iwork ), info ) iu = ie + m ! ! Multiply right singular vectors of L in WORK(IR) by Q ! in A, storing result in WORK(IU) and copying to A ! (Workspace: need M*M+2*M, prefer M*M+M*N+M)) ! DO i = 1, n, chunk blk = MIN( n-i+1, chunk ) CALL sgemm( 'N', 'N', m, blk, m, one, work( ir ), & ldwrkr, a( 1, i ), lda, zero, work( iu ), ldwrku ) CALL slacpy( 'F', m, blk, work( iu ), ldwrku, a( 1, i ), lda ) END DO ! ELSE ! ! Insufficient workspace for a fast algorithm ! itau = 1 iwork = itau + m ! ! Compute A=L*Q ! (Workspace: need 2*M, prefer M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy L to U, zeroing out above it ! CALL slacpy( 'L', m, m, a, lda, u, ldu ) CALL slaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ), ldu ) ! ! Generate Q in A ! (Workspace: need 2*M, prefer M+M*NB) ! CALL sorglq( m, n, m, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Bidiagonalize L in U ! (Workspace: need 4*M, prefer 3*M+2*M*NB) ! CALL sgebrd( m, m, u, ldu, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Multiply right vectors bidiagonalizing L by Q in A ! (Workspace: need 3*M+N, prefer 3*M+N*NB) ! CALL sormbr( 'P', 'L', 'T', m, n, m, u, ldu, & work( itaup ), a, lda, work( iwork ), lwork-iwork+1, ierr ) ! ! Generate left vectors bidiagonalizing L in U ! (Workspace: need 4*M, prefer 3*M+M*NB) ! CALL sorgbr( 'Q', m, m, m, u, ldu, work( itauq ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of A in U and computing right ! singular vectors of A in A ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', m, n, m, 0, s, work( ie ), a, lda, & u, ldu, dum, 1, work( iwork ), 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 >= m*m+MAX( 4*m, bdspac ) ) THEN ! ! Sufficient workspace for a fast algorithm ! ir = 1 IF( lwork >= 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 ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy L to WORK(IR), zeroing out above it ! CALL slacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) CALL slaset( 'U', m-1, m-1, zero, zero, work( ir+ldwrkr ), ldwrkr ) ! ! Generate Q in A ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sorglq( m, n, m, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Bidiagonalize L in WORK(IR) ! (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) ! CALL sgebrd( m, m, work( ir ), ldwrkr, s, & work( ie ), work( itauq ), work( itaup ), work( iwork ), & lwork-iwork+1, ierr ) ! ! Generate right vectors bidiagonalizing L in ! WORK(IR) ! (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) ! CALL sorgbr( 'P', m, m, m, work( ir ), ldwrkr, & work( itaup ), work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! ! Perform bidiagonal QR iteration, computing right ! singular vectors of L in WORK(IR) ! (Workspace: need M*M+BDSPAC) ! CALL sbdsqr( 'U', m, m, 0, 0, s, work( ie ), & work( ir ), ldwrkr, dum, 1, dum, 1, work( iwork ), info ) ! ! Multiply right singular vectors of L in WORK(IR) by ! Q in A, storing result in VT ! (Workspace: need M*M) ! CALL sgemm( 'N', 'N', m, n, m, one, work( ir ), & ldwrkr, a, lda, zero, vt, ldvt ) ! ELSE ! ! Insufficient workspace for a fast algorithm ! itau = 1 iwork = itau + m ! ! Compute A=L*Q ! (Workspace: need 2*M, prefer M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy result to VT ! CALL slacpy( 'U', m, n, a, lda, vt, ldvt ) ! ! Generate Q in VT ! (Workspace: need 2*M, prefer M+M*NB) ! CALL sorglq( m, n, m, vt, ldvt, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Zero out above L in A ! CALL slaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) ! ! Bidiagonalize L in A ! (Workspace: need 4*M, prefer 3*M+2*M*NB) ! CALL sgebrd( m, m, a, lda, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Multiply right vectors bidiagonalizing L by Q in VT ! (Workspace: need 3*M+N, prefer 3*M+N*NB) ! CALL sormbr( 'P', 'L', 'T', m, n, m, a, lda, & work( itaup ), vt, ldvt, work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! ! Perform bidiagonal QR iteration, computing right ! singular vectors of A in VT ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', m, n, 0, 0, s, work( ie ), vt, & ldvt, dum, 1, dum, 1, work( iwork ), 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 >= 2*m*m+MAX( 4*m, bdspac ) ) THEN ! ! Sufficient workspace for a fast algorithm ! iu = 1 IF( lwork >= 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 >= 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 ! (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy L to WORK(IU), zeroing out below it ! CALL slacpy( 'L', m, m, a, lda, work( iu ), ldwrku ) CALL slaset( 'U', m-1, m-1, zero, zero, work( iu+ldwrku ), ldwrku ) ! ! Generate Q in A ! (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) ! CALL sorglq( m, n, m, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Bidiagonalize L in WORK(IU), copying result to ! WORK(IR) ! (Workspace: need 2*M*M+4*M, ! prefer 2*M*M+3*M+2*M*NB) ! CALL sgebrd( m, m, work( iu ), ldwrku, s, & work( ie ), work( itauq ), work( itaup ), work( iwork ), & lwork-iwork+1, ierr ) CALL slacpy( 'L', m, m, work( iu ), ldwrku, work( ir ), ldwrkr ) ! ! Generate right bidiagonalizing vectors in WORK(IU) ! (Workspace: need 2*M*M+4*M-1, ! prefer 2*M*M+3*M+(M-1)*NB) ! CALL sorgbr( 'P', m, m, m, work( iu ), ldwrku, & work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Generate left bidiagonalizing vectors in WORK(IR) ! (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) ! CALL sorgbr( 'Q', m, m, m, work( ir ), ldwrkr, & work( itauq ), work( iwork ), lwork-iwork+1, ierr ) iwork = 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) ! (Workspace: need 2*M*M+BDSPAC) ! CALL sbdsqr( 'U', m, m, m, 0, s, work( ie ), & work( iu ), ldwrku, work( ir ), & ldwrkr, dum, 1, work( iwork ), info ) ! ! Multiply right singular vectors of L in WORK(IU) by ! Q in A, storing result in VT ! (Workspace: need M*M) ! CALL sgemm( 'N', 'N', m, n, m, one, work( iu ), & ldwrku, a, lda, zero, vt, ldvt ) ! ! Copy left singular vectors of L to A ! (Workspace: need M*M) ! CALL slacpy( '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 ! (Workspace: need 2*M, prefer M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'U', m, n, a, lda, vt, ldvt ) ! ! Generate Q in VT ! (Workspace: need 2*M, prefer M+M*NB) ! CALL sorglq( m, n, m, vt, ldvt, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Zero out above L in A ! CALL slaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) ! ! Bidiagonalize L in A ! (Workspace: need 4*M, prefer 3*M+2*M*NB) ! CALL sgebrd( m, m, a, lda, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Multiply right vectors bidiagonalizing L by Q in VT ! (Workspace: need 3*M+N, prefer 3*M+N*NB) ! CALL sormbr( 'P', 'L', 'T', m, n, m, a, lda, & work( itaup ), vt, ldvt, work( iwork ), lwork-iwork+1, ierr ) ! ! Generate left bidiagonalizing vectors of L in A ! (Workspace: need 4*M, prefer 3*M+M*NB) ! CALL sorgbr( 'Q', m, m, m, a, lda, work( itauq ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! ! Perform bidiagonal QR iteration, compute left ! singular vectors of A in A and compute right ! singular vectors of A in VT ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', m, n, m, 0, s, work( ie ), vt, & ldvt, a, lda, dum, 1, work( iwork ), 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 >= m*m+MAX( 4*m, bdspac ) ) THEN ! ! Sufficient workspace for a fast algorithm ! iu = 1 IF( lwork >= 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 ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy L to WORK(IU), zeroing out above it ! CALL slacpy( 'L', m, m, a, lda, work( iu ), ldwrku ) CALL slaset( 'U', m-1, m-1, zero, zero, work( iu+ldwrku ), ldwrku ) ! ! Generate Q in A ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sorglq( m, n, m, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Bidiagonalize L in WORK(IU), copying result to U ! (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) ! CALL sgebrd( m, m, work( iu ), ldwrku, s, & work( ie ), work( itauq ), work( itaup ), work( iwork ), & lwork-iwork+1, ierr ) CALL slacpy( 'L', m, m, work( iu ), ldwrku, u, ldu ) ! ! Generate right bidiagonalizing vectors in WORK(IU) ! (Workspace: need M*M+4*M-1, ! prefer M*M+3*M+(M-1)*NB) ! CALL sorgbr( 'P', m, m, m, work( iu ), ldwrku, & work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Generate left bidiagonalizing vectors in U ! (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) ! CALL sorgbr( 'Q', m, m, m, u, ldu, work( itauq ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of L in U and computing right ! singular vectors of L in WORK(IU) ! (Workspace: need M*M+BDSPAC) ! CALL sbdsqr( 'U', m, m, m, 0, s, work( ie ), & work( iu ), ldwrku, u, ldu, dum, 1, work( iwork ), info ) ! ! Multiply right singular vectors of L in WORK(IU) by ! Q in A, storing result in VT ! (Workspace: need M*M) ! CALL sgemm( 'N', 'N', m, n, m, one, work( iu ), & ldwrku, a, lda, zero, vt, ldvt ) ! ELSE ! ! Insufficient workspace for a fast algorithm ! itau = 1 iwork = itau + m ! ! Compute A=L*Q, copying result to VT ! (Workspace: need 2*M, prefer M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'U', m, n, a, lda, vt, ldvt ) ! ! Generate Q in VT ! (Workspace: need 2*M, prefer M+M*NB) ! CALL sorglq( m, n, m, vt, ldvt, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy L to U, zeroing out above it ! CALL slacpy( 'L', m, m, a, lda, u, ldu ) CALL slaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ), ldu ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Bidiagonalize L in U ! (Workspace: need 4*M, prefer 3*M+2*M*NB) ! CALL sgebrd( m, m, u, ldu, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Multiply right bidiagonalizing vectors in U by Q ! in VT ! (Workspace: need 3*M+N, prefer 3*M+N*NB) ! CALL sormbr( 'P', 'L', 'T', m, n, m, u, ldu, & work( itaup ), vt, ldvt, work( iwork ), lwork-iwork+1, ierr ) ! ! Generate left bidiagonalizing vectors in U ! (Workspace: need 4*M, prefer 3*M+M*NB) ! CALL sorgbr( 'Q', m, m, m, u, ldu, work( itauq ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of A in U and computing right ! singular vectors of A in VT ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', m, n, m, 0, s, work( ie ), vt, & ldvt, u, ldu, dum, 1, work( iwork ), 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 >= m*m+MAX( n+m, 4*m, bdspac ) ) THEN ! ! Sufficient workspace for a fast algorithm ! ir = 1 IF( lwork >= 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 ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'U', m, n, a, lda, vt, ldvt ) ! ! Copy L to WORK(IR), zeroing out above it ! CALL slacpy( 'L', m, m, a, lda, work( ir ), ldwrkr ) CALL slaset( 'U', m-1, m-1, zero, zero, work( ir+ldwrkr ), ldwrkr ) ! ! Generate Q in VT ! (Workspace: need M*M+M+N, prefer M*M+M+N*NB) ! CALL sorglq( n, n, m, vt, ldvt, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Bidiagonalize L in WORK(IR) ! (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) ! CALL sgebrd( m, m, work( ir ), ldwrkr, s, & work( ie ), work( itauq ), work( itaup ), work( iwork ), & lwork-iwork+1, ierr ) ! ! Generate right bidiagonalizing vectors in WORK(IR) ! (Workspace: need M*M+4*M-1, ! prefer M*M+3*M+(M-1)*NB) ! CALL sorgbr( 'P', m, m, m, work( ir ), ldwrkr, & work( itaup ), work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! ! Perform bidiagonal QR iteration, computing right ! singular vectors of L in WORK(IR) ! (Workspace: need M*M+BDSPAC) ! CALL sbdsqr( 'U', m, m, 0, 0, s, work( ie ), & work( ir ), ldwrkr, dum, 1, dum, 1, work( iwork ), info ) ! ! Multiply right singular vectors of L in WORK(IR) by ! Q in VT, storing result in A ! (Workspace: need M*M) ! CALL sgemm( 'N', 'N', m, n, m, one, work( ir ), & ldwrkr, vt, ldvt, zero, a, lda ) ! ! Copy right singular vectors of A from A to VT ! CALL slacpy( '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 ! (Workspace: need 2*M, prefer M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'U', m, n, a, lda, vt, ldvt ) ! ! Generate Q in VT ! (Workspace: need M+N, prefer M+N*NB) ! CALL sorglq( n, n, m, vt, ldvt, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Zero out above L in A ! CALL slaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) ! ! Bidiagonalize L in A ! (Workspace: need 4*M, prefer 3*M+2*M*NB) ! CALL sgebrd( m, m, a, lda, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Multiply right bidiagonalizing vectors in A by Q ! in VT ! (Workspace: need 3*M+N, prefer 3*M+N*NB) ! CALL sormbr( 'P', 'L', 'T', m, n, m, a, lda, & work( itaup ), vt, ldvt, work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! ! Perform bidiagonal QR iteration, computing right ! singular vectors of A in VT ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', m, n, 0, 0, s, work( ie ), vt, & ldvt, dum, 1, dum, 1, work( iwork ), 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 >= 2*m*m+MAX( n+m, 4*m, bdspac ) ) THEN ! ! Sufficient workspace for a fast algorithm ! iu = 1 IF( lwork >= 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 >= 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 ! (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'U', m, n, a, lda, vt, ldvt ) ! ! Generate Q in VT ! (Workspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB) ! CALL sorglq( n, n, m, vt, ldvt, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy L to WORK(IU), zeroing out above it ! CALL slacpy( 'L', m, m, a, lda, work( iu ), ldwrku ) CALL slaset( 'U', m-1, m-1, zero, zero, work( iu+ldwrku ), ldwrku ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Bidiagonalize L in WORK(IU), copying result to ! WORK(IR) ! (Workspace: need 2*M*M+4*M, ! prefer 2*M*M+3*M+2*M*NB) ! CALL sgebrd( m, m, work( iu ), ldwrku, s, & work( ie ), work( itauq ), work( itaup ), work( iwork ), & lwork-iwork+1, ierr ) CALL slacpy( 'L', m, m, work( iu ), ldwrku, work( ir ), ldwrkr ) ! ! Generate right bidiagonalizing vectors in WORK(IU) ! (Workspace: need 2*M*M+4*M-1, ! prefer 2*M*M+3*M+(M-1)*NB) ! CALL sorgbr( 'P', m, m, m, work( iu ), ldwrku, & work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Generate left bidiagonalizing vectors in WORK(IR) ! (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB) ! CALL sorgbr( 'Q', m, m, m, work( ir ), ldwrkr, & work( itauq ), work( iwork ), lwork-iwork+1, ierr ) iwork = 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) ! (Workspace: need 2*M*M+BDSPAC) ! CALL sbdsqr( 'U', m, m, m, 0, s, work( ie ), & work( iu ), ldwrku, work( ir ), & ldwrkr, dum, 1, work( iwork ), info ) ! ! Multiply right singular vectors of L in WORK(IU) by ! Q in VT, storing result in A ! (Workspace: need M*M) ! CALL sgemm( 'N', 'N', m, n, m, one, work( iu ), & ldwrku, vt, ldvt, zero, a, lda ) ! ! Copy right singular vectors of A from A to VT ! CALL slacpy( 'F', m, n, a, lda, vt, ldvt ) ! ! Copy left singular vectors of A from WORK(IR) to A ! CALL slacpy( '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 ! (Workspace: need 2*M, prefer M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'U', m, n, a, lda, vt, ldvt ) ! ! Generate Q in VT ! (Workspace: need M+N, prefer M+N*NB) ! CALL sorglq( n, n, m, vt, ldvt, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Zero out above L in A ! CALL slaset( 'U', m-1, m-1, zero, zero, a( 1, 2 ), lda ) ! ! Bidiagonalize L in A ! (Workspace: need 4*M, prefer 3*M+2*M*NB) ! CALL sgebrd( m, m, a, lda, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Multiply right bidiagonalizing vectors in A by Q ! in VT ! (Workspace: need 3*M+N, prefer 3*M+N*NB) ! CALL sormbr( 'P', 'L', 'T', m, n, m, a, lda, & work( itaup ), vt, ldvt, work( iwork ), lwork-iwork+1, ierr ) ! ! Generate left bidiagonalizing vectors in A ! (Workspace: need 4*M, prefer 3*M+M*NB) ! CALL sorgbr( 'Q', m, m, m, a, lda, work( itauq ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of A in A and computing right ! singular vectors of A in VT ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', m, n, m, 0, s, work( ie ), vt, & ldvt, a, lda, dum, 1, work( iwork ), 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 >= m*m+MAX( n+m, 4*m, bdspac ) ) THEN ! ! Sufficient workspace for a fast algorithm ! iu = 1 IF( lwork >= 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 ! (Workspace: need M*M+2*M, prefer M*M+M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'U', m, n, a, lda, vt, ldvt ) ! ! Generate Q in VT ! (Workspace: need M*M+M+N, prefer M*M+M+N*NB) ! CALL sorglq( n, n, m, vt, ldvt, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy L to WORK(IU), zeroing out above it ! CALL slacpy( 'L', m, m, a, lda, work( iu ), ldwrku ) CALL slaset( 'U', m-1, m-1, zero, zero, work( iu+ldwrku ), ldwrku ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Bidiagonalize L in WORK(IU), copying result to U ! (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) ! CALL sgebrd( m, m, work( iu ), ldwrku, s, & work( ie ), work( itauq ), work( itaup ), work( iwork ), & lwork-iwork+1, ierr ) CALL slacpy( 'L', m, m, work( iu ), ldwrku, u, ldu ) ! ! Generate right bidiagonalizing vectors in WORK(IU) ! (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB) ! CALL sorgbr( 'P', m, m, m, work( iu ), ldwrku, & work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Generate left bidiagonalizing vectors in U ! (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB) ! CALL sorgbr( 'Q', m, m, m, u, ldu, work( itauq ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of L in U and computing right ! singular vectors of L in WORK(IU) ! (Workspace: need M*M+BDSPAC) ! CALL sbdsqr( 'U', m, m, m, 0, s, work( ie ), & work( iu ), ldwrku, u, ldu, dum, 1, work( iwork ), info ) ! ! Multiply right singular vectors of L in WORK(IU) by ! Q in VT, storing result in A ! (Workspace: need M*M) ! CALL sgemm( 'N', 'N', m, n, m, one, work( iu ), & ldwrku, vt, ldvt, zero, a, lda ) ! ! Copy right singular vectors of A from A to VT ! CALL slacpy( '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 ! (Workspace: need 2*M, prefer M+M*NB) ! CALL sgelqf( m, n, a, lda, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) CALL slacpy( 'U', m, n, a, lda, vt, ldvt ) ! ! Generate Q in VT ! (Workspace: need M+N, prefer M+N*NB) ! CALL sorglq( n, n, m, vt, ldvt, work( itau ), & work( iwork ), lwork-iwork+1, ierr ) ! ! Copy L to U, zeroing out above it ! CALL slacpy( 'L', m, m, a, lda, u, ldu ) CALL slaset( 'U', m-1, m-1, zero, zero, u( 1, 2 ), ldu ) ie = itau itauq = ie + m itaup = itauq + m iwork = itaup + m ! ! Bidiagonalize L in U ! (Workspace: need 4*M, prefer 3*M+2*M*NB) ! CALL sgebrd( m, m, u, ldu, s, work( ie ), & work( itauq ), work( itaup ), work( iwork ), lwork-iwork+1, ierr ) ! ! Multiply right bidiagonalizing vectors in U by Q ! in VT ! (Workspace: need 3*M+N, prefer 3*M+N*NB) ! CALL sormbr( 'P', 'L', 'T', m, n, m, u, ldu, & work( itaup ), vt, ldvt, work( iwork ), lwork-iwork+1, ierr ) ! ! Generate left bidiagonalizing vectors in U ! (Workspace: need 4*M, prefer 3*M+M*NB) ! CALL sorgbr( 'Q', m, m, m, u, ldu, work( itauq ), & work( iwork ), lwork-iwork+1, ierr ) iwork = ie + m ! ! Perform bidiagonal QR iteration, computing left ! singular vectors of A in U and computing right ! singular vectors of A in VT ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'U', m, n, m, 0, s, work( ie ), vt, & ldvt, u, ldu, dum, 1, work( iwork ), 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 = ie + m itaup = itauq + m iwork = itaup + m ! ! Bidiagonalize A ! (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) ! CALL sgebrd( m, n, a, lda, s, work( 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 ! (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB) ! CALL slacpy( 'L', m, m, a, lda, u, ldu ) CALL sorgbr( '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 ! (Workspace: need 3*M+NRVT, prefer 3*M+NRVT*NB) ! CALL slacpy( 'U', m, n, a, lda, vt, ldvt ) IF( wntva ) nrvt = n IF( wntvs ) nrvt = m CALL sorgbr( '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 ! (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB) ! CALL sorgbr( '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 ! (Workspace: need 4*M, prefer 3*M+M*NB) ! CALL sorgbr( 'P', m, n, m, a, lda, work( itaup ), & work( iwork ), lwork-iwork+1, ierr ) END IF iwork = 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 ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), vt, & ldvt, u, ldu, dum, 1, work( iwork ), 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 ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), a, lda, & u, ldu, dum, 1, work( iwork ), info ) ELSE ! ! Perform bidiagonal QR iteration, if desired, computing ! left singular vectors in A and computing right singular ! vectors in VT ! (Workspace: need BDSPAC) ! CALL sbdsqr( 'L', m, ncvt, nru, 0, s, work( ie ), vt, & ldvt, a, lda, dum, 1, work( iwork ), info ) END IF ! END IF ! END IF ! ! If SBDSQR failed to converge, copy unconverged superdiagonals ! to WORK( 2:MINMN ) ! IF( info /= 0 ) THEN IF( ie > 2 ) THEN DO i = 1, minmn - 1 work( i+1 ) = work( i+ie-1 ) END DO END IF IF( ie < 2 ) THEN DO i = minmn - 1, 1, -1 work( i+1 ) = work( i+ie-1 ) END DO END IF END IF ! ! Undo scaling if necessary ! IF( iscl == 1 ) THEN IF( anrm > bignum ) & CALL slascl( 'G', 0, 0, bignum, anrm, minmn, 1, s, minmn, ierr ) IF( info /= 0 .AND. anrm > bignum ) & CALL slascl( 'G', 0, 0, bignum, anrm, minmn-1, 1, work( 2 ), minmn, ierr ) IF( anrm < smlnum ) & CALL slascl( 'G', 0, 0, smlnum, anrm, minmn, 1, s, minmn, ierr ) IF( info /= 0 .AND. anrm < smlnum ) & CALL slascl( 'G', 0, 0, smlnum, anrm, minmn-1, 1, work( 2 ), minmn, ierr ) END IF ! ! Return optimal workspace in WORK(1) ! work( 1 ) = maxwrk ! RETURN ! ! End of SGESVD ! END SUBROUTINE sgesvd SUBROUTINE sgesvx( fact, trans, n, nrhs, a, lda, af, ldaf, ipiv, & equed, r, c, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, 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 (LEN=1), INTENT(IN) :: fact CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN) :: af( ldaf, * ) INTEGER, INTENT(IN) :: ldaf INTEGER, INTENT(IN OUT) :: ipiv( * ) CHARACTER (LEN=1), INTENT(OUT) :: equed REAL, INTENT(IN) :: r( * ) REAL, INTENT(IN) :: c( * ) REAL, INTENT(OUT) :: b( ldb, * ) INTEGER, INTENT(IN) :: ldb REAL, INTENT(OUT) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: rcond REAL, INTENT(OUT) :: ferr( * ) REAL, INTENT(IN OUT) :: berr( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGESVX uses the LU factorization to compute 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. ! ! Error bounds on the solution and a condition estimate are also ! provided. ! ! Description ! =========== ! ! The following steps are performed: ! ! 1. If FACT = 'E', real scaling factors are computed to equilibrate ! the system: ! TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B ! TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B ! TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B ! Whether or not the system will be equilibrated depends on the ! scaling of the matrix A, but if equilibration is used, A is ! overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') ! or diag(C)*B (if TRANS = 'T' or 'C'). ! ! 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the ! matrix A (after equilibration if FACT = 'E') as ! A = P * L * U, ! where P is a permutation matrix, L is a unit lower triangular ! matrix, and U is upper triangular. ! ! 3. If some U(i,i)=0, so that U is exactly singular, then the routine ! returns with INFO = i. Otherwise, the factored form of A is used ! to estimate the condition number of the matrix A. If the ! reciprocal of the condition number is less than machine precision, ! INFO = N+1 is returned as a warning, but the routine still goes on ! to solve for X and compute error bounds as described below. ! ! 4. The system of equations is solved for X using the factored form ! of A. ! ! 5. Iterative refinement is applied to improve the computed solution ! matrix and calculate error bounds and backward error estimates ! for it. ! ! 6. If equilibration was used, the matrix X is premultiplied by ! diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so ! that it solves the original system before equilibration. ! ! Arguments ! ========= ! ! FACT (input) CHARACTER*1 ! Specifies whether or not the factored form of the matrix A is ! supplied on entry, and if not, whether the matrix A should be ! equilibrated before it is factored. ! = 'F': On entry, AF and IPIV contain the factored form of A. ! If EQUED is not 'N', the matrix A has been ! equilibrated with scaling factors given by R and C. ! A, AF, and IPIV are not modified. ! = 'N': The matrix A will be copied to AF and factored. ! = 'E': The matrix A will be equilibrated if necessary, then ! copied to AF and factored. ! ! 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 (Transpose) ! ! 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 matrices B and X. NRHS >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is ! not 'N', then A must have been equilibrated by the scaling ! factors in R and/or C. A is not modified if FACT = 'F' or ! 'N', or if FACT = 'E' and EQUED = 'N' on exit. ! ! On exit, if EQUED .ne. 'N', A is scaled as follows: ! EQUED = 'R': A := diag(R) * A ! EQUED = 'C': A := A * diag(C) ! EQUED = 'B': A := diag(R) * A * diag(C). ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! AF (input or output) REAL array, dimension (LDAF,N) ! If FACT = 'F', then AF is an input argument and on entry ! contains the factors L and U from the factorization ! A = P*L*U as computed by SGETRF. If EQUED .ne. 'N', then ! AF is the factored form of the equilibrated matrix A. ! ! If FACT = 'N', then AF is an output argument and on exit ! returns the factors L and U from the factorization A = P*L*U ! of the original matrix A. ! ! If FACT = 'E', then AF is an output argument and on exit ! returns the factors L and U from the factorization A = P*L*U ! of the equilibrated matrix A (see the description of A for ! the form of the equilibrated matrix). ! ! LDAF (input) INTEGER ! The leading dimension of the array AF. LDAF >= max(1,N). ! ! IPIV (input or output) INTEGER array, dimension (N) ! If FACT = 'F', then IPIV is an input argument and on entry ! contains the pivot indices from the factorization A = P*L*U ! as computed by SGETRF; row i of the matrix was interchanged ! with row IPIV(i). ! ! If FACT = 'N', then IPIV is an output argument and on exit ! contains the pivot indices from the factorization A = P*L*U ! of the original matrix A. ! ! If FACT = 'E', then IPIV is an output argument and on exit ! contains the pivot indices from the factorization A = P*L*U ! of the equilibrated matrix A. ! ! EQUED (input or output) CHARACTER*1 ! Specifies the form of equilibration that was done. ! = 'N': No equilibration (always true if FACT = 'N'). ! = 'R': Row equilibration, i.e., A has been premultiplied by ! diag(R). ! = 'C': Column equilibration, i.e., A has been postmultiplied ! by diag(C). ! = 'B': Both row and column equilibration, i.e., A has been ! replaced by diag(R) * A * diag(C). ! EQUED is an input argument if FACT = 'F'; otherwise, it is an ! output argument. ! ! R (input or output) REAL array, dimension (N) ! The row scale factors for A. If EQUED = 'R' or 'B', A is ! multiplied on the left by diag(R); if EQUED = 'N' or 'C', R ! is not accessed. R is an input argument if FACT = 'F'; ! otherwise, R is an output argument. If FACT = 'F' and ! EQUED = 'R' or 'B', each element of R must be positive. ! ! C (input or output) REAL array, dimension (N) ! The column scale factors for A. If EQUED = 'C' or 'B', A is ! multiplied on the right by diag(C); if EQUED = 'N' or 'R', C ! is not accessed. C is an input argument if FACT = 'F'; ! otherwise, C is an output argument. If FACT = 'F' and ! EQUED = 'C' or 'B', each element of C must be positive. ! ! B (input/output) REAL array, dimension (LDB,NRHS) ! On entry, the N-by-NRHS right hand side matrix B. ! On exit, ! if EQUED = 'N', B is not modified; ! if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by ! diag(R)*B; ! if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is ! overwritten by diag(C)*B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (output) REAL array, dimension (LDX,NRHS) ! If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X ! to the original system of equations. Note that A and B are ! modified on exit if EQUED .ne. 'N', and the solution to the ! equilibrated system is inv(diag(C))*X if TRANS = 'N' and ! EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' ! and EQUED = 'R' or 'B'. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! RCOND (output) REAL ! The estimate of the reciprocal condition number of the matrix ! A after equilibration (if done). If RCOND is less than the ! machine precision (in particular, if RCOND = 0), the matrix ! is singular to working precision. This condition is ! indicated by a return code of INFO > 0. ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace/output) REAL array, dimension (4*N) ! On exit, WORK(1) contains the reciprocal pivot growth ! factor norm(A)/norm(U). The "max absolute element" norm is ! used. If WORK(1) is much less than 1, then the stability ! of the LU factorization of the (equilibrated) matrix A ! could be poor. This also means that the solution X, condition ! estimator RCOND, and forward error bound FERR could be ! unreliable. If factorization fails with 0 0: if INFO = i, and i is ! <= N: U(i,i) is exactly zero. The factorization has ! been completed, but the factor U is exactly ! singular, so the solution and error bounds ! could not be computed. RCOND = 0 is returned. ! = N+1: U is nonsingular, but RCOND is less than machine ! precision, meaning that the matrix is singular ! to working precision. Nevertheless, the ! solution and error bounds are computed because ! there are a number of situations where the ! computed solution can be more accurate than the ! value of RCOND would suggest. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: colequ, equil, nofact, notran, rowequ CHARACTER (LEN=1) :: norm INTEGER :: i, infequ, j REAL :: amax, anorm, bignum, colcnd, rcmax, rcmin, rowcnd, rpvgrw, smlnum ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slange, slantr EXTERNAL lsame, slamch, slange, slantr ! .. ! .. External Subroutines .. EXTERNAL sgecon, sgeequ, sgerfs, sgetrf, sgetrs, slacpy, & slaqge, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! info = 0 nofact = lsame( fact, 'N' ) equil = lsame( fact, 'E' ) notran = lsame( trans, 'N' ) IF( nofact .OR. equil ) THEN equed = 'N' rowequ = .false. colequ = .false. ELSE rowequ = lsame( equed, 'R' ) .OR. lsame( equed, 'B' ) colequ = lsame( equed, 'C' ) .OR. lsame( equed, 'B' ) smlnum = slamch( 'Safe minimum' ) bignum = one / smlnum END IF ! ! Test the input parameters. ! IF( .NOT.nofact .AND. .NOT.equil .AND. .NOT.lsame( fact, 'F' ) ) THEN info = -1 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT. & lsame( trans, 'C' ) ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( nrhs < 0 ) THEN info = -4 ELSE IF( lda < MAX( 1, n ) ) THEN info = -6 ELSE IF( ldaf < MAX( 1, n ) ) THEN info = -8 ELSE IF( lsame( fact, 'F' ) .AND. .NOT. & ( rowequ .OR. colequ .OR. lsame( equed, 'N' ) ) ) THEN info = -10 ELSE IF( rowequ ) THEN rcmin = bignum rcmax = zero DO j = 1, n rcmin = MIN( rcmin, r( j ) ) rcmax = MAX( rcmax, r( j ) ) END DO IF( rcmin <= zero ) THEN info = -11 ELSE IF( n > 0 ) THEN rowcnd = MAX( rcmin, smlnum ) / MIN( rcmax, bignum ) ELSE rowcnd = one END IF END IF IF( colequ .AND. info == 0 ) THEN rcmin = bignum rcmax = zero DO j = 1, n rcmin = MIN( rcmin, c( j ) ) rcmax = MAX( rcmax, c( j ) ) END DO IF( rcmin <= zero ) THEN info = -12 ELSE IF( n > 0 ) THEN colcnd = MAX( rcmin, smlnum ) / MIN( rcmax, bignum ) ELSE colcnd = one END IF END IF IF( info == 0 ) THEN IF( ldb < MAX( 1, n ) ) THEN info = -14 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -16 END IF END IF END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SGESVX', -info ) RETURN END IF ! IF( equil ) THEN ! ! Compute row and column scalings to equilibrate the matrix A. ! CALL sgeequ( n, n, a, lda, r, c, rowcnd, colcnd, amax, infequ ) IF( infequ == 0 ) THEN ! ! Equilibrate the matrix. ! CALL slaqge( n, n, a, lda, r, c, rowcnd, colcnd, amax, equed ) rowequ = lsame( equed, 'R' ) .OR. lsame( equed, 'B' ) colequ = lsame( equed, 'C' ) .OR. lsame( equed, 'B' ) END IF END IF ! ! Scale the right hand side. ! IF( notran ) THEN IF( rowequ ) THEN DO j = 1, nrhs DO i = 1, n b( i, j ) = r( i )*b( i, j ) END DO END DO END IF ELSE IF( colequ ) THEN DO j = 1, nrhs DO i = 1, n b( i, j ) = c( i )*b( i, j ) END DO END DO END IF ! IF( nofact .OR. equil ) THEN ! ! Compute the LU factorization of A. ! CALL slacpy( 'Full', n, n, a, lda, af, ldaf ) CALL sgetrf( n, n, af, ldaf, ipiv, info ) ! ! Return if INFO is non-zero. ! IF( info /= 0 ) THEN IF( info > 0 ) THEN ! ! Compute the reciprocal pivot growth factor of the ! leading rank-deficient INFO columns of A. ! rpvgrw = slantr( 'M', 'U', 'N', info, info, af, ldaf, work ) IF( rpvgrw == zero ) THEN rpvgrw = one ELSE rpvgrw = slange( 'M', n, info, a, lda, work ) / rpvgrw END IF work( 1 ) = rpvgrw rcond = zero END IF RETURN END IF END IF ! ! Compute the norm of the matrix A and the ! reciprocal pivot growth factor RPVGRW. ! IF( notran ) THEN norm = '1' ELSE norm = 'I' END IF anorm = slange( norm, n, n, a, lda, work ) rpvgrw = slantr( 'M', 'U', 'N', n, n, af, ldaf, work ) IF( rpvgrw == zero ) THEN rpvgrw = one ELSE rpvgrw = slange( 'M', n, n, a, lda, work ) / rpvgrw END IF ! ! Compute the reciprocal of the condition number of A. ! CALL sgecon( norm, n, af, ldaf, anorm, rcond, work, iwork, info ) ! ! Set INFO = N+1 if the matrix is singular to working precision. ! IF( rcond < slamch( 'Epsilon' ) ) info = n + 1 ! ! Compute the solution matrix X. ! CALL slacpy( 'Full', n, nrhs, b, ldb, x, ldx ) CALL sgetrs( trans, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! ! Use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. ! CALL sgerfs( trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, & ldx, ferr, berr, work, iwork, info ) ! ! Transform the solution matrix X to a solution of the original ! system. ! IF( notran ) THEN IF( colequ ) THEN DO j = 1, nrhs DO i = 1, n x( i, j ) = c( i )*x( i, j ) END DO END DO DO j = 1, nrhs ferr( j ) = ferr( j ) / colcnd END DO END IF ELSE IF( rowequ ) THEN DO j = 1, nrhs DO i = 1, n x( i, j ) = r( i )*x( i, j ) END DO END DO DO j = 1, nrhs ferr( j ) = ferr( j ) / rowcnd END DO END IF ! work( 1 ) = rpvgrw RETURN ! ! End of SGESVX ! END SUBROUTINE sgesvx SUBROUTINE sgetc2( n, a, lda, ipiv, jpiv, 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, INTENT(IN OUT) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(OUT) :: ipiv( * ) INTEGER, INTENT(OUT) :: jpiv( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGETC2 computes an LU factorization with complete pivoting of the ! n-by-n matrix A. The factorization has the form A = P * L * U * Q, ! where P and Q are permutation matrices, L is lower triangular with ! unit diagonal elements and U is upper triangular. ! ! This is the Level 2 BLAS algorithm. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! A (input/output) REAL array, dimension (LDA, N) ! On entry, the n-by-n matrix A to be factored. ! On exit, the factors L and U from the factorization ! A = P*L*U*Q; the unit diagonal elements of L are not stored. ! If U(k, k) appears to be less than SMIN, U(k, k) is given the ! value of SMIN, i.e., giving a nonsingular perturbed system. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! IPIV (output) INTEGER array, dimension(N). ! The pivot indices; for 1 <= i <= N, row i of the ! matrix has been interchanged with row IPIV(i). ! ! JPIV (output) INTEGER array, dimension(N). ! The pivot indices; for 1 <= j <= N, column j of the ! matrix has been interchanged with column JPIV(j). ! ! INFO (output) INTEGER ! = 0: successful exit ! > 0: if INFO = k, U(k, k) is likely to produce owerflow if ! we try to solve for x in Ax = b. So U is perturbed to ! avoid the overflow. ! ! Further Details ! =============== ! ! Based on contributions by ! Bo Kagstrom and Peter Poromaa, Department of Computing Science, ! Umea University, S-901 87 Umea, Sweden. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, ip, ipv, j, jp, jpv REAL :: bignum, eps, smin, smlnum, xmax ! .. ! .. External Subroutines .. EXTERNAL sger, slabad, sswap ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. Executable Statements .. ! ! Set constants to control overflow ! info = 0 eps = slamch( 'P' ) smlnum = slamch( 'S' ) / eps bignum = one / smlnum CALL slabad( smlnum, bignum ) ! ! Factorize A using complete pivoting. ! Set pivots less than SMIN to SMIN. ! DO i = 1, n - 1 ! ! Find max element in matrix A ! xmax = zero DO ip = i, n DO jp = i, n IF( ABS( a( ip, jp ) ) >= xmax ) THEN xmax = ABS( a( ip, jp ) ) ipv = ip jpv = jp END IF END DO END DO IF( i == 1 ) smin = MAX( eps*xmax, smlnum ) ! ! Swap rows ! IF( ipv /= i ) CALL sswap( n, a( ipv, 1 ), lda, a( i, 1 ), lda ) ipiv( i ) = ipv ! ! Swap columns ! IF( jpv /= i ) CALL sswap( n, a( 1, jpv ), 1, a( 1, i ), 1 ) jpiv( i ) = jpv ! ! Check for singularity ! IF( ABS( a( i, i ) ) < smin ) THEN info = i a( i, i ) = smin END IF DO j = i + 1, n a( j, i ) = a( j, i ) / a( i, i ) END DO CALL sger( n-i, n-i, -one, a( i+1, i ), 1, a( i, i+1 ), lda, & a( i+1, i+1 ), lda ) END DO ! IF( ABS( a( n, n ) ) < smin ) THEN info = n a( n, n ) = smin END IF ! RETURN ! ! End of SGETC2 ! END SUBROUTINE sgetc2 SUBROUTINE sgetf2( 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(OUT) :: ipiv( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGETF2 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) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: j, jp ! .. ! .. External Functions .. INTEGER :: isamax EXTERNAL isamax ! .. ! .. External Subroutines .. EXTERNAL sger, sscal, sswap, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, m ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGETF2', -info ) RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 ) RETURN ! DO j = 1, MIN( m, n ) ! ! Find pivot and test for singularity. ! jp = j - 1 + isamax( m-j+1, a( j, j ), 1 ) ipiv( j ) = jp IF( a( jp, j ) /= zero ) THEN ! ! Apply the interchange to columns 1:N. ! IF( jp /= j ) CALL sswap( n, a( j, 1 ), lda, a( jp, 1 ), lda ) ! ! Compute elements J+1:M of J-th column. ! IF( j < m ) CALL sscal( m-j, one / a( j, j ), a( j+1, j ), 1 ) ! ELSE IF( info == 0 ) THEN ! info = j END IF ! IF( j < MIN( m, n ) ) THEN ! ! Update trailing submatrix. ! CALL sger( m-j, n-j, -one, a( j+1, j ), 1, a( j, j+1 ), lda, & a( j+1, j+1 ), lda ) END IF END DO RETURN ! ! End of SGETF2 ! END SUBROUTINE sgetf2 SUBROUTINE sgetrf( 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(OUT) :: ipiv( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGETRF 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) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, iinfo, j, jb, nb ! .. ! .. External Subroutines .. EXTERNAL sgemm, sgetf2, slaswp, strsm, xerbla ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, m ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGETRF', -info ) RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 ) RETURN ! ! Determine the block size for this environment. ! nb = ilaenv( 1, 'SGETRF', ' ', m, n, -1, -1 ) IF( nb <= 1 .OR. nb >= MIN( m, n ) ) THEN ! ! Use unblocked code. ! CALL sgetf2( m, n, a, lda, ipiv, info ) ELSE ! ! Use blocked code. ! DO 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 sgetf2( m-j+1, jb, a( j, j ), lda, ipiv( j ), iinfo ) ! ! Adjust INFO and the pivot indices. ! IF( info == 0 .AND. iinfo > 0 ) info = iinfo + j - 1 DO i = j, MIN( m, j+jb-1 ) ipiv( i ) = j - 1 + ipiv( i ) END DO ! ! Apply interchanges to columns 1:J-1. ! CALL slaswp( j-1, a, lda, j, j+jb-1, ipiv, 1 ) ! IF( j+jb <= n ) THEN ! ! Apply interchanges to columns J+JB:N. ! CALL slaswp( n-j-jb+1, a( 1, j+jb ), lda, j, j+jb-1, ipiv, 1 ) ! ! Compute block row of U. ! CALL strsm( 'Left', 'Lower', 'No transpose', 'Unit', jb, & n-j-jb+1, one, a( j, j ), lda, a( j, j+jb ), lda ) IF( j+jb <= m ) THEN ! ! Update trailing submatrix. ! CALL sgemm( '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 END DO END IF RETURN ! ! End of SGETRF ! END SUBROUTINE sgetrf SUBROUTINE sgetri( 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, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(IN) :: ipiv( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGETRI computes the inverse of a matrix using the LU factorization ! computed by SGETRF. ! ! 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) REAL array, dimension (LDA,N) ! On entry, the factors L and U from the factorization ! A = P*L*U as computed by SGETRF. ! 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 SGETRF; for 1<=i<=N, row i of the ! matrix was interchanged with row IPIV(i). ! ! WORK (workspace/output) REAL 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 .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+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 sgemm, sgemv, sswap, strsm, strtri, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 nb = ilaenv( 1, 'SGETRI', ' ', n, -1, -1, -1 ) lwkopt = n*nb work( 1 ) = lwkopt lquery = ( lwork == -1 ) IF( n < 0 ) THEN info = -1 ELSE IF( lda < MAX( 1, n ) ) THEN info = -3 ELSE IF( lwork < MAX( 1, n ) .AND. .NOT.lquery ) THEN info = -6 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGETRI', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Form inv(U). If INFO > 0 from STRTRI, then U is singular, ! and the inverse is not computed. ! CALL strtri( 'Upper', 'Non-unit', n, a, lda, info ) IF( info > 0 ) RETURN ! nbmin = 2 ldwork = n IF( nb > 1 .AND. nb < n ) THEN iws = MAX( ldwork*nb, 1 ) IF( lwork < iws ) THEN nb = lwork / ldwork nbmin = MAX( 2, ilaenv( 2, 'SGETRI', ' ', n, -1, -1, -1 ) ) END IF ELSE iws = n END IF ! ! Solve the equation inv(A)*L = inv(U) for inv(A). ! IF( nb < nbmin .OR. nb >= n ) THEN ! ! Use unblocked code. ! DO j = n, 1, -1 ! ! Copy current column of L to WORK and replace with zeros. ! DO i = j + 1, n work( i ) = a( i, j ) a( i, j ) = zero END DO ! ! Compute current column of inv(A). ! IF( j < n ) CALL sgemv( 'No transpose', n, n-j, -one, a( 1, j+1 ), & lda, work( j+1 ), 1, one, a( 1, j ), 1 ) END DO ELSE ! ! Use blocked code. ! nn = ( ( n-1 ) / nb )*nb + 1 DO j = nn, 1, -nb jb = MIN( nb, n-j+1 ) ! ! Copy current block column of L to WORK and replace with ! zeros. ! DO jj = j, j + jb - 1 DO i = jj + 1, n work( i+( jj-j )*ldwork ) = a( i, jj ) a( i, jj ) = zero END DO END DO ! ! Compute current block column of inv(A). ! IF( j+jb <= n ) CALL sgemm( '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 strsm( 'Right', 'Lower', 'No transpose', 'Unit', n, jb, & one, work( j ), ldwork, a( 1, j ), lda ) END DO END IF ! ! Apply column interchanges. ! DO j = n - 1, 1, -1 jp = ipiv( j ) IF( jp /= j ) CALL sswap( n, a( 1, j ), 1, a( 1, jp ), 1 ) END DO ! work( 1 ) = iws RETURN ! ! End of SGETRI ! END SUBROUTINE sgetri SUBROUTINE sgetrs( 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 (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(IN OUT) :: ipiv( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGETRS 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 SGETRF. ! ! 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) REAL array, dimension (LDA,N) ! The factors L and U from the factorization A = P*L*U ! as computed by SGETRF. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! IPIV (input) INTEGER array, dimension (N) ! The pivot indices from SGETRF; for 1<=i<=N, row i of the ! matrix was interchanged with row IPIV(i). ! ! B (input/output) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: notran ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL slaswp, strsm, 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 < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -8 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGETRS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) RETURN ! IF( notran ) THEN ! ! Solve A * X = B. ! ! Apply row interchanges to the right hand sides. ! CALL slaswp( nrhs, b, ldb, 1, n, ipiv, 1 ) ! ! Solve L*X = B, overwriting B with X. ! CALL strsm( 'Left', 'Lower', 'No transpose', 'Unit', n, nrhs, & one, a, lda, b, ldb ) ! ! Solve U*X = B, overwriting B with X. ! CALL strsm( '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 strsm( 'Left', 'Upper', 'Transpose', 'Non-unit', n, nrhs, & one, a, lda, b, ldb ) ! ! Solve L'*X = B, overwriting B with X. ! CALL strsm( 'Left', 'Lower', 'Transpose', 'Unit', n, nrhs, one, & a, lda, b, ldb ) ! ! Apply row interchanges to the solution vectors. ! CALL slaswp( nrhs, b, ldb, 1, n, ipiv, -1 ) END IF ! RETURN ! ! End of SGETRS ! END SUBROUTINE sgetrs SUBROUTINE sggbak( 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 (LEN=1), INTENT(IN) :: job CHARACTER (LEN=1), INTENT(IN) :: side INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: ilo INTEGER, INTENT(IN) :: ihi REAL, INTENT(IN) :: lscale( * ) REAL, INTENT(IN) :: rscale( * ) INTEGER, INTENT(IN) :: m REAL, INTENT(IN OUT) :: v( ldv, * ) INTEGER, INTENT(IN OUT) :: ldv INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGGBAK forms the right or left eigenvectors of a real generalized ! eigenvalue problem A*x = lambda*B*x, by backward transformation on ! the computed eigenvectors of the balanced pair of matrices output by ! SGGBAL. ! ! 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 SGGBAL. ! ! 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 SGGBAL. ! 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. ! ! LSCALE (input) REAL array, dimension (N) ! Details of the permutations and/or scaling factors applied ! to the left side of A and B, as returned by SGGBAL. ! ! RSCALE (input) REAL array, dimension (N) ! Details of the permutations and/or scaling factors applied ! to the right side of A and B, as returned by SGGBAL. ! ! M (input) INTEGER ! The number of columns of the matrix V. M >= 0. ! ! V (input/output) REAL array, dimension (LDV,M) ! On entry, the matrix of right or left eigenvectors to be ! transformed, as returned by STGEVC. ! 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 sscal, sswap, xerbla ! .. ! .. 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 < 0 ) THEN info = -3 ELSE IF( ilo < 1 ) THEN info = -4 ELSE IF( ihi < ilo .OR. ihi > MAX( 1, n ) ) THEN info = -5 ELSE IF( m < 0 ) THEN info = -6 ELSE IF( ldv < MAX( 1, n ) ) THEN info = -10 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGGBAK', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN IF( m == 0 ) RETURN IF( lsame( job, 'N' ) ) RETURN ! IF( ilo == ihi ) GO TO 30 ! ! Backward balance ! IF( lsame( job, 'S' ) .OR. lsame( job, 'B' ) ) THEN ! ! Backward transformation on right eigenvectors ! IF( rightv ) THEN DO i = ilo, ihi CALL sscal( m, rscale( i ), v( i, 1 ), ldv ) END DO END IF ! ! Backward transformation on left eigenvectors ! IF( leftv ) THEN DO i = ilo, ihi CALL sscal( m, lscale( i ), v( i, 1 ), ldv ) END DO 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 == 1 ) GO TO 50 ! DO i = ilo - 1, 1, -1 k = rscale( i ) IF( k == i ) CYCLE CALL sswap( m, v( i, 1 ), ldv, v( k, 1 ), ldv ) END DO ! 50 CONTINUE IF( ihi == n ) GO TO 70 DO i = ihi + 1, n k = rscale( i ) IF( k == i ) CYCLE CALL sswap( m, v( i, 1 ), ldv, v( k, 1 ), ldv ) END DO END IF ! ! Backward permutation on left eigenvectors ! 70 CONTINUE IF( leftv ) THEN IF( ilo == 1 ) GO TO 90 DO i = ilo - 1, 1, -1 k = lscale( i ) IF( k == i ) CYCLE CALL sswap( m, v( i, 1 ), ldv, v( k, 1 ), ldv ) END DO ! 90 CONTINUE IF( ihi == n ) GO TO 110 DO i = ihi + 1, n k = lscale( i ) IF( k == i ) CYCLE CALL sswap( m, v( i, 1 ), ldv, v( k, 1 ), ldv ) END DO END IF END IF ! 110 CONTINUE ! RETURN ! ! End of SGGBAK ! END SUBROUTINE sggbak SUBROUTINE sggbal( 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 (LEN=1), INTENT(IN) :: job INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: ilo INTEGER, INTENT(OUT) :: ihi REAL, INTENT(OUT) :: lscale( * ) REAL, INTENT(OUT) :: rscale( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGGBAL balances a pair of general real 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) REAL 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) REAL 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) REAL 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) REAL 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 ! 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. ! ! WORK (workspace) REAL 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 .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: half = 0.5E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: three = 3.0E+0 REAL, PARAMETER :: sclfac = 1.0E+1 ! .. ! .. Local Scalars .. INTEGER :: i, icab, iflow, ip1, ir, irab, it, j, jc, jp1, & k, kount, l, lcab, lm1, lrab, lsfmax, lsfmin, m, nr, nrp2 REAL :: alpha, basl, beta, cab, cmax, coef, coef2, & coef5, cor, ew, ewc, gamma, pgamma, rab, sfmax, sfmin, sum, t, ta, tb, tc ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: isamax REAL :: sdot, slamch EXTERNAL lsame, isamax, sdot, slamch ! .. ! .. External Subroutines .. EXTERNAL saxpy, sscal, sswap, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG10, MAX, MIN, REAL, SIGN ! .. ! .. 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 < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, n ) ) THEN info = -4 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -5 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGGBAL', -info ) RETURN END IF ! k = 1 l = n ! ! Quick return if possible ! IF( n == 0 ) RETURN ! IF( lsame( job, 'N' ) ) THEN ilo = 1 ihi = n DO i = 1, n lscale( i ) = one rscale( i ) = one END DO RETURN END IF ! IF( k == 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 /= 1 ) GO TO 30 ! rscale( 1 ) = 1 lscale( 1 ) = 1 GO TO 190 ! 30 CONTINUE lm1 = l - 1 loop80: DO i = l, 1, -1 DO j = 1, lm1 jp1 = j + 1 IF( a( i, j ) /= zero .OR. b( i, j ) /= zero ) GO TO 50 END DO j = l GO TO 70 ! 50 CONTINUE DO j = jp1, l IF( a( i, j ) /= zero .OR. b( i, j ) /= zero ) CYCLE loop80 END DO j = jp1 - 1 ! 70 CONTINUE m = l iflow = 1 GO TO 160 END DO loop80 GO TO 100 ! ! Find column with one nonzero in rows K through N ! 90 CONTINUE k = k + 1 ! 100 CONTINUE loop150: DO j = k, l DO i = k, lm1 ip1 = i + 1 IF( a( i, j ) /= zero .OR. b( i, j ) /= zero ) GO TO 120 END DO i = l GO TO 140 120 CONTINUE DO i = ip1, l IF( a( i, j ) /= zero .OR. b( i, j ) /= zero ) CYCLE loop150 END DO i = ip1 - 1 140 CONTINUE m = k iflow = 2 GO TO 160 END DO loop150 GO TO 190 ! ! Permute rows M and I ! 160 CONTINUE lscale( m ) = i IF( i == m ) GO TO 170 CALL sswap( n-k+1, a( i, k ), lda, a( m, k ), lda ) CALL sswap( n-k+1, b( i, k ), ldb, b( m, k ), ldb ) ! ! Permute columns M and J ! 170 CONTINUE rscale( m ) = j IF( j == m ) GO TO 180 CALL sswap( l, a( 1, j ), 1, a( 1, m ), 1 ) CALL sswap( l, b( 1, j ), 1, b( 1, m ), 1 ) ! 180 CONTINUE SELECT CASE ( iflow ) CASE ( 1) GO TO 20 CASE ( 2) GO TO 90 END SELECT ! 190 CONTINUE ilo = k ihi = l ! IF( ilo == ihi ) RETURN ! IF( lsame( job, 'P' ) ) RETURN ! ! Balance the submatrix in rows ILO to IHI. ! nr = ihi - ilo + 1 DO 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 END DO ! ! Compute right side vector in resulting linear equations ! basl = LOG10( sclfac ) DO i = ilo, ihi DO j = ilo, ihi tb = b( i, j ) ta = a( i, j ) IF( ta == zero ) GO TO 210 ta = LOG10( ABS( ta ) ) / basl 210 CONTINUE IF( tb == zero ) GO TO 220 tb = LOG10( ABS( tb ) ) / basl 220 CONTINUE work( i+4*n ) = work( i+4*n ) - ta - tb work( j+5*n ) = work( j+5*n ) - ta - tb END DO END DO ! coef = one / REAL( 2*nr ) coef2 = coef*coef coef5 = half*coef2 nrp2 = nr + 2 beta = zero it = 1 ! ! Start generalized conjugate gradient iteration ! 250 CONTINUE ! gamma = sdot( nr, work( ilo+4*n ), 1, work( ilo+4*n ), 1 ) + & sdot( nr, work( ilo+5*n ), 1, work( ilo+5*n ), 1 ) ! ew = zero ewc = zero DO i = ilo, ihi ew = ew + work( i+4*n ) ewc = ewc + work( i+5*n ) END DO ! gamma = coef*gamma - coef2*( ew**2+ewc**2 ) - coef5*( ew-ewc )**2 IF( gamma == zero ) GO TO 350 IF( it /= 1 ) beta = gamma / pgamma t = coef5*( ewc-three*ew ) tc = coef5*( ew-three*ewc ) ! CALL sscal( nr, beta, work( ilo ), 1 ) CALL sscal( nr, beta, work( ilo+n ), 1 ) ! CALL saxpy( nr, coef, work( ilo+4*n ), 1, work( ilo+n ), 1 ) CALL saxpy( nr, coef, work( ilo+5*n ), 1, work( ilo ), 1 ) ! DO i = ilo, ihi work( i ) = work( i ) + tc work( i+n ) = work( i+n ) + t END DO ! ! Apply matrix to vector ! DO i = ilo, ihi kount = 0 sum = zero DO j = ilo, ihi IF( a( i, j ) == zero ) GO TO 280 kount = kount + 1 sum = sum + work( j ) 280 CONTINUE IF( b( i, j ) == zero ) CYCLE kount = kount + 1 sum = sum + work( j ) END DO work( i+2*n ) = REAL( kount )*work( i+n ) + sum END DO ! DO j = ilo, ihi kount = 0 sum = zero DO i = ilo, ihi IF( a( i, j ) == zero ) GO TO 310 kount = kount + 1 sum = sum + work( i+n ) 310 CONTINUE IF( b( i, j ) == zero ) CYCLE kount = kount + 1 sum = sum + work( i+n ) END DO work( j+3*n ) = REAL( kount )*work( j ) + sum END DO ! sum = sdot( nr, work( ilo+n ), 1, work( ilo+2*n ), 1 ) + & sdot( nr, work( ilo ), 1, work( ilo+3*n ), 1 ) alpha = gamma / sum ! ! Determine correction to current iteration ! cmax = zero DO i = ilo, ihi cor = alpha*work( i+n ) IF( ABS( cor ) > cmax ) cmax = ABS( cor ) lscale( i ) = lscale( i ) + cor cor = alpha*work( i ) IF( ABS( cor ) > cmax ) cmax = ABS( cor ) rscale( i ) = rscale( i ) + cor END DO IF( cmax < half ) GO TO 350 ! CALL saxpy( nr, -alpha, work( ilo+2*n ), 1, work( ilo+4*n ), 1 ) CALL saxpy( nr, -alpha, work( ilo+3*n ), 1, work( ilo+5*n ), 1 ) ! pgamma = gamma it = it + 1 IF( it <= nrp2 ) GO TO 250 ! ! End generalized conjugate gradient iteration ! 350 CONTINUE sfmin = slamch( 'S' ) sfmax = one / sfmin lsfmin = INT( LOG10( sfmin ) / basl+one ) lsfmax = INT( LOG10( sfmax ) / basl ) DO i = ilo, ihi irab = isamax( n-ilo+1, a( i, ilo ), lda ) rab = ABS( a( i, irab+ilo-1 ) ) irab = isamax( 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 = isamax( ihi, a( 1, i ), 1 ) cab = ABS( a( icab, i ) ) icab = isamax( 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 END DO ! ! Row scaling of matrices A and B ! DO i = ilo, ihi CALL sscal( n-ilo+1, lscale( i ), a( i, ilo ), lda ) CALL sscal( n-ilo+1, lscale( i ), b( i, ilo ), ldb ) END DO ! ! Column scaling of matrices A and B ! DO j = ilo, ihi CALL sscal( ihi, rscale( j ), a( 1, j ), 1 ) CALL sscal( ihi, rscale( j ), b( 1, j ), 1 ) END DO ! RETURN ! ! End of SGGBAL ! END SUBROUTINE sggbal SUBROUTINE sgges( jobvsl, jobvsr, sort, selctg, n, a, lda, b, ldb, & sdim, alphar, alphai, beta, vsl, ldvsl, vsr, ldvsr, work, lwork, bwork, 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 .. INTEGER, INTENT(IN) :: lda INTEGER, INTENT(IN) :: ldb INTEGER, INTENT(IN OUT) :: ldvsl INTEGER, INTENT(IN OUT) :: ldvsr CHARACTER (LEN=1), INTENT(IN) :: jobvsl CHARACTER (LEN=1), INTENT(IN) :: jobvsr CHARACTER (LEN=1), INTENT(IN) :: sort LOGICAL :: selctg INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(OUT) :: sdim REAL, INTENT(IN OUT) :: alphar( * ) REAL, INTENT(IN OUT) :: alphai( * ) REAL, INTENT(IN OUT) :: beta( * ) REAL, INTENT(IN OUT) :: vsl( ldvsl, * ) REAL, INTENT(IN OUT) :: vsr( ldvsr, * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork LOGICAL, INTENT(OUT) :: bwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! .. Function Arguments .. EXTERNAL selctg ! .. ! ! Purpose ! ======= ! ! SGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B), ! the generalized eigenvalues, the generalized real Schur form (S,T), ! optionally, the left and/or right matrices of Schur vectors (VSL and ! VSR). This gives the generalized Schur factorization ! ! (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T ) ! ! Optionally, it also orders the eigenvalues so that a selected cluster ! of eigenvalues appears in the leading diagonal blocks of the upper ! quasi-triangular matrix S and the upper triangular matrix T.The ! leading columns of VSL and VSR then form an orthonormal basis for the ! corresponding left and right eigenspaces (deflating subspaces). ! ! (If only the generalized eigenvalues are needed, use the driver ! SGGEV instead, which is faster.) ! ! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w ! or a ratio alpha/beta = w, such that A - w*B is singular. It is ! usually represented as the pair (alpha,beta), as there is a ! reasonable interpretation for beta=0 or both being zero. ! ! A pair of matrices (S,T) is in generalized real Schur form if T is ! upper triangular with non-negative diagonal and S is block upper ! triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond ! to real generalized eigenvalues, while 2-by-2 blocks of S will be ! "standardized" by making the corresponding elements of T have the ! form: ! [ a 0 ] ! [ 0 b ] ! ! and the pair of corresponding 2-by-2 blocks in S and T will have a ! complex conjugate pair of generalized eigenvalues. ! ! ! Arguments ! ========= ! ! JOBVSL (input) CHARACTER*1 ! = 'N': do not compute the left Schur vectors; ! = 'V': compute the left Schur vectors. ! ! JOBVSR (input) CHARACTER*1 ! = 'N': do not compute the right Schur vectors; ! = 'V': compute the right Schur vectors. ! ! SORT (input) CHARACTER*1 ! Specifies whether or not to order the eigenvalues on the ! diagonal of the generalized Schur form. ! = 'N': Eigenvalues are not ordered; ! = 'S': Eigenvalues are ordered (see SELCTG); ! ! SELCTG (input) LOGICAL FUNCTION of three REAL arguments ! SELCTG must be declared EXTERNAL in the calling subroutine. ! If SORT = 'N', SELCTG is not referenced. ! If SORT = 'S', SELCTG is used to select eigenvalues to sort ! to the top left of the Schur form. ! An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if ! SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either ! one of a complex conjugate pair of eigenvalues is selected, ! then both complex eigenvalues are selected. ! ! Note that in the ill-conditioned case, a selected complex ! eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j), ! BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2 ! in this case. ! ! N (input) INTEGER ! The order of the matrices A, B, VSL, and VSR. N >= 0. ! ! A (input/output) REAL array, dimension (LDA, N) ! On entry, the first of the pair of matrices. ! On exit, A has been overwritten by its generalized Schur ! form S. ! ! LDA (input) INTEGER ! The leading dimension of A. LDA >= max(1,N). ! ! B (input/output) REAL array, dimension (LDB, N) ! On entry, the second of the pair of matrices. ! On exit, B has been overwritten by its generalized Schur ! form T. ! ! LDB (input) INTEGER ! The leading dimension of B. LDB >= max(1,N). ! ! SDIM (output) INTEGER ! If SORT = 'N', SDIM = 0. ! If SORT = 'S', SDIM = number of eigenvalues (after sorting) ! for which SELCTG is true. (Complex conjugate pairs for which ! SELCTG is true for either eigenvalue count as 2.) ! ! ALPHAR (output) REAL array, dimension (N) ! ALPHAI (output) REAL array, dimension (N) ! BETA (output) REAL array, dimension (N) ! On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will ! be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i, ! and BETA(j),j=1,...,N are the diagonals of the complex Schur ! form (S,T) that would result if the 2-by-2 diagonal blocks of ! the real Schur form of (A,B) were further reduced to ! triangular form using 2-by-2 complex unitary transformations. ! If ALPHAI(j) is zero, then the j-th eigenvalue is real; if ! positive, then the j-th and (j+1)-st eigenvalues are a ! complex conjugate pair, with ALPHAI(j+1) negative. ! ! Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) ! may easily over- or underflow, and BETA(j) may even be zero. ! Thus, the user should avoid naively computing the ratio. ! However, ALPHAR and ALPHAI will be always less than and ! usually comparable with norm(A) in magnitude, and BETA always ! less than and usually comparable with norm(B). ! ! VSL (output) REAL array, dimension (LDVSL,N) ! If JOBVSL = 'V', VSL will contain the left Schur vectors. ! Not referenced if JOBVSL = 'N'. ! ! LDVSL (input) INTEGER ! The leading dimension of the matrix VSL. LDVSL >=1, and ! if JOBVSL = 'V', LDVSL >= N. ! ! VSR (output) REAL array, dimension (LDVSR,N) ! If JOBVSR = 'V', VSR will contain the right Schur vectors. ! Not referenced if JOBVSR = 'N'. ! ! LDVSR (input) INTEGER ! The leading dimension of the matrix VSR. LDVSR >= 1, and ! if JOBVSR = 'V', LDVSR >= N. ! ! WORK (workspace/output) REAL array, dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. LWORK >= 8*N+16. ! ! 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. ! ! BWORK (workspace) LOGICAL array, dimension (N) ! Not referenced if SORT = '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. (A,B) are not in Schur ! form, but ALPHAR(j), ALPHAI(j), and BETA(j) should ! be correct for j=INFO+1,...,N. ! > N: =N+1: other than QZ iteration failed in SHGEQZ. ! =N+2: after reordering, roundoff changed values of ! some complex eigenvalues so that leading ! eigenvalues in the Generalized Schur form no ! longer satisfy SELCTG=.TRUE. This could also ! be caused due to scaling. ! =N+3: reordering failed in STGSEN. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, lquery, lst2sl, wantst INTEGER :: i, icols, ierr, ihi, ijobvl, ijobvr, ileft, & ilo, ip, iright, irows, itau, iwrk, maxwrk, minwrk REAL :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pvsl, & pvsr, safmax, safmin, smlnum ! .. ! .. Local Arrays .. INTEGER :: idum( 1 ) REAL :: dif( 2 ) ! .. ! .. External Subroutines .. EXTERNAL sgeqrf, sggbak, sggbal, sgghrd, shgeqz, slabad, & slacpy, slascl, slaset, sorgqr, sormqr, stgsen, xerbla ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slange EXTERNAL lsame, ilaenv, slamch, slange ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, SQRT ! .. ! .. Executable Statements .. ! ! Decode the input arguments ! IF( lsame( jobvsl, 'N' ) ) THEN ijobvl = 1 ilvsl = .false. ELSE IF( lsame( jobvsl, 'V' ) ) THEN ijobvl = 2 ilvsl = .true. ELSE ijobvl = -1 ilvsl = .false. END IF ! IF( lsame( jobvsr, 'N' ) ) THEN ijobvr = 1 ilvsr = .false. ELSE IF( lsame( jobvsr, 'V' ) ) THEN ijobvr = 2 ilvsr = .true. ELSE ijobvr = -1 ilvsr = .false. END IF ! wantst = lsame( sort, 'S' ) ! ! Test the input arguments ! info = 0 lquery = ( lwork == -1 ) IF( ijobvl <= 0 ) THEN info = -1 ELSE IF( ijobvr <= 0 ) THEN info = -2 ELSE IF( ( .NOT.wantst ) .AND. ( .NOT.lsame( sort, 'N' ) ) ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -5 ELSE IF( lda < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -9 ELSE IF( ldvsl < 1 .OR. ( ilvsl .AND. ldvsl < n ) ) THEN info = -15 ELSE IF( ldvsr < 1 .OR. ( ilvsr .AND. ldvsr < n ) ) THEN info = -17 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.) ! minwrk = 1 IF( info == 0 .AND. ( lwork >= 1 .OR. lquery ) ) THEN minwrk = 7*( n+1 ) + 16 maxwrk = 7*( n+1 ) + n*ilaenv( 1, 'SGEQRF', ' ', n, 1, n, 0 ) + 16 IF( ilvsl ) THEN maxwrk = MAX( maxwrk, 7*( n+1 )+n* & ilaenv( 1, 'SORGQR', ' ', n, 1, n, -1 ) ) END IF work( 1 ) = maxwrk END IF ! IF( lwork < minwrk .AND. .NOT.lquery ) info = -19 IF( info /= 0 ) THEN CALL xerbla( 'SGGES ', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) THEN sdim = 0 RETURN END IF ! ! Get machine constants ! eps = slamch( 'P' ) safmin = slamch( 'S' ) safmax = one / safmin CALL slabad( safmin, safmax ) smlnum = SQRT( safmin ) / eps bignum = one / smlnum ! ! Scale A if max element outside range [SMLNUM,BIGNUM] ! anrm = slange( 'M', n, n, a, lda, work ) ilascl = .false. IF( anrm > zero .AND. anrm < smlnum ) THEN anrmto = smlnum ilascl = .true. ELSE IF( anrm > bignum ) THEN anrmto = bignum ilascl = .true. END IF IF( ilascl ) CALL slascl( 'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr ) ! ! Scale B if max element outside range [SMLNUM,BIGNUM] ! bnrm = slange( 'M', n, n, b, ldb, work ) ilbscl = .false. IF( bnrm > zero .AND. bnrm < smlnum ) THEN bnrmto = smlnum ilbscl = .true. ELSE IF( bnrm > bignum ) THEN bnrmto = bignum ilbscl = .true. END IF IF( ilbscl ) CALL slascl( 'G', 0, 0, bnrm, bnrmto, n, n, b, ldb, ierr ) ! ! Permute the matrix to make it more nearly triangular ! (Workspace: need 6*N + 2*N space for storing balancing factors) ! ileft = 1 iright = n + 1 iwrk = iright + n CALL sggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ), & work( iright ), work( iwrk ), ierr ) ! ! Reduce B to triangular form (QR decomposition of B) ! (Workspace: need N, prefer N*NB) ! irows = ihi + 1 - ilo icols = n + 1 - ilo itau = iwrk iwrk = itau + irows CALL sgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ), & work( iwrk ), lwork+1-iwrk, ierr ) ! ! Apply the orthogonal transformation to matrix A ! (Workspace: need N, prefer N*NB) ! CALL sormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb, & work( itau ), a( ilo, ilo ), lda, work( iwrk ), lwork+1-iwrk, ierr ) ! ! Initialize VSL ! (Workspace: need N, prefer N*NB) ! IF( ilvsl ) THEN CALL slaset( 'Full', n, n, zero, one, vsl, ldvsl ) CALL slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb, & vsl( ilo+1, ilo ), ldvsl ) CALL sorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl, & work( itau ), work( iwrk ), lwork+1-iwrk, ierr ) END IF ! ! Initialize VSR ! IF( ilvsr ) CALL slaset( 'Full', n, n, zero, one, vsr, ldvsr ) ! ! Reduce to generalized Hessenberg form ! (Workspace: none needed) ! CALL sgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl, & ldvsl, vsr, ldvsr, ierr ) ! ! Perform QZ algorithm, computing Schur vectors if desired ! (Workspace: need N) ! iwrk = itau CALL shgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, & alphar, alphai, beta, vsl, ldvsl, vsr, ldvsr, & work( iwrk ), lwork+1-iwrk, ierr ) IF( ierr /= 0 ) THEN IF( ierr > 0 .AND. ierr <= n ) THEN info = ierr ELSE IF( ierr > n .AND. ierr <= 2*n ) THEN info = ierr - n ELSE info = n + 1 END IF GO TO 40 END IF ! ! Sort eigenvalues ALPHA/BETA if desired ! (Workspace: need 4*N+16 ) ! sdim = 0 IF( wantst ) THEN ! ! Undo scaling on eigenvalues before SELCTGing ! IF( ilascl ) THEN CALL slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) CALL slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) END IF IF( ilbscl ) CALL slascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) ! ! Select eigenvalues ! DO i = 1, n bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) ) END DO ! CALL stgsen( 0, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, alphar, & alphai, beta, vsl, ldvsl, vsr, ldvsr, sdim, pvsl, & pvsr, dif, work( iwrk ), lwork-iwrk+1, idum, 1, ierr ) IF( ierr == 1 ) info = n + 3 ! END IF ! ! Apply back-permutation to VSL and VSR ! (Workspace: none needed) ! IF( ilvsl ) CALL sggbak( 'P', 'L', n, ilo, ihi, work( ileft ), & work( iright ), n, vsl, ldvsl, ierr ) ! IF( ilvsr ) CALL sggbak( 'P', 'R', n, ilo, ihi, work( ileft ), & work( iright ), n, vsr, ldvsr, ierr ) ! ! Check if unscaling would cause over/underflow, if so, rescale ! (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of ! B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) ! IF( ilascl )THEN DO i = 1, n IF( alphai( i ) /= zero ) THEN IF( ( alphar( i )/safmax ) > ( anrmto/anrm ) .OR. & ( safmin/alphar( i ) ) > ( anrm/anrmto ) ) THEN work( 1 ) = ABS( a( i, i )/alphar( i ) ) beta( i ) = beta( i )*work( 1 ) alphar( i ) = alphar( i )*work( 1 ) alphai( i ) = alphai( i )*work( 1 ) ELSE IF( ( alphai( i )/safmax ) > ( anrmto/anrm ) .OR. & ( safmin/alphai( i ) ) > ( anrm/anrmto ) ) THEN work( 1 ) = ABS( a( i, i+1 )/alphai( i ) ) beta( i ) = beta( i )*work( 1 ) alphar( i ) = alphar( i )*work( 1 ) alphai( i ) = alphai( i )*work( 1 ) END IF END IF END DO END IF ! IF( ilbscl )THEN DO i = 1, n IF( alphai( i ) /= zero ) THEN IF( ( beta( i )/safmax ) > ( bnrmto/bnrm ) .OR. & ( safmin/beta( i ) ) > ( bnrm/bnrmto ) ) THEN work( 1 ) = ABS(b( i, i )/beta( i )) beta( i ) = beta( i )*work( 1 ) alphar( i ) = alphar( i )*work( 1 ) alphai( i ) = alphai( i )*work( 1 ) END IF END IF END DO END IF ! ! Undo scaling ! IF( ilascl ) THEN CALL slascl( 'H', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) CALL slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) CALL slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) END IF ! IF( ilbscl ) THEN CALL slascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) CALL slascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) END IF ! IF( wantst ) THEN ! ! Check if reordering is correct ! lastsl = .true. lst2sl = .true. sdim = 0 ip = 0 DO i = 1, n cursl = selctg( alphar( i ), alphai( i ), beta( i ) ) IF( alphai( i ) == zero ) THEN IF( cursl ) sdim = sdim + 1 ip = 0 IF( cursl .AND. .NOT.lastsl ) info = n + 2 ELSE IF( ip == 1 ) THEN ! ! Last eigenvalue of conjugate pair ! cursl = cursl .OR. lastsl lastsl = cursl IF( cursl ) sdim = sdim + 2 ip = -1 IF( cursl .AND. .NOT.lst2sl ) info = n + 2 ELSE ! ! First eigenvalue of conjugate pair ! ip = 1 END IF END IF lst2sl = lastsl lastsl = cursl END DO ! END IF ! 40 CONTINUE ! work( 1 ) = maxwrk ! RETURN ! ! End of SGGES ! END SUBROUTINE sgges SUBROUTINE sggesx( jobvsl, jobvsr, sort, selctg, sense, n, a, lda, & b, ldb, sdim, alphar, alphai, beta, vsl, ldvsl, & vsr, ldvsr, rconde, rcondv, work, lwork, iwork, liwork, bwork, 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 .. INTEGER, INTENT(IN) :: lda INTEGER, INTENT(IN) :: ldb CHARACTER (LEN=1), INTENT(IN) :: jobvsl CHARACTER (LEN=1), INTENT(IN) :: jobvsr CHARACTER (LEN=1), INTENT(IN) :: sort LOGICAL :: selctg CHARACTER (LEN=1), INTENT(IN) :: sense INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(OUT) :: sdim REAL, INTENT(IN OUT) :: alphar( * ) REAL, INTENT(IN OUT) :: alphai( * ) REAL, INTENT(IN OUT) :: beta( * ) REAL, INTENT(IN OUT) :: vsl( ldvsl, * ) INTEGER, INTENT(IN OUT) :: ldvsl REAL, INTENT(IN OUT) :: vsr( ldvsr, * ) INTEGER, INTENT(IN OUT) :: ldvsr REAL, INTENT(OUT) :: rconde( 2 ) REAL, INTENT(OUT) :: rcondv( 2 ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(IN) :: liwork LOGICAL, INTENT(OUT) :: bwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! .. Function Arguments .. EXTERNAL selctg ! .. ! ! Purpose ! ======= ! ! SGGESX computes for a pair of N-by-N real nonsymmetric matrices ! (A,B), the generalized eigenvalues, the real Schur form (S,T), and, ! optionally, the left and/or right matrices of Schur vectors (VSL and ! VSR). This gives the generalized Schur factorization ! ! (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T ) ! ! Optionally, it also orders the eigenvalues so that a selected cluster ! of eigenvalues appears in the leading diagonal blocks of the upper ! quasi-triangular matrix S and the upper triangular matrix T; computes ! a reciprocal condition number for the average of the selected ! eigenvalues (RCONDE); and computes a reciprocal condition number for ! the right and left deflating subspaces corresponding to the selected ! eigenvalues (RCONDV). The leading columns of VSL and VSR then form ! an orthonormal basis for the corresponding left and right eigenspaces ! (deflating subspaces). ! ! A generalized eigenvalue for a pair of matrices (A,B) is a scalar w ! or a ratio alpha/beta = w, such that A - w*B is singular. It is ! usually represented as the pair (alpha,beta), as there is a ! reasonable interpretation for beta=0 or for both being zero. ! ! A pair of matrices (S,T) is in generalized real Schur form if T is ! upper triangular with non-negative diagonal and S is block upper ! triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond ! to real generalized eigenvalues, while 2-by-2 blocks of S will be ! "standardized" by making the corresponding elements of T have the ! form: ! [ a 0 ] ! [ 0 b ] ! ! and the pair of corresponding 2-by-2 blocks in S and T will have a ! complex conjugate pair of generalized eigenvalues. ! ! ! Arguments ! ========= ! ! JOBVSL (input) CHARACTER*1 ! = 'N': do not compute the left Schur vectors; ! = 'V': compute the left Schur vectors. ! ! JOBVSR (input) CHARACTER*1 ! = 'N': do not compute the right Schur vectors; ! = 'V': compute the right Schur vectors. ! ! SORT (input) CHARACTER*1 ! Specifies whether or not to order the eigenvalues on the ! diagonal of the generalized Schur form. ! = 'N': Eigenvalues are not ordered; ! = 'S': Eigenvalues are ordered (see SELCTG). ! ! SELCTG (input) LOGICAL FUNCTION of three REAL arguments ! SELCTG must be declared EXTERNAL in the calling subroutine. ! If SORT = 'N', SELCTG is not referenced. ! If SORT = 'S', SELCTG is used to select eigenvalues to sort ! to the top left of the Schur form. ! An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if ! SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either ! one of a complex conjugate pair of eigenvalues is selected, ! then both complex eigenvalues are selected. ! Note that a selected complex eigenvalue may no longer satisfy ! SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering, ! since ordering may change the value of complex eigenvalues ! (especially if the eigenvalue is ill-conditioned), in this ! case INFO is set to N+3. ! ! SENSE (input) CHARACTER ! Determines which reciprocal condition numbers are computed. ! = 'N' : None are computed; ! = 'E' : Computed for average of selected eigenvalues only; ! = 'V' : Computed for selected deflating subspaces only; ! = 'B' : Computed for both. ! If SENSE = 'E', 'V', or 'B', SORT must equal 'S'. ! ! N (input) INTEGER ! The order of the matrices A, B, VSL, and VSR. N >= 0. ! ! A (input/output) REAL array, dimension (LDA, N) ! On entry, the first of the pair of matrices. ! On exit, A has been overwritten by its generalized Schur ! form S. ! ! LDA (input) INTEGER ! The leading dimension of A. LDA >= max(1,N). ! ! B (input/output) REAL array, dimension (LDB, N) ! On entry, the second of the pair of matrices. ! On exit, B has been overwritten by its generalized Schur ! form T. ! ! LDB (input) INTEGER ! The leading dimension of B. LDB >= max(1,N). ! ! SDIM (output) INTEGER ! If SORT = 'N', SDIM = 0. ! If SORT = 'S', SDIM = number of eigenvalues (after sorting) ! for which SELCTG is true. (Complex conjugate pairs for which ! SELCTG is true for either eigenvalue count as 2.) ! ! ALPHAR (output) REAL array, dimension (N) ! ALPHAI (output) REAL array, dimension (N) ! BETA (output) REAL array, dimension (N) ! On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will ! be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i ! and BETA(j),j=1,...,N are the diagonals of the complex Schur ! form (S,T) that would result if the 2-by-2 diagonal blocks of ! the real Schur form of (A,B) were further reduced to ! triangular form using 2-by-2 complex unitary transformations. ! If ALPHAI(j) is zero, then the j-th eigenvalue is real; if ! positive, then the j-th and (j+1)-st eigenvalues are a ! complex conjugate pair, with ALPHAI(j+1) negative. ! ! Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j) ! may easily over- or underflow, and BETA(j) may even be zero. ! Thus, the user should avoid naively computing the ratio. ! However, ALPHAR and ALPHAI will be always less than and ! usually comparable with norm(A) in magnitude, and BETA always ! less than and usually comparable with norm(B). ! ! VSL (output) REAL array, dimension (LDVSL,N) ! If JOBVSL = 'V', VSL will contain the left Schur vectors. ! Not referenced if JOBVSL = 'N'. ! ! LDVSL (input) INTEGER ! The leading dimension of the matrix VSL. LDVSL >=1, and ! if JOBVSL = 'V', LDVSL >= N. ! ! VSR (output) REAL array, dimension (LDVSR,N) ! If JOBVSR = 'V', VSR will contain the right Schur vectors. ! Not referenced if JOBVSR = 'N'. ! ! LDVSR (input) INTEGER ! The leading dimension of the matrix VSR. LDVSR >= 1, and ! if JOBVSR = 'V', LDVSR >= N. ! ! RCONDE (output) REAL array, dimension ( 2 ) ! If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the ! reciprocal condition numbers for the average of the selected ! eigenvalues. ! Not referenced if SENSE = 'N' or 'V'. ! ! RCONDV (output) REAL array, dimension ( 2 ) ! If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the ! reciprocal condition numbers for the selected deflating ! subspaces. ! Not referenced if SENSE = 'N' or 'E'. ! ! WORK (workspace/output) REAL array, dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. LWORK >= 8*(N+1)+16. ! If SENSE = 'E', 'V', or 'B', ! LWORK >= MAX( 8*(N+1)+16, 2*SDIM*(N-SDIM) ). ! ! IWORK (workspace) INTEGER array, dimension (LIWORK) ! Not referenced if SENSE = 'N'. ! ! LIWORK (input) INTEGER ! The dimension of the array WORK. LIWORK >= N+6. ! ! BWORK (workspace) LOGICAL array, dimension (N) ! Not referenced if SORT = '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. (A,B) are not in Schur ! form, but ALPHAR(j), ALPHAI(j), and BETA(j) should ! be correct for j=INFO+1,...,N. ! > N: =N+1: other than QZ iteration failed in SHGEQZ ! =N+2: after reordering, roundoff changed values of ! some complex eigenvalues so that leading ! eigenvalues in the Generalized Schur form no ! longer satisfy SELCTG=.TRUE. This could also ! be caused due to scaling. ! =N+3: reordering failed in STGSEN. ! ! Further details ! =============== ! ! An approximate (asymptotic) bound on the average absolute error of ! the selected eigenvalues is ! ! EPS * norm((A, B)) / RCONDE( 1 ). ! ! An approximate (asymptotic) bound on the maximum angular error in ! the computed deflating subspaces is ! ! EPS * norm((A, B)) / RCONDV( 2 ). ! ! See LAPACK User's Guide, section 4.11 for more information. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: cursl, ilascl, ilbscl, ilvsl, ilvsr, lastsl, & lst2sl, wantsb, wantse, wantsn, wantst, wantsv INTEGER :: i, icols, ierr, ihi, ijob, ijobvl, ijobvr, & ileft, ilo, ip, iright, irows, itau, iwrk, liwmin, maxwrk, minwrk REAL :: anrm, anrmto, bignum, bnrm, bnrmto, eps, pl, & pr, safmax, safmin, smlnum ! .. ! .. Local Arrays .. REAL :: dif( 2 ) ! .. ! .. External Subroutines .. EXTERNAL sgeqrf, sggbak, sggbal, sgghrd, shgeqz, slabad, & slacpy, slascl, slaset, sorgqr, sormqr, stgsen, xerbla ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slange EXTERNAL lsame, ilaenv, slamch, slange ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT ! .. ! .. Executable Statements .. ! ! Decode the input arguments ! IF( lsame( jobvsl, 'N' ) ) THEN ijobvl = 1 ilvsl = .false. ELSE IF( lsame( jobvsl, 'V' ) ) THEN ijobvl = 2 ilvsl = .true. ELSE ijobvl = -1 ilvsl = .false. END IF ! IF( lsame( jobvsr, 'N' ) ) THEN ijobvr = 1 ilvsr = .false. ELSE IF( lsame( jobvsr, 'V' ) ) THEN ijobvr = 2 ilvsr = .true. ELSE ijobvr = -1 ilvsr = .false. END IF ! wantst = lsame( sort, 'S' ) wantsn = lsame( sense, 'N' ) wantse = lsame( sense, 'E' ) wantsv = lsame( sense, 'V' ) wantsb = lsame( sense, 'B' ) IF( wantsn ) THEN ijob = 0 iwork( 1 ) = 1 ELSE IF( wantse ) THEN ijob = 1 ELSE IF( wantsv ) THEN ijob = 2 ELSE IF( wantsb ) THEN ijob = 4 END IF ! ! Test the input arguments ! info = 0 IF( ijobvl <= 0 ) THEN info = -1 ELSE IF( ijobvr <= 0 ) THEN info = -2 ELSE IF( ( .NOT.wantst ) .AND. ( .NOT.lsame( sort, 'N' ) ) ) THEN info = -3 ELSE IF( .NOT.( wantsn .OR. wantse .OR. wantsv .OR. wantsb ) .OR. & ( .NOT.wantst .AND. .NOT.wantsn ) ) THEN info = -5 ELSE IF( n < 0 ) THEN info = -6 ELSE IF( lda < MAX( 1, n ) ) THEN info = -8 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -10 ELSE IF( ldvsl < 1 .OR. ( ilvsl .AND. ldvsl < n ) ) THEN info = -16 ELSE IF( ldvsr < 1 .OR. ( ilvsr .AND. ldvsr < n ) ) THEN info = -18 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.) ! minwrk = 1 IF( info == 0 .AND. lwork >= 1 ) THEN minwrk = 8*( n+1 ) + 16 maxwrk = 7*( n+1 ) + n*ilaenv( 1, 'SGEQRF', ' ', n, 1, n, 0 ) + 16 IF( ilvsl ) THEN maxwrk = MAX( maxwrk, 8*( n+1 )+n* & ilaenv( 1, 'SORGQR', ' ', n, 1, n, -1 )+16 ) END IF work( 1 ) = maxwrk END IF IF( .NOT.wantsn ) THEN liwmin = 1 ELSE liwmin = n + 6 END IF iwork( 1 ) = liwmin ! IF( info == 0 .AND. lwork < minwrk ) THEN info = -22 ELSE IF( info == 0 .AND. ijob >= 1 ) THEN IF( liwork < liwmin ) info = -24 END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SGGESX', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) THEN sdim = 0 RETURN END IF ! ! Get machine constants ! eps = slamch( 'P' ) safmin = slamch( 'S' ) safmax = one / safmin CALL slabad( safmin, safmax ) smlnum = SQRT( safmin ) / eps bignum = one / smlnum ! ! Scale A if max element outside range [SMLNUM,BIGNUM] ! anrm = slange( 'M', n, n, a, lda, work ) ilascl = .false. IF( anrm > zero .AND. anrm < smlnum ) THEN anrmto = smlnum ilascl = .true. ELSE IF( anrm > bignum ) THEN anrmto = bignum ilascl = .true. END IF IF( ilascl ) CALL slascl( 'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr ) ! ! Scale B if max element outside range [SMLNUM,BIGNUM] ! bnrm = slange( 'M', n, n, b, ldb, work ) ilbscl = .false. IF( bnrm > zero .AND. bnrm < smlnum ) THEN bnrmto = smlnum ilbscl = .true. ELSE IF( bnrm > bignum ) THEN bnrmto = bignum ilbscl = .true. END IF IF( ilbscl ) CALL slascl( 'G', 0, 0, bnrm, bnrmto, n, n, b, ldb, ierr ) ! ! Permute the matrix to make it more nearly triangular ! (Workspace: need 6*N + 2*N for permutation parameters) ! ileft = 1 iright = n + 1 iwrk = iright + n CALL sggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ), & work( iright ), work( iwrk ), ierr ) ! ! Reduce B to triangular form (QR decomposition of B) ! (Workspace: need N, prefer N*NB) ! irows = ihi + 1 - ilo icols = n + 1 - ilo itau = iwrk iwrk = itau + irows CALL sgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ), & work( iwrk ), lwork+1-iwrk, ierr ) ! ! Apply the orthogonal transformation to matrix A ! (Workspace: need N, prefer N*NB) ! CALL sormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb, & work( itau ), a( ilo, ilo ), lda, work( iwrk ), lwork+1-iwrk, ierr ) ! ! Initialize VSL ! (Workspace: need N, prefer N*NB) ! IF( ilvsl ) THEN CALL slaset( 'Full', n, n, zero, one, vsl, ldvsl ) CALL slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb, & vsl( ilo+1, ilo ), ldvsl ) CALL sorgqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl, & work( itau ), work( iwrk ), lwork+1-iwrk, ierr ) END IF ! ! Initialize VSR ! IF( ilvsr ) CALL slaset( 'Full', n, n, zero, one, vsr, ldvsr ) ! ! Reduce to generalized Hessenberg form ! (Workspace: none needed) ! CALL sgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, vsl, & ldvsl, vsr, ldvsr, ierr ) ! sdim = 0 ! ! Perform QZ algorithm, computing Schur vectors if desired ! (Workspace: need N) ! iwrk = itau CALL shgeqz( 'S', jobvsl, jobvsr, n, ilo, ihi, a, lda, b, ldb, & alphar, alphai, beta, vsl, ldvsl, vsr, ldvsr, & work( iwrk ), lwork+1-iwrk, ierr ) IF( ierr /= 0 ) THEN IF( ierr > 0 .AND. ierr <= n ) THEN info = ierr ELSE IF( ierr > n .AND. ierr <= 2*n ) THEN info = ierr - n ELSE info = n + 1 END IF GO TO 50 END IF ! ! Sort eigenvalues ALPHA/BETA and compute the reciprocal of ! condition number(s) ! (Workspace: If IJOB >= 1, need MAX( 8*(N+1), 2*SDIM*(N-SDIM) ) ! otherwise, need 8*(N+1) ) ! IF( wantst ) THEN ! ! Undo scaling on eigenvalues before SELCTGing ! IF( ilascl ) THEN CALL slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) CALL slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) END IF IF( ilbscl ) CALL slascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) ! ! Select eigenvalues ! DO i = 1, n bwork( i ) = selctg( alphar( i ), alphai( i ), beta( i ) ) END DO ! ! Reorder eigenvalues, transform Generalized Schur vectors, and ! compute reciprocal condition numbers ! CALL stgsen( ijob, ilvsl, ilvsr, bwork, n, a, lda, b, ldb, & alphar, alphai, beta, vsl, ldvsl, vsr, ldvsr, & sdim, pl, pr, dif, work( iwrk ), lwork-iwrk+1, iwork, liwork, ierr ) ! IF( ijob >= 1 ) maxwrk = MAX( maxwrk, 2*sdim*( n-sdim ) ) IF( ierr == -22 ) THEN ! ! not enough real workspace ! info = -22 ELSE rconde( 1 ) = pl rconde( 2 ) = pr rcondv( 1 ) = dif( 1 ) rcondv( 2 ) = dif( 2 ) IF( ierr == 1 ) info = n + 3 END IF ! END IF ! ! Apply permutation to VSL and VSR ! (Workspace: none needed) ! IF( ilvsl ) CALL sggbak( 'P', 'L', n, ilo, ihi, work( ileft ), & work( iright ), n, vsl, ldvsl, ierr ) ! IF( ilvsr ) CALL sggbak( 'P', 'R', n, ilo, ihi, work( ileft ), & work( iright ), n, vsr, ldvsr, ierr ) ! ! Check if unscaling would cause over/underflow, if so, rescale ! (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of ! B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I) ! IF( ilascl ) THEN DO i = 1, n IF( alphai( i ) /= zero ) THEN IF( ( alphar( i ) / safmax ) > ( anrmto / anrm ) .OR. & ( safmin / alphar( i ) ) > ( anrm / anrmto ) ) THEN work( 1 ) = ABS( a( i, i ) / alphar( i ) ) beta( i ) = beta( i )*work( 1 ) alphar( i ) = alphar( i )*work( 1 ) alphai( i ) = alphai( i )*work( 1 ) ELSE IF( ( alphai( i ) / safmax ) > ( anrmto / anrm ) & .OR. ( safmin / alphai( i ) ) > ( anrm / anrmto ) ) THEN work( 1 ) = ABS( a( i, i+1 ) / alphai( i ) ) beta( i ) = beta( i )*work( 1 ) alphar( i ) = alphar( i )*work( 1 ) alphai( i ) = alphai( i )*work( 1 ) END IF END IF END DO END IF ! IF( ilbscl ) THEN DO i = 1, n IF( alphai( i ) /= zero ) THEN IF( ( beta( i ) / safmax ) > ( bnrmto / bnrm ) .OR. & ( safmin / beta( i ) ) > ( bnrm / bnrmto ) ) THEN work( 1 ) = ABS( b( i, i ) / beta( i ) ) beta( i ) = beta( i )*work( 1 ) alphar( i ) = alphar( i )*work( 1 ) alphai( i ) = alphai( i )*work( 1 ) END IF END IF END DO END IF ! ! Undo scaling ! IF( ilascl ) THEN CALL slascl( 'H', 0, 0, anrmto, anrm, n, n, a, lda, ierr ) CALL slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) CALL slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) END IF ! IF( ilbscl ) THEN CALL slascl( 'U', 0, 0, bnrmto, bnrm, n, n, b, ldb, ierr ) CALL slascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) END IF ! 30 CONTINUE ! IF( wantst ) THEN ! ! Check if reordering is correct ! lastsl = .true. lst2sl = .true. sdim = 0 ip = 0 DO i = 1, n cursl = selctg( alphar( i ), alphai( i ), beta( i ) ) IF( alphai( i ) == zero ) THEN IF( cursl ) sdim = sdim + 1 ip = 0 IF( cursl .AND. .NOT.lastsl ) info = n + 2 ELSE IF( ip == 1 ) THEN ! ! Last eigenvalue of conjugate pair ! cursl = cursl .OR. lastsl lastsl = cursl IF( cursl ) sdim = sdim + 2 ip = -1 IF( cursl .AND. .NOT.lst2sl ) info = n + 2 ELSE ! ! First eigenvalue of conjugate pair ! ip = 1 END IF END IF lst2sl = lastsl lastsl = cursl END DO ! END IF ! 50 CONTINUE ! work( 1 ) = maxwrk iwork( 1 ) = liwmin ! RETURN ! ! End of SGGESX ! END SUBROUTINE sggesx SUBROUTINE sggev( jobvl, jobvr, n, a, lda, b, ldb, alphar, alphai, & beta, vl, ldvl, vr, ldvr, 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 (LEN=1), INTENT(IN) :: jobvl CHARACTER (LEN=1), INTENT(IN) :: jobvr INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN) :: ldb REAL, INTENT(IN OUT) :: alphar( * ) REAL, INTENT(IN) :: alphai( * ) REAL, INTENT(IN OUT) :: beta( * ) REAL, INTENT(IN OUT) :: vl( ldvl, * ) INTEGER, INTENT(IN OUT) :: ldvl REAL, INTENT(IN OUT) :: vr( ldvr, * ) INTEGER, INTENT(IN OUT) :: ldvr REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGGEV computes for a pair of N-by-N real 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 eigenvector v(j) corresponding to the eigenvalue lambda(j) ! of (A,B) satisfies ! ! A * v(j) = lambda(j) * B * v(j). ! ! The left eigenvector u(j) corresponding to the eigenvalue 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) REAL 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) REAL 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). ! ! ALPHAR (output) REAL array, dimension (N) ! ALPHAI (output) REAL array, dimension (N) ! BETA (output) REAL array, dimension (N) ! On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will ! be the generalized eigenvalues. If ALPHAI(j) is zero, then ! the j-th eigenvalue is real; if positive, then the j-th and ! (j+1)-st eigenvalues are a complex conjugate pair, with ! ALPHAI(j+1) negative. ! ! Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(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, ALPHAR and ALPHAI 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) REAL array, dimension (LDVL,N) ! If JOBVL = 'V', the left eigenvectors u(j) are stored one ! after another in the columns of VL, in the same order as ! their eigenvalues. If the j-th eigenvalue is real, then ! u(j) = VL(:,j), the j-th column of VL. If the j-th and ! (j+1)-th eigenvalues form a complex conjugate pair, then ! u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). ! Each eigenvector will be scaled so the largest component 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) REAL array, dimension (LDVR,N) ! If JOBVR = 'V', the right eigenvectors v(j) are stored one ! after another in the columns of VR, in the same order as ! their eigenvalues. If the j-th eigenvalue is real, then ! v(j) = VR(:,j), the j-th column of VR. If the j-th and ! (j+1)-th eigenvalues form a complex conjugate pair, then ! v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). ! Each eigenvector will be scaled so the largest component 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) REAL 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,8*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. ! ! 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 ALPHAR(j), ALPHAI(j), and BETA(j) ! should be correct for j=INFO+1,...,N. ! > N: =N+1: other than QZ iteration failed in SHGEQZ. ! =N+2: error return from STGEVC. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery CHARACTER (LEN=1) :: chtemp INTEGER :: icols, ierr, ihi, ijobvl, ijobvr, ileft, ilo, & in, iright, irows, itau, iwrk, jc, jr, maxwrk, minwrk REAL :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp ! .. ! .. Local Arrays .. LOGICAL :: ldumma( 1 ) ! .. ! .. External Subroutines .. EXTERNAL sgeqrf, sggbak, sggbal, sgghrd, shgeqz, slabad, & slacpy, slascl, slaset, sorgqr, sormqr, stgevc, xerbla ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slange EXTERNAL lsame, ilaenv, slamch, slange ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT ! .. ! .. 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 == -1 ) IF( ijobvl <= 0 ) THEN info = -1 ELSE IF( ijobvr <= 0 ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldvl < 1 .OR. ( ilvl .AND. ldvl < n ) ) THEN info = -12 ELSE IF( ldvr < 1 .OR. ( ilvr .AND. ldvr < n ) ) THEN info = -14 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.) ! minwrk = 1 IF( info == 0 .AND. ( lwork >= 1 .OR. lquery ) ) THEN maxwrk = 7*n + n*ilaenv( 1, 'SGEQRF', ' ', n, 1, n, 0 ) minwrk = MAX( 1, 8*n ) work( 1 ) = maxwrk END IF ! IF( lwork < minwrk .AND. .NOT.lquery ) info = -16 ! IF( info /= 0 ) THEN CALL xerbla( 'SGGEV ', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Get machine constants ! eps = slamch( 'P' ) smlnum = slamch( 'S' ) bignum = one / smlnum CALL slabad( smlnum, bignum ) smlnum = SQRT( smlnum ) / eps bignum = one / smlnum ! ! Scale A if max element outside range [SMLNUM,BIGNUM] ! anrm = slange( 'M', n, n, a, lda, work ) ilascl = .false. IF( anrm > zero .AND. anrm < smlnum ) THEN anrmto = smlnum ilascl = .true. ELSE IF( anrm > bignum ) THEN anrmto = bignum ilascl = .true. END IF IF( ilascl ) CALL slascl( 'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr ) ! ! Scale B if max element outside range [SMLNUM,BIGNUM] ! bnrm = slange( 'M', n, n, b, ldb, work ) ilbscl = .false. IF( bnrm > zero .AND. bnrm < smlnum ) THEN bnrmto = smlnum ilbscl = .true. ELSE IF( bnrm > bignum ) THEN bnrmto = bignum ilbscl = .true. END IF IF( ilbscl ) CALL slascl( 'G', 0, 0, bnrm, bnrmto, n, n, b, ldb, ierr ) ! ! Permute the matrices A, B to isolate eigenvalues if possible ! (Workspace: need 6*N) ! ileft = 1 iright = n + 1 iwrk = iright + n CALL sggbal( 'P', n, a, lda, b, ldb, ilo, ihi, work( ileft ), & work( iright ), work( iwrk ), ierr ) ! ! Reduce B to triangular form (QR decomposition of B) ! (Workspace: need N, prefer N*NB) ! irows = ihi + 1 - ilo IF( ilv ) THEN icols = n + 1 - ilo ELSE icols = irows END IF itau = iwrk iwrk = itau + irows CALL sgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ), & work( iwrk ), lwork+1-iwrk, ierr ) ! ! Apply the orthogonal transformation to matrix A ! (Workspace: need N, prefer N*NB) ! CALL sormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb, & work( itau ), a( ilo, ilo ), lda, work( iwrk ), lwork+1-iwrk, ierr ) ! ! Initialize VL ! (Workspace: need N, prefer N*NB) ! IF( ilvl ) THEN CALL slaset( 'Full', n, n, zero, one, vl, ldvl ) CALL slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb, & vl( ilo+1, ilo ), ldvl ) CALL sorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl, & work( itau ), work( iwrk ), lwork+1-iwrk, ierr ) END IF ! ! Initialize VR ! IF( ilvr ) CALL slaset( 'Full', n, n, zero, one, vr, ldvr ) ! ! Reduce to generalized Hessenberg form ! (Workspace: none needed) ! IF( ilv ) THEN ! ! Eigenvectors requested -- work on whole matrix. ! CALL sgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl, & ldvl, vr, ldvr, ierr ) ELSE CALL sgghrd( '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 forms and Schur vectors) ! (Workspace: need N) ! iwrk = itau IF( ilv ) THEN chtemp = 'S' ELSE chtemp = 'E' END IF CALL shgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, & alphar, alphai, beta, vl, ldvl, vr, ldvr, work( iwrk ), lwork+1-iwrk, ierr ) IF( ierr /= 0 ) THEN IF( ierr > 0 .AND. ierr <= n ) THEN info = ierr ELSE IF( ierr > n .AND. ierr <= 2*n ) THEN info = ierr - n ELSE info = n + 1 END IF GO TO 110 END IF ! ! Compute Eigenvectors ! (Workspace: need 6*N) ! IF( ilv ) THEN IF( ilvl ) THEN IF( ilvr ) THEN chtemp = 'B' ELSE chtemp = 'L' END IF ELSE chtemp = 'R' END IF CALL stgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, ldvl, & vr, ldvr, n, in, work( iwrk ), ierr ) IF( ierr /= 0 ) THEN info = n + 2 GO TO 110 END IF ! ! Undo balancing on VL and VR and normalization ! (Workspace: none needed) ! IF( ilvl ) THEN CALL sggbak( 'P', 'L', n, ilo, ihi, work( ileft ), & work( iright ), n, vl, ldvl, ierr ) DO jc = 1, n IF( alphai( jc ) < zero ) CYCLE temp = zero IF( alphai( jc ) == zero ) THEN DO jr = 1, n temp = MAX( temp, ABS( vl( jr, jc ) ) ) END DO ELSE DO jr = 1, n temp = MAX( temp, ABS( vl( jr, jc ) )+ ABS( vl( jr, jc+1 ) ) ) END DO END IF IF( temp < smlnum ) CYCLE temp = one / temp IF( alphai( jc ) == zero ) THEN DO jr = 1, n vl( jr, jc ) = vl( jr, jc )*temp END DO ELSE DO jr = 1, n vl( jr, jc ) = vl( jr, jc )*temp vl( jr, jc+1 ) = vl( jr, jc+1 )*temp END DO END IF END DO END IF IF( ilvr ) THEN CALL sggbak( 'P', 'R', n, ilo, ihi, work( ileft ), & work( iright ), n, vr, ldvr, ierr ) DO jc = 1, n IF( alphai( jc ) < zero ) CYCLE temp = zero IF( alphai( jc ) == zero ) THEN DO jr = 1, n temp = MAX( temp, ABS( vr( jr, jc ) ) ) END DO ELSE DO jr = 1, n temp = MAX( temp, ABS( vr( jr, jc ) )+ ABS( vr( jr, jc+1 ) ) ) END DO END IF IF( temp < smlnum ) CYCLE temp = one / temp IF( alphai( jc ) == zero ) THEN DO jr = 1, n vr( jr, jc ) = vr( jr, jc )*temp END DO ELSE DO jr = 1, n vr( jr, jc ) = vr( jr, jc )*temp vr( jr, jc+1 ) = vr( jr, jc+1 )*temp END DO END IF END DO END IF ! ! End of eigenvector calculation ! END IF ! ! Undo scaling if necessary ! IF( ilascl ) THEN CALL slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) CALL slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) END IF ! IF( ilbscl ) THEN CALL slascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) END IF ! 110 CONTINUE ! work( 1 ) = maxwrk ! RETURN ! ! End of SGGEV ! END SUBROUTINE sggev SUBROUTINE sggevx( balanc, jobvl, jobvr, sense, n, a, lda, b, ldb, & alphar, alphai, beta, vl, ldvl, vr, ldvr, ilo, & ihi, lscale, rscale, abnrm, bbnrm, rconde, & rcondv, work, lwork, iwork, bwork, 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 (LEN=1), INTENT(IN) :: balanc CHARACTER (LEN=1), INTENT(IN) :: jobvl CHARACTER (LEN=1), INTENT(IN) :: jobvr CHARACTER (LEN=1), INTENT(IN) :: sense INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN) :: ldb REAL, INTENT(IN OUT) :: alphar( * ) REAL, INTENT(IN) :: alphai( * ) REAL, INTENT(IN OUT) :: beta( * ) REAL, INTENT(IN OUT) :: vl( ldvl, * ) INTEGER, INTENT(IN OUT) :: ldvl REAL, INTENT(IN OUT) :: vr( ldvr, * ) INTEGER, INTENT(IN OUT) :: ldvr INTEGER, INTENT(IN) :: ilo INTEGER, INTENT(IN) :: ihi REAL, INTENT(IN OUT) :: lscale( * ) REAL, INTENT(IN OUT) :: rscale( * ) REAL, INTENT(OUT) :: abnrm REAL, INTENT(OUT) :: bbnrm REAL, INTENT(IN OUT) :: rconde( * ) REAL, INTENT(IN OUT) :: rcondv( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(IN OUT) :: iwork( * ) LOGICAL, INTENT(OUT) :: bwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B) ! the generalized eigenvalues, and optionally, the left and/or right ! generalized eigenvectors. ! ! Optionally also, it computes a balancing transformation to improve ! the conditioning of the eigenvalues and eigenvectors (ILO, IHI, ! LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for ! the eigenvalues (RCONDE), and reciprocal condition numbers for the ! right eigenvectors (RCONDV). ! ! 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 eigenvector v(j) corresponding to the eigenvalue lambda(j) ! of (A,B) satisfies ! ! A * v(j) = lambda(j) * B * v(j) . ! ! The left eigenvector u(j) corresponding to the eigenvalue 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 ! ========= ! ! BALANC (input) CHARACTER*1 ! Specifies the balance option to be performed. ! = 'N': do not diagonally scale or permute; ! = 'P': permute only; ! = 'S': scale only; ! = 'B': both permute and scale. ! Computed reciprocal condition numbers will be for the ! matrices after permuting and/or balancing. Permuting does ! not change condition numbers (in exact arithmetic), but ! balancing does. ! ! 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. ! ! SENSE (input) CHARACTER*1 ! Determines which reciprocal condition numbers are computed. ! = 'N': none are computed; ! = 'E': computed for eigenvalues only; ! = 'V': computed for eigenvectors only; ! = 'B': computed for eigenvalues and eigenvectors. ! ! N (input) INTEGER ! The order of the matrices A, B, VL, and VR. N >= 0. ! ! A (input/output) REAL array, dimension (LDA, N) ! On entry, the matrix A in the pair (A,B). ! On exit, A has been overwritten. If JOBVL='V' or JOBVR='V' ! or both, then A contains the first part of the real Schur ! form of the "balanced" versions of the input A and B. ! ! LDA (input) INTEGER ! The leading dimension of A. LDA >= max(1,N). ! ! B (input/output) REAL array, dimension (LDB, N) ! On entry, the matrix B in the pair (A,B). ! On exit, B has been overwritten. If JOBVL='V' or JOBVR='V' ! or both, then B contains the second part of the real Schur ! form of the "balanced" versions of the input A and B. ! ! LDB (input) INTEGER ! The leading dimension of B. LDB >= max(1,N). ! ! ALPHAR (output) REAL array, dimension (N) ! ALPHAI (output) REAL array, dimension (N) ! BETA (output) REAL array, dimension (N) ! On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will ! be the generalized eigenvalues. If ALPHAI(j) is zero, then ! the j-th eigenvalue is real; if positive, then the j-th and ! (j+1)-st eigenvalues are a complex conjugate pair, with ! ALPHAI(j+1) negative. ! ! Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(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, ALPHAR and ALPHAI 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) REAL array, dimension (LDVL,N) ! If JOBVL = 'V', the left eigenvectors u(j) are stored one ! after another in the columns of VL, in the same order as ! their eigenvalues. If the j-th eigenvalue is real, then ! u(j) = VL(:,j), the j-th column of VL. If the j-th and ! (j+1)-th eigenvalues form a complex conjugate pair, then ! u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1). ! Each eigenvector will be scaled so the largest component 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) REAL array, dimension (LDVR,N) ! If JOBVR = 'V', the right eigenvectors v(j) are stored one ! after another in the columns of VR, in the same order as ! their eigenvalues. If the j-th eigenvalue is real, then ! v(j) = VR(:,j), the j-th column of VR. If the j-th and ! (j+1)-th eigenvalues form a complex conjugate pair, then ! v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1). ! Each eigenvector will be scaled so the largest component 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. ! ! ILO,IHI (output) INTEGER ! ILO and IHI are integer values 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 BALANC = 'N' or 'S', ILO = 1 and IHI = N. ! ! LSCALE (output) REAL array, dimension (N) ! Details of the permutations and scaling factors applied ! to the left side of A and B. If PL(j) is the index of the ! row interchanged with row j, and DL(j) is the scaling ! factor applied to row j, then ! LSCALE(j) = PL(j) for j = 1,...,ILO-1 ! = DL(j) for j = ILO,...,IHI ! = PL(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) REAL array, dimension (N) ! Details of the permutations and scaling factors applied ! to the right side of A and B. If PR(j) is the index of the ! column interchanged with column j, and DR(j) is the scaling ! factor applied to column j, then ! RSCALE(j) = PR(j) for j = 1,...,ILO-1 ! = DR(j) for j = ILO,...,IHI ! = PR(j) for j = IHI+1,...,N ! The order in which the interchanges are made is N to IHI+1, ! then 1 to ILO-1. ! ! ABNRM (output) REAL ! The one-norm of the balanced matrix A. ! ! BBNRM (output) REAL ! The one-norm of the balanced matrix B. ! ! RCONDE (output) REAL array, dimension (N) ! If SENSE = 'E' or 'B', the reciprocal condition numbers of ! the selected eigenvalues, stored in consecutive elements of ! the array. For a complex conjugate pair of eigenvalues two ! consecutive elements of RCONDE are set to the same value. ! Thus RCONDE(j), RCONDV(j), and the j-th columns of VL and VR ! all correspond to the same eigenpair (but not in general the ! j-th eigenpair, unless all eigenpairs are selected). ! If SENSE = 'V', RCONDE is not referenced. ! ! RCONDV (output) REAL array, dimension (N) ! If SENSE = 'V' or 'B', the estimated reciprocal condition ! numbers of the selected eigenvectors, stored in consecutive ! elements of the array. For a complex eigenvector two ! consecutive elements of RCONDV are set to the same value. If ! the eigenvalues cannot be reordered to compute RCONDV(j), ! RCONDV(j) is set to 0; this can only occur when the true ! value would be very small anyway. ! If SENSE = 'E', RCONDV is not referenced. ! ! WORK (workspace/output) REAL 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,6*N). ! If SENSE = 'E', LWORK >= 12*N. ! If SENSE = 'V' or 'B', LWORK >= 2*N*N+12*N+16. ! ! 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 (N+6) ! If SENSE = 'E', IWORK is not referenced. ! ! BWORK (workspace) LOGICAL array, dimension (N) ! If SENSE = 'N', BWORK is not referenced. ! ! 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 ALPHAR(j), ALPHAI(j), and BETA(j) ! should be correct for j=INFO+1,...,N. ! > N: =N+1: other than QZ iteration failed in SHGEQZ. ! =N+2: error return from STGEVC. ! ! Further Details ! =============== ! ! Balancing a matrix pair (A,B) includes, first, permuting rows and ! columns to isolate eigenvalues, second, applying diagonal similarity ! transformation to the rows and columns to make the rows and columns ! as close in norm as possible. The computed reciprocal condition ! numbers correspond to the balanced matrix. Permuting rows and columns ! will not change the condition numbers (in exact arithmetic) but ! diagonal scaling will. For further explanation of balancing, see ! section 4.11.1.2 of LAPACK Users' Guide. ! ! An approximate error bound on the chordal distance between the i-th ! computed generalized eigenvalue w and the corresponding exact ! eigenvalue lambda is ! ! chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I) ! ! An approximate error bound for the angle between the i-th computed ! eigenvector VL(i) or VR(i) is given by ! ! EPS * norm(ABNRM, BBNRM) / DIF(i). ! ! For further explanation of the reciprocal condition numbers RCONDE ! and RCONDV, see section 4.11 of LAPACK User's Guide. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: ilascl, ilbscl, ilv, ilvl, ilvr, lquery, pair, & wantsb, wantse, wantsn, wantsv CHARACTER (LEN=1) :: chtemp INTEGER :: i, icols, ierr, ijobvl, ijobvr, in, irows, & itau, iwrk, iwrk1, j, jc, jr, m, maxwrk, minwrk, mm REAL :: anrm, anrmto, bignum, bnrm, bnrmto, eps, smlnum, temp ! .. ! .. Local Arrays .. LOGICAL :: ldumma( 1 ) ! .. ! .. External Subroutines .. EXTERNAL sgeqrf, sggbak, sggbal, sgghrd, shgeqz, slabad, & slacpy, slascl, slaset, sorgqr, sormqr, stgevc, stgsna, xerbla ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slange EXTERNAL lsame, ilaenv, slamch, slange ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT ! .. ! .. 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 ! wantsn = lsame( sense, 'N' ) wantse = lsame( sense, 'E' ) wantsv = lsame( sense, 'V' ) wantsb = lsame( sense, 'B' ) ! ! Test the input arguments ! info = 0 lquery = ( lwork == -1 ) IF( .NOT.( lsame( balanc, 'N' ) .OR. lsame( balanc, & 'S' ) .OR. lsame( balanc, 'P' ) .OR. lsame( balanc, 'B' ) ) ) THEN info = -1 ELSE IF( ijobvl <= 0 ) THEN info = -2 ELSE IF( ijobvr <= 0 ) THEN info = -3 ELSE IF( .NOT.( wantsn .OR. wantse .OR. wantsb .OR. wantsv ) ) & THEN info = -4 ELSE IF( n < 0 ) THEN info = -5 ELSE IF( lda < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -9 ELSE IF( ldvl < 1 .OR. ( ilvl .AND. ldvl < n ) ) THEN info = -14 ELSE IF( ldvr < 1 .OR. ( ilvr .AND. ldvr < n ) ) THEN info = -16 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.) ! minwrk = 1 IF( info == 0 .AND. ( lwork >= 1 .OR. lquery ) ) THEN maxwrk = 5*n + n*ilaenv( 1, 'SGEQRF', ' ', n, 1, n, 0 ) minwrk = MAX( 1, 6*n ) IF( wantse ) THEN minwrk = MAX( 1, 12*n ) ELSE IF( wantsv .OR. wantsb ) THEN minwrk = 2*n*n + 12*n + 16 maxwrk = MAX( maxwrk, 2*n*n+12*n+16 ) END IF work( 1 ) = maxwrk END IF ! IF( lwork < minwrk .AND. .NOT.lquery ) THEN info = -26 END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SGGEVX', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! ! Get machine constants ! eps = slamch( 'P' ) smlnum = slamch( 'S' ) bignum = one / smlnum CALL slabad( smlnum, bignum ) smlnum = SQRT( smlnum ) / eps bignum = one / smlnum ! ! Scale A if max element outside range [SMLNUM,BIGNUM] ! anrm = slange( 'M', n, n, a, lda, work ) ilascl = .false. IF( anrm > zero .AND. anrm < smlnum ) THEN anrmto = smlnum ilascl = .true. ELSE IF( anrm > bignum ) THEN anrmto = bignum ilascl = .true. END IF IF( ilascl ) CALL slascl( 'G', 0, 0, anrm, anrmto, n, n, a, lda, ierr ) ! ! Scale B if max element outside range [SMLNUM,BIGNUM] ! bnrm = slange( 'M', n, n, b, ldb, work ) ilbscl = .false. IF( bnrm > zero .AND. bnrm < smlnum ) THEN bnrmto = smlnum ilbscl = .true. ELSE IF( bnrm > bignum ) THEN bnrmto = bignum ilbscl = .true. END IF IF( ilbscl ) CALL slascl( 'G', 0, 0, bnrm, bnrmto, n, n, b, ldb, ierr ) ! ! Permute and/or balance the matrix pair (A,B) ! (Workspace: need 6*N) ! CALL sggbal( balanc, n, a, lda, b, ldb, ilo, ihi, lscale, rscale, work, ierr ) ! ! Compute ABNRM and BBNRM ! abnrm = slange( '1', n, n, a, lda, work( 1 ) ) IF( ilascl ) THEN work( 1 ) = abnrm CALL slascl( 'G', 0, 0, anrmto, anrm, 1, 1, work( 1 ), 1, ierr ) abnrm = work( 1 ) END IF ! bbnrm = slange( '1', n, n, b, ldb, work( 1 ) ) IF( ilbscl ) THEN work( 1 ) = bbnrm CALL slascl( 'G', 0, 0, bnrmto, bnrm, 1, 1, work( 1 ), 1, ierr ) bbnrm = work( 1 ) END IF ! ! Reduce B to triangular form (QR decomposition of B) ! (Workspace: need N, prefer N*NB ) ! irows = ihi + 1 - ilo IF( ilv .OR. .NOT.wantsn ) THEN icols = n + 1 - ilo ELSE icols = irows END IF itau = 1 iwrk = itau + irows CALL sgeqrf( irows, icols, b( ilo, ilo ), ldb, work( itau ), & work( iwrk ), lwork+1-iwrk, ierr ) ! ! Apply the orthogonal transformation to A ! (Workspace: need N, prefer N*NB) ! CALL sormqr( 'L', 'T', irows, icols, irows, b( ilo, ilo ), ldb, & work( itau ), a( ilo, ilo ), lda, work( iwrk ), lwork+1-iwrk, ierr ) ! ! Initialize VL and/or VR ! (Workspace: need N, prefer N*NB) ! IF( ilvl ) THEN CALL slaset( 'Full', n, n, zero, one, vl, ldvl ) CALL slacpy( 'L', irows-1, irows-1, b( ilo+1, ilo ), ldb, & vl( ilo+1, ilo ), ldvl ) CALL sorgqr( irows, irows, irows, vl( ilo, ilo ), ldvl, & work( itau ), work( iwrk ), lwork+1-iwrk, ierr ) END IF ! IF( ilvr ) CALL slaset( 'Full', n, n, zero, one, vr, ldvr ) ! ! Reduce to generalized Hessenberg form ! (Workspace: none needed) ! IF( ilv .OR. .NOT.wantsn ) THEN ! ! Eigenvectors requested -- work on whole matrix. ! CALL sgghrd( jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, vl, & ldvl, vr, ldvr, ierr ) ELSE CALL sgghrd( '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 forms and Schur vectors) ! (Workspace: need N) ! IF( ilv .OR. .NOT.wantsn ) THEN chtemp = 'S' ELSE chtemp = 'E' END IF ! CALL shgeqz( chtemp, jobvl, jobvr, n, ilo, ihi, a, lda, b, ldb, & alphar, alphai, beta, vl, ldvl, vr, ldvr, work, lwork, ierr ) IF( ierr /= 0 ) THEN IF( ierr > 0 .AND. ierr <= n ) THEN info = ierr ELSE IF( ierr > n .AND. ierr <= 2*n ) THEN info = ierr - n ELSE info = n + 1 END IF GO TO 130 END IF ! ! Compute Eigenvectors and estimate condition numbers if desired ! (Workspace: STGEVC: need 6*N ! STGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B', ! need N otherwise ) ! IF( ilv .OR. .NOT.wantsn ) THEN IF( ilv ) THEN IF( ilvl ) THEN IF( ilvr ) THEN chtemp = 'B' ELSE chtemp = 'L' END IF ELSE chtemp = 'R' END IF ! CALL stgevc( chtemp, 'B', ldumma, n, a, lda, b, ldb, vl, & ldvl, vr, ldvr, n, in, work, ierr ) IF( ierr /= 0 ) THEN info = n + 2 GO TO 130 END IF END IF ! IF( .NOT.wantsn ) THEN ! ! compute eigenvectors (STGEVC) and estimate condition ! numbers (STGSNA). Note that the definition of the condition ! number is not invariant under transformation (u,v) to ! (Q*u, Z*v), where (u,v) are eigenvectors of the generalized ! Schur form (S,T), Q and Z are orthogonal matrices. In order ! to avoid using extra 2*N*N workspace, we have to recalculate ! eigenvectors and estimate one condition numbers at a time. ! pair = .false. DO i = 1, n ! IF( pair ) THEN pair = .false. CYCLE END IF mm = 1 IF( i < n ) THEN IF( a( i+1, i ) /= zero ) THEN pair = .true. mm = 2 END IF END IF ! DO j = 1, n bwork( j ) = .false. END DO IF( mm == 1 ) THEN bwork( i ) = .true. ELSE IF( mm == 2 ) THEN bwork( i ) = .true. bwork( i+1 ) = .true. END IF ! iwrk = mm*n + 1 iwrk1 = iwrk + mm*n ! ! Compute a pair of left and right eigenvectors. ! (compute workspace: need up to 4*N + 6*N) ! IF( wantse .OR. wantsb ) THEN CALL stgevc( 'B', 'S', bwork, n, a, lda, b, ldb, & work( 1 ), n, work( iwrk ), n, mm, m, work( iwrk1 ), ierr ) IF( ierr /= 0 ) THEN info = n + 2 GO TO 130 END IF END IF ! CALL stgsna( sense, 'S', bwork, n, a, lda, b, ldb, & work( 1 ), n, work( iwrk ), n, rconde( i ), & rcondv( i ), mm, m, work( iwrk1 ), lwork-iwrk1+1, iwork, ierr ) ! END DO END IF END IF ! ! Undo balancing on VL and VR and normalization ! (Workspace: none needed) ! IF( ilvl ) THEN CALL sggbak( balanc, 'L', n, ilo, ihi, lscale, rscale, n, vl, ldvl, ierr ) ! DO jc = 1, n IF( alphai( jc ) < zero ) CYCLE temp = zero IF( alphai( jc ) == zero ) THEN DO jr = 1, n temp = MAX( temp, ABS( vl( jr, jc ) ) ) END DO ELSE DO jr = 1, n temp = MAX( temp, ABS( vl( jr, jc ) )+ ABS( vl( jr, jc+1 ) ) ) END DO END IF IF( temp < smlnum ) CYCLE temp = one / temp IF( alphai( jc ) == zero ) THEN DO jr = 1, n vl( jr, jc ) = vl( jr, jc )*temp END DO ELSE DO jr = 1, n vl( jr, jc ) = vl( jr, jc )*temp vl( jr, jc+1 ) = vl( jr, jc+1 )*temp END DO END IF END DO END IF IF( ilvr ) THEN CALL sggbak( balanc, 'R', n, ilo, ihi, lscale, rscale, n, vr, ldvr, ierr ) DO jc = 1, n IF( alphai( jc ) < zero ) CYCLE temp = zero IF( alphai( jc ) == zero ) THEN DO jr = 1, n temp = MAX( temp, ABS( vr( jr, jc ) ) ) END DO ELSE DO jr = 1, n temp = MAX( temp, ABS( vr( jr, jc ) )+ ABS( vr( jr, jc+1 ) ) ) END DO END IF IF( temp < smlnum ) CYCLE temp = one / temp IF( alphai( jc ) == zero ) THEN DO jr = 1, n vr( jr, jc ) = vr( jr, jc )*temp END DO ELSE DO jr = 1, n vr( jr, jc ) = vr( jr, jc )*temp vr( jr, jc+1 ) = vr( jr, jc+1 )*temp END DO END IF END DO END IF ! ! Undo scaling if necessary ! IF( ilascl ) THEN CALL slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphar, n, ierr ) CALL slascl( 'G', 0, 0, anrmto, anrm, n, 1, alphai, n, ierr ) END IF ! IF( ilbscl ) THEN CALL slascl( 'G', 0, 0, bnrmto, bnrm, n, 1, beta, n, ierr ) END IF ! 130 CONTINUE work( 1 ) = maxwrk ! RETURN ! ! End of SGGEVX ! END SUBROUTINE sggevx SUBROUTINE sggglm( n, m, p, a, lda, b, ldb, d, x, y, 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 .. INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: p REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(IN OUT) :: x( * ) REAL, INTENT(OUT) :: y( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGGGLM solves a general Gauss-Markov linear model (GLM) problem: ! ! minimize || y ||_2 subject to d = A*x + B*y ! x ! ! where A is an N-by-M matrix, B is an N-by-P matrix, and d is a ! given N-vector. It is assumed that M <= N <= M+P, and ! ! rank(A) = M and rank( A B ) = N. ! ! Under these assumptions, the constrained equation is always ! consistent, and there is a unique solution x and a minimal 2-norm ! solution y, which is obtained using a generalized QR factorization ! of A and B. ! ! In particular, if matrix B is square nonsingular, then the problem ! GLM is equivalent to the following weighted linear least squares ! problem ! ! minimize || inv(B)*(d-A*x) ||_2 ! x ! ! where inv(B) denotes the inverse of B. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The number of rows of the matrices A and B. N >= 0. ! ! M (input) INTEGER ! The number of columns of the matrix A. 0 <= M <= N. ! ! P (input) INTEGER ! The number of columns of the matrix B. P >= N-M. ! ! A (input/output) REAL array, dimension (LDA,M) ! On entry, the N-by-M matrix A. ! On exit, A is destroyed. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! B (input/output) REAL array, dimension (LDB,P) ! On entry, the N-by-P matrix B. ! On exit, B is destroyed. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! D (input/output) REAL array, dimension (N) ! On entry, D is the left hand side of the GLM equation. ! On exit, D is destroyed. ! ! X (output) REAL array, dimension (M) ! Y (output) REAL array, dimension (P) ! On exit, X and Y are the solutions of the GLM problem. ! ! WORK (workspace/output) REAL 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+M+P). ! For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB, ! where NB is an upper bound for the optimal blocksizes for ! SGEQRF, SGERQF, SORMQR and SORMRQ. ! ! 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 .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: i, lopt, lwkopt, nb, nb1, nb2, nb3, nb4, np ! .. ! .. External Subroutines .. EXTERNAL scopy, sgemv, sggqrf, sormqr, sormrq, strsv, xerbla ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters ! info = 0 np = MIN( n, p ) nb1 = ilaenv( 1, 'SGEQRF', ' ', n, m, -1, -1 ) nb2 = ilaenv( 1, 'SGERQF', ' ', n, m, -1, -1 ) nb3 = ilaenv( 1, 'SORMQR', ' ', n, m, p, -1 ) nb4 = ilaenv( 1, 'SORMRQ', ' ', n, m, p, -1 ) nb = MAX( nb1, nb2, nb3, nb4 ) lwkopt = m + np + MAX( n, p )*nb work( 1 ) = lwkopt lquery = ( lwork == -1 ) IF( n < 0 ) THEN info = -1 ELSE IF( m < 0 .OR. m > n ) THEN info = -2 ELSE IF( p < 0 .OR. p < n-m ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -7 ELSE IF( lwork < MAX( 1, n+m+p ) .AND. .NOT.lquery ) THEN info = -12 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGGGLM', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Compute the GQR factorization of matrices A and B: ! ! Q'*A = ( R11 ) M, Q'*B*Z' = ( T11 T12 ) M ! ( 0 ) N-M ( 0 T22 ) N-M ! M M+P-N N-M ! ! where R11 and T22 are upper triangular, and Q and Z are ! orthogonal. ! CALL sggqrf( n, m, p, a, lda, work, b, ldb, work( m+1 ), & work( m+np+1 ), lwork-m-np, info ) lopt = work( m+np+1 ) ! ! Update left-hand-side vector d = Q'*d = ( d1 ) M ! ( d2 ) N-M ! CALL sormqr( 'Left', 'Transpose', n, 1, m, a, lda, work, d, & MAX( 1, n ), work( m+np+1 ), lwork-m-np, info ) lopt = MAX( lopt, INT( work( m+np+1 ) ) ) ! ! Solve T22*y2 = d2 for y2 ! CALL strsv( 'Upper', 'No transpose', 'Non unit', n-m, & b( m+1, m+p-n+1 ), ldb, d( m+1 ), 1 ) CALL scopy( n-m, d( m+1 ), 1, y( m+p-n+1 ), 1 ) ! ! Set y1 = 0 ! DO i = 1, m + p - n y( i ) = zero END DO ! ! Update d1 = d1 - T12*y2 ! CALL sgemv( 'No transpose', m, n-m, -one, b( 1, m+p-n+1 ), ldb, & y( m+p-n+1 ), 1, one, d, 1 ) ! ! Solve triangular system: R11*x = d1 ! CALL strsv( 'Upper', 'No Transpose', 'Non unit', m, a, lda, d, 1 ) ! ! Copy D to X ! CALL scopy( m, d, 1, x, 1 ) ! ! Backward transformation y = Z'*y ! CALL sormrq( 'Left', 'Transpose', p, 1, np, & b( MAX( 1, n-p+1 ), 1 ), ldb, work( m+1 ), y, & MAX( 1, p ), work( m+np+1 ), lwork-m-np, info ) work( 1 ) = m + np + MAX( lopt, INT( work( m+np+1 ) ) ) ! RETURN ! ! End of SGGGLM ! END SUBROUTINE sggglm SUBROUTINE sgghrd( 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 (LEN=1), INTENT(IN) :: compq CHARACTER (LEN=1), INTENT(IN) :: compz INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: ilo INTEGER, INTENT(IN) :: ihi REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq REAL, INTENT(IN OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGGHRD reduces a pair of real matrices (A,B) to generalized upper ! Hessenberg form using orthogonal 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 orthogonal, and ' means transpose. ! ! The orthogonal 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 ! orthogonal matrix Q is returned; ! = 'V': Q must contain an orthogonal matrix Q1 on entry, ! and the product Q1*Q is returned. ! ! COMPZ (input) CHARACTER*1 ! = 'N': do not compute Z; ! = 'I': Z is initialized to the unit matrix, and the ! orthogonal matrix Z is returned; ! = 'V': Z must contain an orthogonal matrix Z1 on entry, ! and the product Z1*Z 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 SGGBAL; 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) REAL 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) REAL 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) REAL 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 orthogonal 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 an orthogonal 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) REAL 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 orthogonal 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 an orthogonal 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 .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: ilq, ilz INTEGER :: icompq, icompz, jcol, jrow REAL :: c, s, temp ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL slartg, slaset, srot, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC 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 <= 0 ) THEN info = -1 ELSE IF( icompz <= 0 ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( ilo < 1 ) THEN info = -4 ELSE IF( ihi > n .OR. ihi < ilo-1 ) THEN info = -5 ELSE IF( lda < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -9 ELSE IF( ( ilq .AND. ldq < n ) .OR. ldq < 1 ) THEN info = -11 ELSE IF( ( ilz .AND. ldz < n ) .OR. ldz < 1 ) THEN info = -13 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGGHRD', -info ) RETURN END IF ! ! Initialize Q and Z if desired. ! IF( icompq == 3 ) CALL slaset( 'Full', n, n, zero, one, q, ldq ) IF( icompz == 3 ) CALL slaset( 'Full', n, n, zero, one, z, ldz ) ! ! Quick return if possible ! IF( n <= 1 ) RETURN ! ! Zero out lower triangle of B ! DO jcol = 1, n - 1 DO jrow = jcol + 1, n b( jrow, jcol ) = zero END DO END DO ! ! Reduce A and B ! DO jcol = ilo, ihi - 2 ! DO jrow = ihi, jcol + 2, -1 ! ! Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL) ! temp = a( jrow-1, jcol ) CALL slartg( temp, a( jrow, jcol ), c, s, a( jrow-1, jcol ) ) a( jrow, jcol ) = zero CALL srot( n-jcol, a( jrow-1, jcol+1 ), lda, & a( jrow, jcol+1 ), lda, c, s ) CALL srot( n+2-jrow, b( jrow-1, jrow-1 ), ldb, & b( jrow, jrow-1 ), ldb, c, s ) IF( ilq ) CALL srot( n, q( 1, jrow-1 ), 1, q( 1, jrow ), 1, c, s ) ! ! Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1) ! temp = b( jrow, jrow ) CALL slartg( temp, b( jrow, jrow-1 ), c, s, b( jrow, jrow ) ) b( jrow, jrow-1 ) = zero CALL srot( ihi, a( 1, jrow ), 1, a( 1, jrow-1 ), 1, c, s ) CALL srot( jrow-1, b( 1, jrow ), 1, b( 1, jrow-1 ), 1, c, s ) IF( ilz ) CALL srot( n, z( 1, jrow ), 1, z( 1, jrow-1 ), 1, c, s ) END DO END DO ! RETURN ! ! End of SGGHRD ! END SUBROUTINE sgghrd SUBROUTINE sgglse( m, n, p, a, lda, b, ldb, c, d, x, 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 .. INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: p REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: c( * ) REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(IN OUT) :: x( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGGLSE solves the linear equality-constrained least squares (LSE) ! problem: ! ! minimize || c - A*x ||_2 subject to B*x = d ! ! where A is an M-by-N matrix, B is a P-by-N matrix, c is a given ! M-vector, and d is a given P-vector. It is assumed that ! P <= N <= M+P, and ! ! rank(B) = P and rank( ( A ) ) = N. ! ( ( B ) ) ! ! These conditions ensure that the LSE problem has a unique solution, ! which is obtained using a GRQ factorization of the matrices B and A. ! ! Arguments ! ========= ! ! M (input) INTEGER ! The number of rows of the matrix A. M >= 0. ! ! N (input) INTEGER ! The number of columns of the matrices A and B. N >= 0. ! ! P (input) INTEGER ! The number of rows of the matrix B. 0 <= P <= N <= M+P. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the M-by-N matrix A. ! On exit, A is destroyed. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! B (input/output) REAL array, dimension (LDB,N) ! On entry, the P-by-N matrix B. ! On exit, B is destroyed. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,P). ! ! C (input/output) REAL array, dimension (M) ! On entry, C contains the right hand side vector for the ! least squares part of the LSE problem. ! On exit, the residual sum of squares for the solution ! is given by the sum of squares of elements N-P+1 to M of ! vector C. ! ! D (input/output) REAL array, dimension (P) ! On entry, D contains the right hand side vector for the ! constrained equation. ! On exit, D is destroyed. ! ! X (output) REAL array, dimension (N) ! On exit, X is the solution of the LSE problem. ! ! WORK (workspace/output) REAL 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+N+P). ! For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB, ! where NB is an upper bound for the optimal blocksizes for ! SGEQRF, SGERQF, SORMQR and SORMRQ. ! ! 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: lopt, lwkopt, mn, nb, nb1, nb2, nb3, nb4, nr ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, sgemv, sggrqf, sormqr, sormrq, & strmv, strsv, xerbla ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters ! info = 0 mn = MIN( m, n ) nb1 = ilaenv( 1, 'SGEQRF', ' ', m, n, -1, -1 ) nb2 = ilaenv( 1, 'SGERQF', ' ', m, n, -1, -1 ) nb3 = ilaenv( 1, 'SORMQR', ' ', m, n, p, -1 ) nb4 = ilaenv( 1, 'SORMRQ', ' ', m, n, p, -1 ) nb = MAX( nb1, nb2, nb3, nb4 ) lwkopt = p + mn + MAX( m, n )*nb work( 1 ) = lwkopt lquery = ( lwork == -1 ) IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( p < 0 .OR. p > n .OR. p < n-m ) THEN info = -3 ELSE IF( lda < MAX( 1, m ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, p ) ) THEN info = -7 ELSE IF( lwork < MAX( 1, m+n+p ) .AND. .NOT.lquery ) THEN info = -12 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGGLSE', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Compute the GRQ factorization of matrices B and A: ! ! B*Q' = ( 0 T12 ) P Z'*A*Q' = ( R11 R12 ) N-P ! N-P P ( 0 R22 ) M+P-N ! N-P P ! ! where T12 and R11 are upper triangular, and Q and Z are ! orthogonal. ! CALL sggrqf( p, m, n, b, ldb, work, a, lda, work( p+1 ), & work( p+mn+1 ), lwork-p-mn, info ) lopt = work( p+mn+1 ) ! ! Update c = Z'*c = ( c1 ) N-P ! ( c2 ) M+P-N ! CALL sormqr( 'Left', 'Transpose', m, 1, mn, a, lda, work( p+1 ), & c, MAX( 1, m ), work( p+mn+1 ), lwork-p-mn, info ) lopt = MAX( lopt, INT( work( p+mn+1 ) ) ) ! ! Solve T12*x2 = d for x2 ! CALL strsv( 'Upper', 'No transpose', 'Non unit', p, b( 1, n-p+1 ), ldb, d, 1 ) ! ! Update c1 ! CALL sgemv( 'No transpose', n-p, p, -one, a( 1, n-p+1 ), lda, d, & 1, one, c, 1 ) ! ! Sovle R11*x1 = c1 for x1 ! CALL strsv( 'Upper', 'No transpose', 'Non unit', n-p, a, lda, c, 1 ) ! ! Put the solutions in X ! CALL scopy( n-p, c, 1, x, 1 ) CALL scopy( p, d, 1, x( n-p+1 ), 1 ) ! ! Compute the residual vector: ! IF( m < n ) THEN nr = m + p - n CALL sgemv( 'No transpose', nr, n-m, -one, a( n-p+1, m+1 ), & lda, d( nr+1 ), 1, one, c( n-p+1 ), 1 ) ELSE nr = p END IF CALL strmv( 'Upper', 'No transpose', 'Non unit', nr, & a( n-p+1, n-p+1 ), lda, d, 1 ) CALL saxpy( nr, -one, d, 1, c( n-p+1 ), 1 ) ! ! Backward transformation x = Q'*x ! CALL sormrq( 'Left', 'Transpose', n, 1, p, b, ldb, work( 1 ), x, & n, work( p+mn+1 ), lwork-p-mn, info ) work( 1 ) = p + mn + MAX( lopt, INT( work( p+mn+1 ) ) ) ! RETURN ! ! End of SGGLSE ! END SUBROUTINE sgglse SUBROUTINE sggqrf( n, m, p, a, lda, taua, b, ldb, taub, 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, INTENT(IN) :: n INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: p REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: taua( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: taub( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGGQRF computes a generalized QR factorization of an N-by-M matrix A ! and an N-by-P matrix B: ! ! A = Q*R, B = Q*T*Z, ! ! where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal ! matrix, and R and T assume one of the forms: ! ! if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N, ! ( 0 ) N-M N M-N ! M ! ! where R11 is upper triangular, and ! ! if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P, ! P-N N ( T21 ) P ! P ! ! where T12 or T21 is upper triangular. ! ! In particular, if B is square and nonsingular, the GQR factorization ! of A and B implicitly gives the QR factorization of inv(B)*A: ! ! inv(B)*A = Z'*(inv(T)*R) ! ! where inv(B) denotes the inverse of the matrix B, and Z' denotes the ! transpose of the matrix Z. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The number of rows of the matrices A and B. N >= 0. ! ! M (input) INTEGER ! The number of columns of the matrix A. M >= 0. ! ! P (input) INTEGER ! The number of columns of the matrix B. P >= 0. ! ! A (input/output) REAL array, dimension (LDA,M) ! On entry, the N-by-M matrix A. ! On exit, the elements on and above the diagonal of the array ! contain the min(N,M)-by-M upper trapezoidal matrix R (R is ! upper triangular if N >= M); the elements below the diagonal, ! with the array TAUA, represent the orthogonal matrix Q as a ! product of min(N,M) elementary reflectors (see Further ! Details). ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! TAUA (output) REAL array, dimension (min(N,M)) ! The scalar factors of the elementary reflectors which ! represent the orthogonal matrix Q (see Further Details). ! ! B (input/output) REAL array, dimension (LDB,P) ! On entry, the N-by-P matrix B. ! On exit, if N <= P, the upper triangle of the subarray ! B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T; ! if N > P, the elements on and above the (N-P)-th subdiagonal ! contain the N-by-P upper trapezoidal matrix T; the remaining ! elements, with the array TAUB, represent the orthogonal ! matrix Z as a product of elementary reflectors (see Further ! Details). ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! TAUB (output) REAL array, dimension (min(N,P)) ! The scalar factors of the elementary reflectors which ! represent the orthogonal matrix Z (see Further Details). ! ! WORK (workspace/output) REAL 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,M,P). ! For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), ! where NB1 is the optimal blocksize for the QR factorization ! of an N-by-M matrix, NB2 is the optimal blocksize for the ! RQ factorization of an N-by-P matrix, and NB3 is the optimal ! blocksize for a call of SORMQR. ! ! 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(n,m). ! ! Each H(i) has the form ! ! H(i) = I - taua * v * v' ! ! where taua is a real scalar, and v is a real vector with ! v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), ! and taua in TAUA(i). ! To form Q explicitly, use LAPACK subroutine SORGQR. ! To use Q to update another matrix, use LAPACK subroutine SORMQR. ! ! The matrix Z is represented as a product of elementary reflectors ! ! Z = H(1) H(2) . . . H(k), where k = min(n,p). ! ! Each H(i) has the form ! ! H(i) = I - taub * v * v' ! ! where taub is a real scalar, and v is a real vector with ! v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in ! B(n-k+i,1:p-k+i-1), and taub in TAUB(i). ! To form Z explicitly, use LAPACK subroutine SORGRQ. ! To use Z to update another matrix, use LAPACK subroutine SORMRQ. ! ! ===================================================================== ! ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: lopt, lwkopt, nb, nb1, nb2, nb3 ! .. ! .. External Subroutines .. EXTERNAL sgeqrf, sgerqf, sormqr, xerbla ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters ! info = 0 nb1 = ilaenv( 1, 'SGEQRF', ' ', n, m, -1, -1 ) nb2 = ilaenv( 1, 'SGERQF', ' ', n, p, -1, -1 ) nb3 = ilaenv( 1, 'SORMQR', ' ', n, m, p, -1 ) nb = MAX( nb1, nb2, nb3 ) lwkopt = MAX( n, m, p )*nb work( 1 ) = lwkopt lquery = ( lwork == -1 ) IF( n < 0 ) THEN info = -1 ELSE IF( m < 0 ) THEN info = -2 ELSE IF( p < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -8 ELSE IF( lwork < MAX( 1, n, m, p ) .AND. .NOT.lquery ) THEN info = -11 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGGQRF', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! QR factorization of N-by-M matrix A: A = Q*R ! CALL sgeqrf( n, m, a, lda, taua, work, lwork, info ) lopt = work( 1 ) ! ! Update B := Q'*B. ! CALL sormqr( 'Left', 'Transpose', n, p, MIN( n, m ), a, lda, taua, & b, ldb, work, lwork, info ) lopt = MAX( lopt, INT( work( 1 ) ) ) ! ! RQ factorization of N-by-P matrix B: B = T*Z. ! CALL sgerqf( n, p, b, ldb, taub, work, lwork, info ) work( 1 ) = MAX( lopt, INT( work( 1 ) ) ) ! RETURN ! ! End of SGGQRF ! END SUBROUTINE sggqrf SUBROUTINE sggrqf( m, p, n, a, lda, taua, b, ldb, taub, 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: p INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: taua( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: taub( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGGRQF computes a generalized RQ factorization of an M-by-N matrix A ! and a P-by-N matrix B: ! ! A = R*Q, B = Z*T*Q, ! ! where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal ! matrix, and R and T assume one of the forms: ! ! if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N, ! N-M M ( R21 ) N ! N ! ! where R12 or R21 is upper triangular, and ! ! if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P, ! ( 0 ) P-N P N-P ! N ! ! where T11 is upper triangular. ! ! In particular, if B is square and nonsingular, the GRQ factorization ! of A and B implicitly gives the RQ factorization of A*inv(B): ! ! A*inv(B) = (R*inv(T))*Z' ! ! where inv(B) denotes the inverse of the matrix B, and Z' denotes the ! transpose of the matrix Z. ! ! Arguments ! ========= ! ! M (input) INTEGER ! The number of rows of the matrix A. M >= 0. ! ! P (input) INTEGER ! The number of rows of the matrix B. P >= 0. ! ! N (input) INTEGER ! The number of columns of the matrices A and B. N >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the M-by-N matrix A. ! On exit, if M <= N, the upper triangle of the subarray ! A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R; ! if M > N, the elements on and above the (M-N)-th subdiagonal ! contain the M-by-N upper trapezoidal matrix R; the remaining ! elements, with the array TAUA, 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,M). ! ! TAUA (output) REAL array, dimension (min(M,N)) ! The scalar factors of the elementary reflectors which ! represent the orthogonal matrix Q (see Further Details). ! ! B (input/output) REAL array, dimension (LDB,N) ! On entry, the P-by-N matrix B. ! On exit, the elements on and above the diagonal of the array ! contain the min(P,N)-by-N upper trapezoidal matrix T (T is ! upper triangular if P >= N); the elements below the diagonal, ! with the array TAUB, represent the orthogonal matrix Z as a ! product of elementary reflectors (see Further Details). ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,P). ! ! TAUB (output) REAL array, dimension (min(P,N)) ! The scalar factors of the elementary reflectors which ! represent the orthogonal matrix Z (see Further Details). ! ! WORK (workspace/output) REAL 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,M,P). ! For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3), ! where NB1 is the optimal blocksize for the RQ factorization ! of an M-by-N matrix, NB2 is the optimal blocksize for the ! QR factorization of a P-by-N matrix, and NB3 is the optimal ! blocksize for a call of SORMRQ. ! ! 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 INF0= -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 - taua * v * v' ! ! where taua is a real scalar, and v is a real vector with ! v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in ! A(m-k+i,1:n-k+i-1), and taua in TAUA(i). ! To form Q explicitly, use LAPACK subroutine SORGRQ. ! To use Q to update another matrix, use LAPACK subroutine SORMRQ. ! ! The matrix Z is represented as a product of elementary reflectors ! ! Z = H(1) H(2) . . . H(k), where k = min(p,n). ! ! Each H(i) has the form ! ! H(i) = I - taub * v * v' ! ! where taub is a real scalar, and v is a real vector with ! v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i), ! and taub in TAUB(i). ! To form Z explicitly, use LAPACK subroutine SORGQR. ! To use Z to update another matrix, use LAPACK subroutine SORMQR. ! ! ===================================================================== ! ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: lopt, lwkopt, nb, nb1, nb2, nb3 ! .. ! .. External Subroutines .. EXTERNAL sgeqrf, sgerqf, sormrq, xerbla ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Intrinsic Functions .. INTRINSIC INT, MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters ! info = 0 nb1 = ilaenv( 1, 'SGERQF', ' ', m, n, -1, -1 ) nb2 = ilaenv( 1, 'SGEQRF', ' ', p, n, -1, -1 ) nb3 = ilaenv( 1, 'SORMRQ', ' ', m, n, p, -1 ) nb = MAX( nb1, nb2, nb3 ) lwkopt = MAX( n, m, p)*nb work( 1 ) = lwkopt lquery = ( lwork == -1 ) IF( m < 0 ) THEN info = -1 ELSE IF( p < 0 ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, m ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, p ) ) THEN info = -8 ELSE IF( lwork < MAX( 1, m, p, n ) .AND. .NOT.lquery ) THEN info = -11 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGGRQF', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! RQ factorization of M-by-N matrix A: A = R*Q ! CALL sgerqf( m, n, a, lda, taua, work, lwork, info ) lopt = work( 1 ) ! ! Update B := B*Q' ! CALL sormrq( 'Right', 'Transpose', p, n, MIN( m, n ), & a( MAX( 1, m-n+1 ), 1 ), lda, taua, b, ldb, work, lwork, info ) lopt = MAX( lopt, INT( work( 1 ) ) ) ! ! QR factorization of P-by-N matrix B: B = Z*T ! CALL sgeqrf( p, n, b, ldb, taub, work, lwork, info ) work( 1 ) = MAX( lopt, INT( work( 1 ) ) ) ! RETURN ! ! End of SGGRQF ! END SUBROUTINE sggrqf SUBROUTINE sggsvd( jobu, jobv, jobq, m, n, p, k, l, a, lda, b, & ldb, alpha, beta, u, ldu, v, ldv, q, ldq, work, iwork, 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 (LEN=1), INTENT(IN) :: jobu CHARACTER (LEN=1), INTENT(IN) :: jobv CHARACTER (LEN=1), INTENT(IN) :: jobq INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: p INTEGER, INTENT(IN OUT) :: k INTEGER, INTENT(IN) :: l REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN) :: ldb REAL, INTENT(IN OUT) :: alpha( * ) REAL, INTENT(IN OUT) :: beta( * ) REAL, INTENT(IN OUT) :: u( ldu, * ) INTEGER, INTENT(IN OUT) :: ldu REAL, INTENT(IN OUT) :: v( ldv, * ) INTEGER, INTENT(IN OUT) :: ldv REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGGSVD computes the generalized singular value decomposition (GSVD) ! of an M-by-N real matrix A and P-by-N real matrix B: ! ! U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ) ! ! where U, V and Q are orthogonal matrices, and Z' is the transpose ! of Z. Let K+L = the effective numerical rank of the matrix (A',B')', ! then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and ! D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the ! following structures, respectively: ! ! If M-K-L >= 0, ! ! K L ! D1 = K ( I 0 ) ! L ( 0 C ) ! M-K-L ( 0 0 ) ! ! K L ! D2 = L ( 0 S ) ! P-L ( 0 0 ) ! ! N-K-L K L ! ( 0 R ) = K ( 0 R11 R12 ) ! L ( 0 0 R22 ) ! ! where ! ! C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), ! S = diag( BETA(K+1), ... , BETA(K+L) ), ! C**2 + S**2 = I. ! ! R is stored in A(1:K+L,N-K-L+1:N) on exit. ! ! If M-K-L < 0, ! ! K M-K K+L-M ! D1 = K ( I 0 0 ) ! M-K ( 0 C 0 ) ! ! K M-K K+L-M ! D2 = M-K ( 0 S 0 ) ! K+L-M ( 0 0 I ) ! P-L ( 0 0 0 ) ! ! N-K-L K M-K K+L-M ! ( 0 R ) = K ( 0 R11 R12 R13 ) ! M-K ( 0 0 R22 R23 ) ! K+L-M ( 0 0 0 R33 ) ! ! where ! ! C = diag( ALPHA(K+1), ... , ALPHA(M) ), ! S = diag( BETA(K+1), ... , BETA(M) ), ! C**2 + S**2 = I. ! ! (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored ! ( 0 R22 R23 ) ! in B(M-K+1:L,N+M-K-L+1:N) on exit. ! ! The routine computes C, S, R, and optionally the orthogonal ! transformation matrices U, V and Q. ! ! In particular, if B is an N-by-N nonsingular matrix, then the GSVD of ! A and B implicitly gives the SVD of A*inv(B): ! A*inv(B) = U*(D1*inv(D2))*V'. ! If ( A',B')' has orthonormal columns, then the GSVD of A and B is ! also equal to the CS decomposition of A and B. Furthermore, the GSVD ! can be used to derive the solution of the eigenvalue problem: ! A'*A x = lambda* B'*B x. ! In some literature, the GSVD of A and B is presented in the form ! U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 ) ! where U and V are orthogonal and X is nonsingular, D1 and D2 are ! ``diagonal''. The former GSVD form can be converted to the latter ! form by taking the nonsingular matrix X as ! ! X = Q*( I 0 ) ! ( 0 inv(R) ). ! ! Arguments ! ========= ! ! JOBU (input) CHARACTER*1 ! = 'U': Orthogonal matrix U is computed; ! = 'N': U is not computed. ! ! JOBV (input) CHARACTER*1 ! = 'V': Orthogonal matrix V is computed; ! = 'N': V is not computed. ! ! JOBQ (input) CHARACTER*1 ! = 'Q': Orthogonal matrix Q is computed; ! = 'N': Q is not computed. ! ! M (input) INTEGER ! The number of rows of the matrix A. M >= 0. ! ! N (input) INTEGER ! The number of columns of the matrices A and B. N >= 0. ! ! P (input) INTEGER ! The number of rows of the matrix B. P >= 0. ! ! K (output) INTEGER ! L (output) INTEGER ! On exit, K and L specify the dimension of the subblocks ! described in the Purpose section. ! K + L = effective numerical rank of (A',B')'. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the M-by-N matrix A. ! On exit, A contains the triangular matrix R, or part of R. ! See Purpose for details. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! B (input/output) REAL array, dimension (LDB,N) ! On entry, the P-by-N matrix B. ! On exit, B contains the triangular matrix R if M-K-L < 0. ! See Purpose for details. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDA >= max(1,P). ! ! ALPHA (output) REAL array, dimension (N) ! BETA (output) REAL array, dimension (N) ! On exit, ALPHA and BETA contain the generalized singular ! value pairs of A and B; ! ALPHA(1:K) = 1, ! BETA(1:K) = 0, ! and if M-K-L >= 0, ! ALPHA(K+1:K+L) = C, ! BETA(K+1:K+L) = S, ! or if M-K-L < 0, ! ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0 ! BETA(K+1:M) =S, BETA(M+1:K+L) =1 ! and ! ALPHA(K+L+1:N) = 0 ! BETA(K+L+1:N) = 0 ! ! U (output) REAL array, dimension (LDU,M) ! If JOBU = 'U', U contains the M-by-M orthogonal matrix U. ! If JOBU = 'N', U is not referenced. ! ! LDU (input) INTEGER ! The leading dimension of the array U. LDU >= max(1,M) if ! JOBU = 'U'; LDU >= 1 otherwise. ! ! V (output) REAL array, dimension (LDV,P) ! If JOBV = 'V', V contains the P-by-P orthogonal matrix V. ! If JOBV = 'N', V is not referenced. ! ! LDV (input) INTEGER ! The leading dimension of the array V. LDV >= max(1,P) if ! JOBV = 'V'; LDV >= 1 otherwise. ! ! Q (output) REAL array, dimension (LDQ,N) ! If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q. ! If JOBQ = 'N', Q is not referenced. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. LDQ >= max(1,N) if ! JOBQ = 'Q'; LDQ >= 1 otherwise. ! ! WORK (workspace) REAL array, ! dimension (max(3*N,M,P)+N) ! ! IWORK (workspace/output) INTEGER array, dimension (N) ! On exit, IWORK stores the sorting information. More ! precisely, the following loop will sort ALPHA ! for I = K+1, min(M,K+L) ! swap ALPHA(I) and ALPHA(IWORK(I)) ! endfor ! such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N). ! ! INFO (output)INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if INFO = 1, the Jacobi-type procedure failed to ! converge. For further details, see subroutine STGSJA. ! ! Internal Parameters ! =================== ! ! TOLA REAL ! TOLB REAL ! TOLA and TOLB are the thresholds to determine the effective ! rank of (A',B')'. Generally, they are set to ! TOLA = MAX(M,N)*norm(A)*MACHEPS, ! TOLB = MAX(P,N)*norm(B)*MACHEPS. ! The size of TOLA and TOLB may affect the size of backward ! errors of the decomposition. ! ! Further Details ! =============== ! ! 2-96 Based on modifications by ! Ming Gu and Huan Ren, Computer Science Division, University of ! California at Berkeley, USA ! ! ===================================================================== ! ! .. Local Scalars .. LOGICAL :: wantq, wantu, wantv INTEGER :: i, ibnd, isub, j, ncycle REAL :: anorm, bnorm, smax, temp, tola, tolb, ulp, unfl ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slange EXTERNAL lsame, slamch, slange ! .. ! .. External Subroutines .. EXTERNAL scopy, sggsvp, stgsja, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters ! wantu = lsame( jobu, 'U' ) wantv = lsame( jobv, 'V' ) wantq = lsame( jobq, 'Q' ) ! info = 0 IF( .NOT.( wantu .OR. lsame( jobu, 'N' ) ) ) THEN info = -1 ELSE IF( .NOT.( wantv .OR. lsame( jobv, 'N' ) ) ) THEN info = -2 ELSE IF( .NOT.( wantq .OR. lsame( jobq, 'N' ) ) ) THEN info = -3 ELSE IF( m < 0 ) THEN info = -4 ELSE IF( n < 0 ) THEN info = -5 ELSE IF( p < 0 ) THEN info = -6 ELSE IF( lda < MAX( 1, m ) ) THEN info = -10 ELSE IF( ldb < MAX( 1, p ) ) THEN info = -12 ELSE IF( ldu < 1 .OR. ( wantu .AND. ldu < m ) ) THEN info = -16 ELSE IF( ldv < 1 .OR. ( wantv .AND. ldv < p ) ) THEN info = -18 ELSE IF( ldq < 1 .OR. ( wantq .AND. ldq < n ) ) THEN info = -20 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGGSVD', -info ) RETURN END IF ! ! Compute the Frobenius norm of matrices A and B ! anorm = slange( '1', m, n, a, lda, work ) bnorm = slange( '1', p, n, b, ldb, work ) ! ! Get machine precision and set up threshold for determining ! the effective numerical rank of the matrices A and B. ! ulp = slamch( 'Precision' ) unfl = slamch( 'Safe Minimum' ) tola = MAX( m, n )*MAX( anorm, unfl )*ulp tolb = MAX( p, n )*MAX( bnorm, unfl )*ulp ! ! Preprocessing ! CALL sggsvp( jobu, jobv, jobq, m, p, n, a, lda, b, ldb, tola, & tolb, k, l, u, ldu, v, ldv, q, ldq, iwork, work, work( n+1 ), info ) ! ! Compute the GSVD of two upper "triangular" matrices ! CALL stgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b, ldb, & tola, tolb, alpha, beta, u, ldu, v, ldv, q, ldq, work, ncycle, info ) ! ! Sort the singular values and store the pivot indices in IWORK ! Copy ALPHA to WORK, then sort ALPHA in WORK ! CALL scopy( n, alpha, 1, work, 1 ) ibnd = MIN( l, m-k ) DO i = 1, ibnd ! ! Scan for largest ALPHA(K+I) ! isub = i smax = work( k+i ) DO j = i + 1, ibnd temp = work( k+j ) IF( temp > smax ) THEN isub = j smax = temp END IF END DO IF( isub /= i ) THEN work( k+isub ) = work( k+i ) work( k+i ) = smax iwork( k+i ) = k + isub ELSE iwork( k+i ) = k + i END IF END DO ! RETURN ! ! End of SGGSVD ! END SUBROUTINE sggsvd SUBROUTINE sggsvp( jobu, jobv, jobq, m, p, n, a, lda, b, ldb, & tola, tolb, k, l, u, ldu, v, ldv, q, ldq, iwork, 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 .. CHARACTER (LEN=1), INTENT(IN) :: jobu CHARACTER (LEN=1), INTENT(IN) :: jobv CHARACTER (LEN=1), INTENT(IN) :: jobq INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: p INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: tola REAL, INTENT(IN) :: tolb INTEGER, INTENT(OUT) :: k INTEGER, INTENT(OUT) :: l REAL, INTENT(IN OUT) :: u( ldu, * ) INTEGER, INTENT(IN OUT) :: ldu REAL, INTENT(IN OUT) :: v( ldv, * ) INTEGER, INTENT(IN OUT) :: ldv REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq INTEGER, INTENT(OUT) :: iwork( * ) REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGGSVP computes orthogonal matrices U, V and Q such that ! ! N-K-L K L ! U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0; ! L ( 0 0 A23 ) ! M-K-L ( 0 0 0 ) ! ! N-K-L K L ! = K ( 0 A12 A13 ) if M-K-L < 0; ! M-K ( 0 0 A23 ) ! ! N-K-L K L ! V'*B*Q = L ( 0 0 B13 ) ! P-L ( 0 0 0 ) ! ! where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular ! upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, ! otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective ! numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the ! transpose of Z. ! ! This decomposition is the preprocessing step for computing the ! Generalized Singular Value Decomposition (GSVD), see subroutine ! SGGSVD. ! ! Arguments ! ========= ! ! JOBU (input) CHARACTER*1 ! = 'U': Orthogonal matrix U is computed; ! = 'N': U is not computed. ! ! JOBV (input) CHARACTER*1 ! = 'V': Orthogonal matrix V is computed; ! = 'N': V is not computed. ! ! JOBQ (input) CHARACTER*1 ! = 'Q': Orthogonal matrix Q is computed; ! = 'N': Q is not computed. ! ! M (input) INTEGER ! The number of rows of the matrix A. M >= 0. ! ! P (input) INTEGER ! The number of rows of the matrix B. P >= 0. ! ! N (input) INTEGER ! The number of columns of the matrices A and B. N >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the M-by-N matrix A. ! On exit, A contains the triangular (or trapezoidal) matrix ! described in the Purpose section. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! B (input/output) REAL array, dimension (LDB,N) ! On entry, the P-by-N matrix B. ! On exit, B contains the triangular matrix described in ! the Purpose section. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,P). ! ! TOLA (input) REAL ! TOLB (input) REAL ! TOLA and TOLB are the thresholds to determine the effective ! numerical rank of matrix B and a subblock of A. Generally, ! they are set to ! TOLA = MAX(M,N)*norm(A)*MACHEPS, ! TOLB = MAX(P,N)*norm(B)*MACHEPS. ! The size of TOLA and TOLB may affect the size of backward ! errors of the decomposition. ! ! K (output) INTEGER ! L (output) INTEGER ! On exit, K and L specify the dimension of the subblocks ! described in Purpose. ! K + L = effective numerical rank of (A',B')'. ! ! U (output) REAL array, dimension (LDU,M) ! If JOBU = 'U', U contains the orthogonal matrix U. ! If JOBU = 'N', U is not referenced. ! ! LDU (input) INTEGER ! The leading dimension of the array U. LDU >= max(1,M) if ! JOBU = 'U'; LDU >= 1 otherwise. ! ! V (output) REAL array, dimension (LDV,M) ! If JOBV = 'V', V contains the orthogonal matrix V. ! If JOBV = 'N', V is not referenced. ! ! LDV (input) INTEGER ! The leading dimension of the array V. LDV >= max(1,P) if ! JOBV = 'V'; LDV >= 1 otherwise. ! ! Q (output) REAL array, dimension (LDQ,N) ! If JOBQ = 'Q', Q contains the orthogonal matrix Q. ! If JOBQ = 'N', Q is not referenced. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. LDQ >= max(1,N) if ! JOBQ = 'Q'; LDQ >= 1 otherwise. ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! TAU (workspace) REAL array, dimension (N) ! ! WORK (workspace) REAL array, dimension (max(3*N,M,P)) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value. ! ! ! Further Details ! =============== ! ! The subroutine uses LAPACK subroutine SGEQPF for the QR factorization ! with column pivoting to detect the effective numerical rank of the ! a matrix. It may be replaced by a better rank determination strategy. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: forwrd, wantq, wantu, wantv INTEGER :: i, j ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL sgeqpf, sgeqr2, sgerq2, slacpy, slapmt, slaset, & sorg2r, sorm2r, sormr2, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters ! wantu = lsame( jobu, 'U' ) wantv = lsame( jobv, 'V' ) wantq = lsame( jobq, 'Q' ) forwrd = .true. ! info = 0 IF( .NOT.( wantu .OR. lsame( jobu, 'N' ) ) ) THEN info = -1 ELSE IF( .NOT.( wantv .OR. lsame( jobv, 'N' ) ) ) THEN info = -2 ELSE IF( .NOT.( wantq .OR. lsame( jobq, 'N' ) ) ) THEN info = -3 ELSE IF( m < 0 ) THEN info = -4 ELSE IF( p < 0 ) THEN info = -5 ELSE IF( n < 0 ) THEN info = -6 ELSE IF( lda < MAX( 1, m ) ) THEN info = -8 ELSE IF( ldb < MAX( 1, p ) ) THEN info = -10 ELSE IF( ldu < 1 .OR. ( wantu .AND. ldu < m ) ) THEN info = -16 ELSE IF( ldv < 1 .OR. ( wantv .AND. ldv < p ) ) THEN info = -18 ELSE IF( ldq < 1 .OR. ( wantq .AND. ldq < n ) ) THEN info = -20 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGGSVP', -info ) RETURN END IF ! ! QR with column pivoting of B: B*P = V*( S11 S12 ) ! ( 0 0 ) ! DO i = 1, n iwork( i ) = 0 END DO CALL sgeqpf( p, n, b, ldb, iwork, tau, work, info ) ! ! Update A := A*P ! CALL slapmt( forwrd, m, n, a, lda, iwork ) ! ! Determine the effective rank of matrix B. ! l = 0 DO i = 1, MIN( p, n ) IF( ABS( b( i, i ) ) > tolb ) l = l + 1 END DO ! IF( wantv ) THEN ! ! Copy the details of V, and form V. ! CALL slaset( 'Full', p, p, zero, zero, v, ldv ) IF( p > 1 ) CALL slacpy( 'Lower', p-1, n, b( 2, 1 ), ldb, v( 2, 1 ), & ldv ) CALL sorg2r( p, p, MIN( p, n ), v, ldv, tau, work, info ) END IF ! ! Clean up B ! DO j = 1, l - 1 DO i = j + 1, l b( i, j ) = zero END DO END DO IF( p > l ) CALL slaset( 'Full', p-l, n, zero, zero, b( l+1, 1 ), ldb ) ! IF( wantq ) THEN ! ! Set Q = I and Update Q := Q*P ! CALL slaset( 'Full', n, n, zero, one, q, ldq ) CALL slapmt( forwrd, n, n, q, ldq, iwork ) END IF ! IF( p >= l .AND. n /= l ) THEN ! ! RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z ! CALL sgerq2( l, n, b, ldb, tau, work, info ) ! ! Update A := A*Z' ! CALL sormr2( 'Right', 'Transpose', m, n, l, b, ldb, tau, a, & lda, work, info ) ! IF( wantq ) THEN ! ! Update Q := Q*Z' ! CALL sormr2( 'Right', 'Transpose', n, n, l, b, ldb, tau, q, & ldq, work, info ) END IF ! ! Clean up B ! CALL slaset( 'Full', l, n-l, zero, zero, b, ldb ) DO j = n - l + 1, n DO i = j - n + l + 1, l b( i, j ) = zero END DO END DO ! END IF ! ! Let N-L L ! A = ( A11 A12 ) M, ! ! then the following does the complete QR decomposition of A11: ! ! A11 = U*( 0 T12 )*P1' ! ( 0 0 ) ! DO i = 1, n - l iwork( i ) = 0 END DO CALL sgeqpf( m, n-l, a, lda, iwork, tau, work, info ) ! ! Determine the effective rank of A11 ! k = 0 DO i = 1, MIN( m, n-l ) IF( ABS( a( i, i ) ) > tola ) k = k + 1 END DO ! ! Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N ) ! CALL sorm2r( 'Left', 'Transpose', m, l, MIN( m, n-l ), a, lda, & tau, a( 1, n-l+1 ), lda, work, info ) ! IF( wantu ) THEN ! ! Copy the details of U, and form U ! CALL slaset( 'Full', m, m, zero, zero, u, ldu ) IF( m > 1 ) CALL slacpy( 'Lower', m-1, n-l, a( 2, 1 ), lda, u( 2, 1 ), & ldu ) CALL sorg2r( m, m, MIN( m, n-l ), u, ldu, tau, work, info ) END IF ! IF( wantq ) THEN ! ! Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1 ! CALL slapmt( forwrd, n, n-l, q, ldq, iwork ) END IF ! ! Clean up A: set the strictly lower triangular part of ! A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0. ! DO j = 1, k - 1 DO i = j + 1, k a( i, j ) = zero END DO END DO IF( m > k ) CALL slaset( 'Full', m-k, n-l, zero, zero, a( k+1, 1 ), lda ) ! IF( n-l > k ) THEN ! ! RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1 ! CALL sgerq2( k, n-l, a, lda, tau, work, info ) ! IF( wantq ) THEN ! ! Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1' ! CALL sormr2( 'Right', 'Transpose', n, n-l, k, a, lda, tau, & q, ldq, work, info ) END IF ! ! Clean up A ! CALL slaset( 'Full', k, n-l-k, zero, zero, a, lda ) DO j = n - l - k + 1, n - l DO i = j - n + l + k + 1, k a( i, j ) = zero END DO END DO ! END IF ! IF( m > k ) THEN ! ! QR factorization of A( K+1:M,N-L+1:N ) ! CALL sgeqr2( m-k, l, a( k+1, n-l+1 ), lda, tau, work, info ) ! IF( wantu ) THEN ! ! Update U(:,K+1:M) := U(:,K+1:M)*U1 ! CALL sorm2r( 'Right', 'No transpose', m, m-k, MIN( m-k, l ), & a( k+1, n-l+1 ), lda, tau, u( 1, k+1 ), ldu, work, info ) END IF ! ! Clean up ! DO j = n - l + 1, n DO i = j - n + k + l + 1, m a( i, j ) = zero END DO END DO ! END IF ! RETURN ! ! End of SGGSVP ! END SUBROUTINE sggsvp SUBROUTINE sgtcon( norm, n, dl, d, du, du2, ipiv, anorm, rcond, & 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 ! September 30, 1994 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: norm INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: dl( * ) REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN OUT) :: du( * ) REAL, INTENT(IN OUT) :: du2( * ) INTEGER, INTENT(IN OUT) :: ipiv( * ) REAL, INTENT(IN) :: anorm REAL, INTENT(OUT) :: rcond REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGTCON estimates the reciprocal of the condition number of a real ! tridiagonal matrix A using the LU factorization as computed by ! SGTTRF. ! ! An estimate is obtained for norm(inv(A)), and the reciprocal of the ! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! ! Arguments ! ========= ! ! NORM (input) CHARACTER*1 ! Specifies whether the 1-norm condition number or the ! infinity-norm condition number is required: ! = '1' or 'O': 1-norm; ! = 'I': Infinity-norm. ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! DL (input) REAL array, dimension (N-1) ! The (n-1) multipliers that define the matrix L from the ! LU factorization of A as computed by SGTTRF. ! ! D (input) REAL array, dimension (N) ! The n diagonal elements of the upper triangular matrix U from ! the LU factorization of A. ! ! DU (input) REAL array, dimension (N-1) ! The (n-1) elements of the first superdiagonal of U. ! ! DU2 (input) REAL array, dimension (N-2) ! The (n-2) elements of the second superdiagonal of U. ! ! IPIV (input) INTEGER array, dimension (N) ! The pivot indices; for 1 <= i <= n, row i of the matrix was ! interchanged with row IPIV(i). IPIV(i) will always be either ! i or i+1; IPIV(i) = i indicates a row interchange was not ! required. ! ! ANORM (input) REAL ! If NORM = '1' or 'O', the 1-norm of the original matrix A. ! If NORM = 'I', the infinity-norm of the original matrix A. ! ! RCOND (output) REAL ! The reciprocal of the condition number of the matrix A, ! computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an ! estimate of the 1-norm of inv(A) computed in this routine. ! ! WORK (workspace) REAL array, dimension (2*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: onenrm INTEGER :: i, kase, kase1 REAL :: ainvnm ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL sgttrs, slacon, xerbla ! .. ! .. Executable Statements .. ! ! Test the input arguments. ! info = 0 onenrm = norm == '1' .OR. lsame( norm, 'O' ) IF( .NOT.onenrm .AND. .NOT.lsame( norm, 'I' ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( anorm < zero ) THEN info = -8 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGTCON', -info ) RETURN END IF ! ! Quick return if possible ! rcond = zero IF( n == 0 ) THEN rcond = one RETURN ELSE IF( anorm == zero ) THEN RETURN END IF ! ! Check that D(1:N) is non-zero. ! DO i = 1, n IF( d( i ) == zero ) RETURN END DO ! ainvnm = zero IF( onenrm ) THEN kase1 = 1 ELSE kase1 = 2 END IF kase = 0 20 CONTINUE CALL slacon( n, work( n+1 ), work, iwork, ainvnm, kase ) IF( kase /= 0 ) THEN IF( kase == kase1 ) THEN ! ! Multiply by inv(U)*inv(L). ! CALL sgttrs( 'No transpose', n, 1, dl, d, du, du2, ipiv, work, n, info ) ELSE ! ! Multiply by inv(L')*inv(U'). ! CALL sgttrs( 'Transpose', n, 1, dl, d, du, du2, ipiv, work, n, info ) END IF GO TO 20 END IF ! ! Compute the estimate of the reciprocal condition number. ! IF( ainvnm /= zero ) rcond = ( one / ainvnm ) / anorm ! RETURN ! ! End of SGTCON ! END SUBROUTINE sgtcon SUBROUTINE sgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, & ipiv, b, ldb, x, ldx, ferr, berr, 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 ! September 30, 1994 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN OUT) :: dl( * ) REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN OUT) :: du( * ) REAL, INTENT(IN OUT) :: dlf( * ) REAL, INTENT(IN OUT) :: df( * ) REAL, INTENT(IN OUT) :: duf( * ) REAL, INTENT(IN OUT) :: du2( * ) INTEGER, INTENT(IN OUT) :: ipiv( * ) REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: ferr( * ) REAL, INTENT(OUT) :: berr( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGTRFS improves the computed solution to a system of linear ! equations when the coefficient matrix is tridiagonal, and provides ! error bounds and backward error estimates for the solution. ! ! 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 = 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. ! ! DL (input) REAL array, dimension (N-1) ! The (n-1) subdiagonal elements of A. ! ! D (input) REAL array, dimension (N) ! The diagonal elements of A. ! ! DU (input) REAL array, dimension (N-1) ! The (n-1) superdiagonal elements of A. ! ! DLF (input) REAL array, dimension (N-1) ! The (n-1) multipliers that define the matrix L from the ! LU factorization of A as computed by SGTTRF. ! ! DF (input) REAL array, dimension (N) ! The n diagonal elements of the upper triangular matrix U from ! the LU factorization of A. ! ! DUF (input) REAL array, dimension (N-1) ! The (n-1) elements of the first superdiagonal of U. ! ! DU2 (input) REAL array, dimension (N-2) ! The (n-2) elements of the second superdiagonal of U. ! ! IPIV (input) INTEGER array, dimension (N) ! The pivot indices; for 1 <= i <= n, row i of the matrix was ! interchanged with row IPIV(i). IPIV(i) will always be either ! i or i+1; IPIV(i) = i indicates a row interchange was not ! required. ! ! B (input) REAL array, dimension (LDB,NRHS) ! The right hand side matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (input/output) REAL array, dimension (LDX,NRHS) ! On entry, the solution matrix X, as computed by SGTTRS. ! On exit, the improved solution matrix X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! Internal Parameters ! =================== ! ! ITMAX is the maximum number of steps of iterative refinement. ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: itmax = 5 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 REAL, PARAMETER :: three = 3.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: notran CHARACTER (LEN=1) :: transn, transt INTEGER :: count, i, j, kase, nz REAL :: eps, lstres, s, safe1, safe2, safmin ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, sgttrs, slacon, slagtm, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. 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 < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -13 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -15 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGTRFS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) THEN DO j = 1, nrhs ferr( j ) = zero berr( j ) = zero END DO RETURN END IF ! IF( notran ) THEN transn = 'N' transt = 'T' ELSE transn = 'T' transt = 'N' END IF ! ! NZ = maximum number of nonzero elements in each row of A, plus 1 ! nz = 4 eps = slamch( 'Epsilon' ) safmin = slamch( 'Safe minimum' ) safe1 = nz*safmin safe2 = safe1 / eps ! ! Do for each right hand side ! DO j = 1, nrhs ! count = 1 lstres = three 20 CONTINUE ! ! Loop until stopping criterion is satisfied. ! ! Compute residual R = B - op(A) * X, ! where op(A) = A, A**T, or A**H, depending on TRANS. ! CALL scopy( n, b( 1, j ), 1, work( n+1 ), 1 ) CALL slagtm( trans, n, 1, -one, dl, d, du, x( 1, j ), ldx, one, & work( n+1 ), n ) ! ! Compute abs(op(A))*abs(x) + abs(b) for use in the backward ! error bound. ! IF( notran ) THEN IF( n == 1 ) THEN work( 1 ) = ABS( b( 1, j ) ) + ABS( d( 1 )*x( 1, j ) ) ELSE work( 1 ) = ABS( b( 1, j ) ) + ABS( d( 1 )*x( 1, j ) ) + & ABS( du( 1 )*x( 2, j ) ) DO i = 2, n - 1 work( i ) = ABS( b( i, j ) ) + ABS( dl( i-1 )*x( i-1, j ) ) + & ABS( d( i )*x( i, j ) ) + ABS( du( i )*x( i+1, j ) ) END DO work( n ) = ABS( b( n, j ) ) + ABS( dl( n-1 )*x( n-1, j ) ) + & ABS( d( n )*x( n, j ) ) END IF ELSE IF( n == 1 ) THEN work( 1 ) = ABS( b( 1, j ) ) + ABS( d( 1 )*x( 1, j ) ) ELSE work( 1 ) = ABS( b( 1, j ) ) + ABS( d( 1 )*x( 1, j ) ) + & ABS( dl( 1 )*x( 2, j ) ) DO i = 2, n - 1 work( i ) = ABS( b( i, j ) ) + ABS( du( i-1 )*x( i-1, j ) ) + & ABS( d( i )*x( i, j ) ) + ABS( dl( i )*x( i+1, j ) ) END DO work( n ) = ABS( b( n, j ) ) + ABS( du( n-1 )*x( n-1, j ) ) + & ABS( d( n )*x( n, j ) ) END IF END IF ! ! Compute componentwise relative backward error from formula ! ! max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) ! ! where abs(Z) is the componentwise absolute value of the matrix ! or vector Z. If the i-th component of the denominator is less ! than SAFE2, then SAFE1 is added to the i-th components of the ! numerator and denominator before dividing. ! s = zero DO i = 1, n IF( work( i ) > safe2 ) THEN s = MAX( s, ABS( work( n+i ) ) / work( i ) ) ELSE s = MAX( s, ( ABS( work( n+i ) )+safe1 ) / ( work( i )+safe1 ) ) END IF END DO berr( j ) = s ! ! Test stopping criterion. Continue iterating if ! 1) The residual BERR(J) is larger than machine epsilon, and ! 2) BERR(J) decreased by at least a factor of 2 during the ! last iteration, and ! 3) At most ITMAX iterations tried. ! IF( berr( j ) > eps .AND. two*berr( j ) <= lstres .AND. & count <= itmax ) THEN ! ! Update solution and try again. ! CALL sgttrs( trans, n, 1, dlf, df, duf, du2, ipiv, work( n+1 ), n, info ) CALL saxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 GO TO 20 END IF ! ! Bound error from formula ! ! norm(X - XTRUE) / norm(X) .le. FERR = ! norm( abs(inv(op(A)))* ! ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) ! ! where ! norm(Z) is the magnitude of the largest component of Z ! inv(op(A)) is the inverse of op(A) ! abs(Z) is the componentwise absolute value of the matrix or ! vector Z ! NZ is the maximum number of nonzeros in any row of A, plus 1 ! EPS is machine epsilon ! ! The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) ! is incremented by SAFE1 if the i-th component of ! abs(op(A))*abs(X) + abs(B) is less than SAFE2. ! ! Use SLACON to estimate the infinity-norm of the matrix ! inv(op(A)) * diag(W), ! where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) ! DO i = 1, n IF( work( i ) > safe2 ) THEN work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) ELSE work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) + safe1 END IF END DO ! kase = 0 70 CONTINUE CALL slacon( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ), kase ) IF( kase /= 0 ) THEN IF( kase == 1 ) THEN ! ! Multiply by diag(W)*inv(op(A)**T). ! CALL sgttrs( transt, n, 1, dlf, df, duf, du2, ipiv, & work( n+1 ), n, info ) DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO ELSE ! ! Multiply by inv(op(A))*diag(W). ! DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO CALL sgttrs( transn, n, 1, dlf, df, duf, du2, ipiv, & work( n+1 ), n, info ) END IF GO TO 70 END IF ! ! Normalize error. ! lstres = zero DO i = 1, n lstres = MAX( lstres, ABS( x( i, j ) ) ) END DO IF( lstres /= zero ) ferr( j ) = ferr( j ) / lstres ! END DO ! RETURN ! ! End of SGTRFS ! END SUBROUTINE sgtrfs SUBROUTINE sgtsv( n, nrhs, dl, d, du, 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, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN OUT) :: dl( * ) REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(IN OUT) :: du( * ) REAL, INTENT(OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGTSV solves the equation ! ! A*X = B, ! ! where A is an n by n tridiagonal matrix, by Gaussian elimination with ! partial pivoting. ! ! Note that the equation A'*X = B may be solved by interchanging the ! order of the arguments DU and DL. ! ! 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. ! ! DL (input/output) REAL array, dimension (N-1) ! On entry, DL must contain the (n-1) sub-diagonal elements of ! A. ! ! On exit, DL is overwritten by the (n-2) elements of the ! second super-diagonal of the upper triangular matrix U from ! the LU factorization of A, in DL(1), ..., DL(n-2). ! ! D (input/output) REAL array, dimension (N) ! On entry, D must contain the diagonal elements of A. ! ! On exit, D is overwritten by the n diagonal elements of U. ! ! DU (input/output) REAL array, dimension (N-1) ! On entry, DU must contain the (n-1) super-diagonal elements ! of A. ! ! On exit, DU is overwritten by the (n-1) elements of the first ! super-diagonal of U. ! ! B (input/output) REAL array, dimension (LDB,N) ! 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, and the solution ! has not been computed. The factorization has not been ! completed unless i = N. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j REAL :: fact, temp ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. External Subroutines .. EXTERNAL xerbla ! .. ! .. Executable Statements .. ! info = 0 IF( n < 0 ) THEN info = -1 ELSE IF( nrhs < 0 ) THEN info = -2 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -7 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGTSV ', -info ) RETURN END IF ! IF( n == 0 ) RETURN ! IF( nrhs == 1 ) THEN DO i = 1, n - 2 IF( ABS( d( i ) ) >= ABS( dl( i ) ) ) THEN ! ! No row interchange required ! IF( d( i ) /= zero ) THEN fact = dl( i ) / d( i ) d( i+1 ) = d( i+1 ) - fact*du( i ) b( i+1, 1 ) = b( i+1, 1 ) - fact*b( i, 1 ) ELSE info = i RETURN END IF dl( i ) = zero ELSE ! ! Interchange rows I and I+1 ! fact = d( i ) / dl( i ) d( i ) = dl( i ) temp = d( i+1 ) d( i+1 ) = du( i ) - fact*temp dl( i ) = du( i+1 ) du( i+1 ) = -fact*dl( i ) du( i ) = temp temp = b( i, 1 ) b( i, 1 ) = b( i+1, 1 ) b( i+1, 1 ) = temp - fact*b( i+1, 1 ) END IF END DO IF( n > 1 ) THEN i = n - 1 IF( ABS( d( i ) ) >= ABS( dl( i ) ) ) THEN IF( d( i ) /= zero ) THEN fact = dl( i ) / d( i ) d( i+1 ) = d( i+1 ) - fact*du( i ) b( i+1, 1 ) = b( i+1, 1 ) - fact*b( i, 1 ) ELSE info = i RETURN END IF ELSE fact = d( i ) / dl( i ) d( i ) = dl( i ) temp = d( i+1 ) d( i+1 ) = du( i ) - fact*temp du( i ) = temp temp = b( i, 1 ) b( i, 1 ) = b( i+1, 1 ) b( i+1, 1 ) = temp - fact*b( i+1, 1 ) END IF END IF IF( d( n ) == zero ) THEN info = n RETURN END IF ELSE DO i = 1, n - 2 IF( ABS( d( i ) ) >= ABS( dl( i ) ) ) THEN ! ! No row interchange required ! IF( d( i ) /= zero ) THEN fact = dl( i ) / d( i ) d( i+1 ) = d( i+1 ) - fact*du( i ) DO j = 1, nrhs b( i+1, j ) = b( i+1, j ) - fact*b( i, j ) END DO ELSE info = i RETURN END IF dl( i ) = zero ELSE ! ! Interchange rows I and I+1 ! fact = d( i ) / dl( i ) d( i ) = dl( i ) temp = d( i+1 ) d( i+1 ) = du( i ) - fact*temp dl( i ) = du( i+1 ) du( i+1 ) = -fact*dl( i ) du( i ) = temp DO j = 1, nrhs temp = b( i, j ) b( i, j ) = b( i+1, j ) b( i+1, j ) = temp - fact*b( i+1, j ) END DO END IF END DO IF( n > 1 ) THEN i = n - 1 IF( ABS( d( i ) ) >= ABS( dl( i ) ) ) THEN IF( d( i ) /= zero ) THEN fact = dl( i ) / d( i ) d( i+1 ) = d( i+1 ) - fact*du( i ) DO j = 1, nrhs b( i+1, j ) = b( i+1, j ) - fact*b( i, j ) END DO ELSE info = i RETURN END IF ELSE fact = d( i ) / dl( i ) d( i ) = dl( i ) temp = d( i+1 ) d( i+1 ) = du( i ) - fact*temp du( i ) = temp DO j = 1, nrhs temp = b( i, j ) b( i, j ) = b( i+1, j ) b( i+1, j ) = temp - fact*b( i+1, j ) END DO END IF END IF IF( d( n ) == zero ) THEN info = n RETURN END IF END IF ! ! Back solve with the matrix U from the factorization. ! IF( nrhs <= 2 ) THEN j = 1 70 CONTINUE b( n, j ) = b( n, j ) / d( n ) IF( n > 1 ) b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) / d( n-1 ) DO i = n - 2, 1, -1 b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-dl( i )* & b( i+2, j ) ) / d( i ) END DO IF( j < nrhs ) THEN j = j + 1 GO TO 70 END IF ELSE DO j = 1, nrhs b( n, j ) = b( n, j ) / d( n ) IF( n > 1 ) b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) / & d( n-1 ) DO i = n - 2, 1, -1 b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-dl( i )* & b( i+2, j ) ) / d( i ) END DO END DO END IF ! RETURN ! ! End of SGTSV ! END SUBROUTINE sgtsv SUBROUTINE sgtsvx( fact, trans, n, nrhs, dl, d, du, dlf, df, duf, & du2, ipiv, b, ldb, x, ldx, rcond, ferr, berr, 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 (LEN=1), INTENT(IN) :: fact CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: nrhs REAL, INTENT(IN) :: dl( * ) REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: du( * ) REAL, INTENT(IN OUT) :: dlf( * ) REAL, INTENT(IN OUT) :: df( * ) REAL, INTENT(IN OUT) :: duf( * ) REAL, INTENT(IN OUT) :: du2( * ) INTEGER, INTENT(IN OUT) :: ipiv( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: rcond REAL, INTENT(IN OUT) :: ferr( * ) REAL, INTENT(IN OUT) :: berr( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGTSVX uses the LU factorization to compute the solution to a real ! system of linear equations A * X = B or A**T * X = B, ! where A is a tridiagonal matrix of order N and X and B are N-by-NRHS ! matrices. ! ! Error bounds on the solution and a condition estimate are also ! provided. ! ! Description ! =========== ! ! The following steps are performed: ! ! 1. If FACT = 'N', the LU decomposition is used to factor the matrix A ! as A = L * U, where L is a product of permutation and unit lower ! bidiagonal matrices and U is upper triangular with nonzeros in ! only the main diagonal and first two superdiagonals. ! ! 2. If some U(i,i)=0, so that U is exactly singular, then the routine ! returns with INFO = i. Otherwise, the factored form of A is used ! to estimate the condition number of the matrix A. If the ! reciprocal of the condition number is less than machine precision, ! INFO = N+1 is returned as a warning, but the routine still goes on ! to solve for X and compute error bounds as described below. ! ! 3. The system of equations is solved for X using the factored form ! of A. ! ! 4. Iterative refinement is applied to improve the computed solution ! matrix and calculate error bounds and backward error estimates ! for it. ! ! Arguments ! ========= ! ! FACT (input) CHARACTER*1 ! Specifies whether or not the factored form of A has been ! supplied on entry. ! = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored ! form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV ! will not be modified. ! = 'N': The matrix will be copied to DLF, DF, and DUF ! and factored. ! ! 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 = 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. ! ! DL (input) REAL array, dimension (N-1) ! The (n-1) subdiagonal elements of A. ! ! D (input) REAL array, dimension (N) ! The n diagonal elements of A. ! ! DU (input) REAL array, dimension (N-1) ! The (n-1) superdiagonal elements of A. ! ! DLF (input or output) REAL array, dimension (N-1) ! If FACT = 'F', then DLF is an input argument and on entry ! contains the (n-1) multipliers that define the matrix L from ! the LU factorization of A as computed by SGTTRF. ! ! If FACT = 'N', then DLF is an output argument and on exit ! contains the (n-1) multipliers that define the matrix L from ! the LU factorization of A. ! ! DF (input or output) REAL array, dimension (N) ! If FACT = 'F', then DF is an input argument and on entry ! contains the n diagonal elements of the upper triangular ! matrix U from the LU factorization of A. ! ! If FACT = 'N', then DF is an output argument and on exit ! contains the n diagonal elements of the upper triangular ! matrix U from the LU factorization of A. ! ! DUF (input or output) REAL array, dimension (N-1) ! If FACT = 'F', then DUF is an input argument and on entry ! contains the (n-1) elements of the first superdiagonal of U. ! ! If FACT = 'N', then DUF is an output argument and on exit ! contains the (n-1) elements of the first superdiagonal of U. ! ! DU2 (input or output) REAL array, dimension (N-2) ! If FACT = 'F', then DU2 is an input argument and on entry ! contains the (n-2) elements of the second superdiagonal of ! U. ! ! If FACT = 'N', then DU2 is an output argument and on exit ! contains the (n-2) elements of the second superdiagonal of ! U. ! ! IPIV (input or output) INTEGER array, dimension (N) ! If FACT = 'F', then IPIV is an input argument and on entry ! contains the pivot indices from the LU factorization of A as ! computed by SGTTRF. ! ! If FACT = 'N', then IPIV is an output argument and on exit ! contains the pivot indices from the LU factorization of A; ! row i of the matrix was interchanged with row IPIV(i). ! IPIV(i) will always be either i or i+1; IPIV(i) = i indicates ! a row interchange was not required. ! ! B (input) REAL array, dimension (LDB,NRHS) ! The N-by-NRHS right hand side matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (output) REAL array, dimension (LDX,NRHS) ! If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! RCOND (output) REAL ! The estimate of the reciprocal condition number of the matrix ! A. If RCOND is less than the machine precision (in ! particular, if RCOND = 0), the matrix is singular to working ! precision. This condition is indicated by a return code of ! INFO > 0. ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER 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, and i is ! <= N: U(i,i) is exactly zero. The factorization ! has not been completed unless i = N, but the ! factor U is exactly singular, so the solution ! and error bounds could not be computed. ! RCOND = 0 is returned. ! = N+1: U is nonsingular, but RCOND is less than machine ! precision, meaning that the matrix is singular ! to working precision. Nevertheless, the ! solution and error bounds are computed because ! there are a number of situations where the ! computed solution can be more accurate than the ! value of RCOND would suggest. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: nofact, notran CHARACTER (LEN=1) :: norm REAL :: anorm ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slangt EXTERNAL lsame, slamch, slangt ! .. ! .. External Subroutines .. EXTERNAL scopy, sgtcon, sgtrfs, sgttrf, sgttrs, slacpy, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! info = 0 nofact = lsame( fact, 'N' ) notran = lsame( trans, 'N' ) IF( .NOT.nofact .AND. .NOT.lsame( fact, 'F' ) ) THEN info = -1 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT. & lsame( trans, 'C' ) ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( nrhs < 0 ) THEN info = -4 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -14 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -16 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGTSVX', -info ) RETURN END IF ! IF( nofact ) THEN ! ! Compute the LU factorization of A. ! CALL scopy( n, d, 1, df, 1 ) IF( n > 1 ) THEN CALL scopy( n-1, dl, 1, dlf, 1 ) CALL scopy( n-1, du, 1, duf, 1 ) END IF CALL sgttrf( n, dlf, df, duf, du2, ipiv, info ) ! ! Return if INFO is non-zero. ! IF( info /= 0 ) THEN IF( info > 0 ) rcond = zero RETURN END IF END IF ! ! Compute the norm of the matrix A. ! IF( notran ) THEN norm = '1' ELSE norm = 'I' END IF anorm = slangt( norm, n, dl, d, du ) ! ! Compute the reciprocal of the condition number of A. ! CALL sgtcon( norm, n, dlf, df, duf, du2, ipiv, anorm, rcond, work, & iwork, info ) ! ! Set INFO = N+1 if the matrix is singular to working precision. ! IF( rcond < slamch( 'Epsilon' ) ) info = n + 1 ! ! Compute the solution vectors X. ! CALL slacpy( 'Full', n, nrhs, b, ldb, x, ldx ) CALL sgttrs( trans, n, nrhs, dlf, df, duf, du2, ipiv, x, ldx, info ) ! ! Use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. ! CALL sgtrfs( trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv, & b, ldb, x, ldx, ferr, berr, work, iwork, info ) ! RETURN ! ! End of SGTSVX ! END SUBROUTINE sgtsvx SUBROUTINE sgttrf( n, dl, d, du, du2, 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 .. INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: dl( * ) REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(IN OUT) :: du( * ) REAL, INTENT(OUT) :: du2( * ) INTEGER, INTENT(OUT) :: ipiv( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGTTRF computes an LU factorization of a real tridiagonal matrix A ! using elimination with partial pivoting and row interchanges. ! ! The factorization has the form ! A = L * U ! where L is a product of permutation and unit lower bidiagonal ! matrices and U is upper triangular with nonzeros in only the main ! diagonal and first two superdiagonals. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The order of the matrix A. ! ! DL (input/output) REAL array, dimension (N-1) ! On entry, DL must contain the (n-1) sub-diagonal elements of ! A. ! ! On exit, DL is overwritten by the (n-1) multipliers that ! define the matrix L from the LU factorization of A. ! ! D (input/output) REAL array, dimension (N) ! On entry, D must contain the diagonal elements of A. ! ! On exit, D is overwritten by the n diagonal elements of the ! upper triangular matrix U from the LU factorization of A. ! ! DU (input/output) REAL array, dimension (N-1) ! On entry, DU must contain the (n-1) super-diagonal elements ! of A. ! ! On exit, DU is overwritten by the (n-1) elements of the first ! super-diagonal of U. ! ! DU2 (output) REAL array, dimension (N-2) ! On exit, DU2 is overwritten by the (n-2) elements of the ! second super-diagonal of U. ! ! IPIV (output) INTEGER array, dimension (N) ! The pivot indices; for 1 <= i <= n, row i of the matrix was ! interchanged with row IPIV(i). IPIV(i) will always be either ! i or i+1; IPIV(i) = i indicates a row interchange was not ! required. ! ! 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 .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i REAL :: fact, temp ! .. ! .. Intrinsic Functions .. INTRINSIC ABS ! .. ! .. External Subroutines .. EXTERNAL xerbla ! .. ! .. Executable Statements .. ! info = 0 IF( n < 0 ) THEN info = -1 CALL xerbla( 'SGTTRF', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Initialize IPIV(i) = i and DU2(I) = 0 ! DO i = 1, n ipiv( i ) = i END DO DO i = 1, n - 2 du2( i ) = zero END DO ! DO i = 1, n - 2 IF( ABS( d( i ) ) >= ABS( dl( i ) ) ) THEN ! ! No row interchange required, eliminate DL(I) ! IF( d( i ) /= zero ) THEN fact = dl( i ) / d( i ) dl( i ) = fact d( i+1 ) = d( i+1 ) - fact*du( i ) END IF ELSE ! ! Interchange rows I and I+1, eliminate DL(I) ! fact = d( i ) / dl( i ) d( i ) = dl( i ) dl( i ) = fact temp = du( i ) du( i ) = d( i+1 ) d( i+1 ) = temp - fact*d( i+1 ) du2( i ) = du( i+1 ) du( i+1 ) = -fact*du( i+1 ) ipiv( i ) = i + 1 END IF END DO IF( n > 1 ) THEN i = n - 1 IF( ABS( d( i ) ) >= ABS( dl( i ) ) ) THEN IF( d( i ) /= zero ) THEN fact = dl( i ) / d( i ) dl( i ) = fact d( i+1 ) = d( i+1 ) - fact*du( i ) END IF ELSE fact = d( i ) / dl( i ) d( i ) = dl( i ) dl( i ) = fact temp = du( i ) du( i ) = d( i+1 ) d( i+1 ) = temp - fact*d( i+1 ) ipiv( i ) = i + 1 END IF END IF ! ! Check for a zero on the diagonal of U. ! DO i = 1, n IF( d( i ) == zero ) THEN info = i EXIT END IF END DO 50 CONTINUE ! RETURN ! ! End of SGTTRF ! END SUBROUTINE sgttrf SUBROUTINE sgttrs( trans, n, nrhs, dl, d, du, du2, 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 ! June 30, 1999 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN OUT) :: dl( * ) REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(IN OUT) :: du( * ) REAL, INTENT(IN OUT) :: du2( * ) INTEGER, INTENT(IN OUT) :: ipiv( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGTTRS solves one of the systems of equations ! A*X = B or A'*X = B, ! with a tridiagonal matrix A using the LU factorization computed ! by SGTTRF. ! ! Arguments ! ========= ! ! TRANS (input) CHARACTER ! 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. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of columns ! of the matrix B. NRHS >= 0. ! ! DL (input) REAL array, dimension (N-1) ! The (n-1) multipliers that define the matrix L from the ! LU factorization of A. ! ! D (input) REAL array, dimension (N) ! The n diagonal elements of the upper triangular matrix U from ! the LU factorization of A. ! ! DU (input) REAL array, dimension (N-1) ! The (n-1) elements of the first super-diagonal of U. ! ! DU2 (input) REAL array, dimension (N-2) ! The (n-2) elements of the second super-diagonal of U. ! ! IPIV (input) INTEGER array, dimension (N) ! The pivot indices; for 1 <= i <= n, row i of the matrix was ! interchanged with row IPIV(i). IPIV(i) will always be either ! i or i+1; IPIV(i) = i indicates a row interchange was not ! required. ! ! B (input/output) REAL array, dimension (LDB,NRHS) ! On entry, the matrix of right hand side vectors B. ! On exit, B is overwritten by 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 = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Local Scalars .. LOGICAL :: notran INTEGER :: itrans, j, jb, nb ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. External Subroutines .. EXTERNAL sgtts2, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! info = 0 notran = ( trans == 'N' .OR. trans == 'n' ) IF( .NOT.notran .AND. .NOT.( trans == 'T' .OR. trans == & 't' ) .AND. .NOT.( trans == 'C' .OR. trans == 'c' ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( ldb < MAX( n, 1 ) ) THEN info = -10 END IF IF( info /= 0 ) THEN CALL xerbla( 'SGTTRS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) RETURN ! ! Decode TRANS ! IF( notran ) THEN itrans = 0 ELSE itrans = 1 END IF ! ! Determine the number of right-hand sides to solve at a time. ! IF( nrhs == 1 ) THEN nb = 1 ELSE nb = MAX( 1, ilaenv( 1, 'SGTTRS', trans, n, nrhs, -1, -1 ) ) END IF ! IF( nb >= nrhs ) THEN CALL sgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, b, ldb ) ELSE DO j = 1, nrhs, nb jb = MIN( nrhs-j+1, nb ) CALL sgtts2( itrans, n, jb, dl, d, du, du2, ipiv, b( 1, j ), ldb ) END DO END IF ! ! End of SGTTRS ! END SUBROUTINE sgttrs SUBROUTINE sgtts2( itrans, n, nrhs, dl, d, du, du2, ipiv, 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 ! June 30, 1999 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: itrans INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: dl( * ) REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: du( * ) REAL, INTENT(IN) :: du2( * ) INTEGER, INTENT(IN) :: ipiv( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SGTTS2 solves one of the systems of equations ! A*X = B or A'*X = B, ! with a tridiagonal matrix A using the LU factorization computed ! by SGTTRF. ! ! Arguments ! ========= ! ! ITRANS (input) INTEGER ! Specifies the form of the system of equations. ! = 0: A * X = B (No transpose) ! = 1: A'* X = B (Transpose) ! = 2: A'* X = B (Conjugate transpose = Transpose) ! ! N (input) INTEGER ! The order of the matrix A. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of columns ! of the matrix B. NRHS >= 0. ! ! DL (input) REAL array, dimension (N-1) ! The (n-1) multipliers that define the matrix L from the ! LU factorization of A. ! ! D (input) REAL array, dimension (N) ! The n diagonal elements of the upper triangular matrix U from ! the LU factorization of A. ! ! DU (input) REAL array, dimension (N-1) ! The (n-1) elements of the first super-diagonal of U. ! ! DU2 (input) REAL array, dimension (N-2) ! The (n-2) elements of the second super-diagonal of U. ! ! IPIV (input) INTEGER array, dimension (N) ! The pivot indices; for 1 <= i <= n, row i of the matrix was ! interchanged with row IPIV(i). IPIV(i) will always be either ! i or i+1; IPIV(i) = i indicates a row interchange was not ! required. ! ! B (input/output) REAL array, dimension (LDB,NRHS) ! On entry, the matrix of right hand side vectors B. ! On exit, B is overwritten by the solution vectors X. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER :: i, ip, j REAL :: temp ! .. ! .. Executable Statements .. ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) RETURN ! IF( itrans == 0 ) THEN ! ! Solve A*X = B using the LU factorization of A, ! overwriting each right hand side vector with its solution. ! IF( nrhs <= 1 ) THEN j = 1 10 CONTINUE ! ! Solve L*x = b. ! DO i = 1, n - 1 ip = ipiv( i ) temp = b( i+1-ip+i, j ) - dl( i )*b( ip, j ) b( i, j ) = b( ip, j ) b( i+1, j ) = temp END DO ! ! Solve U*x = b. ! b( n, j ) = b( n, j ) / d( n ) IF( n > 1 ) b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) / & d( n-1 ) DO i = n - 2, 1, -1 b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-du2( i )* & b( i+2, j ) ) / d( i ) END DO IF( j < nrhs ) THEN j = j + 1 GO TO 10 END IF ELSE DO j = 1, nrhs ! ! Solve L*x = b. ! DO i = 1, n - 1 IF( ipiv( i ) == i ) THEN b( i+1, j ) = b( i+1, j ) - dl( i )*b( i, j ) ELSE temp = b( i, j ) b( i, j ) = b( i+1, j ) b( i+1, j ) = temp - dl( i )*b( i, j ) END IF END DO ! ! Solve U*x = b. ! b( n, j ) = b( n, j ) / d( n ) IF( n > 1 ) b( n-1, j ) = ( b( n-1, j )-du( n-1 )*b( n, j ) ) / & d( n-1 ) DO i = n - 2, 1, -1 b( i, j ) = ( b( i, j )-du( i )*b( i+1, j )-du2( i )* & b( i+2, j ) ) / d( i ) END DO END DO END IF ELSE ! ! Solve A' * X = B. ! IF( nrhs <= 1 ) THEN ! ! Solve U'*x = b. ! j = 1 70 CONTINUE b( 1, j ) = b( 1, j ) / d( 1 ) IF( n > 1 ) b( 2, j ) = ( b( 2, j )-du( 1 )*b( 1, j ) ) / d( 2 ) DO i = 3, n b( i, j ) = ( b( i, j )-du( i-1 )*b( i-1, j )-du2( i-2 )* & b( i-2, j ) ) / d( i ) END DO ! ! Solve L'*x = b. ! DO i = n - 1, 1, -1 ip = ipiv( i ) temp = b( i, j ) - dl( i )*b( i+1, j ) b( i, j ) = b( ip, j ) b( ip, j ) = temp END DO IF( j < nrhs ) THEN j = j + 1 GO TO 70 END IF ! ELSE DO j = 1, nrhs ! ! Solve U'*x = b. ! b( 1, j ) = b( 1, j ) / d( 1 ) IF( n > 1 ) b( 2, j ) = ( b( 2, j )-du( 1 )*b( 1, j ) ) / d( 2 ) DO i = 3, n b( i, j ) = ( b( i, j )-du( i-1 )*b( i-1, j )- & du2( i-2 )*b( i-2, j ) ) / d( i ) END DO DO i = n - 1, 1, -1 IF( ipiv( i ) == i ) THEN b( i, j ) = b( i, j ) - dl( i )*b( i+1, j ) ELSE temp = b( i+1, j ) b( i+1, j ) = b( i, j ) - dl( i )*temp b( i, j ) = temp END IF END DO END DO END IF END IF ! ! End of SGTTS2 ! END SUBROUTINE sgtts2 SUBROUTINE shgeqz( job, compq, compz, n, ilo, ihi, a, lda, b, ldb, & alphar, alphai, beta, q, ldq, z, ldz, 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 (LEN=1), INTENT(IN) :: job CHARACTER (LEN=1), INTENT(IN) :: compq CHARACTER (LEN=1), INTENT(IN) :: compz INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: ilo INTEGER, INTENT(IN) :: ihi REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN) :: ldb REAL, INTENT(OUT) :: alphar( * ) REAL, INTENT(OUT) :: alphai( * ) REAL, INTENT(OUT) :: beta( * ) REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SHGEQZ implements a single-/double-shift version of the QZ method for ! finding the generalized eigenvalues ! ! w(j)=(ALPHAR(j) + i*ALPHAI(j))/BETAR(j) of the equation ! ! det( A - w(i) B ) = 0 ! ! In addition, the pair A,B may be reduced to generalized Schur form: ! B is upper triangular, and A is block upper triangular, where the ! diagonal blocks are either 1-by-1 or 2-by-2, the 2-by-2 blocks having ! complex generalized eigenvalues (see the description of the argument ! JOB.) ! ! If JOB='S', then the pair (A,B) is simultaneously reduced to Schur ! form by applying one orthogonal tranformation (usually called Q) on ! the left and another (usually called Z) on the right. The 2-by-2 ! upper-triangular diagonal blocks of B corresponding to 2-by-2 blocks ! of A will be reduced to positive diagonal matrices. (I.e., ! if A(j+1,j) is non-zero, then B(j+1,j)=B(j,j+1)=0 and B(j,j) and ! B(j+1,j+1) will be positive.) ! ! If JOB='E', then at each iteration, the same transformations ! are computed, but they are only applied to those parts of A and B ! which are needed to compute ALPHAR, ALPHAI, and BETAR. ! ! If JOB='S' and COMPQ and COMPZ are 'V' or 'I', then the orthogonal ! 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 ALPHAR, ALPHAI, 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 ALPHAR, ALPHAI, and BETA. ! ! COMPQ (input) CHARACTER*1 ! = 'N': do not modify Q. ! = 'V': multiply the array Q on the right by the transpose of ! the orthogonal 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 orthogonal ! 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) REAL 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 generalized Schur form. ! If JOB='E', then on exit A will have been destroyed. ! The diagonal blocks will be correct, but the off-diagonal ! portion will be meaningless. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max( 1, N ). ! ! B (input/output) REAL array, dimension (LDB, N) ! On entry, the N-by-N upper triangular matrix B. Elements ! below the diagonal must be zero. 2-by-2 blocks in B ! corresponding to 2-by-2 blocks in A will be reduced to ! positive diagonal form. (I.e., if A(j+1,j) is non-zero, ! then B(j+1,j)=B(j,j+1)=0 and B(j,j) and B(j+1,j+1) will be ! positive.) ! If JOB='S', then on exit A and B will have been ! simultaneously reduced to Schur form. ! If JOB='E', then on exit B will have been destroyed. ! Elements corresponding to diagonal blocks of A will be ! correct, but the off-diagonal portion will be meaningless. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max( 1, N ). ! ! ALPHAR (output) REAL array, dimension (N) ! ALPHAR(1:N) will be set to real parts of the diagonal ! elements of A that would result from reducing A and B to ! Schur form and then further reducing them both to triangular ! form using unitary transformations s.t. the diagonal of B ! was non-negative real. Thus, if A(j,j) is in a 1-by-1 block ! (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=A(j,j). ! Note that the (real or complex) values ! (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the ! generalized eigenvalues of the matrix pencil A - wB. ! ! ALPHAI (output) REAL array, dimension (N) ! ALPHAI(1:N) will be set to imaginary parts of the diagonal ! elements of A that would result from reducing A and B to ! Schur form and then further reducing them both to triangular ! form using unitary transformations s.t. the diagonal of B ! was non-negative real. Thus, if A(j,j) is in a 1-by-1 block ! (i.e., A(j+1,j)=A(j,j+1)=0), then ALPHAR(j)=0. ! Note that the (real or complex) values ! (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the ! generalized eigenvalues of the matrix pencil A - wB. ! ! BETA (output) REAL array, dimension (N) ! BETA(1:N) will be set to the (real) diagonal elements of B ! that would result from reducing A and B to Schur form and ! then further reducing them both to triangular form using ! unitary transformations s.t. the diagonal of B was ! non-negative real. Thus, if A(j,j) is in a 1-by-1 block ! (i.e., A(j+1,j)=A(j,j+1)=0), then BETA(j)=B(j,j). ! Note that the (real or complex) values ! (ALPHAR(j) + i*ALPHAI(j))/BETA(j), j=1,...,N, are the ! generalized eigenvalues of the matrix pencil A - wB. ! (Note that BETA(1:N) will always be non-negative, and no ! BETAI is necessary.) ! ! Q (input/output) REAL array, dimension (LDQ, N) ! If COMPQ='N', then Q will not be referenced. ! If COMPQ='V' or 'I', then the transpose of the orthogonal ! 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) REAL array, dimension (LDZ, N) ! If COMPZ='N', then Z will not be referenced. ! If COMPZ='V' or 'I', then the orthogonal 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) REAL 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. ! ! 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 ALPHAR(i), ALPHAI(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 ALPHAR(i), ALPHAI(i), and ! BETA(i), i=INFO-N+1,...,N should be correct. ! > 2*N: various "impossible" errors. ! ! Further Details ! =============== ! ! Iteration counters: ! ! JITER -- counts iterations. ! IITER -- counts iterations run since ILAST was last ! changed. This is therefore reset only when a 1-by-1 or ! 2-by-2 block deflates off the bottom. ! ! ===================================================================== ! ! .. Parameters .. ! $ SAFETY = 1.0E+0 ) REAL, PARAMETER :: half = 0.5E+0 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: safety = 1.0E+2 ! .. ! .. Local Scalars .. LOGICAL :: ilazr2, ilazro, ilpivt, ilq, ilschr, ilz, lquery INTEGER :: icompq, icompz, ifirst, ifrstm, iiter, ilast, & ilastm, in, ischur, istart, j, jc, jch, jiter, jr, maxit REAL :: a11, a12, a1i, a1r, a21, a22, a2i, a2r, ad11, & ad11l, ad12, ad12l, ad21, ad21l, ad22, ad22l, & ad32l, an, anorm, ascale, atol, b11, b1a, b1i, & b1r, b22, b2a, b2i, b2r, bn, bnorm, bscale, & btol, c, c11i, c11r, c12, c21, c22i, c22r, cl, & cq, cr, cz, eshift, s, s1, s1inv, s2, safmax, & safmin, scale, sl, sqi, sqr, sr, szi, szr, t, & tau, temp, temp2, tempi, tempr, u1, u12, u12l, & u2, ulp, vs, w11, w12, w21, w22, wabs, wi, wr, wr2 ! .. ! .. Local Arrays .. REAL :: v( 3 ) ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slanhs, slapy2, slapy3 EXTERNAL lsame, slamch, slanhs, slapy2, slapy3 ! .. ! .. External Subroutines .. EXTERNAL slag2, slarfg, slartg, slaset, slasv2, srot, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, REAL, SQRT ! .. ! .. 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 == -1 ) IF( ischur == 0 ) THEN info = -1 ELSE IF( icompq == 0 ) THEN info = -2 ELSE IF( icompz == 0 ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( ilo < 1 ) THEN info = -5 ELSE IF( ihi > n .OR. ihi < ilo-1 ) THEN info = -6 ELSE IF( lda < n ) THEN info = -8 ELSE IF( ldb < n ) THEN info = -10 ELSE IF( ldq < 1 .OR. ( ilq .AND. ldq < n ) ) THEN info = -15 ELSE IF( ldz < 1 .OR. ( ilz .AND. ldz < n ) ) THEN info = -17 ELSE IF( lwork < MAX( 1, n ) .AND. .NOT.lquery ) THEN info = -19 END IF IF( info /= 0 ) THEN CALL xerbla( 'SHGEQZ', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n <= 0 ) THEN work( 1 ) = REAL( 1 ) RETURN END IF ! ! Initialize Q and Z ! IF( icompq == 3 ) CALL slaset( 'Full', n, n, zero, one, q, ldq ) IF( icompz == 3 ) CALL slaset( 'Full', n, n, zero, one, z, ldz ) ! ! Machine Constants ! in = ihi + 1 - ilo safmin = slamch( 'S' ) safmax = one / safmin ulp = slamch( 'E' )*slamch( 'B' ) anorm = slanhs( 'F', in, a( ilo, ilo ), lda, work ) bnorm = slanhs( 'F', in, b( ilo, ilo ), ldb, work ) 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 j = ihi + 1, n IF( b( j, j ) < zero ) THEN IF( ilschr ) THEN DO jr = 1, j a( jr, j ) = -a( jr, j ) b( jr, j ) = -b( jr, j ) END DO ELSE a( j, j ) = -a( j, j ) b( j, j ) = -b( j, j ) END IF IF( ilz ) THEN DO jr = 1, n z( jr, j ) = -z( jr, j ) END DO END IF END IF alphar( j ) = a( j, j ) alphai( j ) = zero beta( j ) = b( j, j ) END DO ! ! If IHI < ILO, skip QZ steps ! IF( ihi < ilo ) GO TO 380 ! ! 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 = zero maxit = 30*( ihi-ilo+1 ) ! DO jiter = 1, maxit ! ! Split the matrix if possible. ! ! Two tests: ! 1: A(j,j-1)=0 or j=ILO ! 2: B(j,j)=0 ! IF( ilast == ilo ) THEN ! ! Special case: j=ILAST ! GO TO 80 ELSE IF( ABS( a( ilast, ilast-1 ) ) <= atol ) THEN a( ilast, ilast-1 ) = zero GO TO 80 END IF END IF ! IF( ABS( b( ilast, ilast ) ) <= btol ) THEN b( ilast, ilast ) = zero GO TO 70 END IF ! ! General case: j= btol ) THEN IF( jch+1 >= ilast ) THEN GO TO 80 ELSE ifirst = jch + 1 GO TO 110 END IF END IF b( jch+1, jch+1 ) = zero END DO GO TO 70 ELSE ! ! Only test 2 passed -- chase the zero to B(ILAST,ILAST) ! Then process as in the case B(ILAST,ILAST)=0 ! DO jch = j, ilast - 1 temp = b( jch, jch+1 ) CALL slartg( temp, b( jch+1, jch+1 ), c, s, b( jch, jch+1 ) ) b( jch+1, jch+1 ) = zero IF( jch < ilastm-1 ) & CALL srot( ilastm-jch-1, b( jch, jch+2 ), ldb, & b( jch+1, jch+2 ), ldb, c, s ) CALL srot( ilastm-jch+2, a( jch, jch-1 ), lda, & a( jch+1, jch-1 ), lda, c, s ) IF( ilq ) CALL srot( n, q( 1, jch ), 1, q( 1, jch+1 ), 1, & c, s ) temp = a( jch+1, jch ) CALL slartg( temp, a( jch+1, jch-1 ), c, s, a( jch+1, jch ) ) a( jch+1, jch-1 ) = zero CALL srot( jch+1-ifrstm, a( ifrstm, jch ), 1, & a( ifrstm, jch-1 ), 1, c, s ) CALL srot( jch-ifrstm, b( ifrstm, jch ), 1, & b( ifrstm, jch-1 ), 1, c, s ) IF( ilz ) CALL srot( n, z( 1, jch ), 1, z( 1, jch-1 ), 1, & c, s ) END DO GO TO 70 END IF ELSE IF( ilazro ) THEN ! ! Only test 1 passed -- work on J:ILAST ! ifirst = j GO TO 110 END IF ! ! Neither test passed -- try next J ! END DO ! ! (Drop-through is "impossible") ! info = n + 1 GO TO 420 ! ! B(ILAST,ILAST)=0 -- clear A(ILAST,ILAST-1) to split off a ! 1x1 block. ! 70 CONTINUE temp = a( ilast, ilast ) CALL slartg( temp, a( ilast, ilast-1 ), c, s, a( ilast, ilast ) ) a( ilast, ilast-1 ) = zero CALL srot( ilast-ifrstm, a( ifrstm, ilast ), 1, & a( ifrstm, ilast-1 ), 1, c, s ) CALL srot( ilast-ifrstm, b( ifrstm, ilast ), 1, & b( ifrstm, ilast-1 ), 1, c, s ) IF( ilz ) CALL srot( n, z( 1, ilast ), 1, z( 1, ilast-1 ), 1, c, s ) ! ! A(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI, ! and BETA ! 80 CONTINUE IF( b( ilast, ilast ) < zero ) THEN IF( ilschr ) THEN DO j = ifrstm, ilast a( j, ilast ) = -a( j, ilast ) b( j, ilast ) = -b( j, ilast ) END DO ELSE a( ilast, ilast ) = -a( ilast, ilast ) b( ilast, ilast ) = -b( ilast, ilast ) END IF IF( ilz ) THEN DO j = 1, n z( j, ilast ) = -z( j, ilast ) END DO END IF END IF alphar( ilast ) = a( ilast, ilast ) alphai( ilast ) = zero beta( ilast ) = b( ilast, ilast ) ! ! Go to next block -- exit if finished. ! ilast = ilast - 1 IF( ilast < ilo ) GO TO 380 ! ! Reset counters ! iiter = 0 eshift = zero IF( .NOT.ilschr ) THEN ilastm = ilast IF( ifrstm > ilast ) ifrstm = ilo END IF GO TO 350 ! ! QZ step ! ! This iteration only involves rows/columns IFIRST:ILAST. We ! assume IFIRST < ILAST, and that the diagonal of B is non-zero. ! 110 CONTINUE iiter = iiter + 1 IF( .NOT.ilschr ) THEN ifrstm = ifirst END IF ! ! Compute single shifts. ! ! At this point, IFIRST < ILAST, and the diagonal elements of ! B(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in ! magnitude) ! IF( ( iiter / 10 )*10 == iiter ) THEN ! ! Exceptional shift. Chosen for no particularly good reason. ! (Single shift only.) ! IF( ( REAL( maxit )*safmin )*ABS( a( ilast-1, ilast ) ) < & ABS( b( ilast-1, ilast-1 ) ) ) THEN eshift = eshift + a( ilast-1, ilast ) / b( ilast-1, ilast-1 ) ELSE eshift = eshift + one / ( safmin*REAL( maxit ) ) END IF s1 = one wr = eshift ! ELSE ! ! Shifts based on the generalized eigenvalues of the ! bottom-right 2x2 block of A and B. The first eigenvalue ! returned by SLAG2 is the Wilkinson shift (AEP p.512), ! CALL slag2( a( ilast-1, ilast-1 ), lda, & b( ilast-1, ilast-1 ), ldb, safmin*safety, s1, s2, wr, wr2, wi ) ! temp = MAX( s1, safmin*MAX( one, ABS( wr ), ABS( wi ) ) ) IF( wi /= zero ) GO TO 200 END IF ! ! Fiddle with shift to avoid overflow ! temp = MIN( ascale, one )*( half*safmax ) IF( s1 > temp ) THEN scale = temp / s1 ELSE scale = one END IF ! temp = MIN( bscale, one )*( half*safmax ) IF( ABS( wr ) > temp ) scale = MIN( scale, temp / ABS( wr ) ) s1 = scale*s1 wr = scale*wr ! ! Now check for two consecutive small subdiagonals. ! DO j = ilast - 1, ifirst + 1, -1 istart = j temp = ABS( s1*a( j, j-1 ) ) temp2 = ABS( s1*a( j, j )-wr*b( j, j ) ) tempr = MAX( temp, temp2 ) IF( tempr < one .AND. tempr /= zero ) THEN temp = temp / tempr temp2 = temp2 / tempr END IF IF( ABS( ( ascale*a( j+1, j ) )*temp ) <= ( ascale*atol )* & temp2 )GO TO 130 END DO ! istart = ifirst 130 CONTINUE ! ! Do an implicit single-shift QZ sweep. ! ! Initial Q ! temp = s1*a( istart, istart ) - wr*b( istart, istart ) temp2 = s1*a( istart+1, istart ) CALL slartg( temp, temp2, c, s, tempr ) ! ! Sweep ! DO j = istart, ilast - 1 IF( j > istart ) THEN temp = a( j, j-1 ) CALL slartg( temp, a( j+1, j-1 ), c, s, a( j, j-1 ) ) a( j+1, j-1 ) = zero END IF ! DO jc = j, ilastm temp = c*a( j, jc ) + s*a( j+1, jc ) a( j+1, jc ) = -s*a( j, jc ) + c*a( j+1, jc ) a( j, jc ) = temp temp2 = c*b( j, jc ) + s*b( j+1, jc ) b( j+1, jc ) = -s*b( j, jc ) + c*b( j+1, jc ) b( j, jc ) = temp2 END DO IF( ilq ) THEN DO jr = 1, n temp = c*q( jr, j ) + s*q( jr, j+1 ) q( jr, j+1 ) = -s*q( jr, j ) + c*q( jr, j+1 ) q( jr, j ) = temp END DO END IF ! temp = b( j+1, j+1 ) CALL slartg( temp, b( j+1, j ), c, s, b( j+1, j+1 ) ) b( j+1, j ) = zero ! DO jr = ifrstm, MIN( j+2, ilast ) temp = c*a( jr, j+1 ) + s*a( jr, j ) a( jr, j ) = -s*a( jr, j+1 ) + c*a( jr, j ) a( jr, j+1 ) = temp END DO DO jr = ifrstm, j temp = c*b( jr, j+1 ) + s*b( jr, j ) b( jr, j ) = -s*b( jr, j+1 ) + c*b( jr, j ) b( jr, j+1 ) = temp END DO IF( ilz ) THEN DO jr = 1, n temp = c*z( jr, j+1 ) + s*z( jr, j ) z( jr, j ) = -s*z( jr, j+1 ) + c*z( jr, j ) z( jr, j+1 ) = temp END DO END IF END DO ! GO TO 350 ! ! Use Francis double-shift ! ! Note: the Francis double-shift should work with real shifts, ! but only if the block is at least 3x3. ! This code may break if this point is reached with ! a 2x2 block with real eigenvalues. ! 200 CONTINUE IF( ifirst+1 == ilast ) THEN ! ! Special case -- 2x2 block with complex eigenvectors ! ! Step 1: Standardize, that is, rotate so that ! ! ( B11 0 ) ! B = ( ) with B11 non-negative. ! ( 0 B22 ) ! CALL slasv2( b( ilast-1, ilast-1 ), b( ilast-1, ilast ), & b( ilast, ilast ), b22, b11, sr, cr, sl, cl ) ! IF( b11 < zero ) THEN cr = -cr sr = -sr b11 = -b11 b22 = -b22 END IF ! CALL srot( ilastm+1-ifirst, a( ilast-1, ilast-1 ), lda, & a( ilast, ilast-1 ), lda, cl, sl ) CALL srot( ilast+1-ifrstm, a( ifrstm, ilast-1 ), 1, & a( ifrstm, ilast ), 1, cr, sr ) ! IF( ilast < ilastm ) & CALL srot( ilastm-ilast, b( ilast-1, ilast+1 ), ldb, & b( ilast, ilast+1 ), lda, cl, sl ) IF( ifrstm < ilast-1 ) & CALL srot( ifirst-ifrstm, b( ifrstm, ilast-1 ), 1, & b( ifrstm, ilast ), 1, cr, sr ) ! IF( ilq ) CALL srot( n, q( 1, ilast-1 ), 1, q( 1, ilast ), 1, cl, & sl ) IF( ilz ) CALL srot( n, z( 1, ilast-1 ), 1, z( 1, ilast ), 1, cr, & sr ) ! b( ilast-1, ilast-1 ) = b11 b( ilast-1, ilast ) = zero b( ilast, ilast-1 ) = zero b( ilast, ilast ) = b22 ! ! If B22 is negative, negate column ILAST ! IF( b22 < zero ) THEN DO j = ifrstm, ilast a( j, ilast ) = -a( j, ilast ) b( j, ilast ) = -b( j, ilast ) END DO ! IF( ilz ) THEN DO j = 1, n z( j, ilast ) = -z( j, ilast ) END DO END IF END IF ! ! Step 2: Compute ALPHAR, ALPHAI, and BETA (see refs.) ! ! Recompute shift ! CALL slag2( a( ilast-1, ilast-1 ), lda, & b( ilast-1, ilast-1 ), ldb, safmin*safety, s1, temp, wr, temp2, wi ) ! ! If standardization has perturbed the shift onto real line, ! do another (real single-shift) QR step. ! IF( wi == zero ) GO TO 350 s1inv = one / s1 ! ! Do EISPACK (QZVAL) computation of alpha and beta ! a11 = a( ilast-1, ilast-1 ) a21 = a( ilast, ilast-1 ) a12 = a( ilast-1, ilast ) a22 = a( ilast, ilast ) ! ! Compute complex Givens rotation on right ! (Assume some element of C = (sA - wB) > unfl ) ! __ ! (sA - wB) ( CZ -SZ ) ! ( SZ CZ ) ! c11r = s1*a11 - wr*b11 c11i = -wi*b11 c12 = s1*a12 c21 = s1*a21 c22r = s1*a22 - wr*b22 c22i = -wi*b22 ! IF( ABS( c11r )+ABS( c11i )+ABS( c12 ) > ABS( c21 )+ & ABS( c22r )+ABS( c22i ) ) THEN t = slapy3( c12, c11r, c11i ) cz = c12 / t szr = -c11r / t szi = -c11i / t ELSE cz = slapy2( c22r, c22i ) IF( cz <= safmin ) THEN cz = zero szr = one szi = zero ELSE tempr = c22r / cz tempi = c22i / cz t = slapy2( cz, c21 ) cz = cz / t szr = -c21*tempr / t szi = c21*tempi / t END IF END IF ! ! Compute Givens rotation on left ! ! ( CQ SQ ) ! ( __ ) A or B ! ( -SQ CQ ) ! an = ABS( a11 ) + ABS( a12 ) + ABS( a21 ) + ABS( a22 ) bn = ABS( b11 ) + ABS( b22 ) wabs = ABS( wr ) + ABS( wi ) IF( s1*an > wabs*bn ) THEN cq = cz*b11 sqr = szr*b22 sqi = -szi*b22 ELSE a1r = cz*a11 + szr*a12 a1i = szi*a12 a2r = cz*a21 + szr*a22 a2i = szi*a22 cq = slapy2( a1r, a1i ) IF( cq <= safmin ) THEN cq = zero sqr = one sqi = zero ELSE tempr = a1r / cq tempi = a1i / cq sqr = tempr*a2r + tempi*a2i sqi = tempi*a2r - tempr*a2i END IF END IF t = slapy3( cq, sqr, sqi ) cq = cq / t sqr = sqr / t sqi = sqi / t ! ! Compute diagonal elements of QBZ ! tempr = sqr*szr - sqi*szi tempi = sqr*szi + sqi*szr b1r = cq*cz*b11 + tempr*b22 b1i = tempi*b22 b1a = slapy2( b1r, b1i ) b2r = cq*cz*b22 + tempr*b11 b2i = -tempi*b11 b2a = slapy2( b2r, b2i ) ! ! Normalize so beta > 0, and Im( alpha1 ) > 0 ! beta( ilast-1 ) = b1a beta( ilast ) = b2a alphar( ilast-1 ) = ( wr*b1a )*s1inv alphai( ilast-1 ) = ( wi*b1a )*s1inv alphar( ilast ) = ( wr*b2a )*s1inv alphai( ilast ) = -( wi*b2a )*s1inv ! ! Step 3: Go to next block -- exit if finished. ! ilast = ifirst - 1 IF( ilast < ilo ) GO TO 380 ! ! Reset counters ! iiter = 0 eshift = zero IF( .NOT.ilschr ) THEN ilastm = ilast IF( ifrstm > ilast ) ifrstm = ilo END IF GO TO 350 ELSE ! ! Usual case: 3x3 or larger block, using Francis implicit ! double-shift ! ! 2 ! Eigenvalue equation is w - c w + d = 0, ! ! -1 2 -1 ! so compute 1st column of (A B ) - c A B + d ! using the formula in QZIT (from EISPACK) ! ! We assume that the block is at least 3x3 ! ad11 = ( ascale*a( ilast-1, ilast-1 ) ) / ( bscale*b( ilast-1, ilast-1 ) ) ad21 = ( ascale*a( ilast, ilast-1 ) ) / ( bscale*b( ilast-1, ilast-1 ) ) ad12 = ( ascale*a( ilast-1, ilast ) ) / ( bscale*b( ilast, ilast ) ) ad22 = ( ascale*a( ilast, ilast ) ) / ( bscale*b( ilast, ilast ) ) u12 = b( ilast-1, ilast ) / b( ilast, ilast ) ad11l = ( ascale*a( ifirst, ifirst ) ) / ( bscale*b( ifirst, ifirst ) ) ad21l = ( ascale*a( ifirst+1, ifirst ) ) / ( bscale*b( ifirst, ifirst ) ) ad12l = ( ascale*a( ifirst, ifirst+1 ) ) / & ( bscale*b( ifirst+1, ifirst+1 ) ) ad22l = ( ascale*a( ifirst+1, ifirst+1 ) ) / & ( bscale*b( ifirst+1, ifirst+1 ) ) ad32l = ( ascale*a( ifirst+2, ifirst+1 ) ) / & ( bscale*b( ifirst+1, ifirst+1 ) ) u12l = b( ifirst, ifirst+1 ) / b( ifirst+1, ifirst+1 ) ! v( 1 ) = ( ad11-ad11l )*( ad22-ad11l ) - ad12*ad21 + & ad21*u12*ad11l + ( ad12l-ad11l*u12l )*ad21l v( 2 ) = ( ( ad22l-ad11l )-ad21l*u12l-( ad11-ad11l )- & ( ad22-ad11l )+ad21*u12 )*ad21l v( 3 ) = ad32l*ad21l ! istart = ifirst ! CALL slarfg( 3, v( 1 ), v( 2 ), 1, tau ) v( 1 ) = one ! ! Sweep ! DO j = istart, ilast - 2 ! ! All but last elements: use 3x3 Householder transforms. ! ! Zero (j-1)st column of A ! IF( j > istart ) THEN v( 1 ) = a( j, j-1 ) v( 2 ) = a( j+1, j-1 ) v( 3 ) = a( j+2, j-1 ) ! CALL slarfg( 3, a( j, j-1 ), v( 2 ), 1, tau ) v( 1 ) = one a( j+1, j-1 ) = zero a( j+2, j-1 ) = zero END IF ! DO jc = j, ilastm temp = tau*( a( j, jc )+v( 2 )*a( j+1, jc )+v( 3 )* a( j+2, jc ) ) a( j, jc ) = a( j, jc ) - temp a( j+1, jc ) = a( j+1, jc ) - temp*v( 2 ) a( j+2, jc ) = a( j+2, jc ) - temp*v( 3 ) temp2 = tau*( b( j, jc )+v( 2 )*b( j+1, jc )+v( 3 )* b( j+2, jc ) ) b( j, jc ) = b( j, jc ) - temp2 b( j+1, jc ) = b( j+1, jc ) - temp2*v( 2 ) b( j+2, jc ) = b( j+2, jc ) - temp2*v( 3 ) END DO IF( ilq ) THEN DO jr = 1, n temp = tau*( q( jr, j )+v( 2 )*q( jr, j+1 )+v( 3 )* q( jr, j+2 ) ) q( jr, j ) = q( jr, j ) - temp q( jr, j+1 ) = q( jr, j+1 ) - temp*v( 2 ) q( jr, j+2 ) = q( jr, j+2 ) - temp*v( 3 ) END DO END IF ! ! Zero j-th column of B (see SLAGBC for details) ! ! Swap rows to pivot ! ilpivt = .false. temp = MAX( ABS( b( j+1, j+1 ) ), ABS( b( j+1, j+2 ) ) ) temp2 = MAX( ABS( b( j+2, j+1 ) ), ABS( b( j+2, j+2 ) ) ) IF( MAX( temp, temp2 ) < safmin ) THEN scale = zero u1 = one u2 = zero GO TO 250 ELSE IF( temp >= temp2 ) THEN w11 = b( j+1, j+1 ) w21 = b( j+2, j+1 ) w12 = b( j+1, j+2 ) w22 = b( j+2, j+2 ) u1 = b( j+1, j ) u2 = b( j+2, j ) ELSE w21 = b( j+1, j+1 ) w11 = b( j+2, j+1 ) w22 = b( j+1, j+2 ) w12 = b( j+2, j+2 ) u2 = b( j+1, j ) u1 = b( j+2, j ) END IF ! ! Swap columns if nec. ! IF( ABS( w12 ) > ABS( w11 ) ) THEN ilpivt = .true. temp = w12 temp2 = w22 w12 = w11 w22 = w21 w11 = temp w21 = temp2 END IF ! ! LU-factor ! temp = w21 / w11 u2 = u2 - temp*u1 w22 = w22 - temp*w12 w21 = zero ! ! Compute SCALE ! scale = one IF( ABS( w22 ) < safmin ) THEN scale = zero u2 = one u1 = -w12 / w11 GO TO 250 END IF IF( ABS( w22 ) < ABS( u2 ) ) scale = ABS( w22 / u2 ) IF( ABS( w11 ) < ABS( u1 ) ) scale = MIN( scale, ABS( w11 / u1 ) ) ! ! Solve ! u2 = ( scale*u2 ) / w22 u1 = ( scale*u1-w12*u2 ) / w11 ! 250 CONTINUE IF( ilpivt ) THEN temp = u2 u2 = u1 u1 = temp END IF ! ! Compute Householder Vector ! t = SQRT( scale**2+u1**2+u2**2 ) tau = one + scale / t vs = -one / ( scale+t ) v( 1 ) = one v( 2 ) = vs*u1 v( 3 ) = vs*u2 ! ! Apply transformations from the right. ! DO jr = ifrstm, MIN( j+3, ilast ) temp = tau*( a( jr, j )+v( 2 )*a( jr, j+1 )+v( 3 )* a( jr, j+2 ) ) a( jr, j ) = a( jr, j ) - temp a( jr, j+1 ) = a( jr, j+1 ) - temp*v( 2 ) a( jr, j+2 ) = a( jr, j+2 ) - temp*v( 3 ) END DO DO jr = ifrstm, j + 2 temp = tau*( b( jr, j )+v( 2 )*b( jr, j+1 )+v( 3 )* b( jr, j+2 ) ) b( jr, j ) = b( jr, j ) - temp b( jr, j+1 ) = b( jr, j+1 ) - temp*v( 2 ) b( jr, j+2 ) = b( jr, j+2 ) - temp*v( 3 ) END DO IF( ilz ) THEN DO jr = 1, n temp = tau*( z( jr, j )+v( 2 )*z( jr, j+1 )+v( 3 )* z( jr, j+2 ) ) z( jr, j ) = z( jr, j ) - temp z( jr, j+1 ) = z( jr, j+1 ) - temp*v( 2 ) z( jr, j+2 ) = z( jr, j+2 ) - temp*v( 3 ) END DO END IF b( j+1, j ) = zero b( j+2, j ) = zero END DO ! ! Last elements: Use Givens rotations ! ! Rotations from the left ! j = ilast - 1 temp = a( j, j-1 ) CALL slartg( temp, a( j+1, j-1 ), c, s, a( j, j-1 ) ) a( j+1, j-1 ) = zero ! DO jc = j, ilastm temp = c*a( j, jc ) + s*a( j+1, jc ) a( j+1, jc ) = -s*a( j, jc ) + c*a( j+1, jc ) a( j, jc ) = temp temp2 = c*b( j, jc ) + s*b( j+1, jc ) b( j+1, jc ) = -s*b( j, jc ) + c*b( j+1, jc ) b( j, jc ) = temp2 END DO IF( ilq ) THEN DO jr = 1, n temp = c*q( jr, j ) + s*q( jr, j+1 ) q( jr, j+1 ) = -s*q( jr, j ) + c*q( jr, j+1 ) q( jr, j ) = temp END DO END IF ! ! Rotations from the right. ! temp = b( j+1, j+1 ) CALL slartg( temp, b( j+1, j ), c, s, b( j+1, j+1 ) ) b( j+1, j ) = zero ! DO jr = ifrstm, ilast temp = c*a( jr, j+1 ) + s*a( jr, j ) a( jr, j ) = -s*a( jr, j+1 ) + c*a( jr, j ) a( jr, j+1 ) = temp END DO DO jr = ifrstm, ilast - 1 temp = c*b( jr, j+1 ) + s*b( jr, j ) b( jr, j ) = -s*b( jr, j+1 ) + c*b( jr, j ) b( jr, j+1 ) = temp END DO IF( ilz ) THEN DO jr = 1, n temp = c*z( jr, j+1 ) + s*z( jr, j ) z( jr, j ) = -s*z( jr, j+1 ) + c*z( jr, j ) z( jr, j+1 ) = temp END DO END IF ! ! End of Double-Shift code ! END IF ! GO TO 350 ! ! End of iteration loop ! 350 CONTINUE END DO ! ! Drop-through = non-convergence ! 370 CONTINUE info = ilast GO TO 420 ! ! Successful completion of all QZ steps ! 380 CONTINUE ! ! Set Eigenvalues 1:ILO-1 ! DO j = 1, ilo - 1 IF( b( j, j ) < zero ) THEN IF( ilschr ) THEN DO jr = 1, j a( jr, j ) = -a( jr, j ) b( jr, j ) = -b( jr, j ) END DO ELSE a( j, j ) = -a( j, j ) b( j, j ) = -b( j, j ) END IF IF( ilz ) THEN DO jr = 1, n z( jr, j ) = -z( jr, j ) END DO END IF END IF alphar( j ) = a( j, j ) alphai( j ) = zero beta( j ) = b( j, j ) END DO ! ! Normal Termination ! info = 0 ! ! Exit (other than argument error) -- return optimal workspace size ! 420 CONTINUE work( 1 ) = REAL( n ) RETURN ! ! End of SHGEQZ ! END SUBROUTINE shgeqz SUBROUTINE shsein( side, eigsrc, initv, select, n, h, ldh, wr, wi, & vl, ldvl, vr, ldvr, mm, m, work, ifaill, ifailr, 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 (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: eigsrc CHARACTER (LEN=1), INTENT(IN) :: initv LOGICAL, INTENT(OUT) :: select( * ) INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: h( ldh, * ) INTEGER, INTENT(IN) :: ldh REAL, INTENT(IN OUT) :: wr( * ) REAL, INTENT(IN) :: wi( * ) REAL, INTENT(OUT) :: vl( ldvl, * ) INTEGER, INTENT(IN OUT) :: ldvl REAL, INTENT(OUT) :: vr( ldvr, * ) INTEGER, INTENT(IN OUT) :: ldvr INTEGER, INTENT(IN OUT) :: mm INTEGER, INTENT(OUT) :: m REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(OUT) :: ifaill( * ) INTEGER, INTENT(OUT) :: ifailr( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SHSEIN uses inverse iteration to find specified right and/or left ! eigenvectors of a real upper Hessenberg matrix H. ! ! The right eigenvector x and the left eigenvector y of the matrix H ! corresponding to an eigenvalue w are defined by: ! ! H * x = w * x, y**h * H = w * y**h ! ! where y**h denotes the conjugate transpose of the vector y. ! ! Arguments ! ========= ! ! SIDE (input) CHARACTER*1 ! = 'R': compute right eigenvectors only; ! = 'L': compute left eigenvectors only; ! = 'B': compute both right and left eigenvectors. ! ! EIGSRC (input) CHARACTER*1 ! Specifies the source of eigenvalues supplied in (WR,WI): ! = 'Q': the eigenvalues were found using SHSEQR; thus, if ! H has zero subdiagonal elements, and so is ! block-triangular, then the j-th eigenvalue can be ! assumed to be an eigenvalue of the block containing ! the j-th row/column. This property allows SHSEIN to ! perform inverse iteration on just one diagonal block. ! = 'N': no assumptions are made on the correspondence ! between eigenvalues and diagonal blocks. In this ! case, SHSEIN must always perform inverse iteration ! using the whole matrix H. ! ! INITV (input) CHARACTER*1 ! = 'N': no initial vectors are supplied; ! = 'U': user-supplied initial vectors are stored in the arrays ! VL and/or VR. ! ! SELECT (input/output) LOGICAL array, dimension (N) ! Specifies the eigenvectors to be computed. To select the ! real eigenvector corresponding to a real eigenvalue WR(j), ! SELECT(j) must be set to .TRUE.. To select the complex ! eigenvector corresponding to a complex eigenvalue ! (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)), ! either SELECT(j) or SELECT(j+1) or both must be set to ! .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is ! .FALSE.. ! ! N (input) INTEGER ! The order of the matrix H. N >= 0. ! ! H (input) REAL array, dimension (LDH,N) ! The upper Hessenberg matrix H. ! ! LDH (input) INTEGER ! The leading dimension of the array H. LDH >= max(1,N). ! ! WR (input/output) REAL array, dimension (N) ! WI (input) REAL array, dimension (N) ! On entry, the real and imaginary parts of the eigenvalues of ! H; a complex conjugate pair of eigenvalues must be stored in ! consecutive elements of WR and WI. ! On exit, WR may have been altered since close eigenvalues ! are perturbed slightly in searching for independent ! eigenvectors. ! ! VL (input/output) REAL array, dimension (LDVL,MM) ! On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must ! contain starting vectors for the inverse iteration for the ! left eigenvectors; the starting vector for each eigenvector ! must be in the same column(s) in which the eigenvector will ! be stored. ! On exit, if SIDE = 'L' or 'B', the left eigenvectors ! specified by SELECT will be stored consecutively in the ! columns of VL, in the same order as their eigenvalues. A ! complex eigenvector corresponding to a complex eigenvalue is ! stored in two consecutive columns, the first holding the real ! part and the second the imaginary part. ! If SIDE = 'R', VL is not referenced. ! ! LDVL (input) INTEGER ! The leading dimension of the array VL. ! LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. ! ! VR (input/output) REAL array, dimension (LDVR,MM) ! On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must ! contain starting vectors for the inverse iteration for the ! right eigenvectors; the starting vector for each eigenvector ! must be in the same column(s) in which the eigenvector will ! be stored. ! On exit, if SIDE = 'R' or 'B', the right eigenvectors ! specified by SELECT will be stored consecutively in the ! columns of VR, in the same order as their eigenvalues. A ! complex eigenvector corresponding to a complex eigenvalue is ! stored in two consecutive columns, the first holding the real ! part and the second the imaginary part. ! 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 required to ! store the eigenvectors; each selected real eigenvector ! occupies one column and each selected complex eigenvector ! occupies two columns. ! ! WORK (workspace) REAL array, dimension ((N+2)*N) ! ! IFAILL (output) INTEGER array, dimension (MM) ! If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left ! eigenvector in the i-th column of VL (corresponding to the ! eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the ! eigenvector converged satisfactorily. If the i-th and (i+1)th ! columns of VL hold a complex eigenvector, then IFAILL(i) and ! IFAILL(i+1) are set to the same value. ! If SIDE = 'R', IFAILL is not referenced. ! ! IFAILR (output) INTEGER array, dimension (MM) ! If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right ! eigenvector in the i-th column of VR (corresponding to the ! eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the ! eigenvector converged satisfactorily. If the i-th and (i+1)th ! columns of VR hold a complex eigenvector, then IFAILR(i) and ! IFAILR(i+1) are set to the same value. ! If SIDE = 'L', IFAILR 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, i is the number of eigenvectors which ! failed to converge; see IFAILL and IFAILR for further ! details. ! ! Further Details ! =============== ! ! Each eigenvector is normalized so that the element of largest ! magnitude has magnitude 1; here the magnitude of a complex number ! (x,y) is taken to be |x|+|y|. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: bothv, fromqr, leftv, noinit, pair, rightv INTEGER :: i, iinfo, k, kl, kln, kr, ksi, ksr, ldwork REAL :: bignum, eps3, hnorm, smlnum, ulp, unfl, wki, wkr ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slanhs EXTERNAL lsame, slamch, slanhs ! .. ! .. External Subroutines .. EXTERNAL slaein, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. Executable Statements .. ! ! Decode and test the input parameters. ! bothv = lsame( side, 'B' ) rightv = lsame( side, 'R' ) .OR. bothv leftv = lsame( side, 'L' ) .OR. bothv ! fromqr = lsame( eigsrc, 'Q' ) ! noinit = lsame( initv, 'N' ) ! ! Set M to the number of columns required to store the selected ! eigenvectors, and standardize the array SELECT. ! m = 0 pair = .false. DO k = 1, n IF( pair ) THEN pair = .false. select( k ) = .false. ELSE IF( wi( k ) == zero ) THEN IF( select( k ) ) m = m + 1 ELSE pair = .true. IF( select( k ) .OR. select( k+1 ) ) THEN select( k ) = .true. m = m + 2 END IF END IF END IF END DO ! info = 0 IF( .NOT.rightv .AND. .NOT.leftv ) THEN info = -1 ELSE IF( .NOT.fromqr .AND. .NOT.lsame( eigsrc, 'N' ) ) THEN info = -2 ELSE IF( .NOT.noinit .AND. .NOT.lsame( initv, 'U' ) ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -5 ELSE IF( ldh < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldvl < 1 .OR. ( leftv .AND. ldvl < n ) ) THEN info = -11 ELSE IF( ldvr < 1 .OR. ( rightv .AND. ldvr < n ) ) THEN info = -13 ELSE IF( mm < m ) THEN info = -14 END IF IF( info /= 0 ) THEN CALL xerbla( 'SHSEIN', -info ) RETURN END IF ! ! Quick return if possible. ! IF( n == 0 ) RETURN ! ! Set machine-dependent constants. ! unfl = slamch( 'Safe minimum' ) ulp = slamch( 'Precision' ) smlnum = unfl*( n / ulp ) bignum = ( one-ulp ) / smlnum ! ldwork = n + 1 ! kl = 1 kln = 0 IF( fromqr ) THEN kr = 0 ELSE kr = n END IF ksr = 1 ! DO k = 1, n IF( select( k ) ) THEN ! ! Compute eigenvector(s) corresponding to W(K). ! IF( fromqr ) THEN ! ! If affiliation of eigenvalues is known, check whether ! the matrix splits. ! ! Determine KL and KR such that 1 <= KL <= K <= KR <= N ! and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or ! KR = N). ! ! Then inverse iteration can be performed with the ! submatrix H(KL:N,KL:N) for a left eigenvector, and with ! the submatrix H(1:KR,1:KR) for a right eigenvector. ! DO i = k, kl + 1, -1 IF( h( i, i-1 ) == zero ) EXIT END DO 30 CONTINUE kl = i IF( k > kr ) THEN DO i = k, n - 1 IF( h( i+1, i ) == zero ) EXIT END DO 50 CONTINUE kr = i END IF END IF ! IF( kl /= kln ) THEN kln = kl ! ! Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it ! has not ben computed before. ! hnorm = slanhs( 'I', kr-kl+1, h( kl, kl ), ldh, work ) IF( hnorm > zero ) THEN eps3 = hnorm*ulp ELSE eps3 = smlnum END IF END IF ! ! Perturb eigenvalue if it is close to any previous ! selected eigenvalues affiliated to the submatrix ! H(KL:KR,KL:KR). Close roots are modified by EPS3. ! wkr = wr( k ) wki = wi( k ) 60 CONTINUE DO i = k - 1, kl, -1 IF( select( i ) .AND. ABS( wr( i )-wkr )+ & ABS( wi( i )-wki ) < eps3 ) THEN wkr = wkr + eps3 GO TO 60 END IF END DO wr( k ) = wkr ! pair = wki /= zero IF( pair ) THEN ksi = ksr + 1 ELSE ksi = ksr END IF IF( leftv ) THEN ! ! Compute left eigenvector. ! CALL slaein( .false., noinit, n-kl+1, h( kl, kl ), ldh, & wkr, wki, vl( kl, ksr ), vl( kl, ksi ), & work, ldwork, work( n*n+n+1 ), eps3, smlnum, bignum, iinfo ) IF( iinfo > 0 ) THEN IF( pair ) THEN info = info + 2 ELSE info = info + 1 END IF ifaill( ksr ) = k ifaill( ksi ) = k ELSE ifaill( ksr ) = 0 ifaill( ksi ) = 0 END IF DO i = 1, kl - 1 vl( i, ksr ) = zero END DO IF( pair ) THEN DO i = 1, kl - 1 vl( i, ksi ) = zero END DO END IF END IF IF( rightv ) THEN ! ! Compute right eigenvector. ! CALL slaein( .true., noinit, kr, h, ldh, wkr, wki, & vr( 1, ksr ), vr( 1, ksi ), work, ldwork, & work( n*n+n+1 ), eps3, smlnum, bignum, iinfo ) IF( iinfo > 0 ) THEN IF( pair ) THEN info = info + 2 ELSE info = info + 1 END IF ifailr( ksr ) = k ifailr( ksi ) = k ELSE ifailr( ksr ) = 0 ifailr( ksi ) = 0 END IF DO i = kr + 1, n vr( i, ksr ) = zero END DO IF( pair ) THEN DO i = kr + 1, n vr( i, ksi ) = zero END DO END IF END IF ! IF( pair ) THEN ksr = ksr + 2 ELSE ksr = ksr + 1 END IF END IF END DO ! RETURN ! ! End of SHSEIN ! END SUBROUTINE shsein SUBROUTINE shseqr( job, compz, n, ilo, ihi, h, ldh, wr, wi, z, & ldz, 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 (LEN=1), INTENT(IN) :: job CHARACTER (LEN=1), INTENT(IN) :: compz INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: ilo INTEGER, INTENT(IN) :: ihi REAL, INTENT(IN OUT) :: h( ldh, * ) INTEGER, INTENT(IN) :: ldh REAL, INTENT(OUT) :: wr( * ) REAL, INTENT(OUT) :: wi( * ) REAL, INTENT(IN OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SHSEQR computes the eigenvalues of a real upper Hessenberg matrix H ! and, optionally, the matrices T and Z from the Schur decomposition ! H = Z T Z**T, where T is an upper quasi-triangular matrix (the Schur ! form), and Z is the orthogonal matrix of Schur vectors. ! ! Optionally Z may be postmultiplied into an input orthogonal matrix Q, ! so that this routine can give the Schur factorization of a matrix A ! which has been reduced to the Hessenberg form H by the orthogonal ! matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. ! ! Arguments ! ========= ! ! JOB (input) CHARACTER*1 ! = 'E': compute eigenvalues only; ! = 'S': compute eigenvalues and the Schur form T. ! ! COMPZ (input) CHARACTER*1 ! = 'N': no Schur vectors are computed; ! = 'I': Z is initialized to the unit matrix and the matrix Z ! of Schur vectors of H is returned; ! = 'V': Z must contain an orthogonal matrix Q on entry, and ! the product Q*Z is returned. ! ! N (input) INTEGER ! The order of the matrix H. N >= 0. ! ! ILO (input) INTEGER ! IHI (input) INTEGER ! It is assumed that H 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 SGEBAL, and then passed to SGEHRD ! when the matrix output by SGEBAL is reduced to Hessenberg ! form. Otherwise ILO and IHI should be set to 1 and N ! respectively. ! 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. ! ! H (input/output) REAL array, dimension (LDH,N) ! On entry, the upper Hessenberg matrix H. ! On exit, if JOB = 'S', H contains the upper quasi-triangular ! matrix T from the Schur decomposition (the Schur form); ! 2-by-2 diagonal blocks (corresponding to complex conjugate ! pairs of eigenvalues) are returned in standard form, with ! H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0. If JOB = 'E', ! the contents of H are unspecified on exit. ! ! LDH (input) INTEGER ! The leading dimension of the array H. LDH >= max(1,N). ! ! WR (output) REAL array, dimension (N) ! WI (output) REAL array, dimension (N) ! The real and imaginary parts, respectively, of the computed ! eigenvalues. If two eigenvalues are computed as a complex ! conjugate pair, they are stored in consecutive elements of ! WR and WI, say the i-th and (i+1)th, with WI(i) > 0 and ! WI(i+1) < 0. If JOB = 'S', the eigenvalues are stored in the ! same order as on the diagonal of the Schur form returned in ! H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 ! diagonal block, WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and ! WI(i+1) = -WI(i). ! ! Z (input/output) REAL array, dimension (LDZ,N) ! If COMPZ = 'N': Z is not referenced. ! If COMPZ = 'I': on entry, Z need not be set, and on exit, Z ! contains the orthogonal matrix Z of the Schur vectors of H. ! If COMPZ = 'V': on entry Z must contain an N-by-N matrix Q, ! which is assumed to be equal to the unit matrix except for ! the submatrix Z(ILO:IHI,ILO:IHI); on exit Z contains Q*Z. ! Normally Q is the orthogonal matrix generated by SORGHR after ! the call to SGEHRD which formed the Hessenberg matrix H. ! ! LDZ (input) INTEGER ! The leading dimension of the array Z. ! LDZ >= max(1,N) if COMPZ = 'I' or 'V'; LDZ >= 1 otherwise. ! ! WORK (workspace/output) REAL 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. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! > 0: if INFO = i, SHSEQR failed to compute all of the ! eigenvalues in a total of 30*(IHI-ILO+1) iterations; ! elements 1:ilo-1 and i+1:n of WR and WI contain those ! eigenvalues which have been successfully computed. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 REAL, PARAMETER :: const = 1.5E+0 INTEGER, PARAMETER :: nsmax = 15 INTEGER, PARAMETER :: lds = nsmax ! .. ! .. Local Scalars .. LOGICAL :: initz, lquery, wantt, wantz INTEGER :: i, i1, i2, ierr, ii, itemp, itn, its, j, k, l, maxb, nh, nr, ns, nv REAL :: absw, ovfl, smlnum, tau, temp, tst1, ulp, unfl ! .. ! .. Local Arrays .. REAL :: s( lds, nsmax ), v( nsmax+1 ), vv( nsmax+1 ) ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv, isamax REAL :: slamch, slanhs, slapy2 EXTERNAL lsame, ilaenv, isamax, slamch, slanhs, slapy2 ! .. ! .. External Subroutines .. EXTERNAL scopy, sgemv, slabad, slacpy, slahqr, slarfg, & slarfx, slaset, sscal, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. Executable Statements .. ! ! Decode and test the input parameters ! wantt = lsame( job, 'S' ) initz = lsame( compz, 'I' ) wantz = initz .OR. lsame( compz, 'V' ) ! info = 0 work( 1 ) = MAX( 1, n ) lquery = ( lwork == -1 ) IF( .NOT.lsame( job, 'E' ) .AND. .NOT.wantt ) THEN info = -1 ELSE IF( .NOT.lsame( compz, 'N' ) .AND. .NOT.wantz ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( ilo < 1 .OR. ilo > MAX( 1, n ) ) THEN info = -4 ELSE IF( ihi < MIN( ilo, n ) .OR. ihi > n ) THEN info = -5 ELSE IF( ldh < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldz < 1 .OR. wantz .AND. ldz < MAX( 1, n ) ) THEN info = -11 ELSE IF( lwork < MAX( 1, n ) .AND. .NOT.lquery ) THEN info = -13 END IF IF( info /= 0 ) THEN CALL xerbla( 'SHSEQR', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Initialize Z, if necessary ! IF( initz ) CALL slaset( 'Full', n, n, zero, one, z, ldz ) ! ! Store the eigenvalues isolated by SGEBAL. ! DO i = 1, ilo - 1 wr( i ) = h( i, i ) wi( i ) = zero END DO DO i = ihi + 1, n wr( i ) = h( i, i ) wi( i ) = zero END DO ! ! Quick return if possible. ! IF( n == 0 ) RETURN IF( ilo == ihi ) THEN wr( ilo ) = h( ilo, ilo ) wi( ilo ) = zero RETURN END IF ! ! Set rows and columns ILO to IHI to zero below the first ! subdiagonal. ! DO j = ilo, ihi - 2 DO i = j + 2, n h( i, j ) = zero END DO END DO nh = ihi - ilo + 1 ! ! Determine the order of the multi-shift QR algorithm to be used. ! ns = ilaenv( 4, 'SHSEQR', job // compz, n, ilo, ihi, -1 ) maxb = ilaenv( 8, 'SHSEQR', job // compz, n, ilo, ihi, -1 ) IF( ns <= 2 .OR. ns > nh .OR. maxb >= nh ) THEN ! ! Use the standard double-shift algorithm ! CALL slahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, ilo, & ihi, z, ldz, info ) RETURN END IF maxb = MAX( 3, maxb ) ns = MIN( ns, maxb, nsmax ) ! ! Now 2 < NS <= MAXB < NH. ! ! Set machine-dependent constants for the stopping criterion. ! If norm(H) <= sqrt(OVFL), overflow should not occur. ! unfl = slamch( 'Safe minimum' ) ovfl = one / unfl CALL slabad( unfl, ovfl ) ulp = slamch( 'Precision' ) smlnum = unfl*( nh / ulp ) ! ! I1 and I2 are the indices of the first row and last column of H ! to which transformations must be applied. If eigenvalues only are ! being computed, I1 and I2 are set inside the main loop. ! IF( wantt ) THEN i1 = 1 i2 = n END IF ! ! ITN is the total number of multiple-shift QR iterations allowed. ! itn = 30*nh ! ! The main loop begins here. I is the loop index and decreases from ! IHI to ILO in steps of at most MAXB. Each iteration of the loop ! works with the active submatrix in rows and columns L to I. ! Eigenvalues I+1 to IHI have already converged. Either L = ILO or ! H(L,L-1) is negligible so that the matrix splits. ! i = ihi 50 CONTINUE l = ilo IF( i < ilo ) GO TO 170 ! ! Perform multiple-shift QR iterations on rows and columns ILO to I ! until a submatrix of order at most MAXB splits off at the bottom ! because a subdiagonal element has become negligible. ! DO its = 0, itn ! ! Look for a single small subdiagonal element. ! DO k = i, l + 1, -1 tst1 = ABS( h( k-1, k-1 ) ) + ABS( h( k, k ) ) IF( tst1 == zero ) tst1 = slanhs( '1', i-l+1, h( l, l ), ldh, work ) IF( ABS( h( k, k-1 ) ) <= MAX( ulp*tst1, smlnum ) ) EXIT END DO 70 CONTINUE l = k IF( l > ilo ) THEN ! ! H(L,L-1) is negligible. ! h( l, l-1 ) = zero END IF ! ! Exit from loop if a submatrix of order <= MAXB has split off. ! IF( l >= i-maxb+1 ) GO TO 160 ! ! Now the active submatrix is in rows and columns L to I. If ! eigenvalues only are being computed, only the active submatrix ! need be transformed. ! IF( .NOT.wantt ) THEN i1 = l i2 = i END IF ! IF( its == 20 .OR. its == 30 ) THEN ! ! Exceptional shifts. ! DO ii = i - ns + 1, i wr( ii ) = const*( ABS( h( ii, ii-1 ) )+ ABS( h( ii, ii ) ) ) wi( ii ) = zero END DO ELSE ! ! Use eigenvalues of trailing submatrix of order NS as shifts. ! CALL slacpy( 'Full', ns, ns, h( i-ns+1, i-ns+1 ), ldh, s, lds ) CALL slahqr( .false., .false., ns, 1, ns, s, lds, & wr( i-ns+1 ), wi( i-ns+1 ), 1, ns, z, ldz, ierr ) IF( ierr > 0 ) THEN ! ! If SLAHQR failed to compute all NS eigenvalues, use the ! unconverged diagonal elements as the remaining shifts. ! DO ii = 1, ierr wr( i-ns+ii ) = s( ii, ii ) wi( i-ns+ii ) = zero END DO END IF END IF ! ! Form the first column of (G-w(1)) (G-w(2)) . . . (G-w(ns)) ! where G is the Hessenberg submatrix H(L:I,L:I) and w is ! the vector of shifts (stored in WR and WI). The result is ! stored in the local array V. ! v( 1 ) = one DO ii = 2, ns + 1 v( ii ) = zero END DO nv = 1 DO j = i - ns + 1, i IF( wi( j ) >= zero ) THEN IF( wi( j ) == zero ) THEN ! ! real shift ! CALL scopy( nv+1, v, 1, vv, 1 ) CALL sgemv( 'No transpose', nv+1, nv, one, h( l, l ), & ldh, vv, 1, -wr( j ), v, 1 ) nv = nv + 1 ELSE IF( wi( j ) > zero ) THEN ! ! complex conjugate pair of shifts ! CALL scopy( nv+1, v, 1, vv, 1 ) CALL sgemv( 'No transpose', nv+1, nv, one, h( l, l ), & ldh, v, 1, -two*wr( j ), vv, 1 ) itemp = isamax( nv+1, vv, 1 ) temp = one / MAX( ABS( vv( itemp ) ), smlnum ) CALL sscal( nv+1, temp, vv, 1 ) absw = slapy2( wr( j ), wi( j ) ) temp = ( temp*absw )*absw CALL sgemv( 'No transpose', nv+2, nv+1, one, & h( l, l ), ldh, vv, 1, temp, v, 1 ) nv = nv + 2 END IF ! ! Scale V(1:NV) so that max(abs(V(i))) = 1. If V is zero, ! reset it to the unit vector. ! itemp = isamax( nv, v, 1 ) temp = ABS( v( itemp ) ) IF( temp == zero ) THEN v( 1 ) = one DO ii = 2, nv v( ii ) = zero END DO ELSE temp = MAX( temp, smlnum ) CALL sscal( nv, one / temp, v, 1 ) END IF END IF END DO ! ! Multiple-shift QR step ! DO k = l, i - 1 ! ! The first iteration of this loop determines a reflection G ! from the vector V and applies it from left and right to H, ! thus creating a nonzero bulge below the subdiagonal. ! ! Each subsequent iteration determines a reflection G to ! restore the Hessenberg form in the (K-1)th column, and thus ! chases the bulge one step toward the bottom of the active ! submatrix. NR is the order of G. ! nr = MIN( ns+1, i-k+1 ) IF( k > l ) CALL scopy( nr, h( k, k-1 ), 1, v, 1 ) CALL slarfg( nr, v( 1 ), v( 2 ), 1, tau ) IF( k > l ) THEN h( k, k-1 ) = v( 1 ) DO ii = k + 1, i h( ii, k-1 ) = zero END DO END IF v( 1 ) = one ! ! Apply G from the left to transform the rows of the matrix in ! columns K to I2. ! CALL slarfx( 'Left', nr, i2-k+1, v, tau, h( k, k ), ldh, work ) ! ! Apply G from the right to transform the columns of the ! matrix in rows I1 to min(K+NR,I). ! CALL slarfx( 'Right', MIN( k+nr, i )-i1+1, nr, v, tau, & h( i1, k ), ldh, work ) ! IF( wantz ) THEN ! ! Accumulate transformations in the matrix Z ! CALL slarfx( 'Right', nh, nr, v, tau, z( ilo, k ), ldz, work ) END IF END DO ! END DO ! ! Failure to converge in remaining number of iterations ! info = i RETURN ! 160 CONTINUE ! ! A submatrix of order <= MAXB in rows and columns L to I has split ! off. Use the double-shift QR algorithm to handle it. ! CALL slahqr( wantt, wantz, n, l, i, h, ldh, wr, wi, ilo, ihi, z, ldz, info ) IF( info > 0 ) RETURN ! ! Decrement number of remaining iterations, and return to start of ! the main loop with a new value of I. ! itn = itn - its i = l - 1 GO TO 50 ! 170 CONTINUE work( 1 ) = MAX( 1, n ) RETURN ! ! End of SHSEQR ! END SUBROUTINE shseqr SUBROUTINE slabad( 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 ! REAL, INTENT(IN OUT) :: small REAL, INTENT(IN OUT) :: large ! .. ! ! Purpose ! ======= ! ! SLABAD takes as input the values computed by SLAMCH 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 SLAMCH. This subroutine is needed because ! SLAMCH does not compensate for poor arithmetic in the upper half of ! the exponent range, as is found on a Cray. ! ! Arguments ! ========= ! ! SMALL (input/output) REAL ! On entry, the underflow threshold as computed by SLAMCH. ! On exit, if LOG10(LARGE) is sufficiently large, the square ! root of SMALL, otherwise unchanged. ! ! LARGE (input/output) REAL ! On entry, the overflow threshold as computed by SLAMCH. ! 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 ) > 2000. ) THEN small = SQRT( small ) large = SQRT( large ) END IF ! RETURN ! ! End of SLABAD ! END SUBROUTINE slabad SUBROUTINE slabrd( 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 ! February 29, 1992 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: nb REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: d( * ) REAL, INTENT(OUT) :: e( * ) REAL, INTENT(IN OUT) :: tauq( * ) REAL, INTENT(IN OUT) :: taup( * ) REAL, INTENT(IN OUT) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(IN OUT) :: y( ldy, * ) INTEGER, INTENT(IN OUT) :: ldy ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLABRD reduces the first NB rows and columns of a real general ! m by n matrix A to upper or lower bidiagonal form by an orthogonal ! 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 SGEBRD ! ! 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) REAL 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 orthogonal ! matrix Q as a product of elementary reflectors; and ! elements above the diagonal in the first NB rows, with the ! array TAUP, represent the orthogonal 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 orthogonal ! 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 orthogonal 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) REAL array, dimension (NB) ! The diagonal elements of the first NB rows and columns of ! the reduced matrix. D(i) = A(i,i). ! ! E (output) REAL array, dimension (NB) ! The off-diagonal elements of the first NB rows and columns of ! the reduced matrix. ! ! TAUQ (output) REAL array dimension (NB) ! The scalar factors of the elementary reflectors which ! represent the orthogonal matrix Q. See Further Details. ! ! TAUP (output) REAL array, dimension (NB) ! The scalar factors of the elementary reflectors which ! represent the orthogonal matrix P. See Further Details. ! ! X (output) REAL 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 >= M. ! ! Y (output) REAL 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 >= 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 real scalars, and v and u are real 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 .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. INTEGER :: i ! .. ! .. External Subroutines .. EXTERNAL sgemv, slarfg, sscal ! .. ! .. Intrinsic Functions .. INTRINSIC MIN ! .. ! .. Executable Statements .. ! ! Quick return if possible ! IF( m <= 0 .OR. n <= 0 ) RETURN ! IF( m >= n ) THEN ! ! Reduce to upper bidiagonal form ! DO i = 1, nb ! ! Update A(i:m,i) ! CALL sgemv( 'No transpose', m-i+1, i-1, -one, a( i, 1 ), & lda, y( i, 1 ), ldy, one, a( i, i ), 1 ) CALL sgemv( '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) ! CALL slarfg( m-i+1, a( i, i ), a( MIN( i+1, m ), i ), 1, tauq( i ) ) d( i ) = a( i, i ) IF( i < n ) THEN a( i, i ) = one ! ! Compute Y(i+1:n,i) ! CALL sgemv( 'Transpose', m-i+1, n-i, one, a( i, i+1 ), & lda, a( i, i ), 1, zero, y( i+1, i ), 1 ) CALL sgemv( 'Transpose', m-i+1, i-1, one, a( i, 1 ), lda, & a( i, i ), 1, zero, y( 1, i ), 1 ) CALL sgemv( 'No transpose', n-i, i-1, -one, y( i+1, 1 ), & ldy, y( 1, i ), 1, one, y( i+1, i ), 1 ) CALL sgemv( 'Transpose', m-i+1, i-1, one, x( i, 1 ), ldx, & a( i, i ), 1, zero, y( 1, i ), 1 ) CALL sgemv( 'Transpose', i-1, n-i, -one, a( 1, i+1 ), & lda, y( 1, i ), 1, one, y( i+1, i ), 1 ) CALL sscal( n-i, tauq( i ), y( i+1, i ), 1 ) ! ! Update A(i,i+1:n) ! CALL sgemv( 'No transpose', n-i, i, -one, y( i+1, 1 ), & ldy, a( i, 1 ), lda, one, a( i, i+1 ), lda ) CALL sgemv( 'Transpose', i-1, n-i, -one, a( 1, i+1 ), & lda, x( i, 1 ), ldx, one, a( i, i+1 ), lda ) ! ! Generate reflection P(i) to annihilate A(i,i+2:n) ! CALL slarfg( n-i, a( i, i+1 ), a( i, MIN( i+2, n ) ), lda, taup( i ) ) e( i ) = a( i, i+1 ) a( i, i+1 ) = one ! ! Compute X(i+1:m,i) ! CALL sgemv( '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 sgemv( 'Transpose', n-i, i, one, y( i+1, 1 ), ldy, & a( i, i+1 ), lda, zero, x( 1, i ), 1 ) CALL sgemv( 'No transpose', m-i, i, -one, a( i+1, 1 ), & lda, x( 1, i ), 1, one, x( i+1, i ), 1 ) CALL sgemv( 'No transpose', i-1, n-i, one, a( 1, i+1 ), & lda, a( i, i+1 ), lda, zero, x( 1, i ), 1 ) CALL sgemv( 'No transpose', m-i, i-1, -one, x( i+1, 1 ), & ldx, x( 1, i ), 1, one, x( i+1, i ), 1 ) CALL sscal( m-i, taup( i ), x( i+1, i ), 1 ) END IF END DO ELSE ! ! Reduce to lower bidiagonal form ! DO i = 1, nb ! ! Update A(i,i:n) ! CALL sgemv( 'No transpose', n-i+1, i-1, -one, y( i, 1 ), & ldy, a( i, 1 ), lda, one, a( i, i ), lda ) CALL sgemv( 'Transpose', i-1, n-i+1, -one, a( 1, i ), lda, & x( i, 1 ), ldx, one, a( i, i ), lda ) ! ! Generate reflection P(i) to annihilate A(i,i+1:n) ! CALL slarfg( n-i+1, a( i, i ), a( i, MIN( i+1, n ) ), lda, taup( i ) ) d( i ) = a( i, i ) IF( i < m ) THEN a( i, i ) = one ! ! Compute X(i+1:m,i) ! CALL sgemv( 'No transpose', m-i, n-i+1, one, a( i+1, i ), & lda, a( i, i ), lda, zero, x( i+1, i ), 1 ) CALL sgemv( 'Transpose', n-i+1, i-1, one, y( i, 1 ), ldy, & a( i, i ), lda, zero, x( 1, i ), 1 ) CALL sgemv( 'No transpose', m-i, i-1, -one, a( i+1, 1 ), & lda, x( 1, i ), 1, one, x( i+1, i ), 1 ) CALL sgemv( 'No transpose', i-1, n-i+1, one, a( 1, i ), & lda, a( i, i ), lda, zero, x( 1, i ), 1 ) CALL sgemv( 'No transpose', m-i, i-1, -one, x( i+1, 1 ), & ldx, x( 1, i ), 1, one, x( i+1, i ), 1 ) CALL sscal( m-i, taup( i ), x( i+1, i ), 1 ) ! ! Update A(i+1:m,i) ! CALL sgemv( 'No transpose', m-i, i-1, -one, a( i+1, 1 ), & lda, y( i, 1 ), ldy, one, a( i+1, i ), 1 ) CALL sgemv( '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) ! CALL slarfg( m-i, a( i+1, i ), a( MIN( i+2, m ), i ), 1, tauq( i ) ) e( i ) = a( i+1, i ) a( i+1, i ) = one ! ! Compute Y(i+1:n,i) ! CALL sgemv( 'Transpose', m-i, n-i, one, a( i+1, i+1 ), & lda, a( i+1, i ), 1, zero, y( i+1, i ), 1 ) CALL sgemv( 'Transpose', m-i, i-1, one, a( i+1, 1 ), lda, & a( i+1, i ), 1, zero, y( 1, i ), 1 ) CALL sgemv( 'No transpose', n-i, i-1, -one, y( i+1, 1 ), & ldy, y( 1, i ), 1, one, y( i+1, i ), 1 ) CALL sgemv( 'Transpose', m-i, i, one, x( i+1, 1 ), ldx, & a( i+1, i ), 1, zero, y( 1, i ), 1 ) CALL sgemv( 'Transpose', i, n-i, -one, a( 1, i+1 ), lda, & y( 1, i ), 1, one, y( i+1, i ), 1 ) CALL sscal( n-i, tauq( i ), y( i+1, i ), 1 ) END IF END DO END IF RETURN ! ! End of SLABRD ! END SUBROUTINE slabrd SUBROUTINE slacon ( n, v, x, isgn, est, kase ) ! ! -- 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 ! INTEGER, INTENT(IN) :: n REAL, INTENT(OUT) :: v( * ) REAL, INTENT(IN OUT) :: x( * ) INTEGER, INTENT(OUT) :: isgn( * ) REAL, INTENT(OUT) :: est INTEGER, INTENT(IN OUT) :: kase ! ! Purpose ! ======= ! ! SLACON estimates the 1-norm of a square, real matrix A. ! Reverse communication is used for evaluating matrix-vector products. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The order of the matrix. N >= 1. ! ! V (workspace) REAL array, dimension (N) ! On the final return, V = A*W, where EST = norm(V)/norm(W) ! (W is not returned). ! ! X (input/output) REAL array, dimension (N) ! On an intermediate return, X should be overwritten by ! A * X, if KASE=1, ! A' * X, if KASE=2, ! and SLACON must be re-called with all the other parameters ! unchanged. ! ! ISGN (workspace) INTEGER array, dimension (N) ! ! EST (output) REAL ! An estimate (a lower bound) for norm(A). ! ! KASE (input/output) INTEGER ! On the initial call to SLACON, KASE should be 0. ! On an intermediate return, KASE will be 1 or 2, indicating ! whether X should be overwritten by A * X or A' * X. ! On the final return from SLACON, KASE will again be 0. ! ! Further Details ! ======= ======= ! ! Contributed by Nick Higham, University of Manchester. ! Originally named SONEST, dated March 16, 1988. ! ! Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of ! a real or complex matrix, with applications to condition estimation", ! ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: itmax = 5 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, iter, j, jlast, jump REAL :: altsgn, estold, temp ! .. ! .. External Functions .. INTEGER :: isamax REAL :: sasum EXTERNAL isamax, sasum ! .. ! .. External Subroutines .. EXTERNAL scopy ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, nint, REAL, SIGN ! .. ! .. Save statement .. SAVE ! .. ! .. Executable Statements .. ! est = 0.0E+00 IF( kase == 0 ) THEN DO i = 1, n x( i ) = one / REAL( n ) END DO kase = 1 jump = 1 RETURN END IF SELECT CASE ( jump ) CASE ( 1) GO TO 20 CASE ( 2) GO TO 40 CASE ( 3) GO TO 70 CASE ( 4) GO TO 110 CASE ( 5) GO TO 140 END SELECT ! ! ................ ENTRY (JUMP = 1) ! FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. ! 20 CONTINUE IF( n == 1 ) THEN v( 1 ) = x( 1 ) est = ABS( v( 1 ) ) ! ... QUIT GO TO 150 END IF est = sasum( n, x, 1 ) ! DO i = 1, n x( i ) = SIGN( one, x( i ) ) isgn( i ) = nint( x( i ) ) END DO kase = 2 jump = 2 RETURN ! ! ................ ENTRY (JUMP = 2) ! FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. ! 40 CONTINUE j = isamax( n, x, 1 ) iter = 2 ! ! MAIN LOOP - ITERATIONS 2,3,...,ITMAX. ! 50 CONTINUE DO i = 1, n x( i ) = zero END DO x( j ) = one kase = 1 jump = 3 RETURN ! ! ................ ENTRY (JUMP = 3) ! X HAS BEEN OVERWRITTEN BY A*X. ! 70 CONTINUE CALL scopy( n, x, 1, v, 1 ) estold = est est = sasum( n, v, 1 ) DO i = 1, n IF( nint( SIGN( one, x( i ) ) ) /= isgn( i ) ) GO TO 90 END DO ! REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. GO TO 120 ! 90 CONTINUE ! TEST FOR CYCLING. IF( est <= estold ) GO TO 120 ! DO i = 1, n x( i ) = SIGN( one, x( i ) ) isgn( i ) = nint( x( i ) ) END DO kase = 2 jump = 4 RETURN ! ! ................ ENTRY (JUMP = 4) ! X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X. ! 110 CONTINUE jlast = j j = isamax( n, x, 1 ) IF( ( x( jlast ) /= ABS( x( j ) ) ) .AND. ( iter < itmax ) ) THEN iter = iter + 1 GO TO 50 END IF ! ! ITERATION COMPLETE. FINAL STAGE. ! 120 CONTINUE altsgn = one DO i = 1, n x( i ) = altsgn*( one+REAL( i-1 ) / REAL( n-1 ) ) altsgn = -altsgn END DO kase = 1 jump = 5 RETURN ! ! ................ ENTRY (JUMP = 5) ! X HAS BEEN OVERWRITTEN BY A*X. ! 140 CONTINUE temp = two*( sasum( n, x, 1 ) / REAL( 3*n ) ) IF( temp > est ) THEN CALL scopy( n, x, 1, v, 1 ) est = temp END IF ! 150 CONTINUE kase = 0 RETURN ! ! End of SLACON ! END SUBROUTINE slacon SUBROUTINE slacpy( 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLACPY 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) REAL 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) REAL 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 j = 1, n DO i = 1, MIN( j, m ) b( i, j ) = a( i, j ) END DO END DO ELSE IF( lsame( uplo, 'L' ) ) THEN DO j = 1, n DO i = j, m b( i, j ) = a( i, j ) END DO END DO ELSE DO j = 1, n DO i = 1, m b( i, j ) = a( i, j ) END DO END DO END IF RETURN ! ! End of SLACPY ! END SUBROUTINE slacpy SUBROUTINE sladiv( 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 .. REAL, INTENT(IN) :: a REAL, INTENT(IN) :: b REAL, INTENT(IN) :: c REAL, INTENT(IN) :: d REAL, INTENT(OUT) :: p REAL, INTENT(OUT) :: q ! .. ! ! Purpose ! ======= ! ! SLADIV 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) REAL ! B (input) REAL ! C (input) REAL ! D (input) REAL ! The scalars a, b, c, and d in the above expression. ! ! P (output) REAL ! Q (output) REAL ! The scalars p and q in the above expression. ! ! ===================================================================== ! ! .. Local Scalars .. REAL :: e, f ! .. ! .. Intrinsic Functions .. INTRINSIC ABS ! .. ! .. Executable Statements .. ! IF( ABS( d ) < 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 SLADIV ! END SUBROUTINE sladiv SUBROUTINE slae2( a, b, c, rt1, rt2 ) ! ! -- 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 .. REAL, INTENT(IN) :: a REAL, INTENT(IN) :: b REAL, INTENT(IN) :: c REAL, INTENT(OUT) :: rt1 REAL, INTENT(OUT) :: rt2 ! .. ! ! Purpose ! ======= ! ! SLAE2 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) REAL ! The (1,1) element of the 2-by-2 matrix. ! ! B (input) REAL ! The (1,2) and (2,1) elements of the 2-by-2 matrix. ! ! C (input) REAL ! The (2,2) element of the 2-by-2 matrix. ! ! RT1 (output) REAL ! The eigenvalue of larger absolute value. ! ! RT2 (output) REAL ! 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 .. REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: half = 0.5E0 ! .. ! .. Local Scalars .. REAL :: 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 ) > ABS( c ) ) THEN acmx = a acmn = c ELSE acmx = c acmn = a END IF IF( adf > ab ) THEN rt = adf*SQRT( one+( ab / adf )**2 ) ELSE IF( adf < ab ) THEN rt = ab*SQRT( one+( adf / ab )**2 ) ELSE ! ! Includes case AB=ADF=0 ! rt = ab*SQRT( two ) END IF IF( sm < 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 > 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 SLAE2 ! END SUBROUTINE slae2 SUBROUTINE slaebz( 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, INTENT(IN) :: ijob INTEGER, INTENT(IN) :: nitmax INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: mmax INTEGER, INTENT(IN) :: minp INTEGER, INTENT(IN) :: nbmin REAL, INTENT(IN) :: abstol REAL, INTENT(IN) :: reltol REAL, INTENT(IN) :: pivmin REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN OUT) :: e( * ) REAL, INTENT(IN) :: e2( * ) INTEGER, INTENT(IN OUT) :: nval( * ) REAL, INTENT(IN OUT) :: ab( mmax, * ) REAL, INTENT(OUT) :: c( * ) INTEGER, INTENT(OUT) :: mout INTEGER, INTENT(OUT) :: nab( mmax, * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAEBZ 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 SLAEBZ 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 SLAEBZ 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) REAL ! 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) REAL ! 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) REAL ! 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) REAL array, dimension (N) ! The diagonal elements of the tridiagonal matrix T. ! ! E (input) REAL array, dimension (N) ! The offdiagonal elements of the tridiagonal matrix T in ! positions 1 through N-1. E(N) is arbitrary. ! ! E2 (input) REAL 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) REAL 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) REAL 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 SLAEBZ 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 SLAEBZ is called. ! ! WORK (workspace) REAL 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, SLAEBZ should have one or ! more initial intervals set up in AB, and SLAEBZ 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. SLAEBZ 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). SLAEBZ 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 .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: half = 1.0E0 / two ! .. ! .. Local Scalars .. INTEGER :: itmp1, itmp2, j, ji, jit, jp, kf, kfnew, kl, klnew REAL :: tmp1, tmp2 ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. Executable Statements .. ! ! Check for Errors ! info = 0 IF( ijob < 1 .OR. ijob > 3 ) THEN info = -1 RETURN END IF ! ! Initialize NAB ! IF( ijob == 1 ) THEN ! ! Compute the number of eigenvalues in the initial intervals. ! mout = 0 !DIR$ NOVECTOR DO ji = 1, minp DO jp = 1, 2 tmp1 = d( 1 ) - ab( ji, jp ) IF( ABS( tmp1 ) < pivmin ) tmp1 = -pivmin nab( ji, jp ) = 0 IF( tmp1 <= zero ) nab( ji, jp ) = 1 ! DO j = 2, n tmp1 = d( j ) - e2( j-1 ) / tmp1 - ab( ji, jp ) IF( ABS( tmp1 ) < pivmin ) tmp1 = -pivmin IF( tmp1 <= zero ) nab( ji, jp ) = nab( ji, jp ) + 1 END DO END DO mout = mout + nab( ji, 2 ) - nab( ji, 1 ) END DO 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 == 2 ) THEN DO ji = 1, minp c( ji ) = half*( ab( ji, 1 )+ab( ji, 2 ) ) END DO END IF ! ! Iteration loop ! DO jit = 1, nitmax ! ! Loop over intervals ! IF( kl-kf+1 >= nbmin .AND. nbmin > 0 ) THEN ! ! Begin of Parallel Version of the loop ! DO 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 ) <= pivmin ) THEN iwork( ji ) = 1 work( ji ) = MIN( work( ji ), -pivmin ) END IF ! DO j = 2, n work( ji ) = d( j ) - e2( j-1 ) / work( ji ) - c( ji ) IF( work( ji ) <= pivmin ) THEN iwork( ji ) = iwork( ji ) + 1 work( ji ) = MIN( work( ji ), -pivmin ) END IF END DO END DO ! IF( ijob <= 2 ) THEN ! ! IJOB=2: Choose all intervals containing eigenvalues. ! klnew = kl DO 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 ) == nab( ji, 2 ) ) THEN ! ! No eigenvalue in the upper interval: ! just use the lower interval. ! ab( ji, 2 ) = c( ji ) ! ELSE IF( iwork( ji ) == 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 <= 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 END DO IF( info /= 0 ) RETURN kl = klnew ELSE ! ! IJOB=3: Binary search. Keep only the interval containing ! w s.t. N(w) = NVAL ! DO ji = kf, kl IF( iwork( ji ) <= nval( ji ) ) THEN ab( ji, 1 ) = c( ji ) nab( ji, 1 ) = iwork( ji ) END IF IF( iwork( ji ) >= nval( ji ) ) THEN ab( ji, 2 ) = c( ji ) nab( ji, 2 ) = iwork( ji ) END IF END DO END IF ! ELSE ! ! End of Parallel Version of the loop ! ! Begin of Serial Version of the loop ! klnew = kl DO ji = kf, kl ! ! Compute N(w), the number of eigenvalues less than w ! tmp1 = c( ji ) tmp2 = d( 1 ) - tmp1 itmp1 = 0 IF( tmp2 <= pivmin ) THEN itmp1 = 1 tmp2 = MIN( tmp2, -pivmin ) END IF ! ! A series of compiler directives to defeat vectorization ! for the next loop ! !$PL$ CMCHAR=' ' !DIR$ NEXTSCALAR !$DIR SCALAR !DIR$ NEXT SCALAR !VD$L NOVECTOR !VD$ NOVECTOR !VDIR NOVECTOR !VOCL LOOP,SCALAR !IBM PREFER SCALAR !$PL$ CMCHAR='*' ! DO j = 2, n tmp2 = d( j ) - e2( j-1 ) / tmp2 - tmp1 IF( tmp2 <= pivmin ) THEN itmp1 = itmp1 + 1 tmp2 = MIN( tmp2, -pivmin ) END IF END DO ! IF( ijob <= 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 == nab( ji, 2 ) ) THEN ! ! No eigenvalue in the upper interval: ! just use the lower interval. ! ab( ji, 2 ) = tmp1 ! ELSE IF( itmp1 == nab( ji, 1 ) ) THEN ! ! No eigenvalue in the lower interval: ! just use the upper interval. ! ab( ji, 1 ) = tmp1 ELSE IF( klnew < 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 <= nval( ji ) ) THEN ab( ji, 1 ) = tmp1 nab( ji, 1 ) = itmp1 END IF IF( itmp1 >= nval( ji ) ) THEN ab( ji, 2 ) = tmp1 nab( ji, 2 ) = itmp1 END IF END IF END DO kl = klnew ! ! End of Serial Version of the loop ! END IF ! ! Check for convergence ! kfnew = kf DO ji = kf, kl tmp1 = ABS( ab( ji, 2 )-ab( ji, 1 ) ) tmp2 = MAX( ABS( ab( ji, 2 ) ), ABS( ab( ji, 1 ) ) ) IF( tmp1 < MAX( abstol, pivmin, reltol*tmp2 ) .OR. & nab( ji, 1 ) >= nab( ji, 2 ) ) THEN ! ! Converged -- Swap with position KFNEW, ! then increment KFNEW ! IF( ji > 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 == 3 ) THEN itmp1 = nval( ji ) nval( ji ) = nval( kfnew ) nval( kfnew ) = itmp1 END IF END IF kfnew = kfnew + 1 END IF END DO kf = kfnew ! ! Choose Midpoints ! DO ji = kf, kl c( ji ) = half*( ab( ji, 1 )+ab( ji, 2 ) ) END DO ! ! If no more intervals to refine, quit. ! IF( kf > kl ) EXIT END DO ! ! Converged ! 140 CONTINUE info = MAX( kl+1-kf, 0 ) mout = kl ! RETURN ! ! End of SLAEBZ ! END SUBROUTINE slaebz SUBROUTINE slaed0( icompq, qsiz, n, d, e, q, ldq, qstore, ldqs, & 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 .. INTEGER, INTENT(IN) :: icompq INTEGER, INTENT(IN OUT) :: qsiz INTEGER, INTENT(IN) :: n REAL, INTENT(OUT) :: d( * ) REAL, INTENT(IN) :: e( * ) REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq REAL, INTENT(IN OUT) :: qstore( ldqs, * ) INTEGER, INTENT(IN OUT) :: ldqs REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAED0 computes all eigenvalues and corresponding eigenvectors of a ! symmetric tridiagonal matrix using the divide and conquer method. ! ! Arguments ! ========= ! ! ICOMPQ (input) INTEGER ! = 0: Compute eigenvalues only. ! = 1: Compute eigenvectors of original dense symmetric matrix ! also. On entry, Q contains the orthogonal matrix used ! to reduce the original matrix to tridiagonal form. ! = 2: Compute eigenvalues and eigenvectors of tridiagonal ! matrix. ! ! QSIZ (input) INTEGER ! The dimension of the orthogonal matrix used to reduce ! the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. ! ! N (input) INTEGER ! The dimension of the symmetric tridiagonal matrix. N >= 0. ! ! D (input/output) REAL array, dimension (N) ! On entry, the main diagonal of the tridiagonal matrix. ! On exit, its eigenvalues. ! ! E (input) REAL array, dimension (N-1) ! The off-diagonal elements of the tridiagonal matrix. ! On exit, E has been destroyed. ! ! Q (input/output) REAL array, dimension (LDQ, N) ! On entry, Q must contain an N-by-N orthogonal matrix. ! If ICOMPQ = 0 Q is not referenced. ! If ICOMPQ = 1 On entry, Q is a subset of the columns of the ! orthogonal matrix used to reduce the full ! matrix to tridiagonal form corresponding to ! the subset of the full matrix which is being ! decomposed at this time. ! If ICOMPQ = 2 On entry, Q will be the identity matrix. ! On exit, Q contains the eigenvectors of the ! tridiagonal matrix. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. If eigenvectors are ! desired, then LDQ >= max(1,N). In any case, LDQ >= 1. ! ! QSTORE (workspace) REAL array, dimension (LDQS, N) ! Referenced only when ICOMPQ = 1. Used to store parts of ! the eigenvector matrix when the updating matrix multiplies ! take place. ! ! LDQS (input) INTEGER ! The leading dimension of the array QSTORE. If ICOMPQ = 1, ! then LDQS >= max(1,N). In any case, LDQS >= 1. ! ! WORK (workspace) REAL array, ! If ICOMPQ = 0 or 1, the dimension of WORK must be at least ! 1 + 3*N + 2*N*lg N + 2*N**2 ! ( lg( N ) = smallest integer k ! such that 2^k >= N ) ! If ICOMPQ = 2, the dimension of WORK must be at least ! 4*N + N**2. ! ! IWORK (workspace) INTEGER array, ! If ICOMPQ = 0 or 1, the dimension of IWORK must be at least ! 6 + 6*N + 5*N*lg N. ! ( lg( N ) = smallest integer k ! such that 2^k >= N ) ! If ICOMPQ = 2, the dimension of IWORK must be at least ! 3 + 5*N. ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: The algorithm failed to compute an eigenvalue while ! working on the submatrix lying in rows and columns ! INFO/(N+1) through mod(INFO,N+1). ! ! Further Details ! =============== ! ! Based on contributions by ! Jeff Rutter, Computer Science Division, University of California ! at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.e0 REAL, PARAMETER :: one = 1.e0 REAL, PARAMETER :: two = 2.e0 ! .. ! .. Local Scalars .. INTEGER :: curlvl, curprb, curr, i, igivcl, igivnm, & igivpt, indxq, iperm, iprmpt, iq, iqptr, iwrem, & j, k, lgn, matsiz, msd2, smlsiz, smm1, spm1, spm2, submat, subpbs, tlvls REAL :: temp ! .. ! .. External Subroutines .. EXTERNAL scopy, sgemm, slacpy, slaed1, slaed7, ssteqr, xerbla ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX, REAL ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( icompq < 0 .OR. icompq > 2 ) THEN info = -1 ELSE IF( ( icompq == 1 ) .AND. ( qsiz < MAX( 0, n ) ) ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( ldq < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldqs < MAX( 1, n ) ) THEN info = -9 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLAED0', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! smlsiz = ilaenv( 9, 'SLAED0', ' ', 0, 0, 0, 0 ) ! ! Determine the size and placement of the submatrices, and save in ! the leading elements of IWORK. ! iwork( 1 ) = n subpbs = 1 tlvls = 0 10 CONTINUE IF( iwork( subpbs ) > smlsiz ) THEN DO j = subpbs, 1, -1 iwork( 2*j ) = ( iwork( j )+1 ) / 2 iwork( 2*j-1 ) = iwork( j ) / 2 END DO tlvls = tlvls + 1 subpbs = 2*subpbs GO TO 10 END IF DO j = 2, subpbs iwork( j ) = iwork( j ) + iwork( j-1 ) END DO ! ! Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 ! using rank-1 modifications (cuts). ! spm1 = subpbs - 1 DO i = 1, spm1 submat = iwork( i ) + 1 smm1 = submat - 1 d( smm1 ) = d( smm1 ) - ABS( e( smm1 ) ) d( submat ) = d( submat ) - ABS( e( smm1 ) ) END DO ! indxq = 4*n + 3 IF( icompq /= 2 ) THEN ! ! Set up workspaces for eigenvalues only/accumulate new vectors ! routine ! temp = LOG( REAL( n ) ) / LOG( two ) lgn = INT( temp ) IF( 2**lgn < n ) lgn = lgn + 1 IF( 2**lgn < n ) lgn = lgn + 1 iprmpt = indxq + n + 1 iperm = iprmpt + n*lgn iqptr = iperm + n*lgn igivpt = iqptr + n + 2 igivcl = igivpt + n*lgn ! igivnm = 1 iq = igivnm + 2*n*lgn iwrem = iq + n**2 + 1 ! ! Initialize pointers ! DO i = 0, subpbs iwork( iprmpt+i ) = 1 iwork( igivpt+i ) = 1 END DO iwork( iqptr ) = 1 END IF ! ! Solve each submatrix eigenproblem at the bottom of the divide and ! conquer tree. ! curr = 0 DO i = 0, spm1 IF( i == 0 ) THEN submat = 1 matsiz = iwork( 1 ) ELSE submat = iwork( i ) + 1 matsiz = iwork( i+1 ) - iwork( i ) END IF IF( icompq == 2 ) THEN CALL ssteqr( 'I', matsiz, d( submat ), e( submat ), & q( submat, submat ), ldq, work, info ) IF( info /= 0 ) GO TO 130 ELSE CALL ssteqr( 'I', matsiz, d( submat ), e( submat ), & work( iq-1+iwork( iqptr+curr ) ), matsiz, work, info ) IF( info /= 0 ) GO TO 130 IF( icompq == 1 ) THEN CALL sgemm( 'N', 'N', qsiz, matsiz, matsiz, one, & q( 1, submat ), ldq, work( iq-1+iwork( iqptr+ & curr ) ), matsiz, zero, qstore( 1, submat ), ldqs ) END IF iwork( iqptr+curr+1 ) = iwork( iqptr+curr ) + matsiz**2 curr = curr + 1 END IF k = 1 DO j = submat, iwork( i+1 ) iwork( indxq+j ) = k k = k + 1 END DO END DO ! ! Successively merge eigensystems of adjacent submatrices ! into eigensystem for the corresponding larger matrix. ! ! while ( SUBPBS > 1 ) ! curlvl = 1 80 CONTINUE IF( subpbs > 1 ) THEN spm2 = subpbs - 2 DO i = 0, spm2, 2 IF( i == 0 ) THEN submat = 1 matsiz = iwork( 2 ) msd2 = iwork( 1 ) curprb = 0 ELSE submat = iwork( i ) + 1 matsiz = iwork( i+2 ) - iwork( i ) msd2 = matsiz / 2 curprb = curprb + 1 END IF ! ! Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) ! into an eigensystem of size MATSIZ. ! SLAED1 is used only for the full eigensystem of a tridiagonal ! matrix. ! SLAED7 handles the cases in which eigenvalues only or eigenvalues ! and eigenvectors of a full symmetric matrix (which was reduced to ! tridiagonal form) are desired. ! IF( icompq == 2 ) THEN CALL slaed1( matsiz, d( submat ), q( submat, submat ), & ldq, iwork( indxq+submat ), e( submat+msd2-1 ), msd2, work, & iwork( subpbs+1 ), info ) ELSE CALL slaed7( icompq, matsiz, qsiz, tlvls, curlvl, curprb, & d( submat ), qstore( 1, submat ), ldqs, & iwork( indxq+submat ), e( submat+msd2-1 ), & msd2, work( iq ), iwork( iqptr ), iwork( iprmpt ), iwork( iperm ), & iwork( igivpt ), iwork( igivcl ), work( igivnm ), work( iwrem ), & iwork( subpbs+1 ), info ) END IF IF( info /= 0 ) GO TO 130 iwork( i / 2+1 ) = iwork( i+2 ) END DO subpbs = subpbs / 2 curlvl = curlvl + 1 GO TO 80 END IF ! ! end while ! ! Re-merge the eigenvalues/vectors which were deflated at the final ! merge step. ! IF( icompq == 1 ) THEN DO i = 1, n j = iwork( indxq+i ) work( i ) = d( j ) CALL scopy( qsiz, qstore( 1, j ), 1, q( 1, i ), 1 ) END DO CALL scopy( n, work, 1, d, 1 ) ELSE IF( icompq == 2 ) THEN DO i = 1, n j = iwork( indxq+i ) work( i ) = d( j ) CALL scopy( n, q( 1, j ), 1, work( n*i+1 ), 1 ) END DO CALL scopy( n, work, 1, d, 1 ) CALL slacpy( 'A', n, n, work( n+1 ), n, q, ldq ) ELSE DO i = 1, n j = iwork( indxq+i ) work( i ) = d( j ) END DO CALL scopy( n, work, 1, d, 1 ) END IF GO TO 140 ! 130 CONTINUE info = submat*( n+1 ) + submat + matsiz - 1 ! 140 CONTINUE RETURN ! ! End of SLAED0 ! END SUBROUTINE slaed0 SUBROUTINE slaed1( n, d, q, ldq, indxq, rho, cutpnt, 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 .. INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq INTEGER, INTENT(OUT) :: indxq( * ) REAL, INTENT(IN OUT) :: rho INTEGER, INTENT(IN) :: cutpnt REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(IN) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAED1 computes the updated eigensystem of a diagonal ! matrix after modification by a rank-one symmetric matrix. This ! routine is used only for the eigenproblem which requires all ! eigenvalues and eigenvectors of a tridiagonal matrix. SLAED7 handles ! the case in which eigenvalues only or eigenvalues and eigenvectors ! of a full symmetric matrix (which was reduced to tridiagonal form) ! are desired. ! ! T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) ! ! where Z = Q'u, u is a vector of length N with ones in the ! CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. ! ! The eigenvectors of the original matrix are stored in Q, and the ! eigenvalues are in D. The algorithm consists of three stages: ! ! The first stage consists of deflating the size of the problem ! when there are multiple eigenvalues or if there is a zero in ! the Z vector. For each such occurence the dimension of the ! secular equation problem is reduced by one. This stage is ! performed by the routine SLAED2. ! ! The second stage consists of calculating the updated ! eigenvalues. This is done by finding the roots of the secular ! equation via the routine SLAED4 (as called by SLAED3). ! This routine also calculates the eigenvectors of the current ! problem. ! ! The final stage consists of computing the updated eigenvectors ! directly using the updated eigenvalues. The eigenvectors for ! the current problem are multiplied with the eigenvectors from ! the overall problem. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The dimension of the symmetric tridiagonal matrix. N >= 0. ! ! D (input/output) REAL array, dimension (N) ! On entry, the eigenvalues of the rank-1-perturbed matrix. ! On exit, the eigenvalues of the repaired matrix. ! ! Q (input/output) REAL array, dimension (LDQ,N) ! On entry, the eigenvectors of the rank-1-perturbed matrix. ! On exit, the eigenvectors of the repaired tridiagonal matrix. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. LDQ >= max(1,N). ! ! INDXQ (input/output) INTEGER array, dimension (N) ! On entry, the permutation which separately sorts the two ! subproblems in D into ascending order. ! On exit, the permutation which will reintegrate the ! subproblems back into sorted order, ! i.e. D( INDXQ( I = 1, N ) ) will be in ascending order. ! ! RHO (input) REAL ! The subdiagonal entry used to create the rank-1 modification. ! ! CUTPNT (input) INTEGER ! The location of the last eigenvalue in the leading sub-matrix. ! min(1,N) <= CUTPNT <= N/2. ! ! WORK (workspace) REAL array, dimension (4*N + N**2) ! ! IWORK (workspace) INTEGER array, dimension (4*N) ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if INFO = 1, an eigenvalue did not converge ! ! Further Details ! =============== ! ! Based on contributions by ! Jeff Rutter, Computer Science Division, University of California ! at Berkeley, USA ! Modified by Francoise Tisseur, University of Tennessee. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER :: coltyp, cpp1, i, idlmda, indx, indxc, indxp, & iq2, is, iw, iz, k, n1, n2 ! .. ! .. External Subroutines .. EXTERNAL scopy, slaed2, slaed3, slamrg, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( n < 0 ) THEN info = -1 ELSE IF( ldq < MAX( 1, n ) ) THEN info = -4 ELSE IF( MIN( 1, n / 2 ) > cutpnt .OR. ( n / 2 ) < cutpnt ) THEN info = -7 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLAED1', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! The following values are integer pointers which indicate ! the portion of the workspace ! used by a particular array in SLAED2 and SLAED3. ! iz = 1 idlmda = iz + n iw = idlmda + n iq2 = iw + n ! indx = 1 indxc = indx + n coltyp = indxc + n indxp = coltyp + n ! ! ! Form the z-vector which consists of the last row of Q_1 and the ! first row of Q_2. ! CALL scopy( cutpnt, q( cutpnt, 1 ), ldq, work( iz ), 1 ) cpp1 = cutpnt + 1 CALL scopy( n-cutpnt, q( cpp1, cpp1 ), ldq, work( iz+cutpnt ), 1 ) ! ! Deflate eigenvalues. ! CALL slaed2( k, n, cutpnt, d, q, ldq, indxq, rho, work( iz ), & work( idlmda ), work( iw ), work( iq2 ), & iwork( indx ), iwork( indxc ), iwork( indxp ), iwork( coltyp ), info ) ! IF( info /= 0 ) GO TO 20 ! ! Solve Secular Equation. ! IF( k /= 0 ) THEN is = ( iwork( coltyp )+iwork( coltyp+1 ) )*cutpnt + & ( iwork( coltyp+1 )+iwork( coltyp+2 ) )*( n-cutpnt ) + iq2 CALL slaed3( k, n, cutpnt, d, q, ldq, rho, work( idlmda ), & work( iq2 ), iwork( indxc ), iwork( coltyp ), work( iw ), work( is ), info ) IF( info /= 0 ) GO TO 20 ! ! Prepare the INDXQ sorting permutation. ! n1 = k n2 = n - k CALL slamrg( n1, n2, d, 1, -1, indxq ) ELSE DO i = 1, n indxq( i ) = i END DO END IF ! 20 CONTINUE RETURN ! ! End of SLAED1 ! END SUBROUTINE slaed1 SUBROUTINE slaed2( k, n, n1, d, q, ldq, indxq, rho, z, dlamda, w, & q2, indx, indxc, indxp, coltyp, 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, INTENT(OUT) :: k INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: n1 REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq INTEGER, INTENT(OUT) :: indxq( * ) REAL, INTENT(IN OUT) :: rho REAL, INTENT(IN OUT) :: z( * ) REAL, INTENT(OUT) :: dlamda( * ) REAL, INTENT(OUT) :: w( * ) REAL, INTENT(IN OUT) :: q2( * ) INTEGER, INTENT(OUT) :: indx( * ) INTEGER, INTENT(IN OUT) :: indxc( * ) INTEGER, INTENT(OUT) :: indxp( * ) INTEGER, INTENT(OUT) :: coltyp( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAED2 merges the two sets of eigenvalues together into a single ! sorted set. Then it tries to deflate the size of the problem. ! There are two ways in which deflation can occur: when two or more ! eigenvalues are close together or if there is a tiny entry in the ! Z vector. For each such occurrence the order of the related secular ! equation problem is reduced by one. ! ! Arguments ! ========= ! ! K (output) INTEGER ! The number of non-deflated eigenvalues, and the order of the ! related secular equation. 0 <= K <=N. ! ! N (input) INTEGER ! The dimension of the symmetric tridiagonal matrix. N >= 0. ! ! N1 (input) INTEGER ! The location of the last eigenvalue in the leading sub-matrix. ! min(1,N) <= N1 <= N/2. ! ! D (input/output) REAL array, dimension (N) ! On entry, D contains the eigenvalues of the two submatrices to ! be combined. ! On exit, D contains the trailing (N-K) updated eigenvalues ! (those which were deflated) sorted into increasing order. ! ! Q (input/output) REAL array, dimension (LDQ, N) ! On entry, Q contains the eigenvectors of two submatrices in ! the two square blocks with corners at (1,1), (N1,N1) ! and (N1+1, N1+1), (N,N). ! On exit, Q contains the trailing (N-K) updated eigenvectors ! (those which were deflated) in its last N-K columns. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. LDQ >= max(1,N). ! ! INDXQ (input/output) INTEGER array, dimension (N) ! The permutation which separately sorts the two sub-problems ! in D into ascending order. Note that elements in the second ! half of this permutation must first have N1 added to their ! values. Destroyed on exit. ! ! RHO (input/output) REAL ! On entry, the off-diagonal element associated with the rank-1 ! cut which originally split the two submatrices which are now ! being recombined. ! On exit, RHO has been modified to the value required by ! SLAED3. ! ! Z (input) REAL array, dimension (N) ! On entry, Z contains the updating vector (the last ! row of the first sub-eigenvector matrix and the first row of ! the second sub-eigenvector matrix). ! On exit, the contents of Z have been destroyed by the updating ! process. ! ! DLAMDA (output) REAL array, dimension (N) ! A copy of the first K eigenvalues which will be used by ! SLAED3 to form the secular equation. ! ! W (output) REAL array, dimension (N) ! The first k values of the final deflation-altered z-vector ! which will be passed to SLAED3. ! ! Q2 (output) REAL array, dimension (N1**2+(N-N1)**2) ! A copy of the first K eigenvectors which will be used by ! SLAED3 in a matrix multiply (SGEMM) to solve for the new ! eigenvectors. ! ! INDX (workspace) INTEGER array, dimension (N) ! The permutation used to sort the contents of DLAMDA into ! ascending order. ! ! INDXC (output) INTEGER array, dimension (N) ! The permutation used to arrange the columns of the deflated ! Q matrix into three groups: the first group contains non-zero ! elements only at and above N1, the second contains ! non-zero elements only below N1, and the third is dense. ! ! INDXP (workspace) INTEGER array, dimension (N) ! The permutation used to place deflated values of D at the end ! of the array. INDXP(1:K) points to the nondeflated D-values ! and INDXP(K+1:N) points to the deflated eigenvalues. ! ! COLTYP (workspace/output) INTEGER array, dimension (N) ! During execution, a label which will indicate which of the ! following types a column in the Q2 matrix is: ! 1 : non-zero in the upper half only; ! 2 : dense; ! 3 : non-zero in the lower half only; ! 4 : deflated. ! On exit, COLTYP(i) is the number of columns of type i, ! for i=1 to 4 only. ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! ! Further Details ! =============== ! ! Based on contributions by ! Jeff Rutter, Computer Science Division, University of California ! at Berkeley, USA ! Modified by Francoise Tisseur, University of Tennessee. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: mone = -1.0E0 REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: eight = 8.0E0 ! .. ! .. Local Arrays .. INTEGER :: ctot( 4 ), psm( 4 ) ! .. ! .. Local Scalars .. INTEGER :: ct, i, imax, iq1, iq2, j, jmax, js, k2, n1p1, n2, nj, pj REAL :: c, eps, s, t, tau, tol ! .. ! .. External Functions .. INTEGER :: isamax REAL :: slamch, slapy2 EXTERNAL isamax, slamch, slapy2 ! .. ! .. External Subroutines .. EXTERNAL scopy, slacpy, slamrg, srot, sscal, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( n < 0 ) THEN info = -2 ELSE IF( ldq < MAX( 1, n ) ) THEN info = -6 ELSE IF( MIN( 1, ( n / 2 ) ) > n1 .OR. ( n / 2 ) < n1 ) THEN info = -3 END IF IF( info /= 0 ) THEN CALL xerbla( 'LAED2', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! n2 = n - n1 n1p1 = n1 + 1 ! IF( rho < zero ) THEN CALL sscal( n2, mone, z( n1p1 ), 1 ) END IF ! ! Normalize z so that norm(z) = 1. Since z is the concatenation of ! two normalized vectors, norm2(z) = sqrt(2). ! t = one / SQRT( two ) CALL sscal( n, t, z, 1 ) ! ! RHO = ABS( norm(z)**2 * RHO ) ! rho = ABS( two*rho ) ! ! Sort the eigenvalues into increasing order ! DO i = n1p1, n indxq( i ) = indxq( i ) + n1 END DO ! ! re-integrate the deflated parts from the last pass ! DO i = 1, n dlamda( i ) = d( indxq( i ) ) END DO CALL slamrg( n1, n2, dlamda, 1, 1, indxc ) DO i = 1, n indx( i ) = indxq( indxc( i ) ) END DO ! ! Calculate the allowable deflation tolerance ! imax = isamax( n, z, 1 ) jmax = isamax( n, d, 1 ) eps = slamch( 'Epsilon' ) tol = eight*eps*MAX( ABS( d( jmax ) ), ABS( z( imax ) ) ) ! ! If the rank-1 modifier is small enough, no more needs to be done ! except to reorganize Q so that its columns correspond with the ! elements in D. ! IF( rho*ABS( z( imax ) ) <= tol ) THEN k = 0 iq2 = 1 DO j = 1, n i = indx( j ) CALL scopy( n, q( 1, i ), 1, q2( iq2 ), 1 ) dlamda( j ) = d( i ) iq2 = iq2 + n END DO CALL slacpy( 'A', n, n, q2, n, q, ldq ) CALL scopy( n, dlamda, 1, d, 1 ) GO TO 190 END IF ! ! If there are multiple eigenvalues then the problem deflates. Here ! the number of equal eigenvalues are found. As each equal ! eigenvalue is found, an elementary reflector is computed to rotate ! the corresponding eigensubspace so that the corresponding ! components of Z are zero in this new basis. ! DO i = 1, n1 coltyp( i ) = 1 END DO DO i = n1p1, n coltyp( i ) = 3 END DO ! ! k = 0 k2 = n + 1 DO j = 1, n nj = indx( j ) IF( rho*ABS( z( nj ) ) <= tol ) THEN ! ! Deflate due to small z component. ! k2 = k2 - 1 coltyp( nj ) = 4 indxp( k2 ) = nj IF( j == n ) GO TO 100 ELSE pj = nj EXIT END IF END DO 80 CONTINUE j = j + 1 nj = indx( j ) IF( j > n ) GO TO 100 IF( rho*ABS( z( nj ) ) <= tol ) THEN ! ! Deflate due to small z component. ! k2 = k2 - 1 coltyp( nj ) = 4 indxp( k2 ) = nj ELSE ! ! Check if eigenvalues are close enough to allow deflation. ! s = z( pj ) c = z( nj ) ! ! Find sqrt(a**2+b**2) without overflow or ! destructive underflow. ! tau = slapy2( c, s ) t = d( nj ) - d( pj ) c = c / tau s = -s / tau IF( ABS( t*c*s ) <= tol ) THEN ! ! Deflation is possible. ! z( nj ) = tau z( pj ) = zero IF( coltyp( nj ) /= coltyp( pj ) ) coltyp( nj ) = 2 coltyp( pj ) = 4 CALL srot( n, q( 1, pj ), 1, q( 1, nj ), 1, c, s ) t = d( pj )*c**2 + d( nj )*s**2 d( nj ) = d( pj )*s**2 + d( nj )*c**2 d( pj ) = t k2 = k2 - 1 i = 1 90 CONTINUE IF( k2+i <= n ) THEN IF( d( pj ) < d( indxp( k2+i ) ) ) THEN indxp( k2+i-1 ) = indxp( k2+i ) indxp( k2+i ) = pj i = i + 1 GO TO 90 ELSE indxp( k2+i-1 ) = pj END IF ELSE indxp( k2+i-1 ) = pj END IF pj = nj ELSE k = k + 1 dlamda( k ) = d( pj ) w( k ) = z( pj ) indxp( k ) = pj pj = nj END IF END IF GO TO 80 100 CONTINUE ! ! Record the last eigenvalue. ! k = k + 1 dlamda( k ) = d( pj ) w( k ) = z( pj ) indxp( k ) = pj ! ! Count up the total number of the various types of columns, then ! form a permutation which positions the four column types into ! four uniform groups (although one or more of these groups may be ! empty). ! DO j = 1, 4 ctot( j ) = 0 END DO DO j = 1, n ct = coltyp( j ) ctot( ct ) = ctot( ct ) + 1 END DO ! ! PSM(*) = Position in SubMatrix (of types 1 through 4) ! psm( 1 ) = 1 psm( 2 ) = 1 + ctot( 1 ) psm( 3 ) = psm( 2 ) + ctot( 2 ) psm( 4 ) = psm( 3 ) + ctot( 3 ) k = n - ctot( 4 ) ! ! Fill out the INDXC array so that the permutation which it induces ! will place all type-1 columns first, all type-2 columns next, ! then all type-3's, and finally all type-4's. ! DO j = 1, n js = indxp( j ) ct = coltyp( js ) indx( psm( ct ) ) = js indxc( psm( ct ) ) = j psm( ct ) = psm( ct ) + 1 END DO ! ! Sort the eigenvalues and corresponding eigenvectors into DLAMDA ! and Q2 respectively. The eigenvalues/vectors which were not ! deflated go into the first K slots of DLAMDA and Q2 respectively, ! while those which were deflated go into the last N - K slots. ! i = 1 iq1 = 1 iq2 = 1 + ( ctot( 1 )+ctot( 2 ) )*n1 DO j = 1, ctot( 1 ) js = indx( i ) CALL scopy( n1, q( 1, js ), 1, q2( iq1 ), 1 ) z( i ) = d( js ) i = i + 1 iq1 = iq1 + n1 END DO ! DO j = 1, ctot( 2 ) js = indx( i ) CALL scopy( n1, q( 1, js ), 1, q2( iq1 ), 1 ) CALL scopy( n2, q( n1+1, js ), 1, q2( iq2 ), 1 ) z( i ) = d( js ) i = i + 1 iq1 = iq1 + n1 iq2 = iq2 + n2 END DO ! DO j = 1, ctot( 3 ) js = indx( i ) CALL scopy( n2, q( n1+1, js ), 1, q2( iq2 ), 1 ) z( i ) = d( js ) i = i + 1 iq2 = iq2 + n2 END DO ! iq1 = iq2 DO j = 1, ctot( 4 ) js = indx( i ) CALL scopy( n, q( 1, js ), 1, q2( iq2 ), 1 ) iq2 = iq2 + n z( i ) = d( js ) i = i + 1 END DO ! ! The deflated eigenvalues and their corresponding vectors go back ! into the last N - K slots of D and Q respectively. ! CALL slacpy( 'A', n, ctot( 4 ), q2( iq1 ), n, q( 1, k+1 ), ldq ) CALL scopy( n-k, z( k+1 ), 1, d( k+1 ), 1 ) ! ! Copy CTOT into COLTYP for referencing in SLAED3. ! DO j = 1, 4 coltyp( j ) = ctot( j ) END DO ! 190 CONTINUE RETURN ! ! End of SLAED2 ! END SUBROUTINE slaed2 SUBROUTINE slaed3( k, n, n1, d, q, ldq, rho, dlamda, q2, indx, & ctot, w, s, info ) ! ! -- LAPACK routine (version 3.0) -- ! Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, ! Courant Institute, NAG Ltd., and Rice University ! June 30, 1999 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: k INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: n1 REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq REAL, INTENT(IN OUT) :: rho REAL, INTENT(OUT) :: dlamda( * ) REAL, INTENT(IN OUT) :: q2( * ) INTEGER, INTENT(IN) :: indx( * ) INTEGER, INTENT(IN) :: ctot( * ) REAL, INTENT(OUT) :: w( * ) REAL, INTENT(IN OUT) :: s( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAED3 finds the roots of the secular equation, as defined by the ! values in D, W, and RHO, between 1 and K. It makes the ! appropriate calls to SLAED4 and then updates the eigenvectors by ! multiplying the matrix of eigenvectors of the pair of eigensystems ! being combined by the matrix of eigenvectors of the K-by-K system ! which is solved here. ! ! This code makes very mild assumptions about floating point ! arithmetic. It will work on machines with a guard digit in ! add/subtract, or on those binary machines without guard digits ! which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. ! It could conceivably fail on hexadecimal or decimal machines ! without guard digits, but we know of none. ! ! Arguments ! ========= ! ! K (input) INTEGER ! The number of terms in the rational function to be solved by ! SLAED4. K >= 0. ! ! N (input) INTEGER ! The number of rows and columns in the Q matrix. ! N >= K (deflation may result in N>K). ! ! N1 (input) INTEGER ! The location of the last eigenvalue in the leading submatrix. ! min(1,N) <= N1 <= N/2. ! ! D (output) REAL array, dimension (N) ! D(I) contains the updated eigenvalues for ! 1 <= I <= K. ! ! Q (output) REAL array, dimension (LDQ,N) ! Initially the first K columns are used as workspace. ! On output the columns 1 to K contain ! the updated eigenvectors. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. LDQ >= max(1,N). ! ! RHO (input) REAL ! The value of the parameter in the rank one update equation. ! RHO >= 0 required. ! ! DLAMDA (input/output) REAL array, dimension (K) ! The first K elements of this array contain the old roots ! of the deflated updating problem. These are the poles ! of the secular equation. May be changed on output by ! having lowest order bit set to zero on Cray X-MP, Cray Y-MP, ! Cray-2, or Cray C-90, as described above. ! ! Q2 (input) REAL array, dimension (LDQ2, N) ! The first K columns of this matrix contain the non-deflated ! eigenvectors for the split problem. ! ! INDX (input) INTEGER array, dimension (N) ! The permutation used to arrange the columns of the deflated ! Q matrix into three groups (see SLAED2). ! The rows of the eigenvectors found by SLAED4 must be likewise ! permuted before the matrix multiply can take place. ! ! CTOT (input) INTEGER array, dimension (4) ! A count of the total number of the various types of columns ! in Q, as described in INDX. The fourth column type is any ! column which has been deflated. ! ! W (input/output) REAL array, dimension (K) ! The first K elements of this array contain the components ! of the deflation-adjusted updating vector. Destroyed on ! output. ! ! S (workspace) REAL array, dimension (N1 + 1)*K ! Will contain the eigenvectors of the repaired matrix which ! will be multiplied by the previously accumulated eigenvectors ! to update the system. ! ! LDS (input) INTEGER ! The leading dimension of S. LDS >= max(1,K). ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if INFO = 1, an eigenvalue did not converge ! ! Further Details ! =============== ! ! Based on contributions by ! Jeff Rutter, Computer Science Division, University of California ! at Berkeley, USA ! Modified by Francoise Tisseur, University of Tennessee. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: zero = 0.0E0 ! .. ! .. Local Scalars .. INTEGER :: i, ii, iq2, j, n12, n2, n23 REAL :: temp ! .. ! .. External Functions .. REAL :: slamc3, snrm2 EXTERNAL slamc3, snrm2 ! .. ! .. External Subroutines .. EXTERNAL scopy, sgemm, slacpy, slaed4, slaset, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, SIGN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( k < 0 ) THEN info = -1 ELSE IF( n < k ) THEN info = -2 ELSE IF( ldq < MAX( 1, n ) ) THEN info = -6 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLAED3', -info ) RETURN END IF ! ! Quick return if possible ! IF( k == 0 ) RETURN ! ! Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can ! be computed with high relative accuracy (barring over/underflow). ! This is a problem on machines without a guard digit in ! add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). ! The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), ! which on any of these machines zeros out the bottommost ! bit of DLAMDA(I) if it is 1; this makes the subsequent ! subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation ! occurs. On binary machines with a guard digit (almost all ! machines) it does not change DLAMDA(I) at all. On hexadecimal ! and decimal machines with a guard digit, it slightly ! changes the bottommost bits of DLAMDA(I). It does not account ! for hexadecimal or decimal machines without guard digits ! (we know of none). We use a subroutine call to compute ! 2*DLAMBDA(I) to prevent optimizing compilers from eliminating ! this code. ! DO i = 1, k dlamda( i ) = slamc3( dlamda( i ), dlamda( i ) ) - dlamda( i ) END DO ! DO j = 1, k CALL slaed4( k, j, dlamda, w, q( 1, j ), rho, d( j ), info ) ! ! If the zero finder fails, the computation is terminated. ! IF( info /= 0 ) GO TO 120 END DO ! IF( k == 1 ) GO TO 110 IF( k == 2 ) THEN DO j = 1, k w( 1 ) = q( 1, j ) w( 2 ) = q( 2, j ) ii = indx( 1 ) q( 1, j ) = w( ii ) ii = indx( 2 ) q( 2, j ) = w( ii ) END DO GO TO 110 END IF ! ! Compute updated W. ! CALL scopy( k, w, 1, s, 1 ) ! ! Initialize W(I) = Q(I,I) ! CALL scopy( k, q, ldq+1, w, 1 ) DO j = 1, k DO i = 1, j - 1 w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) ) END DO DO i = j + 1, k w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) ) END DO END DO DO i = 1, k w( i ) = SIGN( SQRT( -w( i ) ), s( i ) ) END DO ! ! Compute eigenvectors of the modified rank-1 modification. ! DO j = 1, k DO i = 1, k s( i ) = w( i ) / q( i, j ) END DO temp = snrm2( k, s, 1 ) DO i = 1, k ii = indx( i ) q( i, j ) = s( ii ) / temp END DO END DO ! ! Compute the updated eigenvectors. ! 110 CONTINUE ! n2 = n - n1 n12 = ctot( 1 ) + ctot( 2 ) n23 = ctot( 2 ) + ctot( 3 ) ! CALL slacpy( 'A', n23, k, q( ctot( 1 )+1, 1 ), ldq, s, n23 ) iq2 = n1*n12 + 1 IF( n23 /= 0 ) THEN CALL sgemm( 'N', 'N', n2, k, n23, one, q2( iq2 ), n2, s, n23, & zero, q( n1+1, 1 ), ldq ) ELSE CALL slaset( 'A', n2, k, zero, zero, q( n1+1, 1 ), ldq ) END IF ! CALL slacpy( 'A', n12, k, q, ldq, s, n12 ) IF( n12 /= 0 ) THEN CALL sgemm( 'N', 'N', n1, k, n12, one, q2, n1, s, n12, zero, q, ldq ) ELSE CALL slaset( 'A', n1, k, zero, zero, q( 1, 1 ), ldq ) END IF ! ! 120 CONTINUE RETURN ! ! End of SLAED3 ! END SUBROUTINE slaed3 SUBROUTINE slaed4( n, i, d, z, delta, rho, dlam, info ) ! ! -- LAPACK routine (version 3.0) -- ! Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, ! Courant Institute, NAG Ltd., and Rice University ! September 30, 1994 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: i REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: z( * ) REAL, INTENT(OUT) :: delta( * ) REAL, INTENT(IN) :: rho REAL, INTENT(OUT) :: dlam INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! This subroutine computes the I-th updated eigenvalue of a symmetric ! rank-one modification to a diagonal matrix whose elements are ! given in the array d, and that ! ! D(i) < D(j) for i < j ! ! and that RHO > 0. This is arranged by the calling routine, and is ! no loss in generality. The rank-one modified system is thus ! ! diag( D ) + RHO * Z * Z_transpose. ! ! where we assume the Euclidean norm of Z is 1. ! ! The method consists of approximating the rational functions in the ! secular equation by simpler interpolating rational functions. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The length of all arrays. ! ! I (input) INTEGER ! The index of the eigenvalue to be computed. 1 <= I <= N. ! ! D (input) REAL array, dimension (N) ! The original eigenvalues. It is assumed that they are in ! order, D(I) < D(J) for I < J. ! ! Z (input) REAL array, dimension (N) ! The components of the updating vector. ! ! DELTA (output) REAL array, dimension (N) ! If N .ne. 1, DELTA contains (D(j) - lambda_I) in its j-th ! component. If N = 1, then DELTA(1) = 1. The vector DELTA ! contains the information necessary to construct the ! eigenvectors. ! ! RHO (input) REAL ! The scalar in the symmetric updating formula. ! ! DLAM (output) REAL ! The computed lambda_I, the I-th updated eigenvalue. ! ! INFO (output) INTEGER ! = 0: successful exit ! > 0: if INFO = 1, the updating process failed. ! ! Internal Parameters ! =================== ! ! Logical variable ORGATI (origin-at-i?) is used for distinguishing ! whether D(i) or D(i+1) is treated as the origin. ! ! ORGATI = .true. origin at i ! ORGATI = .false. origin at i+1 ! ! Logical variable SWTCH3 (switch-for-3-poles?) is for noting ! if we are working with THREE poles! ! ! MAXIT is the maximum number of iterations allowed for each ! eigenvalue. ! ! Further Details ! =============== ! ! Based on contributions by ! Ren-Cang Li, Computer Science Division, University of California ! at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: maxit = 20 REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: three = 3.0E0 REAL, PARAMETER :: four = 4.0E0 REAL, PARAMETER :: eight = 8.0E0 REAL, PARAMETER :: ten = 10.0E0 ! .. ! .. Local Scalars .. LOGICAL :: orgati, swtch, swtch3 INTEGER :: ii, iim1, iip1, ip1, iter, j, niter REAL :: a, b, c, del, dphi, dpsi, dw, eps, erretm, eta, & phi, prew, psi, rhoinv, tau, temp, temp1, w ! .. ! .. Local Arrays .. REAL :: zz( 3 ) ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. External Subroutines .. EXTERNAL slaed5, slaed6 ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, SQRT ! .. ! .. Executable Statements .. ! ! Since this routine is called in an inner loop, we do no argument ! checking. ! ! Quick return for N=1 and 2. ! info = 0 IF( n == 1 ) THEN ! ! Presumably, I=1 upon entry ! dlam = d( 1 ) + rho*z( 1 )*z( 1 ) delta( 1 ) = one RETURN END IF IF( n == 2 ) THEN CALL slaed5( i, d, z, delta, rho, dlam ) RETURN END IF ! ! Compute machine epsilon ! eps = slamch( 'Epsilon' ) rhoinv = one / rho ! ! The case I = N ! IF( i == n ) THEN ! ! Initialize some basic variables ! ii = n - 1 niter = 1 ! ! Calculate initial guess ! temp = rho / two ! ! If ||Z||_2 is not one, then TEMP should be set to ! RHO * ||Z||_2^2 / TWO ! DO j = 1, n delta( j ) = ( d( j )-d( i ) ) - temp END DO ! psi = zero DO j = 1, n - 2 psi = psi + z( j )*z( j ) / delta( j ) END DO ! c = rhoinv + psi w = c + z( ii )*z( ii ) / delta( ii ) + z( n )*z( n ) / delta( n ) ! IF( w <= zero ) THEN temp = z( n-1 )*z( n-1 ) / ( d( n )-d( n-1 )+rho ) + z( n )*z( n ) / rho IF( c <= temp ) THEN tau = rho ELSE del = d( n ) - d( n-1 ) a = -c*del + z( n-1 )*z( n-1 ) + z( n )*z( n ) b = z( n )*z( n )*del IF( a < zero ) THEN tau = two*b / ( SQRT( a*a+four*b*c )-a ) ELSE tau = ( a+SQRT( a*a+four*b*c ) ) / ( two*c ) END IF END IF ! ! It can be proved that ! D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO ! ELSE del = d( n ) - d( n-1 ) a = -c*del + z( n-1 )*z( n-1 ) + z( n )*z( n ) b = z( n )*z( n )*del IF( a < zero ) THEN tau = two*b / ( SQRT( a*a+four*b*c )-a ) ELSE tau = ( a+SQRT( a*a+four*b*c ) ) / ( two*c ) END IF ! ! It can be proved that ! D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2 ! END IF ! DO j = 1, n delta( j ) = ( d( j )-d( i ) ) - tau END DO ! ! Evaluate PSI and the derivative DPSI ! dpsi = zero psi = zero erretm = zero DO j = 1, ii temp = z( j ) / delta( j ) psi = psi + z( j )*temp dpsi = dpsi + temp*temp erretm = erretm + psi END DO erretm = ABS( erretm ) ! ! Evaluate PHI and the derivative DPHI ! temp = z( n ) / delta( n ) phi = z( n )*temp dphi = temp*temp erretm = eight*( -phi-psi ) + erretm - phi + rhoinv + & ABS( tau )*( dpsi+dphi ) ! w = rhoinv + phi + psi ! ! Test for convergence ! IF( ABS( w ) <= eps*erretm ) THEN dlam = d( i ) + tau GO TO 250 END IF ! ! Calculate the new step ! niter = niter + 1 c = w - delta( n-1 )*dpsi - delta( n )*dphi a = ( delta( n-1 )+delta( n ) )*w - delta( n-1 )*delta( n )*( dpsi+dphi ) b = delta( n-1 )*delta( n )*w IF( c < zero ) c = ABS( c ) IF( c == zero ) THEN ! ETA = B/A eta = rho - tau ELSE IF( a >= zero ) THEN eta = ( a+SQRT( ABS( a*a-four*b*c ) ) ) / ( two*c ) ELSE eta = two*b / ( a-SQRT( ABS( a*a-four*b*c ) ) ) END IF ! ! Note, eta should be positive if w is negative, and ! eta should be negative otherwise. However, ! if for some reason caused by roundoff, eta*w > 0, ! we simply use one Newton step instead. This way ! will guarantee eta*w < 0. ! IF( w*eta > zero ) eta = -w / ( dpsi+dphi ) temp = tau + eta IF( temp > rho ) eta = rho - tau DO j = 1, n delta( j ) = delta( j ) - eta END DO ! tau = tau + eta ! ! Evaluate PSI and the derivative DPSI ! dpsi = zero psi = zero erretm = zero DO j = 1, ii temp = z( j ) / delta( j ) psi = psi + z( j )*temp dpsi = dpsi + temp*temp erretm = erretm + psi END DO erretm = ABS( erretm ) ! ! Evaluate PHI and the derivative DPHI ! temp = z( n ) / delta( n ) phi = z( n )*temp dphi = temp*temp erretm = eight*( -phi-psi ) + erretm - phi + rhoinv + & ABS( tau )*( dpsi+dphi ) ! w = rhoinv + phi + psi ! ! Main loop to update the values of the array DELTA ! iter = niter + 1 ! DO niter = iter, maxit ! ! Test for convergence ! IF( ABS( w ) <= eps*erretm ) THEN dlam = d( i ) + tau GO TO 250 END IF ! ! Calculate the new step ! c = w - delta( n-1 )*dpsi - delta( n )*dphi a = ( delta( n-1 )+delta( n ) )*w - delta( n-1 )*delta( n )*( dpsi+dphi ) b = delta( n-1 )*delta( n )*w IF( a >= zero ) THEN eta = ( a+SQRT( ABS( a*a-four*b*c ) ) ) / ( two*c ) ELSE eta = two*b / ( a-SQRT( ABS( a*a-four*b*c ) ) ) END IF ! ! Note, eta should be positive if w is negative, and ! eta should be negative otherwise. However, ! if for some reason caused by roundoff, eta*w > 0, ! we simply use one Newton step instead. This way ! will guarantee eta*w < 0. ! IF( w*eta > zero ) eta = -w / ( dpsi+dphi ) temp = tau + eta IF( temp <= zero ) eta = eta / two DO j = 1, n delta( j ) = delta( j ) - eta END DO ! tau = tau + eta ! ! Evaluate PSI and the derivative DPSI ! dpsi = zero psi = zero erretm = zero DO j = 1, ii temp = z( j ) / delta( j ) psi = psi + z( j )*temp dpsi = dpsi + temp*temp erretm = erretm + psi END DO erretm = ABS( erretm ) ! ! Evaluate PHI and the derivative DPHI ! temp = z( n ) / delta( n ) phi = z( n )*temp dphi = temp*temp erretm = eight*( -phi-psi ) + erretm - phi + rhoinv + & ABS( tau )*( dpsi+dphi ) ! w = rhoinv + phi + psi END DO ! ! Return with INFO = 1, NITER = MAXIT and not converged ! info = 1 dlam = d( i ) + tau GO TO 250 ! ! End for the case I = N ! ELSE ! ! The case for I < N ! niter = 1 ip1 = i + 1 ! ! Calculate initial guess ! temp = ( d( ip1 )-d( i ) ) / two DO j = 1, n delta( j ) = ( d( j )-d( i ) ) - temp END DO ! psi = zero DO j = 1, i - 1 psi = psi + z( j )*z( j ) / delta( j ) END DO ! phi = zero DO j = n, i + 2, -1 phi = phi + z( j )*z( j ) / delta( j ) END DO c = rhoinv + psi + phi w = c + z( i )*z( i ) / delta( i ) + z( ip1 )*z( ip1 ) / delta( ip1 ) ! IF( w > zero ) THEN ! ! d(i)< the ith eigenvalue < (d(i)+d(i+1))/2 ! ! We choose d(i) as origin. ! orgati = .true. del = d( ip1 ) - d( i ) a = c*del + z( i )*z( i ) + z( ip1 )*z( ip1 ) b = z( i )*z( i )*del IF( a > zero ) THEN tau = two*b / ( a+SQRT( ABS( a*a-four*b*c ) ) ) ELSE tau = ( a-SQRT( ABS( a*a-four*b*c ) ) ) / ( two*c ) END IF ELSE ! ! (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1) ! ! We choose d(i+1) as origin. ! orgati = .false. del = d( ip1 ) - d( i ) a = c*del - z( i )*z( i ) - z( ip1 )*z( ip1 ) b = z( ip1 )*z( ip1 )*del IF( a < zero ) THEN tau = two*b / ( a-SQRT( ABS( a*a+four*b*c ) ) ) ELSE tau = -( a+SQRT( ABS( a*a+four*b*c ) ) ) / ( two*c ) END IF END IF ! IF( orgati ) THEN DO j = 1, n delta( j ) = ( d( j )-d( i ) ) - tau END DO ELSE DO j = 1, n delta( j ) = ( d( j )-d( ip1 ) ) - tau END DO END IF IF( orgati ) THEN ii = i ELSE ii = i + 1 END IF iim1 = ii - 1 iip1 = ii + 1 ! ! Evaluate PSI and the derivative DPSI ! dpsi = zero psi = zero erretm = zero DO j = 1, iim1 temp = z( j ) / delta( j ) psi = psi + z( j )*temp dpsi = dpsi + temp*temp erretm = erretm + psi END DO erretm = ABS( erretm ) ! ! Evaluate PHI and the derivative DPHI ! dphi = zero phi = zero DO j = n, iip1, -1 temp = z( j ) / delta( j ) phi = phi + z( j )*temp dphi = dphi + temp*temp erretm = erretm + phi END DO ! w = rhoinv + phi + psi ! ! W is the value of the secular function with ! its ii-th element removed. ! swtch3 = .false. IF( orgati ) THEN IF( w < zero ) swtch3 = .true. ELSE IF( w > zero ) swtch3 = .true. END IF IF( ii == 1 .OR. ii == n ) swtch3 = .false. ! temp = z( ii ) / delta( ii ) dw = dpsi + dphi + temp*temp temp = z( ii )*temp w = w + temp erretm = eight*( phi-psi ) + erretm + two*rhoinv + & three*ABS( temp ) + ABS( tau )*dw ! ! Test for convergence ! IF( ABS( w ) <= eps*erretm ) THEN IF( orgati ) THEN dlam = d( i ) + tau ELSE dlam = d( ip1 ) + tau END IF GO TO 250 END IF ! ! Calculate the new step ! niter = niter + 1 IF( .NOT.swtch3 ) THEN IF( orgati ) THEN c = w - delta( ip1 )*dw - ( d( i )-d( ip1 ) )* & ( z( i ) / delta( i ) )**2 ELSE c = w - delta( i )*dw - ( d( ip1 )-d( i ) )* & ( z( ip1 ) / delta( ip1 ) )**2 END IF a = ( delta( i )+delta( ip1 ) )*w - delta( i )*delta( ip1 )*dw b = delta( i )*delta( ip1 )*w IF( c == zero ) THEN IF( a == zero ) THEN IF( orgati ) THEN a = z( i )*z( i ) + delta( ip1 )*delta( ip1 )* ( dpsi+dphi ) ELSE a = z( ip1 )*z( ip1 ) + delta( i )*delta( i )* ( dpsi+dphi ) END IF END IF eta = b / a ELSE IF( a <= zero ) THEN eta = ( a-SQRT( ABS( a*a-four*b*c ) ) ) / ( two*c ) ELSE eta = two*b / ( a+SQRT( ABS( a*a-four*b*c ) ) ) END IF ELSE ! ! Interpolation using THREE most relevant poles ! temp = rhoinv + psi + phi IF( orgati ) THEN temp1 = z( iim1 ) / delta( iim1 ) temp1 = temp1*temp1 c = temp - delta( iip1 )*( dpsi+dphi ) - ( d( iim1 )-d( iip1 ) )*temp1 zz( 1 ) = z( iim1 )*z( iim1 ) zz( 3 ) = delta( iip1 )*delta( iip1 )* ( ( dpsi-temp1 )+dphi ) ELSE temp1 = z( iip1 ) / delta( iip1 ) temp1 = temp1*temp1 c = temp - delta( iim1 )*( dpsi+dphi ) - ( d( iip1 )-d( iim1 ) )*temp1 zz( 1 ) = delta( iim1 )*delta( iim1 )* ( dpsi+( dphi-temp1 ) ) zz( 3 ) = z( iip1 )*z( iip1 ) END IF zz( 2 ) = z( ii )*z( ii ) CALL slaed6( niter, orgati, c, delta( iim1 ), zz, w, eta, info ) IF( info /= 0 ) GO TO 250 END IF ! ! Note, eta should be positive if w is negative, and ! eta should be negative otherwise. However, ! if for some reason caused by roundoff, eta*w > 0, ! we simply use one Newton step instead. This way ! will guarantee eta*w < 0. ! IF( w*eta >= zero ) eta = -w / dw temp = tau + eta del = ( d( ip1 )-d( i ) ) / two IF( orgati ) THEN IF( temp >= del ) eta = del - tau IF( temp <= zero ) eta = eta / two ELSE IF( temp <= -del ) eta = -del - tau IF( temp >= zero ) eta = eta / two END IF ! prew = w ! 170 CONTINUE DO j = 1, n delta( j ) = delta( j ) - eta END DO ! ! Evaluate PSI and the derivative DPSI ! dpsi = zero psi = zero erretm = zero DO j = 1, iim1 temp = z( j ) / delta( j ) psi = psi + z( j )*temp dpsi = dpsi + temp*temp erretm = erretm + psi END DO erretm = ABS( erretm ) ! ! Evaluate PHI and the derivative DPHI ! dphi = zero phi = zero DO j = n, iip1, -1 temp = z( j ) / delta( j ) phi = phi + z( j )*temp dphi = dphi + temp*temp erretm = erretm + phi END DO ! temp = z( ii ) / delta( ii ) dw = dpsi + dphi + temp*temp temp = z( ii )*temp w = rhoinv + phi + psi + temp erretm = eight*( phi-psi ) + erretm + two*rhoinv + & three*ABS( temp ) + ABS( tau+eta )*dw ! swtch = .false. IF( orgati ) THEN IF( -w > ABS( prew ) / ten ) swtch = .true. ELSE IF( w > ABS( prew ) / ten ) swtch = .true. END IF ! tau = tau + eta ! ! Main loop to update the values of the array DELTA ! iter = niter + 1 ! DO niter = iter, maxit ! ! Test for convergence ! IF( ABS( w ) <= eps*erretm ) THEN IF( orgati ) THEN dlam = d( i ) + tau ELSE dlam = d( ip1 ) + tau END IF GO TO 250 END IF ! ! Calculate the new step ! IF( .NOT.swtch3 ) THEN IF( .NOT.swtch ) THEN IF( orgati ) THEN c = w - delta( ip1 )*dw - & ( d( i )-d( ip1 ) )*( z( i ) / delta( i ) )**2 ELSE c = w - delta( i )*dw - ( d( ip1 )-d( i ) )* & ( z( ip1 ) / delta( ip1 ) )**2 END IF ELSE temp = z( ii ) / delta( ii ) IF( orgati ) THEN dpsi = dpsi + temp*temp ELSE dphi = dphi + temp*temp END IF c = w - delta( i )*dpsi - delta( ip1 )*dphi END IF a = ( delta( i )+delta( ip1 ) )*w - delta( i )*delta( ip1 )*dw b = delta( i )*delta( ip1 )*w IF( c == zero ) THEN IF( a == zero ) THEN IF( .NOT.swtch ) THEN IF( orgati ) THEN a = z( i )*z( i ) + delta( ip1 )* delta( ip1 )*( dpsi+dphi ) ELSE a = z( ip1 )*z( ip1 ) + delta( i )*delta( i )*( dpsi+dphi ) END IF ELSE a = delta( i )*delta( i )*dpsi + delta( ip1 )*delta( ip1 )*dphi END IF END IF eta = b / a ELSE IF( a <= zero ) THEN eta = ( a-SQRT( ABS( a*a-four*b*c ) ) ) / ( two*c ) ELSE eta = two*b / ( a+SQRT( ABS( a*a-four*b*c ) ) ) END IF ELSE ! ! Interpolation using THREE most relevant poles ! temp = rhoinv + psi + phi IF( swtch ) THEN c = temp - delta( iim1 )*dpsi - delta( iip1 )*dphi zz( 1 ) = delta( iim1 )*delta( iim1 )*dpsi zz( 3 ) = delta( iip1 )*delta( iip1 )*dphi ELSE IF( orgati ) THEN temp1 = z( iim1 ) / delta( iim1 ) temp1 = temp1*temp1 c = temp - delta( iip1 )*( dpsi+dphi ) - & ( d( iim1 )-d( iip1 ) )*temp1 zz( 1 ) = z( iim1 )*z( iim1 ) zz( 3 ) = delta( iip1 )*delta( iip1 )* ( ( dpsi-temp1 )+dphi ) ELSE temp1 = z( iip1 ) / delta( iip1 ) temp1 = temp1*temp1 c = temp - delta( iim1 )*( dpsi+dphi ) - & ( d( iip1 )-d( iim1 ) )*temp1 zz( 1 ) = delta( iim1 )*delta( iim1 )* ( dpsi+( dphi-temp1 ) ) zz( 3 ) = z( iip1 )*z( iip1 ) END IF END IF CALL slaed6( niter, orgati, c, delta( iim1 ), zz, w, eta, info ) IF( info /= 0 ) GO TO 250 END IF ! ! Note, eta should be positive if w is negative, and ! eta should be negative otherwise. However, ! if for some reason caused by roundoff, eta*w > 0, ! we simply use one Newton step instead. This way ! will guarantee eta*w < 0. ! IF( w*eta >= zero ) eta = -w / dw temp = tau + eta del = ( d( ip1 )-d( i ) ) / two IF( orgati ) THEN IF( temp >= del ) eta = del - tau IF( temp <= zero ) eta = eta / two ELSE IF( temp <= -del ) eta = -del - tau IF( temp >= zero ) eta = eta / two END IF ! DO j = 1, n delta( j ) = delta( j ) - eta END DO ! tau = tau + eta prew = w ! ! Evaluate PSI and the derivative DPSI ! dpsi = zero psi = zero erretm = zero DO j = 1, iim1 temp = z( j ) / delta( j ) psi = psi + z( j )*temp dpsi = dpsi + temp*temp erretm = erretm + psi END DO erretm = ABS( erretm ) ! ! Evaluate PHI and the derivative DPHI ! dphi = zero phi = zero DO j = n, iip1, -1 temp = z( j ) / delta( j ) phi = phi + z( j )*temp dphi = dphi + temp*temp erretm = erretm + phi END DO ! temp = z( ii ) / delta( ii ) dw = dpsi + dphi + temp*temp temp = z( ii )*temp w = rhoinv + phi + psi + temp erretm = eight*( phi-psi ) + erretm + two*rhoinv + & three*ABS( temp ) + ABS( tau )*dw IF( w*prew > zero .AND. ABS( w ) > ABS( prew ) / ten ) swtch = .NOT.swtch ! END DO ! ! Return with INFO = 1, NITER = MAXIT and not converged ! info = 1 IF( orgati ) THEN dlam = d( i ) + tau ELSE dlam = d( ip1 ) + tau END IF ! END IF ! 250 CONTINUE RETURN ! ! End of SLAED4 ! END SUBROUTINE slaed4 SUBROUTINE slaed5( i, d, z, delta, rho, dlam ) ! ! -- LAPACK routine (version 3.0) -- ! Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, ! Courant Institute, NAG Ltd., and Rice University ! September 30, 1994 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: i REAL, INTENT(IN) :: d( 2 ) REAL, INTENT(IN) :: z( 2 ) REAL, INTENT(OUT) :: delta( 2 ) REAL, INTENT(IN) :: rho REAL, INTENT(OUT) :: dlam ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! This subroutine computes the I-th eigenvalue of a symmetric rank-one ! modification of a 2-by-2 diagonal matrix ! ! diag( D ) + RHO * Z * transpose(Z) . ! ! The diagonal elements in the array D are assumed to satisfy ! ! D(i) < D(j) for i < j . ! ! We also assume RHO > 0 and that the Euclidean norm of the vector ! Z is one. ! ! Arguments ! ========= ! ! I (input) INTEGER ! The index of the eigenvalue to be computed. I = 1 or I = 2. ! ! D (input) REAL array, dimension (2) ! The original eigenvalues. We assume D(1) < D(2). ! ! Z (input) REAL array, dimension (2) ! The components of the updating vector. ! ! DELTA (output) REAL array, dimension (2) ! The vector DELTA contains the information necessary ! to construct the eigenvectors. ! ! RHO (input) REAL ! The scalar in the symmetric updating formula. ! ! DLAM (output) REAL ! The computed lambda_I, the I-th updated eigenvalue. ! ! Further Details ! =============== ! ! Based on contributions by ! Ren-Cang Li, Computer Science Division, University of California ! at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: four = 4.0E0 ! .. ! .. Local Scalars .. REAL :: b, c, del, tau, temp, w ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, SQRT ! .. ! .. Executable Statements .. ! del = d( 2 ) - d( 1 ) IF( i == 1 ) THEN w = one + two*rho*( z( 2 )*z( 2 )-z( 1 )*z( 1 ) ) / del IF( w > zero ) THEN b = del + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) ) c = rho*z( 1 )*z( 1 )*del ! ! B > ZERO, always ! tau = two*c / ( b+SQRT( ABS( b*b-four*c ) ) ) dlam = d( 1 ) + tau delta( 1 ) = -z( 1 ) / tau delta( 2 ) = z( 2 ) / ( del-tau ) ELSE b = -del + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) ) c = rho*z( 2 )*z( 2 )*del IF( b > zero ) THEN tau = -two*c / ( b+SQRT( b*b+four*c ) ) ELSE tau = ( b-SQRT( b*b+four*c ) ) / two END IF dlam = d( 2 ) + tau delta( 1 ) = -z( 1 ) / ( del+tau ) delta( 2 ) = -z( 2 ) / tau END IF temp = SQRT( delta( 1 )*delta( 1 )+delta( 2 )*delta( 2 ) ) delta( 1 ) = delta( 1 ) / temp delta( 2 ) = delta( 2 ) / temp ELSE ! ! Now I=2 ! b = -del + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) ) c = rho*z( 2 )*z( 2 )*del IF( b > zero ) THEN tau = ( b+SQRT( b*b+four*c ) ) / two ELSE tau = two*c / ( -b+SQRT( b*b+four*c ) ) END IF dlam = d( 2 ) + tau delta( 1 ) = -z( 1 ) / ( del+tau ) delta( 2 ) = -z( 2 ) / tau temp = SQRT( delta( 1 )*delta( 1 )+delta( 2 )*delta( 2 ) ) delta( 1 ) = delta( 1 ) / temp delta( 2 ) = delta( 2 ) / temp END IF RETURN ! ! End OF SLAED5 ! END SUBROUTINE slaed5 SUBROUTINE slaed6( kniter, orgati, rho, d, z, finit, tau, info ) ! ! -- LAPACK routine (version 3.0) -- ! Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, ! Courant Institute, NAG Ltd., and Rice University ! June 30, 1999 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: kniter LOGICAL, INTENT(IN) :: orgati REAL, INTENT(IN) :: rho REAL, INTENT(IN) :: d( 3 ) REAL, INTENT(IN) :: z( 3 ) REAL, INTENT(IN) :: finit REAL, INTENT(OUT) :: tau INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAED6 computes the positive or negative root (closest to the origin) ! of ! z(1) z(2) z(3) ! f(x) = rho + --------- + ---------- + --------- ! d(1)-x d(2)-x d(3)-x ! ! It is assumed that ! ! if ORGATI = .true. the root is between d(2) and d(3); ! otherwise it is between d(1) and d(2) ! ! This routine will be called by SLAED4 when necessary. In most cases, ! the root sought is the smallest in magnitude, though it might not be ! in some extremely rare situations. ! ! Arguments ! ========= ! ! KNITER (input) INTEGER ! Refer to SLAED4 for its significance. ! ! ORGATI (input) LOGICAL ! If ORGATI is true, the needed root is between d(2) and ! d(3); otherwise it is between d(1) and d(2). See ! SLAED4 for further details. ! ! RHO (input) REAL ! Refer to the equation f(x) above. ! ! D (input) REAL array, dimension (3) ! D satisfies d(1) < d(2) < d(3). ! ! Z (input) REAL array, dimension (3) ! Each of the elements in z must be positive. ! ! FINIT (input) REAL ! The value of f at 0. It is more accurate than the one ! evaluated inside this routine (if someone wants to do ! so). ! ! TAU (output) REAL ! The root of the equation f(x). ! ! INFO (output) INTEGER ! = 0: successful exit ! > 0: if INFO = 1, failure to converge ! ! Further Details ! =============== ! ! Based on contributions by ! Ren-Cang Li, Computer Science Division, University of California ! at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: maxit = 20 REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: three = 3.0E0 REAL, PARAMETER :: four = 4.0E0 REAL, PARAMETER :: eight = 8.0E0 ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. Local Arrays .. REAL :: dscale( 3 ), zscale( 3 ) ! .. ! .. Local Scalars .. LOGICAL :: first, scale INTEGER :: i, iter, niter REAL :: a, b, base, c, ddf, df, eps, erretm, eta, f, & fc, sclfac, sclinv, small1, small2, sminv1, & sminv2, temp, temp1, temp2, temp3, temp4 ! .. ! .. Save statement .. SAVE first, small1, sminv1, small2, sminv2, eps ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT ! .. ! .. Data statements .. DATA first / .true. / ! .. ! .. Executable Statements .. ! info = 0 ! niter = 1 tau = zero IF( kniter == 2 ) THEN IF( orgati ) THEN temp = ( d( 3 )-d( 2 ) ) / two c = rho + z( 1 ) / ( ( d( 1 )-d( 2 ) )-temp ) a = c*( d( 2 )+d( 3 ) ) + z( 2 ) + z( 3 ) b = c*d( 2 )*d( 3 ) + z( 2 )*d( 3 ) + z( 3 )*d( 2 ) ELSE temp = ( d( 1 )-d( 2 ) ) / two c = rho + z( 3 ) / ( ( d( 3 )-d( 2 ) )-temp ) a = c*( d( 1 )+d( 2 ) ) + z( 1 ) + z( 2 ) b = c*d( 1 )*d( 2 ) + z( 1 )*d( 2 ) + z( 2 )*d( 1 ) END IF temp = MAX( ABS( a ), ABS( b ), ABS( c ) ) a = a / temp b = b / temp c = c / temp IF( c == zero ) THEN tau = b / a ELSE IF( a <= zero ) THEN tau = ( a-SQRT( ABS( a*a-four*b*c ) ) ) / ( two*c ) ELSE tau = two*b / ( a+SQRT( ABS( a*a-four*b*c ) ) ) END IF temp = rho + z( 1 ) / ( d( 1 )-tau ) + & z( 2 ) / ( d( 2 )-tau ) + z( 3 ) / ( d( 3 )-tau ) IF( ABS( finit ) <= ABS( temp ) ) tau = zero END IF ! ! On first call to routine, get machine parameters for ! possible scaling to avoid overflow ! IF( first ) THEN eps = slamch( 'Epsilon' ) base = slamch( 'Base' ) small1 = base**( INT( LOG( slamch( 'SafMin' ) ) / LOG( base ) / three ) ) sminv1 = one / small1 small2 = small1*small1 sminv2 = sminv1*sminv1 first = .false. END IF ! ! Determine if scaling of inputs necessary to avoid overflow ! when computing 1/TEMP**3 ! IF( orgati ) THEN temp = MIN( ABS( d( 2 )-tau ), ABS( d( 3 )-tau ) ) ELSE temp = MIN( ABS( d( 1 )-tau ), ABS( d( 2 )-tau ) ) END IF scale = .false. IF( temp <= small1 ) THEN scale = .true. IF( temp <= small2 ) THEN ! ! Scale up by power of radix nearest 1/SAFMIN**(2/3) ! sclfac = sminv2 sclinv = small2 ELSE ! ! Scale up by power of radix nearest 1/SAFMIN**(1/3) ! sclfac = sminv1 sclinv = small1 END IF ! ! Scaling up safe because D, Z, TAU scaled elsewhere to be O(1) ! DO i = 1, 3 dscale( i ) = d( i )*sclfac zscale( i ) = z( i )*sclfac END DO tau = tau*sclfac ELSE ! ! Copy D and Z to DSCALE and ZSCALE ! DO i = 1, 3 dscale( i ) = d( i ) zscale( i ) = z( i ) END DO END IF ! fc = zero df = zero ddf = zero DO i = 1, 3 temp = one / ( dscale( i )-tau ) temp1 = zscale( i )*temp temp2 = temp1*temp temp3 = temp2*temp fc = fc + temp1 / dscale( i ) df = df + temp2 ddf = ddf + temp3 END DO f = finit + tau*fc ! IF( ABS( f ) <= zero ) GO TO 60 ! ! Iteration begins ! ! It is not hard to see that ! ! 1) Iterations will go up monotonically ! if FINIT < 0; ! ! 2) Iterations will go down monotonically ! if FINIT > 0. ! iter = niter + 1 ! DO niter = iter, maxit ! IF( orgati ) THEN temp1 = dscale( 2 ) - tau temp2 = dscale( 3 ) - tau ELSE temp1 = dscale( 1 ) - tau temp2 = dscale( 2 ) - tau END IF a = ( temp1+temp2 )*f - temp1*temp2*df b = temp1*temp2*f c = f - ( temp1+temp2 )*df + temp1*temp2*ddf temp = MAX( ABS( a ), ABS( b ), ABS( c ) ) a = a / temp b = b / temp c = c / temp IF( c == zero ) THEN eta = b / a ELSE IF( a <= zero ) THEN eta = ( a-SQRT( ABS( a*a-four*b*c ) ) ) / ( two*c ) ELSE eta = two*b / ( a+SQRT( ABS( a*a-four*b*c ) ) ) END IF IF( f*eta >= zero ) THEN eta = -f / df END IF ! temp = eta + tau IF( orgati ) THEN IF( eta > zero .AND. temp >= dscale( 3 ) ) & eta = ( dscale( 3 )-tau ) / two IF( eta < zero .AND. temp <= dscale( 2 ) ) & eta = ( dscale( 2 )-tau ) / two ELSE IF( eta > zero .AND. temp >= dscale( 2 ) ) & eta = ( dscale( 2 )-tau ) / two IF( eta < zero .AND. temp <= dscale( 1 ) ) & eta = ( dscale( 1 )-tau ) / two END IF tau = tau + eta ! fc = zero erretm = zero df = zero ddf = zero DO i = 1, 3 temp = one / ( dscale( i )-tau ) temp1 = zscale( i )*temp temp2 = temp1*temp temp3 = temp2*temp temp4 = temp1 / dscale( i ) fc = fc + temp4 erretm = erretm + ABS( temp4 ) df = df + temp2 ddf = ddf + temp3 END DO f = finit + tau*fc erretm = eight*( ABS( finit )+ABS( tau )*erretm ) + ABS( tau )*df IF( ABS( f ) <= eps*erretm ) GO TO 60 END DO info = 1 60 CONTINUE ! ! Undo scaling ! IF( scale ) tau = tau*sclinv RETURN ! ! End of SLAED6 ! END SUBROUTINE slaed6 SUBROUTINE slaed7( icompq, n, qsiz, tlvls, curlvl, curpbm, d, q, & ldq, indxq, rho, cutpnt, qstore, qptr, prmptr, & perm, givptr, givcol, givnum, 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 ! September 30, 1994 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: icompq INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: qsiz INTEGER, INTENT(IN) :: tlvls INTEGER, INTENT(IN) :: curlvl INTEGER, INTENT(IN) :: curpbm REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq INTEGER, INTENT(OUT) :: indxq( * ) REAL, INTENT(IN OUT) :: rho INTEGER, INTENT(IN OUT) :: cutpnt REAL, INTENT(IN OUT) :: qstore( * ) INTEGER, INTENT(OUT) :: qptr( * ) INTEGER, INTENT(OUT) :: prmptr( * ) INTEGER, INTENT(IN OUT) :: perm( * ) INTEGER, INTENT(OUT) :: givptr( * ) INTEGER, INTENT(IN OUT) :: givcol( 2, * ) REAL, INTENT(IN OUT) :: givnum( 2, * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAED7 computes the updated eigensystem of a diagonal ! matrix after modification by a rank-one symmetric matrix. This ! routine is used only for the eigenproblem which requires all ! eigenvalues and optionally eigenvectors of a dense symmetric matrix ! that has been reduced to tridiagonal form. SLAED1 handles ! the case in which all eigenvalues and eigenvectors of a symmetric ! tridiagonal matrix are desired. ! ! T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out) ! ! where Z = Q'u, u is a vector of length N with ones in the ! CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. ! ! The eigenvectors of the original matrix are stored in Q, and the ! eigenvalues are in D. The algorithm consists of three stages: ! ! The first stage consists of deflating the size of the problem ! when there are multiple eigenvalues or if there is a zero in ! the Z vector. For each such occurence the dimension of the ! secular equation problem is reduced by one. This stage is ! performed by the routine SLAED8. ! ! The second stage consists of calculating the updated ! eigenvalues. This is done by finding the roots of the secular ! equation via the routine SLAED4 (as called by SLAED9). ! This routine also calculates the eigenvectors of the current ! problem. ! ! The final stage consists of computing the updated eigenvectors ! directly using the updated eigenvalues. The eigenvectors for ! the current problem are multiplied with the eigenvectors from ! the overall problem. ! ! Arguments ! ========= ! ! ICOMPQ (input) INTEGER ! = 0: Compute eigenvalues only. ! = 1: Compute eigenvectors of original dense symmetric matrix ! also. On entry, Q contains the orthogonal matrix used ! to reduce the original matrix to tridiagonal form. ! ! N (input) INTEGER ! The dimension of the symmetric tridiagonal matrix. N >= 0. ! ! QSIZ (input) INTEGER ! The dimension of the orthogonal matrix used to reduce ! the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. ! ! TLVLS (input) INTEGER ! The total number of merging levels in the overall divide and ! conquer tree. ! ! CURLVL (input) INTEGER ! The current level in the overall merge routine, ! 0 <= CURLVL <= TLVLS. ! ! CURPBM (input) INTEGER ! The current problem in the current level in the overall ! merge routine (counting from upper left to lower right). ! ! D (input/output) REAL array, dimension (N) ! On entry, the eigenvalues of the rank-1-perturbed matrix. ! On exit, the eigenvalues of the repaired matrix. ! ! Q (input/output) REAL array, dimension (LDQ, N) ! On entry, the eigenvectors of the rank-1-perturbed matrix. ! On exit, the eigenvectors of the repaired tridiagonal matrix. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. LDQ >= max(1,N). ! ! INDXQ (output) INTEGER array, dimension (N) ! The permutation which will reintegrate the subproblem just ! solved back into sorted order, i.e., D( INDXQ( I = 1, N ) ) ! will be in ascending order. ! ! RHO (input) REAL ! The subdiagonal element used to create the rank-1 ! modification. ! ! CUTPNT (input) INTEGER ! Contains the location of the last eigenvalue in the leading ! sub-matrix. min(1,N) <= CUTPNT <= N. ! ! QSTORE (input/output) REAL array, dimension (N**2+1) ! Stores eigenvectors of submatrices encountered during ! divide and conquer, packed together. QPTR points to ! beginning of the submatrices. ! ! QPTR (input/output) INTEGER array, dimension (N+2) ! List of indices pointing to beginning of submatrices stored ! in QSTORE. The submatrices are numbered starting at the ! bottom left of the divide and conquer tree, from left to ! right and bottom to top. ! ! PRMPTR (input) INTEGER array, dimension (N lg N) ! Contains a list of pointers which indicate where in PERM a ! level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) ! indicates the size of the permutation and also the size of ! the full, non-deflated problem. ! ! PERM (input) INTEGER array, dimension (N lg N) ! Contains the permutations (from deflation and sorting) to be ! applied to each eigenblock. ! ! GIVPTR (input) INTEGER array, dimension (N lg N) ! Contains a list of pointers which indicate where in GIVCOL a ! level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) ! indicates the number of Givens rotations. ! ! GIVCOL (input) INTEGER array, dimension (2, N lg N) ! Each pair of numbers indicates a pair of columns to take place ! in a Givens rotation. ! ! GIVNUM (input) REAL array, dimension (2, N lg N) ! Each number indicates the S value to be used in the ! corresponding Givens rotation. ! ! WORK (workspace) REAL array, dimension (3*N+QSIZ*N) ! ! IWORK (workspace) INTEGER array, dimension (4*N) ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if INFO = 1, an eigenvalue did not converge ! ! Further Details ! =============== ! ! Based on contributions by ! Jeff Rutter, Computer Science Division, University of California ! at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: zero = 0.0E0 ! .. ! .. Local Scalars .. INTEGER :: coltyp, curr, i, idlmda, indx, indxc, indxp, & iq2, is, iw, iz, k, ldq2, n1, n2, ptr ! .. ! .. External Subroutines .. EXTERNAL sgemm, slaed8, slaed9, slaeda, slamrg, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( icompq < 0 .OR. icompq > 1 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( icompq == 1 .AND. qsiz < n ) THEN info = -4 ELSE IF( ldq < MAX( 1, n ) ) THEN info = -9 ELSE IF( MIN( 1, n ) > cutpnt .OR. n < cutpnt ) THEN info = -12 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLAED7', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! The following values are for bookkeeping purposes only. They are ! integer pointers which indicate the portion of the workspace ! used by a particular array in SLAED8 and SLAED9. ! IF( icompq == 1 ) THEN ldq2 = qsiz ELSE ldq2 = n END IF ! iz = 1 idlmda = iz + n iw = idlmda + n iq2 = iw + n is = iq2 + n*ldq2 ! indx = 1 indxc = indx + n coltyp = indxc + n indxp = coltyp + n ! ! Form the z-vector which consists of the last row of Q_1 and the ! first row of Q_2. ! ptr = 1 + 2**tlvls DO i = 1, curlvl - 1 ptr = ptr + 2**( tlvls-i ) END DO curr = ptr + curpbm CALL slaeda( n, tlvls, curlvl, curpbm, prmptr, perm, givptr, & givcol, givnum, qstore, qptr, work( iz ), work( iz+n ), info ) ! ! When solving the final problem, we no longer need the stored data, ! so we will overwrite the data from this level onto the previously ! used storage space. ! IF( curlvl == tlvls ) THEN qptr( curr ) = 1 prmptr( curr ) = 1 givptr( curr ) = 1 END IF ! ! Sort and Deflate eigenvalues. ! CALL slaed8( icompq, k, n, qsiz, d, q, ldq, indxq, rho, cutpnt, & work( iz ), work( idlmda ), work( iq2 ), ldq2, & work( iw ), perm( prmptr( curr ) ), givptr( curr+1 ), & givcol( 1, givptr( curr ) ), givnum( 1, givptr( curr ) ), iwork( indxp ), & iwork( indx ), info ) prmptr( curr+1 ) = prmptr( curr ) + n givptr( curr+1 ) = givptr( curr+1 ) + givptr( curr ) ! ! Solve Secular Equation. ! IF( k /= 0 ) THEN CALL slaed9( k, 1, k, n, d, work( is ), k, rho, work( idlmda ), & work( iw ), qstore( qptr( curr ) ), k, info ) IF( info /= 0 ) GO TO 30 IF( icompq == 1 ) THEN CALL sgemm( 'N', 'N', qsiz, k, k, one, work( iq2 ), ldq2, & qstore( qptr( curr ) ), k, zero, q, ldq ) END IF qptr( curr+1 ) = qptr( curr ) + k**2 ! ! Prepare the INDXQ sorting permutation. ! n1 = k n2 = n - k CALL slamrg( n1, n2, d, 1, -1, indxq ) ELSE qptr( curr+1 ) = qptr( curr ) DO i = 1, n indxq( i ) = i END DO END IF ! 30 CONTINUE RETURN ! ! End of SLAED7 ! END SUBROUTINE slaed7 SUBROUTINE slaed8( icompq, k, n, qsiz, d, q, ldq, indxq, rho, & cutpnt, z, dlamda, q2, ldq2, w, perm, givptr, & givcol, givnum, indxp, indx, info ) ! ! -- LAPACK routine (version 3.0) -- ! Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, ! Courant Institute, NAG Ltd., and Rice University ! September 30, 1994 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: icompq INTEGER, INTENT(OUT) :: k INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: qsiz REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq INTEGER, INTENT(OUT) :: indxq( * ) REAL, INTENT(IN OUT) :: rho INTEGER, INTENT(IN) :: cutpnt REAL, INTENT(IN OUT) :: z( * ) REAL, INTENT(OUT) :: dlamda( * ) REAL, INTENT(IN OUT) :: q2( ldq2, * ) INTEGER, INTENT(IN OUT) :: ldq2 REAL, INTENT(OUT) :: w( * ) INTEGER, INTENT(OUT) :: perm( * ) INTEGER, INTENT(OUT) :: givptr INTEGER, INTENT(OUT) :: givcol( 2, * ) REAL, INTENT(OUT) :: givnum( 2, * ) INTEGER, INTENT(OUT) :: indxp( * ) INTEGER, INTENT(OUT) :: indx( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAED8 merges the two sets of eigenvalues together into a single ! sorted set. Then it tries to deflate the size of the problem. ! There are two ways in which deflation can occur: when two or more ! eigenvalues are close together or if there is a tiny element in the ! Z vector. For each such occurrence the order of the related secular ! equation problem is reduced by one. ! ! Arguments ! ========= ! ! ICOMPQ (input) INTEGER ! = 0: Compute eigenvalues only. ! = 1: Compute eigenvectors of original dense symmetric matrix ! also. On entry, Q contains the orthogonal matrix used ! to reduce the original matrix to tridiagonal form. ! ! K (output) INTEGER ! The number of non-deflated eigenvalues, and the order of the ! related secular equation. ! ! N (input) INTEGER ! The dimension of the symmetric tridiagonal matrix. N >= 0. ! ! QSIZ (input) INTEGER ! The dimension of the orthogonal matrix used to reduce ! the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. ! ! D (input/output) REAL array, dimension (N) ! On entry, the eigenvalues of the two submatrices to be ! combined. On exit, the trailing (N-K) updated eigenvalues ! (those which were deflated) sorted into increasing order. ! ! Q (input/output) REAL array, dimension (LDQ,N) ! If ICOMPQ = 0, Q is not referenced. Otherwise, ! on entry, Q contains the eigenvectors of the partially solved ! system which has been previously updated in matrix ! multiplies with other partially solved eigensystems. ! On exit, Q contains the trailing (N-K) updated eigenvectors ! (those which were deflated) in its last N-K columns. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. LDQ >= max(1,N). ! ! INDXQ (input) INTEGER array, dimension (N) ! The permutation which separately sorts the two sub-problems ! in D into ascending order. Note that elements in the second ! half of this permutation must first have CUTPNT added to ! their values in order to be accurate. ! ! RHO (input/output) REAL ! On entry, the off-diagonal element associated with the rank-1 ! cut which originally split the two submatrices which are now ! being recombined. ! On exit, RHO has been modified to the value required by ! SLAED3. ! ! CUTPNT (input) INTEGER ! The location of the last eigenvalue in the leading ! sub-matrix. min(1,N) <= CUTPNT <= N. ! ! Z (input) REAL array, dimension (N) ! On entry, Z contains the updating vector (the last row of ! the first sub-eigenvector matrix and the first row of the ! second sub-eigenvector matrix). ! On exit, the contents of Z are destroyed by the updating ! process. ! ! DLAMDA (output) REAL array, dimension (N) ! A copy of the first K eigenvalues which will be used by ! SLAED3 to form the secular equation. ! ! Q2 (output) REAL array, dimension (LDQ2,N) ! If ICOMPQ = 0, Q2 is not referenced. Otherwise, ! a copy of the first K eigenvectors which will be used by ! SLAED7 in a matrix multiply (SGEMM) to update the new ! eigenvectors. ! ! LDQ2 (input) INTEGER ! The leading dimension of the array Q2. LDQ2 >= max(1,N). ! ! W (output) REAL array, dimension (N) ! The first k values of the final deflation-altered z-vector and ! will be passed to SLAED3. ! ! PERM (output) INTEGER array, dimension (N) ! The permutations (from deflation and sorting) to be applied ! to each eigenblock. ! ! GIVPTR (output) INTEGER ! The number of Givens rotations which took place in this ! subproblem. ! ! GIVCOL (output) INTEGER array, dimension (2, N) ! Each pair of numbers indicates a pair of columns to take place ! in a Givens rotation. ! ! GIVNUM (output) REAL array, dimension (2, N) ! Each number indicates the S value to be used in the ! corresponding Givens rotation. ! ! INDXP (workspace) INTEGER array, dimension (N) ! The permutation used to place deflated values of D at the end ! of the array. INDXP(1:K) points to the nondeflated D-values ! and INDXP(K+1:N) points to the deflated eigenvalues. ! ! INDX (workspace) INTEGER array, dimension (N) ! The permutation used to sort the contents of D into ascending ! order. ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! ! Further Details ! =============== ! ! Based on contributions by ! Jeff Rutter, Computer Science Division, University of California ! at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: mone = -1.0E0 REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: eight = 8.0E0 ! .. ! .. Local Scalars .. ! INTEGER :: i, imax, j, jlam, jmax, jp, k2, n1, n1p1, n2 REAL :: c, eps, s, t, tau, tol ! .. ! .. External Functions .. INTEGER :: isamax REAL :: slamch, slapy2 EXTERNAL isamax, slamch, slapy2 ! .. ! .. External Subroutines .. EXTERNAL scopy, slacpy, slamrg, srot, sscal, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( icompq < 0 .OR. icompq > 1 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( icompq == 1 .AND. qsiz < n ) THEN info = -4 ELSE IF( ldq < MAX( 1, n ) ) THEN info = -7 ELSE IF( cutpnt < MIN( 1, n ) .OR. cutpnt > n ) THEN info = -10 ELSE IF( ldq2 < MAX( 1, n ) ) THEN info = -14 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLAED8', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! n1 = cutpnt n2 = n - n1 n1p1 = n1 + 1 ! IF( rho < zero ) THEN CALL sscal( n2, mone, z( n1p1 ), 1 ) END IF ! ! Normalize z so that norm(z) = 1 ! t = one / SQRT( two ) DO j = 1, n indx( j ) = j END DO CALL sscal( n, t, z, 1 ) rho = ABS( two*rho ) ! ! Sort the eigenvalues into increasing order ! DO i = cutpnt + 1, n indxq( i ) = indxq( i ) + cutpnt END DO DO i = 1, n dlamda( i ) = d( indxq( i ) ) w( i ) = z( indxq( i ) ) END DO i = 1 j = cutpnt + 1 CALL slamrg( n1, n2, dlamda, 1, 1, indx ) DO i = 1, n d( i ) = dlamda( indx( i ) ) z( i ) = w( indx( i ) ) END DO ! ! Calculate the allowable deflation tolerence ! imax = isamax( n, z, 1 ) jmax = isamax( n, d, 1 ) eps = slamch( 'Epsilon' ) tol = eight*eps*ABS( d( jmax ) ) ! ! If the rank-1 modifier is small enough, no more needs to be done ! except to reorganize Q so that its columns correspond with the ! elements in D. ! IF( rho*ABS( z( imax ) ) <= tol ) THEN k = 0 IF( icompq == 0 ) THEN DO j = 1, n perm( j ) = indxq( indx( j ) ) END DO ELSE DO j = 1, n perm( j ) = indxq( indx( j ) ) CALL scopy( qsiz, q( 1, perm( j ) ), 1, q2( 1, j ), 1 ) END DO CALL slacpy( 'A', qsiz, n, q2( 1, 1 ), ldq2, q( 1, 1 ), ldq ) END IF RETURN END IF ! ! If there are multiple eigenvalues then the problem deflates. Here ! the number of equal eigenvalues are found. As each equal ! eigenvalue is found, an elementary reflector is computed to rotate ! the corresponding eigensubspace so that the corresponding ! components of Z are zero in this new basis. ! k = 0 givptr = 0 k2 = n + 1 DO j = 1, n IF( rho*ABS( z( j ) ) <= tol ) THEN ! ! Deflate due to small z component. ! k2 = k2 - 1 indxp( k2 ) = j IF( j == n ) GO TO 110 ELSE jlam = j EXIT END IF END DO 80 CONTINUE j = j + 1 IF( j > n ) GO TO 100 IF( rho*ABS( z( j ) ) <= tol ) THEN ! ! Deflate due to small z component. ! k2 = k2 - 1 indxp( k2 ) = j ELSE ! ! Check if eigenvalues are close enough to allow deflation. ! s = z( jlam ) c = z( j ) ! ! Find sqrt(a**2+b**2) without overflow or ! destructive underflow. ! tau = slapy2( c, s ) t = d( j ) - d( jlam ) c = c / tau s = -s / tau IF( ABS( t*c*s ) <= tol ) THEN ! ! Deflation is possible. ! z( j ) = tau z( jlam ) = zero ! ! Record the appropriate Givens rotation ! givptr = givptr + 1 givcol( 1, givptr ) = indxq( indx( jlam ) ) givcol( 2, givptr ) = indxq( indx( j ) ) givnum( 1, givptr ) = c givnum( 2, givptr ) = s IF( icompq == 1 ) THEN CALL srot( qsiz, q( 1, indxq( indx( jlam ) ) ), 1, & q( 1, indxq( indx( j ) ) ), 1, c, s ) END IF t = d( jlam )*c*c + d( j )*s*s d( j ) = d( jlam )*s*s + d( j )*c*c d( jlam ) = t k2 = k2 - 1 i = 1 90 CONTINUE IF( k2+i <= n ) THEN IF( d( jlam ) < d( indxp( k2+i ) ) ) THEN indxp( k2+i-1 ) = indxp( k2+i ) indxp( k2+i ) = jlam i = i + 1 GO TO 90 ELSE indxp( k2+i-1 ) = jlam END IF ELSE indxp( k2+i-1 ) = jlam END IF jlam = j ELSE k = k + 1 w( k ) = z( jlam ) dlamda( k ) = d( jlam ) indxp( k ) = jlam jlam = j END IF END IF GO TO 80 100 CONTINUE ! ! Record the last eigenvalue. ! k = k + 1 w( k ) = z( jlam ) dlamda( k ) = d( jlam ) indxp( k ) = jlam ! 110 CONTINUE ! ! Sort the eigenvalues and corresponding eigenvectors into DLAMDA ! and Q2 respectively. The eigenvalues/vectors which were not ! deflated go into the first K slots of DLAMDA and Q2 respectively, ! while those which were deflated go into the last N - K slots. ! IF( icompq == 0 ) THEN DO j = 1, n jp = indxp( j ) dlamda( j ) = d( jp ) perm( j ) = indxq( indx( jp ) ) END DO ELSE DO j = 1, n jp = indxp( j ) dlamda( j ) = d( jp ) perm( j ) = indxq( indx( jp ) ) CALL scopy( qsiz, q( 1, perm( j ) ), 1, q2( 1, j ), 1 ) END DO END IF ! ! The deflated eigenvalues and their corresponding vectors go back ! into the last N - K slots of D and Q respectively. ! IF( k < n ) THEN IF( icompq == 0 ) THEN CALL scopy( n-k, dlamda( k+1 ), 1, d( k+1 ), 1 ) ELSE CALL scopy( n-k, dlamda( k+1 ), 1, d( k+1 ), 1 ) CALL slacpy( 'A', qsiz, n-k, q2( 1, k+1 ), ldq2, q( 1, k+1 ), ldq ) END IF END IF ! RETURN ! ! End of SLAED8 ! END SUBROUTINE slaed8 SUBROUTINE slaed9( k, kstart, kstop, n, d, q, ldq, rho, dlamda, w, & s, lds, info ) ! ! -- LAPACK routine (version 3.0) -- ! Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, ! Courant Institute, NAG Ltd., and Rice University ! September 30, 1994 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: k INTEGER, INTENT(IN) :: kstart INTEGER, INTENT(IN) :: kstop INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq REAL, INTENT(IN OUT) :: rho REAL, INTENT(OUT) :: dlamda( * ) REAL, INTENT(OUT) :: w( * ) REAL, INTENT(OUT) :: s( lds, * ) INTEGER, INTENT(IN OUT) :: lds INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAED9 finds the roots of the secular equation, as defined by the ! values in D, Z, and RHO, between KSTART and KSTOP. It makes the ! appropriate calls to SLAED4 and then stores the new matrix of ! eigenvectors for use in calculating the next level of Z vectors. ! ! Arguments ! ========= ! ! K (input) INTEGER ! The number of terms in the rational function to be solved by ! SLAED4. K >= 0. ! ! KSTART (input) INTEGER ! KSTOP (input) INTEGER ! The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP ! are to be computed. 1 <= KSTART <= KSTOP <= K. ! ! N (input) INTEGER ! The number of rows and columns in the Q matrix. ! N >= K (delation may result in N > K). ! ! D (output) REAL array, dimension (N) ! D(I) contains the updated eigenvalues ! for KSTART <= I <= KSTOP. ! ! Q (workspace) REAL array, dimension (LDQ,N) ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. LDQ >= max( 1, N ). ! ! RHO (input) REAL ! The value of the parameter in the rank one update equation. ! RHO >= 0 required. ! ! DLAMDA (input) REAL array, dimension (K) ! The first K elements of this array contain the old roots ! of the deflated updating problem. These are the poles ! of the secular equation. ! ! W (input) REAL array, dimension (K) ! The first K elements of this array contain the components ! of the deflation-adjusted updating vector. ! ! S (output) REAL array, dimension (LDS, K) ! Will contain the eigenvectors of the repaired matrix which ! will be stored for subsequent Z vector calculation and ! multiplied by the previously accumulated eigenvectors ! to update the system. ! ! LDS (input) INTEGER ! The leading dimension of S. LDS >= max( 1, K ). ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if INFO = 1, an eigenvalue did not converge ! ! Further Details ! =============== ! ! Based on contributions by ! Jeff Rutter, Computer Science Division, University of California ! at Berkeley, USA ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER :: i, j REAL :: temp ! .. ! .. External Functions .. REAL :: slamc3, snrm2 EXTERNAL slamc3, snrm2 ! .. ! .. External Subroutines .. EXTERNAL scopy, slaed4, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, SIGN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( k < 0 ) THEN info = -1 ELSE IF( kstart < 1 .OR. kstart > MAX( 1, k ) ) THEN info = -2 ELSE IF( MAX( 1, kstop ) < kstart .OR. kstop > MAX( 1, k ) ) & THEN info = -3 ELSE IF( n < k ) THEN info = -4 ELSE IF( ldq < MAX( 1, k ) ) THEN info = -7 ELSE IF( lds < MAX( 1, k ) ) THEN info = -12 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLAED9', -info ) RETURN END IF ! ! Quick return if possible ! IF( k == 0 ) RETURN ! ! Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can ! be computed with high relative accuracy (barring over/underflow). ! This is a problem on machines without a guard digit in ! add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). ! The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I), ! which on any of these machines zeros out the bottommost ! bit of DLAMDA(I) if it is 1; this makes the subsequent ! subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation ! occurs. On binary machines with a guard digit (almost all ! machines) it does not change DLAMDA(I) at all. On hexadecimal ! and decimal machines with a guard digit, it slightly ! changes the bottommost bits of DLAMDA(I). It does not account ! for hexadecimal or decimal machines without guard digits ! (we know of none). We use a subroutine call to compute ! 2*DLAMBDA(I) to prevent optimizing compilers from eliminating ! this code. ! DO i = 1, n dlamda( i ) = slamc3( dlamda( i ), dlamda( i ) ) - dlamda( i ) END DO ! DO j = kstart, kstop CALL slaed4( k, j, dlamda, w, q( 1, j ), rho, d( j ), info ) ! ! If the zero finder fails, the computation is terminated. ! IF( info /= 0 ) GO TO 120 END DO ! IF( k == 1 .OR. k == 2 ) THEN DO i = 1, k DO j = 1, k s( j, i ) = q( j, i ) END DO END DO GO TO 120 END IF ! ! Compute updated W. ! CALL scopy( k, w, 1, s, 1 ) ! ! Initialize W(I) = Q(I,I) ! CALL scopy( k, q, ldq+1, w, 1 ) DO j = 1, k DO i = 1, j - 1 w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) ) END DO DO i = j + 1, k w( i ) = w( i )*( q( i, j ) / ( dlamda( i )-dlamda( j ) ) ) END DO END DO DO i = 1, k w( i ) = SIGN( SQRT( -w( i ) ), s( i, 1 ) ) END DO ! ! Compute eigenvectors of the modified rank-1 modification. ! DO j = 1, k DO i = 1, k q( i, j ) = w( i ) / q( i, j ) END DO temp = snrm2( k, q( 1, j ), 1 ) DO i = 1, k s( i, j ) = q( i, j ) / temp END DO END DO ! 120 CONTINUE RETURN ! ! End of SLAED9 ! END SUBROUTINE slaed9 SUBROUTINE slaeda( n, tlvls, curlvl, curpbm, prmptr, perm, givptr, & givcol, givnum, q, qptr, z, ztemp, 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, INTENT(IN) :: n INTEGER, INTENT(IN) :: tlvls INTEGER, INTENT(IN) :: curlvl INTEGER, INTENT(IN) :: curpbm INTEGER, INTENT(IN) :: prmptr( * ) INTEGER, INTENT(IN) :: perm( * ) INTEGER, INTENT(IN) :: givptr( * ) INTEGER, INTENT(IN OUT) :: givcol( 2, * ) REAL, INTENT(IN OUT) :: givnum( 2, * ) REAL, INTENT(IN OUT) :: q( * ) INTEGER, INTENT(IN) :: qptr( * ) REAL, INTENT(OUT) :: z( * ) REAL, INTENT(OUT) :: ztemp( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAEDA computes the Z vector corresponding to the merge step in the ! CURLVLth step of the merge process with TLVLS steps for the CURPBMth ! problem. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The dimension of the symmetric tridiagonal matrix. N >= 0. ! ! TLVLS (input) INTEGER ! The total number of merging levels in the overall divide and ! conquer tree. ! ! CURLVL (input) INTEGER ! The current level in the overall merge routine, ! 0 <= curlvl <= tlvls. ! ! CURPBM (input) INTEGER ! The current problem in the current level in the overall ! merge routine (counting from upper left to lower right). ! ! PRMPTR (input) INTEGER array, dimension (N lg N) ! Contains a list of pointers which indicate where in PERM a ! level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) ! indicates the size of the permutation and incidentally the ! size of the full, non-deflated problem. ! ! PERM (input) INTEGER array, dimension (N lg N) ! Contains the permutations (from deflation and sorting) to be ! applied to each eigenblock. ! ! GIVPTR (input) INTEGER array, dimension (N lg N) ! Contains a list of pointers which indicate where in GIVCOL a ! level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) ! indicates the number of Givens rotations. ! ! GIVCOL (input) INTEGER array, dimension (2, N lg N) ! Each pair of numbers indicates a pair of columns to take place ! in a Givens rotation. ! ! GIVNUM (input) REAL array, dimension (2, N lg N) ! Each number indicates the S value to be used in the ! corresponding Givens rotation. ! ! Q (input) REAL array, dimension (N**2) ! Contains the square eigenblocks from previous levels, the ! starting positions for blocks are given by QPTR. ! ! QPTR (input) INTEGER array, dimension (N+2) ! Contains a list of pointers which indicate where in Q an ! eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates ! the size of the block. ! ! Z (output) REAL array, dimension (N) ! On output this vector contains the updating vector (the last ! row of the first sub-eigenvector matrix and the first row of ! the second sub-eigenvector matrix). ! ! ZTEMP (workspace) REAL array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! ! Further Details ! =============== ! ! Based on contributions by ! Jeff Rutter, Computer Science Division, University of California ! at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: half = 0.5E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. INTEGER :: bsiz1, bsiz2, curr, i, k, mid, psiz1, psiz2, ptr, zptr1 ! .. ! .. External Subroutines .. EXTERNAL scopy, sgemv, srot, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC INT, REAL, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( n < 0 ) THEN info = -1 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLAEDA', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Determine location of first number in second half. ! mid = n / 2 + 1 ! ! Gather last/first rows of appropriate eigenblocks into center of Z ! ptr = 1 ! ! Determine location of lowest level subproblem in the full storage ! scheme ! curr = ptr + curpbm*2**curlvl + 2**( curlvl-1 ) - 1 ! ! Determine size of these matrices. We add HALF to the value of ! the SQRT in case the machine underestimates one of these square ! roots. ! bsiz1 = INT( half+SQRT( REAL( qptr( curr+1 )-qptr( curr ) ) ) ) bsiz2 = INT( half+SQRT( REAL( qptr( curr+2 )-qptr( curr+1 ) ) ) ) DO k = 1, mid - bsiz1 - 1 z( k ) = zero END DO CALL scopy( bsiz1, q( qptr( curr )+bsiz1-1 ), bsiz1, z( mid-bsiz1 ), 1 ) CALL scopy( bsiz2, q( qptr( curr+1 ) ), bsiz2, z( mid ), 1 ) DO k = mid + bsiz2, n z( k ) = zero END DO ! ! Loop thru remaining levels 1 -> CURLVL applying the Givens ! rotations and permutation and then multiplying the center matrices ! against the current Z. ! ptr = 2**tlvls + 1 DO k = 1, curlvl - 1 curr = ptr + curpbm*2**( curlvl-k ) + 2**( curlvl-k-1 ) - 1 psiz1 = prmptr( curr+1 ) - prmptr( curr ) psiz2 = prmptr( curr+2 ) - prmptr( curr+1 ) zptr1 = mid - psiz1 ! ! Apply Givens at CURR and CURR+1 ! DO i = givptr( curr ), givptr( curr+1 ) - 1 CALL srot( 1, z( zptr1+givcol( 1, i )-1 ), 1, & z( zptr1+givcol( 2, i )-1 ), 1, givnum( 1, i ), givnum( 2, i ) ) END DO DO i = givptr( curr+1 ), givptr( curr+2 ) - 1 CALL srot( 1, z( mid-1+givcol( 1, i ) ), 1, & z( mid-1+givcol( 2, i ) ), 1, givnum( 1, i ), givnum( 2, i ) ) END DO psiz1 = prmptr( curr+1 ) - prmptr( curr ) psiz2 = prmptr( curr+2 ) - prmptr( curr+1 ) DO i = 0, psiz1 - 1 ztemp( i+1 ) = z( zptr1+perm( prmptr( curr )+i )-1 ) END DO DO i = 0, psiz2 - 1 ztemp( psiz1+i+1 ) = z( mid+perm( prmptr( curr+1 )+i )-1 ) END DO ! ! Multiply Blocks at CURR and CURR+1 ! ! Determine size of these matrices. We add HALF to the value of ! the SQRT in case the machine underestimates one of these ! square roots. ! bsiz1 = INT( half+SQRT( REAL( qptr( curr+1 )-qptr( curr ) ) ) ) bsiz2 = INT( half+SQRT( REAL( qptr( curr+2 )-qptr( curr+ 1 ) ) ) ) IF( bsiz1 > 0 ) THEN CALL sgemv( 'T', bsiz1, bsiz1, one, q( qptr( curr ) ), & bsiz1, ztemp( 1 ), 1, zero, z( zptr1 ), 1 ) END IF CALL scopy( psiz1-bsiz1, ztemp( bsiz1+1 ), 1, z( zptr1+bsiz1 ), 1 ) IF( bsiz2 > 0 ) THEN CALL sgemv( 'T', bsiz2, bsiz2, one, q( qptr( curr+1 ) ), & bsiz2, ztemp( psiz1+1 ), 1, zero, z( mid ), 1 ) END IF CALL scopy( psiz2-bsiz2, ztemp( psiz1+bsiz2+1 ), 1, z( mid+bsiz2 ), 1 ) ! ptr = ptr + 2**( tlvls-k ) END DO ! RETURN ! ! End of SLAEDA ! END SUBROUTINE slaeda SUBROUTINE slaein( rightv, noinit, n, h, ldh, wr, wi, vr, vi, b, & ldb, work, eps3, smlnum, bignum, info ) ! ! -- 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 .. LOGICAL, INTENT(IN) :: rightv LOGICAL, INTENT(IN) :: noinit INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN) :: h( ldh, * ) INTEGER, INTENT(IN OUT) :: ldh REAL, INTENT(IN) :: wr REAL, INTENT(IN) :: wi REAL, INTENT(OUT) :: vr( * ) REAL, INTENT(OUT) :: vi( * ) REAL, INTENT(OUT) :: b( ldb, * ) INTEGER, INTENT(IN) :: ldb REAL, INTENT(OUT) :: work( * ) REAL, INTENT(IN) :: eps3 REAL, INTENT(IN) :: smlnum REAL, INTENT(IN) :: bignum INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAEIN uses inverse iteration to find a right or left eigenvector ! corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg ! matrix H. ! ! Arguments ! ========= ! ! RIGHTV (input) LOGICAL ! = .TRUE. : compute right eigenvector; ! = .FALSE.: compute left eigenvector. ! ! NOINIT (input) LOGICAL ! = .TRUE. : no initial vector supplied in (VR,VI). ! = .FALSE.: initial vector supplied in (VR,VI). ! ! N (input) INTEGER ! The order of the matrix H. N >= 0. ! ! H (input) REAL array, dimension (LDH,N) ! The upper Hessenberg matrix H. ! ! LDH (input) INTEGER ! The leading dimension of the array H. LDH >= max(1,N). ! ! WR (input) REAL ! WI (input) REAL ! The real and imaginary parts of the eigenvalue of H whose ! corresponding right or left eigenvector is to be computed. ! ! VR (input/output) REAL array, dimension (N) ! VI (input/output) REAL array, dimension (N) ! On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain ! a real starting vector for inverse iteration using the real ! eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI ! must contain the real and imaginary parts of a complex ! starting vector for inverse iteration using the complex ! eigenvalue (WR,WI); otherwise VR and VI need not be set. ! On exit, if WI = 0.0 (real eigenvalue), VR contains the ! computed real eigenvector; if WI.ne.0.0 (complex eigenvalue), ! VR and VI contain the real and imaginary parts of the ! computed complex eigenvector. The eigenvector is normalized ! so that the component of largest magnitude has magnitude 1; ! here the magnitude of a complex number (x,y) is taken to be ! |x| + |y|. ! VI is not referenced if WI = 0.0. ! ! B (workspace) REAL array, dimension (LDB,N) ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= N+1. ! ! WORK (workspace) REAL array, dimension (N) ! ! EPS3 (input) REAL ! A small machine-dependent value which is used to perturb ! close eigenvalues, and to replace zero pivots. ! ! SMLNUM (input) REAL ! A machine-dependent value close to the underflow threshold. ! ! BIGNUM (input) REAL ! A machine-dependent value close to the overflow threshold. ! ! INFO (output) INTEGER ! = 0: successful exit ! = 1: inverse iteration did not converge; VR is set to the ! last iterate, and so is VI if WI.ne.0.0. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: tenth = 1.0E-1 ! .. ! .. Local Scalars .. CHARACTER (LEN=1) :: normin, trans INTEGER :: i, i1, i2, i3, ierr, its, j REAL :: absbii, absbjj, ei, ej, growto, norm, nrmsml, & REC, rootn, scale, temp, vcrit, vmax, vnorm, w, w1, x, xi, xr, y ! .. ! .. External Functions .. INTEGER :: isamax REAL :: sasum, slapy2, snrm2 EXTERNAL isamax, sasum, slapy2, snrm2 ! .. ! .. External Subroutines .. EXTERNAL sladiv, slatrs, sscal ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, REAL, SQRT ! .. ! .. Executable Statements .. ! info = 0 ! ! GROWTO is the threshold used in the acceptance test for an ! eigenvector. ! rootn = SQRT( REAL( n ) ) growto = tenth / rootn nrmsml = MAX( one, eps3*rootn )*smlnum ! ! Form B = H - (WR,WI)*I (except that the subdiagonal elements and ! the imaginary parts of the diagonal elements are not stored). ! DO j = 1, n DO i = 1, j - 1 b( i, j ) = h( i, j ) END DO b( j, j ) = h( j, j ) - wr END DO ! IF( wi == zero ) THEN ! ! Real eigenvalue. ! IF( noinit ) THEN ! ! Set initial vector. ! DO i = 1, n vr( i ) = eps3 END DO ELSE ! ! Scale supplied initial vector. ! vnorm = snrm2( n, vr, 1 ) CALL sscal( n, ( eps3*rootn ) / MAX( vnorm, nrmsml ), vr, 1 ) END IF ! IF( rightv ) THEN ! ! LU decomposition with partial pivoting of B, replacing zero ! pivots by EPS3. ! DO i = 1, n - 1 ei = h( i+1, i ) IF( ABS( b( i, i ) ) < ABS( ei ) ) THEN ! ! Interchange rows and eliminate. ! x = b( i, i ) / ei b( i, i ) = ei DO j = i + 1, n temp = b( i+1, j ) b( i+1, j ) = b( i, j ) - x*temp b( i, j ) = temp END DO ELSE ! ! Eliminate without interchange. ! IF( b( i, i ) == zero ) b( i, i ) = eps3 x = ei / b( i, i ) IF( x /= zero ) THEN DO j = i + 1, n b( i+1, j ) = b( i+1, j ) - x*b( i, j ) END DO END IF END IF END DO IF( b( n, n ) == zero ) b( n, n ) = eps3 ! trans = 'N' ! ELSE ! ! UL decomposition with partial pivoting of B, replacing zero ! pivots by EPS3. ! DO j = n, 2, -1 ej = h( j, j-1 ) IF( ABS( b( j, j ) ) < ABS( ej ) ) THEN ! ! Interchange columns and eliminate. ! x = b( j, j ) / ej b( j, j ) = ej DO i = 1, j - 1 temp = b( i, j-1 ) b( i, j-1 ) = b( i, j ) - x*temp b( i, j ) = temp END DO ELSE ! ! Eliminate without interchange. ! IF( b( j, j ) == zero ) b( j, j ) = eps3 x = ej / b( j, j ) IF( x /= zero ) THEN DO i = 1, j - 1 b( i, j-1 ) = b( i, j-1 ) - x*b( i, j ) END DO END IF END IF END DO IF( b( 1, 1 ) == zero ) b( 1, 1 ) = eps3 ! trans = 'T' ! END IF ! normin = 'N' DO its = 1, n ! ! Solve U*x = scale*v for a right eigenvector ! or U'*x = scale*v for a left eigenvector, ! overwriting x on v. ! CALL slatrs( 'Upper', trans, 'Nonunit', normin, n, b, ldb, & vr, scale, work, ierr ) normin = 'Y' ! ! Test for sufficient growth in the norm of v. ! vnorm = sasum( n, vr, 1 ) IF( vnorm >= growto*scale ) GO TO 120 ! ! Choose new orthogonal starting vector and try again. ! temp = eps3 / ( rootn+one ) vr( 1 ) = eps3 DO i = 2, n vr( i ) = temp END DO vr( n-its+1 ) = vr( n-its+1 ) - eps3*rootn END DO ! ! Failure to find eigenvector in N iterations. ! info = 1 ! 120 CONTINUE ! ! Normalize eigenvector. ! i = isamax( n, vr, 1 ) CALL sscal( n, one / ABS( vr( i ) ), vr, 1 ) ELSE ! ! Complex eigenvalue. ! IF( noinit ) THEN ! ! Set initial vector. ! DO i = 1, n vr( i ) = eps3 vi( i ) = zero END DO ELSE ! ! Scale supplied initial vector. ! norm = slapy2( snrm2( n, vr, 1 ), snrm2( n, vi, 1 ) ) REC = ( eps3*rootn ) / MAX( norm, nrmsml ) CALL sscal( n, REC, vr, 1 ) CALL sscal( n, REC, vi, 1 ) END IF ! IF( rightv ) THEN ! ! LU decomposition with partial pivoting of B, replacing zero ! pivots by EPS3. ! ! The imaginary part of the (i,j)-th element of U is stored in ! B(j+1,i). ! b( 2, 1 ) = -wi DO i = 2, n b( i+1, 1 ) = zero END DO ! DO i = 1, n - 1 absbii = slapy2( b( i, i ), b( i+1, i ) ) ei = h( i+1, i ) IF( absbii < ABS( ei ) ) THEN ! ! Interchange rows and eliminate. ! xr = b( i, i ) / ei xi = b( i+1, i ) / ei b( i, i ) = ei b( i+1, i ) = zero DO j = i + 1, n temp = b( i+1, j ) b( i+1, j ) = b( i, j ) - xr*temp b( j+1, i+1 ) = b( j+1, i ) - xi*temp b( i, j ) = temp b( j+1, i ) = zero END DO b( i+2, i ) = -wi b( i+1, i+1 ) = b( i+1, i+1 ) - xi*wi b( i+2, i+1 ) = b( i+2, i+1 ) + xr*wi ELSE ! ! Eliminate without interchanging rows. ! IF( absbii == zero ) THEN b( i, i ) = eps3 b( i+1, i ) = zero absbii = eps3 END IF ei = ( ei / absbii ) / absbii xr = b( i, i )*ei xi = -b( i+1, i )*ei DO j = i + 1, n b( i+1, j ) = b( i+1, j ) - xr*b( i, j ) + xi*b( j+1, i ) b( j+1, i+1 ) = -xr*b( j+1, i ) - xi*b( i, j ) END DO b( i+2, i+1 ) = b( i+2, i+1 ) - wi END IF ! ! Compute 1-norm of offdiagonal elements of i-th row. ! work( i ) = sasum( n-i, b( i, i+1 ), ldb ) + & sasum( n-i, b( i+2, i ), 1 ) END DO IF( b( n, n ) == zero .AND. b( n+1, n ) == zero ) b( n, n ) = eps3 work( n ) = zero ! i1 = n i2 = 1 i3 = -1 ELSE ! ! UL decomposition with partial pivoting of conjg(B), ! replacing zero pivots by EPS3. ! ! The imaginary part of the (i,j)-th element of U is stored in ! B(j+1,i). ! b( n+1, n ) = wi DO j = 1, n - 1 b( n+1, j ) = zero END DO ! DO j = n, 2, -1 ej = h( j, j-1 ) absbjj = slapy2( b( j, j ), b( j+1, j ) ) IF( absbjj < ABS( ej ) ) THEN ! ! Interchange columns and eliminate ! xr = b( j, j ) / ej xi = b( j+1, j ) / ej b( j, j ) = ej b( j+1, j ) = zero DO i = 1, j - 1 temp = b( i, j-1 ) b( i, j-1 ) = b( i, j ) - xr*temp b( j, i ) = b( j+1, i ) - xi*temp b( i, j ) = temp b( j+1, i ) = zero END DO b( j+1, j-1 ) = wi b( j-1, j-1 ) = b( j-1, j-1 ) + xi*wi b( j, j-1 ) = b( j, j-1 ) - xr*wi ELSE ! ! Eliminate without interchange. ! IF( absbjj == zero ) THEN b( j, j ) = eps3 b( j+1, j ) = zero absbjj = eps3 END IF ej = ( ej / absbjj ) / absbjj xr = b( j, j )*ej xi = -b( j+1, j )*ej DO i = 1, j - 1 b( i, j-1 ) = b( i, j-1 ) - xr*b( i, j ) + xi*b( j+1, i ) b( j, i ) = -xr*b( j+1, i ) - xi*b( i, j ) END DO b( j, j-1 ) = b( j, j-1 ) + wi END IF ! ! Compute 1-norm of offdiagonal elements of j-th column. ! work( j ) = sasum( j-1, b( 1, j ), 1 ) + sasum( j-1, b( j+1, 1 ), ldb ) END DO IF( b( 1, 1 ) == zero .AND. b( 2, 1 ) == zero ) b( 1, 1 ) = eps3 work( 1 ) = zero ! i1 = 1 i2 = n i3 = 1 END IF ! DO its = 1, n scale = one vmax = one vcrit = bignum ! ! Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector, ! or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector, ! overwriting (xr,xi) on (vr,vi). ! DO i = i1, i2, i3 ! IF( work( i ) > vcrit ) THEN REC = one / vmax CALL sscal( n, REC, vr, 1 ) CALL sscal( n, REC, vi, 1 ) scale = scale*REC vmax = one vcrit = bignum END IF ! xr = vr( i ) xi = vi( i ) IF( rightv ) THEN DO j = i + 1, n xr = xr - b( i, j )*vr( j ) + b( j+1, i )*vi( j ) xi = xi - b( i, j )*vi( j ) - b( j+1, i )*vr( j ) END DO ELSE DO j = 1, i - 1 xr = xr - b( j, i )*vr( j ) + b( i+1, j )*vi( j ) xi = xi - b( j, i )*vi( j ) - b( i+1, j )*vr( j ) END DO END IF ! w = ABS( b( i, i ) ) + ABS( b( i+1, i ) ) IF( w > smlnum ) THEN IF( w < one ) THEN w1 = ABS( xr ) + ABS( xi ) IF( w1 > w*bignum ) THEN REC = one / w1 CALL sscal( n, REC, vr, 1 ) CALL sscal( n, REC, vi, 1 ) xr = vr( i ) xi = vi( i ) scale = scale*REC vmax = vmax*REC END IF END IF ! ! Divide by diagonal element of B. ! CALL sladiv( xr, xi, b( i, i ), b( i+1, i ), vr( i ), vi( i ) ) vmax = MAX( ABS( vr( i ) )+ABS( vi( i ) ), vmax ) vcrit = bignum / vmax ELSE DO j = 1, n vr( j ) = zero vi( j ) = zero END DO vr( i ) = one vi( i ) = one scale = zero vmax = one vcrit = bignum END IF END DO ! ! Test for sufficient growth in the norm of (VR,VI). ! vnorm = sasum( n, vr, 1 ) + sasum( n, vi, 1 ) IF( vnorm >= growto*scale ) GO TO 280 ! ! Choose a new orthogonal starting vector and try again. ! y = eps3 / ( rootn+one ) vr( 1 ) = eps3 vi( 1 ) = zero ! DO i = 2, n vr( i ) = y vi( i ) = zero END DO vr( n-its+1 ) = vr( n-its+1 ) - eps3*rootn END DO ! ! Failure to find eigenvector in N iterations ! info = 1 ! 280 CONTINUE ! ! Normalize eigenvector. ! vnorm = zero DO i = 1, n vnorm = MAX( vnorm, ABS( vr( i ) )+ABS( vi( i ) ) ) END DO CALL sscal( n, one / vnorm, vr, 1 ) CALL sscal( n, one / vnorm, vi, 1 ) ! END IF ! RETURN ! ! End of SLAEIN ! END SUBROUTINE slaein SUBROUTINE slaev2( a, b, c, rt1, rt2, cs1, sn1 ) ! ! -- 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 .. REAL, INTENT(IN) :: a REAL, INTENT(IN) :: b REAL, INTENT(IN) :: c REAL, INTENT(OUT) :: rt1 REAL, INTENT(OUT) :: rt2 REAL, INTENT(OUT) :: cs1 REAL, INTENT(OUT) :: sn1 ! .. ! ! Purpose ! ======= ! ! SLAEV2 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) REAL ! The (1,1) element of the 2-by-2 matrix. ! ! B (input) REAL ! The (1,2) element and the conjugate of the (2,1) element of ! the 2-by-2 matrix. ! ! C (input) REAL ! The (2,2) element of the 2-by-2 matrix. ! ! RT1 (output) REAL ! The eigenvalue of larger absolute value. ! ! RT2 (output) REAL ! The eigenvalue of smaller absolute value. ! ! CS1 (output) REAL ! SN1 (output) REAL ! 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 .. REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: half = 0.5E0 ! .. ! .. Local Scalars .. INTEGER :: sgn1, sgn2 REAL :: 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 ) > ABS( c ) ) THEN acmx = a acmn = c ELSE acmx = c acmn = a END IF IF( adf > ab ) THEN rt = adf*SQRT( one+( ab / adf )**2 ) ELSE IF( adf < ab ) THEN rt = ab*SQRT( one+( adf / ab )**2 ) ELSE ! ! Includes case AB=ADF=0 ! rt = ab*SQRT( two ) END IF IF( sm < 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 > 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 >= zero ) THEN cs = df + rt sgn2 = 1 ELSE cs = df - rt sgn2 = -1 END IF acs = ABS( cs ) IF( acs > ab ) THEN ct = -tb / cs sn1 = one / SQRT( one+ct*ct ) cs1 = ct*sn1 ELSE IF( ab == 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 == sgn2 ) THEN tn = cs1 cs1 = -sn1 sn1 = tn END IF RETURN ! ! End of SLAEV2 ! END SUBROUTINE slaev2 SUBROUTINE slaexc( wantq, n, t, ldt, q, ldq, j1, n1, n2, work, 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 .. LOGICAL, INTENT(IN) :: wantq INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: t( ldt, * ) INTEGER, INTENT(IN OUT) :: ldt REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq INTEGER, INTENT(IN OUT) :: j1 INTEGER, INTENT(IN) :: n1 INTEGER, INTENT(IN) :: n2 REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in ! an upper quasi-triangular matrix T by an orthogonal similarity ! transformation. ! ! T must be in Schur canonical form, that is, block upper triangular ! with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block ! has its diagonal elemnts equal and its off-diagonal elements of ! opposite sign. ! ! Arguments ! ========= ! ! WANTQ (input) LOGICAL ! = .TRUE. : accumulate the transformation in the matrix Q; ! = .FALSE.: do not accumulate the transformation. ! ! N (input) INTEGER ! The order of the matrix T. N >= 0. ! ! T (input/output) REAL array, dimension (LDT,N) ! On entry, the upper quasi-triangular matrix T, in Schur ! canonical form. ! On exit, the updated matrix T, again in Schur canonical form. ! ! LDT (input) INTEGER ! The leading dimension of the array T. LDT >= max(1,N). ! ! Q (input/output) REAL array, dimension (LDQ,N) ! On entry, if WANTQ is .TRUE., the orthogonal matrix Q. ! On exit, if WANTQ is .TRUE., the updated matrix Q. ! If WANTQ is .FALSE., Q is not referenced. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. ! LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N. ! ! J1 (input) INTEGER ! The index of the first row of the first block T11. ! ! N1 (input) INTEGER ! The order of the first block T11. N1 = 0, 1 or 2. ! ! N2 (input) INTEGER ! The order of the second block T22. N2 = 0, 1 or 2. ! ! WORK (workspace) REAL array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! = 1: the transformed matrix T would be too far from Schur ! form; the blocks are not swapped and T and Q are ! unchanged. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: ten = 1.0E+1 INTEGER, PARAMETER :: ldd = 4 INTEGER, PARAMETER :: ldx = 2 ! .. ! .. Local Scalars .. INTEGER :: ierr, j2, j3, j4, k, nd REAL :: cs, dnorm, eps, scale, smlnum, sn, t11, t22, & t33, tau, tau1, tau2, temp, thresh, wi1, wi2, wr1, wr2, xnorm ! .. ! .. Local Arrays .. REAL :: d( ldd, 4 ), u( 3 ), u1( 3 ), u2( 3 ), x( ldx, 2 ) ! .. ! .. External Functions .. REAL :: slamch, slange EXTERNAL slamch, slange ! .. ! .. External Subroutines .. EXTERNAL slacpy, slanv2, slarfg, slarfx, slartg, slasy2, srot ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. Executable Statements .. ! info = 0 ! ! Quick return if possible ! IF( n == 0 .OR. n1 == 0 .OR. n2 == 0 ) RETURN IF( j1+n1 > n ) RETURN ! j2 = j1 + 1 j3 = j1 + 2 j4 = j1 + 3 ! IF( n1 == 1 .AND. n2 == 1 ) THEN ! ! Swap two 1-by-1 blocks. ! t11 = t( j1, j1 ) t22 = t( j2, j2 ) ! ! Determine the transformation to perform the interchange. ! CALL slartg( t( j1, j2 ), t22-t11, cs, sn, temp ) ! ! Apply transformation to the matrix T. ! IF( j3 <= n ) CALL srot( n-j1-1, t( j1, j3 ), ldt, t( j2, j3 ), ldt, cs, & sn ) CALL srot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn ) ! t( j1, j1 ) = t22 t( j2, j2 ) = t11 ! IF( wantq ) THEN ! ! Accumulate transformation in the matrix Q. ! CALL srot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn ) END IF ! ELSE ! ! Swapping involves at least one 2-by-2 block. ! ! Copy the diagonal block of order N1+N2 to the local array D ! and compute its norm. ! nd = n1 + n2 CALL slacpy( 'Full', nd, nd, t( j1, j1 ), ldt, d, ldd ) dnorm = slange( 'Max', nd, nd, d, ldd, work ) ! ! Compute machine-dependent threshold for test for accepting ! swap. ! eps = slamch( 'P' ) smlnum = slamch( 'S' ) / eps thresh = MAX( ten*eps*dnorm, smlnum ) ! ! Solve T11*X - X*T22 = scale*T12 for X. ! CALL slasy2( .false., .false., -1, n1, n2, d, ldd, & d( n1+1, n1+1 ), ldd, d( 1, n1+1 ), ldd, scale, x, ldx, xnorm, ierr ) ! ! Swap the adjacent diagonal blocks. ! k = n1 + n1 + n2 - 3 SELECT CASE ( k ) CASE ( 1) GO TO 10 CASE ( 2) GO TO 20 CASE ( 3) GO TO 30 END SELECT ! 10 CONTINUE ! ! N1 = 1, N2 = 2: generate elementary reflector H so that: ! ! ( scale, X11, X12 ) H = ( 0, 0, * ) ! u( 1 ) = scale u( 2 ) = x( 1, 1 ) u( 3 ) = x( 1, 2 ) CALL slarfg( 3, u( 3 ), u, 1, tau ) u( 3 ) = one t11 = t( j1, j1 ) ! ! Perform swap provisionally on diagonal block in D. ! CALL slarfx( 'L', 3, 3, u, tau, d, ldd, work ) CALL slarfx( 'R', 3, 3, u, tau, d, ldd, work ) ! ! Test whether to reject swap. ! IF( MAX( ABS( d( 3, 1 ) ), ABS( d( 3, 2 ) ), ABS( d( 3, & 3 )-t11 ) ) > thresh )GO TO 50 ! ! Accept swap: apply transformation to the entire matrix T. ! CALL slarfx( 'L', 3, n-j1+1, u, tau, t( j1, j1 ), ldt, work ) CALL slarfx( 'R', j2, 3, u, tau, t( 1, j1 ), ldt, work ) ! t( j3, j1 ) = zero t( j3, j2 ) = zero t( j3, j3 ) = t11 ! IF( wantq ) THEN ! ! Accumulate transformation in the matrix Q. ! CALL slarfx( 'R', n, 3, u, tau, q( 1, j1 ), ldq, work ) END IF GO TO 40 ! 20 CONTINUE ! ! N1 = 2, N2 = 1: generate elementary reflector H so that: ! ! H ( -X11 ) = ( * ) ! ( -X21 ) = ( 0 ) ! ( scale ) = ( 0 ) ! u( 1 ) = -x( 1, 1 ) u( 2 ) = -x( 2, 1 ) u( 3 ) = scale CALL slarfg( 3, u( 1 ), u( 2 ), 1, tau ) u( 1 ) = one t33 = t( j3, j3 ) ! ! Perform swap provisionally on diagonal block in D. ! CALL slarfx( 'L', 3, 3, u, tau, d, ldd, work ) CALL slarfx( 'R', 3, 3, u, tau, d, ldd, work ) ! ! Test whether to reject swap. ! IF( MAX( ABS( d( 2, 1 ) ), ABS( d( 3, 1 ) ), ABS( d( 1, & 1 )-t33 ) ) > thresh )GO TO 50 ! ! Accept swap: apply transformation to the entire matrix T. ! CALL slarfx( 'R', j3, 3, u, tau, t( 1, j1 ), ldt, work ) CALL slarfx( 'L', 3, n-j1, u, tau, t( j1, j2 ), ldt, work ) ! t( j1, j1 ) = t33 t( j2, j1 ) = zero t( j3, j1 ) = zero ! IF( wantq ) THEN ! ! Accumulate transformation in the matrix Q. ! CALL slarfx( 'R', n, 3, u, tau, q( 1, j1 ), ldq, work ) END IF GO TO 40 ! 30 CONTINUE ! ! N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so ! that: ! ! H(2) H(1) ( -X11 -X12 ) = ( * * ) ! ( -X21 -X22 ) ( 0 * ) ! ( scale 0 ) ( 0 0 ) ! ( 0 scale ) ( 0 0 ) ! u1( 1 ) = -x( 1, 1 ) u1( 2 ) = -x( 2, 1 ) u1( 3 ) = scale CALL slarfg( 3, u1( 1 ), u1( 2 ), 1, tau1 ) u1( 1 ) = one ! temp = -tau1*( x( 1, 2 )+u1( 2 )*x( 2, 2 ) ) u2( 1 ) = -temp*u1( 2 ) - x( 2, 2 ) u2( 2 ) = -temp*u1( 3 ) u2( 3 ) = scale CALL slarfg( 3, u2( 1 ), u2( 2 ), 1, tau2 ) u2( 1 ) = one ! ! Perform swap provisionally on diagonal block in D. ! CALL slarfx( 'L', 3, 4, u1, tau1, d, ldd, work ) CALL slarfx( 'R', 4, 3, u1, tau1, d, ldd, work ) CALL slarfx( 'L', 3, 4, u2, tau2, d( 2, 1 ), ldd, work ) CALL slarfx( 'R', 4, 3, u2, tau2, d( 1, 2 ), ldd, work ) ! ! Test whether to reject swap. ! IF( MAX( ABS( d( 3, 1 ) ), ABS( d( 3, 2 ) ), ABS( d( 4, 1 ) ), & ABS( d( 4, 2 ) ) ) > thresh )GO TO 50 ! ! Accept swap: apply transformation to the entire matrix T. ! CALL slarfx( 'L', 3, n-j1+1, u1, tau1, t( j1, j1 ), ldt, work ) CALL slarfx( 'R', j4, 3, u1, tau1, t( 1, j1 ), ldt, work ) CALL slarfx( 'L', 3, n-j1+1, u2, tau2, t( j2, j1 ), ldt, work ) CALL slarfx( 'R', j4, 3, u2, tau2, t( 1, j2 ), ldt, work ) ! t( j3, j1 ) = zero t( j3, j2 ) = zero t( j4, j1 ) = zero t( j4, j2 ) = zero ! IF( wantq ) THEN ! ! Accumulate transformation in the matrix Q. ! CALL slarfx( 'R', n, 3, u1, tau1, q( 1, j1 ), ldq, work ) CALL slarfx( 'R', n, 3, u2, tau2, q( 1, j2 ), ldq, work ) END IF ! 40 CONTINUE ! IF( n2 == 2 ) THEN ! ! Standardize new 2-by-2 block T11 ! CALL slanv2( t( j1, j1 ), t( j1, j2 ), t( j2, j1 ), & t( j2, j2 ), wr1, wi1, wr2, wi2, cs, sn ) CALL srot( n-j1-1, t( j1, j1+2 ), ldt, t( j2, j1+2 ), ldt, cs, sn ) CALL srot( j1-1, t( 1, j1 ), 1, t( 1, j2 ), 1, cs, sn ) IF( wantq ) CALL srot( n, q( 1, j1 ), 1, q( 1, j2 ), 1, cs, sn ) END IF ! IF( n1 == 2 ) THEN ! ! Standardize new 2-by-2 block T22 ! j3 = j1 + n2 j4 = j3 + 1 CALL slanv2( t( j3, j3 ), t( j3, j4 ), t( j4, j3 ), & t( j4, j4 ), wr1, wi1, wr2, wi2, cs, sn ) IF( j3+2 <= n ) CALL srot( n-j3-1, t( j3, j3+2 ), ldt, t( j4, j3+2 ), & ldt, cs, sn ) CALL srot( j3-1, t( 1, j3 ), 1, t( 1, j4 ), 1, cs, sn ) IF( wantq ) CALL srot( n, q( 1, j3 ), 1, q( 1, j4 ), 1, cs, sn ) END IF ! END IF RETURN ! ! Exit with INFO = 1 if swap was rejected. ! 50 info = 1 RETURN ! ! End of SLAEXC ! END SUBROUTINE slaexc SUBROUTINE slag2( a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2, wi ) ! ! -- LAPACK auxiliary 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 .. REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: safmin REAL, INTENT(OUT) :: scale1 REAL, INTENT(OUT) :: scale2 REAL, INTENT(OUT) :: wr1 REAL, INTENT(OUT) :: wr2 REAL, INTENT(OUT) :: wi ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue ! problem A - w B, with scaling as necessary to avoid over-/underflow. ! ! The scaling factor "s" results in a modified eigenvalue equation ! ! s A - w B ! ! where s is a non-negative scaling factor chosen so that w, w B, ! and s A do not overflow and, if possible, do not underflow, either. ! ! Arguments ! ========= ! ! A (input) REAL array, dimension (LDA, 2) ! On entry, the 2 x 2 matrix A. It is assumed that its 1-norm ! is less than 1/SAFMIN. Entries less than ! sqrt(SAFMIN)*norm(A) are subject to being treated as zero. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= 2. ! ! B (input) REAL array, dimension (LDB, 2) ! On entry, the 2 x 2 upper triangular matrix B. It is ! assumed that the one-norm of B is less than 1/SAFMIN. The ! diagonals should be at least sqrt(SAFMIN) times the largest ! element of B (in absolute value); if a diagonal is smaller ! than that, then +/- sqrt(SAFMIN) will be used instead of ! that diagonal. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= 2. ! ! SAFMIN (input) REAL ! The smallest positive number s.t. 1/SAFMIN does not ! overflow. (This should always be SLAMCH('S') -- it is an ! argument in order to avoid having to call SLAMCH frequently.) ! ! SCALE1 (output) REAL ! A scaling factor used to avoid over-/underflow in the ! eigenvalue equation which defines the first eigenvalue. If ! the eigenvalues are complex, then the eigenvalues are ! ( WR1 +/- WI i ) / SCALE1 (which may lie outside the ! exponent range of the machine), SCALE1=SCALE2, and SCALE1 ! will always be positive. If the eigenvalues are real, then ! the first (real) eigenvalue is WR1 / SCALE1 , but this may ! overflow or underflow, and in fact, SCALE1 may be zero or ! less than the underflow threshhold if the exact eigenvalue ! is sufficiently large. ! ! SCALE2 (output) REAL ! A scaling factor used to avoid over-/underflow in the ! eigenvalue equation which defines the second eigenvalue. If ! the eigenvalues are complex, then SCALE2=SCALE1. If the ! eigenvalues are real, then the second (real) eigenvalue is ! WR2 / SCALE2 , but this may overflow or underflow, and in ! fact, SCALE2 may be zero or less than the underflow ! threshhold if the exact eigenvalue is sufficiently large. ! ! WR1 (output) REAL ! If the eigenvalue is real, then WR1 is SCALE1 times the ! eigenvalue closest to the (2,2) element of A B**(-1). If the ! eigenvalue is complex, then WR1=WR2 is SCALE1 times the real ! part of the eigenvalues. ! ! WR2 (output) REAL ! If the eigenvalue is real, then WR2 is SCALE2 times the ! other eigenvalue. If the eigenvalue is complex, then ! WR1=WR2 is SCALE1 times the real part of the eigenvalues. ! ! WI (output) REAL ! If the eigenvalue is real, then WI is zero. If the ! eigenvalue is complex, then WI is SCALE1 times the imaginary ! part of the eigenvalues. WI will always be non-negative. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 REAL, PARAMETER :: half = one / two REAL, PARAMETER :: fuzzy1 = one+1.0E-5 ! .. ! .. Local Scalars .. REAL :: a11, a12, a21, a22, abi22, anorm, as11, as12, & as22, ascale, b11, b12, b22, binv11, binv22, & bmin, bnorm, bscale, bsize, c1, c2, c3, c4, c5, & diff, discr, pp, qq, r, rtmax, rtmin, s1, s2, & safmax, shift, ss, sum, wabs, wbig, wdet, wscale, wsize, wsmall ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SIGN, SQRT ! .. ! .. Executable Statements .. ! rtmin = SQRT( safmin ) rtmax = one / rtmin safmax = one / safmin ! ! Scale A ! anorm = MAX( ABS( a( 1, 1 ) )+ABS( a( 2, 1 ) ), & ABS( a( 1, 2 ) )+ABS( a( 2, 2 ) ), safmin ) ascale = one / anorm a11 = ascale*a( 1, 1 ) a21 = ascale*a( 2, 1 ) a12 = ascale*a( 1, 2 ) a22 = ascale*a( 2, 2 ) ! ! Perturb B if necessary to insure non-singularity ! b11 = b( 1, 1 ) b12 = b( 1, 2 ) b22 = b( 2, 2 ) bmin = rtmin*MAX( ABS( b11 ), ABS( b12 ), ABS( b22 ), rtmin ) IF( ABS( b11 ) < bmin ) b11 = SIGN( bmin, b11 ) IF( ABS( b22 ) < bmin ) b22 = SIGN( bmin, b22 ) ! ! Scale B ! bnorm = MAX( ABS( b11 ), ABS( b12 )+ABS( b22 ), safmin ) bsize = MAX( ABS( b11 ), ABS( b22 ) ) bscale = one / bsize b11 = b11*bscale b12 = b12*bscale b22 = b22*bscale ! ! Compute larger eigenvalue by method described by C. van Loan ! ! ( AS is A shifted by -SHIFT*B ) ! binv11 = one / b11 binv22 = one / b22 s1 = a11*binv11 s2 = a22*binv22 IF( ABS( s1 ) <= ABS( s2 ) ) THEN as12 = a12 - s1*b12 as22 = a22 - s1*b22 ss = a21*( binv11*binv22 ) abi22 = as22*binv22 - ss*b12 pp = half*abi22 shift = s1 ELSE as12 = a12 - s2*b12 as11 = a11 - s2*b11 ss = a21*( binv11*binv22 ) abi22 = -ss*b12 pp = half*( as11*binv11+abi22 ) shift = s2 END IF qq = ss*as12 IF( ABS( pp*rtmin ) >= one ) THEN discr = ( rtmin*pp )**2 + qq*safmin r = SQRT( ABS( discr ) )*rtmax ELSE IF( pp**2+ABS( qq ) <= safmin ) THEN discr = ( rtmax*pp )**2 + qq*safmax r = SQRT( ABS( discr ) )*rtmin ELSE discr = pp**2 + qq r = SQRT( ABS( discr ) ) END IF END IF ! ! Note: the test of R in the following IF is to cover the case when ! DISCR is small and negative and is flushed to zero during ! the calculation of R. On machines which have a consistent ! flush-to-zero threshhold and handle numbers above that ! threshhold correctly, it would not be necessary. ! IF( discr >= zero .OR. r == zero ) THEN sum = pp + SIGN( r, pp ) diff = pp - SIGN( r, pp ) wbig = shift + sum ! ! Compute smaller eigenvalue ! wsmall = shift + diff IF( half*ABS( wbig ) > MAX( ABS( wsmall ), safmin ) ) THEN wdet = ( a11*a22-a12*a21 )*( binv11*binv22 ) wsmall = wdet / wbig END IF ! ! Choose (real) eigenvalue closest to 2,2 element of A*B**(-1) ! for WR1. ! IF( pp > abi22 ) THEN wr1 = MIN( wbig, wsmall ) wr2 = MAX( wbig, wsmall ) ELSE wr1 = MAX( wbig, wsmall ) wr2 = MIN( wbig, wsmall ) END IF wi = zero ELSE ! ! Complex eigenvalues ! wr1 = shift + pp wr2 = wr1 wi = r END IF ! ! Further scaling to avoid underflow and overflow in computing ! SCALE1 and overflow in computing w*B. ! ! This scale factor (WSCALE) is bounded from above using C1 and C2, ! and from below using C3 and C4. ! C1 implements the condition s A must never overflow. ! C2 implements the condition w B must never overflow. ! C3, with C2, ! implement the condition that s A - w B must never overflow. ! C4 implements the condition s should not underflow. ! C5 implements the condition max(s,|w|) should be at least 2. ! c1 = bsize*( safmin*MAX( one, ascale ) ) c2 = safmin*MAX( one, bnorm ) c3 = bsize*safmin IF( ascale <= one .AND. bsize <= one ) THEN c4 = MIN( one, ( ascale / safmin )*bsize ) ELSE c4 = one END IF IF( ascale <= one .OR. bsize <= one ) THEN c5 = MIN( one, ascale*bsize ) ELSE c5 = one END IF ! ! Scale first eigenvalue ! wabs = ABS( wr1 ) + ABS( wi ) wsize = MAX( safmin, c1, fuzzy1*( wabs*c2+c3 ), & MIN( c4, half*MAX( wabs, c5 ) ) ) IF( wsize /= one ) THEN wscale = one / wsize IF( wsize > one ) THEN scale1 = ( MAX( ascale, bsize )*wscale )* MIN( ascale, bsize ) ELSE scale1 = ( MIN( ascale, bsize )*wscale )* MAX( ascale, bsize ) END IF wr1 = wr1*wscale IF( wi /= zero ) THEN wi = wi*wscale wr2 = wr1 scale2 = scale1 END IF ELSE scale1 = ascale*bsize scale2 = scale1 END IF ! ! Scale second eigenvalue (if real) ! IF( wi == zero ) THEN wsize = MAX( safmin, c1, fuzzy1*( ABS( wr2 )*c2+c3 ), & MIN( c4, half*MAX( ABS( wr2 ), c5 ) ) ) IF( wsize /= one ) THEN wscale = one / wsize IF( wsize > one ) THEN scale2 = ( MAX( ascale, bsize )*wscale )* MIN( ascale, bsize ) ELSE scale2 = ( MIN( ascale, bsize )*wscale )* MAX( ascale, bsize ) END IF wr2 = wr2*wscale ELSE scale2 = ascale*bsize END IF END IF ! ! End of SLAG2 ! RETURN END SUBROUTINE slag2 SUBROUTINE slags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, csv, & snv, csq, snq ) ! ! -- 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 .. LOGICAL, INTENT(IN) :: upper REAL, INTENT(IN) :: a1 REAL, INTENT(IN) :: a2 REAL, INTENT(IN) :: a3 REAL, INTENT(IN) :: b1 REAL, INTENT(IN) :: b2 REAL, INTENT(IN) :: b3 REAL, INTENT(OUT) :: csu REAL, INTENT(OUT) :: snu REAL, INTENT(OUT) :: csv REAL, INTENT(OUT) :: snv REAL, INTENT(IN OUT) :: csq REAL, INTENT(IN OUT) :: snq ! .. ! ! Purpose ! ======= ! ! SLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such ! that if ( UPPER ) then ! ! U'*A*Q = U'*( A1 A2 )*Q = ( x 0 ) ! ( 0 A3 ) ( x x ) ! and ! V'*B*Q = V'*( B1 B2 )*Q = ( x 0 ) ! ( 0 B3 ) ( x x ) ! ! or if ( .NOT.UPPER ) then ! ! U'*A*Q = U'*( A1 0 )*Q = ( x x ) ! ( A2 A3 ) ( 0 x ) ! and ! V'*B*Q = V'*( B1 0 )*Q = ( x x ) ! ( B2 B3 ) ( 0 x ) ! ! The rows of the transformed A and B are parallel, where ! ! U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ ) ! ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ ) ! ! Z' denotes the transpose of Z. ! ! ! Arguments ! ========= ! ! UPPER (input) LOGICAL ! = .TRUE.: the input matrices A and B are upper triangular. ! = .FALSE.: the input matrices A and B are lower triangular. ! ! A1 (input) REAL ! A2 (input) REAL ! A3 (input) REAL ! On entry, A1, A2 and A3 are elements of the input 2-by-2 ! upper (lower) triangular matrix A. ! ! B1 (input) REAL ! B2 (input) REAL ! B3 (input) REAL ! On entry, B1, B2 and B3 are elements of the input 2-by-2 ! upper (lower) triangular matrix B. ! ! CSU (output) REAL ! SNU (output) REAL ! The desired orthogonal matrix U. ! ! CSV (output) REAL ! SNV (output) REAL ! The desired orthogonal matrix V. ! ! CSQ (output) REAL ! SNQ (output) REAL ! The desired orthogonal matrix Q. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. REAL :: a, aua11, aua12, aua21, aua22, avb11, avb12, & avb21, avb22, csl, csr, d, s1, s2, snl, & snr, ua11r, ua22r, vb11r, vb22r, b, c, r, ua11, & ua12, ua21, ua22, vb11, vb12, vb21, vb22 ! .. ! .. External Subroutines .. EXTERNAL slartg, slasv2 ! .. ! .. Intrinsic Functions .. INTRINSIC ABS ! .. ! .. Executable Statements .. ! IF( upper ) THEN ! ! Input matrices A and B are upper triangular matrices ! ! Form matrix C = A*adj(B) = ( a b ) ! ( 0 d ) ! a = a1*b3 d = a3*b1 b = a2*b1 - a1*b2 ! ! The SVD of real 2-by-2 triangular C ! ! ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 ) ! ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T ) ! CALL slasv2( a, b, d, s1, s2, snr, csr, snl, csl ) ! IF( ABS( csl ) >= ABS( snl ) .OR. ABS( csr ) >= ABS( snr ) ) THEN ! ! Compute the (1,1) and (1,2) elements of U'*A and V'*B, ! and (1,2) element of |U|'*|A| and |V|'*|B|. ! ua11r = csl*a1 ua12 = csl*a2 + snl*a3 ! vb11r = csr*b1 vb12 = csr*b2 + snr*b3 ! aua12 = ABS( csl )*ABS( a2 ) + ABS( snl )*ABS( a3 ) avb12 = ABS( csr )*ABS( b2 ) + ABS( snr )*ABS( b3 ) ! ! zero (1,2) elements of U'*A and V'*B ! IF( ( ABS( ua11r )+ABS( ua12 ) ) /= zero ) THEN IF( aua12 / ( ABS( ua11r )+ABS( ua12 ) ) <= avb12 / & ( ABS( vb11r )+ABS( vb12 ) ) ) THEN CALL slartg( -ua11r, ua12, csq, snq, r ) ELSE CALL slartg( -vb11r, vb12, csq, snq, r ) END IF ELSE CALL slartg( -vb11r, vb12, csq, snq, r ) END IF ! csu = csl snu = -snl csv = csr snv = -snr ! ELSE ! ! Compute the (2,1) and (2,2) elements of U'*A and V'*B, ! and (2,2) element of |U|'*|A| and |V|'*|B|. ! ua21 = -snl*a1 ua22 = -snl*a2 + csl*a3 ! vb21 = -snr*b1 vb22 = -snr*b2 + csr*b3 ! aua22 = ABS( snl )*ABS( a2 ) + ABS( csl )*ABS( a3 ) avb22 = ABS( snr )*ABS( b2 ) + ABS( csr )*ABS( b3 ) ! ! zero (2,2) elements of U'*A and V'*B, and then swap. ! IF( ( ABS( ua21 )+ABS( ua22 ) ) /= zero ) THEN IF( aua22 / ( ABS( ua21 )+ABS( ua22 ) ) <= avb22 / & ( ABS( vb21 )+ABS( vb22 ) ) ) THEN CALL slartg( -ua21, ua22, csq, snq, r ) ELSE CALL slartg( -vb21, vb22, csq, snq, r ) END IF ELSE CALL slartg( -vb21, vb22, csq, snq, r ) END IF ! csu = snl snu = csl csv = snr snv = csr ! END IF ! ELSE ! ! Input matrices A and B are lower triangular matrices ! ! Form matrix C = A*adj(B) = ( a 0 ) ! ( c d ) ! a = a1*b3 d = a3*b1 c = a2*b3 - a3*b2 ! ! The SVD of real 2-by-2 triangular C ! ! ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 ) ! ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T ) ! CALL slasv2( a, c, d, s1, s2, snr, csr, snl, csl ) ! IF( ABS( csr ) >= ABS( snr ) .OR. ABS( csl ) >= ABS( snl ) ) THEN ! ! Compute the (2,1) and (2,2) elements of U'*A and V'*B, ! and (2,1) element of |U|'*|A| and |V|'*|B|. ! ua21 = -snr*a1 + csr*a2 ua22r = csr*a3 ! vb21 = -snl*b1 + csl*b2 vb22r = csl*b3 ! aua21 = ABS( snr )*ABS( a1 ) + ABS( csr )*ABS( a2 ) avb21 = ABS( snl )*ABS( b1 ) + ABS( csl )*ABS( b2 ) ! ! zero (2,1) elements of U'*A and V'*B. ! IF( ( ABS( ua21 )+ABS( ua22r ) ) /= zero ) THEN IF( aua21 / ( ABS( ua21 )+ABS( ua22r ) ) <= avb21 / & ( ABS( vb21 )+ABS( vb22r ) ) ) THEN CALL slartg( ua22r, ua21, csq, snq, r ) ELSE CALL slartg( vb22r, vb21, csq, snq, r ) END IF ELSE CALL slartg( vb22r, vb21, csq, snq, r ) END IF ! csu = csr snu = -snr csv = csl snv = -snl ! ELSE ! ! Compute the (1,1) and (1,2) elements of U'*A and V'*B, ! and (1,1) element of |U|'*|A| and |V|'*|B|. ! ua11 = csr*a1 + snr*a2 ua12 = snr*a3 ! vb11 = csl*b1 + snl*b2 vb12 = snl*b3 ! aua11 = ABS( csr )*ABS( a1 ) + ABS( snr )*ABS( a2 ) avb11 = ABS( csl )*ABS( b1 ) + ABS( snl )*ABS( b2 ) ! ! zero (1,1) elements of U'*A and V'*B, and then swap. ! IF( ( ABS( ua11 )+ABS( ua12 ) ) /= zero ) THEN IF( aua11 / ( ABS( ua11 )+ABS( ua12 ) ) <= avb11 / & ( ABS( vb11 )+ABS( vb12 ) ) ) THEN CALL slartg( ua12, ua11, csq, snq, r ) ELSE CALL slartg( vb12, vb11, csq, snq, r ) END IF ELSE CALL slartg( vb12, vb11, csq, snq, r ) END IF ! csu = snr snu = csr csv = snl snv = csl ! END IF ! END IF ! RETURN ! ! End of SLAGS2 ! END SUBROUTINE slags2 SUBROUTINE slagtf( 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, INTENT(IN OUT) :: n REAL, INTENT(IN OUT) :: a( * ) REAL, INTENT(IN) :: lambda REAL, INTENT(IN OUT) :: b( * ) REAL, INTENT(IN OUT) :: c( * ) REAL, INTENT(IN) :: tol REAL, INTENT(OUT) :: d( * ) INTEGER, INTENT(OUT) :: in( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAGTF 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 SLAGTF may ! be used, in conjunction with SLAGTS, to obtain eigenvectors of T by ! inverse iteration. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The order of the matrix T. ! ! A (input/output) REAL 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) REAL ! On entry, the scalar lambda. ! ! B (input/output) REAL 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) REAL 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) REAL ! 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) REAL 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 .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: k REAL :: eps, mult, piv1, piv2, scale1, scale2, temp, tl ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. External Subroutines .. EXTERNAL xerbla ! .. ! .. Executable Statements .. ! info = 0 IF( n < 0 ) THEN info = -1 CALL xerbla( 'SLAGTF', -info ) RETURN END IF ! IF( n == 0 ) RETURN ! a( 1 ) = a( 1 ) - lambda in( n ) = 0 IF( n == 1 ) THEN IF( a( 1 ) == zero ) in( 1 ) = 1 RETURN END IF ! eps = slamch( 'Epsilon' ) ! tl = MAX( tol, eps ) scale1 = ABS( a( 1 ) ) + ABS( b( 1 ) ) DO k = 1, n - 1 a( k+1 ) = a( k+1 ) - lambda scale2 = ABS( c( k ) ) + ABS( a( k+1 ) ) IF( k < ( n-1 ) ) scale2 = scale2 + ABS( b( k+1 ) ) IF( a( k ) == zero ) THEN piv1 = zero ELSE piv1 = ABS( a( k ) ) / scale1 END IF IF( c( k ) == zero ) THEN in( k ) = 0 piv2 = zero scale1 = scale2 IF( k < ( n-1 ) ) d( k ) = zero ELSE piv2 = ABS( c( k ) ) / scale2 IF( piv2 <= 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 < ( 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 < ( 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 ) <= tl ) .AND. ( in( n ) == 0 ) ) in( n ) = k END DO IF( ( ABS( a( n ) ) <= scale1*tl ) .AND. ( in( n ) == 0 ) ) in( n ) = n ! RETURN ! ! End of SLAGTF ! END SUBROUTINE slagtf SUBROUTINE slagtm( trans, n, nrhs, alpha, dl, d, du, x, ldx, beta, 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 ! October 31, 1992 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: alpha REAL, INTENT(IN) :: dl( * ) REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: du( * ) REAL, INTENT(IN) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(IN) :: beta REAL, INTENT(OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAGTM performs a matrix-vector product of the form ! ! B := alpha * A * X + beta * B ! ! where A is a tridiagonal matrix of order N, B and X are N by NRHS ! matrices, and alpha and beta are real scalars, each of which may be ! 0., 1., or -1. ! ! Arguments ! ========= ! ! TRANS (input) CHARACTER ! Specifies the operation applied to A. ! = 'N': No transpose, B := alpha * A * X + beta * B ! = 'T': Transpose, B := alpha * A'* X + beta * B ! = 'C': 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 matrices X and B. ! ! ALPHA (input) REAL ! The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise, ! it is assumed to be 0. ! ! DL (input) REAL array, dimension (N-1) ! The (n-1) sub-diagonal elements of T. ! ! D (input) REAL array, dimension (N) ! The diagonal elements of T. ! ! DU (input) REAL array, dimension (N-1) ! The (n-1) super-diagonal elements of T. ! ! X (input) REAL array, dimension (LDX,NRHS) ! The N by NRHS matrix X. ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(N,1). ! ! BETA (input) REAL ! The scalar beta. BETA must be 0., 1., or -1.; otherwise, ! it is assumed to be 1. ! ! B (input/output) REAL array, dimension (LDB,NRHS) ! On entry, the N by NRHS matrix B. ! On exit, B is overwritten by the matrix expression ! B := alpha * A * X + beta * B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(N,1). ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Executable Statements .. ! IF( n == 0 ) RETURN ! ! Multiply B by BETA if BETA.NE.1. ! IF( beta == zero ) THEN DO j = 1, nrhs DO i = 1, n b( i, j ) = zero END DO END DO ELSE IF( beta == -one ) THEN DO j = 1, nrhs DO i = 1, n b( i, j ) = -b( i, j ) END DO END DO END IF ! IF( alpha == one ) THEN IF( lsame( trans, 'N' ) ) THEN ! ! Compute B := B + A*X ! DO j = 1, nrhs IF( n == 1 ) THEN b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j ) ELSE b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j ) + du( 1 )*x( 2, j ) b( n, j ) = b( n, j ) + dl( n-1 )*x( n-1, j ) + d( n )*x( n, j ) DO i = 2, n - 1 b( i, j ) = b( i, j ) + dl( i-1 )*x( i-1, j ) + & d( i )*x( i, j ) + du( i )*x( i+1, j ) END DO END IF END DO ELSE ! ! Compute B := B + A'*X ! DO j = 1, nrhs IF( n == 1 ) THEN b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j ) ELSE b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j ) + dl( 1 )*x( 2, j ) b( n, j ) = b( n, j ) + du( n-1 )*x( n-1, j ) + d( n )*x( n, j ) DO i = 2, n - 1 b( i, j ) = b( i, j ) + du( i-1 )*x( i-1, j ) + & d( i )*x( i, j ) + dl( i )*x( i+1, j ) END DO END IF END DO END IF ELSE IF( alpha == -one ) THEN IF( lsame( trans, 'N' ) ) THEN ! ! Compute B := B - A*X ! DO j = 1, nrhs IF( n == 1 ) THEN b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j ) ELSE b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j ) - du( 1 )*x( 2, j ) b( n, j ) = b( n, j ) - dl( n-1 )*x( n-1, j ) - d( n )*x( n, j ) DO i = 2, n - 1 b( i, j ) = b( i, j ) - dl( i-1 )*x( i-1, j ) - & d( i )*x( i, j ) - du( i )*x( i+1, j ) END DO END IF END DO ELSE ! ! Compute B := B - A'*X ! DO j = 1, nrhs IF( n == 1 ) THEN b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j ) ELSE b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j ) - dl( 1 )*x( 2, j ) b( n, j ) = b( n, j ) - du( n-1 )*x( n-1, j ) - d( n )*x( n, j ) DO i = 2, n - 1 b( i, j ) = b( i, j ) - du( i-1 )*x( i-1, j ) - & d( i )*x( i, j ) - dl( i )*x( i+1, j ) END DO END IF END DO END IF END IF RETURN ! ! End of SLAGTM ! END SUBROUTINE slagtm SUBROUTINE slagts( 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, INTENT(IN) :: job INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( * ) REAL, INTENT(IN) :: b( * ) REAL, INTENT(IN) :: c( * ) REAL, INTENT(IN) :: d( * ) INTEGER, INTENT(IN) :: in( * ) REAL, INTENT(OUT) :: y( * ) REAL, INTENT(IN OUT) :: tol INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAGTS 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 SLAGTF. 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 SLAGTS 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) REAL array, dimension (N) ! On entry, A must contain the diagonal elements of U as ! returned from SLAGTF. ! ! B (input) REAL array, dimension (N-1) ! On entry, B must contain the first super-diagonal elements of ! U as returned from SLAGTF. ! ! C (input) REAL array, dimension (N-1) ! On entry, C must contain the sub-diagonal elements of L as ! returned from SLAGTF. ! ! D (input) REAL array, dimension (N-2) ! On entry, D must contain the second super-diagonal elements ! of U as returned from SLAGTF. ! ! IN (input) INTEGER array, dimension (N) ! On entry, IN must contain details of the matrix P as returned ! from SLAGTF. ! ! Y (input/output) REAL array, dimension (N) ! On entry, the right hand side vector y. ! On exit, Y is overwritten by the solution vector x. ! ! TOL (input/output) REAL ! 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 .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: k REAL :: absak, ak, bignum, eps, pert, sfmin, temp ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. External Subroutines .. EXTERNAL xerbla ! .. ! .. Executable Statements .. ! info = 0 IF( ( ABS( job ) > 2 ) .OR. ( job == 0 ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLAGTS', -info ) RETURN END IF ! IF( n == 0 ) RETURN ! eps = slamch( 'Epsilon' ) sfmin = slamch( 'Safe minimum' ) bignum = one / sfmin ! IF( job < 0 ) THEN IF( tol <= zero ) THEN tol = ABS( a( 1 ) ) IF( n > 1 ) tol = MAX( tol, ABS( a( 2 ) ), ABS( b( 1 ) ) ) DO k = 3, n tol = MAX( tol, ABS( a( k ) ), ABS( b( k-1 ) ), ABS( d( k-2 ) ) ) END DO tol = tol*eps IF( tol == zero ) tol = eps END IF END IF ! IF( ABS( job ) == 1 ) THEN DO k = 2, n IF( in( k-1 ) == 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 END DO IF( job == 1 ) THEN DO k = n, 1, -1 IF( k <= n-2 ) THEN temp = y( k ) - b( k )*y( k+1 ) - d( k )*y( k+2 ) ELSE IF( k == 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 < one ) THEN IF( absak < sfmin ) THEN IF( absak == zero .OR. ABS( temp )*sfmin > absak ) THEN info = k RETURN ELSE temp = temp*bignum ak = ak*bignum END IF ELSE IF( ABS( temp ) > absak*bignum ) THEN info = k RETURN END IF END IF y( k ) = temp / ak END DO ELSE DO k = n, 1, -1 IF( k <= n-2 ) THEN temp = y( k ) - b( k )*y( k+1 ) - d( k )*y( k+2 ) ELSE IF( k == 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 < one ) THEN IF( absak < sfmin ) THEN IF( absak == zero .OR. ABS( temp )*sfmin > absak ) THEN ak = ak + pert pert = 2*pert GO TO 40 ELSE temp = temp*bignum ak = ak*bignum END IF ELSE IF( ABS( temp ) > absak*bignum ) THEN ak = ak + pert pert = 2*pert GO TO 40 END IF END IF y( k ) = temp / ak END DO END IF ELSE ! ! Come to here if JOB = 2 or -2 ! IF( job == 2 ) THEN DO k = 1, n IF( k >= 3 ) THEN temp = y( k ) - b( k-1 )*y( k-1 ) - d( k-2 )*y( k-2 ) ELSE IF( k == 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 < one ) THEN IF( absak < sfmin ) THEN IF( absak == zero .OR. ABS( temp )*sfmin > absak ) THEN info = k RETURN ELSE temp = temp*bignum ak = ak*bignum END IF ELSE IF( ABS( temp ) > absak*bignum ) THEN info = k RETURN END IF END IF y( k ) = temp / ak END DO ELSE DO k = 1, n IF( k >= 3 ) THEN temp = y( k ) - b( k-1 )*y( k-1 ) - d( k-2 )*y( k-2 ) ELSE IF( k == 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 < one ) THEN IF( absak < sfmin ) THEN IF( absak == zero .OR. ABS( temp )*sfmin > absak ) THEN ak = ak + pert pert = 2*pert GO TO 70 ELSE temp = temp*bignum ak = ak*bignum END IF ELSE IF( ABS( temp ) > absak*bignum ) THEN ak = ak + pert pert = 2*pert GO TO 70 END IF END IF y( k ) = temp / ak END DO END IF ! DO k = n, 2, -1 IF( in( k-1 ) == 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 END DO END IF ! ! End of SLAGTS ! END SUBROUTINE slagts SUBROUTINE slagv2( a, lda, b, ldb, alphar, alphai, beta, csl, snl, csr, snr ) ! ! -- 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 .. REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(OUT) :: alphar( 2 ) REAL, INTENT(OUT) :: alphai( 2 ) REAL, INTENT(OUT) :: beta( 2 ) REAL, INTENT(OUT) :: csl REAL, INTENT(OUT) :: snl REAL, INTENT(OUT) :: csr REAL, INTENT(OUT) :: snr ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAGV2 computes the Generalized Schur factorization of a real 2-by-2 ! matrix pencil (A,B) where B is upper triangular. This routine ! computes orthogonal (rotation) matrices given by CSL, SNL and CSR, ! SNR such that ! ! 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0 ! types), then ! ! [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] ! [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] ! ! [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] ! [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ], ! ! 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues, ! then ! ! [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ] ! [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ] ! ! [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ] ! [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ] ! ! where b11 >= b22 > 0. ! ! ! Arguments ! ========= ! ! A (input/output) REAL array, dimension (LDA, 2) ! On entry, the 2 x 2 matrix A. ! On exit, A is overwritten by the ``A-part'' of the ! generalized Schur form. ! ! LDA (input) INTEGER ! THe leading dimension of the array A. LDA >= 2. ! ! B (input/output) REAL array, dimension (LDB, 2) ! On entry, the upper triangular 2 x 2 matrix B. ! On exit, B is overwritten by the ``B-part'' of the ! generalized Schur form. ! ! LDB (input) INTEGER ! THe leading dimension of the array B. LDB >= 2. ! ! ALPHAR (output) REAL array, dimension (2) ! ALPHAI (output) REAL array, dimension (2) ! BETA (output) REAL array, dimension (2) ! (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the ! pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may ! be zero. ! ! CSL (output) REAL ! The cosine of the left rotation matrix. ! ! SNL (output) REAL ! The sine of the left rotation matrix. ! ! CSR (output) REAL ! The cosine of the right rotation matrix. ! ! SNR (output) REAL ! The sine of the right rotation matrix. ! ! Further Details ! =============== ! ! Based on contributions by ! Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. REAL :: anorm, ascale, bnorm, bscale, h1, h2, h3, qq, & r, rr, safmin, scale1, scale2, t, ulp, wi, wr1, wr2 ! .. ! .. External Subroutines .. EXTERNAL slag2, slartg, slasv2, srot ! .. ! .. External Functions .. REAL :: slamch, slapy2 EXTERNAL slamch, slapy2 ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. Executable Statements .. ! safmin = slamch( 'S' ) ulp = slamch( 'P' ) ! ! Scale A ! anorm = MAX( ABS( a( 1, 1 ) )+ABS( a( 2, 1 ) ), & ABS( a( 1, 2 ) )+ABS( a( 2, 2 ) ), safmin ) ascale = one / anorm a( 1, 1 ) = ascale*a( 1, 1 ) a( 1, 2 ) = ascale*a( 1, 2 ) a( 2, 1 ) = ascale*a( 2, 1 ) a( 2, 2 ) = ascale*a( 2, 2 ) ! ! Scale B ! bnorm = MAX( ABS( b( 1, 1 ) ), ABS( b( 1, 2 ) )+ABS( b( 2, 2 ) ), safmin ) bscale = one / bnorm b( 1, 1 ) = bscale*b( 1, 1 ) b( 1, 2 ) = bscale*b( 1, 2 ) b( 2, 2 ) = bscale*b( 2, 2 ) ! ! Check if A can be deflated ! IF( ABS( a( 2, 1 ) ) <= ulp ) THEN csl = one snl = zero csr = one snr = zero a( 2, 1 ) = zero b( 2, 1 ) = zero ! ! Check if B is singular ! ELSE IF( ABS( b( 1, 1 ) ) <= ulp ) THEN CALL slartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r ) csr = one snr = zero CALL srot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) CALL srot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) a( 2, 1 ) = zero b( 1, 1 ) = zero b( 2, 1 ) = zero ! ELSE IF( ABS( b( 2, 2 ) ) <= ulp ) THEN CALL slartg( a( 2, 2 ), a( 2, 1 ), csr, snr, t ) snr = -snr CALL srot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) CALL srot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) csl = one snl = zero a( 2, 1 ) = zero b( 2, 1 ) = zero b( 2, 2 ) = zero ! ELSE ! ! B is nonsingular, first compute the eigenvalues of (A,B) ! CALL slag2( a, lda, b, ldb, safmin, scale1, scale2, wr1, wr2, wi ) ! IF( wi == zero ) THEN ! ! two real eigenvalues, compute s*A-w*B ! h1 = scale1*a( 1, 1 ) - wr1*b( 1, 1 ) h2 = scale1*a( 1, 2 ) - wr1*b( 1, 2 ) h3 = scale1*a( 2, 2 ) - wr1*b( 2, 2 ) ! rr = slapy2( h1, h2 ) qq = slapy2( scale1*a( 2, 1 ), h3 ) ! IF( rr > qq ) THEN ! ! find right rotation matrix to zero 1,1 element of ! (sA - wB) ! CALL slartg( h2, h1, csr, snr, t ) ! ELSE ! ! find right rotation matrix to zero 2,1 element of ! (sA - wB) ! CALL slartg( h3, scale1*a( 2, 1 ), csr, snr, t ) ! END IF ! snr = -snr CALL srot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) CALL srot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) ! ! compute inf norms of A and B ! h1 = MAX( ABS( a( 1, 1 ) )+ABS( a( 1, 2 ) ), & ABS( a( 2, 1 ) )+ABS( a( 2, 2 ) ) ) h2 = MAX( ABS( b( 1, 1 ) )+ABS( b( 1, 2 ) ), & ABS( b( 2, 1 ) )+ABS( b( 2, 2 ) ) ) ! IF( ( scale1*h1 ) >= ABS( wr1 )*h2 ) THEN ! ! find left rotation matrix Q to zero out B(2,1) ! CALL slartg( b( 1, 1 ), b( 2, 1 ), csl, snl, r ) ! ELSE ! ! find left rotation matrix Q to zero out A(2,1) ! CALL slartg( a( 1, 1 ), a( 2, 1 ), csl, snl, r ) ! END IF ! CALL srot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) CALL srot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) ! a( 2, 1 ) = zero b( 2, 1 ) = zero ! ELSE ! ! a pair of complex conjugate eigenvalues ! first compute the SVD of the matrix B ! CALL slasv2( b( 1, 1 ), b( 1, 2 ), b( 2, 2 ), r, t, snr, csr, snl, csl ) ! ! Form (A,B) := Q(A,B)Z' where Q is left rotation matrix and ! Z is right rotation matrix computed from SLASV2 ! CALL srot( 2, a( 1, 1 ), lda, a( 2, 1 ), lda, csl, snl ) CALL srot( 2, b( 1, 1 ), ldb, b( 2, 1 ), ldb, csl, snl ) CALL srot( 2, a( 1, 1 ), 1, a( 1, 2 ), 1, csr, snr ) CALL srot( 2, b( 1, 1 ), 1, b( 1, 2 ), 1, csr, snr ) ! b( 2, 1 ) = zero b( 1, 2 ) = zero ! END IF ! END IF ! ! Unscaling ! a( 1, 1 ) = anorm*a( 1, 1 ) a( 2, 1 ) = anorm*a( 2, 1 ) a( 1, 2 ) = anorm*a( 1, 2 ) a( 2, 2 ) = anorm*a( 2, 2 ) b( 1, 1 ) = bnorm*b( 1, 1 ) b( 2, 1 ) = bnorm*b( 2, 1 ) b( 1, 2 ) = bnorm*b( 1, 2 ) b( 2, 2 ) = bnorm*b( 2, 2 ) ! IF( wi == zero ) THEN alphar( 1 ) = a( 1, 1 ) alphar( 2 ) = a( 2, 2 ) alphai( 1 ) = zero alphai( 2 ) = zero beta( 1 ) = b( 1, 1 ) beta( 2 ) = b( 2, 2 ) ELSE alphar( 1 ) = anorm*wr1 / scale1 / bnorm alphai( 1 ) = anorm*wi / scale1 / bnorm alphar( 2 ) = alphar( 1 ) alphai( 2 ) = -alphai( 1 ) beta( 1 ) = one beta( 2 ) = one END IF ! 10 CONTINUE ! RETURN ! ! End of SLAGV2 ! END SUBROUTINE slagv2 SUBROUTINE slahqr( wantt, wantz, n, ilo, ihi, h, ldh, wr, wi, & iloz, ihiz, z, ldz, 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 .. LOGICAL, INTENT(IN) :: wantt LOGICAL, INTENT(IN) :: wantz INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: ilo INTEGER, INTENT(IN) :: ihi REAL, INTENT(IN OUT) :: h( ldh, * ) INTEGER, INTENT(IN) :: ldh REAL, INTENT(OUT) :: wr( * ) REAL, INTENT(OUT) :: wi( * ) INTEGER, INTENT(IN) :: iloz INTEGER, INTENT(IN) :: ihiz REAL, INTENT(IN OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAHQR is an auxiliary routine called by SHSEQR to update the ! eigenvalues and Schur decomposition already computed by SHSEQR, by ! dealing with the Hessenberg submatrix in rows and columns ILO to IHI. ! ! Arguments ! ========= ! ! WANTT (input) LOGICAL ! = .TRUE. : the full Schur form T is required; ! = .FALSE.: only eigenvalues are required. ! ! WANTZ (input) LOGICAL ! = .TRUE. : the matrix of Schur vectors Z is required; ! = .FALSE.: Schur vectors are not required. ! ! N (input) INTEGER ! The order of the matrix H. N >= 0. ! ! ILO (input) INTEGER ! IHI (input) INTEGER ! It is assumed that H is already upper quasi-triangular in ! rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ! ILO = 1). SLAHQR works primarily with the Hessenberg ! submatrix in rows and columns ILO to IHI, but applies ! transformations to all of H if WANTT is .TRUE.. ! 1 <= ILO <= max(1,IHI); IHI <= N. ! ! H (input/output) REAL array, dimension (LDH,N) ! On entry, the upper Hessenberg matrix H. ! On exit, if WANTT is .TRUE., H is upper quasi-triangular in ! rows and columns ILO:IHI, with any 2-by-2 diagonal blocks in ! standard form. If WANTT is .FALSE., the contents of H are ! unspecified on exit. ! ! LDH (input) INTEGER ! The leading dimension of the array H. LDH >= max(1,N). ! ! WR (output) REAL array, dimension (N) ! WI (output) REAL array, dimension (N) ! The real and imaginary parts, respectively, of the computed ! eigenvalues ILO to IHI are stored in the corresponding ! elements of WR and WI. If two eigenvalues are computed as a ! complex conjugate pair, they are stored in consecutive ! elements of WR and WI, say the i-th and (i+1)th, with ! WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the ! eigenvalues are stored in the same order as on the diagonal ! of the Schur form returned in H, with WR(i) = H(i,i), and, if ! H(i:i+1,i:i+1) is a 2-by-2 diagonal block, ! WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). ! ! ILOZ (input) INTEGER ! IHIZ (input) INTEGER ! Specify the rows of Z to which transformations must be ! applied if WANTZ is .TRUE.. ! 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. ! ! Z (input/output) REAL array, dimension (LDZ,N) ! If WANTZ is .TRUE., on entry Z must contain the current ! matrix Z of transformations accumulated by SHSEQR, and on ! exit Z has been updated; transformations are applied only to ! the submatrix Z(ILOZ:IHIZ,ILO:IHI). ! If WANTZ is .FALSE., Z is not referenced. ! ! LDZ (input) INTEGER ! The leading dimension of the array Z. LDZ >= max(1,N). ! ! INFO (output) INTEGER ! = 0: successful exit ! > 0: SLAHQR failed to compute all the eigenvalues ILO to IHI ! in a total of 30*(IHI-ILO+1) iterations; if INFO = i, ! elements i+1:ihi of WR and WI contain those eigenvalues ! which have been successfully computed. ! ! Further Details ! =============== ! ! 2-96 Based on modifications by ! David Day, Sandia National Laboratory, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: half = 0.5E0 REAL, PARAMETER :: dat1 = 0.75E+0 REAL, PARAMETER :: dat2 = -0.4375E+0 ! .. ! .. Local Scalars .. INTEGER :: i, i1, i2, itn, its, j, k, l, m, nh, nr, nz REAL :: ave, cs, disc, h00, h10, h11, h12, h21, h22, & h33, h33s, h43h34, h44, h44s, ovfl, s, smlnum, & sn, sum, t1, t2, t3, tst1, ulp, unfl, v1, v2, v3 ! .. ! .. Local Arrays .. REAL :: v( 3 ), work( 1 ) ! .. ! .. External Functions .. REAL :: slamch, slanhs EXTERNAL slamch, slanhs ! .. ! .. External Subroutines .. EXTERNAL scopy, slabad, slanv2, slarfg, srot ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SIGN, SQRT ! .. ! .. Executable Statements .. ! info = 0 ! ! Quick return if possible ! IF( n == 0 ) RETURN IF( ilo == ihi ) THEN wr( ilo ) = h( ilo, ilo ) wi( ilo ) = zero RETURN END IF ! nh = ihi - ilo + 1 nz = ihiz - iloz + 1 ! ! Set machine-dependent constants for the stopping criterion. ! If norm(H) <= sqrt(OVFL), overflow should not occur. ! unfl = slamch( 'Safe minimum' ) ovfl = one / unfl CALL slabad( unfl, ovfl ) ulp = slamch( 'Precision' ) smlnum = unfl*( nh / ulp ) ! ! I1 and I2 are the indices of the first row and last column of H ! to which transformations must be applied. If eigenvalues only are ! being computed, I1 and I2 are set inside the main loop. ! IF( wantt ) THEN i1 = 1 i2 = n END IF ! ! ITN is the total number of QR iterations allowed. ! itn = 30*nh ! ! The main loop begins here. I is the loop index and decreases from ! IHI to ILO in steps of 1 or 2. Each iteration of the loop works ! with the active submatrix in rows and columns L to I. ! Eigenvalues I+1 to IHI have already converged. Either L = ILO or ! H(L,L-1) is negligible so that the matrix splits. ! i = ihi 10 CONTINUE l = ilo IF( i < ilo ) GO TO 150 ! ! Perform QR iterations on rows and columns ILO to I until a ! submatrix of order 1 or 2 splits off at the bottom because a ! subdiagonal element has become negligible. ! DO its = 0, itn ! ! Look for a single small subdiagonal element. ! DO k = i, l + 1, -1 tst1 = ABS( h( k-1, k-1 ) ) + ABS( h( k, k ) ) IF( tst1 == zero ) tst1 = slanhs( '1', i-l+1, h( l, l ), ldh, work ) IF( ABS( h( k, k-1 ) ) <= MAX( ulp*tst1, smlnum ) ) EXIT END DO 30 CONTINUE l = k IF( l > ilo ) THEN ! ! H(L,L-1) is negligible ! h( l, l-1 ) = zero END IF ! ! Exit from loop if a submatrix of order 1 or 2 has split off. ! IF( l >= i-1 ) GO TO 140 ! ! Now the active submatrix is in rows and columns L to I. If ! eigenvalues only are being computed, only the active submatrix ! need be transformed. ! IF( .NOT.wantt ) THEN i1 = l i2 = i END IF ! IF( its == 10 .OR. its == 20 ) THEN ! ! Exceptional shift. ! s = ABS( h( i, i-1 ) ) + ABS( h( i-1, i-2 ) ) h44 = dat1*s + h( i, i ) h33 = h44 h43h34 = dat2*s*s ELSE ! ! Prepare to use Francis' double shift ! (i.e. 2nd degree generalized Rayleigh quotient) ! h44 = h( i, i ) h33 = h( i-1, i-1 ) h43h34 = h( i, i-1 )*h( i-1, i ) s = h( i-1, i-2 )*h( i-1, i-2 ) disc = ( h33-h44 )*half disc = disc*disc + h43h34 IF( disc > zero ) THEN ! ! Real roots: use Wilkinson's shift twice ! disc = SQRT( disc ) ave = half*( h33+h44 ) IF( ABS( h33 )-ABS( h44 ) > zero ) THEN h33 = h33*h44 - h43h34 h44 = h33 / ( SIGN( disc, ave )+ave ) ELSE h44 = SIGN( disc, ave ) + ave END IF h33 = h44 h43h34 = zero END IF END IF ! ! Look for two consecutive small subdiagonal elements. ! DO m = i - 2, l, -1 ! Determine the effect of starting the double-shift QR ! iteration at row M, and see if this would make H(M,M-1) ! negligible. ! h11 = h( m, m ) h22 = h( m+1, m+1 ) h21 = h( m+1, m ) h12 = h( m, m+1 ) h44s = h44 - h11 h33s = h33 - h11 v1 = ( h33s*h44s-h43h34 ) / h21 + h12 v2 = h22 - h11 - h33s - h44s v3 = h( m+2, m+1 ) s = ABS( v1 ) + ABS( v2 ) + ABS( v3 ) v1 = v1 / s v2 = v2 / s v3 = v3 / s v( 1 ) = v1 v( 2 ) = v2 v( 3 ) = v3 IF( m == l ) EXIT h00 = h( m-1, m-1 ) h10 = h( m, m-1 ) tst1 = ABS( v1 )*( ABS( h00 )+ABS( h11 )+ABS( h22 ) ) IF( ABS( h10 )*( ABS( v2 )+ABS( v3 ) ) <= ulp*tst1 ) EXIT END DO 50 CONTINUE ! ! Double-shift QR step ! DO k = m, i - 1 ! ! The first iteration of this loop determines a reflection G ! from the vector V and applies it from left and right to H, ! thus creating a nonzero bulge below the subdiagonal. ! ! Each subsequent iteration determines a reflection G to ! restore the Hessenberg form in the (K-1)th column, and thus ! chases the bulge one step toward the bottom of the active ! submatrix. NR is the order of G. ! nr = MIN( 3, i-k+1 ) IF( k > m ) CALL scopy( nr, h( k, k-1 ), 1, v, 1 ) CALL slarfg( nr, v( 1 ), v( 2 ), 1, t1 ) IF( k > m ) THEN h( k, k-1 ) = v( 1 ) h( k+1, k-1 ) = zero IF( k < i-1 ) h( k+2, k-1 ) = zero ELSE IF( m > l ) THEN h( k, k-1 ) = -h( k, k-1 ) END IF v2 = v( 2 ) t2 = t1*v2 IF( nr == 3 ) THEN v3 = v( 3 ) t3 = t1*v3 ! ! Apply G from the left to transform the rows of the matrix ! in columns K to I2. ! DO j = k, i2 sum = h( k, j ) + v2*h( k+1, j ) + v3*h( k+2, j ) h( k, j ) = h( k, j ) - sum*t1 h( k+1, j ) = h( k+1, j ) - sum*t2 h( k+2, j ) = h( k+2, j ) - sum*t3 END DO ! ! Apply G from the right to transform the columns of the ! matrix in rows I1 to min(K+3,I). ! DO j = i1, MIN( k+3, i ) sum = h( j, k ) + v2*h( j, k+1 ) + v3*h( j, k+2 ) h( j, k ) = h( j, k ) - sum*t1 h( j, k+1 ) = h( j, k+1 ) - sum*t2 h( j, k+2 ) = h( j, k+2 ) - sum*t3 END DO ! IF( wantz ) THEN ! ! Accumulate transformations in the matrix Z ! DO j = iloz, ihiz sum = z( j, k ) + v2*z( j, k+1 ) + v3*z( j, k+2 ) z( j, k ) = z( j, k ) - sum*t1 z( j, k+1 ) = z( j, k+1 ) - sum*t2 z( j, k+2 ) = z( j, k+2 ) - sum*t3 END DO END IF ELSE IF( nr == 2 ) THEN ! ! Apply G from the left to transform the rows of the matrix ! in columns K to I2. ! DO j = k, i2 sum = h( k, j ) + v2*h( k+1, j ) h( k, j ) = h( k, j ) - sum*t1 h( k+1, j ) = h( k+1, j ) - sum*t2 END DO ! ! Apply G from the right to transform the columns of the ! matrix in rows I1 to min(K+3,I). ! DO j = i1, i sum = h( j, k ) + v2*h( j, k+1 ) h( j, k ) = h( j, k ) - sum*t1 h( j, k+1 ) = h( j, k+1 ) - sum*t2 END DO ! IF( wantz ) THEN ! ! Accumulate transformations in the matrix Z ! DO j = iloz, ihiz sum = z( j, k ) + v2*z( j, k+1 ) z( j, k ) = z( j, k ) - sum*t1 z( j, k+1 ) = z( j, k+1 ) - sum*t2 END DO END IF END IF END DO ! END DO ! ! Failure to converge in remaining number of iterations ! info = i RETURN ! 140 CONTINUE ! IF( l == i ) THEN ! ! H(I,I-1) is negligible: one eigenvalue has converged. ! wr( i ) = h( i, i ) wi( i ) = zero ELSE IF( l == i-1 ) THEN ! ! H(I-1,I-2) is negligible: a pair of eigenvalues have converged. ! ! Transform the 2-by-2 submatrix to standard Schur form, ! and compute and store the eigenvalues. ! CALL slanv2( h( i-1, i-1 ), h( i-1, i ), h( i, i-1 ), & h( i, i ), wr( i-1 ), wi( i-1 ), wr( i ), wi( i ), cs, sn ) ! IF( wantt ) THEN ! ! Apply the transformation to the rest of H. ! IF( i2 > i ) CALL srot( i2-i, h( i-1, i+1 ), ldh, h( i, i+1 ), ldh, & cs, sn ) CALL srot( i-i1-1, h( i1, i-1 ), 1, h( i1, i ), 1, cs, sn ) END IF IF( wantz ) THEN ! ! Apply the transformation to Z. ! CALL srot( nz, z( iloz, i-1 ), 1, z( iloz, i ), 1, cs, sn ) END IF END IF ! ! Decrement number of remaining iterations, and return to start of ! the main loop with new value of I. ! itn = itn - its i = l - 1 GO TO 10 ! 150 CONTINUE RETURN ! ! End of SLAHQR ! END SUBROUTINE slahqr SUBROUTINE slahrd ( n, k, nb, a, lda, tau, t, ldt, 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 ! June 30, 1999 ! INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k INTEGER, INTENT(IN OUT) :: nb REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: tau( nb ) REAL, INTENT(OUT) :: t( ldt, nb ) INTEGER, INTENT(IN OUT) :: ldt REAL, INTENT(IN OUT) :: y( ldy, nb ) INTEGER, INTENT(IN OUT) :: ldy ! ! Purpose ! ======= ! ! SLAHRD reduces the first NB columns of a real general n-by-(n-k+1) ! matrix A so that elements below the k-th subdiagonal are zero. The ! reduction is performed by an orthogonal similarity transformation ! Q' * A * Q. The routine returns the matrices V and T which determine ! Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T. ! ! This is an auxiliary routine called by SGEHRD. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The order of the matrix A. ! ! K (input) INTEGER ! The offset for the reduction. Elements below the k-th ! subdiagonal in the first NB columns are reduced to zero. ! ! NB (input) INTEGER ! The number of columns to be reduced. ! ! A (input/output) REAL array, dimension (LDA,N-K+1) ! On entry, the n-by-(n-k+1) general matrix A. ! On exit, the elements on and above the k-th subdiagonal in ! the first NB columns are overwritten with the corresponding ! elements of the reduced matrix; the elements below the k-th ! subdiagonal, with the array TAU, represent the matrix Q as a ! product of elementary reflectors. The other columns of A are ! unchanged. See Further Details. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! TAU (output) REAL array, dimension (NB) ! The scalar factors of the elementary reflectors. See Further ! Details. ! ! T (output) REAL array, dimension (LDT,NB) ! The upper triangular matrix T. ! ! LDT (input) INTEGER ! The leading dimension of the array T. LDT >= NB. ! ! Y (output) REAL array, dimension (LDY,NB) ! The n-by-nb matrix Y. ! ! LDY (input) INTEGER ! The leading dimension of the array Y. LDY >= N. ! ! Further Details ! =============== ! ! The matrix Q is represented as a product of nb 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+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in ! A(i+k+1:n,i), and tau in TAU(i). ! ! The elements of the vectors v together form the (n-k+1)-by-nb matrix ! V which is needed, with T and Y, to apply the transformation to the ! unreduced part of the matrix, using an update of the form: ! A := (I - V*T*V') * (A - Y*V'). ! ! The contents of A on exit are illustrated by the following example ! with n = 7, k = 3 and nb = 2: ! ! ( a h a a a ) ! ( a h a a a ) ! ( a h a a a ) ! ( h h a a a ) ! ( v1 h a a a ) ! ( v1 v2 a a a ) ! ( v1 v2 a a a ) ! ! where a denotes an element of the original matrix A, h denotes a ! modified element of the upper Hessenberg matrix H, and vi denotes an ! element of the vector defining H(i). ! ! ===================================================================== ! REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 INTEGER :: i REAL :: ei EXTERNAL saxpy, scopy, sgemv, slarfg, sscal, strmv INTRINSIC MIN ! ! Quick return if possible ! IF ( n <= 1 ) then RETURN END IF DO i = 1, nb IF( i > 1 ) THEN ! ! Update A(1:n,i) ! ! Compute i-th column of A - Y * V' ! CALL sgemv( 'No transpose', n, i-1, -one, y, ldy, & a( k+i-1, 1 ), lda, one, a( 1, i ), 1 ) ! ! Apply I - V * T' * V' to this column (call it b) from the ! left, using the last column of T as workspace ! ! Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) ! ( V2 ) ( b2 ) ! ! where V1 is unit lower triangular ! ! w := V1' * b1 ! CALL scopy( i-1, a( k+1, i ), 1, t( 1, nb ), 1 ) CALL strmv( 'Lower', 'Transpose', 'Unit', i-1, a( k+1, 1 ), & lda, t( 1, nb ), 1 ) ! ! w := w + V2'*b2 ! CALL sgemv( 'Transpose', n-k-i+1, i-1, one, a( k+i, 1 ), & lda, a( k+i, i ), 1, one, t( 1, nb ), 1 ) ! ! w := T'*w ! CALL strmv( 'Upper', 'Transpose', 'Non-unit', i-1, t, ldt, t( 1, nb ), 1 ) ! ! b2 := b2 - V2*w ! CALL sgemv( 'No transpose', n-k-i+1, i-1, -one, a( k+i, 1 ), & lda, t( 1, nb ), 1, one, a( k+i, i ), 1 ) ! ! b1 := b1 - V1*w ! CALL strmv( 'Lower', 'No transpose', 'Unit', i-1, & a( k+1, 1 ), lda, t( 1, nb ), 1 ) CALL saxpy( i-1, -one, t( 1, nb ), 1, a( k+1, i ), 1 ) ! a( k+i-1, i-1 ) = ei END IF ! ! Generate the elementary reflector H(i) to annihilate ! A(k+i+1:n,i) ! CALL slarfg( n-k-i+1, a( k+i, i ), a( MIN( k+i+1, n ), i ), 1, tau( i ) ) ei = a( k+i, i ) a( k+i, i ) = one ! ! Compute Y(1:n,i) ! CALL sgemv( 'No transpose', n, n-k-i+1, one, a( 1, i+1 ), lda, & a( k+i, i ), 1, zero, y( 1, i ), 1 ) CALL sgemv( 'Transpose', n-k-i+1, i-1, one, a( k+i, 1 ), lda, & a( k+i, i ), 1, zero, t( 1, i ), 1 ) CALL sgemv( 'No transpose', n, i-1, -one, y, ldy, t( 1, i ), 1, & one, y( 1, i ), 1 ) CALL sscal( n, tau( i ), y( 1, i ), 1 ) ! ! Compute T(1:i,i) ! CALL sscal( i-1, -tau( i ), t( 1, i ), 1 ) CALL strmv( 'Upper', 'No transpose', 'Non-unit', i-1, t, ldt, t( 1, i ), 1 ) t( i, i ) = tau( i ) ! END DO a( k+nb, nb ) = ei ! RETURN ! ! End of SLAHRD ! END SUBROUTINE slahrd SUBROUTINE slaic1( job, j, x, sest, w, gamma, sestpr, s, c ) ! ! -- 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, INTENT(IN) :: job INTEGER, INTENT(IN) :: j REAL, INTENT(IN) :: x( j ) REAL, INTENT(IN) :: sest REAL, INTENT(IN) :: w( j ) REAL, INTENT(IN) :: gamma REAL, INTENT(OUT) :: sestpr REAL, INTENT(OUT) :: s REAL, INTENT(OUT) :: c ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAIC1 applies one step of incremental condition estimation in ! its simplest version: ! ! Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j ! lower triangular matrix L, such that ! twonorm(L*x) = sest ! Then SLAIC1 computes sestpr, s, c such that ! the vector ! [ s*x ] ! xhat = [ c ] ! is an approximate singular vector of ! [ L 0 ] ! Lhat = [ w' gamma ] ! in the sense that ! twonorm(Lhat*xhat) = sestpr. ! ! Depending on JOB, an estimate for the largest or smallest singular ! value is computed. ! ! Note that [s c]' and sestpr**2 is an eigenpair of the system ! ! diag(sest*sest, 0) + [alpha gamma] * [ alpha ] ! [ gamma ] ! ! where alpha = x'*w. ! ! Arguments ! ========= ! ! JOB (input) INTEGER ! = 1: an estimate for the largest singular value is computed. ! = 2: an estimate for the smallest singular value is computed. ! ! J (input) INTEGER ! Length of X and W ! ! X (input) REAL array, dimension (J) ! The j-vector x. ! ! SEST (input) REAL ! Estimated singular value of j by j matrix L ! ! W (input) REAL array, dimension (J) ! The j-vector w. ! ! GAMMA (input) REAL ! The diagonal element gamma. ! ! SESTPR (output) REAL ! Estimated singular value of (j+1) by (j+1) matrix Lhat. ! ! S (output) REAL ! Sine needed in forming xhat. ! ! C (output) REAL ! Cosine needed in forming xhat. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: half = 0.5E0 REAL, PARAMETER :: four = 4.0E0 ! .. ! .. Local Scalars .. REAL :: absalp, absest, absgam, alpha, b, cosine, eps, & norma, s1, s2, sine, t, test, tmp, zeta1, zeta2 ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, SQRT ! .. ! .. External Functions .. REAL :: sdot, slamch EXTERNAL sdot, slamch ! .. ! .. Executable Statements .. ! eps = slamch( 'Epsilon' ) alpha = sdot( j, x, 1, w, 1 ) ! absalp = ABS( alpha ) absgam = ABS( gamma ) absest = ABS( sest ) ! IF( job == 1 ) THEN ! ! Estimating largest singular value ! ! special cases ! IF( sest == zero ) THEN s1 = MAX( absgam, absalp ) IF( s1 == zero ) THEN s = zero c = one sestpr = zero ELSE s = alpha / s1 c = gamma / s1 tmp = SQRT( s*s+c*c ) s = s / tmp c = c / tmp sestpr = s1*tmp END IF RETURN ELSE IF( absgam <= eps*absest ) THEN s = one c = zero tmp = MAX( absest, absalp ) s1 = absest / tmp s2 = absalp / tmp sestpr = tmp*SQRT( s1*s1+s2*s2 ) RETURN ELSE IF( absalp <= eps*absest ) THEN s1 = absgam s2 = absest IF( s1 <= s2 ) THEN s = one c = zero sestpr = s2 ELSE s = zero c = one sestpr = s1 END IF RETURN ELSE IF( absest <= eps*absalp .OR. absest <= eps*absgam ) THEN s1 = absgam s2 = absalp IF( s1 <= s2 ) THEN tmp = s1 / s2 s = SQRT( one+tmp*tmp ) sestpr = s2*s c = ( gamma / s2 ) / s s = SIGN( one, alpha ) / s ELSE tmp = s2 / s1 c = SQRT( one+tmp*tmp ) sestpr = s1*c s = ( alpha / s1 ) / c c = SIGN( one, gamma ) / c END IF RETURN ELSE ! ! normal case ! zeta1 = alpha / absest zeta2 = gamma / absest ! b = ( one-zeta1*zeta1-zeta2*zeta2 )*half c = zeta1*zeta1 IF( b > zero ) THEN t = c / ( b+SQRT( b*b+c ) ) ELSE t = SQRT( b*b+c ) - b END IF ! sine = -zeta1 / t cosine = -zeta2 / ( one+t ) tmp = SQRT( sine*sine+cosine*cosine ) s = sine / tmp c = cosine / tmp sestpr = SQRT( t+one )*absest RETURN END IF ! ELSE IF( job == 2 ) THEN ! ! Estimating smallest singular value ! ! special cases ! IF( sest == zero ) THEN sestpr = zero IF( MAX( absgam, absalp ) == zero ) THEN sine = one cosine = zero ELSE sine = -gamma cosine = alpha END IF s1 = MAX( ABS( sine ), ABS( cosine ) ) s = sine / s1 c = cosine / s1 tmp = SQRT( s*s+c*c ) s = s / tmp c = c / tmp RETURN ELSE IF( absgam <= eps*absest ) THEN s = zero c = one sestpr = absgam RETURN ELSE IF( absalp <= eps*absest ) THEN s1 = absgam s2 = absest IF( s1 <= s2 ) THEN s = zero c = one sestpr = s1 ELSE s = one c = zero sestpr = s2 END IF RETURN ELSE IF( absest <= eps*absalp .OR. absest <= eps*absgam ) THEN s1 = absgam s2 = absalp IF( s1 <= s2 ) THEN tmp = s1 / s2 c = SQRT( one+tmp*tmp ) sestpr = absest*( tmp / c ) s = -( gamma / s2 ) / c c = SIGN( one, alpha ) / c ELSE tmp = s2 / s1 s = SQRT( one+tmp*tmp ) sestpr = absest / s c = ( alpha / s1 ) / s s = -SIGN( one, gamma ) / s END IF RETURN ELSE ! ! normal case ! zeta1 = alpha / absest zeta2 = gamma / absest ! norma = MAX( one+zeta1*zeta1+ABS( zeta1*zeta2 ), & ABS( zeta1*zeta2 )+zeta2*zeta2 ) ! ! See if root is closer to zero or to ONE ! test = one + two*( zeta1-zeta2 )*( zeta1+zeta2 ) IF( test >= zero ) THEN ! ! root is close to zero, compute directly ! b = ( zeta1*zeta1+zeta2*zeta2+one )*half c = zeta2*zeta2 t = c / ( b+SQRT( ABS( b*b-c ) ) ) sine = zeta1 / ( one-t ) cosine = -zeta2 / t sestpr = SQRT( t+four*eps*eps*norma )*absest ELSE ! ! root is closer to ONE, shift by that amount ! b = ( zeta2*zeta2+zeta1*zeta1-one )*half c = zeta1*zeta1 IF( b >= zero ) THEN t = -c / ( b+SQRT( b*b+c ) ) ELSE t = b - SQRT( b*b+c ) END IF sine = -zeta1 / t cosine = -zeta2 / ( one+t ) sestpr = SQRT( one+t+four*eps*eps*norma )*absest END IF tmp = SQRT( sine*sine+cosine*cosine ) s = sine / tmp c = cosine / tmp RETURN ! END IF END IF RETURN ! ! End of SLAIC1 ! END SUBROUTINE slaic1 SUBROUTINE slaln2( ltrans, na, nw, smin, ca, a, lda, d1, d2, b, & ldb, wr, wi, x, ldx, scale, xnorm, 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 .. LOGICAL, INTENT(IN) :: ltrans INTEGER, INTENT(IN) :: na INTEGER, INTENT(IN) :: nw REAL, INTENT(IN) :: smin REAL, INTENT(IN) :: ca REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: d1 REAL, INTENT(IN) :: d2 REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: wr REAL, INTENT(IN) :: wi REAL, INTENT(OUT) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: scale REAL, INTENT(OUT) :: xnorm INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLALN2 solves a system of the form (ca A - w D ) X = s B ! or (ca A' - w D) X = s B with possible scaling ("s") and ! perturbation of A. (A' means A-transpose.) ! ! A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA ! real diagonal matrix, w is a real or complex value, and X and B are ! NA x 1 matrices -- real if w is real, complex if w is complex. NA ! may be 1 or 2. ! ! If w is complex, X and B are represented as NA x 2 matrices, ! the first column of each being the real part and the second ! being the imaginary part. ! ! "s" is a scaling factor (.LE. 1), computed by SLALN2, which is ! so chosen that X can be computed without overflow. X is further ! scaled if necessary to assure that norm(ca A - w D)*norm(X) is less ! than overflow. ! ! If both singular values of (ca A - w D) are less than SMIN, ! SMIN*identity will be used instead of (ca A - w D). If only one ! singular value is less than SMIN, one element of (ca A - w D) will be ! perturbed enough to make the smallest singular value roughly SMIN. ! If both singular values are at least SMIN, (ca A - w D) will not be ! perturbed. In any case, the perturbation will be at most some small ! multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values ! are computed by infinity-norm approximations, and thus will only be ! correct to a factor of 2 or so. ! ! Note: all input quantities are assumed to be smaller than overflow ! by a reasonable factor. (See BIGNUM.) ! ! Arguments ! ========== ! ! LTRANS (input) LOGICAL ! =.TRUE.: A-transpose will be used. ! =.FALSE.: A will be used (not transposed.) ! ! NA (input) INTEGER ! The size of the matrix A. It may (only) be 1 or 2. ! ! NW (input) INTEGER ! 1 if "w" is real, 2 if "w" is complex. It may only be 1 ! or 2. ! ! SMIN (input) REAL ! The desired lower bound on the singular values of A. This ! should be a safe distance away from underflow or overflow, ! say, between (underflow/machine precision) and (machine ! precision * overflow ). (See BIGNUM and ULP.) ! ! CA (input) REAL ! The coefficient c, which A is multiplied by. ! ! A (input) REAL array, dimension (LDA,NA) ! The NA x NA matrix A. ! ! LDA (input) INTEGER ! The leading dimension of A. It must be at least NA. ! ! D1 (input) REAL ! The 1,1 element in the diagonal matrix D. ! ! D2 (input) REAL ! The 2,2 element in the diagonal matrix D. Not used if NW=1. ! ! B (input) REAL array, dimension (LDB,NW) ! The NA x NW matrix B (right-hand side). If NW=2 ("w" is ! complex), column 1 contains the real part of B and column 2 ! contains the imaginary part. ! ! LDB (input) INTEGER ! The leading dimension of B. It must be at least NA. ! ! WR (input) REAL ! The real part of the scalar "w". ! ! WI (input) REAL ! The imaginary part of the scalar "w". Not used if NW=1. ! ! X (output) REAL array, dimension (LDX,NW) ! The NA x NW matrix X (unknowns), as computed by SLALN2. ! If NW=2 ("w" is complex), on exit, column 1 will contain ! the real part of X and column 2 will contain the imaginary ! part. ! ! LDX (input) INTEGER ! The leading dimension of X. It must be at least NA. ! ! SCALE (output) REAL ! The scale factor that B must be multiplied by to insure ! that overflow does not occur when computing X. Thus, ! (ca A - w D) X will be SCALE*B, not B (ignoring ! perturbations of A.) It will be at most 1. ! ! XNORM (output) REAL ! The infinity-norm of X, when X is regarded as an NA x NW ! real matrix. ! ! INFO (output) INTEGER ! An error flag. It will be set to zero if no error occurs, ! a negative number if an argument is in error, or a positive ! number if ca A - w D had to be perturbed. ! The possible values are: ! = 0: No error occurred, and (ca A - w D) did not have to be ! perturbed. ! = 1: (ca A - w D) had to be perturbed to make its smallest ! (or only) singular value greater than SMIN. ! NOTE: In the interests of speed, this routine does not ! check the inputs for errors. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 ! .. ! .. Local Scalars .. INTEGER :: icmax, j REAL :: bbnd, bi1, bi2, bignum, bnorm, br1, br2, ci21, & ci22, cmax, cnorm, cr21, cr22, csi, csr, li21, & lr21, smini, smlnum, temp, u22abs, ui11, ui11r, & ui12, ui12s, ui22, ur11, ur11r, ur12, ur12s, ur22, xi1, xi2, xr1, xr2 ! .. ! .. Local Arrays .. LOGICAL :: cswap( 4 ), rswap( 4 ) INTEGER :: ipivot( 4, 4 ) REAL :: ci( 2, 2 ), civ( 4 ), cr( 2, 2 ), crv( 4 ) ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. External Subroutines .. EXTERNAL sladiv ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. Equivalences .. EQUIVALENCE ( ci( 1, 1 ), civ( 1 ) ), ( cr( 1, 1 ), crv( 1 ) ) ! .. ! .. Data statements .. DATA cswap / .false., .false., .true., .true. / DATA rswap / .false., .true., .false., .true. / DATA ipivot / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4, 3, 2, 1 / ! .. ! .. Executable Statements .. ! ! Compute BIGNUM ! smlnum = two*slamch( 'Safe minimum' ) bignum = one / smlnum smini = MAX( smin, smlnum ) ! ! Don't check for input errors ! info = 0 ! ! Standard Initializations ! scale = one ! IF( na == 1 ) THEN ! ! 1 x 1 (i.e., scalar) system C X = B ! IF( nw == 1 ) THEN ! ! Real 1x1 system. ! ! C = ca A - w D ! csr = ca*a( 1, 1 ) - wr*d1 cnorm = ABS( csr ) ! ! If | C | < SMINI, use C = SMINI ! IF( cnorm < smini ) THEN csr = smini cnorm = smini info = 1 END IF ! ! Check scaling for X = B / C ! bnorm = ABS( b( 1, 1 ) ) IF( cnorm < one .AND. bnorm > one ) THEN IF( bnorm > bignum*cnorm ) scale = one / bnorm END IF ! ! Compute X ! x( 1, 1 ) = ( b( 1, 1 )*scale ) / csr xnorm = ABS( x( 1, 1 ) ) ELSE ! ! Complex 1x1 system (w is complex) ! ! C = ca A - w D ! csr = ca*a( 1, 1 ) - wr*d1 csi = -wi*d1 cnorm = ABS( csr ) + ABS( csi ) ! ! If | C | < SMINI, use C = SMINI ! IF( cnorm < smini ) THEN csr = smini csi = zero cnorm = smini info = 1 END IF ! ! Check scaling for X = B / C ! bnorm = ABS( b( 1, 1 ) ) + ABS( b( 1, 2 ) ) IF( cnorm < one .AND. bnorm > one ) THEN IF( bnorm > bignum*cnorm ) scale = one / bnorm END IF ! ! Compute X ! CALL sladiv( scale*b( 1, 1 ), scale*b( 1, 2 ), csr, csi, & x( 1, 1 ), x( 1, 2 ) ) xnorm = ABS( x( 1, 1 ) ) + ABS( x( 1, 2 ) ) END IF ! ELSE ! ! 2x2 System ! ! Compute the real part of C = ca A - w D (or ca A' - w D ) ! cr( 1, 1 ) = ca*a( 1, 1 ) - wr*d1 cr( 2, 2 ) = ca*a( 2, 2 ) - wr*d2 IF( ltrans ) THEN cr( 1, 2 ) = ca*a( 2, 1 ) cr( 2, 1 ) = ca*a( 1, 2 ) ELSE cr( 2, 1 ) = ca*a( 2, 1 ) cr( 1, 2 ) = ca*a( 1, 2 ) END IF ! IF( nw == 1 ) THEN ! ! Real 2x2 system (w is real) ! ! Find the largest element in C ! cmax = zero icmax = 0 ! DO j = 1, 4 IF( ABS( crv( j ) ) > cmax ) THEN cmax = ABS( crv( j ) ) icmax = j END IF END DO ! ! If norm(C) < SMINI, use SMINI*identity. ! IF( cmax < smini ) THEN bnorm = MAX( ABS( b( 1, 1 ) ), ABS( b( 2, 1 ) ) ) IF( smini < one .AND. bnorm > one ) THEN IF( bnorm > bignum*smini ) scale = one / bnorm END IF temp = scale / smini x( 1, 1 ) = temp*b( 1, 1 ) x( 2, 1 ) = temp*b( 2, 1 ) xnorm = temp*bnorm info = 1 RETURN END IF ! ! Gaussian elimination with complete pivoting. ! ur11 = crv( icmax ) cr21 = crv( ipivot( 2, icmax ) ) ur12 = crv( ipivot( 3, icmax ) ) cr22 = crv( ipivot( 4, icmax ) ) ur11r = one / ur11 lr21 = ur11r*cr21 ur22 = cr22 - ur12*lr21 ! ! If smaller pivot < SMINI, use SMINI ! IF( ABS( ur22 ) < smini ) THEN ur22 = smini info = 1 END IF IF( rswap( icmax ) ) THEN br1 = b( 2, 1 ) br2 = b( 1, 1 ) ELSE br1 = b( 1, 1 ) br2 = b( 2, 1 ) END IF br2 = br2 - lr21*br1 bbnd = MAX( ABS( br1*( ur22*ur11r ) ), ABS( br2 ) ) IF( bbnd > one .AND. ABS( ur22 ) < one ) THEN IF( bbnd >= bignum*ABS( ur22 ) ) scale = one / bbnd END IF ! xr2 = ( br2*scale ) / ur22 xr1 = ( scale*br1 )*ur11r - xr2*( ur11r*ur12 ) IF( cswap( icmax ) ) THEN x( 1, 1 ) = xr2 x( 2, 1 ) = xr1 ELSE x( 1, 1 ) = xr1 x( 2, 1 ) = xr2 END IF xnorm = MAX( ABS( xr1 ), ABS( xr2 ) ) ! ! Further scaling if norm(A) norm(X) > overflow ! IF( xnorm > one .AND. cmax > one ) THEN IF( xnorm > bignum / cmax ) THEN temp = cmax / bignum x( 1, 1 ) = temp*x( 1, 1 ) x( 2, 1 ) = temp*x( 2, 1 ) xnorm = temp*xnorm scale = temp*scale END IF END IF ELSE ! ! Complex 2x2 system (w is complex) ! ! Find the largest element in C ! ci( 1, 1 ) = -wi*d1 ci( 2, 1 ) = zero ci( 1, 2 ) = zero ci( 2, 2 ) = -wi*d2 cmax = zero icmax = 0 ! DO j = 1, 4 IF( ABS( crv( j ) )+ABS( civ( j ) ) > cmax ) THEN cmax = ABS( crv( j ) ) + ABS( civ( j ) ) icmax = j END IF END DO ! ! If norm(C) < SMINI, use SMINI*identity. ! IF( cmax < smini ) THEN bnorm = MAX( ABS( b( 1, 1 ) )+ABS( b( 1, 2 ) ), & ABS( b( 2, 1 ) )+ABS( b( 2, 2 ) ) ) IF( smini < one .AND. bnorm > one ) THEN IF( bnorm > bignum*smini ) scale = one / bnorm END IF temp = scale / smini x( 1, 1 ) = temp*b( 1, 1 ) x( 2, 1 ) = temp*b( 2, 1 ) x( 1, 2 ) = temp*b( 1, 2 ) x( 2, 2 ) = temp*b( 2, 2 ) xnorm = temp*bnorm info = 1 RETURN END IF ! ! Gaussian elimination with complete pivoting. ! ur11 = crv( icmax ) ui11 = civ( icmax ) cr21 = crv( ipivot( 2, icmax ) ) ci21 = civ( ipivot( 2, icmax ) ) ur12 = crv( ipivot( 3, icmax ) ) ui12 = civ( ipivot( 3, icmax ) ) cr22 = crv( ipivot( 4, icmax ) ) ci22 = civ( ipivot( 4, icmax ) ) IF( icmax == 1 .OR. icmax == 4 ) THEN ! ! Code when off-diagonals of pivoted C are real ! IF( ABS( ur11 ) > ABS( ui11 ) ) THEN temp = ui11 / ur11 ur11r = one / ( ur11*( one+temp**2 ) ) ui11r = -temp*ur11r ELSE temp = ur11 / ui11 ui11r = -one / ( ui11*( one+temp**2 ) ) ur11r = -temp*ui11r END IF lr21 = cr21*ur11r li21 = cr21*ui11r ur12s = ur12*ur11r ui12s = ur12*ui11r ur22 = cr22 - ur12*lr21 ui22 = ci22 - ur12*li21 ELSE ! ! Code when diagonals of pivoted C are real ! ur11r = one / ur11 ui11r = zero lr21 = cr21*ur11r li21 = ci21*ur11r ur12s = ur12*ur11r ui12s = ui12*ur11r ur22 = cr22 - ur12*lr21 + ui12*li21 ui22 = -ur12*li21 - ui12*lr21 END IF u22abs = ABS( ur22 ) + ABS( ui22 ) ! ! If smaller pivot < SMINI, use SMINI ! IF( u22abs < smini ) THEN ur22 = smini ui22 = zero info = 1 END IF IF( rswap( icmax ) ) THEN br2 = b( 1, 1 ) br1 = b( 2, 1 ) bi2 = b( 1, 2 ) bi1 = b( 2, 2 ) ELSE br1 = b( 1, 1 ) br2 = b( 2, 1 ) bi1 = b( 1, 2 ) bi2 = b( 2, 2 ) END IF br2 = br2 - lr21*br1 + li21*bi1 bi2 = bi2 - li21*br1 - lr21*bi1 bbnd = MAX( ( ABS( br1 )+ABS( bi1 ) )* & ( u22abs*( ABS( ur11r )+ABS( ui11r ) ) ), ABS( br2 )+ABS( bi2 ) ) IF( bbnd > one .AND. u22abs < one ) THEN IF( bbnd >= bignum*u22abs ) THEN scale = one / bbnd br1 = scale*br1 bi1 = scale*bi1 br2 = scale*br2 bi2 = scale*bi2 END IF END IF ! CALL sladiv( br2, bi2, ur22, ui22, xr2, xi2 ) xr1 = ur11r*br1 - ui11r*bi1 - ur12s*xr2 + ui12s*xi2 xi1 = ui11r*br1 + ur11r*bi1 - ui12s*xr2 - ur12s*xi2 IF( cswap( icmax ) ) THEN x( 1, 1 ) = xr2 x( 2, 1 ) = xr1 x( 1, 2 ) = xi2 x( 2, 2 ) = xi1 ELSE x( 1, 1 ) = xr1 x( 2, 1 ) = xr2 x( 1, 2 ) = xi1 x( 2, 2 ) = xi2 END IF xnorm = MAX( ABS( xr1 )+ABS( xi1 ), ABS( xr2 )+ABS( xi2 ) ) ! ! Further scaling if norm(A) norm(X) > overflow ! IF( xnorm > one .AND. cmax > one ) THEN IF( xnorm > bignum / cmax ) THEN temp = cmax / bignum x( 1, 1 ) = temp*x( 1, 1 ) x( 2, 1 ) = temp*x( 2, 1 ) x( 1, 2 ) = temp*x( 1, 2 ) x( 2, 2 ) = temp*x( 2, 2 ) xnorm = temp*xnorm scale = temp*scale END IF END IF END IF END IF ! RETURN ! ! End of SLALN2 ! END SUBROUTINE slaln2 SUBROUTINE slals0( icompq, nl, nr, sqre, nrhs, b, ldb, bx, ldbx, & perm, givptr, givcol, ldgcol, givnum, ldgnum, & poles, difl, difr, z, k, c, s, 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, INTENT(IN) :: icompq INTEGER, INTENT(IN) :: nl INTEGER, INTENT(IN) :: nr INTEGER, INTENT(IN) :: sqre INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: bx( ldbx, * ) INTEGER, INTENT(IN OUT) :: ldbx INTEGER, INTENT(IN OUT) :: perm( * ) INTEGER, INTENT(IN) :: givptr INTEGER, INTENT(IN OUT) :: givcol( ldgcol, * ) INTEGER, INTENT(IN OUT) :: ldgcol REAL, INTENT(IN OUT) :: givnum( ldgnum, * ) INTEGER, INTENT(IN OUT) :: ldgnum REAL, INTENT(IN) :: poles( ldgnum, * ) REAL, INTENT(IN) :: difl( * ) REAL, INTENT(IN) :: difr( ldgnum, * ) REAL, INTENT(IN) :: z( * ) INTEGER, INTENT(IN) :: k REAL, INTENT(IN OUT) :: c REAL, INTENT(IN OUT) :: s REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLALS0 applies back the multiplying factors of either the left or the ! right singular vector matrix of a diagonal matrix appended by a row ! to the right hand side matrix B in solving the least squares problem ! using the divide-and-conquer SVD approach. ! ! For the left singular vector matrix, three types of orthogonal ! matrices are involved: ! ! (1L) Givens rotations: the number of such rotations is GIVPTR; the ! pairs of columns/rows they were applied to are stored in GIVCOL; ! and the C- and S-values of these rotations are stored in GIVNUM. ! ! (2L) Permutation. The (NL+1)-st row of B is to be moved to the first ! row, and for J=2:N, PERM(J)-th row of B is to be moved to the ! J-th row. ! ! (3L) The left singular vector matrix of the remaining matrix. ! ! For the right singular vector matrix, four types of orthogonal ! matrices are involved: ! ! (1R) The right singular vector matrix of the remaining matrix. ! ! (2R) If SQRE = 1, one extra Givens rotation to generate the right ! null space. ! ! (3R) The inverse transformation of (2L). ! ! (4R) The inverse transformation of (1L). ! ! Arguments ! ========= ! ! ICOMPQ (input) INTEGER ! Specifies whether singular vectors are to be computed in ! factored form: ! = 0: Left singular vector matrix. ! = 1: Right singular vector matrix. ! ! NL (input) INTEGER ! The row dimension of the upper block. NL >= 1. ! ! NR (input) INTEGER ! The row dimension of the lower block. NR >= 1. ! ! SQRE (input) INTEGER ! = 0: the lower block is an NR-by-NR square matrix. ! = 1: the lower block is an NR-by-(NR+1) rectangular matrix. ! ! The bidiagonal matrix has row dimension N = NL + NR + 1, ! and column dimension M = N + SQRE. ! ! NRHS (input) INTEGER ! The number of columns of B and BX. NRHS must be at least 1. ! ! B (input/output) REAL array, dimension ( LDB, NRHS ) ! On input, B contains the right hand sides of the least ! squares problem in rows 1 through M. On output, B contains ! the solution X in rows 1 through N. ! ! LDB (input) INTEGER ! The leading dimension of B. LDB must be at least ! max(1,MAX( M, N ) ). ! ! BX (workspace) REAL array, dimension ( LDBX, NRHS ) ! ! LDBX (input) INTEGER ! The leading dimension of BX. ! ! PERM (input) INTEGER array, dimension ( N ) ! The permutations (from deflation and sorting) applied ! to the two blocks. ! ! GIVPTR (input) INTEGER ! The number of Givens rotations which took place in this ! subproblem. ! ! GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 ) ! Each pair of numbers indicates a pair of rows/columns ! involved in a Givens rotation. ! ! LDGCOL (input) INTEGER ! The leading dimension of GIVCOL, must be at least N. ! ! GIVNUM (input) REAL array, dimension ( LDGNUM, 2 ) ! Each number indicates the C or S value used in the ! corresponding Givens rotation. ! ! LDGNUM (input) INTEGER ! The leading dimension of arrays DIFR, POLES and ! GIVNUM, must be at least K. ! ! POLES (input) REAL array, dimension ( LDGNUM, 2 ) ! On entry, POLES(1:K, 1) contains the new singular ! values obtained from solving the secular equation, and ! POLES(1:K, 2) is an array containing the poles in the secular ! equation. ! ! DIFL (input) REAL array, dimension ( K ). ! On entry, DIFL(I) is the distance between I-th updated ! (undeflated) singular value and the I-th (undeflated) old ! singular value. ! ! DIFR (input) REAL array, dimension ( LDGNUM, 2 ). ! On entry, DIFR(I, 1) contains the distances between I-th ! updated (undeflated) singular value and the I+1-th ! (undeflated) old singular value. And DIFR(I, 2) is the ! normalizing factor for the I-th right singular vector. ! ! Z (input) REAL array, dimension ( K ) ! Contain the components of the deflation-adjusted updating row ! vector. ! ! K (input) INTEGER ! Contains the dimension of the non-deflated matrix, ! This is the order of the related secular equation. 1 <= K <=N. ! ! C (input) REAL ! C contains garbage if SQRE =0 and the C-value of a Givens ! rotation related to the right null space if SQRE = 1. ! ! S (input) REAL ! S contains garbage if SQRE =0 and the S-value of a Givens ! rotation related to the right null space if SQRE = 1. ! ! WORK (workspace) REAL array, dimension ( K ) ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! ! Further Details ! =============== ! ! Based on contributions by ! Ming Gu and Ren-Cang Li, Computer Science Division, University of ! California at Berkeley, USA ! Osni Marques, LBNL/NERSC, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: negone = -1.0E0 ! .. ! .. Local Scalars .. INTEGER :: i, j, m, n, nlp1 REAL :: diflj, difrj, dj, dsigj, dsigjp, temp ! .. ! .. External Subroutines .. EXTERNAL scopy, sgemv, slacpy, slascl, srot, sscal, xerbla ! .. ! .. External Functions .. REAL :: slamc3, snrm2 EXTERNAL slamc3, snrm2 ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( ( icompq < 0 ) .OR. ( icompq > 1 ) ) THEN info = -1 ELSE IF( nl < 1 ) THEN info = -2 ELSE IF( nr < 1 ) THEN info = -3 ELSE IF( ( sqre < 0 ) .OR. ( sqre > 1 ) ) THEN info = -4 END IF ! n = nl + nr + 1 ! IF( nrhs < 1 ) THEN info = -5 ELSE IF( ldb < n ) THEN info = -7 ELSE IF( ldbx < n ) THEN info = -9 ELSE IF( givptr < 0 ) THEN info = -11 ELSE IF( ldgcol < n ) THEN info = -13 ELSE IF( ldgnum < n ) THEN info = -15 ELSE IF( k < 1 ) THEN info = -20 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLALS0', -info ) RETURN END IF ! m = n + sqre nlp1 = nl + 1 ! IF( icompq == 0 ) THEN ! ! Apply back orthogonal transformations from the left. ! ! Step (1L): apply back the Givens rotations performed. ! DO i = 1, givptr CALL srot( nrhs, b( givcol( i, 2 ), 1 ), ldb, & b( givcol( i, 1 ), 1 ), ldb, givnum( i, 2 ), givnum( i, 1 ) ) END DO ! ! Step (2L): permute rows of B. ! CALL scopy( nrhs, b( nlp1, 1 ), ldb, bx( 1, 1 ), ldbx ) DO i = 2, n CALL scopy( nrhs, b( perm( i ), 1 ), ldb, bx( i, 1 ), ldbx ) END DO ! ! Step (3L): apply the inverse of the left singular vector ! matrix to BX. ! IF( k == 1 ) THEN CALL scopy( nrhs, bx, ldbx, b, ldb ) IF( z( 1 ) < zero ) THEN CALL sscal( nrhs, negone, b, ldb ) END IF ELSE DO j = 1, k diflj = difl( j ) dj = poles( j, 1 ) dsigj = -poles( j, 2 ) IF( j < k ) THEN difrj = -difr( j, 1 ) dsigjp = -poles( j+1, 2 ) END IF IF( ( z( j ) == zero ) .OR. ( poles( j, 2 ) == zero ) ) THEN work( j ) = zero ELSE work( j ) = -poles( j, 2 )*z( j ) / diflj / ( poles( j, 2 )+dj ) END IF DO i = 1, j - 1 IF( ( z( i ) == zero ) .OR. ( poles( i, 2 ) == zero ) ) THEN work( i ) = zero ELSE work( i ) = poles( i, 2 )*z( i ) / & ( slamc3( poles( i, 2 ), dsigj )- diflj ) / ( poles( i, 2 )+dj ) END IF END DO DO i = j + 1, k IF( ( z( i ) == zero ) .OR. ( poles( i, 2 ) == zero ) ) THEN work( i ) = zero ELSE work( i ) = poles( i, 2 )*z( i ) / & ( slamc3( poles( i, 2 ), dsigjp )+ difrj ) / ( poles( i, 2 )+dj ) END IF END DO work( 1 ) = negone temp = snrm2( k, work, 1 ) CALL sgemv( 'T', k, nrhs, one, bx, ldbx, work, 1, zero, b( j, 1 ), ldb ) CALL slascl( 'G', 0, 0, temp, one, 1, nrhs, b( j, 1 ), ldb, info ) END DO END IF ! ! Move the deflated rows of BX to B also. ! CALL slacpy( 'A', n-k, nrhs, bx( k+1, 1 ), ldbx, b( k+1, 1 ), ldb ) ELSE ! ! Apply back the right orthogonal transformations. ! ! Step (1R): apply back the new right singular vector matrix ! to B. ! IF( k == 1 ) THEN CALL scopy( nrhs, b, ldb, bx, ldbx ) ELSE DO j = 1, k dsigj = poles( j, 2 ) IF( z( j ) == zero ) THEN work( j ) = zero ELSE work( j ) = -z( j ) / difl( j ) / & ( dsigj+poles( j, 1 ) ) / difr( j, 2 ) END IF DO i = 1, j - 1 IF( z( j ) == zero ) THEN work( i ) = zero ELSE work( i ) = z( j ) / ( slamc3( dsigj, -poles( i+1, & 2 ) )-difr( i, 1 ) ) / ( dsigj+poles( i, 1 ) ) / difr( i, 2 ) END IF END DO DO i = j + 1, k IF( z( j ) == zero ) THEN work( i ) = zero ELSE work( i ) = z( j ) / ( slamc3( dsigj, -poles( i, & 2 ) )-difl( i ) ) / ( dsigj+poles( i, 1 ) ) / difr( i, 2 ) END IF END DO CALL sgemv( 'T', k, nrhs, one, b, ldb, work, 1, zero, bx( j, 1 ), ldbx ) END DO END IF ! ! Step (2R): if SQRE = 1, apply back the rotation that is ! related to the right null space of the subproblem. ! IF( sqre == 1 ) THEN CALL scopy( nrhs, b( m, 1 ), ldb, bx( m, 1 ), ldbx ) CALL srot( nrhs, bx( 1, 1 ), ldbx, bx( m, 1 ), ldbx, c, s ) END IF CALL slacpy( 'A', n-k, nrhs, b( k+1, 1 ), ldb, bx( k+1, 1 ), ldbx ) ! ! Step (3R): permute rows of B. ! CALL scopy( nrhs, bx( 1, 1 ), ldbx, b( nlp1, 1 ), ldb ) IF( sqre == 1 ) THEN CALL scopy( nrhs, bx( m, 1 ), ldbx, b( m, 1 ), ldb ) END IF DO i = 2, n CALL scopy( nrhs, bx( i, 1 ), ldbx, b( perm( i ), 1 ), ldb ) END DO ! ! Step (4R): apply back the Givens rotations performed. ! DO i = givptr, 1, -1 CALL srot( nrhs, b( givcol( i, 2 ), 1 ), ldb, & b( givcol( i, 1 ), 1 ), ldb, givnum( i, 2 ), -givnum( i, 1 ) ) END DO END IF ! RETURN ! ! End of SLALS0 ! END SUBROUTINE slals0 SUBROUTINE slalsa( icompq, smlsiz, n, nrhs, b, ldb, bx, ldbx, u, & ldu, vt, k, difl, difr, z, poles, givptr, & givcol, ldgcol, perm, givnum, c, s, 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 .. INTEGER, INTENT(IN) :: icompq INTEGER, INTENT(IN OUT) :: smlsiz INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: nrhs REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: bx( ldbx, * ) INTEGER, INTENT(IN OUT) :: ldbx REAL, INTENT(IN OUT) :: u( ldu, * ) INTEGER, INTENT(IN OUT) :: ldu REAL, INTENT(IN OUT) :: vt( ldu, * ) INTEGER, INTENT(IN OUT) :: k( * ) REAL, INTENT(IN OUT) :: difl( ldu, * ) REAL, INTENT(IN OUT) :: difr( ldu, * ) REAL, INTENT(IN OUT) :: z( ldu, * ) REAL, INTENT(IN OUT) :: poles( ldu, * ) INTEGER, INTENT(IN OUT) :: givptr( * ) INTEGER, INTENT(IN OUT) :: givcol( ldgcol, * ) INTEGER, INTENT(IN OUT) :: ldgcol INTEGER, INTENT(IN OUT) :: perm( ldgcol, * ) REAL, INTENT(IN OUT) :: givnum( ldu, * ) REAL, INTENT(IN OUT) :: c( * ) REAL, INTENT(IN OUT) :: s( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(IN) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLALSA is an itermediate step in solving the least squares problem ! by computing the SVD of the coefficient matrix in compact form (The ! singular vectors are computed as products of simple orthorgonal ! matrices.). ! ! If ICOMPQ = 0, SLALSA applies the inverse of the left singular vector ! matrix of an upper bidiagonal matrix to the right hand side; and if ! ICOMPQ = 1, SLALSA applies the right singular vector matrix to the ! right hand side. The singular vector matrices were generated in ! compact form by SLALSA. ! ! Arguments ! ========= ! ! ! ICOMPQ (input) INTEGER ! Specifies whether the left or the right singular vector ! matrix is involved. ! = 0: Left singular vector matrix ! = 1: Right singular vector matrix ! ! SMLSIZ (input) INTEGER ! The maximum size of the subproblems at the bottom of the ! computation tree. ! ! N (input) INTEGER ! The row and column dimensions of the upper bidiagonal matrix. ! ! NRHS (input) INTEGER ! The number of columns of B and BX. NRHS must be at least 1. ! ! B (input) REAL array, dimension ( LDB, NRHS ) ! On input, B contains the right hand sides of the least ! squares problem in rows 1 through M. On output, B contains ! the solution X in rows 1 through N. ! ! LDB (input) INTEGER ! The leading dimension of B in the calling subprogram. ! LDB must be at least max(1,MAX( M, N ) ). ! ! BX (output) REAL array, dimension ( LDBX, NRHS ) ! On exit, the result of applying the left or right singular ! vector matrix to B. ! ! LDBX (input) INTEGER ! The leading dimension of BX. ! ! U (input) REAL array, dimension ( LDU, SMLSIZ ). ! On entry, U contains the left singular vector matrices of all ! subproblems at the bottom level. ! ! LDU (input) INTEGER, LDU = > N. ! The leading dimension of arrays U, VT, DIFL, DIFR, ! POLES, GIVNUM, and Z. ! ! VT (input) REAL array, dimension ( LDU, SMLSIZ+1 ). ! On entry, VT' contains the right singular vector matrices of ! all subproblems at the bottom level. ! ! K (input) INTEGER array, dimension ( N ). ! ! DIFL (input) REAL array, dimension ( LDU, NLVL ). ! where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. ! ! DIFR (input) REAL array, dimension ( LDU, 2 * NLVL ). ! On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record ! distances between singular values on the I-th level and ! singular values on the (I -1)-th level, and DIFR(*, 2 * I) ! record the normalizing factors of the right singular vectors ! matrices of subproblems on I-th level. ! ! Z (input) REAL array, dimension ( LDU, NLVL ). ! On entry, Z(1, I) contains the components of the deflation- ! adjusted updating row vector for subproblems on the I-th ! level. ! ! POLES (input) REAL array, dimension ( LDU, 2 * NLVL ). ! On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old ! singular values involved in the secular equations on the I-th ! level. ! ! GIVPTR (input) INTEGER array, dimension ( N ). ! On entry, GIVPTR( I ) records the number of Givens ! rotations performed on the I-th problem on the computation ! tree. ! ! GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ). ! On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the ! locations of Givens rotations performed on the I-th level on ! the computation tree. ! ! LDGCOL (input) INTEGER, LDGCOL = > N. ! The leading dimension of arrays GIVCOL and PERM. ! ! PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ). ! On entry, PERM(*, I) records permutations done on the I-th ! level of the computation tree. ! ! GIVNUM (input) REAL array, dimension ( LDU, 2 * NLVL ). ! On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S- ! values of Givens rotations performed on the I-th level on the ! computation tree. ! ! C (input) REAL array, dimension ( N ). ! On entry, if the I-th subproblem is not square, ! C( I ) contains the C-value of a Givens rotation related to ! the right null space of the I-th subproblem. ! ! S (input) REAL array, dimension ( N ). ! On entry, if the I-th subproblem is not square, ! S( I ) contains the S-value of a Givens rotation related to ! the right null space of the I-th subproblem. ! ! WORK (workspace) REAL array. ! The dimension must be at least N. ! ! IWORK (workspace) INTEGER array. ! The dimension must be at least 3 * N ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! ! Further Details ! =============== ! ! Based on contributions by ! Ming Gu and Ren-Cang Li, Computer Science Division, University of ! California at Berkeley, USA ! Osni Marques, LBNL/NERSC, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. INTEGER :: i, i1, ic, im1, inode, j, lf, ll, lvl, lvl2, & nd, ndb1, ndiml, ndimr, nl, nlf, nlp1, nlvl, nr, nrf, nrp1, sqre ! .. ! .. External Subroutines .. EXTERNAL scopy, sgemm, slals0, slasdt, xerbla ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( ( icompq < 0 ) .OR. ( icompq > 1 ) ) THEN info = -1 ELSE IF( smlsiz < 3 ) THEN info = -2 ELSE IF( n < smlsiz ) THEN info = -3 ELSE IF( nrhs < 1 ) THEN info = -4 ELSE IF( ldb < n ) THEN info = -6 ELSE IF( ldbx < n ) THEN info = -8 ELSE IF( ldu < n ) THEN info = -10 ELSE IF( ldgcol < n ) THEN info = -19 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLALSA', -info ) RETURN END IF ! ! Book-keeping and setting up the computation tree. ! inode = 1 ndiml = inode + n ndimr = ndiml + n ! CALL slasdt( n, nlvl, nd, iwork( inode ), iwork( ndiml ), & iwork( ndimr ), smlsiz ) ! ! The following code applies back the left singular vector factors. ! For applying back the right singular vector factors, go to 50. ! IF( icompq == 1 ) THEN GO TO 50 END IF ! ! The nodes on the bottom level of the tree were solved ! by SLASDQ. The corresponding left and right singular vector ! matrices are in explicit form. First apply back the left ! singular vector matrices. ! ndb1 = ( nd+1 ) / 2 DO i = ndb1, nd ! ! IC : center row of each node ! NL : number of rows of left subproblem ! NR : number of rows of right subproblem ! NLF: starting row of the left subproblem ! NRF: starting row of the right subproblem ! i1 = i - 1 ic = iwork( inode+i1 ) nl = iwork( ndiml+i1 ) nr = iwork( ndimr+i1 ) nlf = ic - nl nrf = ic + 1 CALL sgemm( 'T', 'N', nl, nrhs, nl, one, u( nlf, 1 ), ldu, & b( nlf, 1 ), ldb, zero, bx( nlf, 1 ), ldbx ) CALL sgemm( 'T', 'N', nr, nrhs, nr, one, u( nrf, 1 ), ldu, & b( nrf, 1 ), ldb, zero, bx( nrf, 1 ), ldbx ) END DO ! ! Next copy the rows of B that correspond to unchanged rows ! in the bidiagonal matrix to BX. ! DO i = 1, nd ic = iwork( inode+i-1 ) CALL scopy( nrhs, b( ic, 1 ), ldb, bx( ic, 1 ), ldbx ) END DO ! ! Finally go through the left singular vector matrices of all ! the other subproblems bottom-up on the tree. ! j = 2**nlvl sqre = 0 ! DO lvl = nlvl, 1, -1 lvl2 = 2*lvl - 1 ! ! find the first node LF and last node LL on ! the current level LVL ! IF( lvl == 1 ) THEN lf = 1 ll = 1 ELSE lf = 2**( lvl-1 ) ll = 2*lf - 1 END IF DO i = lf, ll im1 = i - 1 ic = iwork( inode+im1 ) nl = iwork( ndiml+im1 ) nr = iwork( ndimr+im1 ) nlf = ic - nl nrf = ic + 1 j = j - 1 CALL slals0( icompq, nl, nr, sqre, nrhs, bx( nlf, 1 ), ldbx, & b( nlf, 1 ), ldb, perm( nlf, lvl ), & givptr( j ), givcol( nlf, lvl2 ), ldgcol, & givnum( nlf, lvl2 ), ldu, poles( nlf, lvl2 ), & difl( nlf, lvl ), difr( nlf, lvl2 ), & z( nlf, lvl ), k( j ), c( j ), s( j ), work, info ) END DO END DO GO TO 90 ! ! ICOMPQ = 1: applying back the right singular vector factors. ! 50 CONTINUE ! ! First now go through the right singular vector matrices of all ! the tree nodes top-down. ! j = 0 DO lvl = 1, nlvl lvl2 = 2*lvl - 1 ! ! Find the first node LF and last node LL on ! the current level LVL. ! IF( lvl == 1 ) THEN lf = 1 ll = 1 ELSE lf = 2**( lvl-1 ) ll = 2*lf - 1 END IF DO i = ll, lf, -1 im1 = i - 1 ic = iwork( inode+im1 ) nl = iwork( ndiml+im1 ) nr = iwork( ndimr+im1 ) nlf = ic - nl nrf = ic + 1 IF( i == ll ) THEN sqre = 0 ELSE sqre = 1 END IF j = j + 1 CALL slals0( icompq, nl, nr, sqre, nrhs, b( nlf, 1 ), ldb, & bx( nlf, 1 ), ldbx, perm( nlf, lvl ), & givptr( j ), givcol( nlf, lvl2 ), ldgcol, & givnum( nlf, lvl2 ), ldu, poles( nlf, lvl2 ), & difl( nlf, lvl ), difr( nlf, lvl2 ), & z( nlf, lvl ), k( j ), c( j ), s( j ), work, info ) END DO END DO ! ! The nodes on the bottom level of the tree were solved ! by SLASDQ. The corresponding right singular vector ! matrices are in explicit form. Apply them back. ! ndb1 = ( nd+1 ) / 2 DO i = ndb1, nd i1 = i - 1 ic = iwork( inode+i1 ) nl = iwork( ndiml+i1 ) nr = iwork( ndimr+i1 ) nlp1 = nl + 1 IF( i == nd ) THEN nrp1 = nr ELSE nrp1 = nr + 1 END IF nlf = ic - nl nrf = ic + 1 CALL sgemm( 'T', 'N', nlp1, nrhs, nlp1, one, vt( nlf, 1 ), ldu, & b( nlf, 1 ), ldb, zero, bx( nlf, 1 ), ldbx ) CALL sgemm( 'T', 'N', nrp1, nrhs, nrp1, one, vt( nrf, 1 ), ldu, & b( nrf, 1 ), ldb, zero, bx( nrf, 1 ), ldbx ) END DO ! 90 CONTINUE ! RETURN ! ! End of SLALSA ! END SUBROUTINE slalsa SUBROUTINE slalsd ( uplo, smlsiz, n, nrhs, d, e, b, ldb, rcond, & rank, 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: smlsiz INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(OUT) :: e( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: rcond INTEGER, INTENT(OUT) :: rank REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLALSD uses the singular value decomposition of A to solve the least ! squares problem of finding X to minimize the Euclidean norm of each ! column of A*X-B, where A is N-by-N upper bidiagonal, and X and B ! are N-by-NRHS. The solution X overwrites B. ! ! The singular values of A smaller than RCOND times the largest ! singular value are treated as zero in solving the least squares ! problem; in this case a minimum norm solution is returned. ! The actual singular values are returned in D in ascending order. ! ! This code makes very mild assumptions about floating point ! arithmetic. It will work on machines with a guard digit in ! add/subtract, or on those binary machines without guard digits ! which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. ! It could conceivably fail on hexadecimal or decimal machines ! without guard digits, but we know of none. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! = 'U': D and E define an upper bidiagonal matrix. ! = 'L': D and E define a lower bidiagonal matrix. ! ! SMLSIZ (input) INTEGER ! The maximum size of the subproblems at the bottom of the ! computation tree. ! ! N (input) INTEGER ! The dimension of the bidiagonal matrix. N >= 0. ! ! NRHS (input) INTEGER ! The number of columns of B. NRHS must be at least 1. ! ! D (input/output) REAL array, dimension (N) ! On entry D contains the main diagonal of the bidiagonal ! matrix. On exit, if INFO = 0, D contains its singular values. ! ! E (input) REAL array, dimension (N-1) ! Contains the super-diagonal entries of the bidiagonal matrix. ! On exit, E has been destroyed. ! ! B (input/output) REAL array, dimension (LDB,NRHS) ! On input, B contains the right hand sides of the least ! squares problem. On output, B contains the solution X. ! ! LDB (input) INTEGER ! The leading dimension of B in the calling subprogram. ! LDB must be at least max(1,N). ! ! RCOND (input) REAL ! The singular values of A less than or equal to RCOND times ! the largest singular value are treated as zero in solving ! the least squares problem. If RCOND is negative, ! machine precision is used instead. ! For example, if diag(S)*X=B were the least squares problem, ! where diag(S) is a diagonal matrix of singular values, the ! solution would be X(i) = B(i) / S(i) if S(i) is greater than ! RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to ! RCOND*max(S). ! ! RANK (output) INTEGER ! The number of singular values of A greater than RCOND times ! the largest singular value. ! ! WORK (workspace) REAL array, dimension at least ! (8 * N + 2 * N * SMLSIZ + 8 * N * NLVL + N * NRHS), ! where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1 ! ! IWORK (workspace) INTEGER array, dimension at least ! (3 * N * NLVL + 11 * N) ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: The algorithm failed to compute an singular value while ! working on the submatrix lying in rows and columns ! INFO/(N+1) through MOD(INFO,N+1). ! ! Further Details ! =============== ! ! Based on contributions by ! Ming Gu and Ren-Cang Li, Computer Science Division, University of ! California at Berkeley, USA ! Osni Marques, LBNL/NERSC, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 ! .. ! .. Local Scalars .. INTEGER :: bx, bxst, c, difl, difr, givcol, givnum, & givptr, i, icmpq1, icmpq2, iwk, j, k, nlvl, & nm1, nsize, nsub, nwork, perm, poles, s, sizei, & smlszp, sqre, st, st1, u, vt, z REAL :: cs, eps, orgnrm, r, sn, tol ! .. ! .. External Functions .. INTEGER :: isamax REAL :: slamch, slanst EXTERNAL isamax, slamch, slanst ! .. ! .. External Subroutines .. EXTERNAL scopy, sgemm, slacpy, slalsa, slartg, slascl, & slasda, slasdq, slaset, slasrt, srot, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, REAL, SIGN ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( n < 0 ) THEN info = -3 ELSE IF( nrhs < 1 ) THEN info = -4 ELSE IF( ( ldb < 1 ) .OR. ( ldb < n ) ) THEN info = -8 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLALSD', -info ) RETURN END IF ! eps = slamch( 'Epsilon' ) ! ! Set up the tolerance. ! IF( ( rcond <= zero ) .OR. ( rcond >= one ) ) THEN rcond = eps END IF ! rank = 0 ! ! Quick return if possible. ! IF( n == 0 ) THEN RETURN ELSE IF( n == 1 ) THEN IF( d( 1 ) == zero ) THEN CALL slaset( 'A', 1, nrhs, zero, zero, b, ldb ) ELSE rank = 1 CALL slascl( 'G', 0, 0, d( 1 ), one, 1, nrhs, b, ldb, info ) d( 1 ) = ABS( d( 1 ) ) END IF RETURN END IF ! ! Rotate the matrix if it is lower bidiagonal. ! IF( uplo == 'L' ) THEN DO i = 1, n - 1 CALL slartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) IF( nrhs == 1 ) THEN CALL srot( 1, b( i, 1 ), 1, b( i+1, 1 ), 1, cs, sn ) ELSE work( i*2-1 ) = cs work( i*2 ) = sn END IF END DO IF( nrhs > 1 ) THEN DO i = 1, nrhs DO j = 1, n - 1 cs = work( j*2-1 ) sn = work( j*2 ) CALL srot( 1, b( j, i ), 1, b( j+1, i ), 1, cs, sn ) END DO END DO END IF END IF ! ! Scale. ! nm1 = n - 1 orgnrm = slanst( 'M', n, d, e ) IF( orgnrm == zero ) THEN CALL slaset( 'A', n, nrhs, zero, zero, b, ldb ) RETURN END IF ! CALL slascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) CALL slascl( 'G', 0, 0, orgnrm, one, nm1, 1, e, nm1, info ) ! ! If N is smaller than the minimum divide size SMLSIZ, then solve ! the problem with another solver. ! IF( n <= smlsiz ) THEN nwork = 1 + n*n CALL slaset( 'A', n, n, zero, one, work, n ) CALL slasdq( 'U', 0, n, n, 0, nrhs, d, e, work, n, work, n, b, & ldb, work( nwork ), info ) IF( info /= 0 ) THEN RETURN END IF tol = rcond*ABS( d( isamax( n, d, 1 ) ) ) DO i = 1, n IF( d( i ) <= tol ) THEN CALL slaset( 'A', 1, nrhs, zero, zero, b( i, 1 ), ldb ) ELSE CALL slascl( 'G', 0, 0, d( i ), one, 1, nrhs, b( i, 1 ), ldb, info ) rank = rank + 1 END IF END DO CALL sgemm( 'T', 'N', n, nrhs, n, one, work, n, b, ldb, zero, & work( nwork ), n ) CALL slacpy( 'A', n, nrhs, work( nwork ), n, b, ldb ) ! ! Unscale. ! CALL slascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) CALL slascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) ! RETURN END IF ! ! Book-keeping and setting up some constants. ! nlvl = INT( LOG( REAL( n ) / REAL( smlsiz+1 ) ) / LOG( two ) ) + 1 ! smlszp = smlsiz + 1 ! u = 1 vt = 1 + smlsiz*n difl = vt + smlszp*n difr = difl + nlvl*n z = difr + nlvl*n*2 c = z + nlvl*n s = c + n poles = s + n givnum = poles + 2*nlvl*n bx = givnum + 2*nlvl*n nwork = bx + n*nrhs ! sizei = 1 + n k = sizei + n givptr = k + n perm = givptr + n givcol = perm + nlvl*n iwk = givcol + nlvl*n*2 ! st = 1 sqre = 0 icmpq1 = 1 icmpq2 = 0 nsub = 0 ! DO i = 1, n IF( ABS( d( i ) ) < eps ) THEN d( i ) = SIGN( eps, d( i ) ) END IF END DO ! DO i = 1, nm1 IF( ( ABS( e( i ) ) < eps ) .OR. ( i == nm1 ) ) THEN nsub = nsub + 1 iwork( nsub ) = st ! ! Subproblem found. First determine its size and then ! apply divide and conquer on it. ! IF( i < nm1 ) THEN ! ! A subproblem with E(I) small for I < NM1. ! nsize = i - st + 1 iwork( sizei+nsub-1 ) = nsize ELSE IF( ABS( e( i ) ) >= eps ) THEN ! ! A subproblem with E(NM1) not too small but I = NM1. ! nsize = n - st + 1 iwork( sizei+nsub-1 ) = nsize ELSE ! ! A subproblem with E(NM1) small. This implies an ! 1-by-1 subproblem at D(N), which is not solved ! explicitly. ! nsize = i - st + 1 iwork( sizei+nsub-1 ) = nsize nsub = nsub + 1 iwork( nsub ) = n iwork( sizei+nsub-1 ) = 1 CALL scopy( nrhs, b( n, 1 ), ldb, work( bx+nm1 ), n ) END IF st1 = st - 1 IF( nsize == 1 ) THEN ! ! This is a 1-by-1 subproblem and is not solved ! explicitly. ! CALL scopy( nrhs, b( st, 1 ), ldb, work( bx+st1 ), n ) ELSE IF( nsize <= smlsiz ) THEN ! ! This is a small subproblem and is solved by SLASDQ. ! CALL slaset( 'A', nsize, nsize, zero, one, work( vt+st1 ), n ) CALL slasdq( 'U', 0, nsize, nsize, 0, nrhs, d( st ), & e( st ), work( vt+st1 ), n, work( nwork ), & n, b( st, 1 ), ldb, work( nwork ), info ) IF( info /= 0 ) THEN RETURN END IF CALL slacpy( 'A', nsize, nrhs, b( st, 1 ), ldb, work( bx+st1 ), n ) ELSE ! ! A large problem. Solve it using divide and conquer. ! CALL slasda( icmpq1, smlsiz, nsize, sqre, d( st ), & e( st ), work( u+st1 ), n, work( vt+st1 ), & iwork( k+st1 ), work( difl+st1 ), work( difr+st1 ), work( z+st1 ), & work( poles+st1 ), iwork( givptr+st1 ), & iwork( givcol+st1 ), n, iwork( perm+st1 ), & work( givnum+st1 ), work( c+st1 ), & work( s+st1 ), work( nwork ), iwork( iwk ), info ) IF( info /= 0 ) THEN RETURN END IF bxst = bx + st1 CALL slalsa( icmpq2, smlsiz, nsize, nrhs, b( st, 1 ), & ldb, work( bxst ), n, work( u+st1 ), n, & work( vt+st1 ), iwork( k+st1 ), work( difl+st1 ), work( difr+st1 ), & work( z+st1 ), work( poles+st1 ), & iwork( givptr+st1 ), iwork( givcol+st1 ), n, & iwork( perm+st1 ), work( givnum+st1 ), & work( c+st1 ), work( s+st1 ), work( nwork ), iwork( iwk ), info ) IF( info /= 0 ) THEN RETURN END IF END IF st = i + 1 END IF END DO ! ! Apply the singular values and treat the tiny ones as zero. ! tol = rcond*ABS( d( isamax( n, d, 1 ) ) ) ! DO i = 1, n ! ! Some of the elements in D can be negative because 1-by-1 ! subproblems were not solved explicitly. ! IF( ABS( d( i ) ) <= tol ) THEN CALL slaset( 'A', 1, nrhs, zero, zero, work( bx+i-1 ), n ) ELSE rank = rank + 1 CALL slascl( 'G', 0, 0, d( i ), one, 1, nrhs, work( bx+i-1 ), n, info ) END IF d( i ) = ABS( d( i ) ) END DO ! ! Now apply back the right singular vectors. ! icmpq2 = 1 DO i = 1, nsub st = iwork( i ) st1 = st - 1 nsize = iwork( sizei+i-1 ) bxst = bx + st1 IF( nsize == 1 ) THEN CALL scopy( nrhs, work( bxst ), n, b( st, 1 ), ldb ) ELSE IF( nsize <= smlsiz ) THEN CALL sgemm( 'T', 'N', nsize, nrhs, nsize, one, & work( vt+st1 ), n, work( bxst ), n, zero, b( st, 1 ), ldb ) ELSE CALL slalsa( icmpq2, smlsiz, nsize, nrhs, work( bxst ), n, & b( st, 1 ), ldb, work( u+st1 ), n, work( vt+st1 ), iwork( k+st1 ), & work( difl+st1 ), work( difr+st1 ), work( z+st1 ), work( poles+st1 ), & iwork( givptr+st1 ), iwork( givcol+st1 ), n, & iwork( perm+st1 ), work( givnum+st1 ), & work( c+st1 ), work( s+st1 ), work( nwork ), iwork( iwk ), info ) IF( info /= 0 ) THEN RETURN END IF END IF END DO ! ! Unscale and sort the singular values. ! CALL slascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) CALL slasrt( 'D', n, d, info ) CALL slascl( 'G', 0, 0, orgnrm, one, n, nrhs, b, ldb, info ) ! RETURN ! ! End of SLALSD ! END SUBROUTINE slalsd REAL FUNCTION slamch( cmach ) ! ! -- 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 (LEN=1), INTENT(IN) :: cmach ! .. ! ! Purpose ! ======= ! ! SLAMCH determines single precision machine parameters. ! ! Arguments ! ========= ! ! CMACH (input) CHARACTER*1 ! Specifies the value to be returned by SLAMCH: ! = 'E' or 'e', SLAMCH := eps ! = 'S' or 's , SLAMCH := sfmin ! = 'B' or 'b', SLAMCH := base ! = 'P' or 'p', SLAMCH := eps*base ! = 'N' or 'n', SLAMCH := t ! = 'R' or 'r', SLAMCH := rnd ! = 'M' or 'm', SLAMCH := emin ! = 'U' or 'u', SLAMCH := rmin ! = 'L' or 'l', SLAMCH := emax ! = 'O' or 'o', SLAMCH := rmax ! ! where ! ! eps = relative machine precision ! sfmin = safe minimum, such that 1/sfmin does not overflow ! base = base of the machine ! prec = eps*base ! t = number of (base) digits in the mantissa ! rnd = 1.0 when rounding occurs in addition, 0.0 otherwise ! emin = minimum exponent before (gradual) underflow ! rmin = underflow threshold - base**(emin-1) ! emax = largest exponent before overflow ! rmax = overflow threshold - (base**emax)*(1-eps) ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: first, lrnd INTEGER :: beta, imax, imin, it REAL :: base, emax, emin, eps, prec, rmach, rmax, rmin, rnd, sfmin, small, t ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL slamc2 ! .. ! .. Save statement .. SAVE first, eps, sfmin, base, t, rnd, emin, rmin, & emax, rmax, prec ! .. ! .. Data statements .. DATA first / .true. / ! .. ! .. Executable Statements .. ! IF( first ) THEN first = .false. CALL slamc2( beta, it, lrnd, eps, imin, rmin, imax, rmax ) base = beta t = it IF( lrnd ) THEN rnd = one eps = ( base**( 1-it ) ) / 2 ELSE rnd = zero eps = base**( 1-it ) END IF prec = eps*base emin = imin emax = imax sfmin = rmin small = one / rmax IF( small >= sfmin ) THEN ! ! Use SMALL plus a bit, to avoid the possibility of rounding ! causing overflow when computing 1/sfmin. ! sfmin = small*( one+eps ) END IF END IF ! IF( lsame( cmach, 'E' ) ) THEN rmach = eps ELSE IF( lsame( cmach, 'S' ) ) THEN rmach = sfmin ELSE IF( lsame( cmach, 'B' ) ) THEN rmach = base ELSE IF( lsame( cmach, 'P' ) ) THEN rmach = prec ELSE IF( lsame( cmach, 'N' ) ) THEN rmach = t ELSE IF( lsame( cmach, 'R' ) ) THEN rmach = rnd ELSE IF( lsame( cmach, 'M' ) ) THEN rmach = emin ELSE IF( lsame( cmach, 'U' ) ) THEN rmach = rmin ELSE IF( lsame( cmach, 'L' ) ) THEN rmach = emax ELSE IF( lsame( cmach, 'O' ) ) THEN rmach = rmax END IF ! slamch = rmach RETURN ! ! End of SLAMCH ! END FUNCTION slamch SUBROUTINE slamc1( beta, t, rnd, ieee1 ) ! ! -- 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, INTENT(OUT) :: beta INTEGER, INTENT(OUT) :: t LOGICAL, INTENT(OUT) :: rnd LOGICAL, INTENT(OUT) :: ieee1 ! .. ! ! Purpose ! ======= ! ! SLAMC1 determines the machine parameters given by BETA, T, RND, and ! IEEE1. ! ! Arguments ! ========= ! ! BETA (output) INTEGER ! The base of the machine. ! ! T (output) INTEGER ! The number of ( BETA ) digits in the mantissa. ! ! RND (output) LOGICAL ! Specifies whether proper rounding ( RND = .TRUE. ) or ! chopping ( RND = .FALSE. ) occurs in addition. This may not ! be a reliable guide to the way in which the machine performs ! its arithmetic. ! ! IEEE1 (output) LOGICAL ! Specifies whether rounding appears to be done in the IEEE ! 'round to nearest' style. ! ! Further Details ! =============== ! ! The routine is based on the routine ENVRON by Malcolm and ! incorporates suggestions by Gentleman and Marovich. See ! ! Malcolm M. A. (1972) Algorithms to reveal properties of ! floating-point arithmetic. Comms. of the ACM, 15, 949-951. ! ! Gentleman W. M. and Marovich S. B. (1974) More on algorithms ! that reveal properties of floating point arithmetic units. ! Comms. of the ACM, 17, 276-277. ! ! ===================================================================== ! ! .. Local Scalars .. LOGICAL :: first, lieee1, lrnd INTEGER :: lbeta, LT REAL :: a, b, c, f, one, qtr, savec, t1, t2 ! .. ! .. External Functions .. REAL :: slamc3 EXTERNAL slamc3 ! .. ! .. Save statement .. SAVE first, lieee1, lbeta, lrnd, LT ! .. ! .. Data statements .. DATA first / .true. / ! .. ! .. Executable Statements .. ! IF( first ) THEN first = .false. one = 1 ! ! LBETA, LIEEE1, LT and LRND are the local values of BETA, ! IEEE1, T and RND. ! ! Throughout this routine we use the function SLAMC3 to ensure ! that relevant values are stored and not held in registers, or ! are not affected by optimizers. ! ! Compute a = 2.0**m with the smallest positive integer m such ! that ! ! fl( a + 1.0 ) = a. ! a = 1 c = 1 ! !+ WHILE( C.EQ.ONE )LOOP 10 CONTINUE IF( c == one ) THEN a = 2*a c = slamc3( a, one ) c = slamc3( c, -a ) GO TO 10 END IF !+ END WHILE ! ! Now compute b = 2.0**m with the smallest positive integer m ! such that ! ! fl( a + b ) .gt. a. ! b = 1 c = slamc3( a, b ) ! !+ WHILE( C.EQ.A )LOOP 20 CONTINUE IF( c == a ) THEN b = 2*b c = slamc3( a, b ) GO TO 20 END IF !+ END WHILE ! ! Now compute the base. a and c are neighbouring floating point ! numbers in the interval ( beta**t, beta**( t + 1 ) ) and so ! their difference is beta. Adding 0.25 to c is to ensure that it ! is truncated to beta and not ( beta - 1 ). ! qtr = one / 4 savec = c c = slamc3( c, -a ) lbeta = c + qtr ! ! Now determine whether rounding or chopping occurs, by adding a ! bit less than beta/2 and a bit more than beta/2 to a. ! b = lbeta f = slamc3( b / 2, -b / 100 ) c = slamc3( f, a ) IF( c == a ) THEN lrnd = .true. ELSE lrnd = .false. END IF f = slamc3( b / 2, b / 100 ) c = slamc3( f, a ) IF( ( lrnd ) .AND. ( c == a ) ) lrnd = .false. ! ! Try and decide whether rounding is done in the IEEE 'round to ! nearest' style. B/2 is half a unit in the last place of the two ! numbers A and SAVEC. Furthermore, A is even, i.e. has last bit ! zero, and SAVEC is odd. Thus adding B/2 to A should not change ! A, but adding B/2 to SAVEC should change SAVEC. ! t1 = slamc3( b / 2, a ) t2 = slamc3( b / 2, savec ) lieee1 = ( t1 == a ) .AND. ( t2 > savec ) .AND. lrnd ! ! Now find the mantissa, t. It should be the integer part of ! log to the base beta of a, however it is safer to determine t ! by powering. So we find t as the smallest positive integer for ! which ! ! fl( beta**t + 1.0 ) = 1.0. ! LT = 0 a = 1 c = 1 ! !+ WHILE( C.EQ.ONE )LOOP 30 CONTINUE IF( c == one ) THEN LT = LT + 1 a = a*lbeta c = slamc3( a, one ) c = slamc3( c, -a ) GO TO 30 END IF !+ END WHILE ! END IF ! beta = lbeta t = LT rnd = lrnd ieee1 = lieee1 RETURN ! ! End of SLAMC1 ! END SUBROUTINE slamc1 ! !*********************************************************************** ! SUBROUTINE slamc2( beta, t, rnd, eps, emin, rmin, emax, rmax ) ! ! -- 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, INTENT(OUT) :: beta INTEGER, INTENT(OUT) :: t LOGICAL, INTENT(OUT) :: rnd REAL, INTENT(OUT) :: eps INTEGER, INTENT(OUT) :: emin REAL, INTENT(OUT) :: rmin INTEGER, INTENT(OUT) :: emax REAL, INTENT(OUT) :: rmax ! .. ! ! Purpose ! ======= ! ! SLAMC2 determines the machine parameters specified in its argument ! list. ! ! Arguments ! ========= ! ! BETA (output) INTEGER ! The base of the machine. ! ! T (output) INTEGER ! The number of ( BETA ) digits in the mantissa. ! ! RND (output) LOGICAL ! Specifies whether proper rounding ( RND = .TRUE. ) or ! chopping ( RND = .FALSE. ) occurs in addition. This may not ! be a reliable guide to the way in which the machine performs ! its arithmetic. ! ! EPS (output) REAL ! The smallest positive number such that ! ! fl( 1.0 - EPS ) .LT. 1.0, ! ! where fl denotes the computed value. ! ! EMIN (output) INTEGER ! The minimum exponent before (gradual) underflow occurs. ! ! RMIN (output) REAL ! The smallest normalized number for the machine, given by ! BASE**( EMIN - 1 ), where BASE is the floating point value ! of BETA. ! ! EMAX (output) INTEGER ! The maximum exponent before overflow occurs. ! ! RMAX (output) REAL ! The largest positive number for the machine, given by ! BASE**EMAX * ( 1 - EPS ), where BASE is the floating point ! value of BETA. ! ! Further Details ! =============== ! ! The computation of EPS is based on a routine PARANOIA by ! W. Kahan of the University of California at Berkeley. ! ! ===================================================================== ! ! .. Local Scalars .. LOGICAL :: first, ieee, iwarn, lieee1, lrnd INTEGER :: gnmin, gpmin, i, lbeta, lemax, lemin, LT, ngnmin, ngpmin REAL :: a, b, c, half, leps, lrmax, lrmin, one, rbase, & sixth, small, third, two, zero ! .. ! .. External Functions .. REAL :: slamc3 EXTERNAL slamc3 ! .. ! .. External Subroutines .. EXTERNAL slamc1, slamc4, slamc5 ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. Save statement .. SAVE first, iwarn, lbeta, lemax, lemin, leps, lrmax, lrmin, LT ! .. ! .. Data statements .. DATA first / .true. / , iwarn / .false. / ! .. ! .. Executable Statements .. ! IF( first ) THEN first = .false. zero = 0 one = 1 two = 2 ! ! LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of ! BETA, T, RND, EPS, EMIN and RMIN. ! ! Throughout this routine we use the function SLAMC3 to ensure ! that relevant values are stored and not held in registers, or ! are not affected by optimizers. ! ! SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. ! CALL slamc1( lbeta, LT, lrnd, lieee1 ) ! ! Start to find EPS. ! b = lbeta a = b**( -LT ) leps = a ! ! Try some tricks to see whether or not this is the correct EPS. ! b = two / 3 half = one / 2 sixth = slamc3( b, -half ) third = slamc3( sixth, sixth ) b = slamc3( third, -half ) b = slamc3( b, sixth ) b = ABS( b ) IF( b < leps ) b = leps ! leps = 1 ! !+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP 10 CONTINUE IF( ( leps > b ) .AND. ( b > zero ) ) THEN leps = b c = slamc3( half*leps, ( two**5 )*( leps**2 ) ) c = slamc3( half, -c ) b = slamc3( half, c ) c = slamc3( half, -b ) b = slamc3( half, c ) GO TO 10 END IF !+ END WHILE ! IF( a < leps ) leps = a ! ! Computation of EPS complete. ! ! Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). ! Keep dividing A by BETA until (gradual) underflow occurs. This ! is detected when we cannot recover the previous A. ! rbase = one / lbeta small = one DO i = 1, 3 small = slamc3( small*rbase, zero ) END DO a = slamc3( one, small ) CALL slamc4( ngpmin, one, lbeta ) CALL slamc4( ngnmin, -one, lbeta ) CALL slamc4( gpmin, a, lbeta ) CALL slamc4( gnmin, -a, lbeta ) ieee = .false. ! IF( ( ngpmin == ngnmin ) .AND. ( gpmin == gnmin ) ) THEN IF( ngpmin == gpmin ) THEN lemin = ngpmin ! ( Non twos-complement machines, no gradual underflow; ! e.g., VAX ) ELSE IF( ( gpmin-ngpmin ) == 3 ) THEN lemin = ngpmin - 1 + LT ieee = .true. ! ( Non twos-complement machines, with gradual underflow; ! e.g., IEEE standard followers ) ELSE lemin = MIN( ngpmin, gpmin ) ! ( A guess; no known machine ) iwarn = .true. END IF ! ELSE IF( ( ngpmin == gpmin ) .AND. ( ngnmin == gnmin ) ) THEN IF( ABS( ngpmin-ngnmin ) == 1 ) THEN lemin = MAX( ngpmin, ngnmin ) ! ( Twos-complement machines, no gradual underflow; ! e.g., CYBER 205 ) ELSE lemin = MIN( ngpmin, ngnmin ) ! ( A guess; no known machine ) iwarn = .true. END IF ! ELSE IF( ( ABS( ngpmin-ngnmin ) == 1 ) .AND. & ( gpmin == gnmin ) ) THEN IF( ( gpmin-MIN( ngpmin, ngnmin ) ) == 3 ) THEN lemin = MAX( ngpmin, ngnmin ) - 1 + LT ! ( Twos-complement machines with gradual underflow; ! no known machine ) ELSE lemin = MIN( ngpmin, ngnmin ) ! ( A guess; no known machine ) iwarn = .true. END IF ! ELSE lemin = MIN( ngpmin, ngnmin, gpmin, gnmin ) ! ( A guess; no known machine ) iwarn = .true. END IF !** ! Comment out this if block if EMIN is ok IF( iwarn ) THEN first = .true. WRITE( 6, FMT = 9999 )lemin END IF !** ! ! Assume IEEE arithmetic if we found denormalised numbers above, ! or if arithmetic seems to round in the IEEE style, determined ! in routine SLAMC1. A true IEEE machine should have both things ! true; however, faulty machines may have one or the other. ! ieee = ieee .OR. lieee1 ! ! Compute RMIN by successive division by BETA. We could compute ! RMIN as BASE**( EMIN - 1 ), but some machines underflow during ! this computation. ! lrmin = 1 DO i = 1, 1 - lemin lrmin = slamc3( lrmin*rbase, zero ) END DO ! ! Finally, call SLAMC5 to compute EMAX and RMAX. ! CALL slamc5( lbeta, LT, lemin, ieee, lemax, lrmax ) END IF ! beta = lbeta t = LT rnd = lrnd eps = leps emin = lemin rmin = lrmin emax = lemax rmax = lrmax ! RETURN ! 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', & ' EMIN = ', i8, / ' If, after inspection, the value EMIN looks', & ' acceptable please comment out ', & / ' the IF block as marked within the code of routine', & ' SLAMC2,', / ' otherwise supply EMIN explicitly.', / ) ! ! End of SLAMC2 ! END SUBROUTINE slamc2 REAL FUNCTION slamc3( a, b ) ! ! -- 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 .. REAL, INTENT(IN) :: a REAL, INTENT(IN) :: b ! .. ! ! Purpose ! ======= ! ! SLAMC3 is intended to force A and B to be stored prior to doing ! the addition of A and B , for use in situations where optimizers ! might hold one of these in a register. ! ! Arguments ! ========= ! ! A, B (input) REAL ! The values A and B. ! ! ===================================================================== ! ! .. Executable Statements .. ! slamc3 = a + b ! RETURN ! ! End of SLAMC3 ! END FUNCTION slamc3 SUBROUTINE slamc4( emin, start, base ) ! ! -- 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, INTENT(OUT) :: emin REAL, INTENT(IN) :: start INTEGER, INTENT(IN) :: base ! .. ! ! Purpose ! ======= ! ! SLAMC4 is a service routine for SLAMC2. ! ! Arguments ! ========= ! ! EMIN (output) EMIN ! The minimum exponent before (gradual) underflow, computed by ! setting A = START and dividing by BASE until the previous A ! can not be recovered. ! ! START (input) REAL ! The starting point for determining EMIN. ! ! BASE (input) INTEGER ! The base of the machine. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER :: i REAL :: a, b1, b2, c1, c2, d1, d2, one, rbase, zero ! .. ! .. External Functions .. REAL :: slamc3 EXTERNAL slamc3 ! .. ! .. Executable Statements .. ! a = start one = 1 rbase = one / base zero = 0 emin = 1 b1 = slamc3( a*rbase, zero ) c1 = a c2 = a d1 = a d2 = a !+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. ! $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP 10 CONTINUE IF( ( c1 == a ) .AND. ( c2 == a ) .AND. ( d1 == a ) .AND. ( d2 == a ) ) THEN emin = emin - 1 a = b1 b1 = slamc3( a / base, zero ) c1 = slamc3( b1*base, zero ) d1 = zero DO i = 1, base d1 = d1 + b1 END DO b2 = slamc3( a*rbase, zero ) c2 = slamc3( b2 / rbase, zero ) d2 = zero DO i = 1, base d2 = d2 + b2 END DO GO TO 10 END IF !+ END WHILE ! RETURN ! ! End of SLAMC4 ! END SUBROUTINE slamc4 SUBROUTINE slamc5( beta, p, emin, ieee, emax, rmax ) ! ! -- 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, INTENT(IN) :: beta INTEGER, INTENT(IN) :: p INTEGER, INTENT(IN) :: emin LOGICAL, INTENT(IN) :: ieee INTEGER, INTENT(OUT) :: emax REAL, INTENT(OUT) :: rmax ! .. ! ! Purpose ! ======= ! ! SLAMC5 attempts to compute RMAX, the largest machine floating-point ! number, without overflow. It assumes that EMAX + abs(EMIN) sum ! approximately to a power of 2. It will fail on machines where this ! assumption does not hold, for example, the Cyber 205 (EMIN = -28625, ! EMAX = 28718). It will also fail if the value supplied for EMIN is ! too large (i.e. too close to zero), probably with overflow. ! ! Arguments ! ========= ! ! BETA (input) INTEGER ! The base of floating-point arithmetic. ! ! P (input) INTEGER ! The number of base BETA digits in the mantissa of a ! floating-point value. ! ! EMIN (input) INTEGER ! The minimum exponent before (gradual) underflow. ! ! IEEE (input) LOGICAL ! A logical flag specifying whether or not the arithmetic ! system is thought to comply with the IEEE standard. ! ! EMAX (output) INTEGER ! The largest exponent before overflow ! ! RMAX (output) REAL ! The largest machine floating-point number. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. INTEGER :: exbits, expsum, i, lexp, nbits, try, uexp REAL :: oldy, recbas, y, z ! .. ! .. External Functions .. REAL :: slamc3 EXTERNAL slamc3 ! .. ! .. Intrinsic Functions .. INTRINSIC MOD ! .. ! .. Executable Statements .. ! ! First compute LEXP and UEXP, two powers of 2 that bound ! abs(EMIN). We then assume that EMAX + abs(EMIN) will sum ! approximately to the bound that is closest to abs(EMIN). ! (EMAX is the exponent of the required number RMAX). ! lexp = 1 exbits = 1 10 CONTINUE try = lexp*2 IF( try <= ( -emin ) ) THEN lexp = try exbits = exbits + 1 GO TO 10 END IF IF( lexp == -emin ) THEN uexp = lexp ELSE uexp = try exbits = exbits + 1 END IF ! ! Now -LEXP is less than or equal to EMIN, and -UEXP is greater ! than or equal to EMIN. EXBITS is the number of bits needed to ! store the exponent. ! IF( ( uexp+emin ) > ( -lexp-emin ) ) THEN expsum = 2*lexp ELSE expsum = 2*uexp END IF ! ! EXPSUM is the exponent range, approximately equal to ! EMAX - EMIN + 1 . ! emax = expsum + emin - 1 nbits = 1 + exbits + p ! ! NBITS is the total number of bits needed to store a ! floating-point number. ! IF( ( MOD( nbits, 2 ) == 1 ) .AND. ( beta == 2 ) ) THEN ! ! Either there are an odd number of bits used to store a ! floating-point number, which is unlikely, or some bits are ! not used in the representation of numbers, which is possible, ! (e.g. Cray machines) or the mantissa has an implicit bit, ! (e.g. IEEE machines, Dec Vax machines), which is perhaps the ! most likely. We have to assume the last alternative. ! If this is true, then we need to reduce EMAX by one because ! there must be some way of representing zero in an implicit-bit ! system. On machines like Cray, we are reducing EMAX by one ! unnecessarily. ! emax = emax - 1 END IF ! IF( ieee ) THEN ! ! Assume we are on an IEEE machine which reserves one exponent ! for infinity and NaN. ! emax = emax - 1 END IF ! ! Now create RMAX, the largest machine number, which should ! be equal to (1.0 - BETA**(-P)) * BETA**EMAX . ! ! First compute 1.0 - BETA**(-P), being careful that the ! result is less than 1.0 . ! recbas = one / beta z = beta - one y = zero DO i = 1, p z = z*recbas IF( y < one ) oldy = y y = slamc3( y, z ) END DO IF( y >= one ) y = oldy ! ! Now multiply by BETA**EMAX to get RMAX. ! DO i = 1, emax y = slamc3( y*beta, zero ) END DO ! rmax = y RETURN ! ! End of SLAMC5 ! END SUBROUTINE slamc5 SUBROUTINE slamrg( n1, n2, a, strd1, strd2, INDEX ) ! ! -- 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, INTENT(IN) :: n1 INTEGER, INTENT(IN) :: n2 REAL, INTENT(IN) :: a( * ) INTEGER, INTENT(IN) :: strd1 INTEGER, INTENT(IN) :: strd2 INTEGER, INTENT(OUT) :: INDEX( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAMRG will create a permutation list which will merge the elements ! of A (which is composed of two independently sorted sets) into a ! single set which is sorted in ascending order. ! ! Arguments ! ========= ! ! N1 (input) INTEGER ! N2 (input) INTEGER ! These arguements contain the respective lengths of the two ! sorted lists to be merged. ! ! A (input) REAL array, dimension (N1+N2) ! The first N1 elements of A contain a list of numbers which ! are sorted in either ascending or descending order. Likewise ! for the final N2 elements. ! ! STRD1 (input) INTEGER ! STRD2 (input) INTEGER ! These are the strides to be taken through the array A. ! Allowable strides are 1 and -1. They indicate whether a ! subset of A is sorted in ascending (STRDx = 1) or descending ! (STRDx = -1) order. ! ! INDEX (output) INTEGER array, dimension (N1+N2) ! On exit this array will contain a permutation such that ! if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be ! sorted in ascending order. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER :: i, ind1, ind2, n1sv, n2sv ! .. ! .. Executable Statements .. ! n1sv = n1 n2sv = n2 IF( strd1 > 0 ) THEN ind1 = 1 ELSE ind1 = n1 END IF IF( strd2 > 0 ) THEN ind2 = 1 + n1 ELSE ind2 = n1 + n2 END IF i = 1 ! while ( (N1SV > 0) & (N2SV > 0) ) 10 CONTINUE IF( n1sv > 0 .AND. n2sv > 0 ) THEN IF( a( ind1 ) <= a( ind2 ) ) THEN INDEX( i ) = ind1 i = i + 1 ind1 = ind1 + strd1 n1sv = n1sv - 1 ELSE INDEX( i ) = ind2 i = i + 1 ind2 = ind2 + strd2 n2sv = n2sv - 1 END IF GO TO 10 END IF ! end while IF( n1sv == 0 ) THEN DO n1sv = 1, n2sv INDEX( i ) = ind2 i = i + 1 ind2 = ind2 + strd2 END DO ELSE ! N2SV .EQ. 0 DO n2sv = 1, n1sv INDEX( i ) = ind1 i = i + 1 ind1 = ind1 + strd1 END DO END IF ! RETURN ! ! End of SLAMRG ! END SUBROUTINE slamrg REAL FUNCTION slangb( norm, n, kl, ku, ab, ldab, 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 (LEN=1), INTENT(IN OUT) :: norm INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: kl INTEGER, INTENT(IN) :: ku REAL, INTENT(IN) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(OUT) :: work( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLANGB returns the value of the one norm, or the Frobenius norm, or ! the infinity norm, or the element of largest absolute value of an ! n by n band matrix A, with kl sub-diagonals and ku super-diagonals. ! ! Description ! =========== ! ! SLANGB returns the value ! ! SLANGB = ( 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 SLANGB as described ! above. ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. When N = 0, SLANGB is ! set to zero. ! ! KL (input) INTEGER ! The number of sub-diagonals of the matrix A. KL >= 0. ! ! KU (input) INTEGER ! The number of super-diagonals of the matrix A. KU >= 0. ! ! AB (input) REAL array, dimension (LDAB,N) ! The band matrix A, stored in rows 1 to KL+KU+1. The j-th ! column of A is stored in the j-th column of the array AB as ! follows: ! AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KL+KU+1. ! ! WORK (workspace) REAL array, dimension (LWORK), ! where LWORK >= N when NORM = 'I'; otherwise, WORK is not ! referenced. ! ! ===================================================================== ! ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j, k, l REAL :: scale, sum, value ! .. ! .. External Subroutines .. EXTERNAL slassq ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! IF( n == 0 ) THEN value = zero ELSE IF( lsame( norm, 'M' ) ) THEN ! ! Find max(abs(A(i,j))). ! value = zero DO j = 1, n DO i = MAX( ku+2-j, 1 ), MIN( n+ku+1-j, kl+ku+1 ) value = MAX( value, ABS( ab( i, j ) ) ) END DO END DO ELSE IF( ( lsame( norm, 'O' ) ) .OR. ( norm == '1' ) ) THEN ! ! Find norm1(A). ! value = zero DO j = 1, n sum = zero DO i = MAX( ku+2-j, 1 ), MIN( n+ku+1-j, kl+ku+1 ) sum = sum + ABS( ab( i, j ) ) END DO value = MAX( value, sum ) END DO ELSE IF( lsame( norm, 'I' ) ) THEN ! ! Find normI(A). ! DO i = 1, n work( i ) = zero END DO DO j = 1, n k = ku + 1 - j DO i = MAX( 1, j-ku ), MIN( n, j+kl ) work( i ) = work( i ) + ABS( ab( k+i, j ) ) END DO END DO value = zero DO i = 1, n value = MAX( value, work( i ) ) END DO ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN ! ! Find normF(A). ! scale = zero sum = one DO j = 1, n l = MAX( 1, j-ku ) k = ku + 1 - j + l CALL slassq( MIN( n, j+kl )-l+1, ab( k, j ), 1, scale, sum ) END DO value = scale*SQRT( sum ) END IF ! slangb = value RETURN ! ! End of SLANGB ! END FUNCTION slangb REAL FUNCTION slange( 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 (LEN=1), INTENT(IN OUT) :: norm INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: work( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLANGE 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 matrix A. ! ! Description ! =========== ! ! SLANGE returns the value ! ! SLANGE = ( 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 SLANGE as described ! above. ! ! M (input) INTEGER ! The number of rows of the matrix A. M >= 0. When M = 0, ! SLANGE is set to zero. ! ! N (input) INTEGER ! The number of columns of the matrix A. N >= 0. When N = 0, ! SLANGE is set to zero. ! ! A (input) REAL 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) REAL array, dimension (LWORK), ! where LWORK >= M when NORM = 'I'; otherwise, WORK is not ! referenced. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j REAL :: scale, sum, value ! .. ! .. External Subroutines .. EXTERNAL slassq ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! IF( MIN( m, n ) == 0 ) THEN value = zero ELSE IF( lsame( norm, 'M' ) ) THEN ! ! Find max(abs(A(i,j))). ! value = zero DO j = 1, n DO i = 1, m value = MAX( value, ABS( a( i, j ) ) ) END DO END DO ELSE IF( ( lsame( norm, 'O' ) ) .OR. ( norm == '1' ) ) THEN ! ! Find norm1(A). ! value = zero DO j = 1, n sum = zero DO i = 1, m sum = sum + ABS( a( i, j ) ) END DO value = MAX( value, sum ) END DO ELSE IF( lsame( norm, 'I' ) ) THEN ! ! Find normI(A). ! DO i = 1, m work( i ) = zero END DO DO j = 1, n DO i = 1, m work( i ) = work( i ) + ABS( a( i, j ) ) END DO END DO value = zero DO i = 1, m value = MAX( value, work( i ) ) END DO ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN ! ! Find normF(A). ! scale = zero sum = one DO j = 1, n CALL slassq( m, a( 1, j ), 1, scale, sum ) END DO value = scale*SQRT( sum ) END IF ! slange = value RETURN ! ! End of SLANGE ! END FUNCTION slange REAL FUNCTION slangt( norm, n, dl, d, du ) ! ! -- 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 (LEN=1), INTENT(IN OUT) :: norm INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: dl( * ) REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: du( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLANGT 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 tridiagonal matrix A. ! ! Description ! =========== ! ! SLANGT returns the value ! ! SLANGT = ( 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 SLANGT as described ! above. ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. When N = 0, SLANGT is ! set to zero. ! ! DL (input) REAL array, dimension (N-1) ! The (n-1) sub-diagonal elements of A. ! ! D (input) REAL array, dimension (N) ! The diagonal elements of A. ! ! DU (input) REAL array, dimension (N-1) ! The (n-1) super-diagonal elements of A. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i REAL :: anorm, scale, sum ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL slassq ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT ! .. ! .. Executable Statements .. ! IF( n <= 0 ) THEN anorm = zero ELSE IF( lsame( norm, 'M' ) ) THEN ! ! Find max(abs(A(i,j))). ! anorm = ABS( d( n ) ) DO i = 1, n - 1 anorm = MAX( anorm, ABS( dl( i ) ) ) anorm = MAX( anorm, ABS( d( i ) ) ) anorm = MAX( anorm, ABS( du( i ) ) ) END DO ELSE IF( lsame( norm, 'O' ) .OR. norm == '1' ) THEN ! ! Find norm1(A). ! IF( n == 1 ) THEN anorm = ABS( d( 1 ) ) ELSE anorm = MAX( ABS( d( 1 ) )+ABS( dl( 1 ) ), & ABS( d( n ) )+ABS( du( n-1 ) ) ) DO i = 2, n - 1 anorm = MAX( anorm, ABS( d( i ) )+ABS( dl( i ) )+ ABS( du( i-1 ) ) ) END DO END IF ELSE IF( lsame( norm, 'I' ) ) THEN ! ! Find normI(A). ! IF( n == 1 ) THEN anorm = ABS( d( 1 ) ) ELSE anorm = MAX( ABS( d( 1 ) )+ABS( du( 1 ) ), & ABS( d( n ) )+ABS( dl( n-1 ) ) ) DO i = 2, n - 1 anorm = MAX( anorm, ABS( d( i ) )+ABS( du( i ) )+ ABS( dl( i-1 ) ) ) END DO END IF ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN ! ! Find normF(A). ! scale = zero sum = one CALL slassq( n, d, 1, scale, sum ) IF( n > 1 ) THEN CALL slassq( n-1, dl, 1, scale, sum ) CALL slassq( n-1, du, 1, scale, sum ) END IF anorm = scale*SQRT( sum ) END IF ! slangt = anorm RETURN ! ! End of SLANGT ! END FUNCTION slangt REAL FUNCTION slanhs( 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 (LEN=1), INTENT(IN OUT) :: norm INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: work( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLANHS 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 ! =========== ! ! SLANHS returns the value ! ! SLANHS = ( 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 SLANHS as described ! above. ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. When N = 0, SLANHS is ! set to zero. ! ! A (input) REAL 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) REAL array, dimension (LWORK), ! where LWORK >= N when NORM = 'I'; otherwise, WORK is not ! referenced. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j REAL :: scale, sum, value ! .. ! .. External Subroutines .. EXTERNAL slassq ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! IF( n == 0 ) THEN value = zero ELSE IF( lsame( norm, 'M' ) ) THEN ! ! Find max(abs(A(i,j))). ! value = zero DO j = 1, n DO i = 1, MIN( n, j+1 ) value = MAX( value, ABS( a( i, j ) ) ) END DO END DO ELSE IF( ( lsame( norm, 'O' ) ) .OR. ( norm == '1' ) ) THEN ! ! Find norm1(A). ! value = zero DO j = 1, n sum = zero DO i = 1, MIN( n, j+1 ) sum = sum + ABS( a( i, j ) ) END DO value = MAX( value, sum ) END DO ELSE IF( lsame( norm, 'I' ) ) THEN ! ! Find normI(A). ! DO i = 1, n work( i ) = zero END DO DO j = 1, n DO i = 1, MIN( n, j+1 ) work( i ) = work( i ) + ABS( a( i, j ) ) END DO END DO value = zero DO i = 1, n value = MAX( value, work( i ) ) END DO ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN ! ! Find normF(A). ! scale = zero sum = one DO j = 1, n CALL slassq( MIN( n, j+1 ), a( 1, j ), 1, scale, sum ) END DO value = scale*SQRT( sum ) END IF ! slanhs = value RETURN ! ! End of SLANHS ! END FUNCTION slanhs REAL FUNCTION slansb( norm, uplo, n, k, ab, ldab, 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 (LEN=1), INTENT(IN OUT) :: norm CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(IN) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(OUT) :: work( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLANSB returns the value of the one norm, or the Frobenius norm, or ! the infinity norm, or the element of largest absolute value of an ! n by n symmetric band matrix A, with k super-diagonals. ! ! Description ! =========== ! ! SLANSB returns the value ! ! SLANSB = ( 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 SLANSB as described ! above. ! ! UPLO (input) CHARACTER*1 ! Specifies whether the upper or lower triangular part of the ! band matrix A is supplied. ! = 'U': Upper triangular part is supplied ! = 'L': Lower triangular part is supplied ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. When N = 0, SLANSB is ! set to zero. ! ! K (input) INTEGER ! The number of super-diagonals or sub-diagonals of the ! band matrix A. K >= 0. ! ! AB (input) REAL array, dimension (LDAB,N) ! The upper or lower triangle of the symmetric band matrix A, ! stored in the first K+1 rows of AB. The j-th column of A is ! stored in the j-th column of the array AB as follows: ! if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= K+1. ! ! WORK (workspace) REAL array, dimension (LWORK), ! where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, ! WORK is not referenced. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j, l REAL :: absa, scale, sum, value ! .. ! .. External Subroutines .. EXTERNAL slassq ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! IF( n == 0 ) THEN value = zero ELSE IF( lsame( norm, 'M' ) ) THEN ! ! Find max(abs(A(i,j))). ! value = zero IF( lsame( uplo, 'U' ) ) THEN DO j = 1, n DO i = MAX( k+2-j, 1 ), k + 1 value = MAX( value, ABS( ab( i, j ) ) ) END DO END DO ELSE DO j = 1, n DO i = 1, MIN( n+1-j, k+1 ) value = MAX( value, ABS( ab( i, j ) ) ) END DO END DO END IF ELSE IF( ( lsame( norm, 'I' ) ) .OR. ( lsame( norm, 'O' ) ) .OR. & ( norm == '1' ) ) THEN ! ! Find normI(A) ( = norm1(A), since A is symmetric). ! value = zero IF( lsame( uplo, 'U' ) ) THEN DO j = 1, n sum = zero l = k + 1 - j DO i = MAX( 1, j-k ), j - 1 absa = ABS( ab( l+i, j ) ) sum = sum + absa work( i ) = work( i ) + absa END DO work( j ) = sum + ABS( ab( k+1, j ) ) END DO DO i = 1, n value = MAX( value, work( i ) ) END DO ELSE DO i = 1, n work( i ) = zero END DO DO j = 1, n sum = work( j ) + ABS( ab( 1, j ) ) l = 1 - j DO i = j + 1, MIN( n, j+k ) absa = ABS( ab( l+i, j ) ) sum = sum + absa work( i ) = work( i ) + absa END DO value = MAX( value, sum ) END DO END IF ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN ! ! Find normF(A). ! scale = zero sum = one IF( k > 0 ) THEN IF( lsame( uplo, 'U' ) ) THEN DO j = 2, n CALL slassq( MIN( j-1, k ), ab( MAX( k+2-j, 1 ), j ), 1, scale, sum ) END DO l = k + 1 ELSE DO j = 1, n - 1 CALL slassq( MIN( n-j, k ), ab( 2, j ), 1, scale, sum ) END DO l = 1 END IF sum = 2*sum ELSE l = 1 END IF CALL slassq( n, ab( l, 1 ), ldab, scale, sum ) value = scale*SQRT( sum ) END IF ! slansb = value RETURN ! ! End of SLANSB ! END FUNCTION slansb REAL FUNCTION slansp( 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 (LEN=1), INTENT(IN OUT) :: norm CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: ap( * ) REAL, INTENT(OUT) :: work( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLANSP 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 ! =========== ! ! SLANSP returns the value ! ! SLANSP = ( 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 SLANSP 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, SLANSP is ! set to zero. ! ! AP (input) REAL 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) REAL array, dimension (LWORK), ! where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, ! WORK is not referenced. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j, k REAL :: absa, scale, sum, value ! .. ! .. External Subroutines .. EXTERNAL slassq ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT ! .. ! .. Executable Statements .. ! IF( n == 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 j = 1, n DO i = k, k + j - 1 value = MAX( value, ABS( ap( i ) ) ) END DO k = k + j END DO ELSE k = 1 DO j = 1, n DO i = k, k + n - j value = MAX( value, ABS( ap( i ) ) ) END DO k = k + n - j + 1 END DO END IF ELSE IF( ( lsame( norm, 'I' ) ) .OR. ( lsame( norm, 'O' ) ) .OR. & ( norm == '1' ) ) THEN ! ! Find normI(A) ( = norm1(A), since A is symmetric). ! value = zero k = 1 IF( lsame( uplo, 'U' ) ) THEN DO j = 1, n sum = zero DO i = 1, j - 1 absa = ABS( ap( k ) ) sum = sum + absa work( i ) = work( i ) + absa k = k + 1 END DO work( j ) = sum + ABS( ap( k ) ) k = k + 1 END DO DO i = 1, n value = MAX( value, work( i ) ) END DO ELSE DO i = 1, n work( i ) = zero END DO DO j = 1, n sum = work( j ) + ABS( ap( k ) ) k = k + 1 DO i = j + 1, n absa = ABS( ap( k ) ) sum = sum + absa work( i ) = work( i ) + absa k = k + 1 END DO value = MAX( value, sum ) END DO 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 j = 2, n CALL slassq( j-1, ap( k ), 1, scale, sum ) k = k + j END DO ELSE DO j = 1, n - 1 CALL slassq( n-j, ap( k ), 1, scale, sum ) k = k + n - j + 1 END DO END IF sum = 2*sum k = 1 DO i = 1, n IF( ap( k ) /= zero ) THEN absa = ABS( ap( k ) ) IF( scale < 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 END DO value = scale*SQRT( sum ) END IF ! slansp = value RETURN ! ! End of SLANSP ! END FUNCTION slansp REAL FUNCTION slanst( 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 (LEN=1), INTENT(IN OUT) :: norm INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: e( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLANST 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 ! =========== ! ! SLANST returns the value ! ! SLANST = ( 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 SLANST as described ! above. ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. When N = 0, SLANST is ! set to zero. ! ! D (input) REAL array, dimension (N) ! The diagonal elements of A. ! ! E (input) REAL array, dimension (N-1) ! The (n-1) sub-diagonal or super-diagonal elements of A. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i REAL :: anorm, scale, sum ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL slassq ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT ! .. ! .. Executable Statements .. ! IF( n <= 0 ) THEN anorm = zero ELSE IF( lsame( norm, 'M' ) ) THEN ! ! Find max(abs(A(i,j))). ! anorm = ABS( d( n ) ) DO i = 1, n - 1 anorm = MAX( anorm, ABS( d( i ) ) ) anorm = MAX( anorm, ABS( e( i ) ) ) END DO ELSE IF( lsame( norm, 'O' ) .OR. norm == '1' .OR. & lsame( norm, 'I' ) ) THEN ! ! Find norm1(A). ! IF( n == 1 ) THEN anorm = ABS( d( 1 ) ) ELSE anorm = MAX( ABS( d( 1 ) )+ABS( e( 1 ) ), ABS( e( n-1 ) )+ABS( d( n ) ) ) DO i = 2, n - 1 anorm = MAX( anorm, ABS( d( i ) )+ABS( e( i ) )+ ABS( e( i-1 ) ) ) END DO END IF ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN ! ! Find normF(A). ! scale = zero sum = one IF( n > 1 ) THEN CALL slassq( n-1, e, 1, scale, sum ) sum = 2*sum END IF CALL slassq( n, d, 1, scale, sum ) anorm = scale*SQRT( sum ) END IF ! slanst = anorm RETURN ! ! End of SLANST ! END FUNCTION slanst REAL FUNCTION slansy( 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 (LEN=1), INTENT(IN OUT) :: norm CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: work( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLANSY 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 ! =========== ! ! SLANSY returns the value ! ! SLANSY = ( 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 SLANSY 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, SLANSY is ! set to zero. ! ! A (input) REAL 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) REAL array, dimension (LWORK), ! where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, ! WORK is not referenced. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j REAL :: absa, scale, sum, value ! .. ! .. External Subroutines .. EXTERNAL slassq ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT ! .. ! .. Executable Statements .. ! IF( n == 0 ) THEN value = zero ELSE IF( lsame( norm, 'M' ) ) THEN ! ! Find max(abs(A(i,j))). ! value = zero IF( lsame( uplo, 'U' ) ) THEN DO j = 1, n DO i = 1, j value = MAX( value, ABS( a( i, j ) ) ) END DO END DO ELSE DO j = 1, n DO i = j, n value = MAX( value, ABS( a( i, j ) ) ) END DO END DO END IF ELSE IF( ( lsame( norm, 'I' ) ) .OR. ( lsame( norm, 'O' ) ) .OR. & ( norm == '1' ) ) THEN ! ! Find normI(A) ( = norm1(A), since A is symmetric). ! value = zero IF( lsame( uplo, 'U' ) ) THEN DO j = 1, n sum = zero DO i = 1, j - 1 absa = ABS( a( i, j ) ) sum = sum + absa work( i ) = work( i ) + absa END DO work( j ) = sum + ABS( a( j, j ) ) END DO DO i = 1, n value = MAX( value, work( i ) ) END DO ELSE DO i = 1, n work( i ) = zero END DO DO j = 1, n sum = work( j ) + ABS( a( j, j ) ) DO i = j + 1, n absa = ABS( a( i, j ) ) sum = sum + absa work( i ) = work( i ) + absa END DO value = MAX( value, sum ) END DO 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 j = 2, n CALL slassq( j-1, a( 1, j ), 1, scale, sum ) END DO ELSE DO j = 1, n - 1 CALL slassq( n-j, a( j+1, j ), 1, scale, sum ) END DO END IF sum = 2*sum CALL slassq( n, a, lda+1, scale, sum ) value = scale*SQRT( sum ) END IF ! slansy = value RETURN ! ! End of SLANSY ! END FUNCTION slansy REAL FUNCTION slantb( norm, uplo, diag, n, k, ab, ldab, 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 (LEN=1), INTENT(IN OUT) :: norm CHARACTER (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: diag INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(IN) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(OUT) :: work( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLANTB returns the value of the one norm, or the Frobenius norm, or ! the infinity norm, or the element of largest absolute value of an ! n by n triangular band matrix A, with ( k + 1 ) diagonals. ! ! Description ! =========== ! ! SLANTB returns the value ! ! SLANTB = ( 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 SLANTB as described ! above. ! ! 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. When N = 0, SLANTB is ! set to zero. ! ! K (input) INTEGER ! The number of super-diagonals of the matrix A if UPLO = 'U', ! or the number of sub-diagonals of the matrix A if UPLO = 'L'. ! K >= 0. ! ! AB (input) REAL array, dimension (LDAB,N) ! The upper or lower triangular band matrix A, stored in the ! first k+1 rows of AB. The j-th column of A is stored ! in the j-th column of the array AB as follows: ! if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k). ! Note that when DIAG = 'U', the elements of the array AB ! corresponding to the diagonal elements of the matrix A are ! not referenced, but are assumed to be one. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= K+1. ! ! WORK (workspace) REAL array, dimension (LWORK), ! where LWORK >= N when NORM = 'I'; otherwise, WORK is not ! referenced. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: udiag INTEGER :: i, j, l REAL :: scale, sum, value ! .. ! .. External Subroutines .. EXTERNAL slassq ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! IF( n == 0 ) THEN value = zero ELSE IF( lsame( norm, 'M' ) ) THEN ! ! Find max(abs(A(i,j))). ! IF( lsame( diag, 'U' ) ) THEN value = one IF( lsame( uplo, 'U' ) ) THEN DO j = 1, n DO i = MAX( k+2-j, 1 ), k value = MAX( value, ABS( ab( i, j ) ) ) END DO END DO ELSE DO j = 1, n DO i = 2, MIN( n+1-j, k+1 ) value = MAX( value, ABS( ab( i, j ) ) ) END DO END DO END IF ELSE value = zero IF( lsame( uplo, 'U' ) ) THEN DO j = 1, n DO i = MAX( k+2-j, 1 ), k + 1 value = MAX( value, ABS( ab( i, j ) ) ) END DO END DO ELSE DO j = 1, n DO i = 1, MIN( n+1-j, k+1 ) value = MAX( value, ABS( ab( i, j ) ) ) END DO END DO END IF END IF ELSE IF( ( lsame( norm, 'O' ) ) .OR. ( norm == '1' ) ) THEN ! ! Find norm1(A). ! value = zero udiag = lsame( diag, 'U' ) IF( lsame( uplo, 'U' ) ) THEN DO j = 1, n IF( udiag ) THEN sum = one DO i = MAX( k+2-j, 1 ), k sum = sum + ABS( ab( i, j ) ) END DO ELSE sum = zero DO i = MAX( k+2-j, 1 ), k + 1 sum = sum + ABS( ab( i, j ) ) END DO END IF value = MAX( value, sum ) END DO ELSE DO j = 1, n IF( udiag ) THEN sum = one DO i = 2, MIN( n+1-j, k+1 ) sum = sum + ABS( ab( i, j ) ) END DO ELSE sum = zero DO i = 1, MIN( n+1-j, k+1 ) sum = sum + ABS( ab( i, j ) ) END DO END IF value = MAX( value, sum ) END DO END IF ELSE IF( lsame( norm, 'I' ) ) THEN ! ! Find normI(A). ! value = zero IF( lsame( uplo, 'U' ) ) THEN IF( lsame( diag, 'U' ) ) THEN DO i = 1, n work( i ) = one END DO DO j = 1, n l = k + 1 - j DO i = MAX( 1, j-k ), j - 1 work( i ) = work( i ) + ABS( ab( l+i, j ) ) END DO END DO ELSE DO i = 1, n work( i ) = zero END DO DO j = 1, n l = k + 1 - j DO i = MAX( 1, j-k ), j work( i ) = work( i ) + ABS( ab( l+i, j ) ) END DO END DO END IF ELSE IF( lsame( diag, 'U' ) ) THEN DO i = 1, n work( i ) = one END DO DO j = 1, n l = 1 - j DO i = j + 1, MIN( n, j+k ) work( i ) = work( i ) + ABS( ab( l+i, j ) ) END DO END DO ELSE DO i = 1, n work( i ) = zero END DO DO j = 1, n l = 1 - j DO i = j, MIN( n, j+k ) work( i ) = work( i ) + ABS( ab( l+i, j ) ) END DO END DO END IF END IF DO i = 1, n value = MAX( value, work( i ) ) END DO ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN ! ! Find normF(A). ! IF( lsame( uplo, 'U' ) ) THEN IF( lsame( diag, 'U' ) ) THEN scale = one sum = n IF( k > 0 ) THEN DO j = 2, n CALL slassq( MIN( j-1, k ), ab( MAX( k+2-j, 1 ), j ), 1, scale, & sum ) END DO END IF ELSE scale = zero sum = one DO j = 1, n CALL slassq( MIN( j, k+1 ), ab( MAX( k+2-j, 1 ), j ), 1, scale, sum ) END DO END IF ELSE IF( lsame( diag, 'U' ) ) THEN scale = one sum = n IF( k > 0 ) THEN DO j = 1, n - 1 CALL slassq( MIN( n-j, k ), ab( 2, j ), 1, scale, sum ) END DO END IF ELSE scale = zero sum = one DO j = 1, n CALL slassq( MIN( n-j+1, k+1 ), ab( 1, j ), 1, scale, sum ) END DO END IF END IF value = scale*SQRT( sum ) END IF ! slantb = value RETURN ! ! End of SLANTB ! END FUNCTION slantb REAL FUNCTION slantp( norm, uplo, diag, 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 (LEN=1), INTENT(IN OUT) :: norm CHARACTER (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: diag INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: ap( * ) REAL, INTENT(OUT) :: work( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLANTP returns the value of the one norm, or the Frobenius norm, or ! the infinity norm, or the element of largest absolute value of a ! triangular matrix A, supplied in packed form. ! ! Description ! =========== ! ! SLANTP returns the value ! ! SLANTP = ( 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 SLANTP as described ! above. ! ! 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. When N = 0, SLANTP is ! set to zero. ! ! AP (input) REAL array, dimension (N*(N+1)/2) ! The upper or lower triangular 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 when DIAG = 'U', the elements of the array AP ! corresponding to the diagonal elements of the matrix A are ! not referenced, but are assumed to be one. ! ! WORK (workspace) REAL array, dimension (LWORK), ! where LWORK >= N when NORM = 'I'; otherwise, WORK is not ! referenced. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: udiag INTEGER :: i, j, k REAL :: scale, sum, value ! .. ! .. External Subroutines .. EXTERNAL slassq ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT ! .. ! .. Executable Statements .. ! IF( n == 0 ) THEN value = zero ELSE IF( lsame( norm, 'M' ) ) THEN ! ! Find max(abs(A(i,j))). ! k = 1 IF( lsame( diag, 'U' ) ) THEN value = one IF( lsame( uplo, 'U' ) ) THEN DO j = 1, n DO i = k, k + j - 2 value = MAX( value, ABS( ap( i ) ) ) END DO k = k + j END DO ELSE DO j = 1, n DO i = k + 1, k + n - j value = MAX( value, ABS( ap( i ) ) ) END DO k = k + n - j + 1 END DO END IF ELSE value = zero IF( lsame( uplo, 'U' ) ) THEN DO j = 1, n DO i = k, k + j - 1 value = MAX( value, ABS( ap( i ) ) ) END DO k = k + j END DO ELSE DO j = 1, n DO i = k, k + n - j value = MAX( value, ABS( ap( i ) ) ) END DO k = k + n - j + 1 END DO END IF END IF ELSE IF( ( lsame( norm, 'O' ) ) .OR. ( norm == '1' ) ) THEN ! ! Find norm1(A). ! value = zero k = 1 udiag = lsame( diag, 'U' ) IF( lsame( uplo, 'U' ) ) THEN DO j = 1, n IF( udiag ) THEN sum = one DO i = k, k + j - 2 sum = sum + ABS( ap( i ) ) END DO ELSE sum = zero DO i = k, k + j - 1 sum = sum + ABS( ap( i ) ) END DO END IF k = k + j value = MAX( value, sum ) END DO ELSE DO j = 1, n IF( udiag ) THEN sum = one DO i = k + 1, k + n - j sum = sum + ABS( ap( i ) ) END DO ELSE sum = zero DO i = k, k + n - j sum = sum + ABS( ap( i ) ) END DO END IF k = k + n - j + 1 value = MAX( value, sum ) END DO END IF ELSE IF( lsame( norm, 'I' ) ) THEN ! ! Find normI(A). ! k = 1 IF( lsame( uplo, 'U' ) ) THEN IF( lsame( diag, 'U' ) ) THEN DO i = 1, n work( i ) = one END DO DO j = 1, n DO i = 1, j - 1 work( i ) = work( i ) + ABS( ap( k ) ) k = k + 1 END DO k = k + 1 END DO ELSE DO i = 1, n work( i ) = zero END DO DO j = 1, n DO i = 1, j work( i ) = work( i ) + ABS( ap( k ) ) k = k + 1 END DO END DO END IF ELSE IF( lsame( diag, 'U' ) ) THEN DO i = 1, n work( i ) = one END DO DO j = 1, n k = k + 1 DO i = j + 1, n work( i ) = work( i ) + ABS( ap( k ) ) k = k + 1 END DO END DO ELSE DO i = 1, n work( i ) = zero END DO DO j = 1, n DO i = j, n work( i ) = work( i ) + ABS( ap( k ) ) k = k + 1 END DO END DO END IF END IF value = zero DO i = 1, n value = MAX( value, work( i ) ) END DO ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN ! ! Find normF(A). ! IF( lsame( uplo, 'U' ) ) THEN IF( lsame( diag, 'U' ) ) THEN scale = one sum = n k = 2 DO j = 2, n CALL slassq( j-1, ap( k ), 1, scale, sum ) k = k + j END DO ELSE scale = zero sum = one k = 1 DO j = 1, n CALL slassq( j, ap( k ), 1, scale, sum ) k = k + j END DO END IF ELSE IF( lsame( diag, 'U' ) ) THEN scale = one sum = n k = 2 DO j = 1, n - 1 CALL slassq( n-j, ap( k ), 1, scale, sum ) k = k + n - j + 1 END DO ELSE scale = zero sum = one k = 1 DO j = 1, n CALL slassq( n-j+1, ap( k ), 1, scale, sum ) k = k + n - j + 1 END DO END IF END IF value = scale*SQRT( sum ) END IF ! slantp = value RETURN ! ! End of SLANTP ! END FUNCTION slantp REAL FUNCTION slantr( norm, uplo, diag, 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 (LEN=1), INTENT(IN OUT) :: norm CHARACTER (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: diag INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: work( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLANTR returns the value of the one norm, or the Frobenius norm, or ! the infinity norm, or the element of largest absolute value of a ! trapezoidal or triangular matrix A. ! ! Description ! =========== ! ! SLANTR returns the value ! ! SLANTR = ( 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 SLANTR as described ! above. ! ! UPLO (input) CHARACTER*1 ! Specifies whether the matrix A is upper or lower trapezoidal. ! = 'U': Upper trapezoidal ! = 'L': Lower trapezoidal ! Note that A is triangular instead of trapezoidal if M = N. ! ! DIAG (input) CHARACTER*1 ! Specifies whether or not the matrix A has unit diagonal. ! = 'N': Non-unit diagonal ! = 'U': Unit diagonal ! ! M (input) INTEGER ! The number of rows of the matrix A. M >= 0, and if ! UPLO = 'U', M <= N. When M = 0, SLANTR is set to zero. ! ! N (input) INTEGER ! The number of columns of the matrix A. N >= 0, and if ! UPLO = 'L', N <= M. When N = 0, SLANTR is set to zero. ! ! A (input) REAL array, dimension (LDA,N) ! The trapezoidal matrix A (A is triangular if M = N). ! If UPLO = 'U', the leading m by n upper trapezoidal part of ! the array A contains the upper trapezoidal matrix, and the ! strictly lower triangular part of A is not referenced. ! If UPLO = 'L', the leading m by n lower trapezoidal part of ! the array A contains the lower trapezoidal matrix, and the ! strictly upper triangular part of A is not referenced. Note ! that when DIAG = 'U', the diagonal elements of A are not ! referenced and are assumed to be one. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(M,1). ! ! WORK (workspace) REAL array, dimension (LWORK), ! where LWORK >= M when NORM = 'I'; otherwise, WORK is not ! referenced. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: udiag INTEGER :: i, j REAL :: scale, sum, value ! .. ! .. External Subroutines .. EXTERNAL slassq ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! IF( MIN( m, n ) == 0 ) THEN value = zero ELSE IF( lsame( norm, 'M' ) ) THEN ! ! Find max(abs(A(i,j))). ! IF( lsame( diag, 'U' ) ) THEN value = one IF( lsame( uplo, 'U' ) ) THEN DO j = 1, n DO i = 1, MIN( m, j-1 ) value = MAX( value, ABS( a( i, j ) ) ) END DO END DO ELSE DO j = 1, n DO i = j + 1, m value = MAX( value, ABS( a( i, j ) ) ) END DO END DO END IF ELSE value = zero IF( lsame( uplo, 'U' ) ) THEN DO j = 1, n DO i = 1, MIN( m, j ) value = MAX( value, ABS( a( i, j ) ) ) END DO END DO ELSE DO j = 1, n DO i = j, m value = MAX( value, ABS( a( i, j ) ) ) END DO END DO END IF END IF ELSE IF( ( lsame( norm, 'O' ) ) .OR. ( norm == '1' ) ) THEN ! ! Find norm1(A). ! value = zero udiag = lsame( diag, 'U' ) IF( lsame( uplo, 'U' ) ) THEN DO j = 1, n IF( ( udiag ) .AND. ( j <= m ) ) THEN sum = one DO i = 1, j - 1 sum = sum + ABS( a( i, j ) ) END DO ELSE sum = zero DO i = 1, MIN( m, j ) sum = sum + ABS( a( i, j ) ) END DO END IF value = MAX( value, sum ) END DO ELSE DO j = 1, n IF( udiag ) THEN sum = one DO i = j + 1, m sum = sum + ABS( a( i, j ) ) END DO ELSE sum = zero DO i = j, m sum = sum + ABS( a( i, j ) ) END DO END IF value = MAX( value, sum ) END DO END IF ELSE IF( lsame( norm, 'I' ) ) THEN ! ! Find normI(A). ! IF( lsame( uplo, 'U' ) ) THEN IF( lsame( diag, 'U' ) ) THEN DO i = 1, m work( i ) = one END DO DO j = 1, n DO i = 1, MIN( m, j-1 ) work( i ) = work( i ) + ABS( a( i, j ) ) END DO END DO ELSE DO i = 1, m work( i ) = zero END DO DO j = 1, n DO i = 1, MIN( m, j ) work( i ) = work( i ) + ABS( a( i, j ) ) END DO END DO END IF ELSE IF( lsame( diag, 'U' ) ) THEN DO i = 1, n work( i ) = one END DO DO i = n + 1, m work( i ) = zero END DO DO j = 1, n DO i = j + 1, m work( i ) = work( i ) + ABS( a( i, j ) ) END DO END DO ELSE DO i = 1, m work( i ) = zero END DO DO j = 1, n DO i = j, m work( i ) = work( i ) + ABS( a( i, j ) ) END DO END DO END IF END IF value = zero DO i = 1, m value = MAX( value, work( i ) ) END DO ELSE IF( ( lsame( norm, 'F' ) ) .OR. ( lsame( norm, 'E' ) ) ) THEN ! ! Find normF(A). ! IF( lsame( uplo, 'U' ) ) THEN IF( lsame( diag, 'U' ) ) THEN scale = one sum = MIN( m, n ) DO j = 2, n CALL slassq( MIN( m, j-1 ), a( 1, j ), 1, scale, sum ) END DO ELSE scale = zero sum = one DO j = 1, n CALL slassq( MIN( m, j ), a( 1, j ), 1, scale, sum ) END DO END IF ELSE IF( lsame( diag, 'U' ) ) THEN scale = one sum = MIN( m, n ) DO j = 1, n CALL slassq( m-j, a( MIN( m, j+1 ), j ), 1, scale, sum ) END DO ELSE scale = zero sum = one DO j = 1, n CALL slassq( m-j+1, a( j, j ), 1, scale, sum ) END DO END IF END IF value = scale*SQRT( sum ) END IF ! slantr = value RETURN ! ! End of SLANTR ! END FUNCTION slantr SUBROUTINE slanv2( a, b, c, d, rt1r, rt1i, rt2r, rt2i, cs, sn ) ! ! -- 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 .. REAL, INTENT(IN OUT) :: a REAL, INTENT(IN OUT) :: b REAL, INTENT(IN OUT) :: c REAL, INTENT(IN OUT) :: d REAL, INTENT(OUT) :: rt1r REAL, INTENT(OUT) :: rt1i REAL, INTENT(OUT) :: rt2r REAL, INTENT(OUT) :: rt2i REAL, INTENT(OUT) :: cs REAL, INTENT(OUT) :: sn ! .. ! ! Purpose ! ======= ! ! SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric ! matrix in standard form: ! ! [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ] ! [ C D ] [ SN CS ] [ CC DD ] [-SN CS ] ! ! where either ! 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or ! 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex ! conjugate eigenvalues. ! ! Arguments ! ========= ! ! A (input/output) REAL ! B (input/output) REAL ! C (input/output) REAL ! D (input/output) REAL ! On entry, the elements of the input matrix. ! On exit, they are overwritten by the elements of the ! standardised Schur form. ! ! RT1R (output) REAL ! RT1I (output) REAL ! RT2R (output) REAL ! RT2I (output) REAL ! The real and imaginary parts of the eigenvalues. If the ! eigenvalues are a complex conjugate pair, RT1I > 0. ! ! CS (output) REAL ! SN (output) REAL ! Parameters of the rotation matrix. ! ! Further Details ! =============== ! ! Modified by V. Sima, Research Institute for Informatics, Bucharest, ! Romania, to reduce the risk of cancellation errors, ! when computing real eigenvalues, and to ensure, if possible, that ! abs(RT1R) >= abs(RT2R). ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: half = 0.5E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: multpl = 4.0E+0 ! .. ! .. Local Scalars .. REAL :: aa, bb, bcmax, bcmis, cc, cs1, dd, eps, p, sab, & sac, scale, sigma, sn1, tau, temp, z ! .. ! .. External Functions .. REAL :: slamch, slapy2 EXTERNAL slamch, slapy2 ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SIGN, SQRT ! .. ! .. Executable Statements .. ! eps = slamch( 'P' ) IF( c == zero ) THEN cs = one sn = zero GO TO 10 ! ELSE IF( b == zero ) THEN ! ! Swap rows and columns ! cs = zero sn = one temp = d d = a a = temp b = -c c = zero GO TO 10 ELSE IF( (a-d) == zero .AND. SIGN( one, b ) /= & SIGN( one, c ) ) THEN cs = one sn = zero GO TO 10 ELSE ! temp = a - d p = half*temp bcmax = MAX( ABS( b ), ABS( c ) ) bcmis = MIN( ABS( b ), ABS( c ) )*SIGN( one, b )*SIGN( one, c ) scale = MAX( ABS( p ), bcmax ) z = ( p / scale )*p + ( bcmax / scale )*bcmis ! ! If Z is of the order of the machine accuracy, postpone the ! decision on the nature of eigenvalues ! IF( z >= multpl*eps ) THEN ! ! Real eigenvalues. Compute A and D. ! z = p + SIGN( SQRT( scale )*SQRT( z ), p ) a = d + z d = d - ( bcmax / z )*bcmis ! ! Compute B and the rotation matrix ! tau = slapy2( c, z ) cs = z / tau sn = c / tau b = b - c c = zero ELSE ! ! Complex eigenvalues, or real (almost) equal eigenvalues. ! Make diagonal elements equal. ! sigma = b + c tau = slapy2( sigma, temp ) cs = SQRT( half*( one+ABS( sigma ) / tau ) ) sn = -( p / ( tau*cs ) )*SIGN( one, sigma ) ! ! Compute [ AA BB ] = [ A B ] [ CS -SN ] ! [ CC DD ] [ C D ] [ SN CS ] ! aa = a*cs + b*sn bb = -a*sn + b*cs cc = c*cs + d*sn dd = -c*sn + d*cs ! ! Compute [ A B ] = [ CS SN ] [ AA BB ] ! [ C D ] [-SN CS ] [ CC DD ] ! a = aa*cs + cc*sn b = bb*cs + dd*sn c = -aa*sn + cc*cs d = -bb*sn + dd*cs ! temp = half*( a+d ) a = temp d = temp ! IF( c /= zero ) THEN IF( b /= zero ) THEN IF( SIGN( one, b ) == SIGN( one, c ) ) THEN ! ! Real eigenvalues: reduce to upper triangular form ! sab = SQRT( ABS( b ) ) sac = SQRT( ABS( c ) ) p = SIGN( sab*sac, c ) tau = one / SQRT( ABS( b+c ) ) a = temp + p d = temp - p b = b - c c = zero cs1 = sab*tau sn1 = sac*tau temp = cs*cs1 - sn*sn1 sn = cs*sn1 + sn*cs1 cs = temp END IF ELSE b = -c c = zero temp = cs cs = -sn sn = temp END IF END IF END IF ! END IF ! 10 CONTINUE ! ! Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I). ! rt1r = a rt2r = d IF( c == zero ) THEN rt1i = zero rt2i = zero ELSE rt1i = SQRT( ABS( b ) )*SQRT( ABS( c ) ) rt2i = -rt1i END IF RETURN ! ! End of SLANV2 ! END SUBROUTINE slanv2 SUBROUTINE slapll( n, x, incx, y, incy, ssmin ) ! ! -- LAPACK auxiliary 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, INTENT(IN) :: n REAL, INTENT(IN OUT) :: x( * ) INTEGER, INTENT(IN) :: incx REAL, INTENT(IN) :: y( * ) INTEGER, INTENT(IN) :: incy REAL, INTENT(OUT) :: ssmin ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! Given two column vectors X and Y, let ! ! A = ( X Y ). ! ! The subroutine first computes the QR factorization of A = Q*R, ! and then computes the SVD of the 2-by-2 upper triangular matrix R. ! The smaller singular value of R is returned in SSMIN, which is used ! as the measurement of the linear dependency of the vectors X and Y. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The length of the vectors X and Y. ! ! X (input/output) REAL array, ! dimension (1+(N-1)*INCX) ! On entry, X contains the N-vector X. ! On exit, X is overwritten. ! ! INCX (input) INTEGER ! The increment between successive elements of X. INCX > 0. ! ! Y (input/output) REAL array, ! dimension (1+(N-1)*INCY) ! On entry, Y contains the N-vector Y. ! On exit, Y is overwritten. ! ! INCY (input) INTEGER ! The increment between successive elements of Y. INCY > 0. ! ! SSMIN (output) REAL ! The smallest singular value of the N-by-2 matrix A = ( X Y ). ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. REAL :: a11, a12, a22, c, ssmax, tau ! .. ! .. External Functions .. REAL :: sdot EXTERNAL sdot ! .. ! .. External Subroutines .. EXTERNAL saxpy, slarfg, slas2 ! .. ! .. Executable Statements .. ! ! Quick return if possible ! IF( n <= 1 ) THEN ssmin = zero RETURN END IF ! ! Compute the QR factorization of the N-by-2 matrix ( X Y ) ! CALL slarfg( n, x( 1 ), x( 1+incx ), incx, tau ) a11 = x( 1 ) x( 1 ) = one ! c = -tau*sdot( n, x, incx, y, incy ) CALL saxpy( n, c, x, incx, y, incy ) ! CALL slarfg( n-1, y( 1+incy ), y( 1+2*incy ), incy, tau ) ! a12 = y( 1 ) a22 = y( 1+incy ) ! ! Compute the SVD of 2-by-2 Upper triangular matrix. ! CALL slas2( a11, a12, a22, ssmin, ssmax ) ! RETURN ! ! End of SLAPLL ! END SUBROUTINE slapll SUBROUTINE slapmt( forwrd, m, n, x, ldx, k ) ! ! -- LAPACK auxiliary 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 .. LOGICAL, INTENT(IN) :: forwrd INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx INTEGER, INTENT(OUT) :: k( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAPMT rearranges the columns of the M by N matrix X as specified ! by the permutation K(1),K(2),...,K(N) of the integers 1,...,N. ! If FORWRD = .TRUE., forward permutation: ! ! X(*,K(J)) is moved X(*,J) for J = 1,2,...,N. ! ! If FORWRD = .FALSE., backward permutation: ! ! X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N. ! ! Arguments ! ========= ! ! FORWRD (input) LOGICAL ! = .TRUE., forward permutation ! = .FALSE., backward permutation ! ! M (input) INTEGER ! The number of rows of the matrix X. M >= 0. ! ! N (input) INTEGER ! The number of columns of the matrix X. N >= 0. ! ! X (input/output) REAL array, dimension (LDX,N) ! On entry, the M by N matrix X. ! On exit, X contains the permuted matrix X. ! ! LDX (input) INTEGER ! The leading dimension of the array X, LDX >= MAX(1,M). ! ! K (input) INTEGER array, dimension (N) ! On entry, K contains the permutation vector. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER :: i, ii, j, in REAL :: temp ! .. ! .. Executable Statements .. ! IF( n <= 1 ) RETURN ! DO i = 1, n k( i ) = -k( i ) END DO ! IF( forwrd ) THEN ! ! Forward permutation ! DO i = 1, n ! IF( k( i ) > 0 ) GO TO 40 ! j = i k( j ) = -k( j ) in = k( j ) ! 20 CONTINUE IF( k( in ) > 0 ) GO TO 40 ! DO ii = 1, m temp = x( ii, j ) x( ii, j ) = x( ii, in ) x( ii, in ) = temp END DO ! k( in ) = -k( in ) j = in in = k( in ) GO TO 20 ! 40 CONTINUE ! END DO ! ELSE ! ! Backward permutation ! DO i = 1, n ! IF( k( i ) > 0 ) GO TO 100 ! k( i ) = -k( i ) j = k( i ) 80 CONTINUE IF( j == i ) GO TO 100 ! DO ii = 1, m temp = x( ii, i ) x( ii, i ) = x( ii, j ) x( ii, j ) = temp END DO ! k( j ) = -k( j ) j = k( j ) GO TO 80 ! 100 CONTINUE END DO ! END IF ! RETURN ! ! End of SLAPMT ! END SUBROUTINE slapmt REAL FUNCTION slapy2( 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 .. REAL, INTENT(IN) :: x REAL, INTENT(IN) :: y ! .. ! ! Purpose ! ======= ! ! SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary ! overflow. ! ! Arguments ! ========= ! ! X (input) REAL ! Y (input) REAL ! X and Y specify the values x and y. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. REAL :: 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 == zero ) THEN slapy2 = w ELSE slapy2 = w*SQRT( one+( z / w )**2 ) END IF RETURN ! ! End of SLAPY2 ! END FUNCTION slapy2 REAL FUNCTION slapy3( 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 .. REAL, INTENT(IN) :: x REAL, INTENT(IN) :: y REAL, INTENT(IN) :: z ! .. ! ! Purpose ! ======= ! ! SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause ! unnecessary overflow. ! ! Arguments ! ========= ! ! X (input) REAL ! Y (input) REAL ! Z (input) REAL ! X, Y and Z specify the values x, y and z. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 ! .. ! .. Local Scalars .. REAL :: 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 == zero ) THEN slapy3 = zero ELSE slapy3 = w*SQRT( ( xabs / w )**2+( yabs / w )**2+ ( zabs / w )**2 ) END IF RETURN ! ! End of SLAPY3 ! END FUNCTION slapy3 SUBROUTINE slaqgb( m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, equed ) ! ! -- 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 .. INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: kl INTEGER, INTENT(IN OUT) :: ku REAL, INTENT(OUT) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(IN) :: r( * ) REAL, INTENT(IN) :: c( * ) REAL, INTENT(IN) :: rowcnd REAL, INTENT(IN) :: colcnd REAL, INTENT(IN) :: amax CHARACTER (LEN=1), INTENT(OUT) :: equed ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAQGB equilibrates a general M by N band matrix A with KL ! subdiagonals and KU superdiagonals using the row and scaling factors ! in the vectors R and C. ! ! 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. ! ! KL (input) INTEGER ! The number of subdiagonals within the band of A. KL >= 0. ! ! KU (input) INTEGER ! The number of superdiagonals within the band of A. KU >= 0. ! ! AB (input/output) REAL array, dimension (LDAB,N) ! On entry, the matrix A in band storage, in rows 1 to KL+KU+1. ! The j-th column of A is stored in the j-th column of the ! array AB as follows: ! AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) ! ! On exit, the equilibrated matrix, in the same storage format ! as A. See EQUED for the form of the equilibrated matrix. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDA >= KL+KU+1. ! ! R (output) REAL array, dimension (M) ! The row scale factors for A. ! ! C (output) REAL array, dimension (N) ! The column scale factors for A. ! ! ROWCND (output) REAL ! Ratio of the smallest R(i) to the largest R(i). ! ! COLCND (output) REAL ! Ratio of the smallest C(i) to the largest C(i). ! ! AMAX (input) REAL ! Absolute value of largest matrix entry. ! ! EQUED (output) CHARACTER*1 ! Specifies the form of equilibration that was done. ! = 'N': No equilibration ! = 'R': Row equilibration, i.e., A has been premultiplied by ! diag(R). ! = 'C': Column equilibration, i.e., A has been postmultiplied ! by diag(C). ! = 'B': Both row and column equilibration, i.e., A has been ! replaced by diag(R) * A * diag(C). ! ! Internal Parameters ! =================== ! ! THRESH is a threshold value used to decide if row or column scaling ! should be done based on the ratio of the row or column scaling ! factors. If ROWCND < THRESH, row scaling is done, and if ! COLCND < THRESH, column scaling is done. ! ! LARGE and SMALL are threshold values used to decide if row scaling ! should be done based on the absolute size of the largest matrix ! element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: thresh = 0.1E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j REAL :: cj, large, small ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Quick return if possible ! IF( m <= 0 .OR. n <= 0 ) THEN equed = 'N' RETURN END IF ! ! Initialize LARGE and SMALL. ! small = slamch( 'Safe minimum' ) / slamch( 'Precision' ) large = one / small ! IF( rowcnd >= thresh .AND. amax >= small .AND. amax <= large ) THEN ! ! No row scaling ! IF( colcnd >= thresh ) THEN ! ! No column scaling ! equed = 'N' ELSE ! ! Column scaling ! DO j = 1, n cj = c( j ) DO i = MAX( 1, j-ku ), MIN( m, j+kl ) ab( ku+1+i-j, j ) = cj*ab( ku+1+i-j, j ) END DO END DO equed = 'C' END IF ELSE IF( colcnd >= thresh ) THEN ! ! Row scaling, no column scaling ! DO j = 1, n DO i = MAX( 1, j-ku ), MIN( m, j+kl ) ab( ku+1+i-j, j ) = r( i )*ab( ku+1+i-j, j ) END DO END DO equed = 'R' ELSE ! ! Row and column scaling ! DO j = 1, n cj = c( j ) DO i = MAX( 1, j-ku ), MIN( m, j+kl ) ab( ku+1+i-j, j ) = cj*r( i )*ab( ku+1+i-j, j ) END DO END DO equed = 'B' END IF ! RETURN ! ! End of SLAQGB ! END SUBROUTINE slaqgb SUBROUTINE slaqge( m, n, a, lda, r, c, rowcnd, colcnd, amax, equed ) ! ! -- 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 .. INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: r( * ) REAL, INTENT(IN) :: c( * ) REAL, INTENT(IN) :: rowcnd REAL, INTENT(IN) :: colcnd REAL, INTENT(IN) :: amax CHARACTER (LEN=1), INTENT(OUT) :: equed ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAQGE equilibrates a general M by N matrix A using the row and ! scaling factors in the vectors R and C. ! ! 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) REAL array, dimension (LDA,N) ! On entry, the M by N matrix A. ! On exit, the equilibrated matrix. See EQUED for the form of ! the equilibrated matrix. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(M,1). ! ! R (input) REAL array, dimension (M) ! The row scale factors for A. ! ! C (input) REAL array, dimension (N) ! The column scale factors for A. ! ! ROWCND (input) REAL ! Ratio of the smallest R(i) to the largest R(i). ! ! COLCND (input) REAL ! Ratio of the smallest C(i) to the largest C(i). ! ! AMAX (input) REAL ! Absolute value of largest matrix entry. ! ! EQUED (output) CHARACTER*1 ! Specifies the form of equilibration that was done. ! = 'N': No equilibration ! = 'R': Row equilibration, i.e., A has been premultiplied by ! diag(R). ! = 'C': Column equilibration, i.e., A has been postmultiplied ! by diag(C). ! = 'B': Both row and column equilibration, i.e., A has been ! replaced by diag(R) * A * diag(C). ! ! Internal Parameters ! =================== ! ! THRESH is a threshold value used to decide if row or column scaling ! should be done based on the ratio of the row or column scaling ! factors. If ROWCND < THRESH, row scaling is done, and if ! COLCND < THRESH, column scaling is done. ! ! LARGE and SMALL are threshold values used to decide if row scaling ! should be done based on the absolute size of the largest matrix ! element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: thresh = 0.1E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j REAL :: cj, large, small ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. Executable Statements .. ! ! Quick return if possible ! IF( m <= 0 .OR. n <= 0 ) THEN equed = 'N' RETURN END IF ! ! Initialize LARGE and SMALL. ! small = slamch( 'Safe minimum' ) / slamch( 'Precision' ) large = one / small ! IF( rowcnd >= thresh .AND. amax >= small .AND. amax <= large ) THEN ! ! No row scaling ! IF( colcnd >= thresh ) THEN ! ! No column scaling ! equed = 'N' ELSE ! ! Column scaling ! DO j = 1, n cj = c( j ) DO i = 1, m a( i, j ) = cj*a( i, j ) END DO END DO equed = 'C' END IF ELSE IF( colcnd >= thresh ) THEN ! ! Row scaling, no column scaling ! DO j = 1, n DO i = 1, m a( i, j ) = r( i )*a( i, j ) END DO END DO equed = 'R' ELSE ! ! Row and column scaling ! DO j = 1, n cj = c( j ) DO i = 1, m a( i, j ) = cj*r( i )*a( i, j ) END DO END DO equed = 'B' END IF ! RETURN ! ! End of SLAQGE ! END SUBROUTINE slaqge SUBROUTINE slaqp2( m, n, offset, a, lda, jpvt, tau, vn1, vn2, work ) ! ! -- 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: offset REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(IN OUT) :: jpvt( * ) REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: vn1( * ) REAL, INTENT(OUT) :: vn2( * ) REAL, INTENT(IN OUT) :: work( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAQP2 computes a QR factorization with column pivoting of ! the block A(OFFSET+1:M,1:N). ! The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. ! ! 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. ! ! OFFSET (input) INTEGER ! The number of rows of the matrix A that must be pivoted ! but no factorized. OFFSET >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the M-by-N matrix A. ! On exit, the upper triangle of block A(OFFSET+1:M,1:N) is ! the triangular factor obtained; the elements in block ! A(OFFSET+1:M,1:N) below the diagonal, together with the ! array TAU, represent the orthogonal matrix Q as a product of ! elementary reflectors. Block A(1:OFFSET,1:N) has been ! accordingly pivoted, but no factorized. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! JPVT (input/output) INTEGER array, dimension (N) ! On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted ! to the front of A*P (a leading column); if JPVT(i) = 0, ! the i-th column of A is a free column. ! On exit, if JPVT(i) = k, then the i-th column of A*P ! was the k-th column of A. ! ! TAU (output) REAL array, dimension (min(M,N)) ! The scalar factors of the elementary reflectors. ! ! VN1 (input/output) REAL array, dimension (N) ! The vector with the partial column norms. ! ! VN2 (input/output) REAL array, dimension (N) ! The vector with the exact column norms. ! ! WORK (workspace) REAL array, dimension (N) ! ! Further Details ! =============== ! ! Based on contributions by ! G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain ! X. Sun, Computer Science Dept., Duke University, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, itemp, j, mn, offpi, pvt REAL :: aii, temp, temp2 ! .. ! .. External Subroutines .. EXTERNAL slarf, slarfg, sswap ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT ! .. ! .. External Functions .. INTEGER :: isamax REAL :: snrm2 EXTERNAL isamax, snrm2 ! .. ! .. Executable Statements .. ! mn = MIN( m-offset, n ) ! ! Compute factorization. ! DO i = 1, mn ! offpi = offset + i ! ! Determine ith pivot column and swap if necessary. ! pvt = ( i-1 ) + isamax( n-i+1, vn1( i ), 1 ) ! IF( pvt /= i ) THEN CALL sswap( m, a( 1, pvt ), 1, a( 1, i ), 1 ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( i ) jpvt( i ) = itemp vn1( pvt ) = vn1( i ) vn2( pvt ) = vn2( i ) END IF ! ! Generate elementary reflector H(i). ! IF( offpi < m ) THEN CALL slarfg( m-offpi+1, a( offpi, i ), a( offpi+1, i ), 1, tau( i ) ) ELSE CALL slarfg( 1, a( m, i ), a( m, i ), 1, tau( i ) ) END IF ! IF( i < n ) THEN ! ! Apply H(i)' to A(offset+i:m,i+1:n) from the left. ! aii = a( offpi, i ) a( offpi, i ) = one CALL slarf( 'Left', m-offpi+1, n-i, a( offpi, i ), 1, & tau( i ), a( offpi, i+1 ), lda, work( 1 ) ) a( offpi, i ) = aii END IF ! ! Update partial column norms. ! DO j = i + 1, n IF( vn1( j ) /= zero ) THEN temp = one - ( ABS( a( offpi, j ) ) / vn1( j ) )**2 temp = MAX( temp, zero ) temp2 = one + 0.05*temp*( vn1( j ) / vn2( j ) )**2 IF( temp2 == one ) THEN IF( offpi < m ) THEN vn1( j ) = snrm2( m-offpi, a( offpi+1, j ), 1 ) vn2( j ) = vn1( j ) ELSE vn1( j ) = zero vn2( j ) = zero END IF ELSE vn1( j ) = vn1( j )*SQRT( temp ) END IF END IF END DO ! END DO ! RETURN ! ! End of SLAQP2 ! END SUBROUTINE slaqp2 SUBROUTINE slaqps( m, n, offset, nb, kb, a, lda, jpvt, tau, vn1, & vn2, auxv, f, ldf ) ! ! -- 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: offset INTEGER, INTENT(IN) :: nb INTEGER, INTENT(OUT) :: kb REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(IN OUT) :: jpvt( * ) REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: vn1( * ) REAL, INTENT(OUT) :: vn2( * ) REAL, INTENT(IN OUT) :: auxv( * ) REAL, INTENT(OUT) :: f( ldf, * ) INTEGER, INTENT(IN OUT) :: ldf ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAQPS computes a step of QR factorization with column pivoting ! of a real M-by-N matrix A by using Blas-3. It tries to factorize ! NB columns from A starting from the row OFFSET+1, and updates all ! of the matrix with Blas-3 xGEMM. ! ! In some cases, due to catastrophic cancellations, it cannot ! factorize NB columns. Hence, the actual number of factorized ! columns is returned in KB. ! ! Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. ! ! 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 ! ! OFFSET (input) INTEGER ! The number of rows of A that have been factorized in ! previous steps. ! ! NB (input) INTEGER ! The number of columns to factorize. ! ! KB (output) INTEGER ! The number of columns actually factorized. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the M-by-N matrix A. ! On exit, block A(OFFSET+1:M,1:KB) is the triangular ! factor obtained and block A(1:OFFSET,1:N) has been ! accordingly pivoted, but no factorized. ! The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has ! been updated. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! JPVT (input/output) INTEGER array, dimension (N) ! JPVT(I) = K <==> Column K of the full matrix A has been ! permuted into position I in AP. ! ! TAU (output) REAL array, dimension (KB) ! The scalar factors of the elementary reflectors. ! ! VN1 (input/output) REAL array, dimension (N) ! The vector with the partial column norms. ! ! VN2 (input/output) REAL array, dimension (N) ! The vector with the exact column norms. ! ! AUXV (input/output) REAL array, dimension (NB) ! Auxiliar vector. ! ! F (input/output) REAL array, dimension (LDF,NB) ! Matrix F' = L*Y'*A. ! ! LDF (input) INTEGER ! The leading dimension of the array F. LDF >= max(1,N). ! ! Further Details ! =============== ! ! Based on contributions by ! G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain ! X. Sun, Computer Science Dept., Duke University, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: itemp, j, k, lastrk, lsticc, pvt, rk REAL :: akk, temp, temp2 ! .. ! .. External Subroutines .. EXTERNAL sgemm, sgemv, slarfg, sswap ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, nint, REAL, SQRT ! .. ! .. External Functions .. INTEGER :: isamax REAL :: snrm2 EXTERNAL isamax, snrm2 ! .. ! .. Executable Statements .. ! lastrk = MIN( m, n+offset ) lsticc = 0 k = 0 ! ! Beginning of while loop. ! 10 CONTINUE IF( ( k < nb ) .AND. ( lsticc == 0 ) ) THEN k = k + 1 rk = offset + k ! ! Determine ith pivot column and swap if necessary ! pvt = ( k-1 ) + isamax( n-k+1, vn1( k ), 1 ) IF( pvt /= k ) THEN CALL sswap( m, a( 1, pvt ), 1, a( 1, k ), 1 ) CALL sswap( k-1, f( pvt, 1 ), ldf, f( k, 1 ), ldf ) itemp = jpvt( pvt ) jpvt( pvt ) = jpvt( k ) jpvt( k ) = itemp vn1( pvt ) = vn1( k ) vn2( pvt ) = vn2( k ) END IF ! ! Apply previous Householder reflectors to column K: ! A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'. ! IF( k > 1 ) THEN CALL sgemv( 'No transpose', m-rk+1, k-1, -one, a( rk, 1 ), & lda, f( k, 1 ), ldf, one, a( rk, k ), 1 ) END IF ! ! Generate elementary reflector H(k). ! IF( rk < m ) THEN CALL slarfg( m-rk+1, a( rk, k ), a( rk+1, k ), 1, tau( k ) ) ELSE CALL slarfg( 1, a( rk, k ), a( rk, k ), 1, tau( k ) ) END IF ! akk = a( rk, k ) a( rk, k ) = one ! ! Compute Kth column of F: ! ! Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K). ! IF( k < n ) THEN CALL sgemv( 'Transpose', m-rk+1, n-k, tau( k ), & a( rk, k+1 ), lda, a( rk, k ), 1, zero, f( k+1, k ), 1 ) END IF ! ! Padding F(1:K,K) with zeros. ! DO j = 1, k f( j, k ) = zero END DO ! ! Incremental updating of F: ! F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)' ! *A(RK:M,K). ! IF( k > 1 ) THEN CALL sgemv( 'Transpose', m-rk+1, k-1, -tau( k ), a( rk, 1 ), & lda, a( rk, k ), 1, zero, auxv( 1 ), 1 ) ! CALL sgemv( 'No transpose', n, k-1, one, f( 1, 1 ), ldf, & auxv( 1 ), 1, one, f( 1, k ), 1 ) END IF ! ! Update the current row of A: ! A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'. ! IF( k < n ) THEN CALL sgemv( 'No transpose', n-k, k, -one, f( k+1, 1 ), ldf, & a( rk, 1 ), lda, one, a( rk, k+1 ), lda ) END IF ! ! Update partial column norms. ! IF( rk < lastrk ) THEN DO j = k + 1, n IF( vn1( j ) /= zero ) THEN temp = ABS( a( rk, j ) ) / vn1( j ) temp = MAX( zero, ( one+temp )*( one-temp ) ) temp2 = one + 0.05*temp*( vn1( j ) / vn2( j ) )**2 IF( temp2 == one ) THEN vn2( j ) = REAL( lsticc ) lsticc = j ELSE vn1( j ) = vn1( j )*SQRT( temp ) END IF END IF END DO END IF ! a( rk, k ) = akk ! ! End of while loop. ! GO TO 10 END IF kb = k rk = offset + kb ! ! Apply the block reflector to the rest of the matrix: ! A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - ! A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'. ! IF( kb < MIN( n, m-offset ) ) THEN CALL sgemm( 'No transpose', 'Transpose', m-rk, n-kb, kb, -one, & a( rk+1, 1 ), lda, f( kb+1, 1 ), ldf, one, a( rk+1, kb+1 ), lda ) END IF ! ! Recomputation of difficult columns. ! 40 CONTINUE IF( lsticc > 0 ) THEN itemp = nint( vn2( lsticc ) ) vn1( lsticc ) = snrm2( m-rk, a( rk+1, lsticc ), 1 ) vn2( lsticc ) = vn1( lsticc ) lsticc = itemp GO TO 40 END IF ! RETURN ! ! End of SLAQPS ! END SUBROUTINE slaqps SUBROUTINE slaqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) ! ! -- 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: kd REAL, INTENT(OUT) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(IN) :: s( * ) REAL, INTENT(IN) :: scond REAL, INTENT(IN) :: amax CHARACTER (LEN=1), INTENT(OUT) :: equed ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAQSB equilibrates a symmetric band matrix A using the scaling ! factors in the vector S. ! ! 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. ! ! KD (input) INTEGER ! The number of super-diagonals of the matrix A if UPLO = 'U', ! or the number of sub-diagonals if UPLO = 'L'. KD >= 0. ! ! AB (input/output) REAL array, dimension (LDAB,N) ! On entry, the upper or lower triangle of the symmetric band ! matrix A, stored in the first KD+1 rows of the array. The ! j-th column of A is stored in the j-th column of the array AB ! as follows: ! if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). ! ! On exit, if INFO = 0, the triangular factor U or L from the ! Cholesky factorization A = U'*U or A = L*L' of the band ! matrix A, in the same storage format as A. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KD+1. ! ! S (output) REAL array, dimension (N) ! The scale factors for A. ! ! SCOND (input) REAL ! Ratio of the smallest S(i) to the largest S(i). ! ! AMAX (input) REAL ! Absolute value of largest matrix entry. ! ! EQUED (output) CHARACTER*1 ! Specifies whether or not equilibration was done. ! = 'N': No equilibration. ! = 'Y': Equilibration was done, i.e., A has been replaced by ! diag(S) * A * diag(S). ! ! Internal Parameters ! =================== ! ! THRESH is a threshold value used to decide if scaling should be done ! based on the ratio of the scaling factors. If SCOND < THRESH, ! scaling is done. ! ! LARGE and SMALL are threshold values used to decide if scaling should ! be done based on the absolute size of the largest matrix element. ! If AMAX > LARGE or AMAX < SMALL, scaling is done. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: thresh = 0.1E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j REAL :: cj, large, small ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Quick return if possible ! IF( n <= 0 ) THEN equed = 'N' RETURN END IF ! ! Initialize LARGE and SMALL. ! small = slamch( 'Safe minimum' ) / slamch( 'Precision' ) large = one / small ! IF( scond >= thresh .AND. amax >= small .AND. amax <= large ) THEN ! ! No equilibration ! equed = 'N' ELSE ! ! Replace A by diag(S) * A * diag(S). ! IF( lsame( uplo, 'U' ) ) THEN ! ! Upper triangle of A is stored in band format. ! DO j = 1, n cj = s( j ) DO i = MAX( 1, j-kd ), j ab( kd+1+i-j, j ) = cj*s( i )*ab( kd+1+i-j, j ) END DO END DO ELSE ! ! Lower triangle of A is stored. ! DO j = 1, n cj = s( j ) DO i = j, MIN( n, j+kd ) ab( 1+i-j, j ) = cj*s( i )*ab( 1+i-j, j ) END DO END DO END IF equed = 'Y' END IF ! RETURN ! ! End of SLAQSB ! END SUBROUTINE slaqsb SUBROUTINE slaqsp( uplo, n, ap, s, scond, amax, equed ) ! ! -- 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(OUT) :: ap( * ) REAL, INTENT(IN) :: s( * ) REAL, INTENT(IN) :: scond REAL, INTENT(IN) :: amax CHARACTER (LEN=1), INTENT(OUT) :: equed ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAQSP equilibrates a symmetric matrix A using the scaling factors ! in the vector S. ! ! 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. ! ! AP (input/output) REAL 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 equilibrated matrix: diag(S) * A * diag(S), in ! the same storage format as A. ! ! S (input) REAL array, dimension (N) ! The scale factors for A. ! ! SCOND (input) REAL ! Ratio of the smallest S(i) to the largest S(i). ! ! AMAX (input) REAL ! Absolute value of largest matrix entry. ! ! EQUED (output) CHARACTER*1 ! Specifies whether or not equilibration was done. ! = 'N': No equilibration. ! = 'Y': Equilibration was done, i.e., A has been replaced by ! diag(S) * A * diag(S). ! ! Internal Parameters ! =================== ! ! THRESH is a threshold value used to decide if scaling should be done ! based on the ratio of the scaling factors. If SCOND < THRESH, ! scaling is done. ! ! LARGE and SMALL are threshold values used to decide if scaling should ! be done based on the absolute size of the largest matrix element. ! If AMAX > LARGE or AMAX < SMALL, scaling is done. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: thresh = 0.1E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j, jc REAL :: cj, large, small ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. Executable Statements .. ! ! Quick return if possible ! IF( n <= 0 ) THEN equed = 'N' RETURN END IF ! ! Initialize LARGE and SMALL. ! small = slamch( 'Safe minimum' ) / slamch( 'Precision' ) large = one / small ! IF( scond >= thresh .AND. amax >= small .AND. amax <= large ) THEN ! ! No equilibration ! equed = 'N' ELSE ! ! Replace A by diag(S) * A * diag(S). ! IF( lsame( uplo, 'U' ) ) THEN ! ! Upper triangle of A is stored. ! jc = 1 DO j = 1, n cj = s( j ) DO i = 1, j ap( jc+i-1 ) = cj*s( i )*ap( jc+i-1 ) END DO jc = jc + j END DO ELSE ! ! Lower triangle of A is stored. ! jc = 1 DO j = 1, n cj = s( j ) DO i = j, n ap( jc+i-j ) = cj*s( i )*ap( jc+i-j ) END DO jc = jc + n - j + 1 END DO END IF equed = 'Y' END IF ! RETURN ! ! End of SLAQSP ! END SUBROUTINE slaqsp SUBROUTINE slaqsy( uplo, n, a, lda, s, scond, amax, equed ) ! ! -- 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: s( * ) REAL, INTENT(IN) :: scond REAL, INTENT(IN) :: amax CHARACTER (LEN=1), INTENT(OUT) :: equed ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAQSY equilibrates a symmetric matrix A using the scaling factors ! in the vector S. ! ! 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) REAL 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 EQUED = 'Y', the equilibrated matrix: ! diag(S) * A * diag(S). ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(N,1). ! ! S (input) REAL array, dimension (N) ! The scale factors for A. ! ! SCOND (input) REAL ! Ratio of the smallest S(i) to the largest S(i). ! ! AMAX (input) REAL ! Absolute value of largest matrix entry. ! ! EQUED (output) CHARACTER*1 ! Specifies whether or not equilibration was done. ! = 'N': No equilibration. ! = 'Y': Equilibration was done, i.e., A has been replaced by ! diag(S) * A * diag(S). ! ! Internal Parameters ! =================== ! ! THRESH is a threshold value used to decide if scaling should be done ! based on the ratio of the scaling factors. If SCOND < THRESH, ! scaling is done. ! ! LARGE and SMALL are threshold values used to decide if scaling should ! be done based on the absolute size of the largest matrix element. ! If AMAX > LARGE or AMAX < SMALL, scaling is done. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: thresh = 0.1E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j REAL :: cj, large, small ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. Executable Statements .. ! ! Quick return if possible ! IF( n <= 0 ) THEN equed = 'N' RETURN END IF ! ! Initialize LARGE and SMALL. ! small = slamch( 'Safe minimum' ) / slamch( 'Precision' ) large = one / small ! IF( scond >= thresh .AND. amax >= small .AND. amax <= large ) THEN ! ! No equilibration ! equed = 'N' ELSE ! ! Replace A by diag(S) * A * diag(S). ! IF( lsame( uplo, 'U' ) ) THEN ! ! Upper triangle of A is stored. ! DO j = 1, n cj = s( j ) DO i = 1, j a( i, j ) = cj*s( i )*a( i, j ) END DO END DO ELSE ! ! Lower triangle of A is stored. ! DO j = 1, n cj = s( j ) DO i = j, n a( i, j ) = cj*s( i )*a( i, j ) END DO END DO END IF equed = 'Y' END IF ! RETURN ! ! End of SLAQSY ! END SUBROUTINE slaqsy SUBROUTINE slaqtr( ltran, lreal, n, t, ldt, b, w, scale, x, work, 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 .. LOGICAL, INTENT(IN OUT) :: ltran LOGICAL, INTENT(IN) :: lreal INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN) :: t( ldt, * ) INTEGER, INTENT(IN) :: ldt REAL, INTENT(IN) :: b( * ) REAL, INTENT(IN) :: w REAL, INTENT(OUT) :: scale REAL, INTENT(IN OUT) :: x( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAQTR solves the real quasi-triangular system ! ! op(T)*p = scale*c, if LREAL = .TRUE. ! ! or the complex quasi-triangular systems ! ! op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE. ! ! in real arithmetic, where T is upper quasi-triangular. ! If LREAL = .FALSE., then the first diagonal block of T must be ! 1 by 1, B is the specially structured matrix ! ! B = [ b(1) b(2) ... b(n) ] ! [ w ] ! [ w ] ! [ . ] ! [ w ] ! ! op(A) = A or A', A' denotes the conjugate transpose of ! matrix A. ! ! On input, X = [ c ]. On output, X = [ p ]. ! [ d ] [ q ] ! ! This subroutine is designed for the condition number estimation ! in routine STRSNA. ! ! Arguments ! ========= ! ! LTRAN (input) LOGICAL ! On entry, LTRAN specifies the option of conjugate transpose: ! = .FALSE., op(T+i*B) = T+i*B, ! = .TRUE., op(T+i*B) = (T+i*B)'. ! ! LREAL (input) LOGICAL ! On entry, LREAL specifies the input matrix structure: ! = .FALSE., the input is complex ! = .TRUE., the input is real ! ! N (input) INTEGER ! On entry, N specifies the order of T+i*B. N >= 0. ! ! T (input) REAL array, dimension (LDT,N) ! On entry, T contains a matrix in Schur canonical form. ! If LREAL = .FALSE., then the first diagonal block of T must ! be 1 by 1. ! ! LDT (input) INTEGER ! The leading dimension of the matrix T. LDT >= max(1,N). ! ! B (input) REAL array, dimension (N) ! On entry, B contains the elements to form the matrix ! B as described above. ! If LREAL = .TRUE., B is not referenced. ! ! W (input) REAL ! On entry, W is the diagonal element of the matrix B. ! If LREAL = .TRUE., W is not referenced. ! ! SCALE (output) REAL ! On exit, SCALE is the scale factor. ! ! X (input/output) REAL array, dimension (2*N) ! On entry, X contains the right hand side of the system. ! On exit, X is overwritten by the solution. ! ! WORK (workspace) REAL array, dimension (N) ! ! INFO (output) INTEGER ! On exit, INFO is set to ! 0: successful exit. ! 1: the some diagonal 1 by 1 block has been perturbed by ! a small number SMIN to keep nonsingularity. ! 2: the some diagonal 2 by 2 block has been perturbed by ! a small number in SLALN2 to keep nonsingularity. ! NOTE: In the interests of speed, this routine does not ! check the inputs for errors. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: notran INTEGER :: i, ierr, j, j1, j2, jnext, k, n1, n2 REAL :: bignum, eps, REC, scaloc, si, smin, sminw, & smlnum, sr, tjj, tmp, xj, xmax, xnorm, z ! .. ! .. Local Arrays .. REAL :: d( 2, 2 ), v( 2, 2 ) ! .. ! .. External Functions .. INTEGER :: isamax REAL :: sasum, sdot, slamch, slange EXTERNAL isamax, sasum, sdot, slamch, slange ! .. ! .. External Subroutines .. EXTERNAL saxpy, sladiv, slaln2, sscal ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. Executable Statements .. ! ! Do not test the input parameters for errors ! notran = .NOT.ltran info = 0 ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Set constants to control overflow ! eps = slamch( 'P' ) smlnum = slamch( 'S' ) / eps bignum = one / smlnum ! xnorm = slange( 'M', n, n, t, ldt, d ) IF( .NOT.lreal ) xnorm = MAX( xnorm, ABS( w ), slange( 'M', n, 1, b, n, d ) ) smin = MAX( smlnum, eps*xnorm ) ! ! Compute 1-norm of each column of strictly upper triangular ! part of T to control overflow in triangular solver. ! work( 1 ) = zero DO j = 2, n work( j ) = sasum( j-1, t( 1, j ), 1 ) END DO ! IF( .NOT.lreal ) THEN DO i = 2, n work( i ) = work( i ) + ABS( b( i ) ) END DO END IF ! n2 = 2*n n1 = n IF( .NOT.lreal ) n1 = n2 k = isamax( n1, x, 1 ) xmax = ABS( x( k ) ) scale = one ! IF( xmax > bignum ) THEN scale = bignum / xmax CALL sscal( n1, scale, x, 1 ) xmax = bignum END IF ! IF( lreal ) THEN ! IF( notran ) THEN ! ! Solve T*p = scale*c ! jnext = n DO j = n, 1, -1 IF( j > jnext ) CYCLE j1 = j j2 = j jnext = j - 1 IF( j > 1 ) THEN IF( t( j, j-1 ) /= zero ) THEN j1 = j - 1 jnext = j - 2 END IF END IF ! IF( j1 == j2 ) THEN ! ! Meet 1 by 1 diagonal block ! ! Scale to avoid overflow when computing ! x(j) = b(j)/T(j,j) ! xj = ABS( x( j1 ) ) tjj = ABS( t( j1, j1 ) ) tmp = t( j1, j1 ) IF( tjj < smin ) THEN tmp = smin tjj = smin info = 1 END IF ! IF( xj == zero ) CYCLE ! IF( tjj < one ) THEN IF( xj > bignum*tjj ) THEN REC = one / xj CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF END IF x( j1 ) = x( j1 ) / tmp xj = ABS( x( j1 ) ) ! ! Scale x if necessary to avoid overflow when adding a ! multiple of column j1 of T. ! IF( xj > one ) THEN REC = one / xj IF( work( j1 ) > ( bignum-xmax )*REC ) THEN CALL sscal( n, REC, x, 1 ) scale = scale*REC END IF END IF IF( j1 > 1 ) THEN CALL saxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) k = isamax( j1-1, x, 1 ) xmax = ABS( x( k ) ) END IF ! ELSE ! ! Meet 2 by 2 diagonal block ! ! Call 2 by 2 linear system solve, to take ! care of possible overflow by scaling factor. ! d( 1, 1 ) = x( j1 ) d( 2, 1 ) = x( j2 ) CALL slaln2( .false., 2, 1, smin, one, t( j1, j1 ), & ldt, one, one, d, 2, zero, zero, v, 2, scaloc, xnorm, ierr ) IF( ierr /= 0 ) info = 2 ! IF( scaloc /= one ) THEN CALL sscal( n, scaloc, x, 1 ) scale = scale*scaloc END IF x( j1 ) = v( 1, 1 ) x( j2 ) = v( 2, 1 ) ! ! Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2)) ! to avoid overflow in updating right-hand side. ! xj = MAX( ABS( v( 1, 1 ) ), ABS( v( 2, 1 ) ) ) IF( xj > one ) THEN REC = one / xj IF( MAX( work( j1 ), work( j2 ) ) > ( bignum-xmax )*REC ) THEN CALL sscal( n, REC, x, 1 ) scale = scale*REC END IF END IF ! ! Update right-hand side ! IF( j1 > 1 ) THEN CALL saxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) CALL saxpy( j1-1, -x( j2 ), t( 1, j2 ), 1, x, 1 ) k = isamax( j1-1, x, 1 ) xmax = ABS( x( k ) ) END IF ! END IF ! END DO ! ELSE ! ! Solve T'*p = scale*c ! jnext = 1 DO j = 1, n IF( j < jnext ) CYCLE j1 = j j2 = j jnext = j + 1 IF( j < n ) THEN IF( t( j+1, j ) /= zero ) THEN j2 = j + 1 jnext = j + 2 END IF END IF ! IF( j1 == j2 ) THEN ! ! 1 by 1 diagonal block ! ! Scale if necessary to avoid overflow in forming the ! right-hand side element by inner product. ! xj = ABS( x( j1 ) ) IF( xmax > one ) THEN REC = one / xmax IF( work( j1 ) > ( bignum-xj )*REC ) THEN CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF END IF ! x( j1 ) = x( j1 ) - sdot( j1-1, t( 1, j1 ), 1, x, 1 ) ! xj = ABS( x( j1 ) ) tjj = ABS( t( j1, j1 ) ) tmp = t( j1, j1 ) IF( tjj < smin ) THEN tmp = smin tjj = smin info = 1 END IF ! IF( tjj < one ) THEN IF( xj > bignum*tjj ) THEN REC = one / xj CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF END IF x( j1 ) = x( j1 ) / tmp xmax = MAX( xmax, ABS( x( j1 ) ) ) ! ELSE ! ! 2 by 2 diagonal block ! ! Scale if necessary to avoid overflow in forming the ! right-hand side elements by inner product. ! xj = MAX( ABS( x( j1 ) ), ABS( x( j2 ) ) ) IF( xmax > one ) THEN REC = one / xmax IF( MAX( work( j2 ), work( j1 ) ) > ( bignum-xj )* REC ) THEN CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF END IF ! d( 1, 1 ) = x( j1 ) - sdot( j1-1, t( 1, j1 ), 1, x, 1 ) d( 2, 1 ) = x( j2 ) - sdot( j1-1, t( 1, j2 ), 1, x, 1 ) ! CALL slaln2( .true., 2, 1, smin, one, t( j1, j1 ), & ldt, one, one, d, 2, zero, zero, v, 2, scaloc, xnorm, ierr ) IF( ierr /= 0 ) info = 2 ! IF( scaloc /= one ) THEN CALL sscal( n, scaloc, x, 1 ) scale = scale*scaloc END IF x( j1 ) = v( 1, 1 ) x( j2 ) = v( 2, 1 ) xmax = MAX( ABS( x( j1 ) ), ABS( x( j2 ) ), xmax ) ! END IF END DO END IF ! ELSE ! sminw = MAX( eps*ABS( w ), smin ) IF( notran ) THEN ! ! Solve (T + iB)*(p+iq) = c+id ! jnext = n DO j = n, 1, -1 IF( j > jnext ) CYCLE j1 = j j2 = j jnext = j - 1 IF( j > 1 ) THEN IF( t( j, j-1 ) /= zero ) THEN j1 = j - 1 jnext = j - 2 END IF END IF ! IF( j1 == j2 ) THEN ! ! 1 by 1 diagonal block ! ! Scale if necessary to avoid overflow in division ! z = w IF( j1 == 1 ) z = b( 1 ) xj = ABS( x( j1 ) ) + ABS( x( n+j1 ) ) tjj = ABS( t( j1, j1 ) ) + ABS( z ) tmp = t( j1, j1 ) IF( tjj < sminw ) THEN tmp = sminw tjj = sminw info = 1 END IF ! IF( xj == zero ) CYCLE ! IF( tjj < one ) THEN IF( xj > bignum*tjj ) THEN REC = one / xj CALL sscal( n2, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF END IF CALL sladiv( x( j1 ), x( n+j1 ), tmp, z, sr, si ) x( j1 ) = sr x( n+j1 ) = si xj = ABS( x( j1 ) ) + ABS( x( n+j1 ) ) ! ! Scale x if necessary to avoid overflow when adding a ! multiple of column j1 of T. ! IF( xj > one ) THEN REC = one / xj IF( work( j1 ) > ( bignum-xmax )*REC ) THEN CALL sscal( n2, REC, x, 1 ) scale = scale*REC END IF END IF ! IF( j1 > 1 ) THEN CALL saxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) CALL saxpy( j1-1, -x( n+j1 ), t( 1, j1 ), 1, x( n+1 ), 1 ) ! x( 1 ) = x( 1 ) + b( j1 )*x( n+j1 ) x( n+1 ) = x( n+1 ) - b( j1 )*x( j1 ) ! xmax = zero DO k = 1, j1 - 1 xmax = MAX( xmax, ABS( x( k ) )+ ABS( x( k+n ) ) ) END DO END IF ! ELSE ! ! Meet 2 by 2 diagonal block ! d( 1, 1 ) = x( j1 ) d( 2, 1 ) = x( j2 ) d( 1, 2 ) = x( n+j1 ) d( 2, 2 ) = x( n+j2 ) CALL slaln2( .false., 2, 2, sminw, one, t( j1, j1 ), & ldt, one, one, d, 2, zero, -w, v, 2, scaloc, xnorm, ierr ) IF( ierr /= 0 ) info = 2 ! IF( scaloc /= one ) THEN CALL sscal( 2*n, scaloc, x, 1 ) scale = scaloc*scale END IF x( j1 ) = v( 1, 1 ) x( j2 ) = v( 2, 1 ) x( n+j1 ) = v( 1, 2 ) x( n+j2 ) = v( 2, 2 ) ! ! Scale X(J1), .... to avoid overflow in ! updating right hand side. ! xj = MAX( ABS( v( 1, 1 ) )+ABS( v( 1, 2 ) ), & ABS( v( 2, 1 ) )+ABS( v( 2, 2 ) ) ) IF( xj > one ) THEN REC = one / xj IF( MAX( work( j1 ), work( j2 ) ) > ( bignum-xmax )*REC ) THEN CALL sscal( n2, REC, x, 1 ) scale = scale*REC END IF END IF ! ! Update the right-hand side. ! IF( j1 > 1 ) THEN CALL saxpy( j1-1, -x( j1 ), t( 1, j1 ), 1, x, 1 ) CALL saxpy( j1-1, -x( j2 ), t( 1, j2 ), 1, x, 1 ) ! CALL saxpy( j1-1, -x( n+j1 ), t( 1, j1 ), 1, x( n+1 ), 1 ) CALL saxpy( j1-1, -x( n+j2 ), t( 1, j2 ), 1, x( n+1 ), 1 ) ! x( 1 ) = x( 1 ) + b( j1 )*x( n+j1 ) + b( j2 )*x( n+j2 ) x( n+1 ) = x( n+1 ) - b( j1 )*x( j1 ) - b( j2 )*x( j2 ) ! xmax = zero DO k = 1, j1 - 1 xmax = MAX( ABS( x( k ) )+ABS( x( k+n ) ), xmax ) END DO END IF ! END IF END DO ! ELSE ! ! Solve (T + iB)'*(p+iq) = c+id ! jnext = 1 DO j = 1, n IF( j < jnext ) CYCLE j1 = j j2 = j jnext = j + 1 IF( j < n ) THEN IF( t( j+1, j ) /= zero ) THEN j2 = j + 1 jnext = j + 2 END IF END IF ! IF( j1 == j2 ) THEN ! ! 1 by 1 diagonal block ! ! Scale if necessary to avoid overflow in forming the ! right-hand side element by inner product. ! xj = ABS( x( j1 ) ) + ABS( x( j1+n ) ) IF( xmax > one ) THEN REC = one / xmax IF( work( j1 ) > ( bignum-xj )*REC ) THEN CALL sscal( n2, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF END IF ! x( j1 ) = x( j1 ) - sdot( j1-1, t( 1, j1 ), 1, x, 1 ) x( n+j1 ) = x( n+j1 ) - sdot( j1-1, t( 1, j1 ), 1, x( n+1 ), 1 ) IF( j1 > 1 ) THEN x( j1 ) = x( j1 ) - b( j1 )*x( n+1 ) x( n+j1 ) = x( n+j1 ) + b( j1 )*x( 1 ) END IF xj = ABS( x( j1 ) ) + ABS( x( j1+n ) ) ! z = w IF( j1 == 1 ) z = b( 1 ) ! ! Scale if necessary to avoid overflow in ! complex division ! tjj = ABS( t( j1, j1 ) ) + ABS( z ) tmp = t( j1, j1 ) IF( tjj < sminw ) THEN tmp = sminw tjj = sminw info = 1 END IF ! IF( tjj < one ) THEN IF( xj > bignum*tjj ) THEN REC = one / xj CALL sscal( n2, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF END IF CALL sladiv( x( j1 ), x( n+j1 ), tmp, -z, sr, si ) x( j1 ) = sr x( j1+n ) = si xmax = MAX( ABS( x( j1 ) )+ABS( x( j1+n ) ), xmax ) ! ELSE ! ! 2 by 2 diagonal block ! ! Scale if necessary to avoid overflow in forming the ! right-hand side element by inner product. ! xj = MAX( ABS( x( j1 ) )+ABS( x( n+j1 ) ), & ABS( x( j2 ) )+ABS( x( n+j2 ) ) ) IF( xmax > one ) THEN REC = one / xmax IF( MAX( work( j1 ), work( j2 ) ) > ( bignum-xj ) / xmax ) THEN CALL sscal( n2, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF END IF ! d( 1, 1 ) = x( j1 ) - sdot( j1-1, t( 1, j1 ), 1, x, 1 ) d( 2, 1 ) = x( j2 ) - sdot( j1-1, t( 1, j2 ), 1, x, 1 ) d( 1, 2 ) = x( n+j1 ) - sdot( j1-1, t( 1, j1 ), 1, x( n+1 ), 1 ) d( 2, 2 ) = x( n+j2 ) - sdot( j1-1, t( 1, j2 ), 1, x( n+1 ), 1 ) d( 1, 1 ) = d( 1, 1 ) - b( j1 )*x( n+1 ) d( 2, 1 ) = d( 2, 1 ) - b( j2 )*x( n+1 ) d( 1, 2 ) = d( 1, 2 ) + b( j1 )*x( 1 ) d( 2, 2 ) = d( 2, 2 ) + b( j2 )*x( 1 ) ! CALL slaln2( .true., 2, 2, sminw, one, t( j1, j1 ), & ldt, one, one, d, 2, zero, w, v, 2, scaloc, xnorm, ierr ) IF( ierr /= 0 ) info = 2 ! IF( scaloc /= one ) THEN CALL sscal( n2, scaloc, x, 1 ) scale = scaloc*scale END IF x( j1 ) = v( 1, 1 ) x( j2 ) = v( 2, 1 ) x( n+j1 ) = v( 1, 2 ) x( n+j2 ) = v( 2, 2 ) xmax = MAX( ABS( x( j1 ) )+ABS( x( n+j1 ) ), & ABS( x( j2 ) )+ABS( x( n+j2 ) ), xmax ) ! END IF ! END DO ! END IF ! END IF ! RETURN ! ! End of SLAQTR ! END SUBROUTINE slaqtr SUBROUTINE slar1v( n, b1, bn, sigma, d, l, ld, lld, gersch, z, & ztz, mingma, r, isuppz, work ) ! ! -- 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, INTENT(IN) :: n INTEGER, INTENT(IN) :: b1 INTEGER, INTENT(IN OUT) :: bn REAL, INTENT(IN) :: sigma REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: l( * ) REAL, INTENT(IN) :: ld( * ) REAL, INTENT(IN) :: lld( * ) REAL, INTENT(IN) :: gersch( * ) REAL, INTENT(OUT) :: z( * ) REAL, INTENT(OUT) :: ztz REAL, INTENT(OUT) :: mingma INTEGER, INTENT(IN OUT) :: r INTEGER, INTENT(OUT) :: isuppz( * ) REAL, INTENT(OUT) :: work( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAR1V computes the (scaled) r-th column of the inverse of ! the sumbmatrix in rows B1 through BN of the tridiagonal matrix ! L D L^T - sigma I. The following steps accomplish this computation : ! (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T, ! (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T, ! (c) Computation of the diagonal elements of the inverse of ! L D L^T - sigma I by combining the above transforms, and choosing ! r as the index where the diagonal of the inverse is (one of the) ! largest in magnitude. ! (d) Computation of the (scaled) r-th column of the inverse using the ! twisted factorization obtained by combining the top part of the ! the stationary and the bottom part of the progressive transform. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The order of the matrix L D L^T. ! ! B1 (input) INTEGER ! First index of the submatrix of L D L^T. ! ! BN (input) INTEGER ! Last index of the submatrix of L D L^T. ! ! SIGMA (input) REAL ! The shift. Initially, when R = 0, SIGMA should be a good ! approximation to an eigenvalue of L D L^T. ! ! L (input) REAL array, dimension (N-1) ! The (n-1) subdiagonal elements of the unit bidiagonal matrix ! L, in elements 1 to N-1. ! ! D (input) REAL array, dimension (N) ! The n diagonal elements of the diagonal matrix D. ! ! LD (input) REAL array, dimension (N-1) ! The n-1 elements L(i)*D(i). ! ! LLD (input) REAL array, dimension (N-1) ! The n-1 elements L(i)*L(i)*D(i). ! ! GERSCH (input) REAL array, dimension (2*N) ! The n Gerschgorin intervals. These are used to restrict ! the initial search for R, when R is input as 0. ! ! Z (output) REAL array, dimension (N) ! The (scaled) r-th column of the inverse. Z(R) is returned ! to be 1. ! ! ZTZ (output) REAL ! The square of the norm of Z. ! ! MINGMA (output) REAL ! The reciprocal of the largest (in magnitude) diagonal ! element of the inverse of L D L^T - sigma I. ! ! R (input/output) INTEGER ! Initially, R should be input to be 0 and is then output as ! the index where the diagonal element of the inverse is ! largest in magnitude. In later iterations, this same value ! of R should be input. ! ! ISUPPZ (output) INTEGER array, dimension (2) ! The support of the vector in Z, i.e., the vector Z is ! nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ). ! ! WORK (workspace) REAL array, dimension (4*N) ! ! Further Details ! =============== ! ! Based on contributions by ! Inderjit Dhillon, IBM Almaden, USA ! Osni Marques, LBNL/NERSC, USA ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: blksiz = 32 REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: sawnan INTEGER :: from, i, indp, inds, indumn, j, r1, r2, TO REAL :: dminus, dplus, eps, s, tmp ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. Executable Statements .. ! eps = slamch( 'Precision' ) IF( r == 0 ) THEN ! ! Eliminate the top and bottom indices from the possible values ! of R where the desired eigenvector is largest in magnitude. ! r1 = b1 DO i = b1, bn IF( sigma >= gersch( 2*i-1 ) .OR. sigma <= gersch( 2*i ) ) THEN r1 = i EXIT END IF END DO 20 CONTINUE r2 = bn DO i = bn, b1, -1 IF( sigma >= gersch( 2*i-1 ) .OR. sigma <= gersch( 2*i ) ) THEN r2 = i EXIT END IF END DO 40 CONTINUE ELSE r1 = r r2 = r END IF ! indumn = n inds = 2*n + 1 indp = 3*n + 1 sawnan = .false. ! ! Compute the stationary transform (using the differential form) ! untill the index R2 ! IF( b1 == 1 ) THEN work( inds ) = zero ELSE work( inds ) = lld( b1-1 ) END IF s = work( inds ) - sigma DO i = b1, r2 - 1 dplus = d( i ) + s work( i ) = ld( i ) / dplus work( inds+i ) = s*work( i )*l( i ) s = work( inds+i ) - sigma END DO ! IF( .NOT.( s > zero .OR. s < one ) ) THEN ! ! Run a slower version of the above loop if a NaN is detected ! sawnan = .true. j = b1 + 1 60 CONTINUE IF( work( inds+j ) > zero .OR. work( inds+j ) < one ) THEN j = j + 1 GO TO 60 END IF work( inds+j ) = lld( j ) s = work( inds+j ) - sigma DO i = j + 1, r2 - 1 dplus = d( i ) + s work( i ) = ld( i ) / dplus IF( work( i ) == zero ) THEN work( inds+i ) = lld( i ) ELSE work( inds+i ) = s*work( i )*l( i ) END IF s = work( inds+i ) - sigma END DO END IF work( indp+bn-1 ) = d( bn ) - sigma DO i = bn - 1, r1, -1 dminus = lld( i ) + work( indp+i ) tmp = d( i ) / dminus work( indumn+i ) = l( i )*tmp work( indp+i-1 ) = work( indp+i )*tmp - sigma END DO tmp = work( indp+r1-1 ) IF( .NOT.( tmp > zero .OR. tmp < one ) ) THEN ! ! Run a slower version of the above loop if a NaN is detected ! sawnan = .true. j = bn - 3 90 CONTINUE IF( work( indp+j ) > zero .OR. work( indp+j ) < one ) THEN j = j - 1 GO TO 90 END IF work( indp+j ) = d( j+1 ) - sigma DO i = j, r1, -1 dminus = lld( i ) + work( indp+i ) tmp = d( i ) / dminus work( indumn+i ) = l( i )*tmp IF( tmp == zero ) THEN work( indp+i-1 ) = d( i ) - sigma ELSE work( indp+i-1 ) = work( indp+i )*tmp - sigma END IF END DO END IF ! ! Find the index (from R1 to R2) of the largest (in magnitude) ! diagonal element of the inverse ! mingma = work( inds+r1-1 ) + work( indp+r1-1 ) IF( mingma == zero ) mingma = eps*work( inds+r1-1 ) r = r1 DO i = r1, r2 - 1 tmp = work( inds+i ) + work( indp+i ) IF( tmp == zero ) tmp = eps*work( inds+i ) IF( ABS( tmp ) < ABS( mingma ) ) THEN mingma = tmp r = i + 1 END IF END DO ! ! Compute the (scaled) r-th column of the inverse ! isuppz( 1 ) = b1 isuppz( 2 ) = bn z( r ) = one ztz = one IF( .NOT.sawnan ) THEN from = r - 1 TO = MAX( r-blksiz, b1 ) 120 CONTINUE IF( from >= b1 ) THEN DO i = from, TO, -1 z( i ) = -( work( i )*z( i+1 ) ) ztz = ztz + z( i )*z( i ) END DO IF( ABS( z( TO ) ) <= eps .AND. ABS( z( TO+1 ) ) <= eps ) THEN isuppz( 1 ) = TO + 2 ELSE from = TO - 1 TO = MAX( TO-blksiz, b1 ) GO TO 120 END IF END IF from = r + 1 TO = MIN( r+blksiz, bn ) 140 CONTINUE IF( from <= bn ) THEN DO i = from, TO z( i ) = -( work( indumn+i-1 )*z( i-1 ) ) ztz = ztz + z( i )*z( i ) END DO IF( ABS( z( TO ) ) <= eps .AND. ABS( z( TO-1 ) ) <= eps ) THEN isuppz( 2 ) = TO - 2 ELSE from = TO + 1 TO = MIN( TO+blksiz, bn ) GO TO 140 END IF END IF ELSE DO i = r - 1, b1, -1 IF( z( i+1 ) == zero ) THEN z( i ) = -( ld( i+1 ) / ld( i ) )*z( i+2 ) ELSE IF( ABS( z( i+1 ) ) <= eps .AND. ABS( z( i+2 ) ) <= & eps ) THEN isuppz( 1 ) = i + 3 EXIT ELSE z( i ) = -( work( i )*z( i+1 ) ) END IF ztz = ztz + z( i )*z( i ) END DO 170 CONTINUE DO i = r, bn - 1 IF( z( i ) == zero ) THEN z( i+1 ) = -( ld( i-1 ) / ld( i ) )*z( i-1 ) ELSE IF( ABS( z( i ) ) <= eps .AND. ABS( z( i-1 ) ) <= eps ) & THEN isuppz( 2 ) = i - 2 EXIT ELSE z( i+1 ) = -( work( indumn+i )*z( i ) ) END IF ztz = ztz + z( i+1 )*z( i+1 ) END DO 190 CONTINUE END IF DO i = b1, isuppz( 1 ) - 3 z( i ) = zero END DO DO i = isuppz( 2 ) + 3, bn z( i ) = zero END DO ! RETURN ! ! End of SLAR1V ! END SUBROUTINE slar1v SUBROUTINE slar2v( n, x, y, z, incx, c, s, incc ) ! ! -- 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 .. INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: x( * ) REAL, INTENT(IN OUT) :: y( * ) REAL, INTENT(IN OUT) :: z( * ) INTEGER, INTENT(IN) :: incx REAL, INTENT(IN) :: c( * ) REAL, INTENT(IN) :: s( * ) INTEGER, INTENT(IN) :: incc ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAR2V applies a vector of real plane rotations from both sides to ! a sequence of 2-by-2 real symmetric matrices, defined by the elements ! of the vectors x, y and z. For i = 1,2,...,n ! ! ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) ) ! ( z(i) y(i) ) ( -s(i) c(i) ) ( z(i) y(i) ) ( s(i) c(i) ) ! ! Arguments ! ========= ! ! N (input) INTEGER ! The number of plane rotations to be applied. ! ! X (input/output) REAL array, ! dimension (1+(N-1)*INCX) ! The vector x. ! ! Y (input/output) REAL array, ! dimension (1+(N-1)*INCX) ! The vector y. ! ! Z (input/output) REAL array, ! dimension (1+(N-1)*INCX) ! The vector z. ! ! INCX (input) INTEGER ! The increment between elements of X, Y and Z. INCX > 0. ! ! C (input) REAL array, dimension (1+(N-1)*INCC) ! The cosines of the plane rotations. ! ! S (input) REAL array, dimension (1+(N-1)*INCC) ! The sines of the plane rotations. ! ! INCC (input) INTEGER ! The increment between elements of C and S. INCC > 0. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER :: i, ic, ix REAL :: ci, si, t1, t2, t3, t4, t5, t6, xi, yi, zi ! .. ! .. Executable Statements .. ! ix = 1 ic = 1 DO i = 1, n xi = x( ix ) yi = y( ix ) zi = z( ix ) ci = c( ic ) si = s( ic ) t1 = si*zi t2 = ci*zi t3 = t2 - si*xi t4 = t2 + si*yi t5 = ci*xi + t1 t6 = ci*yi - t1 x( ix ) = ci*t5 + si*t4 y( ix ) = ci*t6 - si*t3 z( ix ) = ci*t4 - si*t5 ix = ix + incx ic = ic + incc END DO ! ! End of SLAR2V ! RETURN END SUBROUTINE slar2v SUBROUTINE slarf( 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 ! February 29, 1992 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: side INTEGER, INTENT(IN OUT) :: m INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN OUT) :: v( * ) INTEGER, INTENT(IN OUT) :: incv REAL, INTENT(IN) :: tau REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(IN OUT) :: work( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLARF 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) REAL 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) REAL ! The value tau in the representation of H. ! ! C (input/output) REAL 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) REAL array, dimension ! (N) if SIDE = 'L' ! or (M) if SIDE = 'R' ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. External Subroutines .. EXTERNAL sgemv, sger ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Executable Statements .. ! IF( lsame( side, 'L' ) ) THEN ! ! Form H * C ! IF( tau /= zero ) THEN ! ! w := C' * v ! CALL sgemv( 'Transpose', m, n, one, c, ldc, v, incv, zero, work, 1 ) ! ! C := C - v * w' ! CALL sger( m, n, -tau, v, incv, work, 1, c, ldc ) END IF ELSE ! ! Form C * H ! IF( tau /= zero ) THEN ! ! w := C * v ! CALL sgemv( 'No transpose', m, n, one, c, ldc, v, incv, zero, work, 1 ) ! ! C := C - w * v' ! CALL sger( m, n, -tau, work, 1, v, incv, c, ldc ) END IF END IF RETURN ! ! End of SLARF ! END SUBROUTINE slarf SUBROUTINE slarfb( 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 (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: trans CHARACTER (LEN=1), INTENT(IN) :: DIRECT CHARACTER (LEN=1), INTENT(IN) :: storev INTEGER, INTENT(IN OUT) :: m INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN OUT) :: k REAL, INTENT(IN OUT) :: v( ldv, * ) INTEGER, INTENT(IN OUT) :: ldv REAL, INTENT(IN OUT) :: t( ldt, * ) INTEGER, INTENT(IN OUT) :: ldt REAL, INTENT(OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(IN) :: work( ldwork, * ) INTEGER, INTENT(IN OUT) :: ldwork ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLARFB 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) REAL 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) REAL 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) REAL 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) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. CHARACTER (LEN=1) :: transt INTEGER :: i, j ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL scopy, sgemm, strmm ! .. ! .. Executable Statements .. ! ! Quick return if possible ! IF( m <= 0 .OR. n <= 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 j = 1, k CALL scopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) END DO ! ! W := W * V1 ! CALL strmm( 'Right', 'Lower', 'No transpose', 'Unit', n, & k, one, v, ldv, work, ldwork ) IF( m > k ) THEN ! ! W := W + C2'*V2 ! CALL sgemm( 'Transpose', 'No transpose', n, k, m-k, & one, c( k+1, 1 ), ldc, v( k+1, 1 ), ldv, one, work, ldwork ) END IF ! ! W := W * T' or W * T ! CALL strmm( 'Right', 'Upper', transt, 'Non-unit', n, k, & one, t, ldt, work, ldwork ) ! ! C := C - V * W' ! IF( m > k ) THEN ! ! C2 := C2 - V2 * W' ! CALL sgemm( 'No transpose', 'Transpose', m-k, n, k, & -one, v( k+1, 1 ), ldv, work, ldwork, one, c( k+1, 1 ), ldc ) END IF ! ! W := W * V1' ! CALL strmm( 'Right', 'Lower', 'Transpose', 'Unit', n, k, & one, v, ldv, work, ldwork ) ! ! C1 := C1 - W' ! DO j = 1, k DO i = 1, n c( j, i ) = c( j, i ) - work( i, j ) END DO END DO ! 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 j = 1, k CALL scopy( m, c( 1, j ), 1, work( 1, j ), 1 ) END DO ! ! W := W * V1 ! CALL strmm( 'Right', 'Lower', 'No transpose', 'Unit', m, & k, one, v, ldv, work, ldwork ) IF( n > k ) THEN ! ! W := W + C2 * V2 ! CALL sgemm( 'No transpose', 'No transpose', m, k, n-k, & one, c( 1, k+1 ), ldc, v( k+1, 1 ), ldv, one, work, ldwork ) END IF ! ! W := W * T or W * T' ! CALL strmm( 'Right', 'Upper', trans, 'Non-unit', m, k, & one, t, ldt, work, ldwork ) ! ! C := C - W * V' ! IF( n > k ) THEN ! ! C2 := C2 - W * V2' ! CALL sgemm( 'No transpose', 'Transpose', m, n-k, k, & -one, work, ldwork, v( k+1, 1 ), ldv, one, c( 1, k+1 ), ldc ) END IF ! ! W := W * V1' ! CALL strmm( 'Right', 'Lower', 'Transpose', 'Unit', m, k, & one, v, ldv, work, ldwork ) ! ! C1 := C1 - W ! DO j = 1, k DO i = 1, m c( i, j ) = c( i, j ) - work( i, j ) END DO END DO 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 j = 1, k CALL scopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) END DO ! ! W := W * V2 ! CALL strmm( 'Right', 'Upper', 'No transpose', 'Unit', n, & k, one, v( m-k+1, 1 ), ldv, work, ldwork ) IF( m > k ) THEN ! ! W := W + C1'*V1 ! CALL sgemm( 'Transpose', 'No transpose', n, k, m-k, & one, c, ldc, v, ldv, one, work, ldwork ) END IF ! ! W := W * T' or W * T ! CALL strmm( 'Right', 'Lower', transt, 'Non-unit', n, k, & one, t, ldt, work, ldwork ) ! ! C := C - V * W' ! IF( m > k ) THEN ! ! C1 := C1 - V1 * W' ! CALL sgemm( 'No transpose', 'Transpose', m-k, n, k, & -one, v, ldv, work, ldwork, one, c, ldc ) END IF ! ! W := W * V2' ! CALL strmm( 'Right', 'Upper', 'Transpose', 'Unit', n, k, & one, v( m-k+1, 1 ), ldv, work, ldwork ) ! ! C2 := C2 - W' ! DO j = 1, k DO i = 1, n c( m-k+j, i ) = c( m-k+j, i ) - work( i, j ) END DO END DO ! 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 j = 1, k CALL scopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) END DO ! ! W := W * V2 ! CALL strmm( 'Right', 'Upper', 'No transpose', 'Unit', m, & k, one, v( n-k+1, 1 ), ldv, work, ldwork ) IF( n > k ) THEN ! ! W := W + C1 * V1 ! CALL sgemm( 'No transpose', 'No transpose', m, k, n-k, & one, c, ldc, v, ldv, one, work, ldwork ) END IF ! ! W := W * T or W * T' ! CALL strmm( 'Right', 'Lower', trans, 'Non-unit', m, k, & one, t, ldt, work, ldwork ) ! ! C := C - W * V' ! IF( n > k ) THEN ! ! C1 := C1 - W * V1' ! CALL sgemm( 'No transpose', 'Transpose', m, n-k, k, & -one, work, ldwork, v, ldv, one, c, ldc ) END IF ! ! W := W * V2' ! CALL strmm( 'Right', 'Upper', 'Transpose', 'Unit', m, k, & one, v( n-k+1, 1 ), ldv, work, ldwork ) ! ! C2 := C2 - W ! DO j = 1, k DO i = 1, m c( i, n-k+j ) = c( i, n-k+j ) - work( i, j ) END DO END DO 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 j = 1, k CALL scopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) END DO ! ! W := W * V1' ! CALL strmm( 'Right', 'Upper', 'Transpose', 'Unit', n, k, & one, v, ldv, work, ldwork ) IF( m > k ) THEN ! ! W := W + C2'*V2' ! CALL sgemm( 'Transpose', 'Transpose', n, k, m-k, one, & c( k+1, 1 ), ldc, v( 1, k+1 ), ldv, one, work, ldwork ) END IF ! ! W := W * T' or W * T ! CALL strmm( 'Right', 'Upper', transt, 'Non-unit', n, k, & one, t, ldt, work, ldwork ) ! ! C := C - V' * W' ! IF( m > k ) THEN ! ! C2 := C2 - V2' * W' ! CALL sgemm( 'Transpose', 'Transpose', m-k, n, k, -one, & v( 1, k+1 ), ldv, work, ldwork, one, c( k+1, 1 ), ldc ) END IF ! ! W := W * V1 ! CALL strmm( 'Right', 'Upper', 'No transpose', 'Unit', n, & k, one, v, ldv, work, ldwork ) ! ! C1 := C1 - W' ! DO j = 1, k DO i = 1, n c( j, i ) = c( j, i ) - work( i, j ) END DO END DO ! 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 j = 1, k CALL scopy( m, c( 1, j ), 1, work( 1, j ), 1 ) END DO ! ! W := W * V1' ! CALL strmm( 'Right', 'Upper', 'Transpose', 'Unit', m, k, & one, v, ldv, work, ldwork ) IF( n > k ) THEN ! ! W := W + C2 * V2' ! CALL sgemm( 'No transpose', 'Transpose', m, k, n-k, & one, c( 1, k+1 ), ldc, v( 1, k+1 ), ldv, one, work, ldwork ) END IF ! ! W := W * T or W * T' ! CALL strmm( 'Right', 'Upper', trans, 'Non-unit', m, k, & one, t, ldt, work, ldwork ) ! ! C := C - W * V ! IF( n > k ) THEN ! ! C2 := C2 - W * V2 ! CALL sgemm( 'No transpose', 'No transpose', m, n-k, k, & -one, work, ldwork, v( 1, k+1 ), ldv, one, c( 1, k+1 ), ldc ) END IF ! ! W := W * V1 ! CALL strmm( 'Right', 'Upper', 'No transpose', 'Unit', m, & k, one, v, ldv, work, ldwork ) ! ! C1 := C1 - W ! DO j = 1, k DO i = 1, m c( i, j ) = c( i, j ) - work( i, j ) END DO END DO ! 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 j = 1, k CALL scopy( n, c( m-k+j, 1 ), ldc, work( 1, j ), 1 ) END DO ! ! W := W * V2' ! CALL strmm( 'Right', 'Lower', 'Transpose', 'Unit', n, k, & one, v( 1, m-k+1 ), ldv, work, ldwork ) IF( m > k ) THEN ! ! W := W + C1'*V1' ! CALL sgemm( 'Transpose', 'Transpose', n, k, m-k, one, & c, ldc, v, ldv, one, work, ldwork ) END IF ! ! W := W * T' or W * T ! CALL strmm( 'Right', 'Lower', transt, 'Non-unit', n, k, & one, t, ldt, work, ldwork ) ! ! C := C - V' * W' ! IF( m > k ) THEN ! ! C1 := C1 - V1' * W' ! CALL sgemm( 'Transpose', 'Transpose', m-k, n, k, -one, & v, ldv, work, ldwork, one, c, ldc ) END IF ! ! W := W * V2 ! CALL strmm( 'Right', 'Lower', 'No transpose', 'Unit', n, & k, one, v( 1, m-k+1 ), ldv, work, ldwork ) ! ! C2 := C2 - W' ! DO j = 1, k DO i = 1, n c( m-k+j, i ) = c( m-k+j, i ) - work( i, j ) END DO END DO ! 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 j = 1, k CALL scopy( m, c( 1, n-k+j ), 1, work( 1, j ), 1 ) END DO ! ! W := W * V2' ! CALL strmm( 'Right', 'Lower', 'Transpose', 'Unit', m, k, & one, v( 1, n-k+1 ), ldv, work, ldwork ) IF( n > k ) THEN ! ! W := W + C1 * V1' ! CALL sgemm( 'No transpose', 'Transpose', m, k, n-k, & one, c, ldc, v, ldv, one, work, ldwork ) END IF ! ! W := W * T or W * T' ! CALL strmm( 'Right', 'Lower', trans, 'Non-unit', m, k, & one, t, ldt, work, ldwork ) ! ! C := C - W * V ! IF( n > k ) THEN ! ! C1 := C1 - W * V1 ! CALL sgemm( 'No transpose', 'No transpose', m, n-k, k, & -one, work, ldwork, v, ldv, one, c, ldc ) END IF ! ! W := W * V2 ! CALL strmm( 'Right', 'Lower', 'No transpose', 'Unit', m, & k, one, v( 1, n-k+1 ), ldv, work, ldwork ) ! ! C1 := C1 - W ! DO j = 1, k DO i = 1, m c( i, n-k+j ) = c( i, n-k+j ) - work( i, j ) END DO END DO ! END IF ! END IF END IF ! RETURN ! ! End of SLARFB ! END SUBROUTINE slarfb SUBROUTINE slarfg( 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, INTENT(IN) :: n REAL, INTENT(IN OUT) :: alpha REAL, INTENT(IN) :: x( * ) INTEGER, INTENT(IN) :: incx REAL, INTENT(OUT) :: tau ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLARFG 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) REAL ! On entry, the value alpha. ! On exit, it is overwritten with the value beta. ! ! X (input/output) REAL 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) REAL ! The value tau. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: j, knt REAL :: beta, rsafmn, safmin, xnorm ! .. ! .. External Functions .. REAL :: slamch, slapy2, snrm2 EXTERNAL slamch, slapy2, snrm2 ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, SIGN ! .. ! .. External Subroutines .. EXTERNAL sscal ! .. ! .. Executable Statements .. ! IF( n <= 1 ) THEN tau = zero RETURN END IF ! xnorm = snrm2( n-1, x, incx ) ! IF( xnorm == zero ) THEN ! ! H = I ! tau = zero ELSE ! ! general case ! beta = -SIGN( slapy2( alpha, xnorm ), alpha ) safmin = slamch( 'S' ) / slamch( 'E' ) IF( ABS( beta ) < safmin ) THEN ! ! XNORM, BETA may be inaccurate; scale X and recompute them ! rsafmn = one / safmin knt = 0 10 CONTINUE knt = knt + 1 CALL sscal( n-1, rsafmn, x, incx ) beta = beta*rsafmn alpha = alpha*rsafmn IF( ABS( beta ) < safmin ) GO TO 10 ! ! New BETA is at most 1, at least SAFMIN ! xnorm = snrm2( n-1, x, incx ) beta = -SIGN( slapy2( alpha, xnorm ), alpha ) tau = ( beta-alpha ) / beta CALL sscal( n-1, one / ( alpha-beta ), x, incx ) ! ! If ALPHA is subnormal, it may lose relative accuracy ! alpha = beta DO j = 1, knt alpha = alpha*safmin END DO ELSE tau = ( beta-alpha ) / beta CALL sscal( n-1, one / ( alpha-beta ), x, incx ) alpha = beta END IF END IF ! RETURN ! ! End of SLARFG ! END SUBROUTINE slarfg SUBROUTINE slarft( 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 (LEN=1), INTENT(IN) :: DIRECT CHARACTER (LEN=1), INTENT(IN) :: storev INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN OUT) :: k REAL, INTENT(IN OUT) :: v( ldv, * ) INTEGER, INTENT(IN OUT) :: ldv REAL, INTENT(IN) :: tau( * ) REAL, INTENT(OUT) :: t( ldt, * ) INTEGER, INTENT(IN OUT) :: ldt ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLARFT 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) REAL 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i). ! ! T (output) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j REAL :: vii ! .. ! .. External Subroutines .. EXTERNAL sgemv, strmv ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Executable Statements .. ! ! Quick return if possible ! IF( n == 0 ) RETURN ! IF( lsame( DIRECT, 'F' ) ) THEN DO i = 1, k IF( tau( i ) == zero ) THEN ! ! H(i) = I ! DO j = 1, i t( j, i ) = zero END DO 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 sgemv( '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 sgemv( '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 strmv( 'Upper', 'No transpose', 'Non-unit', i-1, t, & ldt, t( 1, i ), 1 ) t( i, i ) = tau( i ) END IF END DO ELSE DO i = k, 1, -1 IF( tau( i ) == zero ) THEN ! ! H(i) = I ! DO j = i, k t( j, i ) = zero END DO ELSE ! ! general case ! IF( i < 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 sgemv( '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 sgemv( '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 strmv( '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 END DO END IF RETURN ! ! End of SLARFT ! END SUBROUTINE slarft SUBROUTINE slarfx( side, m, n, v, 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 ! February 29, 1992 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: side INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: v( * ) REAL, INTENT(IN) :: tau REAL, INTENT(OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(IN OUT) :: work( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLARFX 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 ! ! This version uses inline code if H has order < 11. ! ! 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) REAL array, dimension (M) if SIDE = 'L' ! or (N) if SIDE = 'R' ! The vector v in the representation of H. ! ! TAU (input) REAL ! The value tau in the representation of H. ! ! C (input/output) REAL 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. LDA >= (1,M). ! ! WORK (workspace) REAL array, dimension ! (N) if SIDE = 'L' ! or (M) if SIDE = 'R' ! WORK is not referenced if H has order < 11. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: j REAL :: sum, t1, t10, t2, t3, t4, t5, t6, t7, t8, t9, & v1, v10, v2, v3, v4, v5, v6, v7, v8, v9 ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL sgemv, sger ! .. ! .. Executable Statements .. ! IF( tau == zero ) RETURN IF( lsame( side, 'L' ) ) THEN ! ! Form H * C, where H has order m. ! SELECT CASE ( m ) CASE ( 1) GO TO 10 CASE ( 2) GO TO 30 CASE ( 3) GO TO 50 CASE ( 4) GO TO 70 CASE ( 5) GO TO 90 CASE ( 6) GO TO 110 CASE ( 7) GO TO 130 CASE ( 8) GO TO 150 CASE ( 9) GO TO 170 CASE ( 10) GO TO 190 END SELECT ! ! Code for general M ! ! w := C'*v ! CALL sgemv( 'Transpose', m, n, one, c, ldc, v, 1, zero, work, 1 ) ! ! C := C - tau * v * w' ! CALL sger( m, n, -tau, v, 1, work, 1, c, ldc ) GO TO 410 10 CONTINUE ! ! Special code for 1 x 1 Householder ! t1 = one - tau*v( 1 )*v( 1 ) DO j = 1, n c( 1, j ) = t1*c( 1, j ) END DO GO TO 410 30 CONTINUE ! ! Special code for 2 x 2 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 DO j = 1, n sum = v1*c( 1, j ) + v2*c( 2, j ) c( 1, j ) = c( 1, j ) - sum*t1 c( 2, j ) = c( 2, j ) - sum*t2 END DO GO TO 410 50 CONTINUE ! ! Special code for 3 x 3 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 v3 = v( 3 ) t3 = tau*v3 DO j = 1, n sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) c( 1, j ) = c( 1, j ) - sum*t1 c( 2, j ) = c( 2, j ) - sum*t2 c( 3, j ) = c( 3, j ) - sum*t3 END DO GO TO 410 70 CONTINUE ! ! Special code for 4 x 4 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 v3 = v( 3 ) t3 = tau*v3 v4 = v( 4 ) t4 = tau*v4 DO j = 1, n sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) + v4*c( 4, j ) c( 1, j ) = c( 1, j ) - sum*t1 c( 2, j ) = c( 2, j ) - sum*t2 c( 3, j ) = c( 3, j ) - sum*t3 c( 4, j ) = c( 4, j ) - sum*t4 END DO GO TO 410 90 CONTINUE ! ! Special code for 5 x 5 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 v3 = v( 3 ) t3 = tau*v3 v4 = v( 4 ) t4 = tau*v4 v5 = v( 5 ) t5 = tau*v5 DO j = 1, n sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) + & v4*c( 4, j ) + v5*c( 5, j ) c( 1, j ) = c( 1, j ) - sum*t1 c( 2, j ) = c( 2, j ) - sum*t2 c( 3, j ) = c( 3, j ) - sum*t3 c( 4, j ) = c( 4, j ) - sum*t4 c( 5, j ) = c( 5, j ) - sum*t5 END DO GO TO 410 110 CONTINUE ! ! Special code for 6 x 6 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 v3 = v( 3 ) t3 = tau*v3 v4 = v( 4 ) t4 = tau*v4 v5 = v( 5 ) t5 = tau*v5 v6 = v( 6 ) t6 = tau*v6 DO j = 1, n sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) + & v4*c( 4, j ) + v5*c( 5, j ) + v6*c( 6, j ) c( 1, j ) = c( 1, j ) - sum*t1 c( 2, j ) = c( 2, j ) - sum*t2 c( 3, j ) = c( 3, j ) - sum*t3 c( 4, j ) = c( 4, j ) - sum*t4 c( 5, j ) = c( 5, j ) - sum*t5 c( 6, j ) = c( 6, j ) - sum*t6 END DO GO TO 410 130 CONTINUE ! ! Special code for 7 x 7 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 v3 = v( 3 ) t3 = tau*v3 v4 = v( 4 ) t4 = tau*v4 v5 = v( 5 ) t5 = tau*v5 v6 = v( 6 ) t6 = tau*v6 v7 = v( 7 ) t7 = tau*v7 DO j = 1, n sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) + & v4*c( 4, j ) + v5*c( 5, j ) + v6*c( 6, j ) + v7*c( 7, j ) c( 1, j ) = c( 1, j ) - sum*t1 c( 2, j ) = c( 2, j ) - sum*t2 c( 3, j ) = c( 3, j ) - sum*t3 c( 4, j ) = c( 4, j ) - sum*t4 c( 5, j ) = c( 5, j ) - sum*t5 c( 6, j ) = c( 6, j ) - sum*t6 c( 7, j ) = c( 7, j ) - sum*t7 END DO GO TO 410 150 CONTINUE ! ! Special code for 8 x 8 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 v3 = v( 3 ) t3 = tau*v3 v4 = v( 4 ) t4 = tau*v4 v5 = v( 5 ) t5 = tau*v5 v6 = v( 6 ) t6 = tau*v6 v7 = v( 7 ) t7 = tau*v7 v8 = v( 8 ) t8 = tau*v8 DO j = 1, n sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) + & v4*c( 4, j ) + v5*c( 5, j ) + v6*c( 6, j ) + v7*c( 7, j ) + v8*c( 8, j ) c( 1, j ) = c( 1, j ) - sum*t1 c( 2, j ) = c( 2, j ) - sum*t2 c( 3, j ) = c( 3, j ) - sum*t3 c( 4, j ) = c( 4, j ) - sum*t4 c( 5, j ) = c( 5, j ) - sum*t5 c( 6, j ) = c( 6, j ) - sum*t6 c( 7, j ) = c( 7, j ) - sum*t7 c( 8, j ) = c( 8, j ) - sum*t8 END DO GO TO 410 170 CONTINUE ! ! Special code for 9 x 9 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 v3 = v( 3 ) t3 = tau*v3 v4 = v( 4 ) t4 = tau*v4 v5 = v( 5 ) t5 = tau*v5 v6 = v( 6 ) t6 = tau*v6 v7 = v( 7 ) t7 = tau*v7 v8 = v( 8 ) t8 = tau*v8 v9 = v( 9 ) t9 = tau*v9 DO j = 1, n sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) + & v4*c( 4, j ) + v5*c( 5, j ) + v6*c( 6, j ) + & v7*c( 7, j ) + v8*c( 8, j ) + v9*c( 9, j ) c( 1, j ) = c( 1, j ) - sum*t1 c( 2, j ) = c( 2, j ) - sum*t2 c( 3, j ) = c( 3, j ) - sum*t3 c( 4, j ) = c( 4, j ) - sum*t4 c( 5, j ) = c( 5, j ) - sum*t5 c( 6, j ) = c( 6, j ) - sum*t6 c( 7, j ) = c( 7, j ) - sum*t7 c( 8, j ) = c( 8, j ) - sum*t8 c( 9, j ) = c( 9, j ) - sum*t9 END DO GO TO 410 190 CONTINUE ! ! Special code for 10 x 10 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 v3 = v( 3 ) t3 = tau*v3 v4 = v( 4 ) t4 = tau*v4 v5 = v( 5 ) t5 = tau*v5 v6 = v( 6 ) t6 = tau*v6 v7 = v( 7 ) t7 = tau*v7 v8 = v( 8 ) t8 = tau*v8 v9 = v( 9 ) t9 = tau*v9 v10 = v( 10 ) t10 = tau*v10 DO j = 1, n sum = v1*c( 1, j ) + v2*c( 2, j ) + v3*c( 3, j ) + & v4*c( 4, j ) + v5*c( 5, j ) + v6*c( 6, j ) + & v7*c( 7, j ) + v8*c( 8, j ) + v9*c( 9, j ) + v10*c( 10, j ) c( 1, j ) = c( 1, j ) - sum*t1 c( 2, j ) = c( 2, j ) - sum*t2 c( 3, j ) = c( 3, j ) - sum*t3 c( 4, j ) = c( 4, j ) - sum*t4 c( 5, j ) = c( 5, j ) - sum*t5 c( 6, j ) = c( 6, j ) - sum*t6 c( 7, j ) = c( 7, j ) - sum*t7 c( 8, j ) = c( 8, j ) - sum*t8 c( 9, j ) = c( 9, j ) - sum*t9 c( 10, j ) = c( 10, j ) - sum*t10 END DO GO TO 410 ELSE ! ! Form C * H, where H has order n. ! SELECT CASE ( n ) CASE ( 1) GO TO 210 CASE ( 2) GO TO 230 CASE ( 3) GO TO 250 CASE ( 4) GO TO 270 CASE ( 5) GO TO 290 CASE ( 6) GO TO 310 CASE ( 7) GO TO 330 CASE ( 8) GO TO 350 CASE ( 9) GO TO 370 CASE ( 10) GO TO 390 END SELECT ! ! Code for general N ! ! w := C * v ! CALL sgemv( 'No transpose', m, n, one, c, ldc, v, 1, zero, work, 1 ) ! ! C := C - tau * w * v' ! CALL sger( m, n, -tau, work, 1, v, 1, c, ldc ) GO TO 410 210 CONTINUE ! ! Special code for 1 x 1 Householder ! t1 = one - tau*v( 1 )*v( 1 ) DO j = 1, m c( j, 1 ) = t1*c( j, 1 ) END DO GO TO 410 230 CONTINUE ! ! Special code for 2 x 2 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 DO j = 1, m sum = v1*c( j, 1 ) + v2*c( j, 2 ) c( j, 1 ) = c( j, 1 ) - sum*t1 c( j, 2 ) = c( j, 2 ) - sum*t2 END DO GO TO 410 250 CONTINUE ! ! Special code for 3 x 3 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 v3 = v( 3 ) t3 = tau*v3 DO j = 1, m sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) c( j, 1 ) = c( j, 1 ) - sum*t1 c( j, 2 ) = c( j, 2 ) - sum*t2 c( j, 3 ) = c( j, 3 ) - sum*t3 END DO GO TO 410 270 CONTINUE ! ! Special code for 4 x 4 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 v3 = v( 3 ) t3 = tau*v3 v4 = v( 4 ) t4 = tau*v4 DO j = 1, m sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) + v4*c( j, 4 ) c( j, 1 ) = c( j, 1 ) - sum*t1 c( j, 2 ) = c( j, 2 ) - sum*t2 c( j, 3 ) = c( j, 3 ) - sum*t3 c( j, 4 ) = c( j, 4 ) - sum*t4 END DO GO TO 410 290 CONTINUE ! ! Special code for 5 x 5 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 v3 = v( 3 ) t3 = tau*v3 v4 = v( 4 ) t4 = tau*v4 v5 = v( 5 ) t5 = tau*v5 DO j = 1, m sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) + & v4*c( j, 4 ) + v5*c( j, 5 ) c( j, 1 ) = c( j, 1 ) - sum*t1 c( j, 2 ) = c( j, 2 ) - sum*t2 c( j, 3 ) = c( j, 3 ) - sum*t3 c( j, 4 ) = c( j, 4 ) - sum*t4 c( j, 5 ) = c( j, 5 ) - sum*t5 END DO GO TO 410 310 CONTINUE ! ! Special code for 6 x 6 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 v3 = v( 3 ) t3 = tau*v3 v4 = v( 4 ) t4 = tau*v4 v5 = v( 5 ) t5 = tau*v5 v6 = v( 6 ) t6 = tau*v6 DO j = 1, m sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) + & v4*c( j, 4 ) + v5*c( j, 5 ) + v6*c( j, 6 ) c( j, 1 ) = c( j, 1 ) - sum*t1 c( j, 2 ) = c( j, 2 ) - sum*t2 c( j, 3 ) = c( j, 3 ) - sum*t3 c( j, 4 ) = c( j, 4 ) - sum*t4 c( j, 5 ) = c( j, 5 ) - sum*t5 c( j, 6 ) = c( j, 6 ) - sum*t6 END DO GO TO 410 330 CONTINUE ! ! Special code for 7 x 7 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 v3 = v( 3 ) t3 = tau*v3 v4 = v( 4 ) t4 = tau*v4 v5 = v( 5 ) t5 = tau*v5 v6 = v( 6 ) t6 = tau*v6 v7 = v( 7 ) t7 = tau*v7 DO j = 1, m sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) + & v4*c( j, 4 ) + v5*c( j, 5 ) + v6*c( j, 6 ) + v7*c( j, 7 ) c( j, 1 ) = c( j, 1 ) - sum*t1 c( j, 2 ) = c( j, 2 ) - sum*t2 c( j, 3 ) = c( j, 3 ) - sum*t3 c( j, 4 ) = c( j, 4 ) - sum*t4 c( j, 5 ) = c( j, 5 ) - sum*t5 c( j, 6 ) = c( j, 6 ) - sum*t6 c( j, 7 ) = c( j, 7 ) - sum*t7 END DO GO TO 410 350 CONTINUE ! ! Special code for 8 x 8 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 v3 = v( 3 ) t3 = tau*v3 v4 = v( 4 ) t4 = tau*v4 v5 = v( 5 ) t5 = tau*v5 v6 = v( 6 ) t6 = tau*v6 v7 = v( 7 ) t7 = tau*v7 v8 = v( 8 ) t8 = tau*v8 DO j = 1, m sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) + & v4*c( j, 4 ) + v5*c( j, 5 ) + v6*c( j, 6 ) + v7*c( j, 7 ) + v8*c( j, 8 ) c( j, 1 ) = c( j, 1 ) - sum*t1 c( j, 2 ) = c( j, 2 ) - sum*t2 c( j, 3 ) = c( j, 3 ) - sum*t3 c( j, 4 ) = c( j, 4 ) - sum*t4 c( j, 5 ) = c( j, 5 ) - sum*t5 c( j, 6 ) = c( j, 6 ) - sum*t6 c( j, 7 ) = c( j, 7 ) - sum*t7 c( j, 8 ) = c( j, 8 ) - sum*t8 END DO GO TO 410 370 CONTINUE ! ! Special code for 9 x 9 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 v3 = v( 3 ) t3 = tau*v3 v4 = v( 4 ) t4 = tau*v4 v5 = v( 5 ) t5 = tau*v5 v6 = v( 6 ) t6 = tau*v6 v7 = v( 7 ) t7 = tau*v7 v8 = v( 8 ) t8 = tau*v8 v9 = v( 9 ) t9 = tau*v9 DO j = 1, m sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) + & v4*c( j, 4 ) + v5*c( j, 5 ) + v6*c( j, 6 ) + & v7*c( j, 7 ) + v8*c( j, 8 ) + v9*c( j, 9 ) c( j, 1 ) = c( j, 1 ) - sum*t1 c( j, 2 ) = c( j, 2 ) - sum*t2 c( j, 3 ) = c( j, 3 ) - sum*t3 c( j, 4 ) = c( j, 4 ) - sum*t4 c( j, 5 ) = c( j, 5 ) - sum*t5 c( j, 6 ) = c( j, 6 ) - sum*t6 c( j, 7 ) = c( j, 7 ) - sum*t7 c( j, 8 ) = c( j, 8 ) - sum*t8 c( j, 9 ) = c( j, 9 ) - sum*t9 END DO GO TO 410 390 CONTINUE ! ! Special code for 10 x 10 Householder ! v1 = v( 1 ) t1 = tau*v1 v2 = v( 2 ) t2 = tau*v2 v3 = v( 3 ) t3 = tau*v3 v4 = v( 4 ) t4 = tau*v4 v5 = v( 5 ) t5 = tau*v5 v6 = v( 6 ) t6 = tau*v6 v7 = v( 7 ) t7 = tau*v7 v8 = v( 8 ) t8 = tau*v8 v9 = v( 9 ) t9 = tau*v9 v10 = v( 10 ) t10 = tau*v10 DO j = 1, m sum = v1*c( j, 1 ) + v2*c( j, 2 ) + v3*c( j, 3 ) + & v4*c( j, 4 ) + v5*c( j, 5 ) + v6*c( j, 6 ) + & v7*c( j, 7 ) + v8*c( j, 8 ) + v9*c( j, 9 ) + v10*c( j, 10 ) c( j, 1 ) = c( j, 1 ) - sum*t1 c( j, 2 ) = c( j, 2 ) - sum*t2 c( j, 3 ) = c( j, 3 ) - sum*t3 c( j, 4 ) = c( j, 4 ) - sum*t4 c( j, 5 ) = c( j, 5 ) - sum*t5 c( j, 6 ) = c( j, 6 ) - sum*t6 c( j, 7 ) = c( j, 7 ) - sum*t7 c( j, 8 ) = c( j, 8 ) - sum*t8 c( j, 9 ) = c( j, 9 ) - sum*t9 c( j, 10 ) = c( j, 10 ) - sum*t10 END DO GO TO 410 END IF 410 RETURN ! ! End of SLARFX ! END SUBROUTINE slarfx SUBROUTINE slargv( n, x, incx, y, incy, c, incc ) ! ! -- 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, INTENT(IN) :: n REAL, INTENT(IN OUT) :: x( * ) INTEGER, INTENT(IN) :: incx REAL, INTENT(IN OUT) :: y( * ) INTEGER, INTENT(IN) :: incy REAL, INTENT(OUT) :: c( * ) INTEGER, INTENT(IN) :: incc ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLARGV generates a vector of real plane rotations, determined by ! elements of the real vectors x and y. For i = 1,2,...,n ! ! ( c(i) s(i) ) ( x(i) ) = ( a(i) ) ! ( -s(i) c(i) ) ( y(i) ) = ( 0 ) ! ! Arguments ! ========= ! ! N (input) INTEGER ! The number of plane rotations to be generated. ! ! X (input/output) REAL array, ! dimension (1+(N-1)*INCX) ! On entry, the vector x. ! On exit, x(i) is overwritten by a(i), for i = 1,...,n. ! ! INCX (input) INTEGER ! The increment between elements of X. INCX > 0. ! ! Y (input/output) REAL array, ! dimension (1+(N-1)*INCY) ! On entry, the vector y. ! On exit, the sines of the plane rotations. ! ! INCY (input) INTEGER ! The increment between elements of Y. INCY > 0. ! ! C (output) REAL array, dimension (1+(N-1)*INCC) ! The cosines of the plane rotations. ! ! INCC (input) INTEGER ! The increment between elements of C. INCC > 0. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, ic, ix, iy REAL :: f, g, t, tt ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, SQRT ! .. ! .. Executable Statements .. ! ix = 1 iy = 1 ic = 1 DO i = 1, n f = x( ix ) g = y( iy ) IF( g == zero ) THEN c( ic ) = one ELSE IF( f == zero ) THEN c( ic ) = zero y( iy ) = one x( ix ) = g ELSE IF( ABS( f ) > ABS( g ) ) THEN t = g / f tt = SQRT( one+t*t ) c( ic ) = one / tt y( iy ) = t*c( ic ) x( ix ) = f*tt ELSE t = f / g tt = SQRT( one+t*t ) y( iy ) = one / tt c( ic ) = t*y( iy ) x( ix ) = g*tt END IF ic = ic + incc iy = iy + incy ix = ix + incx END DO RETURN ! ! End of SLARGV ! END SUBROUTINE slargv SUBROUTINE slarnv( 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, INTENT(IN) :: idist INTEGER, INTENT(IN OUT) :: iseed( 4 ) INTEGER, INTENT(IN) :: n REAL, INTENT(OUT) :: x( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLARNV 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) REAL array, dimension (N) ! The generated random numbers. ! ! Further Details ! =============== ! ! This routine calls the auxiliary routine SLARUV 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 .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 INTEGER, PARAMETER :: lv = 128 REAL, PARAMETER :: twopi = 6.2831853071795864769252867663E+0 ! .. ! .. Local Scalars .. INTEGER :: i, il, il2, iv ! .. ! .. Local Arrays .. REAL :: u( lv ) ! .. ! .. Intrinsic Functions .. INTRINSIC COS, LOG, MIN, SQRT ! .. ! .. External Subroutines .. EXTERNAL slaruv ! .. ! .. Executable Statements .. ! DO iv = 1, n, lv / 2 il = MIN( lv / 2, n-iv+1 ) IF( idist == 3 ) THEN il2 = 2*il ELSE il2 = il END IF ! ! Call SLARUV to generate IL2 numbers from a uniform (0,1) ! distribution (IL2 <= LV) ! CALL slaruv( iseed, il2, u ) ! IF( idist == 1 ) THEN ! ! Copy generated numbers ! DO i = 1, il x( iv+i-1 ) = u( i ) END DO ELSE IF( idist == 2 ) THEN ! ! Convert generated numbers to uniform (-1,1) distribution ! DO i = 1, il x( iv+i-1 ) = two*u( i ) - one END DO ELSE IF( idist == 3 ) THEN ! ! Convert generated numbers to normal (0,1) distribution ! DO i = 1, il x( iv+i-1 ) = SQRT( -two*LOG( u( 2*i-1 ) ) )* COS( twopi*u( 2*i ) ) END DO END IF END DO RETURN ! ! End of SLARNV ! END SUBROUTINE slarnv SUBROUTINE slarrb( n, d, l, ld, lld, ifirst, ilast, sigma, reltol, & w, wgap, werr, 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, INTENT(IN OUT) :: n REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: l( * ) REAL, INTENT(IN) :: ld( * ) REAL, INTENT(IN OUT) :: lld( * ) INTEGER, INTENT(IN) :: ifirst INTEGER, INTENT(IN) :: ilast REAL, INTENT(IN) :: sigma REAL, INTENT(IN) :: reltol REAL, INTENT(IN OUT) :: w( * ) REAL, INTENT(IN OUT) :: wgap( * ) REAL, INTENT(OUT) :: werr( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(IN OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! Given the relatively robust representation(RRR) L D L^T, SLARRB ! does ``limited'' bisection to locate the eigenvalues of L D L^T, ! W( IFIRST ) thru' W( ILAST ), to more accuracy. Intervals ! [left, right] are maintained by storing their mid-points and ! semi-widths in the arrays W and WERR respectively. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The order of the matrix. ! ! D (input) REAL array, dimension (N) ! The n diagonal elements of the diagonal matrix D. ! ! L (input) REAL array, dimension (N-1) ! The n-1 subdiagonal elements of the unit bidiagonal matrix L. ! ! LD (input) REAL array, dimension (N-1) ! The n-1 elements L(i)*D(i). ! ! LLD (input) REAL array, dimension (N-1) ! The n-1 elements L(i)*L(i)*D(i). ! ! IFIRST (input) INTEGER ! The index of the first eigenvalue in the cluster. ! ! ILAST (input) INTEGER ! The index of the last eigenvalue in the cluster. ! ! SIGMA (input) REAL ! The shift used to form L D L^T (see SLARRF). ! ! RELTOL (input) REAL ! The relative tolerance. ! ! W (input/output) REAL array, dimension (N) ! On input, W( IFIRST ) thru' W( ILAST ) are estimates of the ! corresponding eigenvalues of L D L^T. ! On output, these estimates are ``refined''. ! ! WGAP (input/output) REAL array, dimension (N) ! The gaps between the eigenvalues of L D L^T. Very small ! gaps are changed on output. ! ! WERR (input/output) REAL array, dimension (N) ! On input, WERR( IFIRST ) thru' WERR( ILAST ) are the errors ! in the estimates W( IFIRST ) thru' W( ILAST ). ! On output, these are the ``refined'' errors. ! !****Reminder to Inder --- WORK is never used in this subroutine ***** ! WORK (input) REAL array, dimension (???) ! Workspace. ! ! IWORK (input) INTEGER array, dimension (2*N) ! Workspace. ! !****Reminder to Inder --- INFO is never set in this subroutine ****** ! INFO (output) INTEGER ! Error flag. ! ! Further Details ! =============== ! ! Based on contributions by ! Inderjit Dhillon, IBM Almaden, USA ! Osni Marques, LBNL/NERSC, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: half = 0.5E0 ! .. ! .. Local Scalars .. INTEGER :: cnt, i, i1, i2, initi1, initi2, j, k, ncnvrg, & neig, nint, nright, olnint REAL :: delta, eps, gap, left, mid, pert, right, s, thresh, tmp, width ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. Executable Statements .. ! eps = slamch( 'Precision' ) i1 = ifirst i2 = ifirst neig = ilast - ifirst + 1 ncnvrg = 0 thresh = reltol DO i = ifirst, ilast iwork( i ) = 0 pert = eps*( ABS( sigma )+ABS( w( i ) ) ) werr( i ) = werr( i ) + pert IF( wgap( i ) < pert ) wgap( i ) = pert END DO DO i = i1, ilast IF( i == 1 ) THEN gap = wgap( i ) ELSE IF( i == n ) THEN gap = wgap( i-1 ) ELSE gap = MIN( wgap( i-1 ), wgap( i ) ) END IF IF( werr( i ) < thresh*gap ) THEN ncnvrg = ncnvrg + 1 iwork( i ) = 1 IF( i1 == i ) i1 = i1 + 1 ELSE i2 = i END IF END DO ! ! Initialize the unconverged intervals. ! i = i1 nint = 0 right = zero 30 CONTINUE IF( i <= i2 ) THEN IF( iwork( i ) == 0 ) THEN delta = eps left = w( i ) - werr( i ) ! ! Do while( CNT(LEFT).GT.I-1 ) ! 40 CONTINUE IF( i > i1 .AND. left <= right ) THEN left = right cnt = i - 1 ELSE s = -left cnt = 0 DO j = 1, n - 1 tmp = d( j ) + s s = s*( ld( j ) / tmp )*l( j ) - left IF( tmp < zero ) cnt = cnt + 1 END DO tmp = d( n ) + s IF( tmp < zero ) cnt = cnt + 1 IF( cnt > i-1 ) THEN delta = two*delta left = left - ( ABS( sigma )+ABS( left ) )*delta GO TO 40 END IF END IF delta = eps right = w( i ) + werr( i ) ! ! Do while( CNT(RIGHT).LT.I ) ! 60 CONTINUE s = -right cnt = 0 DO j = 1, n - 1 tmp = d( j ) + s s = s*( ld( j ) / tmp )*l( j ) - right IF( tmp < zero ) cnt = cnt + 1 END DO tmp = d( n ) + s IF( tmp < zero ) cnt = cnt + 1 IF( cnt < i ) THEN delta = two*delta right = right + ( ABS( sigma )+ABS( right ) )*delta GO TO 60 END IF werr( i ) = left w( i ) = right iwork( n+i ) = cnt nint = nint + 1 i = cnt + 1 ELSE i = i + 1 END IF GO TO 30 END IF ! ! While( NCNVRG.LT.NEIG ) ! initi1 = i1 initi2 = i2 80 CONTINUE IF( ncnvrg < neig ) THEN olnint = nint i = i1 DO k = 1, olnint nright = iwork( n+i ) IF( iwork( i ) == 0 ) THEN mid = half*( werr( i )+w( i ) ) s = -mid cnt = 0 DO j = 1, n - 1 tmp = d( j ) + s s = s*( ld( j ) / tmp )*l( j ) - mid IF( tmp < zero ) cnt = cnt + 1 END DO tmp = d( n ) + s IF( tmp < zero ) cnt = cnt + 1 cnt = MAX( i-1, MIN( nright, cnt ) ) IF( i == nright ) THEN IF( i == ifirst ) THEN gap = werr( i+1 ) - w( i ) ELSE IF( i == ilast ) THEN gap = werr( i ) - w( i-1 ) ELSE gap = MIN( werr( i+1 )-w( i ), werr( i )-w( i-1 ) ) END IF width = w( i ) - mid IF( width < thresh*gap ) THEN ncnvrg = ncnvrg + 1 iwork( i ) = 1 IF( i1 == i ) THEN i1 = i1 + 1 nint = nint - 1 END IF END IF END IF IF( iwork( i ) == 0 ) i2 = k IF( cnt == i-1 ) THEN werr( i ) = mid ELSE IF( cnt == nright ) THEN w( i ) = mid ELSE iwork( n+i ) = cnt nint = nint + 1 werr( cnt+1 ) = mid w( cnt+1 ) = w( i ) w( i ) = mid i = cnt + 1 iwork( n+i ) = nright END IF END IF i = nright + 1 END DO nint = nint - olnint + i2 GO TO 80 END IF DO i = initi1, initi2 w( i ) = half*( werr( i )+w( i ) ) werr( i ) = w( i ) - werr( i ) END DO ! RETURN ! ! End of SLARRB ! END SUBROUTINE slarrb SUBROUTINE slarre( n, d, e, tol, nsplit, isplit, m, w, woff, & gersch, work, 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, INTENT(IN) :: n REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(IN OUT) :: e( * ) REAL, INTENT(IN) :: tol INTEGER, INTENT(OUT) :: nsplit INTEGER, INTENT(OUT) :: isplit( * ) INTEGER, INTENT(OUT) :: m REAL, INTENT(OUT) :: w( * ) REAL, INTENT(OUT) :: woff( * ) REAL, INTENT(OUT) :: gersch( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! Given the tridiagonal matrix T, SLARRE sets "small" off-diagonal ! elements to zero, and for each unreduced block T_i, it finds ! (i) the numbers sigma_i ! (ii) the base T_i - sigma_i I = L_i D_i L_i^T representations and ! (iii) eigenvalues of each L_i D_i L_i^T. ! The representations and eigenvalues found are then used by ! SSTEGR to compute the eigenvectors of a symmetric tridiagonal ! matrix. Currently, the base representations are limited to being ! positive or negative definite, and the eigenvalues of the definite ! matrices are found by the dqds algorithm (subroutine SLASQ2). As ! an added benefit, SLARRE also outputs the n Gerschgorin ! intervals for each L_i D_i L_i^T. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The order of the matrix. ! ! D (input/output) REAL array, dimension (N) ! On entry, the n diagonal elements of the tridiagonal ! matrix T. ! On exit, the n diagonal elements of the diagonal ! matrices D_i. ! ! E (input/output) REAL array, dimension (N) ! On entry, the (n-1) subdiagonal elements of the tridiagonal ! matrix T; E(N) need not be set. ! On exit, the subdiagonal elements of the unit bidiagonal ! matrices L_i. ! ! TOL (input) REAL ! The threshold for splitting. If on input |E(i)| < TOL, then ! the matrix T is split into smaller blocks. ! ! NSPLIT (input) INTEGER ! The number of blocks T splits into. 1 <= NSPLIT <= N. ! ! ISPLIT (output) INTEGER array, dimension (2*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. ! ! M (output) INTEGER ! The total number of eigenvalues (of all the L_i D_i L_i^T) ! found. ! ! W (output) REAL array, dimension (N) ! The first M elements contain the eigenvalues. The ! eigenvalues of each of the blocks, L_i D_i L_i^T, are ! sorted in ascending order. ! ! WOFF (output) REAL array, dimension (N) ! The NSPLIT base points sigma_i. ! ! GERSCH (output) REAL array, dimension (2*N) ! The n Gerschgorin intervals. ! ! WORK (input) REAL array, dimension (4*N???) ! Workspace. ! ! INFO (output) INTEGER ! Output error code from SLASQ2 ! ! Further Details ! =============== ! ! Based on contributions by ! Inderjit Dhillon, IBM Almaden, USA ! Osni Marques, LBNL/NERSC, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: four = 4.0E0 REAL, PARAMETER :: fourth = one / four ! .. ! .. Local Scalars .. INTEGER :: cnt, i, ibegin, iend, in, j, jblk, maxcnt REAL :: delta, eps, gl, gu, nrm, offd, s, sgndef, sigma, tau, tmp1, width ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. External Subroutines .. EXTERNAL scopy, slasq2 ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. Executable Statements .. ! info = 0 eps = slamch( 'Precision' ) ! ! Compute Splitting Points ! nsplit = 1 DO i = 1, n - 1 IF( ABS( e( i ) ) <= tol ) THEN isplit( nsplit ) = i nsplit = nsplit + 1 END IF END DO isplit( nsplit ) = n ! ibegin = 1 DO jblk = 1, nsplit iend = isplit( jblk ) IF( ibegin == iend ) THEN w( ibegin ) = d( ibegin ) woff( jblk ) = zero ibegin = iend + 1 CYCLE END IF in = iend - ibegin + 1 ! ! Form the n Gerschgorin intervals ! gl = d( ibegin ) - ABS( e( ibegin ) ) gu = d( ibegin ) + ABS( e( ibegin ) ) gersch( 2*ibegin-1 ) = gl gersch( 2*ibegin ) = gu gersch( 2*iend-1 ) = d( iend ) - ABS( e( iend-1 ) ) gersch( 2*iend ) = d( iend ) + ABS( e( iend-1 ) ) gl = MIN( gersch( 2*iend-1 ), gl ) gu = MAX( gersch( 2*iend ), gu ) DO i = ibegin + 1, iend - 1 offd = ABS( e( i-1 ) ) + ABS( e( i ) ) gersch( 2*i-1 ) = d( i ) - offd gl = MIN( gersch( 2*i-1 ), gl ) gersch( 2*i ) = d( i ) + offd gu = MAX( gersch( 2*i ), gu ) END DO nrm = MAX( ABS( gl ), ABS( gu ) ) ! ! Find the number SIGMA where the base representation ! T - sigma I = L D L^T is to be formed. ! width = gu - gl DO i = ibegin, iend - 1 work( i ) = e( i )*e( i ) END DO DO j = 1, 2 IF( j == 1 ) THEN tau = gl + fourth*width ELSE tau = gu - fourth*width END IF tmp1 = d( ibegin ) - tau IF( tmp1 < zero ) THEN cnt = 1 ELSE cnt = 0 END IF DO i = ibegin + 1, iend tmp1 = d( i ) - tau - work( i-1 ) / tmp1 IF( tmp1 < zero ) cnt = cnt + 1 END DO IF( cnt == 0 ) THEN gl = tau ELSE IF( cnt == in ) THEN gu = tau END IF IF( j == 1 ) THEN maxcnt = cnt sigma = gl sgndef = one ELSE IF( in-cnt > maxcnt ) THEN sigma = gu sgndef = -one END IF END IF END DO ! ! Find the base L D L^T representation ! work( 3*in ) = one delta = eps tau = sgndef*nrm 60 CONTINUE sigma = sigma - delta*tau work( 1 ) = d( ibegin ) - sigma j = ibegin DO i = 1, in - 1 work( 2*in+i ) = one / work( 2*i-1 ) tmp1 = e( j )*work( 2*in+i ) work( 2*i+1 ) = ( d( j+1 )-sigma ) - tmp1*e( j ) work( 2*i ) = tmp1 j = j + 1 END DO DO i = in, 1, -1 tmp1 = sgndef*work( 2*i-1 ) IF( tmp1 < zero .OR. work( 2*in+i ) == zero .OR. .NOT. & ( tmp1 > zero .OR. tmp1 < one ) ) THEN delta = two*delta GO TO 60 END IF j = j - 1 END DO ! j = ibegin d( ibegin ) = work( 1 ) work( 1 ) = ABS( work( 1 ) ) DO i = 1, in - 1 tmp1 = e( j ) e( j ) = work( 2*i ) work( 2*i ) = ABS( tmp1*work( 2*i ) ) j = j + 1 d( j ) = work( 2*i+1 ) work( 2*i+1 ) = ABS( work( 2*i+1 ) ) END DO ! CALL slasq2( in, work, info ) ! tau = sgndef*work( in ) work( 3*in ) = one delta = two*eps 100 CONTINUE tau = tau*( one-delta ) ! s = -tau j = ibegin DO i = 1, in - 1 work( i ) = d( j ) + s work( 2*in+i ) = one / work( i ) ! WORK( N+I ) = ( E( I ) * D( I ) ) / WORK( I ) work( in+i ) = ( e( j )*d( j ) )*work( 2*in+i ) s = s*work( in+i )*e( j ) - tau j = j + 1 END DO work( in ) = d( iend ) + s ! ! Checking to see if all the diagonal elements of the new ! L D L^T representation have the same sign ! DO i = in, 1, -1 tmp1 = sgndef*work( i ) IF( tmp1 < zero .OR. work( 2*in+i ) == zero .OR. .NOT. & ( tmp1 > zero .OR. tmp1 < one ) ) THEN delta = two*delta GO TO 100 END IF END DO ! sigma = sigma + tau CALL scopy( in, work, 1, d( ibegin ), 1 ) CALL scopy( in-1, work( in+1 ), 1, e( ibegin ), 1 ) woff( jblk ) = sigma ! ! Update the n Gerschgorin intervals ! DO i = ibegin, iend gersch( 2*i-1 ) = gersch( 2*i-1 ) - sigma gersch( 2*i ) = gersch( 2*i ) - sigma END DO ! ! Compute the eigenvalues of L D L^T. ! j = ibegin DO i = 1, in - 1 work( 2*i-1 ) = ABS( d( j ) ) work( 2*i ) = e( j )*e( j )*work( 2*i-1 ) j = j + 1 END DO work( 2*in-1 ) = ABS( d( iend ) ) ! CALL slasq2( in, work, info ) ! j = ibegin IF( sgndef > zero ) THEN DO i = 1, in w( j ) = work( in-i+1 ) j = j + 1 END DO ELSE DO i = 1, in w( j ) = -work( i ) j = j + 1 END DO END IF ibegin = iend + 1 END DO m = n ! RETURN ! ! End of SLARRE ! END SUBROUTINE slarre SUBROUTINE slarrf( n, d, l, ld, lld, ifirst, ilast, w, dplus, & lplus, 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, INTENT(IN OUT) :: n REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: l( * ) REAL, INTENT(IN) :: ld( * ) REAL, INTENT(IN OUT) :: lld( * ) INTEGER, INTENT(IN) :: ifirst INTEGER, INTENT(IN) :: ilast REAL, INTENT(IN OUT) :: w( * ) REAL, INTENT(OUT) :: dplus( * ) REAL, INTENT(OUT) :: lplus( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! Given the initial representation L D L^T and its cluster of close ! eigenvalues (in a relative measure), W( IFIRST ), W( IFIRST+1 ), ... ! W( ILAST ), SLARRF finds a new relatively robust representation ! L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the ! eigenvalues of L(+) D(+) L(+)^T is relatively isolated. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The order of the matrix. ! ! D (input) REAL array, dimension (N) ! The n diagonal elements of the diagonal matrix D. ! ! L (input) REAL array, dimension (N-1) ! The (n-1) subdiagonal elements of the unit bidiagonal ! matrix L. ! ! LD (input) REAL array, dimension (N-1) ! The n-1 elements L(i)*D(i). ! ! LLD (input) REAL array, dimension (N-1) ! The n-1 elements L(i)*L(i)*D(i). ! ! IFIRST (input) INTEGER ! The index of the first eigenvalue in the cluster. ! ! ILAST (input) INTEGER ! The index of the last eigenvalue in the cluster. ! ! W (input/output) REAL array, dimension (N) ! On input, the eigenvalues of L D L^T in ascending order. ! W( IFIRST ) through W( ILAST ) form the cluster of relatively ! close eigenalues. ! On output, W( IFIRST ) thru' W( ILAST ) are estimates of the ! corresponding eigenvalues of L(+) D(+) L(+)^T. ! ! SIGMA (input) REAL ! The shift used to form L(+) D(+) L(+)^T. ! ! DPLUS (output) REAL array, dimension (N) ! The n diagonal elements of the diagonal matrix D(+). ! ! LPLUS (output) REAL array, dimension (N) ! The first (n-1) elements of LPLUS contain the subdiagonal ! elements of the unit bidiagonal matrix L(+). LPLUS( N ) is ! set to SIGMA. ! ! WORK (input) REAL array, dimension (???) ! Workspace. ! ! Further Details ! =============== ! ! Based on contributions by ! Inderjit Dhillon, IBM Almaden, USA ! Osni Marques, LBNL/NERSC, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: two = 2.0E0 ! .. ! .. Local Scalars .. INTEGER :: i REAL :: delta, eps, s, sigma ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. Intrinsic Functions .. INTRINSIC ABS ! .. ! .. Executable Statements .. ! info = 0 eps = slamch( 'Precision' ) IF( ifirst == 1 ) THEN sigma = w( ifirst ) ELSE IF( ilast == n ) THEN sigma = w( ilast ) ELSE info = 1 RETURN END IF ! ! Compute the new relatively robust representation (RRR) ! delta = two*eps 10 CONTINUE IF( ifirst == 1 ) THEN sigma = sigma - ABS( sigma )*delta ELSE sigma = sigma + ABS( sigma )*delta END IF s = -sigma DO i = 1, n - 1 dplus( i ) = d( i ) + s lplus( i ) = ld( i ) / dplus( i ) s = s*lplus( i )*l( i ) - sigma END DO dplus( n ) = d( n ) + s IF( ifirst == 1 ) THEN DO i = 1, n IF( dplus( i ) < zero ) THEN delta = two*delta GO TO 10 END IF END DO ELSE DO i = 1, n IF( dplus( i ) > zero ) THEN delta = two*delta GO TO 10 END IF END DO END IF DO i = ifirst, ilast w( i ) = w( i ) - sigma END DO lplus( n ) = sigma ! RETURN ! ! End of SLARRF ! END SUBROUTINE slarrf SUBROUTINE slarrv( n, d, l, isplit, m, w, iblock, gersch, tol, z, & ldz, isuppz, 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, INTENT(IN) :: n REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: l( * ) INTEGER, INTENT(IN) :: isplit( * ) INTEGER, INTENT(IN) :: m REAL, INTENT(IN) :: w( * ) INTEGER, INTENT(IN) :: iblock( * ) REAL, INTENT(IN OUT) :: gersch( * ) REAL, INTENT(IN) :: tol REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz INTEGER, INTENT(OUT) :: isuppz( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLARRV computes the eigenvectors of the tridiagonal matrix ! T = L D L^T given L, D and the eigenvalues of L D L^T. ! The input eigenvalues should have high relative accuracy with ! respect to the entries of L and D. The desired accuracy of the ! output can be specified by the input parameter TOL. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The order of the matrix. N >= 0. ! ! D (input/output) REAL array, dimension (N) ! On entry, the n diagonal elements of the diagonal matrix D. ! On exit, D may be overwritten. ! ! L (input/output) REAL array, dimension (N-1) ! On entry, the (n-1) subdiagonal elements of the unit ! bidiagonal matrix L in elements 1 to N-1 of L. L(N) need ! not be set. On exit, L is overwritten. ! ! 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. ! ! TOL (input) REAL ! The absolute error tolerance for the ! eigenvalues/eigenvectors. ! Errors in the input eigenvalues must be bounded by TOL. ! The eigenvectors output have residual norms ! bounded by TOL, and the dot products between different ! eigenvectors are bounded by TOL. TOL must be at least ! N*EPS*|T|, where EPS is the machine precision and |T| is ! the 1-norm of the tridiagonal matrix. ! ! M (input) INTEGER ! The total number of eigenvalues found. 0 <= M <= N. ! If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. ! ! W (input) REAL 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 SLARRE is expected here ). ! Errors in W must be bounded by TOL (see above). ! ! 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. ! ! Z (output) REAL 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 T ! corresponding to the selected eigenvalues, with the i-th ! column of Z holding the eigenvector associated with W(i). ! 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). ! ! ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) ! The support of the eigenvectors in Z, i.e., the indices ! indicating the nonzero elements in Z. The i-th eigenvector ! is nonzero only in elements ISUPPZ( 2*i-1 ) through ! ISUPPZ( 2*i ). ! ! WORK (workspace) REAL array, dimension (13*N) ! ! IWORK (workspace) INTEGER array, dimension (6*N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! > 0: if INFO = 1, internal error in SLARRB ! if INFO = 2, internal error in SSTEIN ! ! Further Details ! =============== ! ! Based on contributions by ! Inderjit Dhillon, IBM Almaden, USA ! Osni Marques, LBNL/NERSC, USA ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: mgssiz = 20 REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: four = 4.0E0 ! .. ! .. Local Scalars .. LOGICAL :: mgscls INTEGER :: i, ibegin, iend, iindc1, iindc2, iindr, iindwk, & iinfo, im, in, inderr, indgap, indld, indlld, & indwrk, iter, itmp1, itmp2, j, jblk, k, ktot, & lsbdpt, maxitr, nclus, ndepth, ndone, newcls, & newfrs, newftt, newlst, newsiz, nsplit, oldcls, & oldfst, oldien, oldlst, oldncl, p, q, temp( 1 ) REAL :: eps, gap, lambda, mgstol, mingma, minrgp, & nrminv, relgap, reltol, resid, rqcorr, sigma, tmp1, ztz ! .. ! .. External Functions .. REAL :: sdot, slamch, snrm2 EXTERNAL sdot, slamch, snrm2 ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, slar1v, slarrb, slarrf, slaset, sscal, sstein ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, REAL, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! inderr = n + 1 indld = 2*n indlld = 3*n indgap = 4*n indwrk = 5*n + 1 ! iindr = n iindc1 = 2*n iindc2 = 3*n iindwk = 4*n + 1 ! eps = slamch( 'Precision' ) ! DO i = 1, 2*n iwork( i ) = 0 END DO DO i = 1, m work( inderr+i-1 ) = eps*ABS( w( i ) ) END DO CALL slaset( 'Full', n, n, zero, zero, z, ldz ) mgstol = 5.0E0*eps ! nsplit = iblock( m ) ibegin = 1 DO jblk = 1, nsplit iend = isplit( jblk ) ! ! Find the eigenvectors of the submatrix indexed IBEGIN ! through IEND. ! IF( ibegin == iend ) THEN z( ibegin, ibegin ) = one isuppz( 2*ibegin-1 ) = ibegin isuppz( 2*ibegin ) = ibegin ibegin = iend + 1 CYCLE END IF oldien = ibegin - 1 in = iend - oldien reltol = MIN( 1.0E-2, one / REAL( in ) ) im = in CALL scopy( im, w( ibegin ), 1, work, 1 ) DO i = 1, in - 1 work( indgap+i ) = work( i+1 ) - work( i ) END DO work( indgap+in ) = MAX( ABS( work( in ) ), eps ) ndone = 0 ! ndepth = 0 lsbdpt = 1 nclus = 1 iwork( iindc1+1 ) = 1 iwork( iindc1+2 ) = in ! ! While( NDONE.LT.IM ) do ! 40 CONTINUE IF( ndone < im ) THEN oldncl = nclus nclus = 0 lsbdpt = 1 - lsbdpt DO i = 1, oldncl IF( lsbdpt == 0 ) THEN oldcls = iindc1 newcls = iindc2 ELSE oldcls = iindc2 newcls = iindc1 END IF ! ! If NDEPTH > 1, retrieve the relatively robust ! representation (RRR) and perform limited bisection ! (if necessary) to get approximate eigenvalues. ! j = oldcls + 2*i oldfst = iwork( j-1 ) oldlst = iwork( j ) IF( ndepth > 0 ) THEN j = oldien + oldfst CALL scopy( in, z( ibegin, j ), 1, d( ibegin ), 1 ) CALL scopy( in, z( ibegin, j+1 ), 1, l( ibegin ), 1 ) sigma = l( iend ) END IF k = ibegin DO j = 1, in - 1 work( indld+j ) = d( k )*l( k ) work( indlld+j ) = work( indld+j )*l( k ) k = k + 1 END DO IF( ndepth > 0 ) THEN CALL slarrb( in, d( ibegin ), l( ibegin ), & work( indld+1 ), work( indlld+1 ), & oldfst, oldlst, sigma, reltol, work, & work( indgap+1 ), work( inderr ), & work( indwrk ), iwork( iindwk ), iinfo ) IF( iinfo /= 0 ) THEN info = 1 RETURN END IF END IF ! ! Classify eigenvalues of the current representation (RRR) ! as (i) isolated, (ii) loosely clustered or (iii) tightly ! clustered ! newfrs = oldfst DO j = oldfst, oldlst IF( j == oldlst .OR. work( indgap+j ) >= reltol* & ABS( work( j ) ) ) THEN newlst = j ELSE ! ! continue (to the next loop) ! relgap = work( indgap+j ) / ABS( work( j ) ) IF( j == newfrs ) THEN minrgp = relgap ELSE minrgp = MIN( minrgp, relgap ) END IF CYCLE END IF newsiz = newlst - newfrs + 1 maxitr = 10 newftt = oldien + newfrs IF( newsiz > 1 ) THEN mgscls = newsiz <= mgssiz .AND. minrgp >= mgstol IF( .NOT.mgscls ) THEN CALL slarrf( in, d( ibegin ), l( ibegin ), & work( indld+1 ), work( indlld+1 ), newfrs, newlst, work, & z( ibegin, newftt ), z( ibegin, newftt+1 ), & work( indwrk ), iwork( iindwk ), info ) IF( info == 0 ) THEN nclus = nclus + 1 k = newcls + 2*nclus iwork( k-1 ) = newfrs iwork( k ) = newlst ELSE info = 0 IF( minrgp >= mgstol ) THEN mgscls = .true. ELSE ! ! Call SSTEIN to process this tight cluster. ! This happens only if MINRGP <= MGSTOL ! and SLARRF returns INFO = 1. The latter ! means that a new RRR to "break" the ! cluster could not be found. ! work( indwrk ) = d( ibegin ) DO k = 1, in - 1 work( indwrk+k ) = d( ibegin+k ) + work( indlld+k ) END DO DO k = 1, newsiz iwork( iindwk+k-1 ) = 1 END DO DO k = newfrs, newlst isuppz( 2*( ibegin+k )-3 ) = 1 isuppz( 2*( ibegin+k )-2 ) = in END DO temp( 1 ) = in CALL sstein( in, work( indwrk ), work( indld+1 ), newsiz, & work( newfrs ), iwork( iindwk ), temp( 1 ), & z( ibegin, newftt ), ldz, work( indwrk+in ), & iwork( iindwk+in ), iwork( iindwk+2*in ), iinfo ) IF( iinfo /= 0 ) THEN info = 2 RETURN END IF ndone = ndone + newsiz END IF END IF END IF ELSE mgscls = .false. END IF IF( newsiz == 1 .OR. mgscls ) THEN ktot = newftt DO k = newfrs, newlst iter = 0 90 CONTINUE lambda = work( k ) CALL slar1v( in, 1, in, lambda, d( ibegin ), & l( ibegin ), work( indld+1 ), work( indlld+1 ), & gersch( 2*oldien+1 ), z( ibegin, ktot ), ztz, mingma, & iwork( iindr+ktot ), isuppz( 2*ktot-1 ), & work( indwrk ) ) tmp1 = one / ztz nrminv = SQRT( tmp1 ) resid = ABS( mingma )*nrminv rqcorr = mingma*tmp1 IF( k == in ) THEN gap = work( indgap+k-1 ) ELSE IF( k == 1 ) THEN gap = work( indgap+k ) ELSE gap = MIN( work( indgap+k-1 ), work( indgap+k ) ) END IF iter = iter + 1 IF( resid > tol*gap .AND. ABS( rqcorr ) > & four*eps*ABS( lambda ) ) THEN work( k ) = lambda + rqcorr IF( iter < maxitr ) THEN GO TO 90 END IF END IF iwork( ktot ) = 1 IF( newsiz == 1 ) ndone = ndone + 1 CALL sscal( in, nrminv, z( ibegin, ktot ), 1 ) ktot = ktot + 1 END DO IF( newsiz > 1 ) THEN itmp1 = isuppz( 2*newftt-1 ) itmp2 = isuppz( 2*newftt ) ktot = oldien + newlst DO p = newftt + 1, ktot DO q = newftt, p - 1 tmp1 = -sdot( in, z( ibegin, p ), 1, z( ibegin, q ), 1 ) CALL saxpy( in, tmp1, z( ibegin, q ), 1, z( ibegin, p ), 1 ) END DO tmp1 = one / snrm2( in, z( ibegin, p ), 1 ) CALL sscal( in, tmp1, z( ibegin, p ), 1 ) itmp1 = MIN( itmp1, isuppz( 2*p-1 ) ) itmp2 = MAX( itmp2, isuppz( 2*p ) ) END DO DO p = newftt, ktot isuppz( 2*p-1 ) = itmp1 isuppz( 2*p ) = itmp2 END DO ndone = ndone + newsiz END IF END IF newfrs = j + 1 END DO END DO ndepth = ndepth + 1 GO TO 40 END IF j = 2*ibegin DO i = ibegin, iend isuppz( j-1 ) = isuppz( j-1 ) + oldien isuppz( j ) = isuppz( j ) + oldien j = j + 2 END DO ibegin = iend + 1 END DO ! RETURN ! ! End of SLARRV ! END SUBROUTINE slarrv SUBROUTINE slartg( 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 ! September 30, 1994 ! ! .. Scalar Arguments .. REAL, INTENT(IN) :: f REAL, INTENT(IN) :: g REAL, INTENT(OUT) :: cs REAL, INTENT(OUT) :: sn REAL, INTENT(OUT) :: r ! .. ! ! Purpose ! ======= ! ! SLARTG generate a plane rotation so that ! ! [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. ! [ -SN CS ] [ G ] [ 0 ] ! ! This is a slower, more accurate version of the BLAS1 routine SROTG, ! with the following other 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 SBDSQR when ! there are zeros on the diagonal). ! ! If F exceeds G in magnitude, CS will be positive. ! ! Arguments ! ========= ! ! F (input) REAL ! The first component of vector to be rotated. ! ! G (input) REAL ! The second component of vector to be rotated. ! ! CS (output) REAL ! The cosine of the rotation. ! ! SN (output) REAL ! The sine of the rotation. ! ! R (output) REAL ! The nonzero component of the rotated vector. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 ! .. ! .. Local Scalars .. LOGICAL :: first INTEGER :: count, i REAL :: eps, f1, g1, safmin, safmn2, safmx2, scale ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX, SQRT ! .. ! .. Save statement .. SAVE first, safmx2, safmin, safmn2 ! .. ! .. Data statements .. DATA first / .true. / ! .. ! .. Executable Statements .. ! IF( first ) THEN first = .false. safmin = slamch( 'S' ) eps = slamch( 'E' ) safmn2 = slamch( 'B' )**INT( LOG( safmin / eps ) / & LOG( slamch( 'B' ) ) / two ) safmx2 = one / safmn2 END IF IF( g == zero ) THEN cs = one sn = zero r = f ELSE IF( f == zero ) THEN cs = zero sn = one r = g ELSE f1 = f g1 = g scale = MAX( ABS( f1 ), ABS( g1 ) ) IF( scale >= safmx2 ) THEN count = 0 10 CONTINUE count = count + 1 f1 = f1*safmn2 g1 = g1*safmn2 scale = MAX( ABS( f1 ), ABS( g1 ) ) IF( scale >= safmx2 ) GO TO 10 r = SQRT( f1**2+g1**2 ) cs = f1 / r sn = g1 / r DO i = 1, count r = r*safmx2 END DO ELSE IF( scale <= safmn2 ) THEN count = 0 30 CONTINUE count = count + 1 f1 = f1*safmx2 g1 = g1*safmx2 scale = MAX( ABS( f1 ), ABS( g1 ) ) IF( scale <= safmn2 ) GO TO 30 r = SQRT( f1**2+g1**2 ) cs = f1 / r sn = g1 / r DO i = 1, count r = r*safmn2 END DO ELSE r = SQRT( f1**2+g1**2 ) cs = f1 / r sn = g1 / r END IF IF( ABS( f ) > ABS( g ) .AND. cs < zero ) THEN cs = -cs sn = -sn r = -r END IF END IF RETURN ! ! End of SLARTG ! END SUBROUTINE slartg SUBROUTINE slartv( n, x, incx, y, incy, c, s, incc ) ! ! -- 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 .. INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: x( * ) INTEGER, INTENT(IN) :: incx REAL, INTENT(IN OUT) :: y( * ) INTEGER, INTENT(IN) :: incy REAL, INTENT(IN) :: c( * ) REAL, INTENT(IN) :: s( * ) INTEGER, INTENT(IN) :: incc ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLARTV applies a vector of real plane rotations to elements of the ! real vectors x and y. For i = 1,2,...,n ! ! ( x(i) ) := ( c(i) s(i) ) ( x(i) ) ! ( y(i) ) ( -s(i) c(i) ) ( y(i) ) ! ! Arguments ! ========= ! ! N (input) INTEGER ! The number of plane rotations to be applied. ! ! X (input/output) REAL array, ! dimension (1+(N-1)*INCX) ! The vector x. ! ! INCX (input) INTEGER ! The increment between elements of X. INCX > 0. ! ! Y (input/output) REAL array, ! dimension (1+(N-1)*INCY) ! The vector y. ! ! INCY (input) INTEGER ! The increment between elements of Y. INCY > 0. ! ! C (input) REAL array, dimension (1+(N-1)*INCC) ! The cosines of the plane rotations. ! ! S (input) REAL array, dimension (1+(N-1)*INCC) ! The sines of the plane rotations. ! ! INCC (input) INTEGER ! The increment between elements of C and S. INCC > 0. ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER :: i, ic, ix, iy REAL :: xi, yi ! .. ! .. Executable Statements .. ! ix = 1 iy = 1 ic = 1 DO i = 1, n xi = x( ix ) yi = y( iy ) x( ix ) = c( ic )*xi + s( ic )*yi y( iy ) = c( ic )*yi - s( ic )*xi ix = ix + incx iy = iy + incy ic = ic + incc END DO RETURN ! ! End of SLARTV ! END SUBROUTINE slartv SUBROUTINE slaruv( 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, INTENT(IN OUT) :: iseed( 4 ) INTEGER, INTENT(IN) :: n REAL, INTENT(OUT) :: x( n ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLARUV returns a vector of n random real numbers from a uniform (0,1) ! distribution (n <= 128). ! ! This is an auxiliary routine called by SLARNV and CLARNV. ! ! 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) REAL 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 .. REAL, PARAMETER :: one = 1.0E0 INTEGER, PARAMETER :: lv = 128 INTEGER, PARAMETER :: ipw2 = 4096 REAL, PARAMETER :: 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 MIN, MOD, REAL ! .. ! .. 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 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*( REAL( it1 )+r*( REAL( it2 )+r*( REAL( it3 )+r*REAL( it4 ) ) ) ) END DO ! ! Return final value of seed ! iseed( 1 ) = it1 iseed( 2 ) = it2 iseed( 3 ) = it3 iseed( 4 ) = it4 RETURN ! ! End of SLARUV ! END SUBROUTINE slaruv SUBROUTINE slarz( side, m, n, l, v, incv, tau, c, ldc, work ) ! ! -- 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 (LEN=1), INTENT(IN) :: side INTEGER, INTENT(IN OUT) :: m INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN OUT) :: l REAL, INTENT(IN OUT) :: v( * ) INTEGER, INTENT(IN OUT) :: incv REAL, INTENT(IN) :: tau REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(IN OUT) :: work( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLARZ 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. ! ! ! H is a product of k elementary reflectors as returned by STZRZF. ! ! 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. ! ! L (input) INTEGER ! The number of entries of the vector V containing ! the meaningful part of the Householder vectors. ! If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. ! ! V (input) REAL array, dimension (1+(L-1)*abs(INCV)) ! The vector v in the representation of H as returned by ! STZRZF. V is not used if TAU = 0. ! ! INCV (input) INTEGER ! The increment between elements of v. INCV <> 0. ! ! TAU (input) REAL ! The value tau in the representation of H. ! ! C (input/output) REAL 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) REAL array, dimension ! (N) if SIDE = 'L' ! or (M) if SIDE = 'R' ! ! Further Details ! =============== ! ! Based on contributions by ! A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, sgemv, sger ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Executable Statements .. ! IF( lsame( side, 'L' ) ) THEN ! ! Form H * C ! IF( tau /= zero ) THEN ! ! w( 1:n ) = C( 1, 1:n ) ! CALL scopy( n, c, ldc, work, 1 ) ! ! w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l ) ! CALL sgemv( 'Transpose', l, n, one, c( m-l+1, 1 ), ldc, v, & incv, one, work, 1 ) ! ! C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) ! CALL saxpy( n, -tau, work, 1, c, ldc ) ! ! C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... ! tau * v( 1:l ) * w( 1:n )' ! CALL sger( l, n, -tau, v, incv, work, 1, c( m-l+1, 1 ), ldc ) END IF ! ELSE ! ! Form C * H ! IF( tau /= zero ) THEN ! ! w( 1:m ) = C( 1:m, 1 ) ! CALL scopy( m, c, 1, work, 1 ) ! ! w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l ) ! CALL sgemv( 'No transpose', m, l, one, c( 1, n-l+1 ), ldc, & v, incv, one, work, 1 ) ! ! C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) ! CALL saxpy( m, -tau, work, 1, c, 1 ) ! ! C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... ! tau * w( 1:m ) * v( 1:l )' ! CALL sger( m, l, -tau, work, 1, v, incv, c( 1, n-l+1 ), ldc ) ! END IF ! END IF ! RETURN ! ! End of SLARZ ! END SUBROUTINE slarz SUBROUTINE slarzb( side, trans, DIRECT, storev, m, n, k, l, v, & ldv, t, ldt, c, ldc, work, ldwork ) ! ! -- 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 (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: trans CHARACTER (LEN=1), INTENT(IN) :: DIRECT CHARACTER (LEN=1), INTENT(IN OUT) :: storev INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k INTEGER, INTENT(IN OUT) :: l REAL, INTENT(IN OUT) :: v( ldv, * ) INTEGER, INTENT(IN OUT) :: ldv REAL, INTENT(IN OUT) :: t( ldt, * ) INTEGER, INTENT(IN OUT) :: ldt REAL, INTENT(OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(IN) :: work( ldwork, * ) INTEGER, INTENT(IN OUT) :: ldwork ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLARZB applies a real block reflector H or its transpose H**T to ! a real distributed M-by-N C from the left or the right. ! ! Currently, only STOREV = 'R' and DIRECT = 'B' are supported. ! ! 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' (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, not supported yet) ! = '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 (not supported yet) ! = '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). ! ! L (input) INTEGER ! The number of columns of the matrix V containing the ! meaningful part of the Householder reflectors. ! If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. ! ! V (input) REAL array, dimension (LDV,NV). ! If STOREV = 'C', NV = K; if STOREV = 'R', NV = L. ! ! LDV (input) INTEGER ! The leading dimension of the array V. ! If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K. ! ! T (input) REAL 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) REAL 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) REAL 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). ! ! Further Details ! =============== ! ! Based on contributions by ! A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. CHARACTER (LEN=1) :: transt INTEGER :: i, info, j ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL scopy, sgemm, strmm, xerbla ! .. ! .. Executable Statements .. ! ! Quick return if possible ! IF( m <= 0 .OR. n <= 0 ) RETURN ! ! Check for currently supported options ! info = 0 IF( .NOT.lsame( DIRECT, 'B' ) ) THEN info = -3 ELSE IF( .NOT.lsame( storev, 'R' ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLARZB', -info ) RETURN END IF ! IF( lsame( trans, 'N' ) ) THEN transt = 'T' ELSE transt = 'N' END IF ! IF( lsame( side, 'L' ) ) THEN ! ! Form H * C or H' * C ! ! W( 1:n, 1:k ) = C( 1:k, 1:n )' ! DO j = 1, k CALL scopy( n, c( j, 1 ), ldc, work( 1, j ), 1 ) END DO ! ! W( 1:n, 1:k ) = W( 1:n, 1:k ) + ... ! C( m-l+1:m, 1:n )' * V( 1:k, 1:l )' ! CALL sgemm( 'Transpose', 'Transpose', n, k, l, one, & c( m-l+1, 1 ), ldc, v, ldv, one, work, ldwork ) ! ! W( 1:n, 1:k ) = W( 1:n, 1:k ) * T' or W( 1:m, 1:k ) * T ! CALL strmm( 'Right', 'Lower', transt, 'Non-unit', n, k, one, t, & ldt, work, ldwork ) ! ! C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )' ! DO j = 1, n DO i = 1, k c( i, j ) = c( i, j ) - work( j, i ) END DO END DO ! ! C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... ! V( 1:k, 1:l )' * W( 1:n, 1:k )' ! CALL sgemm( 'Transpose', 'Transpose', l, n, k, -one, v, ldv, & work, ldwork, one, c( m-l+1, 1 ), ldc ) ! ELSE IF( lsame( side, 'R' ) ) THEN ! ! Form C * H or C * H' ! ! W( 1:m, 1:k ) = C( 1:m, 1:k ) ! DO j = 1, k CALL scopy( m, c( 1, j ), 1, work( 1, j ), 1 ) END DO ! ! W( 1:m, 1:k ) = W( 1:m, 1:k ) + ... ! C( 1:m, n-l+1:n ) * V( 1:k, 1:l )' ! CALL sgemm( 'No transpose', 'Transpose', m, k, l, one, & c( 1, n-l+1 ), ldc, v, ldv, one, work, ldwork ) ! ! W( 1:m, 1:k ) = W( 1:m, 1:k ) * T or W( 1:m, 1:k ) * T' ! CALL strmm( 'Right', 'Lower', trans, 'Non-unit', m, k, one, t, & ldt, work, ldwork ) ! ! C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k ) ! DO j = 1, k DO i = 1, m c( i, j ) = c( i, j ) - work( i, j ) END DO END DO ! ! C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... ! W( 1:m, 1:k ) * V( 1:k, 1:l ) ! CALL sgemm( 'No transpose', 'No transpose', m, l, k, -one, & work, ldwork, v, ldv, one, c( 1, n-l+1 ), ldc ) ! END IF ! RETURN ! ! End of SLARZB ! END SUBROUTINE slarzb SUBROUTINE slarzt( DIRECT, storev, n, k, v, ldv, tau, t, ldt ) ! ! -- 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 (LEN=1), INTENT(IN) :: DIRECT CHARACTER (LEN=1), INTENT(IN OUT) :: storev INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(IN OUT) :: v( ldv, * ) INTEGER, INTENT(IN OUT) :: ldv REAL, INTENT(IN) :: tau( * ) REAL, INTENT(OUT) :: t( ldt, * ) INTEGER, INTENT(IN OUT) :: ldt ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLARZT 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 ! ! Currently, only STOREV = 'R' and DIRECT = 'B' are supported. ! ! 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, not supported yet) ! = '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 (not supported yet) ! = '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) REAL 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i). ! ! T (output) REAL 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 ! =============== ! ! Based on contributions by ! A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA ! ! 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_____ ! ( v1 v2 v3 ) / \ ! ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 ) ! V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 ) ! ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 ) ! ( v1 v2 v3 ) ! . . . ! . . . ! 1 . . ! 1 . ! 1 ! ! DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': ! ! ______V_____ ! 1 / \ ! . 1 ( 1 . . . . v1 v1 v1 v1 v1 ) ! . . 1 ( . 1 . . . v2 v2 v2 v2 v2 ) ! . . . ( . . 1 . . v3 v3 v3 v3 v3 ) ! . . . ! ( v1 v2 v3 ) ! ( v1 v2 v3 ) ! V = ( v1 v2 v3 ) ! ( v1 v2 v3 ) ! ( v1 v2 v3 ) ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, info, j ! .. ! .. External Subroutines .. EXTERNAL sgemv, strmv, xerbla ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Executable Statements .. ! ! Check for currently supported options ! info = 0 IF( .NOT.lsame( DIRECT, 'B' ) ) THEN info = -1 ELSE IF( .NOT.lsame( storev, 'R' ) ) THEN info = -2 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLARZT', -info ) RETURN END IF ! DO i = k, 1, -1 IF( tau( i ) == zero ) THEN ! ! H(i) = I ! DO j = i, k t( j, i ) = zero END DO ELSE ! ! general case ! IF( i < k ) THEN ! ! T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)' ! CALL sgemv( 'No transpose', k-i, n, -tau( i ), & v( i+1, 1 ), ldv, v( i, 1 ), ldv, zero, t( i+1, i ), 1 ) ! ! T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i) ! CALL strmv( '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 END DO RETURN ! ! End of SLARZT ! END SUBROUTINE slarzt SUBROUTINE slas2( 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 .. REAL, INTENT(IN) :: f REAL, INTENT(IN) :: g REAL, INTENT(IN) :: h REAL, INTENT(OUT) :: ssmin REAL, INTENT(OUT) :: ssmax ! .. ! ! Purpose ! ======= ! ! SLAS2 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) REAL ! The (1,1) element of the 2-by-2 matrix. ! ! G (input) REAL ! The (1,2) element of the 2-by-2 matrix. ! ! H (input) REAL ! The (2,2) element of the 2-by-2 matrix. ! ! SSMIN (output) REAL ! The smaller singular value. ! ! SSMAX (output) REAL ! 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 .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 ! .. ! .. Local Scalars .. REAL :: 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 == zero ) THEN ssmin = zero IF( fhmx == zero ) THEN ssmax = ga ELSE ssmax = MAX( fhmx, ga )*SQRT( one+ & ( MIN( fhmx, ga ) / MAX( fhmx, ga ) )**2 ) END IF ELSE IF( ga < 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 == 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 SLAS2 ! END SUBROUTINE slas2 SUBROUTINE slascl( 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 (LEN=1), INTENT(IN) :: TYPE INTEGER, INTENT(IN) :: kl INTEGER, INTENT(IN) :: ku REAL, INTENT(IN) :: cfrom REAL, INTENT(IN) :: cto INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLASCL 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) REAL ! CTO (input) REAL ! 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) REAL 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 .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: done INTEGER :: i, itype, j, k1, k2, k3, k4 REAL :: bignum, cfrom1, cfromc, cto1, ctoc, mul, smlnum ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. 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 == -1 ) THEN info = -1 ELSE IF( cfrom == zero ) THEN info = -4 ELSE IF( m < 0 ) THEN info = -6 ELSE IF( n < 0 .OR. ( itype == 4 .AND. n /= m ) .OR. & ( itype == 5 .AND. n /= m ) ) THEN info = -7 ELSE IF( itype <= 3 .AND. lda < MAX( 1, m ) ) THEN info = -9 ELSE IF( itype >= 4 ) THEN IF( kl < 0 .OR. kl > MAX( m-1, 0 ) ) THEN info = -2 ELSE IF( ku < 0 .OR. ku > MAX( n-1, 0 ) .OR. & ( ( itype == 4 .OR. itype == 5 ) .AND. kl /= ku ) ) THEN info = -3 ELSE IF( ( itype == 4 .AND. lda < kl+1 ) .OR. & ( itype == 5 .AND. lda < ku+1 ) .OR. & ( itype == 6 .AND. lda < 2*kl+ku+1 ) ) THEN info = -9 END IF END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SLASCL', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. m == 0 ) RETURN ! ! Get machine parameters ! smlnum = slamch( 'S' ) bignum = one / smlnum ! cfromc = cfrom ctoc = cto ! 10 CONTINUE cfrom1 = cfromc*smlnum cto1 = ctoc / bignum IF( ABS( cfrom1 ) > ABS( ctoc ) .AND. ctoc /= zero ) THEN mul = smlnum done = .false. cfromc = cfrom1 ELSE IF( ABS( cto1 ) > ABS( cfromc ) ) THEN mul = bignum done = .false. ctoc = cto1 ELSE mul = ctoc / cfromc done = .true. END IF ! IF( itype == 0 ) THEN ! ! Full matrix ! DO j = 1, n DO i = 1, m a( i, j ) = a( i, j )*mul END DO END DO ! ELSE IF( itype == 1 ) THEN ! ! Lower triangular matrix ! DO j = 1, n DO i = j, m a( i, j ) = a( i, j )*mul END DO END DO ! ELSE IF( itype == 2 ) THEN ! ! Upper triangular matrix ! DO j = 1, n DO i = 1, MIN( j, m ) a( i, j ) = a( i, j )*mul END DO END DO ! ELSE IF( itype == 3 ) THEN ! ! Upper Hessenberg matrix ! DO j = 1, n DO i = 1, MIN( j+1, m ) a( i, j ) = a( i, j )*mul END DO END DO ! ELSE IF( itype == 4 ) THEN ! ! Lower half of a symmetric band matrix ! k3 = kl + 1 k4 = n + 1 DO j = 1, n DO i = 1, MIN( k3, k4-j ) a( i, j ) = a( i, j )*mul END DO END DO ! ELSE IF( itype == 5 ) THEN ! ! Upper half of a symmetric band matrix ! k1 = ku + 2 k3 = ku + 1 DO j = 1, n DO i = MAX( k1-j, 1 ), k3 a( i, j ) = a( i, j )*mul END DO END DO ! ELSE IF( itype == 6 ) THEN ! ! Band matrix ! k1 = kl + ku + 2 k2 = kl + 1 k3 = 2*kl + ku + 1 k4 = kl + ku + 1 + m DO j = 1, n DO i = MAX( k1-j, k2 ), MIN( k3, k4-j ) a( i, j ) = a( i, j )*mul END DO END DO ! END IF ! IF( .NOT.done ) GO TO 10 ! RETURN ! ! End of SLASCL ! END SUBROUTINE slascl SUBROUTINE slasd0( n, sqre, d, e, u, ldu, vt, ldvt, smlsiz, iwork, & work, 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, INTENT(IN) :: n INTEGER, INTENT(IN) :: sqre REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: e( * ) REAL, INTENT(IN OUT) :: u( ldu, * ) INTEGER, INTENT(IN) :: ldu REAL, INTENT(IN OUT) :: vt( ldvt, * ) INTEGER, INTENT(IN OUT) :: ldvt INTEGER, INTENT(IN) :: smlsiz INTEGER, INTENT(IN OUT) :: iwork( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! Using a divide and conquer approach, SLASD0 computes the singular ! value decomposition (SVD) of a real upper bidiagonal N-by-M ! matrix B with diagonal D and offdiagonal E, where M = N + SQRE. ! The algorithm computes orthogonal matrices U and VT such that ! B = U * S * VT. The singular values S are overwritten on D. ! ! A related subroutine, SLASDA, computes only the singular values, ! and optionally, the singular vectors in compact form. ! ! Arguments ! ========= ! ! N (input) INTEGER ! On entry, the row dimension of the upper bidiagonal matrix. ! This is also the dimension of the main diagonal array D. ! ! SQRE (input) INTEGER ! Specifies the column dimension of the bidiagonal matrix. ! = 0: The bidiagonal matrix has column dimension M = N; ! = 1: The bidiagonal matrix has column dimension M = N+1; ! ! D (input/output) REAL array, dimension (N) ! On entry D contains the main diagonal of the bidiagonal ! matrix. ! On exit D, if INFO = 0, contains its singular values. ! ! E (input) REAL array, dimension (M-1) ! Contains the subdiagonal entries of the bidiagonal matrix. ! On exit, E has been destroyed. ! ! U (output) REAL array, dimension at least (LDQ, N) ! On exit, U contains the left singular vectors. ! ! LDU (input) INTEGER ! On entry, leading dimension of U. ! ! VT (output) REAL array, dimension at least (LDVT, M) ! On exit, VT' contains the right singular vectors. ! ! LDVT (input) INTEGER ! On entry, leading dimension of VT. ! ! SMLSIZ (input) INTEGER ! On entry, maximum size of the subproblems at the ! bottom of the computation tree. ! ! IWORK INTEGER work array. ! Dimension must be at least (8 * N) ! ! WORK REAL work array. ! Dimension must be at least (3 * M**2 + 2 * M) ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if INFO = 1, an singular value did not converge ! ! Further Details ! =============== ! ! Based on contributions by ! Ming Gu and Huan Ren, Computer Science Division, University of ! California at Berkeley, USA ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER :: i, i1, ic, idxq, idxqc, im1, inode, itemp, iwk, & j, lf, ll, lvl, m, ncc, nd, ndb1, ndiml, ndimr, & nl, nlf, nlp1, nlvl, nr, nrf, nrp1, sqrei REAL :: alpha, beta ! .. ! .. External Subroutines .. EXTERNAL slasd1, slasdq, slasdt, xerbla ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( n < 0 ) THEN info = -1 ELSE IF( ( sqre < 0 ) .OR. ( sqre > 1 ) ) THEN info = -2 END IF ! m = n + sqre ! IF( ldu < n ) THEN info = -6 ELSE IF( ldvt < m ) THEN info = -8 ELSE IF( smlsiz < 3 ) THEN info = -9 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLASD0', -info ) RETURN END IF ! ! If the input matrix is too small, call SLASDQ to find the SVD. ! IF( n <= smlsiz ) THEN CALL slasdq( 'U', sqre, n, m, n, 0, d, e, vt, ldvt, u, ldu, u, & ldu, work, info ) RETURN END IF ! ! Set up the computation tree. ! inode = 1 ndiml = inode + n ndimr = ndiml + n idxq = ndimr + n iwk = idxq + n CALL slasdt( n, nlvl, nd, iwork( inode ), iwork( ndiml ), & iwork( ndimr ), smlsiz ) ! ! For the nodes on bottom level of the tree, solve ! their subproblems by SLASDQ. ! ndb1 = ( nd+1 ) / 2 ncc = 0 DO i = ndb1, nd ! ! IC : center row of each node ! NL : number of rows of left subproblem ! NR : number of rows of right subproblem ! NLF: starting row of the left subproblem ! NRF: starting row of the right subproblem ! i1 = i - 1 ic = iwork( inode+i1 ) nl = iwork( ndiml+i1 ) nlp1 = nl + 1 nr = iwork( ndimr+i1 ) nrp1 = nr + 1 nlf = ic - nl nrf = ic + 1 sqrei = 1 CALL slasdq( 'U', sqrei, nl, nlp1, nl, ncc, d( nlf ), e( nlf ), & vt( nlf, nlf ), ldvt, u( nlf, nlf ), ldu, u( nlf, nlf ), ldu, work, info ) IF( info /= 0 ) THEN RETURN END IF itemp = idxq + nlf - 2 DO j = 1, nl iwork( itemp+j ) = j END DO IF( i == nd ) THEN sqrei = sqre ELSE sqrei = 1 END IF nrp1 = nr + sqrei CALL slasdq( 'U', sqrei, nr, nrp1, nr, ncc, d( nrf ), e( nrf ), & vt( nrf, nrf ), ldvt, u( nrf, nrf ), ldu, u( nrf, nrf ), ldu, work, info ) IF( info /= 0 ) THEN RETURN END IF itemp = idxq + ic DO j = 1, nr iwork( itemp+j-1 ) = j END DO END DO ! ! Now conquer each subproblem bottom-up. ! DO lvl = nlvl, 1, -1 ! ! Find the first node LF and last node LL on the ! current level LVL. ! IF( lvl == 1 ) THEN lf = 1 ll = 1 ELSE lf = 2**( lvl-1 ) ll = 2*lf - 1 END IF DO i = lf, ll im1 = i - 1 ic = iwork( inode+im1 ) nl = iwork( ndiml+im1 ) nr = iwork( ndimr+im1 ) nlf = ic - nl IF( ( sqre == 0 ) .AND. ( i == ll ) ) THEN sqrei = sqre ELSE sqrei = 1 END IF idxqc = idxq + nlf - 1 alpha = d( ic ) beta = e( ic ) CALL slasd1( nl, nr, sqrei, d( nlf ), alpha, beta, & u( nlf, nlf ), ldu, vt( nlf, nlf ), ldvt, & iwork( idxqc ), iwork( iwk ), work, info ) IF( info /= 0 ) THEN RETURN END IF END DO END DO ! RETURN ! ! End of SLASD0 ! END SUBROUTINE slasd0 SUBROUTINE slasd1( nl, nr, sqre, d, alpha, beta, u, ldu, vt, ldvt, & idxq, iwork, work, 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, INTENT(IN OUT) :: nl INTEGER, INTENT(IN) :: nr INTEGER, INTENT(IN) :: sqre REAL, INTENT(OUT) :: d( * ) REAL, INTENT(IN OUT) :: alpha REAL, INTENT(IN OUT) :: beta REAL, INTENT(IN OUT) :: u( ldu, * ) INTEGER, INTENT(IN OUT) :: ldu REAL, INTENT(IN OUT) :: vt( ldvt, * ) INTEGER, INTENT(IN OUT) :: ldvt INTEGER, INTENT(IN OUT) :: idxq( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B, ! where N = NL + NR + 1 and M = N + SQRE. SLASD1 is called from SLASD0. ! ! A related subroutine SLASD7 handles the case in which the singular ! values (and the singular vectors in factored form) are desired. ! ! SLASD1 computes the SVD as follows: ! ! ( D1(in) 0 0 0 ) ! B = U(in) * ( Z1' a Z2' b ) * VT(in) ! ( 0 0 D2(in) 0 ) ! ! = U(out) * ( D(out) 0) * VT(out) ! ! where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M ! with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros ! elsewhere; and the entry b is empty if SQRE = 0. ! ! The left singular vectors of the original matrix are stored in U, and ! the transpose of the right singular vectors are stored in VT, and the ! singular values are in D. The algorithm consists of three stages: ! ! The first stage consists of deflating the size of the problem ! when there are multiple singular values or when there are zeros in ! the Z vector. For each such occurence the dimension of the ! secular equation problem is reduced by one. This stage is ! performed by the routine SLASD2. ! ! The second stage consists of calculating the updated ! singular values. This is done by finding the square roots of the ! roots of the secular equation via the routine SLASD4 (as called ! by SLASD3). This routine also calculates the singular vectors of ! the current problem. ! ! The final stage consists of computing the updated singular vectors ! directly using the updated singular values. The singular vectors ! for the current problem are multiplied with the singular vectors ! from the overall problem. ! ! Arguments ! ========= ! ! NL (input) INTEGER ! The row dimension of the upper block. NL >= 1. ! ! NR (input) INTEGER ! The row dimension of the lower block. NR >= 1. ! ! SQRE (input) INTEGER ! = 0: the lower block is an NR-by-NR square matrix. ! = 1: the lower block is an NR-by-(NR+1) rectangular matrix. ! ! The bidiagonal matrix has row dimension N = NL + NR + 1, ! and column dimension M = N + SQRE. ! ! D (input/output) REAL array, ! dimension (N = NL+NR+1). ! On entry D(1:NL,1:NL) contains the singular values of the ! upper block; and D(NL+2:N) contains the singular values of ! the lower block. On exit D(1:N) contains the singular values ! of the modified matrix. ! ! ALPHA (input) REAL ! Contains the diagonal element associated with the added row. ! ! BETA (input) REAL ! Contains the off-diagonal element associated with the added ! row. ! ! U (input/output) REAL array, dimension(LDU,N) ! On entry U(1:NL, 1:NL) contains the left singular vectors of ! the upper block; U(NL+2:N, NL+2:N) contains the left singular ! vectors of the lower block. On exit U contains the left ! singular vectors of the bidiagonal matrix. ! ! LDU (input) INTEGER ! The leading dimension of the array U. LDU >= max( 1, N ). ! ! VT (input/output) REAL array, dimension(LDVT,M) ! where M = N + SQRE. ! On entry VT(1:NL+1, 1:NL+1)' contains the right singular ! vectors of the upper block; VT(NL+2:M, NL+2:M)' contains ! the right singular vectors of the lower block. On exit ! VT' contains the right singular vectors of the ! bidiagonal matrix. ! ! LDVT (input) INTEGER ! The leading dimension of the array VT. LDVT >= max( 1, M ). ! ! IDXQ (output) INTEGER array, dimension(N) ! This contains the permutation which will reintegrate the ! subproblem just solved back into sorted order, i.e. ! D( IDXQ( I = 1, N ) ) will be in ascending order. ! ! IWORK (workspace) INTEGER array, dimension( 4 * N ) ! ! WORK (workspace) REAL array, dimension( 3*M**2 + 2*M ) ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if INFO = 1, an singular value did not converge ! ! Further Details ! =============== ! ! Based on contributions by ! Ming Gu and Huan Ren, Computer Science Division, University of ! California at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. ! REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: coltyp, i, idx, idxc, idxp, iq, isigma, iu2, & ivt2, iz, k, ldq, ldu2, ldvt2, m, n, n1, n2 REAL :: orgnrm ! .. ! .. External Subroutines .. EXTERNAL slamrg, slascl, slasd2, slasd3, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( nl < 1 ) THEN info = -1 ELSE IF( nr < 1 ) THEN info = -2 ELSE IF( ( sqre < 0 ) .OR. ( sqre > 1 ) ) THEN info = -3 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLASD1', -info ) RETURN END IF ! n = nl + nr + 1 m = n + sqre ! ! The following values are for bookkeeping purposes only. They are ! integer pointers which indicate the portion of the workspace ! used by a particular array in SLASD2 and SLASD3. ! ldu2 = n ldvt2 = m ! iz = 1 isigma = iz + m iu2 = isigma + n ivt2 = iu2 + ldu2*n iq = ivt2 + ldvt2*m ! idx = 1 idxc = idx + n coltyp = idxc + n idxp = coltyp + n ! ! Scale. ! orgnrm = MAX( ABS( alpha ), ABS( beta ) ) d( nl+1 ) = zero DO i = 1, n IF( ABS( d( i ) ) > orgnrm ) THEN orgnrm = ABS( d( i ) ) END IF END DO CALL slascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) alpha = alpha / orgnrm beta = beta / orgnrm ! ! Deflate singular values. ! CALL slasd2( nl, nr, sqre, k, d, work( iz ), alpha, beta, u, ldu, & vt, ldvt, work( isigma ), work( iu2 ), ldu2, & work( ivt2 ), ldvt2, iwork( idxp ), iwork( idx ), & iwork( idxc ), idxq, iwork( coltyp ), info ) ! ! Solve Secular Equation and update singular vectors. ! ldq = k CALL slasd3( nl, nr, sqre, k, d, work( iq ), ldq, work( isigma ), & u, ldu, work( iu2 ), ldu2, vt, ldvt, work( ivt2 ), & ldvt2, iwork( idxc ), iwork( coltyp ), work( iz ), info ) IF( info /= 0 ) THEN RETURN END IF ! ! Unscale. ! CALL slascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) ! ! Prepare the IDXQ sorting permutation. ! n1 = k n2 = n - k CALL slamrg( n1, n2, d, 1, -1, idxq ) ! RETURN ! ! End of SLASD1 ! END SUBROUTINE slasd1 SUBROUTINE slasd2( nl, nr, sqre, k, d, z, alpha, beta, u, ldu, vt, & ldvt, dsigma, u2, ldu2, vt2, ldvt2, idxp, idx, idxc, idxq, coltyp, info ) ! ! -- LAPACK auxiliary routine (version 3.0) -- ! Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, ! Courant Institute, NAG Ltd., and Rice University ! June 30, 1999 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: nl INTEGER, INTENT(IN) :: nr INTEGER, INTENT(IN) :: sqre INTEGER, INTENT(OUT) :: k REAL, INTENT(OUT) :: d( * ) REAL, INTENT(OUT) :: z( * ) REAL, INTENT(IN) :: alpha REAL, INTENT(IN) :: beta REAL, INTENT(IN OUT) :: u( ldu, * ) INTEGER, INTENT(IN) :: ldu REAL, INTENT(IN OUT) :: vt( ldvt, * ) INTEGER, INTENT(IN OUT) :: ldvt REAL, INTENT(OUT) :: dsigma( * ) REAL, INTENT(OUT) :: u2( ldu2, * ) INTEGER, INTENT(IN OUT) :: ldu2 REAL, INTENT(OUT) :: vt2( ldvt2, * ) INTEGER, INTENT(IN OUT) :: ldvt2 INTEGER, INTENT(OUT) :: idxp( * ) INTEGER, INTENT(IN) :: idx( * ) INTEGER, INTENT(OUT) :: idxc( * ) INTEGER, INTENT(OUT) :: idxq( * ) INTEGER, INTENT(OUT) :: coltyp( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLASD2 merges the two sets of singular values together into a single ! sorted set. Then it tries to deflate the size of the problem. ! There are two ways in which deflation can occur: when two or more ! singular values are close together or if there is a tiny entry in the ! Z vector. For each such occurrence the order of the related secular ! equation problem is reduced by one. ! ! SLASD2 is called from SLASD1. ! ! Arguments ! ========= ! ! NL (input) INTEGER ! The row dimension of the upper block. NL >= 1. ! ! NR (input) INTEGER ! The row dimension of the lower block. NR >= 1. ! ! SQRE (input) INTEGER ! = 0: the lower block is an NR-by-NR square matrix. ! = 1: the lower block is an NR-by-(NR+1) rectangular matrix. ! ! The bidiagonal matrix has N = NL + NR + 1 rows and ! M = N + SQRE >= N columns. ! ! K (output) INTEGER ! Contains the dimension of the non-deflated matrix, ! This is the order of the related secular equation. 1 <= K <=N. ! ! D (input/output) REAL array, dimension(N) ! On entry D contains the singular values of the two submatrices ! to be combined. On exit D contains the trailing (N-K) updated ! singular values (those which were deflated) sorted into ! increasing order. ! ! ALPHA (input) REAL ! Contains the diagonal element associated with the added row. ! ! BETA (input) REAL ! Contains the off-diagonal element associated with the added ! row. ! ! U (input/output) REAL array, dimension(LDU,N) ! On entry U contains the left singular vectors of two ! submatrices in the two square blocks with corners at (1,1), ! (NL, NL), and (NL+2, NL+2), (N,N). ! On exit U contains the trailing (N-K) updated left singular ! vectors (those which were deflated) in its last N-K columns. ! ! LDU (input) INTEGER ! The leading dimension of the array U. LDU >= N. ! ! Z (output) REAL array, dimension(N) ! On exit Z contains the updating row vector in the secular ! equation. ! ! DSIGMA (output) REAL array, dimension (N) ! Contains a copy of the diagonal elements (K-1 singular values ! and one zero) in the secular equation. ! ! U2 (output) REAL array, dimension(LDU2,N) ! Contains a copy of the first K-1 left singular vectors which ! will be used by SLASD3 in a matrix multiply (SGEMM) to solve ! for the new left singular vectors. U2 is arranged into four ! blocks. The first block contains a column with 1 at NL+1 and ! zero everywhere else; the second block contains non-zero ! entries only at and above NL; the third contains non-zero ! entries only below NL+1; and the fourth is dense. ! ! LDU2 (input) INTEGER ! The leading dimension of the array U2. LDU2 >= N. ! ! VT (input/output) REAL array, dimension(LDVT,M) ! On entry VT' contains the right singular vectors of two ! submatrices in the two square blocks with corners at (1,1), ! (NL+1, NL+1), and (NL+2, NL+2), (M,M). ! On exit VT' contains the trailing (N-K) updated right singular ! vectors (those which were deflated) in its last N-K columns. ! In case SQRE =1, the last row of VT spans the right null ! space. ! ! LDVT (input) INTEGER ! The leading dimension of the array VT. LDVT >= M. ! ! VT2 (output) REAL array, dimension(LDVT2,N) ! VT2' contains a copy of the first K right singular vectors ! which will be used by SLASD3 in a matrix multiply (SGEMM) to ! solve for the new right singular vectors. VT2 is arranged into ! three blocks. The first block contains a row that corresponds ! to the special 0 diagonal element in SIGMA; the second block ! contains non-zeros only at and before NL +1; the third block ! contains non-zeros only at and after NL +2. ! ! LDVT2 (input) INTEGER ! The leading dimension of the array VT2. LDVT2 >= M. ! ! IDXP (workspace) INTEGER array, dimension(N) ! This will contain the permutation used to place deflated ! values of D at the end of the array. On output IDXP(2:K) ! points to the nondeflated D-values and IDXP(K+1:N) ! points to the deflated singular values. ! ! IDX (workspace) INTEGER array, dimension(N) ! This will contain the permutation used to sort the contents of ! D into ascending order. ! ! IDXC (output) INTEGER array, dimension(N) ! This will contain the permutation used to arrange the columns ! of the deflated U matrix into three groups: the first group ! contains non-zero entries only at and above NL, the second ! contains non-zero entries only below NL+2, and the third is ! dense. ! ! COLTYP (workspace/output) INTEGER array, dimension(N) ! As workspace, this will contain a label which will indicate ! which of the following types a column in the U2 matrix or a ! row in the VT2 matrix is: ! 1 : non-zero in the upper half only ! 2 : non-zero in the lower half only ! 3 : dense ! 4 : deflated ! ! On exit, it is an array of dimension 4, with COLTYP(I) being ! the dimension of the I-th type columns. ! ! IDXQ (input) INTEGER array, dimension(N) ! This contains the permutation which separately sorts the two ! sub-problems in D into ascending order. Note that entries in ! the first hlaf of this permutation must first be moved one ! position backward; and entries in the second half ! must first have NL+1 added to their values. ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! ! Further Details ! =============== ! ! Based on contributions by ! Ming Gu and Huan Ren, Computer Science Division, University of ! California at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 REAL, PARAMETER :: eight = 8.0E+0 ! .. ! .. Local Arrays .. INTEGER :: ctot( 4 ), psm( 4 ) ! .. ! .. Local Scalars .. INTEGER :: ct, i, idxi, idxj, idxjp, j, jp, jprev, k2, m, n, nlp1, nlp2 REAL :: c, eps, hlftol, s, tau, tol, z1 ! .. ! .. External Functions .. REAL :: slamch, slapy2 EXTERNAL slamch, slapy2 ! .. ! .. External Subroutines .. EXTERNAL scopy, slacpy, slamrg, slaset, srot, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( nl < 1 ) THEN info = -1 ELSE IF( nr < 1 ) THEN info = -2 ELSE IF( ( sqre /= 1 ) .AND. ( sqre /= 0 ) ) THEN info = -3 END IF ! n = nl + nr + 1 m = n + sqre ! IF( ldu < n ) THEN info = -10 ELSE IF( ldvt < m ) THEN info = -12 ELSE IF( ldu2 < n ) THEN info = -15 ELSE IF( ldvt2 < m ) THEN info = -17 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLASD2', -info ) RETURN END IF ! nlp1 = nl + 1 nlp2 = nl + 2 ! ! Generate the first part of the vector Z; and move the singular ! values in the first part of D one position backward. ! z1 = alpha*vt( nlp1, nlp1 ) z( 1 ) = z1 DO i = nl, 1, -1 z( i+1 ) = alpha*vt( i, nlp1 ) d( i+1 ) = d( i ) idxq( i+1 ) = idxq( i ) + 1 END DO ! ! Generate the second part of the vector Z. ! DO i = nlp2, m z( i ) = beta*vt( i, nlp2 ) END DO ! ! Initialize some reference arrays. ! DO i = 2, nlp1 coltyp( i ) = 1 END DO DO i = nlp2, n coltyp( i ) = 2 END DO ! ! Sort the singular values into increasing order ! DO i = nlp2, n idxq( i ) = idxq( i ) + nlp1 END DO ! ! DSIGMA, IDXC, IDXC, and the first column of U2 ! are used as storage space. ! DO i = 2, n dsigma( i ) = d( idxq( i ) ) u2( i, 1 ) = z( idxq( i ) ) idxc( i ) = coltyp( idxq( i ) ) END DO ! CALL slamrg( nl, nr, dsigma( 2 ), 1, 1, idx( 2 ) ) ! DO i = 2, n idxi = 1 + idx( i ) d( i ) = dsigma( idxi ) z( i ) = u2( idxi, 1 ) coltyp( i ) = idxc( idxi ) END DO ! ! Calculate the allowable deflation tolerance ! eps = slamch( 'Epsilon' ) tol = MAX( ABS( alpha ), ABS( beta ) ) tol = eight*eps*MAX( ABS( d( n ) ), tol ) ! ! There are 2 kinds of deflation -- first a value in the z-vector ! is small, second two (or more) singular values are very close ! together (their difference is small). ! ! If the value in the z-vector is small, we simply permute the ! array so that the corresponding singular value is moved to the ! end. ! ! If two values in the D-vector are close, we perform a two-sided ! rotation designed to make one of the corresponding z-vector ! entries zero, and then permute the array so that the deflated ! singular value is moved to the end. ! ! If there are multiple singular values then the problem deflates. ! Here the number of equal singular values are found. As each equal ! singular value is found, an elementary reflector is computed to ! rotate the corresponding singular subspace so that the ! corresponding components of Z are zero in this new basis. ! k = 1 k2 = n + 1 DO j = 2, n IF( ABS( z( j ) ) <= tol ) THEN ! ! Deflate due to small z component. ! k2 = k2 - 1 idxp( k2 ) = j coltyp( j ) = 4 IF( j == n ) GO TO 120 ELSE jprev = j EXIT END IF END DO 90 CONTINUE j = jprev 100 CONTINUE j = j + 1 IF( j > n ) GO TO 110 IF( ABS( z( j ) ) <= tol ) THEN ! ! Deflate due to small z component. ! k2 = k2 - 1 idxp( k2 ) = j coltyp( j ) = 4 ELSE ! ! Check if singular values are close enough to allow deflation. ! IF( ABS( d( j )-d( jprev ) ) <= tol ) THEN ! ! Deflation is possible. ! s = z( jprev ) c = z( j ) ! ! Find sqrt(a**2+b**2) without overflow or ! destructive underflow. ! tau = slapy2( c, s ) c = c / tau s = -s / tau z( j ) = tau z( jprev ) = zero ! ! Apply back the Givens rotation to the left and right ! singular vector matrices. ! idxjp = idxq( idx( jprev )+1 ) idxj = idxq( idx( j )+1 ) IF( idxjp <= nlp1 ) THEN idxjp = idxjp - 1 END IF IF( idxj <= nlp1 ) THEN idxj = idxj - 1 END IF CALL srot( n, u( 1, idxjp ), 1, u( 1, idxj ), 1, c, s ) CALL srot( m, vt( idxjp, 1 ), ldvt, vt( idxj, 1 ), ldvt, c, s ) IF( coltyp( j ) /= coltyp( jprev ) ) THEN coltyp( j ) = 3 END IF coltyp( jprev ) = 4 k2 = k2 - 1 idxp( k2 ) = jprev jprev = j ELSE k = k + 1 u2( k, 1 ) = z( jprev ) dsigma( k ) = d( jprev ) idxp( k ) = jprev jprev = j END IF END IF GO TO 100 110 CONTINUE ! ! Record the last singular value. ! k = k + 1 u2( k, 1 ) = z( jprev ) dsigma( k ) = d( jprev ) idxp( k ) = jprev ! 120 CONTINUE ! ! Count up the total number of the various types of columns, then ! form a permutation which positions the four column types into ! four groups of uniform structure (although one or more of these ! groups may be empty). ! DO j = 1, 4 ctot( j ) = 0 END DO DO j = 2, n ct = coltyp( j ) ctot( ct ) = ctot( ct ) + 1 END DO ! ! PSM(*) = Position in SubMatrix (of types 1 through 4) ! psm( 1 ) = 2 psm( 2 ) = 2 + ctot( 1 ) psm( 3 ) = psm( 2 ) + ctot( 2 ) psm( 4 ) = psm( 3 ) + ctot( 3 ) ! ! Fill out the IDXC array so that the permutation which it induces ! will place all type-1 columns first, all type-2 columns next, ! then all type-3's, and finally all type-4's, starting from the ! second column. This applies similarly to the rows of VT. ! DO j = 2, n jp = idxp( j ) ct = coltyp( jp ) idxc( psm( ct ) ) = j psm( ct ) = psm( ct ) + 1 END DO ! ! Sort the singular values and corresponding singular vectors into ! DSIGMA, U2, and VT2 respectively. The singular values/vectors ! which were not deflated go into the first K slots of DSIGMA, U2, ! and VT2 respectively, while those which were deflated go into the ! last N - K slots, except that the first column/row will be treated ! separately. ! DO j = 2, n jp = idxp( j ) dsigma( j ) = d( jp ) idxj = idxq( idx( idxp( idxc( j ) ) )+1 ) IF( idxj <= nlp1 ) THEN idxj = idxj - 1 END IF CALL scopy( n, u( 1, idxj ), 1, u2( 1, j ), 1 ) CALL scopy( m, vt( idxj, 1 ), ldvt, vt2( j, 1 ), ldvt2 ) END DO ! ! Determine DSIGMA(1), DSIGMA(2) and Z(1) ! dsigma( 1 ) = zero hlftol = tol / two IF( ABS( dsigma( 2 ) ) <= hlftol ) dsigma( 2 ) = hlftol IF( m > n ) THEN z( 1 ) = slapy2( z1, z( m ) ) IF( z( 1 ) <= tol ) THEN c = one s = zero z( 1 ) = tol ELSE c = z1 / z( 1 ) s = z( m ) / z( 1 ) END IF ELSE IF( ABS( z1 ) <= tol ) THEN z( 1 ) = tol ELSE z( 1 ) = z1 END IF END IF ! ! Move the rest of the updating row to Z. ! CALL scopy( k-1, u2( 2, 1 ), 1, z( 2 ), 1 ) ! ! Determine the first column of U2, the first row of VT2 and the ! last row of VT. ! CALL slaset( 'A', n, 1, zero, zero, u2, ldu2 ) u2( nlp1, 1 ) = one IF( m > n ) THEN DO i = 1, nlp1 vt( m, i ) = -s*vt( nlp1, i ) vt2( 1, i ) = c*vt( nlp1, i ) END DO DO i = nlp2, m vt2( 1, i ) = s*vt( m, i ) vt( m, i ) = c*vt( m, i ) END DO ELSE CALL scopy( m, vt( nlp1, 1 ), ldvt, vt2( 1, 1 ), ldvt2 ) END IF IF( m > n ) THEN CALL scopy( m, vt( m, 1 ), ldvt, vt2( m, 1 ), ldvt2 ) END IF ! ! The deflated singular values and their corresponding vectors go ! into the back of D, U, and V respectively. ! CALL scopy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 ) CALL slacpy( 'A', n, n-k, u2( 1, k+1 ), ldu2, u( 1, k+1 ), ldu ) CALL slacpy( 'A', n-k, m, vt2( k+1, 1 ), ldvt2, vt( k+1, 1 ), ldvt ) ! ! Copy CTOT into COLTYP for referencing in SLASD3. ! DO j = 1, 4 coltyp( j ) = ctot( j ) END DO ! RETURN ! ! End of SLASD2 ! END SUBROUTINE slasd2 SUBROUTINE slasd3( nl, nr, sqre, k, d, q, ldq, dsigma, u, ldu, u2, & ldu2, vt, ldvt, vt2, ldvt2, idxc, ctot, z, info ) ! ! -- LAPACK auxiliary routine (version 3.0) -- ! Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, ! Courant Institute, NAG Ltd., and Rice University ! June 30, 1999 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: nl INTEGER, INTENT(IN) :: nr INTEGER, INTENT(IN) :: sqre INTEGER, INTENT(IN) :: k REAL, INTENT(OUT) :: d( * ) REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq REAL, INTENT(OUT) :: dsigma( * ) REAL, INTENT(OUT) :: u( ldu, * ) INTEGER, INTENT(IN OUT) :: ldu REAL, INTENT(IN) :: u2( ldu2, * ) INTEGER, INTENT(IN OUT) :: ldu2 REAL, INTENT(IN OUT) :: vt( ldvt, * ) INTEGER, INTENT(IN OUT) :: ldvt REAL, INTENT(OUT) :: vt2( ldvt2, * ) INTEGER, INTENT(IN OUT) :: ldvt2 INTEGER, INTENT(IN) :: idxc( * ) INTEGER, INTENT(IN) :: ctot( * ) REAL, INTENT(IN OUT) :: z( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLASD3 finds all the square roots of the roots of the secular ! equation, as defined by the values in D and Z. It makes the ! appropriate calls to SLASD4 and then updates the singular ! vectors by matrix multiplication. ! ! This code makes very mild assumptions about floating point ! arithmetic. It will work on machines with a guard digit in ! add/subtract, or on those binary machines without guard digits ! which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. ! It could conceivably fail on hexadecimal or decimal machines ! without guard digits, but we know of none. ! ! SLASD3 is called from SLASD1. ! ! Arguments ! ========= ! ! NL (input) INTEGER ! The row dimension of the upper block. NL >= 1. ! ! NR (input) INTEGER ! The row dimension of the lower block. NR >= 1. ! ! SQRE (input) INTEGER ! = 0: the lower block is an NR-by-NR square matrix. ! = 1: the lower block is an NR-by-(NR+1) rectangular matrix. ! ! The bidiagonal matrix has N = NL + NR + 1 rows and ! M = N + SQRE >= N columns. ! ! K (input) INTEGER ! The size of the secular equation, 1 =< K = < N. ! ! D (output) REAL array, dimension(K) ! On exit the square roots of the roots of the secular equation, ! in ascending order. ! ! Q (workspace) REAL array, ! dimension at least (LDQ,K). ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. LDQ >= K. ! ! DSIGMA (input) REAL array, dimension(K) ! The first K elements of this array contain the old roots ! of the deflated updating problem. These are the poles ! of the secular equation. ! ! U (input) REAL array, dimension (LDU, N) ! The last N - K columns of this matrix contain the deflated ! left singular vectors. ! ! LDU (input) INTEGER ! The leading dimension of the array U. LDU >= N. ! ! U2 (input) REAL array, dimension (LDU2, N) ! The first K columns of this matrix contain the non-deflated ! left singular vectors for the split problem. ! ! LDU2 (input) INTEGER ! The leading dimension of the array U2. LDU2 >= N. ! ! VT (input) REAL array, dimension (LDVT, M) ! The last M - K columns of VT' contain the deflated ! right singular vectors. ! ! LDVT (input) INTEGER ! The leading dimension of the array VT. LDVT >= N. ! ! VT2 (input) REAL array, dimension (LDVT2, N) ! The first K columns of VT2' contain the non-deflated ! right singular vectors for the split problem. ! ! LDVT2 (input) INTEGER ! The leading dimension of the array VT2. LDVT2 >= N. ! ! IDXC (input) INTEGER array, dimension ( N ) ! The permutation used to arrange the columns of U (and rows of ! VT) into three groups: the first group contains non-zero ! entries only at and above (or before) NL +1; the second ! contains non-zero entries only at and below (or after) NL+2; ! and the third is dense. The first column of U and the row of ! VT are treated separately, however. ! ! The rows of the singular vectors found by SLASD4 ! must be likewise permuted before the matrix multiplies can ! take place. ! ! CTOT (input) INTEGER array, dimension ( 4 ) ! A count of the total number of the various types of columns ! in U (or rows in VT), as described in IDXC. The fourth column ! type is any column which has been deflated. ! ! Z (input) REAL array, dimension (K) ! The first K elements of this array contain the components ! of the deflation-adjusted updating row vector. ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if INFO = 1, an singular value did not converge ! ! Further Details ! =============== ! ! Based on contributions by ! Ming Gu and Huan Ren, Computer Science Division, University of ! California at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: negone = -1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: ctemp, i, j, jc, ktemp, m, n, nlp1, nlp2, nrp1 REAL :: rho, temp ! .. ! .. External Functions .. REAL :: slamc3, snrm2 EXTERNAL slamc3, snrm2 ! .. ! .. External Subroutines .. EXTERNAL scopy, sgemm, slacpy, slascl, slasd4, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( nl < 1 ) THEN info = -1 ELSE IF( nr < 1 ) THEN info = -2 ELSE IF( ( sqre /= 1 ) .AND. ( sqre /= 0 ) ) THEN info = -3 END IF ! n = nl + nr + 1 m = n + sqre nlp1 = nl + 1 nlp2 = nl + 2 ! IF( ( k < 1 ) .OR. ( k > n ) ) THEN info = -4 ELSE IF( ldq < k ) THEN info = -7 ELSE IF( ldu < n ) THEN info = -10 ELSE IF( ldu2 < n ) THEN info = -12 ELSE IF( ldvt < m ) THEN info = -14 ELSE IF( ldvt2 < m ) THEN info = -16 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLASD3', -info ) RETURN END IF ! ! Quick return if possible ! IF( k == 1 ) THEN d( 1 ) = ABS( z( 1 ) ) CALL scopy( m, vt2( 1, 1 ), ldvt2, vt( 1, 1 ), ldvt ) IF( z( 1 ) > zero ) THEN CALL scopy( n, u2( 1, 1 ), 1, u( 1, 1 ), 1 ) ELSE DO i = 1, n u( i, 1 ) = -u2( i, 1 ) END DO END IF RETURN END IF ! ! Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can ! be computed with high relative accuracy (barring over/underflow). ! This is a problem on machines without a guard digit in ! add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). ! The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), ! which on any of these machines zeros out the bottommost ! bit of DSIGMA(I) if it is 1; this makes the subsequent ! subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation ! occurs. On binary machines with a guard digit (almost all ! machines) it does not change DSIGMA(I) at all. On hexadecimal ! and decimal machines with a guard digit, it slightly ! changes the bottommost bits of DSIGMA(I). It does not account ! for hexadecimal or decimal machines without guard digits ! (we know of none). We use a subroutine call to compute ! 2*DLAMBDA(I) to prevent optimizing compilers from eliminating ! this code. ! DO i = 1, k dsigma( i ) = slamc3( dsigma( i ), dsigma( i ) ) - dsigma( i ) END DO ! ! Keep a copy of Z. ! CALL scopy( k, z, 1, q, 1 ) ! ! Normalize Z. ! rho = snrm2( k, z, 1 ) CALL slascl( 'G', 0, 0, rho, one, k, 1, z, k, info ) rho = rho*rho ! ! Find the new singular values. ! DO j = 1, k CALL slasd4( k, j, dsigma, z, u( 1, j ), rho, d( j ), vt( 1, j ), info ) ! ! If the zero finder fails, the computation is terminated. ! IF( info /= 0 ) THEN RETURN END IF END DO ! ! Compute updated Z. ! DO i = 1, k z( i ) = u( i, k )*vt( i, k ) DO j = 1, i - 1 z( i ) = z( i )*( u( i, j )*vt( i, j ) / ( dsigma( i )-dsigma( j ) ) / & ( dsigma( i )+dsigma( j ) ) ) END DO DO j = i, k - 1 z( i ) = z( i )*( u( i, j )*vt( i, j ) / & ( dsigma( i )-dsigma( j+1 ) ) / ( dsigma( i )+dsigma( j+1 ) ) ) END DO z( i ) = SIGN( SQRT( ABS( z( i ) ) ), q( i, 1 ) ) END DO ! ! Compute left singular vectors of the modified diagonal matrix, ! and store related information for the right singular vectors. ! DO i = 1, k vt( 1, i ) = z( 1 ) / u( 1, i ) / vt( 1, i ) u( 1, i ) = negone DO j = 2, k vt( j, i ) = z( j ) / u( j, i ) / vt( j, i ) u( j, i ) = dsigma( j )*vt( j, i ) END DO temp = snrm2( k, u( 1, i ), 1 ) q( 1, i ) = u( 1, i ) / temp DO j = 2, k jc = idxc( j ) q( j, i ) = u( jc, i ) / temp END DO END DO ! ! Update the left singular vector matrix. ! IF( k == 2 ) THEN CALL sgemm( 'N', 'N', n, k, k, one, u2, ldu2, q, ldq, zero, u, ldu ) GO TO 100 END IF IF( ctot( 1 ) > 0 ) THEN CALL sgemm( 'N', 'N', nl, k, ctot( 1 ), one, u2( 1, 2 ), ldu2, & q( 2, 1 ), ldq, zero, u( 1, 1 ), ldu ) IF( ctot( 3 ) > 0 ) THEN ktemp = 2 + ctot( 1 ) + ctot( 2 ) CALL sgemm( 'N', 'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ), & ldu2, q( ktemp, 1 ), ldq, one, u( 1, 1 ), ldu ) END IF ELSE IF( ctot( 3 ) > 0 ) THEN ktemp = 2 + ctot( 1 ) + ctot( 2 ) CALL sgemm( 'N', 'N', nl, k, ctot( 3 ), one, u2( 1, ktemp ), & ldu2, q( ktemp, 1 ), ldq, zero, u( 1, 1 ), ldu ) ELSE CALL slacpy( 'F', nl, k, u2, ldu2, u, ldu ) END IF CALL scopy( k, q( 1, 1 ), ldq, u( nlp1, 1 ), ldu ) ktemp = 2 + ctot( 1 ) ctemp = ctot( 2 ) + ctot( 3 ) CALL sgemm( 'N', 'N', nr, k, ctemp, one, u2( nlp2, ktemp ), ldu2, & q( ktemp, 1 ), ldq, zero, u( nlp2, 1 ), ldu ) ! ! Generate the right singular vectors. ! 100 CONTINUE DO i = 1, k temp = snrm2( k, vt( 1, i ), 1 ) q( i, 1 ) = vt( 1, i ) / temp DO j = 2, k jc = idxc( j ) q( i, j ) = vt( jc, i ) / temp END DO END DO ! ! Update the right singular vector matrix. ! IF( k == 2 ) THEN CALL sgemm( 'N', 'N', k, m, k, one, q, ldq, vt2, ldvt2, zero, vt, ldvt ) RETURN END IF ktemp = 1 + ctot( 1 ) CALL sgemm( 'N', 'N', k, nlp1, ktemp, one, q( 1, 1 ), ldq, & vt2( 1, 1 ), ldvt2, zero, vt( 1, 1 ), ldvt ) ktemp = 2 + ctot( 1 ) + ctot( 2 ) CALL sgemm( 'N', 'N', k, nlp1, ctot( 3 ), one, q( 1, ktemp ), ldq, & vt2( ktemp, 1 ), ldvt2, one, vt( 1, 1 ), ldvt ) ktemp = ctot( 1 ) + 1 nrp1 = nr + sqre IF( ktemp > 1 ) THEN DO i = 1, k q( i, ktemp ) = q( i, 1 ) END DO DO i = nlp2, m vt2( ktemp, i ) = vt2( 1, i ) END DO END IF ctemp = 1 + ctot( 2 ) + ctot( 3 ) CALL sgemm( 'N', 'N', k, nrp1, ctemp, one, q( 1, ktemp ), ldq, & vt2( ktemp, nlp2 ), ldvt2, zero, vt( 1, nlp2 ), ldvt ) ! RETURN ! ! End of SLASD3 ! END SUBROUTINE slasd3 SUBROUTINE slasd4( n, i, d, z, delta, rho, sigma, work, info ) ! ! -- LAPACK auxiliary routine (version 3.0) -- ! Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, ! Courant Institute, NAG Ltd., and Rice University ! June 30, 1999 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: i REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: z( * ) REAL, INTENT(OUT) :: delta( * ) REAL, INTENT(IN) :: rho REAL, INTENT(OUT) :: sigma REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! This subroutine computes the square root of the I-th updated ! eigenvalue of a positive symmetric rank-one modification to ! a positive diagonal matrix whose entries are given as the squares ! of the corresponding entries in the array d, and that ! ! 0 <= D(i) < D(j) for i < j ! ! and that RHO > 0. This is arranged by the calling routine, and is ! no loss in generality. The rank-one modified system is thus ! ! diag( D ) * diag( D ) + RHO * Z * Z_transpose. ! ! where we assume the Euclidean norm of Z is 1. ! ! The method consists of approximating the rational functions in the ! secular equation by simpler interpolating rational functions. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The length of all arrays. ! ! I (input) INTEGER ! The index of the eigenvalue to be computed. 1 <= I <= N. ! ! D (input) REAL array, dimension ( N ) ! The original eigenvalues. It is assumed that they are in ! order, 0 <= D(I) < D(J) for I < J. ! ! Z (input) REAL array, dimension ( N ) ! The components of the updating vector. ! ! DELTA (output) REAL array, dimension ( N ) ! If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th ! component. If N = 1, then DELTA(1) = 1. The vector DELTA ! contains the information necessary to construct the ! (singular) eigenvectors. ! ! RHO (input) REAL ! The scalar in the symmetric updating formula. ! ! SIGMA (output) REAL ! The computed lambda_I, the I-th updated eigenvalue. ! ! WORK (workspace) REAL array, dimension ( N ) ! If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th ! component. If N = 1, then WORK( 1 ) = 1. ! ! INFO (output) INTEGER ! = 0: successful exit ! > 0: if INFO = 1, the updating process failed. ! ! Internal Parameters ! =================== ! ! Logical variable ORGATI (origin-at-i?) is used for distinguishing ! whether D(i) or D(i+1) is treated as the origin. ! ! ORGATI = .true. origin at i ! ORGATI = .false. origin at i+1 ! ! Logical variable SWTCH3 (switch-for-3-poles?) is for noting ! if we are working with THREE poles! ! ! MAXIT is the maximum number of iterations allowed for each ! eigenvalue. ! ! Further Details ! =============== ! ! Based on contributions by ! Ren-Cang Li, Computer Science Division, University of California ! at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: maxit = 20 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 REAL, PARAMETER :: three = 3.0E+0 REAL, PARAMETER :: four = 4.0E+0 REAL, PARAMETER :: eight = 8.0E+0 REAL, PARAMETER :: ten = 10.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: orgati, swtch, swtch3 INTEGER :: ii, iim1, iip1, ip1, iter, j, niter REAL :: a, b, c, delsq, delsq2, dphi, dpsi, dtiim, & dtiip, dtipsq, dtisq, dtnsq, dtnsq1, dw, eps, & erretm, eta, phi, prew, psi, rhoinv, sg2lb, sg2ub, tau, temp, temp1, temp2, w ! .. ! .. Local Arrays .. REAL :: dd( 3 ), zz( 3 ) ! .. ! .. External Subroutines .. EXTERNAL slaed6, slasd5 ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Since this routine is called in an inner loop, we do no argument ! checking. ! ! Quick return for N=1 and 2. ! info = 0 IF( n == 1 ) THEN ! ! Presumably, I=1 upon entry ! sigma = SQRT( d( 1 )*d( 1 )+rho*z( 1 )*z( 1 ) ) delta( 1 ) = one work( 1 ) = one RETURN END IF IF( n == 2 ) THEN CALL slasd5( i, d, z, delta, rho, sigma, work ) RETURN END IF ! ! Compute machine epsilon ! eps = slamch( 'Epsilon' ) rhoinv = one / rho ! ! The case I = N ! IF( i == n ) THEN ! ! Initialize some basic variables ! ii = n - 1 niter = 1 ! ! Calculate initial guess ! temp = rho / two ! ! If ||Z||_2 is not one, then TEMP should be set to ! RHO * ||Z||_2^2 / TWO ! temp1 = temp / ( d( n )+SQRT( d( n )*d( n )+temp ) ) DO j = 1, n work( j ) = d( j ) + d( n ) + temp1 delta( j ) = ( d( j )-d( n ) ) - temp1 END DO ! psi = zero DO j = 1, n - 2 psi = psi + z( j )*z( j ) / ( delta( j )*work( j ) ) END DO ! c = rhoinv + psi w = c + z( ii )*z( ii ) / ( delta( ii )*work( ii ) ) + & z( n )*z( n ) / ( delta( n )*work( n ) ) ! IF( w <= zero ) THEN temp1 = SQRT( d( n )*d( n )+rho ) temp = z( n-1 )*z( n-1 ) / ( ( d( n-1 )+temp1 )* & ( d( n )-d( n-1 )+rho / ( d( n )+temp1 ) ) ) + z( n )*z( n ) / rho ! ! The following TAU is to approximate ! SIGMA_n^2 - D( N )*D( N ) ! IF( c <= temp ) THEN tau = rho ELSE delsq = ( d( n )-d( n-1 ) )*( d( n )+d( n-1 ) ) a = -c*delsq + z( n-1 )*z( n-1 ) + z( n )*z( n ) b = z( n )*z( n )*delsq IF( a < zero ) THEN tau = two*b / ( SQRT( a*a+four*b*c )-a ) ELSE tau = ( a+SQRT( a*a+four*b*c ) ) / ( two*c ) END IF END IF ! ! It can be proved that ! D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO ! ELSE delsq = ( d( n )-d( n-1 ) )*( d( n )+d( n-1 ) ) a = -c*delsq + z( n-1 )*z( n-1 ) + z( n )*z( n ) b = z( n )*z( n )*delsq ! ! The following TAU is to approximate ! SIGMA_n^2 - D( N )*D( N ) ! IF( a < zero ) THEN tau = two*b / ( SQRT( a*a+four*b*c )-a ) ELSE tau = ( a+SQRT( a*a+four*b*c ) ) / ( two*c ) END IF ! ! It can be proved that ! D(N)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2 ! END IF ! ! The following ETA is to approximate SIGMA_n - D( N ) ! eta = tau / ( d( n )+SQRT( d( n )*d( n )+tau ) ) ! sigma = d( n ) + eta DO j = 1, n delta( j ) = ( d( j )-d( i ) ) - eta work( j ) = d( j ) + d( i ) + eta END DO ! ! Evaluate PSI and the derivative DPSI ! dpsi = zero psi = zero erretm = zero DO j = 1, ii temp = z( j ) / ( delta( j )*work( j ) ) psi = psi + z( j )*temp dpsi = dpsi + temp*temp erretm = erretm + psi END DO erretm = ABS( erretm ) ! ! Evaluate PHI and the derivative DPHI ! temp = z( n ) / ( delta( n )*work( n ) ) phi = z( n )*temp dphi = temp*temp erretm = eight*( -phi-psi ) + erretm - phi + rhoinv + & ABS( tau )*( dpsi+dphi ) ! w = rhoinv + phi + psi ! ! Test for convergence ! IF( ABS( w ) <= eps*erretm ) THEN GO TO 240 END IF ! ! Calculate the new step ! niter = niter + 1 dtnsq1 = work( n-1 )*delta( n-1 ) dtnsq = work( n )*delta( n ) c = w - dtnsq1*dpsi - dtnsq*dphi a = ( dtnsq+dtnsq1 )*w - dtnsq*dtnsq1*( dpsi+dphi ) b = dtnsq*dtnsq1*w IF( c < zero ) c = ABS( c ) IF( c == zero ) THEN eta = rho - sigma*sigma ELSE IF( a >= zero ) THEN eta = ( a+SQRT( ABS( a*a-four*b*c ) ) ) / ( two*c ) ELSE eta = two*b / ( a-SQRT( ABS( a*a-four*b*c ) ) ) END IF ! ! Note, eta should be positive if w is negative, and ! eta should be negative otherwise. However, ! if for some reason caused by roundoff, eta*w > 0, ! we simply use one Newton step instead. This way ! will guarantee eta*w < 0. ! IF( w*eta > zero ) eta = -w / ( dpsi+dphi ) temp = eta - dtnsq IF( temp > rho ) eta = rho + dtnsq ! tau = tau + eta eta = eta / ( sigma+SQRT( eta+sigma*sigma ) ) DO j = 1, n delta( j ) = delta( j ) - eta work( j ) = work( j ) + eta END DO ! sigma = sigma + eta ! ! Evaluate PSI and the derivative DPSI ! dpsi = zero psi = zero erretm = zero DO j = 1, ii temp = z( j ) / ( work( j )*delta( j ) ) psi = psi + z( j )*temp dpsi = dpsi + temp*temp erretm = erretm + psi END DO erretm = ABS( erretm ) ! ! Evaluate PHI and the derivative DPHI ! temp = z( n ) / ( work( n )*delta( n ) ) phi = z( n )*temp dphi = temp*temp erretm = eight*( -phi-psi ) + erretm - phi + rhoinv + & ABS( tau )*( dpsi+dphi ) ! w = rhoinv + phi + psi ! ! Main loop to update the values of the array DELTA ! iter = niter + 1 ! DO niter = iter, maxit ! ! Test for convergence ! IF( ABS( w ) <= eps*erretm ) THEN GO TO 240 END IF ! ! Calculate the new step ! dtnsq1 = work( n-1 )*delta( n-1 ) dtnsq = work( n )*delta( n ) c = w - dtnsq1*dpsi - dtnsq*dphi a = ( dtnsq+dtnsq1 )*w - dtnsq1*dtnsq*( dpsi+dphi ) b = dtnsq1*dtnsq*w IF( a >= zero ) THEN eta = ( a+SQRT( ABS( a*a-four*b*c ) ) ) / ( two*c ) ELSE eta = two*b / ( a-SQRT( ABS( a*a-four*b*c ) ) ) END IF ! ! Note, eta should be positive if w is negative, and ! eta should be negative otherwise. However, ! if for some reason caused by roundoff, eta*w > 0, ! we simply use one Newton step instead. This way ! will guarantee eta*w < 0. ! IF( w*eta > zero ) eta = -w / ( dpsi+dphi ) temp = eta - dtnsq IF( temp <= zero ) eta = eta / two ! tau = tau + eta eta = eta / ( sigma+SQRT( eta+sigma*sigma ) ) DO j = 1, n delta( j ) = delta( j ) - eta work( j ) = work( j ) + eta END DO ! sigma = sigma + eta ! ! Evaluate PSI and the derivative DPSI ! dpsi = zero psi = zero erretm = zero DO j = 1, ii temp = z( j ) / ( work( j )*delta( j ) ) psi = psi + z( j )*temp dpsi = dpsi + temp*temp erretm = erretm + psi END DO erretm = ABS( erretm ) ! ! Evaluate PHI and the derivative DPHI ! temp = z( n ) / ( work( n )*delta( n ) ) phi = z( n )*temp dphi = temp*temp erretm = eight*( -phi-psi ) + erretm - phi + rhoinv + & ABS( tau )*( dpsi+dphi ) ! w = rhoinv + phi + psi END DO ! ! Return with INFO = 1, NITER = MAXIT and not converged ! info = 1 GO TO 240 ! ! End for the case I = N ! ELSE ! ! The case for I < N ! niter = 1 ip1 = i + 1 ! ! Calculate initial guess ! delsq = ( d( ip1 )-d( i ) )*( d( ip1 )+d( i ) ) delsq2 = delsq / two temp = delsq2 / ( d( i )+SQRT( d( i )*d( i )+delsq2 ) ) DO j = 1, n work( j ) = d( j ) + d( i ) + temp delta( j ) = ( d( j )-d( i ) ) - temp END DO ! psi = zero DO j = 1, i - 1 psi = psi + z( j )*z( j ) / ( work( j )*delta( j ) ) END DO ! phi = zero DO j = n, i + 2, -1 phi = phi + z( j )*z( j ) / ( work( j )*delta( j ) ) END DO c = rhoinv + psi + phi w = c + z( i )*z( i ) / ( work( i )*delta( i ) ) + & z( ip1 )*z( ip1 ) / ( work( ip1 )*delta( ip1 ) ) ! IF( w > zero ) THEN ! ! d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2 ! ! We choose d(i) as origin. ! orgati = .true. sg2lb = zero sg2ub = delsq2 a = c*delsq + z( i )*z( i ) + z( ip1 )*z( ip1 ) b = z( i )*z( i )*delsq IF( a > zero ) THEN tau = two*b / ( a+SQRT( ABS( a*a-four*b*c ) ) ) ELSE tau = ( a-SQRT( ABS( a*a-four*b*c ) ) ) / ( two*c ) END IF ! ! TAU now is an estimation of SIGMA^2 - D( I )^2. The ! following, however, is the corresponding estimation of ! SIGMA - D( I ). ! eta = tau / ( d( i )+SQRT( d( i )*d( i )+tau ) ) ELSE ! ! (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2 ! ! We choose d(i+1) as origin. ! orgati = .false. sg2lb = -delsq2 sg2ub = zero a = c*delsq - z( i )*z( i ) - z( ip1 )*z( ip1 ) b = z( ip1 )*z( ip1 )*delsq IF( a < zero ) THEN tau = two*b / ( a-SQRT( ABS( a*a+four*b*c ) ) ) ELSE tau = -( a+SQRT( ABS( a*a+four*b*c ) ) ) / ( two*c ) END IF ! ! TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The ! following, however, is the corresponding estimation of ! SIGMA - D( IP1 ). ! eta = tau / ( d( ip1 )+SQRT( ABS( d( ip1 )*d( ip1 )+ tau ) ) ) END IF ! IF( orgati ) THEN ii = i sigma = d( i ) + eta DO j = 1, n work( j ) = d( j ) + d( i ) + eta delta( j ) = ( d( j )-d( i ) ) - eta END DO ELSE ii = i + 1 sigma = d( ip1 ) + eta DO j = 1, n work( j ) = d( j ) + d( ip1 ) + eta delta( j ) = ( d( j )-d( ip1 ) ) - eta END DO END IF iim1 = ii - 1 iip1 = ii + 1 ! ! Evaluate PSI and the derivative DPSI ! dpsi = zero psi = zero erretm = zero DO j = 1, iim1 temp = z( j ) / ( work( j )*delta( j ) ) psi = psi + z( j )*temp dpsi = dpsi + temp*temp erretm = erretm + psi END DO erretm = ABS( erretm ) ! ! Evaluate PHI and the derivative DPHI ! dphi = zero phi = zero DO j = n, iip1, -1 temp = z( j ) / ( work( j )*delta( j ) ) phi = phi + z( j )*temp dphi = dphi + temp*temp erretm = erretm + phi END DO ! w = rhoinv + phi + psi ! ! W is the value of the secular function with ! its ii-th element removed. ! swtch3 = .false. IF( orgati ) THEN IF( w < zero ) swtch3 = .true. ELSE IF( w > zero ) swtch3 = .true. END IF IF( ii == 1 .OR. ii == n ) swtch3 = .false. ! temp = z( ii ) / ( work( ii )*delta( ii ) ) dw = dpsi + dphi + temp*temp temp = z( ii )*temp w = w + temp erretm = eight*( phi-psi ) + erretm + two*rhoinv + & three*ABS( temp ) + ABS( tau )*dw ! ! Test for convergence ! IF( ABS( w ) <= eps*erretm ) THEN GO TO 240 END IF ! IF( w <= zero ) THEN sg2lb = MAX( sg2lb, tau ) ELSE sg2ub = MIN( sg2ub, tau ) END IF ! ! Calculate the new step ! niter = niter + 1 IF( .NOT.swtch3 ) THEN dtipsq = work( ip1 )*delta( ip1 ) dtisq = work( i )*delta( i ) IF( orgati ) THEN c = w - dtipsq*dw + delsq*( z( i ) / dtisq )**2 ELSE c = w - dtisq*dw - delsq*( z( ip1 ) / dtipsq )**2 END IF a = ( dtipsq+dtisq )*w - dtipsq*dtisq*dw b = dtipsq*dtisq*w IF( c == zero ) THEN IF( a == zero ) THEN IF( orgati ) THEN a = z( i )*z( i ) + dtipsq*dtipsq*( dpsi+dphi ) ELSE a = z( ip1 )*z( ip1 ) + dtisq*dtisq*( dpsi+dphi ) END IF END IF eta = b / a ELSE IF( a <= zero ) THEN eta = ( a-SQRT( ABS( a*a-four*b*c ) ) ) / ( two*c ) ELSE eta = two*b / ( a+SQRT( ABS( a*a-four*b*c ) ) ) END IF ELSE ! ! Interpolation using THREE most relevant poles ! dtiim = work( iim1 )*delta( iim1 ) dtiip = work( iip1 )*delta( iip1 ) temp = rhoinv + psi + phi IF( orgati ) THEN temp1 = z( iim1 ) / dtiim temp1 = temp1*temp1 c = temp - dtiip*( dpsi+dphi ) - & ( d( iim1 )-d( iip1 ) )*( d( iim1 )+d( iip1 ) )*temp1 zz( 1 ) = z( iim1 )*z( iim1 ) IF( dpsi < temp1 ) THEN zz( 3 ) = dtiip*dtiip*dphi ELSE zz( 3 ) = dtiip*dtiip*( ( dpsi-temp1 )+dphi ) END IF ELSE temp1 = z( iip1 ) / dtiip temp1 = temp1*temp1 c = temp - dtiim*( dpsi+dphi ) - & ( d( iip1 )-d( iim1 ) )*( d( iim1 )+d( iip1 ) )*temp1 IF( dphi < temp1 ) THEN zz( 1 ) = dtiim*dtiim*dpsi ELSE zz( 1 ) = dtiim*dtiim*( dpsi+( dphi-temp1 ) ) END IF zz( 3 ) = z( iip1 )*z( iip1 ) END IF zz( 2 ) = z( ii )*z( ii ) dd( 1 ) = dtiim dd( 2 ) = delta( ii )*work( ii ) dd( 3 ) = dtiip CALL slaed6( niter, orgati, c, dd, zz, w, eta, info ) IF( info /= 0 ) GO TO 240 END IF ! ! Note, eta should be positive if w is negative, and ! eta should be negative otherwise. However, ! if for some reason caused by roundoff, eta*w > 0, ! we simply use one Newton step instead. This way ! will guarantee eta*w < 0. ! IF( w*eta >= zero ) eta = -w / dw IF( orgati ) THEN temp1 = work( i )*delta( i ) temp = eta - temp1 ELSE temp1 = work( ip1 )*delta( ip1 ) temp = eta - temp1 END IF IF( temp > sg2ub .OR. temp < sg2lb ) THEN IF( w < zero ) THEN eta = ( sg2ub-tau ) / two ELSE eta = ( sg2lb-tau ) / two END IF END IF ! tau = tau + eta eta = eta / ( sigma+SQRT( sigma*sigma+eta ) ) ! prew = w ! sigma = sigma + eta DO j = 1, n work( j ) = work( j ) + eta delta( j ) = delta( j ) - eta END DO ! ! Evaluate PSI and the derivative DPSI ! dpsi = zero psi = zero erretm = zero DO j = 1, iim1 temp = z( j ) / ( work( j )*delta( j ) ) psi = psi + z( j )*temp dpsi = dpsi + temp*temp erretm = erretm + psi END DO erretm = ABS( erretm ) ! ! Evaluate PHI and the derivative DPHI ! dphi = zero phi = zero DO j = n, iip1, -1 temp = z( j ) / ( work( j )*delta( j ) ) phi = phi + z( j )*temp dphi = dphi + temp*temp erretm = erretm + phi END DO ! temp = z( ii ) / ( work( ii )*delta( ii ) ) dw = dpsi + dphi + temp*temp temp = z( ii )*temp w = rhoinv + phi + psi + temp erretm = eight*( phi-psi ) + erretm + two*rhoinv + & three*ABS( temp ) + ABS( tau )*dw ! IF( w <= zero ) THEN sg2lb = MAX( sg2lb, tau ) ELSE sg2ub = MIN( sg2ub, tau ) END IF ! swtch = .false. IF( orgati ) THEN IF( -w > ABS( prew ) / ten ) swtch = .true. ELSE IF( w > ABS( prew ) / ten ) swtch = .true. END IF ! ! Main loop to update the values of the array DELTA and WORK ! iter = niter + 1 ! DO niter = iter, maxit ! ! Test for convergence ! IF( ABS( w ) <= eps*erretm ) THEN GO TO 240 END IF ! ! Calculate the new step ! IF( .NOT.swtch3 ) THEN dtipsq = work( ip1 )*delta( ip1 ) dtisq = work( i )*delta( i ) IF( .NOT.swtch ) THEN IF( orgati ) THEN c = w - dtipsq*dw + delsq*( z( i ) / dtisq )**2 ELSE c = w - dtisq*dw - delsq*( z( ip1 ) / dtipsq )**2 END IF ELSE temp = z( ii ) / ( work( ii )*delta( ii ) ) IF( orgati ) THEN dpsi = dpsi + temp*temp ELSE dphi = dphi + temp*temp END IF c = w - dtisq*dpsi - dtipsq*dphi END IF a = ( dtipsq+dtisq )*w - dtipsq*dtisq*dw b = dtipsq*dtisq*w IF( c == zero ) THEN IF( a == zero ) THEN IF( .NOT.swtch ) THEN IF( orgati ) THEN a = z( i )*z( i ) + dtipsq*dtipsq* ( dpsi+dphi ) ELSE a = z( ip1 )*z( ip1 ) + dtisq*dtisq*( dpsi+dphi ) END IF ELSE a = dtisq*dtisq*dpsi + dtipsq*dtipsq*dphi END IF END IF eta = b / a ELSE IF( a <= zero ) THEN eta = ( a-SQRT( ABS( a*a-four*b*c ) ) ) / ( two*c ) ELSE eta = two*b / ( a+SQRT( ABS( a*a-four*b*c ) ) ) END IF ELSE ! ! Interpolation using THREE most relevant poles ! dtiim = work( iim1 )*delta( iim1 ) dtiip = work( iip1 )*delta( iip1 ) temp = rhoinv + psi + phi IF( swtch ) THEN c = temp - dtiim*dpsi - dtiip*dphi zz( 1 ) = dtiim*dtiim*dpsi zz( 3 ) = dtiip*dtiip*dphi ELSE IF( orgati ) THEN temp1 = z( iim1 ) / dtiim temp1 = temp1*temp1 temp2 = ( d( iim1 )-d( iip1 ) )* ( d( iim1 )+d( iip1 ) )*temp1 c = temp - dtiip*( dpsi+dphi ) - temp2 zz( 1 ) = z( iim1 )*z( iim1 ) IF( dpsi < temp1 ) THEN zz( 3 ) = dtiip*dtiip*dphi ELSE zz( 3 ) = dtiip*dtiip*( ( dpsi-temp1 )+dphi ) END IF ELSE temp1 = z( iip1 ) / dtiip temp1 = temp1*temp1 temp2 = ( d( iip1 )-d( iim1 ) )* ( d( iim1 )+d( iip1 ) )*temp1 c = temp - dtiim*( dpsi+dphi ) - temp2 IF( dphi < temp1 ) THEN zz( 1 ) = dtiim*dtiim*dpsi ELSE zz( 1 ) = dtiim*dtiim*( dpsi+( dphi-temp1 ) ) END IF zz( 3 ) = z( iip1 )*z( iip1 ) END IF END IF dd( 1 ) = dtiim dd( 2 ) = delta( ii )*work( ii ) dd( 3 ) = dtiip CALL slaed6( niter, orgati, c, dd, zz, w, eta, info ) IF( info /= 0 ) GO TO 240 END IF ! ! Note, eta should be positive if w is negative, and ! eta should be negative otherwise. However, ! if for some reason caused by roundoff, eta*w > 0, ! we simply use one Newton step instead. This way ! will guarantee eta*w < 0. ! IF( w*eta >= zero ) eta = -w / dw IF( orgati ) THEN temp1 = work( i )*delta( i ) temp = eta - temp1 ELSE temp1 = work( ip1 )*delta( ip1 ) temp = eta - temp1 END IF IF( temp > sg2ub .OR. temp < sg2lb ) THEN IF( w < zero ) THEN eta = ( sg2ub-tau ) / two ELSE eta = ( sg2lb-tau ) / two END IF END IF ! tau = tau + eta eta = eta / ( sigma+SQRT( sigma*sigma+eta ) ) ! sigma = sigma + eta DO j = 1, n work( j ) = work( j ) + eta delta( j ) = delta( j ) - eta END DO ! prew = w ! ! Evaluate PSI and the derivative DPSI ! dpsi = zero psi = zero erretm = zero DO j = 1, iim1 temp = z( j ) / ( work( j )*delta( j ) ) psi = psi + z( j )*temp dpsi = dpsi + temp*temp erretm = erretm + psi END DO erretm = ABS( erretm ) ! ! Evaluate PHI and the derivative DPHI ! dphi = zero phi = zero DO j = n, iip1, -1 temp = z( j ) / ( work( j )*delta( j ) ) phi = phi + z( j )*temp dphi = dphi + temp*temp erretm = erretm + phi END DO ! temp = z( ii ) / ( work( ii )*delta( ii ) ) dw = dpsi + dphi + temp*temp temp = z( ii )*temp w = rhoinv + phi + psi + temp erretm = eight*( phi-psi ) + erretm + two*rhoinv + & three*ABS( temp ) + ABS( tau )*dw IF( w*prew > zero .AND. ABS( w ) > ABS( prew ) / ten ) swtch = .NOT.swtch ! IF( w <= zero ) THEN sg2lb = MAX( sg2lb, tau ) ELSE sg2ub = MIN( sg2ub, tau ) END IF ! END DO ! ! Return with INFO = 1, NITER = MAXIT and not converged ! info = 1 ! END IF ! 240 CONTINUE RETURN ! ! End of SLASD4 ! END SUBROUTINE slasd4 SUBROUTINE slasd5( i, d, z, delta, rho, dsigma, work ) ! ! -- LAPACK auxiliary routine (version 3.0) -- ! Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, ! Courant Institute, NAG Ltd., and Rice University ! June 30, 1999 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: i REAL, INTENT(IN) :: d( 2 ) REAL, INTENT(IN) :: z( 2 ) REAL, INTENT(OUT) :: delta( 2 ) REAL, INTENT(IN) :: rho REAL, INTENT(OUT) :: dsigma REAL, INTENT(OUT) :: work( 2 ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! This subroutine computes the square root of the I-th eigenvalue ! of a positive symmetric rank-one modification of a 2-by-2 diagonal ! matrix ! ! diag( D ) * diag( D ) + RHO * Z * transpose(Z) . ! ! The diagonal entries in the array D are assumed to satisfy ! ! 0 <= D(i) < D(j) for i < j . ! ! We also assume RHO > 0 and that the Euclidean norm of the vector ! Z is one. ! ! Arguments ! ========= ! ! I (input) INTEGER ! The index of the eigenvalue to be computed. I = 1 or I = 2. ! ! D (input) REAL array, dimension ( 2 ) ! The original eigenvalues. We assume 0 <= D(1) < D(2). ! ! Z (input) REAL array, dimension ( 2 ) ! The components of the updating vector. ! ! DELTA (output) REAL array, dimension ( 2 ) ! Contains (D(j) - lambda_I) in its j-th component. ! The vector DELTA contains the information necessary ! to construct the eigenvectors. ! ! RHO (input) REAL ! The scalar in the symmetric updating formula. ! ! DSIGMA (output) REAL ! The computed lambda_I, the I-th updated eigenvalue. ! ! WORK (workspace) REAL array, dimension ( 2 ) ! WORK contains (D(j) + sigma_I) in its j-th component. ! ! Further Details ! =============== ! ! Based on contributions by ! Ren-Cang Li, Computer Science Division, University of California ! at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 REAL, PARAMETER :: three = 3.0E+0 REAL, PARAMETER :: four = 4.0E+0 ! .. ! .. Local Scalars .. REAL :: b, c, del, delsq, tau, w ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, SQRT ! .. ! .. Executable Statements .. ! del = d( 2 ) - d( 1 ) delsq = del*( d( 2 )+d( 1 ) ) IF( i == 1 ) THEN w = one + four*rho*( z( 2 )*z( 2 ) / ( d( 1 )+three*d( 2 ) )- & z( 1 )*z( 1 ) / ( three*d( 1 )+d( 2 ) ) ) / del IF( w > zero ) THEN b = delsq + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) ) c = rho*z( 1 )*z( 1 )*delsq ! ! B > ZERO, always ! ! The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 ) ! tau = two*c / ( b+SQRT( ABS( b*b-four*c ) ) ) ! ! The following TAU is DSIGMA - D( 1 ) ! tau = tau / ( d( 1 )+SQRT( d( 1 )*d( 1 )+tau ) ) dsigma = d( 1 ) + tau delta( 1 ) = -tau delta( 2 ) = del - tau work( 1 ) = two*d( 1 ) + tau work( 2 ) = ( d( 1 )+tau ) + d( 2 ) ! DELTA( 1 ) = -Z( 1 ) / TAU ! DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) ELSE b = -delsq + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) ) c = rho*z( 2 )*z( 2 )*delsq ! ! The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) ! IF( b > zero ) THEN tau = -two*c / ( b+SQRT( b*b+four*c ) ) ELSE tau = ( b-SQRT( b*b+four*c ) ) / two END IF ! ! The following TAU is DSIGMA - D( 2 ) ! tau = tau / ( d( 2 )+SQRT( ABS( d( 2 )*d( 2 )+tau ) ) ) dsigma = d( 2 ) + tau delta( 1 ) = -( del+tau ) delta( 2 ) = -tau work( 1 ) = d( 1 ) + tau + d( 2 ) work( 2 ) = two*d( 2 ) + tau ! DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) ! DELTA( 2 ) = -Z( 2 ) / TAU END IF ! TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) ! DELTA( 1 ) = DELTA( 1 ) / TEMP ! DELTA( 2 ) = DELTA( 2 ) / TEMP ELSE ! ! Now I=2 ! b = -delsq + rho*( z( 1 )*z( 1 )+z( 2 )*z( 2 ) ) c = rho*z( 2 )*z( 2 )*delsq ! ! The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) ! IF( b > zero ) THEN tau = ( b+SQRT( b*b+four*c ) ) / two ELSE tau = two*c / ( -b+SQRT( b*b+four*c ) ) END IF ! ! The following TAU is DSIGMA - D( 2 ) ! tau = tau / ( d( 2 )+SQRT( d( 2 )*d( 2 )+tau ) ) dsigma = d( 2 ) + tau delta( 1 ) = -( del+tau ) delta( 2 ) = -tau work( 1 ) = d( 1 ) + tau + d( 2 ) work( 2 ) = two*d( 2 ) + tau ! DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) ! DELTA( 2 ) = -Z( 2 ) / TAU ! TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) ! DELTA( 1 ) = DELTA( 1 ) / TEMP ! DELTA( 2 ) = DELTA( 2 ) / TEMP END IF RETURN ! ! End of SLASD5 ! END SUBROUTINE slasd5 SUBROUTINE slasd6( icompq, nl, nr, sqre, d, vf, vl, alpha, beta, & idxq, perm, givptr, givcol, ldgcol, givnum, & ldgnum, poles, difl, difr, z, k, c, s, 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, INTENT(IN) :: icompq INTEGER, INTENT(IN OUT) :: nl INTEGER, INTENT(IN) :: nr INTEGER, INTENT(IN) :: sqre REAL, INTENT(OUT) :: d( * ) REAL, INTENT(IN OUT) :: vf( * ) REAL, INTENT(IN OUT) :: vl( * ) REAL, INTENT(IN OUT) :: alpha REAL, INTENT(IN OUT) :: beta INTEGER, INTENT(IN OUT) :: idxq( * ) INTEGER, INTENT(IN OUT) :: perm( * ) INTEGER, INTENT(IN OUT) :: givptr INTEGER, INTENT(IN OUT) :: givcol( ldgcol, * ) INTEGER, INTENT(IN OUT) :: ldgcol REAL, INTENT(IN OUT) :: givnum( ldgnum, * ) INTEGER, INTENT(IN OUT) :: ldgnum REAL, INTENT(IN OUT) :: poles( ldgnum, * ) REAL, INTENT(IN OUT) :: difl( * ) REAL, INTENT(IN OUT) :: difr( * ) REAL, INTENT(IN OUT) :: z( * ) INTEGER, INTENT(IN) :: k REAL, INTENT(IN OUT) :: c REAL, INTENT(IN OUT) :: s REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLASD6 computes the SVD of an updated upper bidiagonal matrix B ! obtained by merging two smaller ones by appending a row. This ! routine is used only for the problem which requires all singular ! values and optionally singular vector matrices in factored form. ! B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE. ! A related subroutine, SLASD1, handles the case in which all singular ! values and singular vectors of the bidiagonal matrix are desired. ! ! SLASD6 computes the SVD as follows: ! ! ( D1(in) 0 0 0 ) ! B = U(in) * ( Z1' a Z2' b ) * VT(in) ! ( 0 0 D2(in) 0 ) ! ! = U(out) * ( D(out) 0) * VT(out) ! ! where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M ! with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros ! elsewhere; and the entry b is empty if SQRE = 0. ! ! The singular values of B can be computed using D1, D2, the first ! components of all the right singular vectors of the lower block, and ! the last components of all the right singular vectors of the upper ! block. These components are stored and updated in VF and VL, ! respectively, in SLASD6. Hence U and VT are not explicitly ! referenced. ! ! The singular values are stored in D. The algorithm consists of two ! stages: ! ! The first stage consists of deflating the size of the problem ! when there are multiple singular values or if there is a zero ! in the Z vector. For each such occurence the dimension of the ! secular equation problem is reduced by one. This stage is ! performed by the routine SLASD7. ! ! The second stage consists of calculating the updated ! singular values. This is done by finding the roots of the ! secular equation via the routine SLASD4 (as called by SLASD8). ! This routine also updates VF and VL and computes the distances ! between the updated singular values and the old singular ! values. ! ! SLASD6 is called from SLASDA. ! ! Arguments ! ========= ! ! ICOMPQ (input) INTEGER ! Specifies whether singular vectors are to be computed in ! factored form: ! = 0: Compute singular values only. ! = 1: Compute singular vectors in factored form as well. ! ! NL (input) INTEGER ! The row dimension of the upper block. NL >= 1. ! ! NR (input) INTEGER ! The row dimension of the lower block. NR >= 1. ! ! SQRE (input) INTEGER ! = 0: the lower block is an NR-by-NR square matrix. ! = 1: the lower block is an NR-by-(NR+1) rectangular matrix. ! ! The bidiagonal matrix has row dimension N = NL + NR + 1, ! and column dimension M = N + SQRE. ! ! D (input/output) REAL array, dimension ( NL+NR+1 ). ! On entry D(1:NL,1:NL) contains the singular values of the ! upper block, and D(NL+2:N) contains the singular values ! of the lower block. On exit D(1:N) contains the singular ! values of the modified matrix. ! ! VF (input/output) REAL array, dimension ( M ) ! On entry, VF(1:NL+1) contains the first components of all ! right singular vectors of the upper block; and VF(NL+2:M) ! contains the first components of all right singular vectors ! of the lower block. On exit, VF contains the first components ! of all right singular vectors of the bidiagonal matrix. ! ! VL (input/output) REAL array, dimension ( M ) ! On entry, VL(1:NL+1) contains the last components of all ! right singular vectors of the upper block; and VL(NL+2:M) ! contains the last components of all right singular vectors of ! the lower block. On exit, VL contains the last components of ! all right singular vectors of the bidiagonal matrix. ! ! ALPHA (input) REAL ! Contains the diagonal element associated with the added row. ! ! BETA (input) REAL ! Contains the off-diagonal element associated with the added ! row. ! ! IDXQ (output) INTEGER array, dimension ( N ) ! This contains the permutation which will reintegrate the ! subproblem just solved back into sorted order, i.e. ! D( IDXQ( I = 1, N ) ) will be in ascending order. ! ! PERM (output) INTEGER array, dimension ( N ) ! The permutations (from deflation and sorting) to be applied ! to each block. Not referenced if ICOMPQ = 0. ! ! GIVPTR (output) INTEGER ! The number of Givens rotations which took place in this ! subproblem. Not referenced if ICOMPQ = 0. ! ! GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) ! Each pair of numbers indicates a pair of columns to take place ! in a Givens rotation. Not referenced if ICOMPQ = 0. ! ! LDGCOL (input) INTEGER ! leading dimension of GIVCOL, must be at least N. ! ! GIVNUM (output) REAL array, dimension ( LDGNUM, 2 ) ! Each number indicates the C or S value to be used in the ! corresponding Givens rotation. Not referenced if ICOMPQ = 0. ! ! LDGNUM (input) INTEGER ! The leading dimension of GIVNUM and POLES, must be at least N. ! ! POLES (output) REAL array, dimension ( LDGNUM, 2 ) ! On exit, POLES(1,*) is an array containing the new singular ! values obtained from solving the secular equation, and ! POLES(2,*) is an array containing the poles in the secular ! equation. Not referenced if ICOMPQ = 0. ! ! DIFL (output) REAL array, dimension ( N ) ! On exit, DIFL(I) is the distance between I-th updated ! (undeflated) singular value and the I-th (undeflated) old ! singular value. ! ! DIFR (output) REAL array, ! dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and ! dimension ( N ) if ICOMPQ = 0. ! On exit, DIFR(I, 1) is the distance between I-th updated ! (undeflated) singular value and the I+1-th (undeflated) old ! singular value. ! ! If ICOMPQ = 1, DIFR(1:K,2) is an array containing the ! normalizing factors for the right singular vector matrix. ! ! See SLASD8 for details on DIFL and DIFR. ! ! Z (output) REAL array, dimension ( M ) ! The first elements of this array contain the components ! of the deflation-adjusted updating row vector. ! ! K (output) INTEGER ! Contains the dimension of the non-deflated matrix, ! This is the order of the related secular equation. 1 <= K <=N. ! ! C (output) REAL ! C contains garbage if SQRE =0 and the C-value of a Givens ! rotation related to the right null space if SQRE = 1. ! ! S (output) REAL ! S contains garbage if SQRE =0 and the S-value of a Givens ! rotation related to the right null space if SQRE = 1. ! ! WORK (workspace) REAL array, dimension ( 4 * M ) ! ! 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: if INFO = 1, an singular value did not converge ! ! Further Details ! =============== ! ! Based on contributions by ! Ming Gu and Huan Ren, Computer Science Division, University of ! California at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, idx, idxc, idxp, isigma, ivfw, ivlw, iw, m, n, n1, n2 REAL :: orgnrm ! .. ! .. External Subroutines .. EXTERNAL scopy, slamrg, slascl, slasd7, slasd8, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 n = nl + nr + 1 m = n + sqre ! IF( ( icompq < 0 ) .OR. ( icompq > 1 ) ) THEN info = -1 ELSE IF( nl < 1 ) THEN info = -2 ELSE IF( nr < 1 ) THEN info = -3 ELSE IF( ( sqre < 0 ) .OR. ( sqre > 1 ) ) THEN info = -4 ELSE IF( ldgcol < n ) THEN info = -14 ELSE IF( ldgnum < n ) THEN info = -16 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLASD6', -info ) RETURN END IF ! ! The following values are for bookkeeping purposes only. They are ! integer pointers which indicate the portion of the workspace ! used by a particular array in SLASD7 and SLASD8. ! isigma = 1 iw = isigma + n ivfw = iw + m ivlw = ivfw + m ! idx = 1 idxc = idx + n idxp = idxc + n ! ! Scale. ! orgnrm = MAX( ABS( alpha ), ABS( beta ) ) d( nl+1 ) = zero DO i = 1, n IF( ABS( d( i ) ) > orgnrm ) THEN orgnrm = ABS( d( i ) ) END IF END DO CALL slascl( 'G', 0, 0, orgnrm, one, n, 1, d, n, info ) alpha = alpha / orgnrm beta = beta / orgnrm ! ! Sort and Deflate singular values. ! CALL slasd7( icompq, nl, nr, sqre, k, d, z, work( iw ), vf, & work( ivfw ), vl, work( ivlw ), alpha, beta, & work( isigma ), iwork( idx ), iwork( idxp ), idxq, & perm, givptr, givcol, ldgcol, givnum, ldgnum, c, s, info ) ! ! Solve Secular Equation, compute DIFL, DIFR, and update VF, VL. ! CALL slasd8( icompq, k, d, z, vf, vl, difl, difr, ldgnum, & work( isigma ), work( iw ), info ) ! ! Save the poles if ICOMPQ = 1. ! IF( icompq == 1 ) THEN CALL scopy( k, d, 1, poles( 1, 1 ), 1 ) CALL scopy( k, work( isigma ), 1, poles( 1, 2 ), 1 ) END IF ! ! Unscale. ! CALL slascl( 'G', 0, 0, one, orgnrm, n, 1, d, n, info ) ! ! Prepare the IDXQ sorting permutation. ! n1 = k n2 = n - k CALL slamrg( n1, n2, d, 1, -1, idxq ) ! RETURN ! ! End of SLASD6 ! END SUBROUTINE slasd6 SUBROUTINE slasd7( icompq, nl, nr, sqre, k, d, z, zw, vf, vfw, vl, & vlw, alpha, beta, dsigma, idx, idxp, idxq, & perm, givptr, givcol, ldgcol, givnum, ldgnum, c, s, info ) ! ! -- LAPACK auxiliary routine (version 3.0) -- ! Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, ! Courant Institute, NAG Ltd., and Rice University ! June 30, 1999 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: icompq INTEGER, INTENT(IN) :: nl INTEGER, INTENT(IN) :: nr INTEGER, INTENT(IN) :: sqre INTEGER, INTENT(OUT) :: k REAL, INTENT(OUT) :: d( * ) REAL, INTENT(OUT) :: z( * ) REAL, INTENT(OUT) :: zw( * ) REAL, INTENT(IN OUT) :: vf( * ) REAL, INTENT(OUT) :: vfw( * ) REAL, INTENT(IN OUT) :: vl( * ) REAL, INTENT(OUT) :: vlw( * ) REAL, INTENT(IN) :: alpha REAL, INTENT(IN) :: beta REAL, INTENT(OUT) :: dsigma( * ) INTEGER, INTENT(IN) :: idx( * ) INTEGER, INTENT(OUT) :: idxp( * ) INTEGER, INTENT(OUT) :: idxq( * ) INTEGER, INTENT(OUT) :: perm( * ) INTEGER, INTENT(OUT) :: givptr INTEGER, INTENT(OUT) :: givcol( ldgcol, * ) INTEGER, INTENT(IN OUT) :: ldgcol REAL, INTENT(OUT) :: givnum( ldgnum, * ) INTEGER, INTENT(IN OUT) :: ldgnum REAL, INTENT(OUT) :: c REAL, INTENT(OUT) :: s INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLASD7 merges the two sets of singular values together into a single ! sorted set. Then it tries to deflate the size of the problem. There ! are two ways in which deflation can occur: when two or more singular ! values are close together or if there is a tiny entry in the Z ! vector. For each such occurrence the order of the related ! secular equation problem is reduced by one. ! ! SLASD7 is called from SLASD6. ! ! Arguments ! ========= ! ! ICOMPQ (input) INTEGER ! Specifies whether singular vectors are to be computed ! in compact form, as follows: ! = 0: Compute singular values only. ! = 1: Compute singular vectors of upper ! bidiagonal matrix in compact form. ! ! NL (input) INTEGER ! The row dimension of the upper block. NL >= 1. ! ! NR (input) INTEGER ! The row dimension of the lower block. NR >= 1. ! ! SQRE (input) INTEGER ! = 0: the lower block is an NR-by-NR square matrix. ! = 1: the lower block is an NR-by-(NR+1) rectangular matrix. ! ! The bidiagonal matrix has ! N = NL + NR + 1 rows and ! M = N + SQRE >= N columns. ! ! K (output) INTEGER ! Contains the dimension of the non-deflated matrix, this is ! the order of the related secular equation. 1 <= K <=N. ! ! D (input/output) REAL array, dimension ( N ) ! On entry D contains the singular values of the two submatrices ! to be combined. On exit D contains the trailing (N-K) updated ! singular values (those which were deflated) sorted into ! increasing order. ! ! Z (output) REAL array, dimension ( M ) ! On exit Z contains the updating row vector in the secular ! equation. ! ! ZW (workspace) REAL array, dimension ( M ) ! Workspace for Z. ! ! VF (input/output) REAL array, dimension ( M ) ! On entry, VF(1:NL+1) contains the first components of all ! right singular vectors of the upper block; and VF(NL+2:M) ! contains the first components of all right singular vectors ! of the lower block. On exit, VF contains the first components ! of all right singular vectors of the bidiagonal matrix. ! ! VFW (workspace) REAL array, dimension ( M ) ! Workspace for VF. ! ! VL (input/output) REAL array, dimension ( M ) ! On entry, VL(1:NL+1) contains the last components of all ! right singular vectors of the upper block; and VL(NL+2:M) ! contains the last components of all right singular vectors ! of the lower block. On exit, VL contains the last components ! of all right singular vectors of the bidiagonal matrix. ! ! VLW (workspace) REAL array, dimension ( M ) ! Workspace for VL. ! ! ALPHA (input) REAL ! Contains the diagonal element associated with the added row. ! ! BETA (input) REAL ! Contains the off-diagonal element associated with the added ! row. ! ! DSIGMA (output) REAL array, dimension ( N ) ! Contains a copy of the diagonal elements (K-1 singular values ! and one zero) in the secular equation. ! ! IDX (workspace) INTEGER array, dimension ( N ) ! This will contain the permutation used to sort the contents of ! D into ascending order. ! ! IDXP (workspace) INTEGER array, dimension ( N ) ! This will contain the permutation used to place deflated ! values of D at the end of the array. On output IDXP(2:K) ! points to the nondeflated D-values and IDXP(K+1:N) ! points to the deflated singular values. ! ! IDXQ (input) INTEGER array, dimension ( N ) ! This contains the permutation which separately sorts the two ! sub-problems in D into ascending order. Note that entries in ! the first half of this permutation must first be moved one ! position backward; and entries in the second half ! must first have NL+1 added to their values. ! ! PERM (output) INTEGER array, dimension ( N ) ! The permutations (from deflation and sorting) to be applied ! to each singular block. Not referenced if ICOMPQ = 0. ! ! GIVPTR (output) INTEGER ! The number of Givens rotations which took place in this ! subproblem. Not referenced if ICOMPQ = 0. ! ! GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 ) ! Each pair of numbers indicates a pair of columns to take place ! in a Givens rotation. Not referenced if ICOMPQ = 0. ! ! LDGCOL (input) INTEGER ! The leading dimension of GIVCOL, must be at least N. ! ! GIVNUM (output) REAL array, dimension ( LDGNUM, 2 ) ! Each number indicates the C or S value to be used in the ! corresponding Givens rotation. Not referenced if ICOMPQ = 0. ! ! LDGNUM (input) INTEGER ! The leading dimension of GIVNUM, must be at least N. ! ! C (output) REAL ! C contains garbage if SQRE =0 and the C-value of a Givens ! rotation related to the right null space if SQRE = 1. ! ! S (output) REAL ! S contains garbage if SQRE =0 and the S-value of a Givens ! rotation related to the right null space if SQRE = 1. ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! ! Further Details ! =============== ! ! Based on contributions by ! Ming Gu and Huan Ren, Computer Science Division, University of ! California at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 REAL, PARAMETER :: eight = 8.0E+0 ! .. ! .. Local Scalars .. ! INTEGER :: i, idxi, idxj, idxjp, j, jp, jprev, k2, m, n, nlp1, nlp2 REAL :: eps, hlftol, tau, tol, z1 ! .. ! .. External Subroutines .. EXTERNAL scopy, slamrg, srot, xerbla ! .. ! .. External Functions .. REAL :: slamch, slapy2 EXTERNAL slamch, slapy2 ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 n = nl + nr + 1 m = n + sqre ! IF( ( icompq < 0 ) .OR. ( icompq > 1 ) ) THEN info = -1 ELSE IF( nl < 1 ) THEN info = -2 ELSE IF( nr < 1 ) THEN info = -3 ELSE IF( ( sqre < 0 ) .OR. ( sqre > 1 ) ) THEN info = -4 ELSE IF( ldgcol < n ) THEN info = -22 ELSE IF( ldgnum < n ) THEN info = -24 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLASD7', -info ) RETURN END IF ! nlp1 = nl + 1 nlp2 = nl + 2 IF( icompq == 1 ) THEN givptr = 0 END IF ! ! Generate the first part of the vector Z and move the singular ! values in the first part of D one position backward. ! z1 = alpha*vl( nlp1 ) vl( nlp1 ) = zero tau = vf( nlp1 ) DO i = nl, 1, -1 z( i+1 ) = alpha*vl( i ) vl( i ) = zero vf( i+1 ) = vf( i ) d( i+1 ) = d( i ) idxq( i+1 ) = idxq( i ) + 1 END DO vf( 1 ) = tau ! ! Generate the second part of the vector Z. ! DO i = nlp2, m z( i ) = beta*vf( i ) vf( i ) = zero END DO ! ! Sort the singular values into increasing order ! DO i = nlp2, n idxq( i ) = idxq( i ) + nlp1 END DO ! ! DSIGMA, IDXC, IDXC, and ZW are used as storage space. ! DO i = 2, n dsigma( i ) = d( idxq( i ) ) zw( i ) = z( idxq( i ) ) vfw( i ) = vf( idxq( i ) ) vlw( i ) = vl( idxq( i ) ) END DO ! CALL slamrg( nl, nr, dsigma( 2 ), 1, 1, idx( 2 ) ) ! DO i = 2, n idxi = 1 + idx( i ) d( i ) = dsigma( idxi ) z( i ) = zw( idxi ) vf( i ) = vfw( idxi ) vl( i ) = vlw( idxi ) END DO ! ! Calculate the allowable deflation tolerence ! eps = slamch( 'Epsilon' ) tol = MAX( ABS( alpha ), ABS( beta ) ) tol = eight*eight*eps*MAX( ABS( d( n ) ), tol ) ! ! There are 2 kinds of deflation -- first a value in the z-vector ! is small, second two (or more) singular values are very close ! together (their difference is small). ! ! If the value in the z-vector is small, we simply permute the ! array so that the corresponding singular value is moved to the ! end. ! ! If two values in the D-vector are close, we perform a two-sided ! rotation designed to make one of the corresponding z-vector ! entries zero, and then permute the array so that the deflated ! singular value is moved to the end. ! ! If there are multiple singular values then the problem deflates. ! Here the number of equal singular values are found. As each equal ! singular value is found, an elementary reflector is computed to ! rotate the corresponding singular subspace so that the ! corresponding components of Z are zero in this new basis. ! k = 1 k2 = n + 1 DO j = 2, n IF( ABS( z( j ) ) <= tol ) THEN ! ! Deflate due to small z component. ! k2 = k2 - 1 idxp( k2 ) = j IF( j == n ) GO TO 100 ELSE jprev = j EXIT END IF END DO 70 CONTINUE j = jprev 80 CONTINUE j = j + 1 IF( j > n ) GO TO 90 IF( ABS( z( j ) ) <= tol ) THEN ! ! Deflate due to small z component. ! k2 = k2 - 1 idxp( k2 ) = j ELSE ! ! Check if singular values are close enough to allow deflation. ! IF( ABS( d( j )-d( jprev ) ) <= tol ) THEN ! ! Deflation is possible. ! s = z( jprev ) c = z( j ) ! ! Find sqrt(a**2+b**2) without overflow or ! destructive underflow. ! tau = slapy2( c, s ) z( j ) = tau z( jprev ) = zero c = c / tau s = -s / tau ! ! Record the appropriate Givens rotation ! IF( icompq == 1 ) THEN givptr = givptr + 1 idxjp = idxq( idx( jprev )+1 ) idxj = idxq( idx( j )+1 ) IF( idxjp <= nlp1 ) THEN idxjp = idxjp - 1 END IF IF( idxj <= nlp1 ) THEN idxj = idxj - 1 END IF givcol( givptr, 2 ) = idxjp givcol( givptr, 1 ) = idxj givnum( givptr, 2 ) = c givnum( givptr, 1 ) = s END IF CALL srot( 1, vf( jprev ), 1, vf( j ), 1, c, s ) CALL srot( 1, vl( jprev ), 1, vl( j ), 1, c, s ) k2 = k2 - 1 idxp( k2 ) = jprev jprev = j ELSE k = k + 1 zw( k ) = z( jprev ) dsigma( k ) = d( jprev ) idxp( k ) = jprev jprev = j END IF END IF GO TO 80 90 CONTINUE ! ! Record the last singular value. ! k = k + 1 zw( k ) = z( jprev ) dsigma( k ) = d( jprev ) idxp( k ) = jprev ! 100 CONTINUE ! ! Sort the singular values into DSIGMA. The singular values which ! were not deflated go into the first K slots of DSIGMA, except ! that DSIGMA(1) is treated separately. ! DO j = 2, n jp = idxp( j ) dsigma( j ) = d( jp ) vfw( j ) = vf( jp ) vlw( j ) = vl( jp ) END DO IF( icompq == 1 ) THEN DO j = 2, n jp = idxp( j ) perm( j ) = idxq( idx( jp )+1 ) IF( perm( j ) <= nlp1 ) THEN perm( j ) = perm( j ) - 1 END IF END DO END IF ! ! The deflated singular values go back into the last N - K slots of ! D. ! CALL scopy( n-k, dsigma( k+1 ), 1, d( k+1 ), 1 ) ! ! Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and ! VL(M). ! dsigma( 1 ) = zero hlftol = tol / two IF( ABS( dsigma( 2 ) ) <= hlftol ) dsigma( 2 ) = hlftol IF( m > n ) THEN z( 1 ) = slapy2( z1, z( m ) ) IF( z( 1 ) <= tol ) THEN c = one s = zero z( 1 ) = tol ELSE c = z1 / z( 1 ) s = -z( m ) / z( 1 ) END IF CALL srot( 1, vf( m ), 1, vf( 1 ), 1, c, s ) CALL srot( 1, vl( m ), 1, vl( 1 ), 1, c, s ) ELSE IF( ABS( z1 ) <= tol ) THEN z( 1 ) = tol ELSE z( 1 ) = z1 END IF END IF ! ! Restore Z, VF, and VL. ! CALL scopy( k-1, zw( 2 ), 1, z( 2 ), 1 ) CALL scopy( n-1, vfw( 2 ), 1, vf( 2 ), 1 ) CALL scopy( n-1, vlw( 2 ), 1, vl( 2 ), 1 ) ! RETURN ! ! End of SLASD7 ! END SUBROUTINE slasd7 SUBROUTINE slasd8( icompq, k, d, z, vf, vl, difl, difr, lddifr, & dsigma, work, info ) ! ! -- LAPACK auxiliary routine (version 3.0) -- ! Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, ! Courant Institute, NAG Ltd., and Rice University ! June 30, 1999 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: icompq INTEGER, INTENT(IN) :: k REAL, INTENT(OUT) :: d( * ) REAL, INTENT(IN OUT) :: z( * ) REAL, INTENT(IN) :: vf( * ) REAL, INTENT(IN) :: vl( * ) REAL, INTENT(OUT) :: difl( * ) REAL, INTENT(OUT) :: difr( lddifr, * ) INTEGER, INTENT(IN OUT) :: lddifr REAL, INTENT(OUT) :: dsigma( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLASD8 finds the square roots of the roots of the secular equation, ! as defined by the values in DSIGMA and Z. It makes the appropriate ! calls to SLASD4, and stores, for each element in D, the distance ! to its two nearest poles (elements in DSIGMA). It also updates ! the arrays VF and VL, the first and last components of all the ! right singular vectors of the original bidiagonal matrix. ! ! SLASD8 is called from SLASD6. ! ! Arguments ! ========= ! ! ICOMPQ (input) INTEGER ! Specifies whether singular vectors are to be computed in ! factored form in the calling routine: ! = 0: Compute singular values only. ! = 1: Compute singular vectors in factored form as well. ! ! K (input) INTEGER ! The number of terms in the rational function to be solved ! by SLASD4. K >= 1. ! ! D (output) REAL array, dimension ( K ) ! On output, D contains the updated singular values. ! ! Z (input) REAL array, dimension ( K ) ! The first K elements of this array contain the components ! of the deflation-adjusted updating row vector. ! ! VF (input/output) REAL array, dimension ( K ) ! On entry, VF contains information passed through DBEDE8. ! On exit, VF contains the first K components of the first ! components of all right singular vectors of the bidiagonal ! matrix. ! ! VL (input/output) REAL array, dimension ( K ) ! On entry, VL contains information passed through DBEDE8. ! On exit, VL contains the first K components of the last ! components of all right singular vectors of the bidiagonal ! matrix. ! ! DIFL (output) REAL array, dimension ( K ) ! On exit, DIFL(I) = D(I) - DSIGMA(I). ! ! DIFR (output) REAL array, ! dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and ! dimension ( K ) if ICOMPQ = 0. ! On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not ! defined and will not be referenced. ! ! If ICOMPQ = 1, DIFR(1:K,2) is an array containing the ! normalizing factors for the right singular vector matrix. ! ! LDDIFR (input) INTEGER ! The leading dimension of DIFR, must be at least K. ! ! DSIGMA (input) REAL array, dimension ( K ) ! The first K elements of this array contain the old roots ! of the deflated updating problem. These are the poles ! of the secular equation. ! ! WORK (workspace) REAL array, dimension at least 3 * K ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if INFO = 1, an singular value did not converge ! ! Further Details ! =============== ! ! Based on contributions by ! Ming Gu and Huan Ren, Computer Science Division, University of ! California at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, iwk1, iwk2, iwk2i, iwk3, iwk3i, j REAL :: diflj, difrj, dj, dsigj, dsigjp, rho, temp ! .. ! .. External Subroutines .. EXTERNAL scopy, slascl, slasd4, slaset, xerbla ! .. ! .. External Functions .. REAL :: sdot, slamc3, snrm2 EXTERNAL sdot, slamc3, snrm2 ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( ( icompq < 0 ) .OR. ( icompq > 1 ) ) THEN info = -1 ELSE IF( k < 1 ) THEN info = -2 ELSE IF( lddifr < k ) THEN info = -9 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLASD8', -info ) RETURN END IF ! ! Quick return if possible ! IF( k == 1 ) THEN d( 1 ) = ABS( z( 1 ) ) difl( 1 ) = d( 1 ) IF( icompq == 1 ) THEN difl( 2 ) = one difr( 1, 2 ) = one END IF RETURN END IF ! ! Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can ! be computed with high relative accuracy (barring over/underflow). ! This is a problem on machines without a guard digit in ! add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). ! The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), ! which on any of these machines zeros out the bottommost ! bit of DSIGMA(I) if it is 1; this makes the subsequent ! subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation ! occurs. On binary machines with a guard digit (almost all ! machines) it does not change DSIGMA(I) at all. On hexadecimal ! and decimal machines with a guard digit, it slightly ! changes the bottommost bits of DSIGMA(I). It does not account ! for hexadecimal or decimal machines without guard digits ! (we know of none). We use a subroutine call to compute ! 2*DLAMBDA(I) to prevent optimizing compilers from eliminating ! this code. ! DO i = 1, k dsigma( i ) = slamc3( dsigma( i ), dsigma( i ) ) - dsigma( i ) END DO ! ! Book keeping. ! iwk1 = 1 iwk2 = iwk1 + k iwk3 = iwk2 + k iwk2i = iwk2 - 1 iwk3i = iwk3 - 1 ! ! Normalize Z. ! rho = snrm2( k, z, 1 ) CALL slascl( 'G', 0, 0, rho, one, k, 1, z, k, info ) rho = rho*rho ! ! Initialize WORK(IWK3). ! CALL slaset( 'A', k, 1, one, one, work( iwk3 ), k ) ! ! Compute the updated singular values, the arrays DIFL, DIFR, ! and the updated Z. ! DO j = 1, k CALL slasd4( k, j, dsigma, z, work( iwk1 ), rho, d( j ), & work( iwk2 ), info ) ! ! If the root finder fails, the computation is terminated. ! IF( info /= 0 ) THEN RETURN END IF work( iwk3i+j ) = work( iwk3i+j )*work( j )*work( iwk2i+j ) difl( j ) = -work( j ) difr( j, 1 ) = -work( j+1 ) DO i = 1, j - 1 work( iwk3i+i ) = work( iwk3i+i )*work( i )* & work( iwk2i+i ) / ( dsigma( i )- dsigma( j ) ) / ( dsigma( i )+ & dsigma( j ) ) END DO DO i = j + 1, k work( iwk3i+i ) = work( iwk3i+i )*work( i )* & work( iwk2i+i ) / ( dsigma( i )- dsigma( j ) ) / ( dsigma( i )+ & dsigma( j ) ) END DO END DO ! ! Compute updated Z. ! DO i = 1, k z( i ) = SIGN( SQRT( ABS( work( iwk3i+i ) ) ), z( i ) ) END DO ! ! Update VF and VL. ! DO j = 1, k diflj = difl( j ) dj = d( j ) dsigj = -dsigma( j ) IF( j < k ) THEN difrj = -difr( j, 1 ) dsigjp = -dsigma( j+1 ) END IF work( j ) = -z( j ) / diflj / ( dsigma( j )+dj ) DO i = 1, j - 1 work( i ) = z( i ) / ( slamc3( dsigma( i ), dsigj )-diflj ) & / ( dsigma( i )+dj ) END DO DO i = j + 1, k work( i ) = z( i ) / ( slamc3( dsigma( i ), dsigjp )+difrj ) & / ( dsigma( i )+dj ) END DO temp = snrm2( k, work, 1 ) work( iwk2i+j ) = sdot( k, work, 1, vf, 1 ) / temp work( iwk3i+j ) = sdot( k, work, 1, vl, 1 ) / temp IF( icompq == 1 ) THEN difr( j, 2 ) = temp END IF END DO ! CALL scopy( k, work( iwk2 ), 1, vf, 1 ) CALL scopy( k, work( iwk3 ), 1, vl, 1 ) ! RETURN ! ! End of SLASD8 ! END SUBROUTINE slasd8 SUBROUTINE slasd9( icompq, ldu, k, d, z, vf, vl, difl, difr, & dsigma, work, info ) ! ! -- LAPACK auxiliary routine (version 3.0) -- ! Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, ! Courant Institute, NAG Ltd., and Rice University ! June 30, 1999 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: icompq INTEGER, INTENT(IN OUT) :: ldu INTEGER, INTENT(IN) :: k REAL, INTENT(OUT) :: d( * ) REAL, INTENT(IN OUT) :: z( * ) REAL, INTENT(IN) :: vf( * ) REAL, INTENT(IN) :: vl( * ) REAL, INTENT(OUT) :: difl( * ) REAL, INTENT(OUT) :: difr( ldu, * ) REAL, INTENT(OUT) :: dsigma( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLASD9 finds the square roots of the roots of the secular equation, ! as defined by the values in DSIGMA and Z. It makes the ! appropriate calls to SLASD4, and stores, for each element in D, ! the distance to its two nearest poles (elements in DSIGMA). It also ! updates the arrays VF and VL, the first and last components of all ! the right singular vectors of the original bidiagonal matrix. ! ! SLASD9 is called from SLASD7. ! ! Arguments ! ========= ! ! ICOMPQ (input) INTEGER ! Specifies whether singular vectors are to be computed in ! factored form in the calling routine: ! ! ICOMPQ = 0 Compute singular values only. ! ! ICOMPQ = 1 Compute singular vector matrices in ! factored form also. ! K (input) INTEGER ! The number of terms in the rational function to be solved by ! SLASD4. K >= 1. ! ! D (output) REAL array, dimension(K) ! D(I) contains the updated singular values. ! ! DSIGMA (input) REAL array, dimension(K) ! The first K elements of this array contain the old roots ! of the deflated updating problem. These are the poles ! of the secular equation. ! ! Z (input) REAL array, dimension (K) ! The first K elements of this array contain the components ! of the deflation-adjusted updating row vector. ! ! VF (input/output) REAL array, dimension(K) ! On entry, VF contains information passed through SBEDE8.f ! On exit, VF contains the first K components of the first ! components of all right singular vectors of the bidiagonal ! matrix. ! ! VL (input/output) REAL array, dimension(K) ! On entry, VL contains information passed through SBEDE8.f ! On exit, VL contains the first K components of the last ! components of all right singular vectors of the bidiagonal ! matrix. ! ! DIFL (output) REAL array, dimension (K). ! On exit, DIFL(I) = D(I) - DSIGMA(I). ! ! DIFR (output) REAL array, ! dimension (LDU, 2) if ICOMPQ =1 and ! dimension (K) if ICOMPQ = 0. ! On exit, DIFR(I, 1) = D(I) - DSIGMA(I+1), DIFR(K, 1) is not ! defined and will not be referenced. ! ! If ICOMPQ = 1, DIFR(1:K, 2) is an array containing the ! normalizing factors for the right singular vector matrix. ! ! WORK (workspace) REAL array, ! dimension at least (3 * K) ! Workspace. ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if INFO = 1, an singular value did not converge ! ! Further Details ! =============== ! ! Based on contributions by ! Ming Gu and Huan Ren, Computer Science Division, University of ! California at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. INTEGER :: i, iwk1, iwk2, iwk2i, iwk3, iwk3i, j REAL :: diflj, difrj, dj, djp1, dsigj, dsigjp, rho, temp ! .. ! .. External Functions .. REAL :: sdot, slamc3, snrm2 EXTERNAL sdot, slamc3, snrm2 ! .. ! .. External Subroutines .. EXTERNAL scopy, slascl, slasd4, slaset, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( ( icompq < 0 ) .OR. ( icompq > 1 ) ) THEN info = -1 ELSE IF( k < 1 ) THEN info = -3 ELSE IF( ldu < k ) THEN info = -2 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLASD9', -info ) RETURN END IF ! ! Quick return if possible ! IF( k == 1 ) THEN d( 1 ) = ABS( z( 1 ) ) difl( 1 ) = d( 1 ) IF( icompq == 1 ) THEN difl( 2 ) = one difr( 1, 2 ) = one END IF RETURN END IF ! ! Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can ! be computed with high relative accuracy (barring over/underflow). ! This is a problem on machines without a guard digit in ! add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). ! The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), ! which on any of these machines zeros out the bottommost ! bit of DSIGMA(I) if it is 1; this makes the subsequent ! subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation ! occurs. On binary machines with a guard digit (almost all ! machines) it does not change DSIGMA(I) at all. On hexadecimal ! and decimal machines with a guard digit, it slightly ! changes the bottommost bits of DSIGMA(I). It does not account ! for hexadecimal or decimal machines without guard digits ! (we know of none). We use a subroutine call to compute ! 2*DLAMBDA(I) to prevent optimizing compilers from eliminating ! this code. ! DO i = 1, k dsigma( i ) = slamc3( dsigma( i ), dsigma( i ) ) - dsigma( i ) END DO ! ! Book keeping. ! iwk1 = 1 iwk2 = iwk1 + k iwk3 = iwk2 + k iwk2i = iwk2 - 1 iwk3i = iwk3 - 1 ! ! Normalize Z. ! rho = snrm2( k, z, 1 ) CALL slascl( 'G', 0, 0, rho, one, k, 1, z, k, info ) rho = rho*rho ! ! Initialize WORK(IWK3). ! CALL slaset( 'A', k, 1, one, one, work( iwk3 ), k ) ! ! Compute the updated singular values, the arrays DIFL, DIFR, ! and the updated Z. ! DO j = 1, k CALL slasd4( k, j, dsigma, z, work( iwk1 ), rho, d( j ), & work( iwk2 ), info ) ! ! If the root finder fails, the computation is terminated. ! IF( info /= 0 ) THEN RETURN END IF work( iwk3i+j ) = work( iwk3i+j )*work( j )*work( iwk2i+j ) difl( j ) = -work( j ) difr( j, 1 ) = -work( j+1 ) DO i = 1, j - 1 work( iwk3i+i ) = work( iwk3i+i )*work( i )* & work( iwk2i+i ) / ( dsigma( i )- dsigma( j ) ) / ( dsigma( i )+ & dsigma( j ) ) END DO DO i = j + 1, k work( iwk3i+i ) = work( iwk3i+i )*work( i )* & work( iwk2i+i ) / ( dsigma( i )- dsigma( j ) ) / ( dsigma( i )+ & dsigma( j ) ) END DO END DO ! ! Compute updated Z. ! DO i = 1, k z( i ) = SIGN( SQRT( ABS( work( iwk3i+i ) ) ), z( i ) ) END DO ! ! Update VF and VL. ! DO j = 1, k diflj = difl( j ) dj = d( j ) dsigj = -dsigma( j ) IF( j < k ) THEN difrj = -difr( j, 1 ) djp1 = d( j+1 ) dsigjp = -dsigma( j+1 ) END IF work( j ) = -z( j ) / diflj / ( dsigma( j )+dj ) DO i = 1, j - 1 work( i ) = z( i ) / ( slamc3( dsigma( i ), dsigj )-diflj ) & / ( dsigma( i )+dj ) END DO DO i = j + 1, k work( i ) = z( i ) / ( slamc3( dsigma( i ), dsigjp )+difrj ) & / ( dsigma( i )+dj ) END DO temp = snrm2( k, work, 1 ) work( iwk2i+j ) = sdot( k, work, 1, vf, 1 ) / temp work( iwk3i+j ) = sdot( k, work, 1, vl, 1 ) / temp IF( icompq == 1 ) THEN difr( j, 2 ) = temp END IF END DO ! CALL scopy( k, work( iwk2 ), 1, vf, 1 ) CALL scopy( k, work( iwk3 ), 1, vl, 1 ) ! RETURN ! ! End of SLASD9 ! END SUBROUTINE slasd9 SUBROUTINE slasda( icompq, smlsiz, n, sqre, d, e, u, ldu, vt, k, & difl, difr, z, poles, givptr, givcol, ldgcol, & perm, givnum, c, s, 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, INTENT(IN) :: icompq INTEGER, INTENT(IN) :: smlsiz INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: sqre REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: e( * ) REAL, INTENT(IN OUT) :: u( ldu, * ) INTEGER, INTENT(IN OUT) :: ldu REAL, INTENT(IN OUT) :: vt( ldu, * ) INTEGER, INTENT(IN OUT) :: k( * ) REAL, INTENT(IN OUT) :: difl( ldu, * ) REAL, INTENT(IN OUT) :: difr( ldu, * ) REAL, INTENT(IN OUT) :: z( ldu, * ) REAL, INTENT(IN OUT) :: poles( ldu, * ) INTEGER, INTENT(IN OUT) :: givptr( * ) INTEGER, INTENT(IN OUT) :: givcol( ldgcol, * ) INTEGER, INTENT(IN OUT) :: ldgcol INTEGER, INTENT(IN OUT) :: perm( ldgcol, * ) REAL, INTENT(IN OUT) :: givnum( ldu, * ) REAL, INTENT(IN OUT) :: c( * ) REAL, INTENT(IN OUT) :: s( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! Using a divide and conquer approach, SLASDA computes the singular ! value decomposition (SVD) of a real upper bidiagonal N-by-M matrix ! B with diagonal D and offdiagonal E, where M = N + SQRE. The ! algorithm computes the singular values in the SVD B = U * S * VT. ! The orthogonal matrices U and VT are optionally computed in ! compact form. ! ! A related subroutine, SLASD0, computes the singular values and ! the singular vectors in explicit form. ! ! Arguments ! ========= ! ! ICOMPQ (input) INTEGER ! Specifies whether singular vectors are to be computed ! in compact form, as follows ! = 0: Compute singular values only. ! = 1: Compute singular vectors of upper bidiagonal ! matrix in compact form. ! ! SMLSIZ (input) INTEGER ! The maximum size of the subproblems at the bottom of the ! computation tree. ! ! N (input) INTEGER ! The row dimension of the upper bidiagonal matrix. This is ! also the dimension of the main diagonal array D. ! ! SQRE (input) INTEGER ! Specifies the column dimension of the bidiagonal matrix. ! = 0: The bidiagonal matrix has column dimension M = N; ! = 1: The bidiagonal matrix has column dimension M = N + 1. ! ! D (input/output) REAL array, dimension ( N ) ! On entry D contains the main diagonal of the bidiagonal ! matrix. On exit D, if INFO = 0, contains its singular values. ! ! E (input) REAL array, dimension ( M-1 ) ! Contains the subdiagonal entries of the bidiagonal matrix. ! On exit, E has been destroyed. ! ! U (output) REAL array, ! dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced ! if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left ! singular vector matrices of all subproblems at the bottom ! level. ! ! LDU (input) INTEGER, LDU = > N. ! The leading dimension of arrays U, VT, DIFL, DIFR, POLES, ! GIVNUM, and Z. ! ! VT (output) REAL array, ! dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced ! if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right ! singular vector matrices of all subproblems at the bottom ! level. ! ! K (output) INTEGER array, ! dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. ! If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th ! secular equation on the computation tree. ! ! DIFL (output) REAL array, dimension ( LDU, NLVL ), ! where NLVL = floor(log_2 (N/SMLSIZ))). ! ! DIFR (output) REAL array, ! dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and ! dimension ( N ) if ICOMPQ = 0. ! If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1) ! record distances between singular values on the I-th ! level and singular values on the (I -1)-th level, and ! DIFR(1:N, 2 * I ) contains the normalizing factors for ! the right singular vector matrix. See SLASD8 for details. ! ! Z (output) REAL array, ! dimension ( LDU, NLVL ) if ICOMPQ = 1 and ! dimension ( N ) if ICOMPQ = 0. ! The first K elements of Z(1, I) contain the components of ! the deflation-adjusted updating row vector for subproblems ! on the I-th level. ! ! POLES (output) REAL array, ! dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced ! if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and ! POLES(1, 2*I) contain the new and old singular values ! involved in the secular equations on the I-th level. ! ! GIVPTR (output) INTEGER array, ! dimension ( N ) if ICOMPQ = 1, and not referenced if ! ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records ! the number of Givens rotations performed on the I-th ! problem on the computation tree. ! ! GIVCOL (output) INTEGER array, ! dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not ! referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, ! GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations ! of Givens rotations performed on the I-th level on the ! computation tree. ! ! LDGCOL (input) INTEGER, LDGCOL = > N. ! The leading dimension of arrays GIVCOL and PERM. ! ! PERM (output) INTEGER array, ! dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced ! if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records ! permutations done on the I-th level of the computation tree. ! ! GIVNUM (output) REAL array, ! dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not ! referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, ! GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S- ! values of Givens rotations performed on the I-th level on ! the computation tree. ! ! C (output) REAL array, ! dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. ! If ICOMPQ = 1 and the I-th subproblem is not square, on exit, ! C( I ) contains the C-value of a Givens rotation related to ! the right null space of the I-th subproblem. ! ! S (output) REAL array, dimension ( N ) if ! ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 ! and the I-th subproblem is not square, on exit, S( I ) ! contains the S-value of a Givens rotation related to ! the right null space of the I-th subproblem. ! ! WORK (workspace) REAL array ! If ICOMPQ = 0 its dimension must be at least ! (2 * N + max(4 * N, (SMLSIZ + 4)*(SMLSIZ + 1))). ! and if ICOMPQ = 1, dimension must be at least (6 * N). ! ! IWORK (workspace) INTEGER array. ! Dimension must be at least (7 * N). ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if INFO = 1, an singular value did not converge ! ! Further Details ! =============== ! ! Based on contributions by ! Ming Gu and Huan Ren, Computer Science Division, University of ! California at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, i1, ic, idxq, idxqi, im1, inode, itemp, iwk, & j, lf, ll, lvl, lvl2, m, ncc, nd, ndb1, ndiml, & ndimr, nl, nlf, nlp1, nlvl, nr, nrf, nrp1, nru, & nwork1, nwork2, smlszp, sqrei, vf, vfi, vl, vli REAL :: alpha, beta ! .. ! .. External Subroutines .. EXTERNAL scopy, slasd6, slasdq, slasdt, slaset, xerbla ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! IF( ( icompq < 0 ) .OR. ( icompq > 1 ) ) THEN info = -1 ELSE IF( smlsiz < 3 ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( ( sqre < 0 ) .OR. ( sqre > 1 ) ) THEN info = -4 ELSE IF( ldu < ( n+sqre ) ) THEN info = -8 ELSE IF( ldgcol < n ) THEN info = -17 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLASDA', -info ) RETURN END IF ! m = n + sqre ! ! If the input matrix is too small, call SLASDQ to find the SVD. ! IF( n <= smlsiz ) THEN IF( icompq == 0 ) THEN CALL slasdq( 'U', sqre, n, 0, 0, 0, d, e, vt, ldu, u, ldu, & u, ldu, work, info ) ELSE CALL slasdq( 'U', sqre, n, m, n, 0, d, e, vt, ldu, u, ldu, & u, ldu, work, info ) END IF RETURN END IF ! ! Book-keeping and set up the computation tree. ! inode = 1 ndiml = inode + n ndimr = ndiml + n idxq = ndimr + n iwk = idxq + n ! ncc = 0 nru = 0 ! smlszp = smlsiz + 1 vf = 1 vl = vf + m nwork1 = vl + m nwork2 = nwork1 + smlszp*smlszp ! CALL slasdt( n, nlvl, nd, iwork( inode ), iwork( ndiml ), & iwork( ndimr ), smlsiz ) ! ! for the nodes on bottom level of the tree, solve ! their subproblems by SLASDQ. ! ndb1 = ( nd+1 ) / 2 DO i = ndb1, nd ! ! IC : center row of each node ! NL : number of rows of left subproblem ! NR : number of rows of right subproblem ! NLF: starting row of the left subproblem ! NRF: starting row of the right subproblem ! i1 = i - 1 ic = iwork( inode+i1 ) nl = iwork( ndiml+i1 ) nlp1 = nl + 1 nr = iwork( ndimr+i1 ) nlf = ic - nl nrf = ic + 1 idxqi = idxq + nlf - 2 vfi = vf + nlf - 1 vli = vl + nlf - 1 sqrei = 1 IF( icompq == 0 ) THEN CALL slaset( 'A', nlp1, nlp1, zero, one, work( nwork1 ), smlszp ) CALL slasdq( 'U', sqrei, nl, nlp1, nru, ncc, d( nlf ), & e( nlf ), work( nwork1 ), smlszp, & work( nwork2 ), nl, work( nwork2 ), nl, work( nwork2 ), info ) itemp = nwork1 + nl*smlszp CALL scopy( nlp1, work( nwork1 ), 1, work( vfi ), 1 ) CALL scopy( nlp1, work( itemp ), 1, work( vli ), 1 ) ELSE CALL slaset( 'A', nl, nl, zero, one, u( nlf, 1 ), ldu ) CALL slaset( 'A', nlp1, nlp1, zero, one, vt( nlf, 1 ), ldu ) CALL slasdq( 'U', sqrei, nl, nlp1, nl, ncc, d( nlf ), & e( nlf ), vt( nlf, 1 ), ldu, u( nlf, 1 ), ldu, & u( nlf, 1 ), ldu, work( nwork1 ), info ) CALL scopy( nlp1, vt( nlf, 1 ), 1, work( vfi ), 1 ) CALL scopy( nlp1, vt( nlf, nlp1 ), 1, work( vli ), 1 ) END IF IF( info /= 0 ) THEN RETURN END IF DO j = 1, nl iwork( idxqi+j ) = j END DO IF( ( i == nd ) .AND. ( sqre == 0 ) ) THEN sqrei = 0 ELSE sqrei = 1 END IF idxqi = idxqi + nlp1 vfi = vfi + nlp1 vli = vli + nlp1 nrp1 = nr + sqrei IF( icompq == 0 ) THEN CALL slaset( 'A', nrp1, nrp1, zero, one, work( nwork1 ), smlszp ) CALL slasdq( 'U', sqrei, nr, nrp1, nru, ncc, d( nrf ), & e( nrf ), work( nwork1 ), smlszp, & work( nwork2 ), nr, work( nwork2 ), nr, work( nwork2 ), info ) itemp = nwork1 + ( nrp1-1 )*smlszp CALL scopy( nrp1, work( nwork1 ), 1, work( vfi ), 1 ) CALL scopy( nrp1, work( itemp ), 1, work( vli ), 1 ) ELSE CALL slaset( 'A', nr, nr, zero, one, u( nrf, 1 ), ldu ) CALL slaset( 'A', nrp1, nrp1, zero, one, vt( nrf, 1 ), ldu ) CALL slasdq( 'U', sqrei, nr, nrp1, nr, ncc, d( nrf ), & e( nrf ), vt( nrf, 1 ), ldu, u( nrf, 1 ), ldu, & u( nrf, 1 ), ldu, work( nwork1 ), info ) CALL scopy( nrp1, vt( nrf, 1 ), 1, work( vfi ), 1 ) CALL scopy( nrp1, vt( nrf, nrp1 ), 1, work( vli ), 1 ) END IF IF( info /= 0 ) THEN RETURN END IF DO j = 1, nr iwork( idxqi+j ) = j END DO END DO ! ! Now conquer each subproblem bottom-up. ! j = 2**nlvl DO lvl = nlvl, 1, -1 lvl2 = lvl*2 - 1 ! ! Find the first node LF and last node LL on ! the current level LVL. ! IF( lvl == 1 ) THEN lf = 1 ll = 1 ELSE lf = 2**( lvl-1 ) ll = 2*lf - 1 END IF DO i = lf, ll im1 = i - 1 ic = iwork( inode+im1 ) nl = iwork( ndiml+im1 ) nr = iwork( ndimr+im1 ) nlf = ic - nl nrf = ic + 1 IF( i == ll ) THEN sqrei = sqre ELSE sqrei = 1 END IF vfi = vf + nlf - 1 vli = vl + nlf - 1 idxqi = idxq + nlf - 1 alpha = d( ic ) beta = e( ic ) IF( icompq == 0 ) THEN CALL slasd6( icompq, nl, nr, sqrei, d( nlf ), & work( vfi ), work( vli ), alpha, beta, & iwork( idxqi ), perm, givptr( 1 ), givcol, & ldgcol, givnum, ldu, poles, difl, difr, z, & k( 1 ), c( 1 ), s( 1 ), work( nwork1 ), iwork( iwk ), info ) ELSE j = j - 1 CALL slasd6( icompq, nl, nr, sqrei, d( nlf ), & work( vfi ), work( vli ), alpha, beta, & iwork( idxqi ), perm( nlf, lvl ), & givptr( j ), givcol( nlf, lvl2 ), ldgcol, givnum( nlf, lvl2 ), ldu, & poles( nlf, lvl2 ), difl( nlf, lvl ), & difr( nlf, lvl2 ), z( nlf, lvl ), k( j ), & c( j ), s( j ), work( nwork1 ), iwork( iwk ), info ) END IF IF( info /= 0 ) THEN RETURN END IF END DO END DO ! RETURN ! ! End of SLASDA ! END SUBROUTINE slasda SUBROUTINE slasdq( uplo, sqre, n, ncvt, nru, ncc, d, e, vt, ldvt, & u, ldu, c, ldc, work, 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 .. CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: sqre INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: ncvt INTEGER, INTENT(IN) :: nru INTEGER, INTENT(IN) :: ncc REAL, INTENT(OUT) :: d( * ) REAL, INTENT(OUT) :: e( * ) REAL, INTENT(IN OUT) :: vt( ldvt, * ) INTEGER, INTENT(IN OUT) :: ldvt REAL, INTENT(IN OUT) :: u( ldu, * ) INTEGER, INTENT(IN OUT) :: ldu REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLASDQ computes the singular value decomposition (SVD) of a real ! (upper or lower) bidiagonal matrix with diagonal D and offdiagonal ! E, accumulating the transformations if desired. Letting B denote ! the input bidiagonal matrix, the algorithm computes orthogonal ! matrices Q and P such that B = Q * S * P' (P' denotes the transpose ! of P). The singular values S are overwritten on D. ! ! The input matrix U is changed to U * Q if desired. ! The input matrix VT is changed to P' * VT if desired. ! The input matrix C is changed to Q' * C if desired. ! ! See "Computing Small Singular Values of Bidiagonal Matrices With ! Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, ! LAPACK Working Note #3, for a detailed description of the algorithm. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! On entry, UPLO specifies whether the input bidiagonal matrix ! is upper or lower bidiagonal, and wether it is square are ! not. ! UPLO = 'U' or 'u' B is upper bidiagonal. ! UPLO = 'L' or 'l' B is lower bidiagonal. ! ! SQRE (input) INTEGER ! = 0: then the input matrix is N-by-N. ! = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and ! (N+1)-by-N if UPLU = 'L'. ! ! The bidiagonal matrix has ! N = NL + NR + 1 rows and ! M = N + SQRE >= N columns. ! ! N (input) INTEGER ! On entry, N specifies the number of rows and columns ! in the matrix. N must be at least 0. ! ! NCVT (input) INTEGER ! On entry, NCVT specifies the number of columns of ! the matrix VT. NCVT must be at least 0. ! ! NRU (input) INTEGER ! On entry, NRU specifies the number of rows of ! the matrix U. NRU must be at least 0. ! ! NCC (input) INTEGER ! On entry, NCC specifies the number of columns of ! the matrix C. NCC must be at least 0. ! ! D (input/output) REAL array, dimension (N) ! On entry, D contains the diagonal entries of the ! bidiagonal matrix whose SVD is desired. On normal exit, ! D contains the singular values in ascending order. ! ! E (input/output) REAL array. ! dimension is (N-1) if SQRE = 0 and N if SQRE = 1. ! On entry, the entries of E contain the offdiagonal entries ! of the bidiagonal matrix whose SVD is desired. On normal ! exit, E will contain 0. If the algorithm does not converge, ! D and E will contain the diagonal and superdiagonal entries ! of a bidiagonal matrix orthogonally equivalent to the one ! given as input. ! ! VT (input/output) REAL array, dimension (LDVT, NCVT) ! On entry, contains a matrix which on exit has been ! premultiplied by P', dimension N-by-NCVT if SQRE = 0 ! and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). ! ! LDVT (input) INTEGER ! On entry, LDVT specifies the leading dimension of VT as ! declared in the calling (sub) program. LDVT must be at ! least 1. If NCVT is nonzero LDVT must also be at least N. ! ! U (input/output) REAL array, dimension (LDU, N) ! On entry, contains a matrix which on exit has been ! postmultiplied by Q, dimension NRU-by-N if SQRE = 0 ! and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0). ! ! LDU (input) INTEGER ! On entry, LDU specifies the leading dimension of U as ! declared in the calling (sub) program. LDU must be at ! least max( 1, NRU ) . ! ! C (input/output) REAL array, dimension (LDC, NCC) ! On entry, contains an N-by-NCC matrix which on exit ! has been premultiplied by Q' dimension N-by-NCC if SQRE = 0 ! and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). ! ! LDC (input) INTEGER ! On entry, LDC specifies the leading dimension of C as ! declared in the calling (sub) program. LDC must be at ! least 1. If NCC is nonzero, LDC must also be at least N. ! ! WORK (workspace) REAL array, dimension (MAX( 1, 4*N-4 )) ! Workspace. Only referenced if one of NCVT, NRU, or NCC is ! nonzero, and if N is at least 2. ! ! INFO (output) INTEGER ! On exit, a value of 0 indicates a successful exit. ! If INFO < 0, argument number -INFO is illegal. ! If INFO > 0, the algorithm did not converge, and INFO ! specifies how many superdiagonals did not converge. ! ! Further Details ! =============== ! ! Based on contributions by ! Ming Gu and Huan Ren, Computer Science Division, University of ! California at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: rotate INTEGER :: i, isub, iuplo, j, np1, sqre1 REAL :: cs, r, smin, sn ! .. ! .. External Subroutines .. EXTERNAL sbdsqr, slartg, slasr, sswap, xerbla ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 iuplo = 0 IF( lsame( uplo, 'U' ) ) iuplo = 1 IF( lsame( uplo, 'L' ) ) iuplo = 2 IF( iuplo == 0 ) THEN info = -1 ELSE IF( ( sqre < 0 ) .OR. ( sqre > 1 ) ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( ncvt < 0 ) THEN info = -4 ELSE IF( nru < 0 ) THEN info = -5 ELSE IF( ncc < 0 ) THEN info = -6 ELSE IF( ( ncvt == 0 .AND. ldvt < 1 ) .OR. & ( ncvt > 0 .AND. ldvt < MAX( 1, n ) ) ) THEN info = -10 ELSE IF( ldu < MAX( 1, nru ) ) THEN info = -12 ELSE IF( ( ncc == 0 .AND. ldc < 1 ) .OR. & ( ncc > 0 .AND. ldc < MAX( 1, n ) ) ) THEN info = -14 END IF IF( info /= 0 ) THEN CALL xerbla( 'SBDSQR', -info ) RETURN END IF IF( n == 0 ) RETURN ! ! ROTATE is true if any singular vectors desired, false otherwise ! rotate = ( ncvt > 0 ) .OR. ( nru > 0 ) .OR. ( ncc > 0 ) np1 = n + 1 sqre1 = sqre ! ! If matrix non-square upper bidiagonal, rotate to be lower ! bidiagonal. The rotations are on the right. ! IF( ( iuplo == 1 ) .AND. ( sqre1 == 1 ) ) THEN DO i = 1, n - 1 CALL slartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) IF( rotate ) THEN work( i ) = cs work( n+i ) = sn END IF END DO CALL slartg( d( n ), e( n ), cs, sn, r ) d( n ) = r e( n ) = zero IF( rotate ) THEN work( n ) = cs work( n+n ) = sn END IF iuplo = 2 sqre1 = 0 ! ! Update singular vectors if desired. ! IF( ncvt > 0 ) CALL slasr( 'L', 'V', 'F', np1, ncvt, work( 1 ), & work( np1 ), vt, ldvt ) END IF ! ! If matrix lower bidiagonal, rotate to be upper bidiagonal ! by applying Givens rotations on the left. ! IF( iuplo == 2 ) THEN DO i = 1, n - 1 CALL slartg( d( i ), e( i ), cs, sn, r ) d( i ) = r e( i ) = sn*d( i+1 ) d( i+1 ) = cs*d( i+1 ) IF( rotate ) THEN work( i ) = cs work( n+i ) = sn END IF END DO ! ! If matrix (N+1)-by-N lower bidiagonal, one additional ! rotation is needed. ! IF( sqre1 == 1 ) THEN CALL slartg( d( n ), e( n ), cs, sn, r ) d( n ) = r IF( rotate ) THEN work( n ) = cs work( n+n ) = sn END IF END IF ! ! Update singular vectors if desired. ! IF( nru > 0 ) THEN IF( sqre1 == 0 ) THEN CALL slasr( 'R', 'V', 'F', nru, n, work( 1 ), work( np1 ), u, ldu ) ELSE CALL slasr( 'R', 'V', 'F', nru, np1, work( 1 ), work( np1 ), u, ldu ) END IF END IF IF( ncc > 0 ) THEN IF( sqre1 == 0 ) THEN CALL slasr( 'L', 'V', 'F', n, ncc, work( 1 ), work( np1 ), c, ldc ) ELSE CALL slasr( 'L', 'V', 'F', np1, ncc, work( 1 ), work( np1 ), c, ldc ) END IF END IF END IF ! ! Call SBDSQR to compute the SVD of the reduced real ! N-by-N upper bidiagonal matrix. ! CALL sbdsqr( 'U', n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c, & ldc, work, info ) ! ! Sort the singular values into ascending order (insertion sort on ! singular values, but only one transposition per singular vector) ! DO i = 1, n ! ! Scan for smallest D(I). ! isub = i smin = d( i ) DO j = i + 1, n IF( d( j ) < smin ) THEN isub = j smin = d( j ) END IF END DO IF( isub /= i ) THEN ! ! Swap singular values and vectors. ! d( isub ) = d( i ) d( i ) = smin IF( ncvt > 0 ) CALL sswap( ncvt, vt( isub, 1 ), ldvt, vt( i, 1 ), ldvt ) IF( nru > 0 ) CALL sswap( nru, u( 1, isub ), 1, u( 1, i ), 1 ) IF( ncc > 0 ) CALL sswap( ncc, c( isub, 1 ), ldc, c( i, 1 ), ldc ) END IF END DO ! RETURN ! ! End of SLASDQ ! END SUBROUTINE slasdq SUBROUTINE slasdt( n, lvl, nd, inode, ndiml, ndimr, msub ) ! ! -- 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, INTENT(IN) :: n INTEGER, INTENT(OUT) :: lvl INTEGER, INTENT(OUT) :: nd INTEGER, INTENT(OUT) :: inode( * ) INTEGER, INTENT(OUT) :: ndiml( * ) INTEGER, INTENT(OUT) :: ndimr( * ) INTEGER, INTENT(IN) :: msub ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLASDT creates a tree of subproblems for bidiagonal divide and ! conquer. ! ! Arguments ! ========= ! ! N (input) INTEGER ! On entry, the number of diagonal elements of the ! bidiagonal matrix. ! ! LVL (output) INTEGER ! On exit, the number of levels on the computation tree. ! ! ND (output) INTEGER ! On exit, the number of nodes on the tree. ! ! INODE (output) INTEGER array, dimension ( N ) ! On exit, centers of subproblems. ! ! NDIML (output) INTEGER array, dimension ( N ) ! On exit, row dimensions of left children. ! ! NDIMR (output) INTEGER array, dimension ( N ) ! On exit, row dimensions of right children. ! ! MSUB (input) INTEGER. ! On entry, the maximum row dimension each subproblem at the ! bottom of the tree can be of. ! ! Further Details ! =============== ! ! Based on contributions by ! Ming Gu and Huan Ren, Computer Science Division, University of ! California at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: two = 2.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, il, ir, llst, maxn, ncrnt, nlvl REAL :: temp ! .. ! .. Intrinsic Functions .. INTRINSIC INT, LOG, REAL ! .. ! .. Executable Statements .. ! ! Find the number of levels on the tree. ! maxn = MAX( 1, n ) temp = LOG( REAL( maxn ) / REAL( msub+1 ) ) / LOG( two ) lvl = INT( temp ) + 1 ! i = n / 2 inode( 1 ) = i + 1 ndiml( 1 ) = i ndimr( 1 ) = n - i - 1 il = 0 ir = 1 llst = 1 DO nlvl = 1, lvl - 1 ! ! Constructing the tree at (NLVL+1)-st level. The number of ! nodes created on this level is LLST * 2. ! DO i = 0, llst - 1 il = il + 2 ir = ir + 2 ncrnt = llst + i ndiml( il ) = ndiml( ncrnt ) / 2 ndimr( il ) = ndiml( ncrnt ) - ndiml( il ) - 1 inode( il ) = inode( ncrnt ) - ndimr( il ) - 1 ndiml( ir ) = ndimr( ncrnt ) / 2 ndimr( ir ) = ndimr( ncrnt ) - ndiml( ir ) - 1 inode( ir ) = inode( ncrnt ) + ndiml( ir ) + 1 END DO llst = llst*2 END DO nd = llst*2 - 1 ! RETURN ! ! End of SLASDT ! END SUBROUTINE slasdt SUBROUTINE slaset( 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: alpha REAL, INTENT(IN) :: beta REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLASET initializes an m-by-n matrix 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 strictly lower ! triangular part of A is not changed. ! = 'L': Lower triangular part is set; the strictly upper ! triangular part of A is not changed. ! Otherwise: All of the matrix A is set. ! ! 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) REAL ! The constant to which the offdiagonal elements are to be set. ! ! BETA (input) REAL ! The constant to which the diagonal elements are to be set. ! ! A (input/output) REAL array, dimension (LDA,N) ! On exit, the leading m-by-n submatrix of A is set as follows: ! ! if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, ! if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, ! otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, ! ! and, for all UPLO, 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 strictly upper triangular or trapezoidal part of the ! array to ALPHA. ! DO j = 2, n DO i = 1, MIN( j-1, m ) a( i, j ) = alpha END DO END DO ! ELSE IF( lsame( uplo, 'L' ) ) THEN ! ! Set the strictly lower triangular or trapezoidal part of the ! array to ALPHA. ! DO j = 1, MIN( m, n ) DO i = j + 1, m a( i, j ) = alpha END DO END DO ! ELSE ! ! Set the leading m-by-n submatrix to ALPHA. ! DO j = 1, n DO i = 1, m a( i, j ) = alpha END DO END DO END IF ! ! Set the first min(M,N) diagonal elements to BETA. ! DO i = 1, MIN( m, n ) a( i, i ) = beta END DO ! RETURN ! ! End of SLASET ! END SUBROUTINE slaset SUBROUTINE slasq1( 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 ! June 30, 1999 ! INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(IN) :: e( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! ! Purpose ! ======= ! ! SLASQ1 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 ! dqds", LAPACK technical report. ! ! Note : SLASQ1 works only on machines which follow ieee-754 ! floating-point standard in their handling of infinities and NaNs. ! Normal execution of SLASQ1 may create NaNs and infinities and hence ! may abort due to a floating point exception in environments which ! do not conform to the ieee standard. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The number of rows and columns in the matrix. N >= 0. ! ! D (input/output) REAL 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) REAL 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) REAL array, dimension (2*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 .. REAL, PARAMETER :: zero = 0.0E0 ! .. ! .. Local Scalars .. INTEGER :: i, iinfo REAL :: eps, scale, sfmin, sigmn, sigmx ! .. ! .. External Subroutines .. EXTERNAL scopy, slas2, slascl, slasq2, slasrt, xerbla ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT ! .. ! .. Executable Statements .. ! info = 0 IF( n < 0 ) THEN info = -2 CALL xerbla( 'SLASQ1', -info ) RETURN ELSE IF( n == 0 ) THEN RETURN ELSE IF( n == 1 ) THEN d( 1 ) = ABS( d( 1 ) ) RETURN ELSE IF( n == 2 ) THEN CALL slas2( 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 i = 1, n - 1 d( i ) = ABS( d( i ) ) sigmx = MAX( sigmx, ABS( e( i ) ) ) END DO d( n ) = ABS( d( n ) ) ! ! Early return if SIGMX is zero (matrix is already diagonal). ! IF( sigmx == zero ) THEN CALL slasrt( 'D', n, d, iinfo ) GO TO 50 END IF ! DO i = 1, n sigmx = MAX( sigmx, d( i ) ) END DO ! ! 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 = slamch( 'Precision' ) sfmin = slamch( 'Safe minimum' ) scale = SQRT( eps / sfmin ) CALL scopy( n, d, 1, work( 1 ), 2 ) CALL scopy( n-1, e, 1, work( 2 ), 2 ) CALL slascl( 'G', 0, 0, sigmx, scale, 2*n-1, 1, work, 2*n-1, iinfo ) ! ! Compute the q's and e's. ! DO i = 1, 2*n - 1 work( i ) = work( i )**2 END DO work( 2*n ) = zero ! CALL slasq2( n, work, info ) ! IF( info == 0 ) THEN DO i = 1, n d( i ) = SQRT( work( i ) ) END DO CALL slascl( 'G', 0, 0, scale, sigmx, n, 1, d, n, iinfo ) END IF ! 50 CONTINUE RETURN ! ! End of SLASQ1 ! END SUBROUTINE slasq1 SUBROUTINE slasq2( n, z, 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, INTENT(IN OUT) :: n REAL, INTENT(IN OUT) :: z( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLASQ2 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 : SLASQ2 works only on machines which follow ieee-754 ! floating-point standard in their handling of infinities and NaNs. ! Normal execution of SLASQ2 may create NaNs and infinities and hence ! may abort due to a floating point exception in environments which ! do not conform to the ieee standard. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The number of rows and columns in the matrix. N >= 0. ! ! Z (workspace) REAL 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, Z( 2*N+2 ) holds the sum of the eigenvalues, 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 .. REAL, PARAMETER :: cbias = 1.50E0 REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: half = 0.5E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: four = 4.0E0 REAL, PARAMETER :: ten = 10.0E0 REAL, PARAMETER :: hndrd = 100.0E0 ! .. ! .. Local Scalars .. INTEGER :: i0, i4, iinfo, ipn4, iter, iwhila, iwhilb, k, & n0, nbig, ndiv, nfail, pp, splt REAL :: d, desig, dmin, DMIN1, dmin2, dn, dn1, dn2, e, & emax, emin, eps, eps2, oldemn, qmax, qmin, s, sigma, t, tau, temp, trace, zmax ! .. ! .. External Subroutines .. EXTERNAL slasq3, slasq5, slasrt, xerbla ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, REAL, SQRT ! .. ! .. Executable Statements .. ! ! Test the input arguments. ! (in case SLASQ2 is not called by SLASQ1) ! info = 0 eps = slamch( 'Precision' )*ten eps2 = eps**2 ! IF( n < 0 ) THEN info = -1 CALL xerbla( 'SLASQ2', 1 ) RETURN ELSE IF( n == 0 ) THEN RETURN ELSE IF( n == 1 ) THEN ! ! 1-by-1 case. ! IF( z( 1 ) < zero ) THEN info = -201 CALL xerbla( 'SLASQ2', 2 ) END IF RETURN ELSE IF( n == 2 ) THEN ! ! 2-by-2 case. ! IF( z( 2 ) < zero .OR. z( 3 ) < zero ) THEN info = -2 CALL xerbla( 'SLASQ2', 2 ) RETURN ELSE IF( z( 3 ) > 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 ) > z( 3 )*eps2 ) THEN t = half*( ( z( 1 )-z( 3 ) )+z( 2 ) ) s = z( 3 )*( z( 2 ) / t ) IF( s <= 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 ) z( 7 ) = zero z( 8 ) = zero z( 9 ) = zero 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 d = zero e = zero ! DO k = 1, n IF( z( k ) < zero ) THEN info = -( 200+k ) CALL xerbla( 'SLASQ2', 2 ) RETURN ELSE IF( z( n+k ) < zero ) THEN info = -( 200+n+k ) CALL xerbla( 'SLASQ2', 2 ) RETURN END IF d = d + z( k ) e = e + z( n+k ) qmax = MAX( qmax, z( k ) ) END DO zmax = qmax DO k = 1, n - 1 emin = MIN( emin, z( n+k ) ) zmax = MAX( zmax, z( n+k ) ) END DO ! ! Check for diagonality. ! IF( e == zero ) THEN CALL slasrt( 'D', n, z, iinfo ) z( 2*n-1 ) = d RETURN END IF ! trace = d + e i0 = 1 n0 = n ! ! Check for zero data. ! IF( trace == zero ) THEN z( 2*n-1 ) = zero RETURN END IF ! ! Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). ! DO 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 ) END DO ! ! Reverse the qd-array, if warranted. ! IF( cbias*z( 4*i0-3 ) < z( 4*n0-3 ) ) THEN ipn4 = 4*( i0+n0 ) DO 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 END DO END IF ! ! Initial split checking via dqd and Li's test. ! pp = 0 ! DO k = 1, 2 ! IF( emin <= eps2*qmax ) THEN ! ! Li's reverse test. ! d = z( 4*n0+pp-3 ) DO i4 = 4*( n0-1 ) + pp, 4*i0 + pp, -4 IF( z( i4-1 ) <= eps2*d ) THEN z( i4-1 ) = -zero d = z( i4-3 ) ELSE d = z( i4-3 )*( d / ( d+z( i4-1 ) ) ) END IF END DO ! ! dqd maps Z to ZZ plus Li's test. ! emin = z( 4*i0+pp+1 ) d = z( 4*i0+pp-3 ) DO i4 = 4*i0 + pp, 4*( n0-1 ) + pp, 4 IF( z( i4-1 ) <= eps2*d ) THEN z( i4-1 ) = -zero z( i4-2*pp-2 ) = d z( i4-2*pp ) = zero d = z( i4+1 ) emin = zero ELSE z( i4-2*pp-2 ) = d + z( i4-1 ) 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 ) ) emin = MIN( emin, z( i4-2*pp ) ) END IF END DO z( 4*n0-pp-2 ) = d ELSE tau = zero CALL slasq5( i0, n0, z, pp, tau, dmin, DMIN1, dmin2, dn, dn1, dn2 ) ! emin = z( 4*n0 ) END IF ! ! Now find qmax. ! qmax = z( 4*i0-pp-2 ) DO i4 = 4*i0 - pp + 2, 4*n0 - pp - 2, 4 qmax = MAX( qmax, z( i4 ) ) END DO ! ! Prepare for the next iteration on K. ! pp = 1 - pp END DO ! iter = 2 nfail = 0 ndiv = 2*( n0-i0 ) ! DO iwhila = 1, n + 1 IF( n0 < 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 == n ) THEN sigma = zero ELSE sigma = -z( 4*n0-1 ) END IF IF( sigma < 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 emin = ABS( z( 4*n0-5 ) ) qmin = z( 4*n0-3 ) qmax = qmin DO i4 = 4*n0, 8, -4 IF( z( i4-5 ) <= zero ) GO TO 100 IF( qmin >= 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 ) ) END DO i4 = 4 ! 100 CONTINUE i0 = i4 / 4 ! ! Store EMIN for passing to SLASQ3. ! 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 iwhilb = 1, nbig IF( i0 > n0 ) GO TO 130 ! ! While submatrix unfinished take a good dqds step. ! CALL slasq3( i0, n0, z, pp, dmin, sigma, desig, qmax, nfail, iter, ndiv ) ! pp = 1 - pp ! ! When EMIN is very small check for splits. ! IF( pp == 0 .AND. n0-i0 >= 3 ) THEN IF( z( 4*n0 ) <= eps2*qmax .OR. z( 4*n0-1 ) <= eps2* sigma ) THEN splt = i0 - 1 qmax = z( 4*i0-3 ) emin = z( 4*i0-1 ) oldemn = z( 4*i0 ) DO i4 = 4*i0, 4*( n0-3 ), 4 IF( z( i4 ) <= eps2*z( i4-3 ) .OR. z( i4-1 ) <= eps2*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 END DO z( 4*n0-1 ) = emin z( 4*n0 ) = oldemn i0 = splt + 1 END IF END IF ! END DO ! info = 2 RETURN ! ! end IWHILB ! 130 CONTINUE ! END DO ! info = 3 RETURN ! ! end IWHILA ! 150 CONTINUE ! ! Move q's to the front. ! DO k = 2, n z( k ) = z( 4*k-3 ) END DO ! ! Sort and compute sum of eigenvalues. ! CALL slasrt( 'D', n, z, iinfo ) ! e = zero DO k = n, 1, -1 e = e + z( k ) END DO ! ! Store trace, sum(eigenvalues) and information on performance. ! z( 2*n+1 ) = trace z( 2*n+2 ) = e z( 2*n+3 ) = REAL( iter ) z( 2*n+4 ) = REAL( ndiv ) / REAL( n**2 ) z( 2*n+5 ) = hndrd*nfail / REAL( iter ) RETURN ! ! End of SLASQ2 ! END SUBROUTINE slasq2 SUBROUTINE slasq3 ( i0, n0, z, pp, dmin, sigma, desig, qmax, nfail, & iter, ndiv ) ! ! -- 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 ! INTEGER, INTENT(IN OUT) :: i0 INTEGER, INTENT(IN OUT) :: n0 REAL, INTENT(IN OUT) :: z( * ) INTEGER, INTENT(IN OUT) :: pp REAL, INTENT(IN OUT) :: dmin REAL, INTENT(IN OUT) :: sigma REAL, INTENT(IN OUT) :: desig REAL, INTENT(IN OUT) :: qmax INTEGER, INTENT(OUT) :: nfail INTEGER, INTENT(IN OUT) :: iter INTEGER, INTENT(IN OUT) :: ndiv ! ! Purpose ! ======= ! SLASQ3 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) REAL array, dimension ( 4*N ) ! Z holds the qd array. ! ! PP (input) INTEGER ! PP=0 for ping, PP=1 for pong. ! ! DMIN (output) REAL ! Minimum value of d. ! ! SIGMA (output) REAL ! Sum of shifts used in current segment. ! ! DESIG (input/output) REAL ! Lower order part of SIGMA ! ! QMAX (input) REAL ! 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. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: cbias = 1.50E0 REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: qurtr = 0.250E0 REAL, PARAMETER :: half = 0.5E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: ten = 10.0E0 ! .. ! .. Local Scalars .. INTEGER :: ipn4, j4, n0in, nn, ttype REAL :: DMIN1, dmin2, dn, dn1, dn2, eps, eps2, s, sfmin, t, tau, temp ! .. ! .. External Subroutines .. EXTERNAL slasq4, slasq5, slasq6 ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SQRT ! .. ! .. Save statement .. SAVE ttype, DMIN1, dmin2, dn, dn1, dn2, tau ! .. ! .. Data statements .. DATA ttype / 0 / DATA DMIN1 / zero / , dmin2 / zero / , dn / zero / , & dn1 / zero / , dn2 / zero / , tau / zero / ! .. ! .. Executable Statements .. ! n0in = n0 eps = slamch( 'Precision' )*ten sfmin = slamch( 'Safe minimum' ) eps2 = eps**2 ! ! Check for deflation. ! 10 CONTINUE ! IF( n0 < i0 ) RETURN IF( n0 == i0 ) GO TO 20 nn = 4*n0 + pp IF( n0 == ( i0+1 ) ) GO TO 40 ! ! Check whether E(N0-1) is negligible, 1-by-1 case. ! IF( z( nn-5 ) > eps2*( sigma+z( nn-3 ) ) .AND. z( nn-2*pp-4 ) > & eps2*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-by-2 case. ! 30 CONTINUE ! IF( z( nn-9 ) > eps2*sigma .AND. z( nn-2*pp-8 ) > eps2* z( nn-11 ) )GO TO 50 ! 40 CONTINUE ! IF( z( nn-3 ) > z( nn-7 ) ) THEN s = z( nn-3 ) z( nn-3 ) = z( nn-7 ) z( nn-7 ) = s END IF IF( z( nn-5 ) > z( nn-3 )*eps2 ) THEN t = half*( ( z( nn-7 )-z( nn-3 ) )+z( nn-5 ) ) s = z( nn-3 )*( z( nn-5 ) / t ) IF( s <= 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 <= zero .OR. n0 < n0in ) THEN IF( cbias*z( 4*i0+pp-3 ) < z( 4*n0+pp-3 ) ) THEN ipn4 = 4*( i0+n0 ) DO 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 END DO IF( n0-i0 <= 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*i0-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 < zero .OR. sfmin*qmax <= & MIN( z( 4*n0+pp-1 ), z( 4*n0+pp-9 ), dmin2+z( 4*n0-pp ) ) ) THEN ! ! Choose a shift. ! CALL slasq4( i0, n0, z, pp, n0in, dmin, DMIN1, dmin2, dn, dn1, & dn2, tau, ttype ) ! ! Call dqds until DMIN > 0. ! 80 CONTINUE ! CALL slasq5( i0, n0, z, pp, tau, dmin, DMIN1, dmin2, dn, dn1, dn2 ) ! iter = iter + 1 ndiv = ndiv + ( n0-i0+2 ) ! ! Check for NaN: "DMIN.NE.DMIN" ! IF( dmin /= dmin ) THEN z( 4*n0+pp-1 ) = zero tau = zero GO TO 70 END IF ! ! Check for convergence hidden by negative DN. ! IF( dmin < zero .AND. DMIN1 > zero .AND. & z( 4*( n0-1 )-pp ) < eps*( sigma+dn1 ) .AND. ABS( dn ) < eps*sigma ) THEN z( 4*( n0-1 )-pp+2 ) = zero dmin = ABS( dmin ) END IF ! IF( dmin < zero ) THEN ! ! Failure. Select new TAU and try again. ! nfail = nfail + 1 ! ! Failed twice. Play it safe. ! IF( ttype < -22 ) THEN tau = zero GO TO 80 END IF ! IF( DMIN1 > 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 END IF ELSE CALL slasq6( i0, n0, z, pp, dmin, DMIN1, dmin2, dn, dn1, dn2 ) iter = iter + 1 ndiv = ndiv + ( n0-i0 ) tau = zero END IF ! IF( tau < 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 SLASQ3 ! END SUBROUTINE slasq3 SUBROUTINE slasq4( 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 ! June 30, 1999 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: i0 INTEGER, INTENT(IN) :: n0 REAL, INTENT(IN) :: z( * ) INTEGER, INTENT(IN) :: pp INTEGER, INTENT(IN) :: n0in REAL, INTENT(IN) :: dmin REAL, INTENT(IN) :: DMIN1 REAL, INTENT(IN) :: dmin2 REAL, INTENT(IN) :: dn REAL, INTENT(IN) :: dn1 REAL, INTENT(IN) :: dn2 REAL, INTENT(OUT) :: tau INTEGER, INTENT(OUT) :: ttype ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! SLASQ4 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) REAL 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) REAL ! Minimum value of d. ! ! DMIN1 (input) REAL ! Minimum value of d, excluding D( N0 ). ! ! DMIN2 (input) REAL ! Minimum value of d, excluding D( N0 ) and D( N0-1 ). ! ! DN (input) REAL ! d(N) ! ! DN1 (input) REAL ! d(N-1) ! ! DN2 (input) REAL ! d(N-2) ! ! TAU (output) REAL ! This is the shift. ! ! TTYPE (output) INTEGER ! Shift type. ! ! Further Details ! =============== ! CNST1 = 9/16 ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: cnst1 = 0.5630E0 REAL, PARAMETER :: cnst2 = 1.010E0 REAL, PARAMETER :: cnst3 = 1.050E0 REAL, PARAMETER :: qurtr = 0.250E0 REAL, PARAMETER :: third = 0.3330E0 REAL, PARAMETER :: half = 0.50E0 REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: hndrd = 100.0E0 ! .. ! .. Local Scalars .. INTEGER :: i4, nn, np REAL :: a2, b1, b2, g, gam, gap1, gap2, s ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT ! .. ! .. Save statement .. SAVE g ! .. ! .. Data statements .. DATA g / zero / ! .. ! .. Executable Statements .. ! ! A negative DMIN forces the shift to take that absolute value ! TTYPE records the type of shift. ! ttype = 0 IF( dmin <= zero ) THEN tau = -dmin ttype = -1 RETURN END IF nn = 4*n0 + pp IF( n0in == n0 ) THEN ! ! No eigenvalues deflated. ! IF( dmin == dn .OR. dmin == 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 == dn .AND. DMIN1 == dn1 ) THEN gap2 = dmin2 - a2 - dmin2*qurtr IF( gap2 > zero .AND. gap2 > b2 ) THEN gap1 = a2 - dn - ( b2 / gap2 )*b2 ELSE gap1 = a2 - dn - ( b1+b2 ) END IF IF( gap1 > zero .AND. gap1 > b1 ) THEN s = MAX( dn-( b1 / gap1 )*b1, half*dmin ) ttype = -2 ELSE s = zero IF( dn > b1 ) s = dn - b1 IF( a2 > ( b1+b2 ) ) s = MIN( s, a2-( b1+b2 ) ) s = MAX( s, third*dmin ) ttype = -3 END IF ELSE ! ! Case 4. ! IF( dmin == dn ) THEN gam = dn a2 = zero b2 = z( nn-5 ) / z( nn-7 ) np = nn - 9 ELSE np = nn - 2*pp b2 = z( np-2 ) gam = dn1 a2 = z( np-4 ) / z( np-2 ) b2 = z( nn-9 ) / z( nn-11 ) np = nn - 13 END IF ! ! Approximate contribution to norm squared from I < NN-1. ! IF( b2 == zero ) GO TO 20 a2 = a2 + b2 DO i4 = np, 4*i0 - 1 + pp, -4 b1 = b2 b2 = b2*( z( i4 ) / z( i4-2 ) ) a2 = a2 + b2 IF( hndrd*MAX( b2, b1 ) < a2 .OR. cnst1 < a2 ) EXIT END DO 20 CONTINUE a2 = cnst3*a2 ! ! Rayleigh quotient residual bound. ! IF( a2 < cnst1 ) THEN s = gam*( one-SQRT( a2 ) ) / ( one+a2 ) ELSE s = qurtr*gam END IF ttype = -4 END IF ELSE IF( dmin == dn2 ) THEN ! ! Case 5. ! ! Compute contribution to norm squared from I > NN-2. ! np = nn - 2*pp b1 = z( np-2 ) b2 = z( np-6 ) gam = dn2 a2 = ( z( np-8 ) / b2 )*( one+z( np-4 ) / b1 ) ! ! Approximate contribution to norm squared from I < NN-2. ! IF( n0-i0 > 2 ) THEN b2 = z( nn-13 ) / z( nn-15 ) IF( b2 == zero ) GO TO 40 a2 = a2 + b2 DO i4 = nn - 17, 4*i0 - 1 + pp, -4 b1 = b2 b2 = b2*( z( i4 ) / z( i4-2 ) ) a2 = a2 + b2 IF( hndrd*MAX( b2, b1 ) < a2 .OR. cnst1 < a2 ) EXIT END DO 40 CONTINUE a2 = cnst3*a2 END IF ! IF( a2 < cnst1 ) THEN s = gam*( one-SQRT( a2 ) ) / ( one+a2 ) ELSE s = qurtr*gam / ( one+a2 ) END IF ttype = -5 ELSE ! ! Case 6, no information to guide us. ! IF( ttype == -6 ) THEN g = g + third*( one-g ) ELSE IF( ttype == -18 ) THEN g = qurtr*third ELSE g = qurtr END IF s = g*dmin ttype = -6 END IF ! ELSE IF( n0in == ( n0+1 ) ) THEN ! ! One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. ! IF( DMIN1 == dn1 .AND. dmin2 == dn2 ) THEN ! ! Cases 7 and 8. ! b1 = z( nn-5 ) / z( nn-7 ) b2 = b1 IF( b2 == zero ) GO TO 60 DO i4 = 4*n0 - 9 + pp, 4*i0 - 1 + pp, -4 a2 = b1 b1 = b1*( z( i4 ) / z( i4-2 ) ) b2 = b2 + b1 IF( hndrd*MAX( b1, a2 ) < b2 ) EXIT END DO 60 CONTINUE b2 = SQRT( cnst3*b2 ) a2 = DMIN1 / ( one+b2**2 ) gap2 = half*dmin2 - a2 IF( gap2 > zero .AND. gap2 > b2*a2 ) THEN s = MAX( a2*( one-cnst2*a2*( b2 / gap2 )*b2 ), third*DMIN1 ) ttype = -7 ELSE s = MAX( a2*( one-cnst2*b2 ), third*DMIN1 ) ttype = -8 END IF ELSE ! ! Case 9. ! s = qurtr*DMIN1 IF( DMIN1 == dn1 ) s = half*DMIN1 ttype = -9 END IF ! ELSE IF( n0in == ( n0+2 ) ) THEN ! ! Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. ! ! Cases 10 and 11. ! IF( dmin2 == dn2 .AND. two*z( nn-5 ) < z( nn-7 ) ) THEN b1 = z( nn-5 ) / z( nn-7 ) b2 = b1 IF( b2 == zero ) GO TO 80 DO i4 = 4*n0 - 9 + pp, 4*i0 - 1 + pp, -4 b1 = b1*( z( i4 ) / z( i4-2 ) ) b2 = b2 + b1 IF( hndrd*b1 < b2 ) EXIT END DO 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 > zero .AND. gap2 > b2*a2 ) THEN s = MAX( a2*( one-cnst2*a2*( b2 / gap2 )*b2 ), third*dmin2 ) ELSE s = MAX( a2*( one-cnst2*b2 ), third*dmin2 ) END IF ttype = -10 ELSE s = qurtr*dmin2 ttype = -11 END IF ELSE IF( n0in > ( n0+2 ) ) THEN ! ! Case 12, more than two eigenvalues deflated. No information. ! s = zero ttype = -12 END IF ! tau = s RETURN ! ! End of SLASQ4 ! END SUBROUTINE slasq4 SUBROUTINE slasq5( i0, n0, z, pp, tau, 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 ! June 30, 1999 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: i0 INTEGER, INTENT(IN OUT) :: n0 REAL, INTENT(IN OUT) :: z( * ) INTEGER, INTENT(IN OUT) :: pp REAL, INTENT(IN) :: tau REAL, INTENT(OUT) :: dmin REAL, INTENT(OUT) :: DMIN1 REAL, INTENT(OUT) :: dmin2 REAL, INTENT(OUT) :: dn REAL, INTENT(OUT) :: dnm1 REAL, INTENT(OUT) :: dnm2 ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! SLASQ5 computes one dqds transform in ping-pong form. ! ! Arguments ! ========= ! ! I0 (input) INTEGER ! First index. ! ! N0 (input) INTEGER ! Last index. ! ! Z (input) REAL 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) REAL ! This is the shift. ! ! DMIN (output) REAL ! Minimum value of d. ! ! DMIN1 (output) REAL ! Minimum value of d, excluding D( N0 ). ! ! DMIN2 (output) REAL ! Minimum value of d, excluding D( N0 ) and D( N0-1 ). ! ! DN (output) REAL ! d(N0), the last value of d. ! ! DNM1 (output) REAL ! d(N0-1). ! ! DNM2 (output) REAL ! d(N0-2). ! ! ===================================================================== ! ! .. Local Scalars .. INTEGER :: j4, j4p2 REAL :: d, emin, temp ! .. ! .. Intrinsic Functions .. INTRINSIC MIN ! .. ! .. Executable Statements .. ! IF( ( n0-i0-1 ) <= 0 ) RETURN ! j4 = 4*i0 + pp - 3 emin = z( j4+4 ) d = z( j4 ) - tau dmin = d ! IF( pp == 0 ) THEN DO 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 ) END DO ELSE DO 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 ) END DO 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 ) ! z( j4+2 ) = dn z( 4*n0-pp ) = emin RETURN ! ! End of SLASQ5 ! END SUBROUTINE slasq5 SUBROUTINE slasq6( 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 ! June 30, 1999 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: i0 INTEGER, INTENT(IN OUT) :: n0 REAL, INTENT(IN OUT) :: z( * ) INTEGER, INTENT(IN OUT) :: pp REAL, INTENT(OUT) :: dmin REAL, INTENT(OUT) :: DMIN1 REAL, INTENT(OUT) :: dmin2 REAL, INTENT(OUT) :: dn REAL, INTENT(OUT) :: dnm1 REAL, INTENT(OUT) :: dnm2 ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! SLASQ6 computes one dqds transform in ping-pong form. ! ! Arguments ! ========= ! ! I0 (input) INTEGER ! First index. ! ! N0 (input) INTEGER ! Last index. ! ! Z (input) REAL 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) REAL ! Minimum value of d. ! ! DMIN1 (output) REAL ! Minimum value of d, excluding D( N0 ). ! ! DMIN2 (output) REAL ! Minimum value of d, excluding D( N0 ) and D( N0-1 ). ! ! DN (output) REAL ! d(N0), the last value of d. ! ! DNM1 (output) REAL ! d(N0-1). ! ! DNM2 (output) REAL ! d(N0-2). ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 ! .. ! .. Local Scalars .. INTEGER :: j4, j4p2 REAL :: d, emin, sfmin, temp ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. Intrinsic Functions .. INTRINSIC MIN ! .. ! .. Executable Statements .. ! IF( ( n0-i0-1 ) <= 0 ) RETURN ! sfmin = slamch( 'Safe minimum' ) j4 = 4*i0 + pp - 3 emin = z( j4+4 ) d = z( j4 ) dmin = d ! DO j4 = 4*i0 - pp, 4*( n0-3 ) - pp, 4 j4p2 = j4 + 2*pp - 1 z( j4-2 ) = d + z( j4p2 ) IF( z( j4-2 ) == zero ) THEN z( j4 ) = zero d = z( j4p2+2 ) dmin = d emin = zero ELSE IF( sfmin*z( j4p2+2 ) < z( j4-2 ) ) THEN temp = z( j4p2+2 ) / z( j4-2 ) z( j4 ) = z( j4p2 )*temp d = d*temp ELSE z( j4 ) = z( j4p2+2 )*( z( j4p2 ) / z( j4-2 ) ) d = z( j4p2+2 )*( d / z( j4-2 ) ) END IF dmin = MIN( dmin, d ) emin = MIN( emin, z( j4 ) ) END DO ! ! 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 ) == zero ) THEN z( j4 ) = zero dnm1 = z( j4p2+2 ) dmin = dnm1 emin = zero ELSE IF( sfmin*z( j4p2+2 ) < z( j4-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 ) == zero ) THEN z( j4 ) = zero dn = z( j4p2+2 ) dmin = dn emin = zero ELSE IF( sfmin*z( j4p2+2 ) < z( j4-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 SLASQ6 ! END SUBROUTINE slasq6 SUBROUTINE slasr( 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 (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: pivot CHARACTER (LEN=1), INTENT(IN) :: DIRECT INTEGER, INTENT(IN OUT) :: m INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN) :: c( * ) REAL, INTENT(IN) :: s( * ) REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLASR 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) REAL 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) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, info, j REAL :: 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 < 0 ) THEN info = 4 ELSE IF( n < 0 ) THEN info = 5 ELSE IF( lda < MAX( 1, m ) ) THEN info = 9 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLASR ', info ) RETURN END IF ! ! Quick return if possible ! IF( ( m == 0 ) .OR. ( n == 0 ) ) RETURN IF( lsame( side, 'L' ) ) THEN ! ! Form P * A ! IF( lsame( pivot, 'V' ) ) THEN IF( lsame( DIRECT, 'F' ) ) THEN DO j = 1, m - 1 ctemp = c( j ) stemp = s( j ) IF( ( ctemp /= one ) .OR. ( stemp /= zero ) ) THEN DO 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 ) END DO END IF END DO ELSE IF( lsame( DIRECT, 'B' ) ) THEN DO j = m - 1, 1, -1 ctemp = c( j ) stemp = s( j ) IF( ( ctemp /= one ) .OR. ( stemp /= zero ) ) THEN DO 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 ) END DO END IF END DO END IF ELSE IF( lsame( pivot, 'T' ) ) THEN IF( lsame( DIRECT, 'F' ) ) THEN DO j = 2, m ctemp = c( j-1 ) stemp = s( j-1 ) IF( ( ctemp /= one ) .OR. ( stemp /= zero ) ) THEN DO 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 ) END DO END IF END DO ELSE IF( lsame( DIRECT, 'B' ) ) THEN DO j = m, 2, -1 ctemp = c( j-1 ) stemp = s( j-1 ) IF( ( ctemp /= one ) .OR. ( stemp /= zero ) ) THEN DO 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 ) END DO END IF END DO END IF ELSE IF( lsame( pivot, 'B' ) ) THEN IF( lsame( DIRECT, 'F' ) ) THEN DO j = 1, m - 1 ctemp = c( j ) stemp = s( j ) IF( ( ctemp /= one ) .OR. ( stemp /= zero ) ) THEN DO 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 END DO END IF END DO ELSE IF( lsame( DIRECT, 'B' ) ) THEN DO j = m - 1, 1, -1 ctemp = c( j ) stemp = s( j ) IF( ( ctemp /= one ) .OR. ( stemp /= zero ) ) THEN DO 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 END DO END IF END DO END IF END IF ELSE IF( lsame( side, 'R' ) ) THEN ! ! Form A * P' ! IF( lsame( pivot, 'V' ) ) THEN IF( lsame( DIRECT, 'F' ) ) THEN DO j = 1, n - 1 ctemp = c( j ) stemp = s( j ) IF( ( ctemp /= one ) .OR. ( stemp /= zero ) ) THEN DO 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 ) END DO END IF END DO ELSE IF( lsame( DIRECT, 'B' ) ) THEN DO j = n - 1, 1, -1 ctemp = c( j ) stemp = s( j ) IF( ( ctemp /= one ) .OR. ( stemp /= zero ) ) THEN DO 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 ) END DO END IF END DO END IF ELSE IF( lsame( pivot, 'T' ) ) THEN IF( lsame( DIRECT, 'F' ) ) THEN DO j = 2, n ctemp = c( j-1 ) stemp = s( j-1 ) IF( ( ctemp /= one ) .OR. ( stemp /= zero ) ) THEN DO 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 ) END DO END IF END DO ELSE IF( lsame( DIRECT, 'B' ) ) THEN DO j = n, 2, -1 ctemp = c( j-1 ) stemp = s( j-1 ) IF( ( ctemp /= one ) .OR. ( stemp /= zero ) ) THEN DO 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 ) END DO END IF END DO END IF ELSE IF( lsame( pivot, 'B' ) ) THEN IF( lsame( DIRECT, 'F' ) ) THEN DO j = 1, n - 1 ctemp = c( j ) stemp = s( j ) IF( ( ctemp /= one ) .OR. ( stemp /= zero ) ) THEN DO 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 END DO END IF END DO ELSE IF( lsame( DIRECT, 'B' ) ) THEN DO j = n - 1, 1, -1 ctemp = c( j ) stemp = s( j ) IF( ( ctemp /= one ) .OR. ( stemp /= zero ) ) THEN DO 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 END DO END IF END DO END IF END IF END IF ! RETURN ! ! End of SLASR ! END SUBROUTINE slasr SUBROUTINE slasrt( 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 (LEN=1), INTENT(IN) :: id INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: d( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! 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) REAL 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, PARAMETER :: select = 20 ! .. ! .. Local Scalars .. INTEGER :: dir, endd, i, j, start, stkpnt REAL :: 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 == -1 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLASRT', -info ) RETURN END IF ! ! Quick return if possible ! IF( n <= 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 <= select .AND. endd-start > 0 ) THEN ! ! Do Insertion sort on D( START:ENDD ) ! IF( dir == 0 ) THEN ! ! Sort into decreasing order ! loop30: DO i = start + 1, endd DO j = i, start + 1, -1 IF( d( j ) > d( j-1 ) ) THEN dmnmx = d( j ) d( j ) = d( j-1 ) d( j-1 ) = dmnmx ELSE CYCLE loop30 END IF END DO END DO loop30 ! ELSE ! ! Sort into increasing order ! loop50: DO i = start + 1, endd DO j = i, start + 1, -1 IF( d( j ) < d( j-1 ) ) THEN dmnmx = d( j ) d( j ) = d( j-1 ) d( j-1 ) = dmnmx ELSE CYCLE loop50 END IF END DO END DO loop50 ! END IF ! ELSE IF( endd-start > 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 < d2 ) THEN IF( d3 < d1 ) THEN dmnmx = d1 ELSE IF( d3 < d2 ) THEN dmnmx = d3 ELSE dmnmx = d2 END IF ELSE IF( d3 < d2 ) THEN dmnmx = d2 ELSE IF( d3 < d1 ) THEN dmnmx = d3 ELSE dmnmx = d1 END IF END IF ! IF( dir == 0 ) THEN ! ! Sort into decreasing order ! i = start - 1 j = endd + 1 60 CONTINUE 70 CONTINUE j = j - 1 IF( d( j ) < dmnmx ) GO TO 70 80 CONTINUE i = i + 1 IF( d( i ) > dmnmx ) GO TO 80 IF( i < j ) THEN tmp = d( i ) d( i ) = d( j ) d( j ) = tmp GO TO 60 END IF IF( j-start > 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 ) > dmnmx ) GO TO 100 110 CONTINUE i = i + 1 IF( d( i ) < dmnmx ) GO TO 110 IF( i < j ) THEN tmp = d( i ) d( i ) = d( j ) d( j ) = tmp GO TO 90 END IF IF( j-start > 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 > 0 ) GO TO 10 RETURN ! ! End of SLASRT ! END SUBROUTINE slasrt SUBROUTINE slassq( 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, INTENT(IN) :: n REAL, INTENT(IN) :: x( * ) INTEGER, INTENT(IN) :: incx REAL, INTENT(IN OUT) :: scale REAL, INTENT(OUT) :: sumsq ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLASSQ 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) REAL array, dimension (N) ! 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) REAL ! 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) REAL ! 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 .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: ix REAL :: absxi ! .. ! .. Intrinsic Functions .. INTRINSIC ABS ! .. ! .. Executable Statements .. ! IF( n > 0 ) THEN DO ix = 1, 1 + ( n-1 )*incx, incx IF( x( ix ) /= zero ) THEN absxi = ABS( x( ix ) ) IF( scale < absxi ) THEN sumsq = 1 + sumsq*( scale / absxi )**2 scale = absxi ELSE sumsq = sumsq + ( absxi / scale )**2 END IF END IF END DO END IF RETURN ! ! End of SLASSQ ! END SUBROUTINE slassq SUBROUTINE slasv2( 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 .. REAL, INTENT(IN) :: f REAL, INTENT(IN) :: g REAL, INTENT(IN) :: h REAL, INTENT(OUT) :: ssmin REAL, INTENT(OUT) :: ssmax REAL, INTENT(OUT) :: snr REAL, INTENT(OUT) :: csr REAL, INTENT(OUT) :: snl REAL, INTENT(OUT) :: csl ! .. ! ! Purpose ! ======= ! ! SLASV2 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) REAL ! The (1,1) element of the 2-by-2 matrix. ! ! G (input) REAL ! The (1,2) element of the 2-by-2 matrix. ! ! H (input) REAL ! The (2,2) element of the 2-by-2 matrix. ! ! SSMIN (output) REAL ! abs(SSMIN) is the smaller singular value. ! ! SSMAX (output) REAL ! abs(SSMAX) is the larger singular value. ! ! SNL (output) REAL ! CSL (output) REAL ! The vector (CSL, SNL) is a unit left singular vector for the ! singular value abs(SSMAX). ! ! SNR (output) REAL ! CSR (output) REAL ! 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 .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: half = 0.5E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: four = 4.0E0 ! .. ! .. Local Scalars .. LOGICAL :: gasmal, swap INTEGER :: pmax REAL :: 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 .. REAL :: slamch EXTERNAL slamch ! .. ! .. 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 > 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 == zero ) THEN ! ! Diagonal matrix ! ssmin = ha ssmax = fa clt = one crt = one slt = zero srt = zero ELSE gasmal = .true. IF( ga > fa ) THEN pmax = 2 IF( ( fa / ga ) < slamch( 'EPS' ) ) THEN ! ! Case of very large GA ! gasmal = .false. ssmax = ga IF( ha > 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 == 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 == 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 == zero ) THEN ! ! Note that M is very tiny ! IF( l == 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 == 1 ) tsign = SIGN( one, csr )*SIGN( one, csl )*SIGN( one, f ) IF( pmax == 2 ) tsign = SIGN( one, snr )*SIGN( one, csl )*SIGN( one, g ) IF( pmax == 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 SLASV2 ! END SUBROUTINE slasv2 SUBROUTINE slaswp( 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, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(IN) :: k1 INTEGER, INTENT(IN) :: k2 INTEGER, INTENT(IN) :: ipiv( * ) INTEGER, INTENT(IN) :: incx ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLASWP 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) REAL 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 REAL :: temp ! .. ! .. Executable Statements .. ! ! Interchange row I with row IPIV(I) for each of rows K1 through K2. ! IF( incx > 0 ) THEN ix0 = k1 i1 = k1 i2 = k2 inc = 1 ELSE IF( incx < 0 ) THEN ix0 = 1 + ( 1-k2 )*incx i1 = k2 i2 = k1 inc = -1 ELSE RETURN END IF ! n32 = ( n / 32 )*32 IF( n32 /= 0 ) THEN DO j = 1, n32, 32 ix = ix0 DO i = i1, i2, inc ip = ipiv( ix ) IF( ip /= i ) THEN DO k = j, j + 31 temp = a( i, k ) a( i, k ) = a( ip, k ) a( ip, k ) = temp END DO END IF ix = ix + incx END DO END DO END IF IF( n32 /= n ) THEN n32 = n32 + 1 ix = ix0 DO i = i1, i2, inc ip = ipiv( ix ) IF( ip /= i ) THEN DO k = n32, n temp = a( i, k ) a( i, k ) = a( ip, k ) a( ip, k ) = temp END DO END IF ix = ix + incx END DO END IF ! RETURN ! ! End of SLASWP ! END SUBROUTINE slaswp SUBROUTINE slasy2( ltranl, ltranr, isgn, n1, n2, tl, ldtl, tr, & ldtr, b, ldb, scale, x, ldx, xnorm, 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 .. LOGICAL, INTENT(IN) :: ltranl LOGICAL, INTENT(IN) :: ltranr INTEGER, INTENT(IN) :: isgn INTEGER, INTENT(IN) :: n1 INTEGER, INTENT(IN) :: n2 REAL, INTENT(IN) :: tl( ldtl, * ) INTEGER, INTENT(IN OUT) :: ldtl REAL, INTENT(IN) :: tr( ldtr, * ) INTEGER, INTENT(IN OUT) :: ldtr REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(OUT) :: scale REAL, INTENT(OUT) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: xnorm INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in ! ! op(TL)*X + ISGN*X*op(TR) = SCALE*B, ! ! where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or ! -1. op(T) = T or T', where T' denotes the transpose of T. ! ! Arguments ! ========= ! ! LTRANL (input) LOGICAL ! On entry, LTRANL specifies the op(TL): ! = .FALSE., op(TL) = TL, ! = .TRUE., op(TL) = TL'. ! ! LTRANR (input) LOGICAL ! On entry, LTRANR specifies the op(TR): ! = .FALSE., op(TR) = TR, ! = .TRUE., op(TR) = TR'. ! ! ISGN (input) INTEGER ! On entry, ISGN specifies the sign of the equation ! as described before. ISGN may only be 1 or -1. ! ! N1 (input) INTEGER ! On entry, N1 specifies the order of matrix TL. ! N1 may only be 0, 1 or 2. ! ! N2 (input) INTEGER ! On entry, N2 specifies the order of matrix TR. ! N2 may only be 0, 1 or 2. ! ! TL (input) REAL array, dimension (LDTL,2) ! On entry, TL contains an N1 by N1 matrix. ! ! LDTL (input) INTEGER ! The leading dimension of the matrix TL. LDTL >= max(1,N1). ! ! TR (input) REAL array, dimension (LDTR,2) ! On entry, TR contains an N2 by N2 matrix. ! ! LDTR (input) INTEGER ! The leading dimension of the matrix TR. LDTR >= max(1,N2). ! ! B (input) REAL array, dimension (LDB,2) ! On entry, the N1 by N2 matrix B contains the right-hand ! side of the equation. ! ! LDB (input) INTEGER ! The leading dimension of the matrix B. LDB >= max(1,N1). ! ! SCALE (output) REAL ! On exit, SCALE contains the scale factor. SCALE is chosen ! less than or equal to 1 to prevent the solution overflowing. ! ! X (output) REAL array, dimension (LDX,2) ! On exit, X contains the N1 by N2 solution. ! ! LDX (input) INTEGER ! The leading dimension of the matrix X. LDX >= max(1,N1). ! ! XNORM (output) REAL ! On exit, XNORM is the infinity-norm of the solution. ! ! INFO (output) INTEGER ! On exit, INFO is set to ! 0: successful exit. ! 1: TL and TR have too close eigenvalues, so TL or ! TR is perturbed to get a nonsingular equation. ! NOTE: In the interests of speed, this routine does not ! check the inputs for errors. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 REAL, PARAMETER :: half = 0.5E+0 REAL, PARAMETER :: eight = 8.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: bswap, xswap INTEGER :: i, ip, ipiv, ipsv, j, jp, jpsv, k REAL :: bet, eps, gam, l21, sgn, smin, smlnum, tau1, temp, u11, u12, u22, xmax ! .. ! .. Local Arrays .. LOGICAL :: bswpiv( 4 ), xswpiv( 4 ) INTEGER :: jpiv( 4 ), locl21( 4 ), locu12( 4 ), locu22( 4 ) REAL :: btmp( 4 ), t16( 4, 4 ), tmp( 4 ), x2( 2 ) ! .. ! .. External Functions .. INTEGER :: isamax REAL :: slamch EXTERNAL isamax, slamch ! .. ! .. External Subroutines .. EXTERNAL scopy, sswap ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. Data statements .. DATA locu12 / 3, 4, 1, 2 / , locl21 / 2, 1, 4, 3 / , & locu22 / 4, 3, 2, 1 / DATA xswpiv / .false., .false., .true., .true. / DATA bswpiv / .false., .true., .false., .true. / ! .. ! .. Executable Statements .. ! ! Do not check the input parameters for errors ! info = 0 ! ! Quick return if possible ! IF( n1 == 0 .OR. n2 == 0 ) RETURN ! ! Set constants to control overflow ! eps = slamch( 'P' ) smlnum = slamch( 'S' ) / eps sgn = isgn ! k = n1 + n1 + n2 - 2 SELECT CASE ( k ) CASE ( 1) GO TO 10 CASE ( 2) GO TO 20 CASE ( 3) GO TO 30 CASE ( 4) GO TO 50 END SELECT ! ! 1 by 1: TL11*X + SGN*X*TR11 = B11 ! 10 CONTINUE tau1 = tl( 1, 1 ) + sgn*tr( 1, 1 ) bet = ABS( tau1 ) IF( bet <= smlnum ) THEN tau1 = smlnum bet = smlnum info = 1 END IF ! scale = one gam = ABS( b( 1, 1 ) ) IF( smlnum*gam > bet ) scale = one / gam ! x( 1, 1 ) = ( b( 1, 1 )*scale ) / tau1 xnorm = ABS( x( 1, 1 ) ) RETURN ! ! 1 by 2: ! TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12] ! [TR21 TR22] ! 20 CONTINUE ! smin = MAX( eps*MAX( ABS( tl( 1, 1 ) ), ABS( tr( 1, 1 ) ), & ABS( tr( 1, 2 ) ), ABS( tr( 2, 1 ) ), ABS( tr( 2, 2 ) ) ), smlnum ) tmp( 1 ) = tl( 1, 1 ) + sgn*tr( 1, 1 ) tmp( 4 ) = tl( 1, 1 ) + sgn*tr( 2, 2 ) IF( ltranr ) THEN tmp( 2 ) = sgn*tr( 2, 1 ) tmp( 3 ) = sgn*tr( 1, 2 ) ELSE tmp( 2 ) = sgn*tr( 1, 2 ) tmp( 3 ) = sgn*tr( 2, 1 ) END IF btmp( 1 ) = b( 1, 1 ) btmp( 2 ) = b( 1, 2 ) GO TO 40 ! ! 2 by 1: ! op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11] ! [TL21 TL22] [X21] [X21] [B21] ! 30 CONTINUE smin = MAX( eps*MAX( ABS( tr( 1, 1 ) ), ABS( tl( 1, 1 ) ), & ABS( tl( 1, 2 ) ), ABS( tl( 2, 1 ) ), ABS( tl( 2, 2 ) ) ), smlnum ) tmp( 1 ) = tl( 1, 1 ) + sgn*tr( 1, 1 ) tmp( 4 ) = tl( 2, 2 ) + sgn*tr( 1, 1 ) IF( ltranl ) THEN tmp( 2 ) = tl( 1, 2 ) tmp( 3 ) = tl( 2, 1 ) ELSE tmp( 2 ) = tl( 2, 1 ) tmp( 3 ) = tl( 1, 2 ) END IF btmp( 1 ) = b( 1, 1 ) btmp( 2 ) = b( 2, 1 ) 40 CONTINUE ! ! Solve 2 by 2 system using complete pivoting. ! Set pivots less than SMIN to SMIN. ! ipiv = isamax( 4, tmp, 1 ) u11 = tmp( ipiv ) IF( ABS( u11 ) <= smin ) THEN info = 1 u11 = smin END IF u12 = tmp( locu12( ipiv ) ) l21 = tmp( locl21( ipiv ) ) / u11 u22 = tmp( locu22( ipiv ) ) - u12*l21 xswap = xswpiv( ipiv ) bswap = bswpiv( ipiv ) IF( ABS( u22 ) <= smin ) THEN info = 1 u22 = smin END IF IF( bswap ) THEN temp = btmp( 2 ) btmp( 2 ) = btmp( 1 ) - l21*temp btmp( 1 ) = temp ELSE btmp( 2 ) = btmp( 2 ) - l21*btmp( 1 ) END IF scale = one IF( ( two*smlnum )*ABS( btmp( 2 ) ) > ABS( u22 ) .OR. & ( two*smlnum )*ABS( btmp( 1 ) ) > ABS( u11 ) ) THEN scale = half / MAX( ABS( btmp( 1 ) ), ABS( btmp( 2 ) ) ) btmp( 1 ) = btmp( 1 )*scale btmp( 2 ) = btmp( 2 )*scale END IF x2( 2 ) = btmp( 2 ) / u22 x2( 1 ) = btmp( 1 ) / u11 - ( u12 / u11 )*x2( 2 ) IF( xswap ) THEN temp = x2( 2 ) x2( 2 ) = x2( 1 ) x2( 1 ) = temp END IF x( 1, 1 ) = x2( 1 ) IF( n1 == 1 ) THEN x( 1, 2 ) = x2( 2 ) xnorm = ABS( x( 1, 1 ) ) + ABS( x( 1, 2 ) ) ELSE x( 2, 1 ) = x2( 2 ) xnorm = MAX( ABS( x( 1, 1 ) ), ABS( x( 2, 1 ) ) ) END IF RETURN ! ! 2 by 2: ! op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12] ! [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22] ! ! Solve equivalent 4 by 4 system using complete pivoting. ! Set pivots less than SMIN to SMIN. ! 50 CONTINUE smin = MAX( ABS( tr( 1, 1 ) ), ABS( tr( 1, 2 ) ), & ABS( tr( 2, 1 ) ), ABS( tr( 2, 2 ) ) ) smin = MAX( smin, ABS( tl( 1, 1 ) ), ABS( tl( 1, 2 ) ), & ABS( tl( 2, 1 ) ), ABS( tl( 2, 2 ) ) ) smin = MAX( eps*smin, smlnum ) btmp( 1 ) = zero CALL scopy( 16, btmp, 0, t16, 1 ) t16( 1, 1 ) = tl( 1, 1 ) + sgn*tr( 1, 1 ) t16( 2, 2 ) = tl( 2, 2 ) + sgn*tr( 1, 1 ) t16( 3, 3 ) = tl( 1, 1 ) + sgn*tr( 2, 2 ) t16( 4, 4 ) = tl( 2, 2 ) + sgn*tr( 2, 2 ) IF( ltranl ) THEN t16( 1, 2 ) = tl( 2, 1 ) t16( 2, 1 ) = tl( 1, 2 ) t16( 3, 4 ) = tl( 2, 1 ) t16( 4, 3 ) = tl( 1, 2 ) ELSE t16( 1, 2 ) = tl( 1, 2 ) t16( 2, 1 ) = tl( 2, 1 ) t16( 3, 4 ) = tl( 1, 2 ) t16( 4, 3 ) = tl( 2, 1 ) END IF IF( ltranr ) THEN t16( 1, 3 ) = sgn*tr( 1, 2 ) t16( 2, 4 ) = sgn*tr( 1, 2 ) t16( 3, 1 ) = sgn*tr( 2, 1 ) t16( 4, 2 ) = sgn*tr( 2, 1 ) ELSE t16( 1, 3 ) = sgn*tr( 2, 1 ) t16( 2, 4 ) = sgn*tr( 2, 1 ) t16( 3, 1 ) = sgn*tr( 1, 2 ) t16( 4, 2 ) = sgn*tr( 1, 2 ) END IF btmp( 1 ) = b( 1, 1 ) btmp( 2 ) = b( 2, 1 ) btmp( 3 ) = b( 1, 2 ) btmp( 4 ) = b( 2, 2 ) ! ! Perform elimination ! DO i = 1, 3 xmax = zero DO ip = i, 4 DO jp = i, 4 IF( ABS( t16( ip, jp ) ) >= xmax ) THEN xmax = ABS( t16( ip, jp ) ) ipsv = ip jpsv = jp END IF END DO END DO IF( ipsv /= i ) THEN CALL sswap( 4, t16( ipsv, 1 ), 4, t16( i, 1 ), 4 ) temp = btmp( i ) btmp( i ) = btmp( ipsv ) btmp( ipsv ) = temp END IF IF( jpsv /= i ) CALL sswap( 4, t16( 1, jpsv ), 1, t16( 1, i ), 1 ) jpiv( i ) = jpsv IF( ABS( t16( i, i ) ) < smin ) THEN info = 1 t16( i, i ) = smin END IF DO j = i + 1, 4 t16( j, i ) = t16( j, i ) / t16( i, i ) btmp( j ) = btmp( j ) - t16( j, i )*btmp( i ) DO k = i + 1, 4 t16( j, k ) = t16( j, k ) - t16( j, i )*t16( i, k ) END DO END DO END DO IF( ABS( t16( 4, 4 ) ) < smin ) t16( 4, 4 ) = smin scale = one IF( ( eight*smlnum )*ABS( btmp( 1 ) ) > ABS( t16( 1, 1 ) ) .OR. & ( eight*smlnum )*ABS( btmp( 2 ) ) > ABS( t16( 2, 2 ) ) .OR. & ( eight*smlnum )*ABS( btmp( 3 ) ) > ABS( t16( 3, 3 ) ) .OR. & ( eight*smlnum )*ABS( btmp( 4 ) ) > ABS( t16( 4, 4 ) ) ) THEN scale = ( one / eight ) / MAX( ABS( btmp( 1 ) ), & ABS( btmp( 2 ) ), ABS( btmp( 3 ) ), ABS( btmp( 4 ) ) ) btmp( 1 ) = btmp( 1 )*scale btmp( 2 ) = btmp( 2 )*scale btmp( 3 ) = btmp( 3 )*scale btmp( 4 ) = btmp( 4 )*scale END IF DO i = 1, 4 k = 5 - i temp = one / t16( k, k ) tmp( k ) = btmp( k )*temp DO j = k + 1, 4 tmp( k ) = tmp( k ) - ( temp*t16( k, j ) )*tmp( j ) END DO END DO DO i = 1, 3 IF( jpiv( 4-i ) /= 4-i ) THEN temp = tmp( 4-i ) tmp( 4-i ) = tmp( jpiv( 4-i ) ) tmp( jpiv( 4-i ) ) = temp END IF END DO x( 1, 1 ) = tmp( 1 ) x( 2, 1 ) = tmp( 2 ) x( 1, 2 ) = tmp( 3 ) x( 2, 2 ) = tmp( 4 ) xnorm = MAX( ABS( tmp( 1 ) )+ABS( tmp( 3 ) ), & ABS( tmp( 2 ) )+ABS( tmp( 4 ) ) ) RETURN ! ! End of SLASY2 ! END SUBROUTINE slasy2 SUBROUTINE slasyf( 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: nb INTEGER, INTENT(OUT) :: kb REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(OUT) :: ipiv( * ) REAL, INTENT(IN) :: w( ldw, * ) INTEGER, INTENT(IN OUT) :: ldw INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLASYF 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. ! ! SLASYF is an auxiliary routine called by SSYTRF. 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) REAL 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) REAL 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 .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: eight = 8.0E+0 REAL, PARAMETER :: sevten = 17.0E+0 ! .. ! .. Local Scalars .. INTEGER :: imax, j, jb, jj, jmax, jp, k, kk, kkw, kp, kstep, kw REAL :: absakk, alpha, colmax, d11, d21, d22, r1, rowmax, t ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: isamax EXTERNAL lsame, isamax ! .. ! .. External Subroutines .. EXTERNAL scopy, sgemm, sgemv, sscal, sswap ! .. ! .. 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 <= n-nb+1 .AND. nb < n ) .OR. k < 1 ) GO TO 30 ! ! Copy column K of A to column KW of W and update it ! CALL scopy( k, a( 1, k ), 1, w( 1, kw ), 1 ) IF( k < n ) CALL sgemv( '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 > 1 ) THEN imax = isamax( k-1, w( 1, kw ), 1 ) colmax = ABS( w( imax, kw ) ) ELSE colmax = zero END IF ! IF( MAX( absakk, colmax ) == zero ) THEN ! ! Column K is zero: set INFO and continue ! IF( info == 0 ) info = k kp = k ELSE IF( absakk >= 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 scopy( imax, a( 1, imax ), 1, w( 1, kw-1 ), 1 ) CALL scopy( k-imax, a( imax, imax+1 ), lda, w( imax+1, kw-1 ), 1 ) IF( k < n ) CALL sgemv( '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 + isamax( k-imax, w( imax+1, kw-1 ), 1 ) rowmax = ABS( w( jmax, kw-1 ) ) IF( imax > 1 ) THEN jmax = isamax( imax-1, w( 1, kw-1 ), 1 ) rowmax = MAX( rowmax, ABS( w( jmax, kw-1 ) ) ) END IF ! IF( absakk >= alpha*colmax*( colmax / rowmax ) ) THEN ! ! no interchange, use 1-by-1 pivot block ! kp = k ELSE IF( ABS( w( imax, kw-1 ) ) >= 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 scopy( 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 /= kk ) THEN ! ! Copy non-updated column KK to column KP ! a( kp, k ) = a( kk, k ) CALL scopy( k-1-kp, a( kp+1, kk ), 1, a( kp, kp+1 ), lda ) CALL scopy( kp, a( 1, kk ), 1, a( 1, kp ), 1 ) ! ! Interchange rows KK and KP in last KK columns of A and W ! CALL sswap( n-kk+1, a( kk, kk ), lda, a( kp, kk ), lda ) CALL sswap( n-kk+1, w( kk, kkw ), ldw, w( kp, kkw ), ldw ) END IF ! IF( kstep == 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 scopy( k, w( 1, kw ), 1, a( 1, k ), 1 ) r1 = one / a( k, k ) CALL sscal( 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 > 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 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 ) ) END DO 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 == 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 j = ( ( k-1 ) / nb )*nb + 1, 1, -nb jb = MIN( nb, k-j+1 ) ! ! Update the upper triangle of the diagonal block ! DO jj = j, j + jb - 1 CALL sgemv( 'No transpose', jj-j+1, n-k, -one, & a( j, k+1 ), lda, w( jj, kw+1 ), ldw, one, a( j, jj ), 1 ) END DO ! ! Update the rectangular superdiagonal block ! CALL sgemm( 'No transpose', 'Transpose', j-1, jb, n-k, -one, & a( 1, k+1 ), lda, w( j, kw+1 ), ldw, one, a( 1, j ), lda ) END DO ! ! 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 < 0 ) THEN jp = -jp j = j + 1 END IF j = j + 1 IF( jp /= jj .AND. j <= n ) & CALL sswap( n-j+1, a( jp, j ), lda, a( jj, j ), lda ) IF( j <= 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 >= nb .AND. nb < n ) .OR. k > n ) GO TO 90 ! ! Copy column K of A to column K of W and update it ! CALL scopy( n-k+1, a( k, k ), 1, w( k, k ), 1 ) CALL sgemv( '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 < n ) THEN imax = k + isamax( n-k, w( k+1, k ), 1 ) colmax = ABS( w( imax, k ) ) ELSE colmax = zero END IF ! IF( MAX( absakk, colmax ) == zero ) THEN ! ! Column K is zero: set INFO and continue ! IF( info == 0 ) info = k kp = k ELSE IF( absakk >= 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 scopy( imax-k, a( imax, k ), lda, w( k, k+1 ), 1 ) CALL scopy( n-imax+1, a( imax, imax ), 1, w( imax, k+1 ), 1 ) CALL sgemv( '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 + isamax( imax-k, w( k, k+1 ), 1 ) rowmax = ABS( w( jmax, k+1 ) ) IF( imax < n ) THEN jmax = imax + isamax( n-imax, w( imax+1, k+1 ), 1 ) rowmax = MAX( rowmax, ABS( w( jmax, k+1 ) ) ) END IF ! IF( absakk >= alpha*colmax*( colmax / rowmax ) ) THEN ! ! no interchange, use 1-by-1 pivot block ! kp = k ELSE IF( ABS( w( imax, k+1 ) ) >= 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 scopy( 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 /= kk ) THEN ! ! Copy non-updated column KK to column KP ! a( kp, k ) = a( kk, k ) CALL scopy( kp-k-1, a( k+1, kk ), 1, a( kp, k+1 ), lda ) CALL scopy( 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 sswap( kk, a( kk, 1 ), lda, a( kp, 1 ), lda ) CALL sswap( kk, w( kk, 1 ), ldw, w( kp, 1 ), ldw ) END IF ! IF( kstep == 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 scopy( n-k+1, w( k, k ), 1, a( k, k ), 1 ) IF( k < n ) THEN r1 = one / a( k, k ) CALL sscal( 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 < 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 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 ) ) END DO 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 == 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 j = k, n, nb jb = MIN( nb, n-j+1 ) ! ! Update the lower triangle of the diagonal block ! DO jj = j, j + jb - 1 CALL sgemv( 'No transpose', j+jb-jj, k-1, -one, & a( jj, 1 ), lda, w( jj, 1 ), ldw, one, a( jj, jj ), 1 ) END DO ! ! Update the rectangular subdiagonal block ! IF( j+jb <= n ) CALL sgemm( '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 ) END DO ! ! 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 < 0 ) THEN jp = -jp j = j - 1 END IF j = j - 1 IF( jp /= jj .AND. j >= 1 ) & CALL sswap( j, a( jp, 1 ), lda, a( jj, 1 ), lda ) IF( j >= 1 ) GO TO 120 ! ! Set KB to the number of columns factorized ! kb = k - 1 ! END IF RETURN ! ! End of SLASYF ! END SUBROUTINE slasyf SUBROUTINE slatbs( uplo, trans, diag, normin, n, kd, ab, ldab, x, & scale, cnorm, 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, 1992 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: trans CHARACTER (LEN=1), INTENT(IN) :: diag CHARACTER (LEN=1), INTENT(IN) :: normin INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: kd REAL, INTENT(IN) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(IN OUT) :: x( * ) REAL, INTENT(OUT) :: scale REAL, INTENT(OUT) :: cnorm( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLATBS solves one of the triangular systems ! ! A *x = s*b or A'*x = s*b ! ! with scaling to prevent overflow, where A is an upper or lower ! triangular band matrix. Here A' denotes the transpose of A, x and b ! are n-element vectors, and s is a scaling factor, usually less than ! or equal to 1, chosen so that the components of x will be less than ! the overflow threshold. If the unscaled problem will not cause ! overflow, the Level 2 BLAS routine STBSV is called. If the matrix A ! is singular (A(j,j) = 0 for some j), then s is set to 0 and a ! non-trivial solution to A*x = 0 is returned. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! Specifies whether the matrix A is upper or lower triangular. ! = 'U': Upper triangular ! = 'L': Lower triangular ! ! TRANS (input) CHARACTER*1 ! Specifies the operation applied to A. ! = 'N': Solve A * x = s*b (No transpose) ! = 'T': Solve A'* x = s*b (Transpose) ! = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) ! ! DIAG (input) CHARACTER*1 ! Specifies whether or not the matrix A is unit triangular. ! = 'N': Non-unit triangular ! = 'U': Unit triangular ! ! NORMIN (input) CHARACTER*1 ! Specifies whether CNORM has been set or not. ! = 'Y': CNORM contains the column norms on entry ! = 'N': CNORM is not set on entry. On exit, the norms will ! be computed and stored in CNORM. ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! KD (input) INTEGER ! The number of subdiagonals or superdiagonals in the ! triangular matrix A. KD >= 0. ! ! AB (input) REAL array, dimension (LDAB,N) ! The upper or lower triangular band matrix A, stored in the ! first KD+1 rows of the array. The j-th column of A is stored ! in the j-th column of the array AB as follows: ! if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KD+1. ! ! X (input/output) REAL array, dimension (N) ! On entry, the right hand side b of the triangular system. ! On exit, X is overwritten by the solution vector x. ! ! SCALE (output) REAL ! The scaling factor s for the triangular system ! A * x = s*b or A'* x = s*b. ! If SCALE = 0, the matrix A is singular or badly scaled, and ! the vector x is an exact or approximate solution to A*x = 0. ! ! CNORM (input or output) REAL array, dimension (N) ! ! If NORMIN = 'Y', CNORM is an input argument and CNORM(j) ! contains the norm of the off-diagonal part of the j-th column ! of A. If TRANS = 'N', CNORM(j) must be greater than or equal ! to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) ! must be greater than or equal to the 1-norm. ! ! If NORMIN = 'N', CNORM is an output argument and CNORM(j) ! returns the 1-norm of the offdiagonal part of the j-th column ! of A. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -k, the k-th argument had an illegal value ! ! Further Details ! ======= ======= ! ! A rough bound on x is computed; if that is less than overflow, STBSV ! is called, otherwise, specific code is used which checks for possible ! overflow or divide-by-zero at every operation. ! ! A columnwise scheme is used for solving A*x = b. The basic algorithm ! if A is lower triangular is ! ! x[1:n] := b[1:n] ! for j = 1, ..., n ! x(j) := x(j) / A(j,j) ! x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] ! end ! ! Define bounds on the components of x after j iterations of the loop: ! M(j) = bound on x[1:j] ! G(j) = bound on x[j+1:n] ! Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. ! ! Then for iteration j+1 we have ! M(j+1) <= G(j) / | A(j+1,j+1) | ! G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | ! <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) ! ! where CNORM(j+1) is greater than or equal to the infinity-norm of ! column j+1 of A, not counting the diagonal. Hence ! ! G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) ! 1<=i<=j ! and ! ! |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) ! 1<=i< j ! ! Since |x(j)| <= M(j), we use the Level 2 BLAS routine STBSV if the ! reciprocal of the largest M(j), j=1,..,n, is larger than ! max(underflow, 1/overflow). ! ! The bound on x(j) is also used to determine when a step in the ! columnwise method can be performed without fear of overflow. If ! the computed bound is greater than a large constant, x is scaled to ! prevent overflow, but if the bound overflows, x is set to 0, x(j) to ! 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. ! ! Similarly, a row-wise scheme is used to solve A'*x = b. The basic ! algorithm for A upper triangular is ! ! for j = 1, ..., n ! x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) ! end ! ! We simultaneously compute two bounds ! G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j ! M(j) = bound on x(i), 1<=i<=j ! ! The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we ! add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. ! Then the bound on x(j) is ! ! M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | ! ! <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) ! 1<=i<=j ! ! and we can safely call STBSV if 1/M(n) and 1/G(n) are both greater ! than max(underflow, 1/overflow). ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: half = 0.5E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: notran, nounit, upper INTEGER :: i, imax, j, jfirst, jinc, jlast, jlen, maind REAL :: bignum, grow, REC, smlnum, sumj, tjj, tjjs, & tmax, tscal, uscal, xbnd, xj, xmax ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: isamax REAL :: sasum, sdot, slamch EXTERNAL lsame, isamax, sasum, sdot, slamch ! .. ! .. External Subroutines .. EXTERNAL saxpy, sscal, stbsv, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. Executable Statements .. ! info = 0 upper = lsame( uplo, 'U' ) notran = lsame( trans, 'N' ) nounit = lsame( diag, 'N' ) ! ! Test the input parameters. ! IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -1 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT. & lsame( trans, 'C' ) ) THEN info = -2 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN info = -3 ELSE IF( .NOT.lsame( normin, 'Y' ) .AND. .NOT. & lsame( normin, 'N' ) ) THEN info = -4 ELSE IF( n < 0 ) THEN info = -5 ELSE IF( kd < 0 ) THEN info = -6 ELSE IF( ldab < kd+1 ) THEN info = -8 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLATBS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Determine machine dependent parameters to control overflow. ! smlnum = slamch( 'Safe minimum' ) / slamch( 'Precision' ) bignum = one / smlnum scale = one ! IF( lsame( normin, 'N' ) ) THEN ! ! Compute the 1-norm of each column, not including the diagonal. ! IF( upper ) THEN ! ! A is upper triangular. ! DO j = 1, n jlen = MIN( kd, j-1 ) cnorm( j ) = sasum( jlen, ab( kd+1-jlen, j ), 1 ) END DO ELSE ! ! A is lower triangular. ! DO j = 1, n jlen = MIN( kd, n-j ) IF( jlen > 0 ) THEN cnorm( j ) = sasum( jlen, ab( 2, j ), 1 ) ELSE cnorm( j ) = zero END IF END DO END IF END IF ! ! Scale the column norms by TSCAL if the maximum element in CNORM is ! greater than BIGNUM. ! imax = isamax( n, cnorm, 1 ) tmax = cnorm( imax ) IF( tmax <= bignum ) THEN tscal = one ELSE tscal = one / ( smlnum*tmax ) CALL sscal( n, tscal, cnorm, 1 ) END IF ! ! Compute a bound on the computed solution vector to see if the ! Level 2 BLAS routine STBSV can be used. ! j = isamax( n, x, 1 ) xmax = ABS( x( j ) ) xbnd = xmax IF( notran ) THEN ! ! Compute the growth in A * x = b. ! IF( upper ) THEN jfirst = n jlast = 1 jinc = -1 maind = kd + 1 ELSE jfirst = 1 jlast = n jinc = 1 maind = 1 END IF ! IF( tscal /= one ) THEN grow = zero GO TO 50 END IF ! IF( nounit ) THEN ! ! A is non-unit triangular. ! ! Compute GROW = 1/G(j) and XBND = 1/M(j). ! Initially, G(0) = max{x(i), i=1,...,n}. ! grow = one / MAX( xbnd, smlnum ) xbnd = grow DO j = jfirst, jlast, jinc ! ! Exit the loop if the growth factor is too small. ! IF( grow <= smlnum ) GO TO 50 ! ! M(j) = G(j-1) / abs(A(j,j)) ! tjj = ABS( ab( maind, j ) ) xbnd = MIN( xbnd, MIN( one, tjj )*grow ) IF( tjj+cnorm( j ) >= smlnum ) THEN ! ! G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) ! grow = grow*( tjj / ( tjj+cnorm( j ) ) ) ELSE ! ! G(j) could overflow, set GROW to 0. ! grow = zero END IF END DO grow = xbnd ELSE ! ! A is unit triangular. ! ! Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. ! grow = MIN( one, one / MAX( xbnd, smlnum ) ) DO j = jfirst, jlast, jinc ! ! Exit the loop if the growth factor is too small. ! IF( grow <= smlnum ) GO TO 50 ! ! G(j) = G(j-1)*( 1 + CNORM(j) ) ! grow = grow*( one / ( one+cnorm( j ) ) ) END DO END IF 50 CONTINUE ! ELSE ! ! Compute the growth in A' * x = b. ! IF( upper ) THEN jfirst = 1 jlast = n jinc = 1 maind = kd + 1 ELSE jfirst = n jlast = 1 jinc = -1 maind = 1 END IF ! IF( tscal /= one ) THEN grow = zero GO TO 80 END IF ! IF( nounit ) THEN ! ! A is non-unit triangular. ! ! Compute GROW = 1/G(j) and XBND = 1/M(j). ! Initially, M(0) = max{x(i), i=1,...,n}. ! grow = one / MAX( xbnd, smlnum ) xbnd = grow DO j = jfirst, jlast, jinc ! ! Exit the loop if the growth factor is too small. ! IF( grow <= smlnum ) GO TO 80 ! ! G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) ! xj = one + cnorm( j ) grow = MIN( grow, xbnd / xj ) ! ! M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) ! tjj = ABS( ab( maind, j ) ) IF( xj > tjj ) xbnd = xbnd*( tjj / xj ) END DO grow = MIN( grow, xbnd ) ELSE ! ! A is unit triangular. ! ! Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. ! grow = MIN( one, one / MAX( xbnd, smlnum ) ) DO j = jfirst, jlast, jinc ! ! Exit the loop if the growth factor is too small. ! IF( grow <= smlnum ) GO TO 80 ! ! G(j) = ( 1 + CNORM(j) )*G(j-1) ! xj = one + cnorm( j ) grow = grow / xj END DO END IF 80 CONTINUE END IF ! IF( ( grow*tscal ) > smlnum ) THEN ! ! Use the Level 2 BLAS solve if the reciprocal of the bound on ! elements of X is not too small. ! CALL stbsv( uplo, trans, diag, n, kd, ab, ldab, x, 1 ) ELSE ! ! Use a Level 1 BLAS solve, scaling intermediate results. ! IF( xmax > bignum ) THEN ! ! Scale X so that its components are less than or equal to ! BIGNUM in absolute value. ! scale = bignum / xmax CALL sscal( n, scale, x, 1 ) xmax = bignum END IF ! IF( notran ) THEN ! ! Solve A * x = b ! DO j = jfirst, jlast, jinc ! ! Compute x(j) = b(j) / A(j,j), scaling x if necessary. ! xj = ABS( x( j ) ) IF( nounit ) THEN tjjs = ab( maind, j )*tscal ELSE tjjs = tscal IF( tscal == one ) GO TO 95 END IF tjj = ABS( tjjs ) IF( tjj > smlnum ) THEN ! ! abs(A(j,j)) > SMLNUM: ! IF( tjj < one ) THEN IF( xj > tjj*bignum ) THEN ! ! Scale x by 1/b(j). ! REC = one / xj CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF END IF x( j ) = x( j ) / tjjs xj = ABS( x( j ) ) ELSE IF( tjj > zero ) THEN ! ! 0 < abs(A(j,j)) <= SMLNUM: ! IF( xj > tjj*bignum ) THEN ! ! Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM ! to avoid overflow when dividing by A(j,j). ! REC = ( tjj*bignum ) / xj IF( cnorm( j ) > one ) THEN ! ! Scale by 1/CNORM(j) to avoid overflow when ! multiplying x(j) times column j. ! REC = REC / cnorm( j ) END IF CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF x( j ) = x( j ) / tjjs xj = ABS( x( j ) ) ELSE ! ! A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and ! scale = 0, and compute a solution to A*x = 0. ! DO i = 1, n x( i ) = zero END DO x( j ) = one xj = one scale = zero xmax = zero END IF 95 CONTINUE ! ! Scale x if necessary to avoid overflow when adding a ! multiple of column j of A. ! IF( xj > one ) THEN REC = one / xj IF( cnorm( j ) > ( bignum-xmax )*REC ) THEN ! ! Scale x by 1/(2*abs(x(j))). ! REC = REC*half CALL sscal( n, REC, x, 1 ) scale = scale*REC END IF ELSE IF( xj*cnorm( j ) > ( bignum-xmax ) ) THEN ! ! Scale x by 1/2. ! CALL sscal( n, half, x, 1 ) scale = scale*half END IF ! IF( upper ) THEN IF( j > 1 ) THEN ! ! Compute the update ! x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - ! x(j)* A(max(1,j-kd):j-1,j) ! jlen = MIN( kd, j-1 ) CALL saxpy( jlen, -x( j )*tscal, & ab( kd+1-jlen, j ), 1, x( j-jlen ), 1 ) i = isamax( j-1, x, 1 ) xmax = ABS( x( i ) ) END IF ELSE IF( j < n ) THEN ! ! Compute the update ! x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) - ! x(j) * A(j+1:min(j+kd,n),j) ! jlen = MIN( kd, n-j ) IF( jlen > 0 ) CALL saxpy( jlen, -x( j )*tscal, ab( 2, j ), 1, & x( j+1 ), 1 ) i = j + isamax( n-j, x( j+1 ), 1 ) xmax = ABS( x( i ) ) END IF END DO ! ELSE ! ! Solve A' * x = b ! DO j = jfirst, jlast, jinc ! ! Compute x(j) = b(j) - sum A(k,j)*x(k). ! k<>j ! xj = ABS( x( j ) ) uscal = tscal REC = one / MAX( xmax, one ) IF( cnorm( j ) > ( bignum-xj )*REC ) THEN ! ! If x(j) could overflow, scale x by 1/(2*XMAX). ! REC = REC*half IF( nounit ) THEN tjjs = ab( maind, j )*tscal ELSE tjjs = tscal END IF tjj = ABS( tjjs ) IF( tjj > one ) THEN ! ! Divide by A(j,j) when scaling x if A(j,j) > 1. ! REC = MIN( one, REC*tjj ) uscal = uscal / tjjs END IF IF( REC < one ) THEN CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF END IF ! sumj = zero IF( uscal == one ) THEN ! ! If the scaling needed for A in the dot product is 1, ! call SDOT to perform the dot product. ! IF( upper ) THEN jlen = MIN( kd, j-1 ) sumj = sdot( jlen, ab( kd+1-jlen, j ), 1, x( j-jlen ), 1 ) ELSE jlen = MIN( kd, n-j ) IF( jlen > 0 ) sumj = sdot( jlen, ab( 2, j ), 1, x( j+1 ), 1 ) END IF ELSE ! ! Otherwise, use in-line code for the dot product. ! IF( upper ) THEN jlen = MIN( kd, j-1 ) DO i = 1, jlen sumj = sumj + ( ab( kd+i-jlen, j )*uscal )* x( j-jlen-1+i ) END DO ELSE jlen = MIN( kd, n-j ) DO i = 1, jlen sumj = sumj + ( ab( i+1, j )*uscal )*x( j+i ) END DO END IF END IF ! IF( uscal == tscal ) THEN ! ! Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) ! was not used to scale the dotproduct. ! x( j ) = x( j ) - sumj xj = ABS( x( j ) ) IF( nounit ) THEN ! ! Compute x(j) = x(j) / A(j,j), scaling if necessary. ! tjjs = ab( maind, j )*tscal ELSE tjjs = tscal IF( tscal == one ) GO TO 135 END IF tjj = ABS( tjjs ) IF( tjj > smlnum ) THEN ! ! abs(A(j,j)) > SMLNUM: ! IF( tjj < one ) THEN IF( xj > tjj*bignum ) THEN ! ! Scale X by 1/abs(x(j)). ! REC = one / xj CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF END IF x( j ) = x( j ) / tjjs ELSE IF( tjj > zero ) THEN ! ! 0 < abs(A(j,j)) <= SMLNUM: ! IF( xj > tjj*bignum ) THEN ! ! Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. ! REC = ( tjj*bignum ) / xj CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF x( j ) = x( j ) / tjjs ELSE ! ! A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and ! scale = 0, and compute a solution to A'*x = 0. ! DO i = 1, n x( i ) = zero END DO x( j ) = one scale = zero xmax = zero END IF 135 CONTINUE ELSE ! ! Compute x(j) := x(j) / A(j,j) - sumj if the dot ! product has already been divided by 1/A(j,j). ! x( j ) = x( j ) / tjjs - sumj END IF xmax = MAX( xmax, ABS( x( j ) ) ) END DO END IF scale = scale / tscal END IF ! ! Scale the column norms by 1/TSCAL for return. ! IF( tscal /= one ) THEN CALL sscal( n, one / tscal, cnorm, 1 ) END IF ! RETURN ! ! End of SLATBS ! END SUBROUTINE slatbs SUBROUTINE slatdf( ijob, n, z, ldz, rhs, rdsum, rdscal, ipiv, jpiv ) ! ! -- 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, INTENT(IN) :: ijob INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(IN OUT) :: rhs( * ) REAL, INTENT(IN OUT) :: rdsum REAL, INTENT(IN OUT) :: rdscal INTEGER, INTENT(IN OUT) :: ipiv( * ) INTEGER, INTENT(IN OUT) :: jpiv( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLATDF uses the LU factorization of the n-by-n matrix Z computed by ! SGETC2 and computes a contribution to the reciprocal Dif-estimate ! by solving Z * x = b for x, and choosing the r.h.s. b such that ! the norm of x is as large as possible. On entry RHS = b holds the ! contribution from earlier solved sub-systems, and on return RHS = x. ! ! The factorization of Z returned by SGETC2 has the form Z = P*L*U*Q, ! where P and Q are permutation matrices. L is lower triangular with ! unit diagonal elements and U is upper triangular. ! ! Arguments ! ========= ! ! IJOB (input) INTEGER ! IJOB = 2: First compute an approximative null-vector e ! of Z using SGECON, e is normalized and solve for ! Zx = +-e - f with the sign giving the greater value ! of 2-norm(x). About 5 times as expensive as Default. ! IJOB .ne. 2: Local look ahead strategy where all entries of ! the r.h.s. b is choosen as either +1 or -1 (Default). ! ! N (input) INTEGER ! The number of columns of the matrix Z. ! ! Z (input) REAL array, dimension (LDZ, N) ! On entry, the LU part of the factorization of the n-by-n ! matrix Z computed by SGETC2: Z = P * L * U * Q ! ! LDZ (input) INTEGER ! The leading dimension of the array Z. LDA >= max(1, N). ! ! RHS (input/output) REAL array, dimension N. ! On entry, RHS contains contributions from other subsystems. ! On exit, RHS contains the solution of the subsystem with ! entries acoording to the value of IJOB (see above). ! ! RDSUM (input/output) REAL ! On entry, the sum of squares of computed contributions to ! the Dif-estimate under computation by STGSYL, where the ! scaling factor RDSCAL (see below) has been factored out. ! On exit, the corresponding sum of squares updated with the ! contributions from the current sub-system. ! If TRANS = 'T' RDSUM is not touched. ! NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL. ! ! RDSCAL (input/output) REAL ! On entry, scaling factor used to prevent overflow in RDSUM. ! On exit, RDSCAL is updated w.r.t. the current contributions ! in RDSUM. ! If TRANS = 'T', RDSCAL is not touched. ! NOTE: RDSCAL only makes sense when STGSY2 is called by ! STGSYL. ! ! IPIV (input) INTEGER array, dimension (N). ! The pivot indices; for 1 <= i <= N, row i of the ! matrix has been interchanged with row IPIV(i). ! ! JPIV (input) INTEGER array, dimension (N). ! The pivot indices; for 1 <= j <= N, column j of the ! matrix has been interchanged with column JPIV(j). ! ! Further Details ! =============== ! ! Based on contributions by ! Bo Kagstrom and Peter Poromaa, Department of Computing Science, ! Umea University, S-901 87 Umea, Sweden. ! ! This routine is a further developed implementation of algorithm ! BSOLVE in [1] using complete pivoting in the LU factorization. ! ! [1] Bo Kagstrom and Lars Westin, ! Generalized Schur Methods with Condition Estimators for ! Solving the Generalized Sylvester Equation, IEEE Transactions ! on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. ! ! [2] Peter Poromaa, ! On Efficient and Robust Estimators for the Separation ! between two Regular Matrix Pairs with Applications in ! Condition Estimation. Report IMINF-95.05, Departement of ! Computing Science, Umea University, S-901 87 Umea, Sweden, 1995. ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: maxdim = 8 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, info, j, k REAL :: bm, bp, pmone, sminu, splus, temp ! .. ! .. Local Arrays .. INTEGER :: iwork( maxdim ) REAL :: work( 4*maxdim ), xm( maxdim ), xp( maxdim ) ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, sgecon, sgesc2, slassq, slaswp, sscal ! .. ! .. External Functions .. REAL :: sasum, sdot EXTERNAL sasum, sdot ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, SQRT ! .. ! .. Executable Statements .. ! IF( ijob /= 2 ) THEN ! ! Apply permutations IPIV to RHS ! CALL slaswp( 1, rhs, ldz, 1, n-1, ipiv, 1 ) ! ! Solve for L-part choosing RHS either to +1 or -1. ! pmone = -one ! DO j = 1, n - 1 bp = rhs( j ) + one bm = rhs( j ) - one splus = one ! ! Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and ! SMIN computed more efficiently than in BSOLVE [1]. ! splus = splus + sdot( n-j, z( j+1, j ), 1, z( j+1, j ), 1 ) sminu = sdot( n-j, z( j+1, j ), 1, rhs( j+1 ), 1 ) splus = splus*rhs( j ) IF( splus > sminu ) THEN rhs( j ) = bp ELSE IF( sminu > splus ) THEN rhs( j ) = bm ELSE ! ! In this case the updating sums are equal and we can ! choose RHS(J) +1 or -1. The first time this happens ! we choose -1, thereafter +1. This is a simple way to ! get good estimates of matrices like Byers well-known ! example (see [1]). (Not done in BSOLVE.) ! rhs( j ) = rhs( j ) + pmone pmone = one END IF ! ! Compute the remaining r.h.s. ! temp = -rhs( j ) CALL saxpy( n-j, temp, z( j+1, j ), 1, rhs( j+1 ), 1 ) ! END DO ! ! Solve for U-part, look-ahead for RHS(N) = +-1. This is not done ! in BSOLVE and will hopefully give us a better estimate because ! any ill-conditioning of the original matrix is transfered to U ! and not to L. U(N, N) is an approximation to sigma_min(LU). ! CALL scopy( n-1, rhs, 1, xp, 1 ) xp( n ) = rhs( n ) + one rhs( n ) = rhs( n ) - one splus = zero sminu = zero DO i = n, 1, -1 temp = one / z( i, i ) xp( i ) = xp( i )*temp rhs( i ) = rhs( i )*temp DO k = i + 1, n xp( i ) = xp( i ) - xp( k )*( z( i, k )*temp ) rhs( i ) = rhs( i ) - rhs( k )*( z( i, k )*temp ) END DO splus = splus + ABS( xp( i ) ) sminu = sminu + ABS( rhs( i ) ) END DO IF( splus > sminu ) CALL scopy( n, xp, 1, rhs, 1 ) ! ! Apply the permutations JPIV to the computed solution (RHS) ! CALL slaswp( 1, rhs, ldz, 1, n-1, jpiv, -1 ) ! ! Compute the sum of squares ! CALL slassq( n, rhs, 1, rdscal, rdsum ) ! ELSE ! ! IJOB = 2, Compute approximate nullvector XM of Z ! CALL sgecon( 'I', n, z, ldz, one, temp, work, iwork, info ) CALL scopy( n, work( n+1 ), 1, xm, 1 ) ! ! Compute RHS ! CALL slaswp( 1, xm, ldz, 1, n-1, ipiv, -1 ) temp = one / SQRT( sdot( n, xm, 1, xm, 1 ) ) CALL sscal( n, temp, xm, 1 ) CALL scopy( n, xm, 1, xp, 1 ) CALL saxpy( n, one, rhs, 1, xp, 1 ) CALL saxpy( n, -one, xm, 1, rhs, 1 ) CALL sgesc2( n, z, ldz, rhs, ipiv, jpiv, temp ) CALL sgesc2( n, z, ldz, xp, ipiv, jpiv, temp ) IF( sasum( n, xp, 1 ) > sasum( n, rhs, 1 ) ) CALL scopy( n, xp, 1, rhs, 1 ) ! ! Compute the sum of squares ! CALL slassq( n, rhs, 1, rdscal, rdsum ) ! END IF ! RETURN ! ! End of SLATDF ! END SUBROUTINE slatdf SUBROUTINE slatps( uplo, trans, diag, normin, n, ap, x, scale, cnorm, 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, 1992 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: trans CHARACTER (LEN=1), INTENT(IN) :: diag CHARACTER (LEN=1), INTENT(IN) :: normin INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN) :: ap( * ) REAL, INTENT(IN OUT) :: x( * ) REAL, INTENT(OUT) :: scale REAL, INTENT(OUT) :: cnorm( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLATPS solves one of the triangular systems ! ! A *x = s*b or A'*x = s*b ! ! with scaling to prevent overflow, where A is an upper or lower ! triangular matrix stored in packed form. Here A' denotes the ! transpose of A, x and b are n-element vectors, and s is a scaling ! factor, usually less than or equal to 1, chosen so that the ! components of x will be less than the overflow threshold. If the ! unscaled problem will not cause overflow, the Level 2 BLAS routine ! STPSV is called. If the matrix A is singular (A(j,j) = 0 for some j), ! then s is set to 0 and a non-trivial solution to A*x = 0 is returned. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! Specifies whether the matrix A is upper or lower triangular. ! = 'U': Upper triangular ! = 'L': Lower triangular ! ! TRANS (input) CHARACTER*1 ! Specifies the operation applied to A. ! = 'N': Solve A * x = s*b (No transpose) ! = 'T': Solve A'* x = s*b (Transpose) ! = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) ! ! DIAG (input) CHARACTER*1 ! Specifies whether or not the matrix A is unit triangular. ! = 'N': Non-unit triangular ! = 'U': Unit triangular ! ! NORMIN (input) CHARACTER*1 ! Specifies whether CNORM has been set or not. ! = 'Y': CNORM contains the column norms on entry ! = 'N': CNORM is not set on entry. On exit, the norms will ! be computed and stored in CNORM. ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! AP (input) REAL array, dimension (N*(N+1)/2) ! The upper or lower triangular 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. ! ! X (input/output) REAL array, dimension (N) ! On entry, the right hand side b of the triangular system. ! On exit, X is overwritten by the solution vector x. ! ! SCALE (output) REAL ! The scaling factor s for the triangular system ! A * x = s*b or A'* x = s*b. ! If SCALE = 0, the matrix A is singular or badly scaled, and ! the vector x is an exact or approximate solution to A*x = 0. ! ! CNORM (input or output) REAL array, dimension (N) ! ! If NORMIN = 'Y', CNORM is an input argument and CNORM(j) ! contains the norm of the off-diagonal part of the j-th column ! of A. If TRANS = 'N', CNORM(j) must be greater than or equal ! to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) ! must be greater than or equal to the 1-norm. ! ! If NORMIN = 'N', CNORM is an output argument and CNORM(j) ! returns the 1-norm of the offdiagonal part of the j-th column ! of A. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -k, the k-th argument had an illegal value ! ! Further Details ! ======= ======= ! ! A rough bound on x is computed; if that is less than overflow, STPSV ! is called, otherwise, specific code is used which checks for possible ! overflow or divide-by-zero at every operation. ! ! A columnwise scheme is used for solving A*x = b. The basic algorithm ! if A is lower triangular is ! ! x[1:n] := b[1:n] ! for j = 1, ..., n ! x(j) := x(j) / A(j,j) ! x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] ! end ! ! Define bounds on the components of x after j iterations of the loop: ! M(j) = bound on x[1:j] ! G(j) = bound on x[j+1:n] ! Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. ! ! Then for iteration j+1 we have ! M(j+1) <= G(j) / | A(j+1,j+1) | ! G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | ! <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) ! ! where CNORM(j+1) is greater than or equal to the infinity-norm of ! column j+1 of A, not counting the diagonal. Hence ! ! G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) ! 1<=i<=j ! and ! ! |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) ! 1<=i< j ! ! Since |x(j)| <= M(j), we use the Level 2 BLAS routine STPSV if the ! reciprocal of the largest M(j), j=1,..,n, is larger than ! max(underflow, 1/overflow). ! ! The bound on x(j) is also used to determine when a step in the ! columnwise method can be performed without fear of overflow. If ! the computed bound is greater than a large constant, x is scaled to ! prevent overflow, but if the bound overflows, x is set to 0, x(j) to ! 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. ! ! Similarly, a row-wise scheme is used to solve A'*x = b. The basic ! algorithm for A upper triangular is ! ! for j = 1, ..., n ! x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) ! end ! ! We simultaneously compute two bounds ! G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j ! M(j) = bound on x(i), 1<=i<=j ! ! The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we ! add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. ! Then the bound on x(j) is ! ! M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | ! ! <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) ! 1<=i<=j ! ! and we can safely call STPSV if 1/M(n) and 1/G(n) are both greater ! than max(underflow, 1/overflow). ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: half = 0.5E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: notran, nounit, upper INTEGER :: i, imax, ip, j, jfirst, jinc, jlast, jlen REAL :: bignum, grow, REC, smlnum, sumj, tjj, tjjs, & tmax, tscal, uscal, xbnd, xj, xmax ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: isamax REAL :: sasum, sdot, slamch EXTERNAL lsame, isamax, sasum, sdot, slamch ! .. ! .. External Subroutines .. EXTERNAL saxpy, sscal, stpsv, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. Executable Statements .. ! info = 0 upper = lsame( uplo, 'U' ) notran = lsame( trans, 'N' ) nounit = lsame( diag, 'N' ) ! ! Test the input parameters. ! IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -1 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT. & lsame( trans, 'C' ) ) THEN info = -2 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN info = -3 ELSE IF( .NOT.lsame( normin, 'Y' ) .AND. .NOT. & lsame( normin, 'N' ) ) THEN info = -4 ELSE IF( n < 0 ) THEN info = -5 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLATPS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Determine machine dependent parameters to control overflow. ! smlnum = slamch( 'Safe minimum' ) / slamch( 'Precision' ) bignum = one / smlnum scale = one ! IF( lsame( normin, 'N' ) ) THEN ! ! Compute the 1-norm of each column, not including the diagonal. ! IF( upper ) THEN ! ! A is upper triangular. ! ip = 1 DO j = 1, n cnorm( j ) = sasum( j-1, ap( ip ), 1 ) ip = ip + j END DO ELSE ! ! A is lower triangular. ! ip = 1 DO j = 1, n - 1 cnorm( j ) = sasum( n-j, ap( ip+1 ), 1 ) ip = ip + n - j + 1 END DO cnorm( n ) = zero END IF END IF ! ! Scale the column norms by TSCAL if the maximum element in CNORM is ! greater than BIGNUM. ! imax = isamax( n, cnorm, 1 ) tmax = cnorm( imax ) IF( tmax <= bignum ) THEN tscal = one ELSE tscal = one / ( smlnum*tmax ) CALL sscal( n, tscal, cnorm, 1 ) END IF ! ! Compute a bound on the computed solution vector to see if the ! Level 2 BLAS routine STPSV can be used. ! j = isamax( n, x, 1 ) xmax = ABS( x( j ) ) xbnd = xmax IF( notran ) THEN ! ! Compute the growth in A * x = b. ! IF( upper ) THEN jfirst = n jlast = 1 jinc = -1 ELSE jfirst = 1 jlast = n jinc = 1 END IF ! IF( tscal /= one ) THEN grow = zero GO TO 50 END IF ! IF( nounit ) THEN ! ! A is non-unit triangular. ! ! Compute GROW = 1/G(j) and XBND = 1/M(j). ! Initially, G(0) = max{x(i), i=1,...,n}. ! grow = one / MAX( xbnd, smlnum ) xbnd = grow ip = jfirst*( jfirst+1 ) / 2 jlen = n DO j = jfirst, jlast, jinc ! ! Exit the loop if the growth factor is too small. ! IF( grow <= smlnum ) GO TO 50 ! ! M(j) = G(j-1) / abs(A(j,j)) ! tjj = ABS( ap( ip ) ) xbnd = MIN( xbnd, MIN( one, tjj )*grow ) IF( tjj+cnorm( j ) >= smlnum ) THEN ! ! G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) ! grow = grow*( tjj / ( tjj+cnorm( j ) ) ) ELSE ! ! G(j) could overflow, set GROW to 0. ! grow = zero END IF ip = ip + jinc*jlen jlen = jlen - 1 END DO grow = xbnd ELSE ! ! A is unit triangular. ! ! Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. ! grow = MIN( one, one / MAX( xbnd, smlnum ) ) DO j = jfirst, jlast, jinc ! ! Exit the loop if the growth factor is too small. ! IF( grow <= smlnum ) GO TO 50 ! ! G(j) = G(j-1)*( 1 + CNORM(j) ) ! grow = grow*( one / ( one+cnorm( j ) ) ) END DO END IF 50 CONTINUE ! ELSE ! ! Compute the growth in A' * x = b. ! IF( upper ) THEN jfirst = 1 jlast = n jinc = 1 ELSE jfirst = n jlast = 1 jinc = -1 END IF ! IF( tscal /= one ) THEN grow = zero GO TO 80 END IF ! IF( nounit ) THEN ! ! A is non-unit triangular. ! ! Compute GROW = 1/G(j) and XBND = 1/M(j). ! Initially, M(0) = max{x(i), i=1,...,n}. ! grow = one / MAX( xbnd, smlnum ) xbnd = grow ip = jfirst*( jfirst+1 ) / 2 jlen = 1 DO j = jfirst, jlast, jinc ! ! Exit the loop if the growth factor is too small. ! IF( grow <= smlnum ) GO TO 80 ! ! G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) ! xj = one + cnorm( j ) grow = MIN( grow, xbnd / xj ) ! ! M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) ! tjj = ABS( ap( ip ) ) IF( xj > tjj ) xbnd = xbnd*( tjj / xj ) jlen = jlen + 1 ip = ip + jinc*jlen END DO grow = MIN( grow, xbnd ) ELSE ! ! A is unit triangular. ! ! Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. ! grow = MIN( one, one / MAX( xbnd, smlnum ) ) DO j = jfirst, jlast, jinc ! ! Exit the loop if the growth factor is too small. ! IF( grow <= smlnum ) GO TO 80 ! ! G(j) = ( 1 + CNORM(j) )*G(j-1) ! xj = one + cnorm( j ) grow = grow / xj END DO END IF 80 CONTINUE END IF ! IF( ( grow*tscal ) > smlnum ) THEN ! ! Use the Level 2 BLAS solve if the reciprocal of the bound on ! elements of X is not too small. ! CALL stpsv( uplo, trans, diag, n, ap, x, 1 ) ELSE ! ! Use a Level 1 BLAS solve, scaling intermediate results. ! IF( xmax > bignum ) THEN ! ! Scale X so that its components are less than or equal to ! BIGNUM in absolute value. ! scale = bignum / xmax CALL sscal( n, scale, x, 1 ) xmax = bignum END IF ! IF( notran ) THEN ! ! Solve A * x = b ! ip = jfirst*( jfirst+1 ) / 2 DO j = jfirst, jlast, jinc ! ! Compute x(j) = b(j) / A(j,j), scaling x if necessary. ! xj = ABS( x( j ) ) IF( nounit ) THEN tjjs = ap( ip )*tscal ELSE tjjs = tscal IF( tscal == one ) GO TO 95 END IF tjj = ABS( tjjs ) IF( tjj > smlnum ) THEN ! ! abs(A(j,j)) > SMLNUM: ! IF( tjj < one ) THEN IF( xj > tjj*bignum ) THEN ! ! Scale x by 1/b(j). ! REC = one / xj CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF END IF x( j ) = x( j ) / tjjs xj = ABS( x( j ) ) ELSE IF( tjj > zero ) THEN ! ! 0 < abs(A(j,j)) <= SMLNUM: ! IF( xj > tjj*bignum ) THEN ! ! Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM ! to avoid overflow when dividing by A(j,j). ! REC = ( tjj*bignum ) / xj IF( cnorm( j ) > one ) THEN ! ! Scale by 1/CNORM(j) to avoid overflow when ! multiplying x(j) times column j. ! REC = REC / cnorm( j ) END IF CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF x( j ) = x( j ) / tjjs xj = ABS( x( j ) ) ELSE ! ! A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and ! scale = 0, and compute a solution to A*x = 0. ! DO i = 1, n x( i ) = zero END DO x( j ) = one xj = one scale = zero xmax = zero END IF 95 CONTINUE ! ! Scale x if necessary to avoid overflow when adding a ! multiple of column j of A. ! IF( xj > one ) THEN REC = one / xj IF( cnorm( j ) > ( bignum-xmax )*REC ) THEN ! ! Scale x by 1/(2*abs(x(j))). ! REC = REC*half CALL sscal( n, REC, x, 1 ) scale = scale*REC END IF ELSE IF( xj*cnorm( j ) > ( bignum-xmax ) ) THEN ! ! Scale x by 1/2. ! CALL sscal( n, half, x, 1 ) scale = scale*half END IF ! IF( upper ) THEN IF( j > 1 ) THEN ! ! Compute the update ! x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) ! CALL saxpy( j-1, -x( j )*tscal, ap( ip-j+1 ), 1, x, 1 ) i = isamax( j-1, x, 1 ) xmax = ABS( x( i ) ) END IF ip = ip - j ELSE IF( j < n ) THEN ! ! Compute the update ! x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) ! CALL saxpy( n-j, -x( j )*tscal, ap( ip+1 ), 1, x( j+1 ), 1 ) i = j + isamax( n-j, x( j+1 ), 1 ) xmax = ABS( x( i ) ) END IF ip = ip + n - j + 1 END IF END DO ! ELSE ! ! Solve A' * x = b ! ip = jfirst*( jfirst+1 ) / 2 jlen = 1 DO j = jfirst, jlast, jinc ! ! Compute x(j) = b(j) - sum A(k,j)*x(k). ! k<>j ! xj = ABS( x( j ) ) uscal = tscal REC = one / MAX( xmax, one ) IF( cnorm( j ) > ( bignum-xj )*REC ) THEN ! ! If x(j) could overflow, scale x by 1/(2*XMAX). ! REC = REC*half IF( nounit ) THEN tjjs = ap( ip )*tscal ELSE tjjs = tscal END IF tjj = ABS( tjjs ) IF( tjj > one ) THEN ! ! Divide by A(j,j) when scaling x if A(j,j) > 1. ! REC = MIN( one, REC*tjj ) uscal = uscal / tjjs END IF IF( REC < one ) THEN CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF END IF ! sumj = zero IF( uscal == one ) THEN ! ! If the scaling needed for A in the dot product is 1, ! call SDOT to perform the dot product. ! IF( upper ) THEN sumj = sdot( j-1, ap( ip-j+1 ), 1, x, 1 ) ELSE IF( j < n ) THEN sumj = sdot( n-j, ap( ip+1 ), 1, x( j+1 ), 1 ) END IF ELSE ! ! Otherwise, use in-line code for the dot product. ! IF( upper ) THEN DO i = 1, j - 1 sumj = sumj + ( ap( ip-j+i )*uscal )*x( i ) END DO ELSE IF( j < n ) THEN DO i = 1, n - j sumj = sumj + ( ap( ip+i )*uscal )*x( j+i ) END DO END IF END IF ! IF( uscal == tscal ) THEN ! ! Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) ! was not used to scale the dotproduct. ! x( j ) = x( j ) - sumj xj = ABS( x( j ) ) IF( nounit ) THEN ! ! Compute x(j) = x(j) / A(j,j), scaling if necessary. ! tjjs = ap( ip )*tscal ELSE tjjs = tscal IF( tscal == one ) GO TO 135 END IF tjj = ABS( tjjs ) IF( tjj > smlnum ) THEN ! ! abs(A(j,j)) > SMLNUM: ! IF( tjj < one ) THEN IF( xj > tjj*bignum ) THEN ! ! Scale X by 1/abs(x(j)). ! REC = one / xj CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF END IF x( j ) = x( j ) / tjjs ELSE IF( tjj > zero ) THEN ! ! 0 < abs(A(j,j)) <= SMLNUM: ! IF( xj > tjj*bignum ) THEN ! ! Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. ! REC = ( tjj*bignum ) / xj CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF x( j ) = x( j ) / tjjs ELSE ! ! A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and ! scale = 0, and compute a solution to A'*x = 0. ! DO i = 1, n x( i ) = zero END DO x( j ) = one scale = zero xmax = zero END IF 135 CONTINUE ELSE ! ! Compute x(j) := x(j) / A(j,j) - sumj if the dot ! product has already been divided by 1/A(j,j). ! x( j ) = x( j ) / tjjs - sumj END IF xmax = MAX( xmax, ABS( x( j ) ) ) jlen = jlen + 1 ip = ip + jinc*jlen END DO END IF scale = scale / tscal END IF ! ! Scale the column norms by 1/TSCAL for return. ! IF( tscal /= one ) THEN CALL sscal( n, one / tscal, cnorm, 1 ) END IF ! RETURN ! ! End of SLATPS ! END SUBROUTINE slatps SUBROUTINE slatrd( 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: nb REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: e( * ) REAL, INTENT(IN) :: tau( * ) REAL, INTENT(IN) :: w( ldw, * ) INTEGER, INTENT(IN OUT) :: ldw ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLATRD 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', SLATRD reduces the last NB rows and columns of a ! matrix, of which the upper triangle is supplied; ! if UPLO = 'L', SLATRD reduces the first NB rows and columns of a ! matrix, of which the lower triangle is supplied. ! ! This is an auxiliary routine called by SSYTRD. ! ! 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) REAL 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) REAL 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) REAL 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) REAL 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 .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: half = 0.5E+0 ! .. ! .. Local Scalars .. INTEGER :: i, iw REAL :: alpha ! .. ! .. External Subroutines .. EXTERNAL saxpy, sgemv, slarfg, sscal, ssymv ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: sdot EXTERNAL lsame, sdot ! .. ! .. Intrinsic Functions .. INTRINSIC MIN ! .. ! .. Executable Statements .. ! ! Quick return if possible ! IF( n <= 0 ) RETURN ! IF( lsame( uplo, 'U' ) ) THEN ! ! Reduce last NB columns of upper triangle ! DO i = n, n - nb + 1, -1 iw = i - n + nb IF( i < n ) THEN ! ! Update A(1:i,i) ! CALL sgemv( 'No transpose', i, n-i, -one, a( 1, i+1 ), & lda, w( i, iw+1 ), ldw, one, a( 1, i ), 1 ) CALL sgemv( '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 > 1 ) THEN ! ! Generate elementary reflector H(i) to annihilate ! A(1:i-2,i) ! CALL slarfg( 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 ssymv( 'Upper', i-1, one, a, lda, a( 1, i ), 1, & zero, w( 1, iw ), 1 ) IF( i < n ) THEN CALL sgemv( 'Transpose', i-1, n-i, one, w( 1, iw+1 ), & ldw, a( 1, i ), 1, zero, w( i+1, iw ), 1 ) CALL sgemv( 'No transpose', i-1, n-i, -one, & a( 1, i+1 ), lda, w( i+1, iw ), 1, one, w( 1, iw ), 1 ) CALL sgemv( 'Transpose', i-1, n-i, one, a( 1, i+1 ), & lda, a( 1, i ), 1, zero, w( i+1, iw ), 1 ) CALL sgemv( '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 sscal( i-1, tau( i-1 ), w( 1, iw ), 1 ) alpha = -half*tau( i-1 )*sdot( i-1, w( 1, iw ), 1, a( 1, i ), 1 ) CALL saxpy( i-1, alpha, a( 1, i ), 1, w( 1, iw ), 1 ) END IF ! END DO ELSE ! ! Reduce first NB columns of lower triangle ! DO i = 1, nb ! ! Update A(i:n,i) ! CALL sgemv( 'No transpose', n-i+1, i-1, -one, a( i, 1 ), & lda, w( i, 1 ), ldw, one, a( i, i ), 1 ) CALL sgemv( 'No transpose', n-i+1, i-1, -one, w( i, 1 ), & ldw, a( i, 1 ), lda, one, a( i, i ), 1 ) IF( i < n ) THEN ! ! Generate elementary reflector H(i) to annihilate ! A(i+2:n,i) ! CALL slarfg( 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 ssymv( 'Lower', n-i, one, a( i+1, i+1 ), lda, & a( i+1, i ), 1, zero, w( i+1, i ), 1 ) CALL sgemv( 'Transpose', n-i, i-1, one, w( i+1, 1 ), ldw, & a( i+1, i ), 1, zero, w( 1, i ), 1 ) CALL sgemv( 'No transpose', n-i, i-1, -one, a( i+1, 1 ), & lda, w( 1, i ), 1, one, w( i+1, i ), 1 ) CALL sgemv( 'Transpose', n-i, i-1, one, a( i+1, 1 ), lda, & a( i+1, i ), 1, zero, w( 1, i ), 1 ) CALL sgemv( 'No transpose', n-i, i-1, -one, w( i+1, 1 ), & ldw, w( 1, i ), 1, one, w( i+1, i ), 1 ) CALL sscal( n-i, tau( i ), w( i+1, i ), 1 ) alpha = -half*tau( i )*sdot( n-i, w( i+1, i ), 1, a( i+1, i ), 1 ) CALL saxpy( n-i, alpha, a( i+1, i ), 1, w( i+1, i ), 1 ) END IF ! END DO END IF ! RETURN ! ! End of SLATRD ! END SUBROUTINE slatrd SUBROUTINE slatrs( uplo, trans, diag, normin, n, a, lda, x, scale, & cnorm, 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, 1992 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: trans CHARACTER (LEN=1), INTENT(IN) :: diag CHARACTER (LEN=1), INTENT(IN) :: normin INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: x( * ) REAL, INTENT(OUT) :: scale REAL, INTENT(OUT) :: cnorm( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLATRS solves one of the triangular systems ! ! A *x = s*b or A'*x = s*b ! ! with scaling to prevent overflow. Here A is an upper or lower ! triangular matrix, A' denotes the transpose of A, x and b are ! n-element vectors, and s is a scaling factor, usually less than ! or equal to 1, chosen so that the components of x will be less than ! the overflow threshold. If the unscaled problem will not cause ! overflow, the Level 2 BLAS routine STRSV is called. If the matrix A ! is singular (A(j,j) = 0 for some j), then s is set to 0 and a ! non-trivial solution to A*x = 0 is returned. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! Specifies whether the matrix A is upper or lower triangular. ! = 'U': Upper triangular ! = 'L': Lower triangular ! ! TRANS (input) CHARACTER*1 ! Specifies the operation applied to A. ! = 'N': Solve A * x = s*b (No transpose) ! = 'T': Solve A'* x = s*b (Transpose) ! = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) ! ! DIAG (input) CHARACTER*1 ! Specifies whether or not the matrix A is unit triangular. ! = 'N': Non-unit triangular ! = 'U': Unit triangular ! ! NORMIN (input) CHARACTER*1 ! Specifies whether CNORM has been set or not. ! = 'Y': CNORM contains the column norms on entry ! = 'N': CNORM is not set on entry. On exit, the norms will ! be computed and stored in CNORM. ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! A (input) REAL array, dimension (LDA,N) ! 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. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max (1,N). ! ! X (input/output) REAL array, dimension (N) ! On entry, the right hand side b of the triangular system. ! On exit, X is overwritten by the solution vector x. ! ! SCALE (output) REAL ! The scaling factor s for the triangular system ! A * x = s*b or A'* x = s*b. ! If SCALE = 0, the matrix A is singular or badly scaled, and ! the vector x is an exact or approximate solution to A*x = 0. ! ! CNORM (input or output) REAL array, dimension (N) ! ! If NORMIN = 'Y', CNORM is an input argument and CNORM(j) ! contains the norm of the off-diagonal part of the j-th column ! of A. If TRANS = 'N', CNORM(j) must be greater than or equal ! to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) ! must be greater than or equal to the 1-norm. ! ! If NORMIN = 'N', CNORM is an output argument and CNORM(j) ! returns the 1-norm of the offdiagonal part of the j-th column ! of A. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -k, the k-th argument had an illegal value ! ! Further Details ! ======= ======= ! ! A rough bound on x is computed; if that is less than overflow, STRSV ! is called, otherwise, specific code is used which checks for possible ! overflow or divide-by-zero at every operation. ! ! A columnwise scheme is used for solving A*x = b. The basic algorithm ! if A is lower triangular is ! ! x[1:n] := b[1:n] ! for j = 1, ..., n ! x(j) := x(j) / A(j,j) ! x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] ! end ! ! Define bounds on the components of x after j iterations of the loop: ! M(j) = bound on x[1:j] ! G(j) = bound on x[j+1:n] ! Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. ! ! Then for iteration j+1 we have ! M(j+1) <= G(j) / | A(j+1,j+1) | ! G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | ! <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) ! ! where CNORM(j+1) is greater than or equal to the infinity-norm of ! column j+1 of A, not counting the diagonal. Hence ! ! G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) ! 1<=i<=j ! and ! ! |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) ! 1<=i< j ! ! Since |x(j)| <= M(j), we use the Level 2 BLAS routine STRSV if the ! reciprocal of the largest M(j), j=1,..,n, is larger than ! max(underflow, 1/overflow). ! ! The bound on x(j) is also used to determine when a step in the ! columnwise method can be performed without fear of overflow. If ! the computed bound is greater than a large constant, x is scaled to ! prevent overflow, but if the bound overflows, x is set to 0, x(j) to ! 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. ! ! Similarly, a row-wise scheme is used to solve A'*x = b. The basic ! algorithm for A upper triangular is ! ! for j = 1, ..., n ! x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) ! end ! ! We simultaneously compute two bounds ! G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j ! M(j) = bound on x(i), 1<=i<=j ! ! The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we ! add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. ! Then the bound on x(j) is ! ! M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | ! ! <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) ! 1<=i<=j ! ! and we can safely call STRSV if 1/M(n) and 1/G(n) are both greater ! than max(underflow, 1/overflow). ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: half = 0.5E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: notran, nounit, upper INTEGER :: i, imax, j, jfirst, jinc, jlast REAL :: bignum, grow, REC, smlnum, sumj, tjj, tjjs, & tmax, tscal, uscal, xbnd, xj, xmax ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: isamax REAL :: sasum, sdot, slamch EXTERNAL lsame, isamax, sasum, sdot, slamch ! .. ! .. External Subroutines .. EXTERNAL saxpy, sscal, strsv, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. Executable Statements .. ! info = 0 upper = lsame( uplo, 'U' ) notran = lsame( trans, 'N' ) nounit = lsame( diag, 'N' ) ! ! Test the input parameters. ! IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -1 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT. & lsame( trans, 'C' ) ) THEN info = -2 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN info = -3 ELSE IF( .NOT.lsame( normin, 'Y' ) .AND. .NOT. & lsame( normin, 'N' ) ) THEN info = -4 ELSE IF( n < 0 ) THEN info = -5 ELSE IF( lda < MAX( 1, n ) ) THEN info = -7 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLATRS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Determine machine dependent parameters to control overflow. ! smlnum = slamch( 'Safe minimum' ) / slamch( 'Precision' ) bignum = one / smlnum scale = one ! IF( lsame( normin, 'N' ) ) THEN ! ! Compute the 1-norm of each column, not including the diagonal. ! IF( upper ) THEN ! ! A is upper triangular. ! DO j = 1, n cnorm( j ) = sasum( j-1, a( 1, j ), 1 ) END DO ELSE ! ! A is lower triangular. ! DO j = 1, n - 1 cnorm( j ) = sasum( n-j, a( j+1, j ), 1 ) END DO cnorm( n ) = zero END IF END IF ! ! Scale the column norms by TSCAL if the maximum element in CNORM is ! greater than BIGNUM. ! imax = isamax( n, cnorm, 1 ) tmax = cnorm( imax ) IF( tmax <= bignum ) THEN tscal = one ELSE tscal = one / ( smlnum*tmax ) CALL sscal( n, tscal, cnorm, 1 ) END IF ! ! Compute a bound on the computed solution vector to see if the ! Level 2 BLAS routine STRSV can be used. ! j = isamax( n, x, 1 ) xmax = ABS( x( j ) ) xbnd = xmax IF( notran ) THEN ! ! Compute the growth in A * x = b. ! IF( upper ) THEN jfirst = n jlast = 1 jinc = -1 ELSE jfirst = 1 jlast = n jinc = 1 END IF ! IF( tscal /= one ) THEN grow = zero GO TO 50 END IF ! IF( nounit ) THEN ! ! A is non-unit triangular. ! ! Compute GROW = 1/G(j) and XBND = 1/M(j). ! Initially, G(0) = max{x(i), i=1,...,n}. ! grow = one / MAX( xbnd, smlnum ) xbnd = grow DO j = jfirst, jlast, jinc ! ! Exit the loop if the growth factor is too small. ! IF( grow <= smlnum ) GO TO 50 ! ! M(j) = G(j-1) / abs(A(j,j)) ! tjj = ABS( a( j, j ) ) xbnd = MIN( xbnd, MIN( one, tjj )*grow ) IF( tjj+cnorm( j ) >= smlnum ) THEN ! ! G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) ! grow = grow*( tjj / ( tjj+cnorm( j ) ) ) ELSE ! ! G(j) could overflow, set GROW to 0. ! grow = zero END IF END DO grow = xbnd ELSE ! ! A is unit triangular. ! ! Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. ! grow = MIN( one, one / MAX( xbnd, smlnum ) ) DO j = jfirst, jlast, jinc ! ! Exit the loop if the growth factor is too small. ! IF( grow <= smlnum ) GO TO 50 ! ! G(j) = G(j-1)*( 1 + CNORM(j) ) ! grow = grow*( one / ( one+cnorm( j ) ) ) END DO END IF 50 CONTINUE ! ELSE ! ! Compute the growth in A' * x = b. ! IF( upper ) THEN jfirst = 1 jlast = n jinc = 1 ELSE jfirst = n jlast = 1 jinc = -1 END IF ! IF( tscal /= one ) THEN grow = zero GO TO 80 END IF ! IF( nounit ) THEN ! ! A is non-unit triangular. ! ! Compute GROW = 1/G(j) and XBND = 1/M(j). ! Initially, M(0) = max{x(i), i=1,...,n}. ! grow = one / MAX( xbnd, smlnum ) xbnd = grow DO j = jfirst, jlast, jinc ! ! Exit the loop if the growth factor is too small. ! IF( grow <= smlnum ) GO TO 80 ! ! G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) ! xj = one + cnorm( j ) grow = MIN( grow, xbnd / xj ) ! ! M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) ! tjj = ABS( a( j, j ) ) IF( xj > tjj ) xbnd = xbnd*( tjj / xj ) END DO grow = MIN( grow, xbnd ) ELSE ! ! A is unit triangular. ! ! Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. ! grow = MIN( one, one / MAX( xbnd, smlnum ) ) DO j = jfirst, jlast, jinc ! ! Exit the loop if the growth factor is too small. ! IF( grow <= smlnum ) GO TO 80 ! ! G(j) = ( 1 + CNORM(j) )*G(j-1) ! xj = one + cnorm( j ) grow = grow / xj END DO END IF 80 CONTINUE END IF ! IF( ( grow*tscal ) > smlnum ) THEN ! ! Use the Level 2 BLAS solve if the reciprocal of the bound on ! elements of X is not too small. ! CALL strsv( uplo, trans, diag, n, a, lda, x, 1 ) ELSE ! ! Use a Level 1 BLAS solve, scaling intermediate results. ! IF( xmax > bignum ) THEN ! ! Scale X so that its components are less than or equal to ! BIGNUM in absolute value. ! scale = bignum / xmax CALL sscal( n, scale, x, 1 ) xmax = bignum END IF ! IF( notran ) THEN ! ! Solve A * x = b ! DO j = jfirst, jlast, jinc ! ! Compute x(j) = b(j) / A(j,j), scaling x if necessary. ! xj = ABS( x( j ) ) IF( nounit ) THEN tjjs = a( j, j )*tscal ELSE tjjs = tscal IF( tscal == one ) GO TO 95 END IF tjj = ABS( tjjs ) IF( tjj > smlnum ) THEN ! ! abs(A(j,j)) > SMLNUM: ! IF( tjj < one ) THEN IF( xj > tjj*bignum ) THEN ! ! Scale x by 1/b(j). ! REC = one / xj CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF END IF x( j ) = x( j ) / tjjs xj = ABS( x( j ) ) ELSE IF( tjj > zero ) THEN ! ! 0 < abs(A(j,j)) <= SMLNUM: ! IF( xj > tjj*bignum ) THEN ! ! Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM ! to avoid overflow when dividing by A(j,j). ! REC = ( tjj*bignum ) / xj IF( cnorm( j ) > one ) THEN ! ! Scale by 1/CNORM(j) to avoid overflow when ! multiplying x(j) times column j. ! REC = REC / cnorm( j ) END IF CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF x( j ) = x( j ) / tjjs xj = ABS( x( j ) ) ELSE ! ! A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and ! scale = 0, and compute a solution to A*x = 0. ! DO i = 1, n x( i ) = zero END DO x( j ) = one xj = one scale = zero xmax = zero END IF 95 CONTINUE ! ! Scale x if necessary to avoid overflow when adding a ! multiple of column j of A. ! IF( xj > one ) THEN REC = one / xj IF( cnorm( j ) > ( bignum-xmax )*REC ) THEN ! ! Scale x by 1/(2*abs(x(j))). ! REC = REC*half CALL sscal( n, REC, x, 1 ) scale = scale*REC END IF ELSE IF( xj*cnorm( j ) > ( bignum-xmax ) ) THEN ! ! Scale x by 1/2. ! CALL sscal( n, half, x, 1 ) scale = scale*half END IF ! IF( upper ) THEN IF( j > 1 ) THEN ! ! Compute the update ! x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) ! CALL saxpy( j-1, -x( j )*tscal, a( 1, j ), 1, x, 1 ) i = isamax( j-1, x, 1 ) xmax = ABS( x( i ) ) END IF ELSE IF( j < n ) THEN ! ! Compute the update ! x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) ! CALL saxpy( n-j, -x( j )*tscal, a( j+1, j ), 1, x( j+1 ), 1 ) i = j + isamax( n-j, x( j+1 ), 1 ) xmax = ABS( x( i ) ) END IF END IF END DO ! ELSE ! ! Solve A' * x = b ! DO j = jfirst, jlast, jinc ! ! Compute x(j) = b(j) - sum A(k,j)*x(k). ! k<>j ! xj = ABS( x( j ) ) uscal = tscal REC = one / MAX( xmax, one ) IF( cnorm( j ) > ( bignum-xj )*REC ) THEN ! ! If x(j) could overflow, scale x by 1/(2*XMAX). ! REC = REC*half IF( nounit ) THEN tjjs = a( j, j )*tscal ELSE tjjs = tscal END IF tjj = ABS( tjjs ) IF( tjj > one ) THEN ! ! Divide by A(j,j) when scaling x if A(j,j) > 1. ! REC = MIN( one, REC*tjj ) uscal = uscal / tjjs END IF IF( REC < one ) THEN CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF END IF ! sumj = zero IF( uscal == one ) THEN ! ! If the scaling needed for A in the dot product is 1, ! call SDOT to perform the dot product. ! IF( upper ) THEN sumj = sdot( j-1, a( 1, j ), 1, x, 1 ) ELSE IF( j < n ) THEN sumj = sdot( n-j, a( j+1, j ), 1, x( j+1 ), 1 ) END IF ELSE ! ! Otherwise, use in-line code for the dot product. ! IF( upper ) THEN DO i = 1, j - 1 sumj = sumj + ( a( i, j )*uscal )*x( i ) END DO ELSE IF( j < n ) THEN DO i = j + 1, n sumj = sumj + ( a( i, j )*uscal )*x( i ) END DO END IF END IF ! IF( uscal == tscal ) THEN ! ! Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) ! was not used to scale the dotproduct. ! x( j ) = x( j ) - sumj xj = ABS( x( j ) ) IF( nounit ) THEN tjjs = a( j, j )*tscal ELSE tjjs = tscal IF( tscal == one ) GO TO 135 END IF ! ! Compute x(j) = x(j) / A(j,j), scaling if necessary. ! tjj = ABS( tjjs ) IF( tjj > smlnum ) THEN ! ! abs(A(j,j)) > SMLNUM: ! IF( tjj < one ) THEN IF( xj > tjj*bignum ) THEN ! ! Scale X by 1/abs(x(j)). ! REC = one / xj CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF END IF x( j ) = x( j ) / tjjs ELSE IF( tjj > zero ) THEN ! ! 0 < abs(A(j,j)) <= SMLNUM: ! IF( xj > tjj*bignum ) THEN ! ! Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. ! REC = ( tjj*bignum ) / xj CALL sscal( n, REC, x, 1 ) scale = scale*REC xmax = xmax*REC END IF x( j ) = x( j ) / tjjs ELSE ! ! A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and ! scale = 0, and compute a solution to A'*x = 0. ! DO i = 1, n x( i ) = zero END DO x( j ) = one scale = zero xmax = zero END IF 135 CONTINUE ELSE ! ! Compute x(j) := x(j) / A(j,j) - sumj if the dot ! product has already been divided by 1/A(j,j). ! x( j ) = x( j ) / tjjs - sumj END IF xmax = MAX( xmax, ABS( x( j ) ) ) END DO END IF scale = scale / tscal END IF ! ! Scale the column norms by 1/TSCAL for return. ! IF( tscal /= one ) THEN CALL sscal( n, one / tscal, cnorm, 1 ) END IF ! RETURN ! ! End of SLATRS ! END SUBROUTINE slatrs SUBROUTINE slatrz( m, n, l, a, lda, tau, work ) ! ! -- 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: l REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: tau( * ) REAL, INTENT(IN OUT) :: work( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLATRZ factors the M-by-(M+L) real upper trapezoidal matrix ! [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means ! of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal ! matrix and, R and A1 are M-by-M upper triangular matrices. ! ! 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. ! ! L (input) INTEGER ! The number of columns of the matrix A containing the ! meaningful part of the Householder vectors. N-M >= L >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the leading M-by-N upper trapezoidal part of the ! array A must contain the matrix to be factorized. ! On exit, the leading M-by-M upper triangular part of A ! contains the upper triangular matrix R, and elements N-L+1 to ! N of the first M rows of A, with the array TAU, represent the ! orthogonal matrix Z as a product of M elementary reflectors. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! TAU (output) REAL array, dimension (M) ! The scalar factors of the elementary reflectors. ! ! WORK (workspace) REAL array, dimension (M) ! ! Further Details ! =============== ! ! Based on contributions by ! A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA ! ! The factorization is obtained by Householder's method. The kth ! transformation matrix, Z( k ), which is used to introduce zeros into ! the ( m - k + 1 )th row of A, is given in the form ! ! Z( k ) = ( I 0 ), ! ( 0 T( k ) ) ! ! where ! ! T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), ! ( 0 ) ! ( z( k ) ) ! ! tau is a scalar and z( k ) is an l element vector. tau and z( k ) ! are chosen to annihilate the elements of the kth row of A2. ! ! The scalar tau is returned in the kth element of TAU and the vector ! u( k ) in the kth row of A2, such that the elements of z( k ) are ! in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in ! the upper triangular part of A1. ! ! Z is given by ! ! Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i ! .. ! .. External Subroutines .. EXTERNAL slarfg, slarz ! .. ! .. Executable Statements .. ! ! Test the input arguments ! ! Quick return if possible ! IF( m == 0 ) THEN RETURN ELSE IF( m == n ) THEN DO i = 1, n tau( i ) = zero END DO RETURN END IF ! DO i = m, 1, -1 ! ! Generate elementary reflector H(i) to annihilate ! [ A(i,i) A(i,n-l+1:n) ] ! CALL slarfg( l+1, a( i, i ), a( i, n-l+1 ), lda, tau( i ) ) ! ! Apply H(i) to A(1:i-1,i:n) from the right ! CALL slarz( 'Right', i-1, n-i+1, l, a( i, n-l+1 ), lda, & tau( i ), a( 1, i ), lda, work ) ! END DO ! RETURN ! ! End of SLATRZ ! END SUBROUTINE slatrz SUBROUTINE slatzm( side, m, n, v, incv, tau, c1, c2, ldc, work ) ! ! -- 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 (LEN=1), INTENT(IN) :: side INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: v( * ) INTEGER, INTENT(IN OUT) :: incv REAL, INTENT(IN) :: tau REAL, INTENT(IN OUT) :: c1( ldc, * ) REAL, INTENT(IN OUT) :: c2( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(IN OUT) :: work( * ) ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! This routine is deprecated and has been replaced by routine SORMRZ. ! ! SLATZM applies a Householder matrix generated by STZRQF to a matrix. ! ! Let P = I - tau*u*u', u = ( 1 ), ! ( v ) ! where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if ! SIDE = 'R'. ! ! If SIDE equals 'L', let ! C = [ C1 ] 1 ! [ C2 ] m-1 ! n ! Then C is overwritten by P*C. ! ! If SIDE equals 'R', let ! C = [ C1, C2 ] m ! 1 n-1 ! Then C is overwritten by C*P. ! ! Arguments ! ========= ! ! SIDE (input) CHARACTER*1 ! = 'L': form P * C ! = 'R': form C * P ! ! M (input) INTEGER ! The number of rows of the matrix C. ! ! N (input) INTEGER ! The number of columns of the matrix C. ! ! V (input) REAL array, dimension ! (1 + (M-1)*abs(INCV)) if SIDE = 'L' ! (1 + (N-1)*abs(INCV)) if SIDE = 'R' ! The vector v in the representation of P. V is not used ! if TAU = 0. ! ! INCV (input) INTEGER ! The increment between elements of v. INCV <> 0 ! ! TAU (input) REAL ! The value tau in the representation of P. ! ! C1 (input/output) REAL array, dimension ! (LDC,N) if SIDE = 'L' ! (M,1) if SIDE = 'R' ! On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1 ! if SIDE = 'R'. ! ! On exit, the first row of P*C if SIDE = 'L', or the first ! column of C*P if SIDE = 'R'. ! ! C2 (input/output) REAL array, dimension ! (LDC, N) if SIDE = 'L' ! (LDC, N-1) if SIDE = 'R' ! On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the ! m x (n - 1) matrix C2 if SIDE = 'R'. ! ! On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P ! if SIDE = 'R'. ! ! LDC (input) INTEGER ! The leading dimension of the arrays C1 and C2. LDC >= (1,M). ! ! WORK (workspace) REAL array, dimension ! (N) if SIDE = 'L' ! (M) if SIDE = 'R' ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, sgemv, sger ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Intrinsic Functions .. INTRINSIC MIN ! .. ! .. Executable Statements .. ! IF( ( MIN( m, n ) == 0 ) .OR. ( tau == zero ) ) RETURN ! IF( lsame( side, 'L' ) ) THEN ! ! w := C1 + v' * C2 ! CALL scopy( n, c1, ldc, work, 1 ) CALL sgemv( 'Transpose', m-1, n, one, c2, ldc, v, incv, one, work, 1 ) ! ! [ C1 ] := [ C1 ] - tau* [ 1 ] * w' ! [ C2 ] [ C2 ] [ v ] ! CALL saxpy( n, -tau, work, 1, c1, ldc ) CALL sger( m-1, n, -tau, v, incv, work, 1, c2, ldc ) ! ELSE IF( lsame( side, 'R' ) ) THEN ! ! w := C1 + C2 * v ! CALL scopy( m, c1, 1, work, 1 ) CALL sgemv( 'No transpose', m, n-1, one, c2, ldc, v, incv, one, work, 1 ) ! ! [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v'] ! CALL saxpy( m, -tau, work, 1, c1, 1 ) CALL sger( m, n-1, -tau, work, 1, v, incv, c2, ldc ) END IF ! RETURN ! ! End of SLATZM ! END SUBROUTINE slatzm SUBROUTINE slauu2( uplo, 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN) :: lda INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAUU2 computes the product U * U' or L' * L, where the triangular ! factor U or L is stored in the upper or lower triangular part of ! the array A. ! ! If UPLO = 'U' or 'u' then the upper triangle of the result is stored, ! overwriting the factor U in A. ! If UPLO = 'L' or 'l' then the lower triangle of the result is stored, ! overwriting the factor L in A. ! ! This is the unblocked form of the algorithm, calling Level 2 BLAS. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! Specifies whether the triangular factor stored in the array A ! is upper or lower triangular: ! = 'U': Upper triangular ! = 'L': Lower triangular ! ! N (input) INTEGER ! The order of the triangular factor U or L. N >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the triangular factor U or L. ! On exit, if UPLO = 'U', the upper triangle of A is ! overwritten with the upper triangle of the product U * U'; ! if UPLO = 'L', the lower triangle of A is overwritten with ! the lower triangle of the product 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 ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: i REAL :: aii ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: sdot EXTERNAL lsame, sdot ! .. ! .. External Subroutines .. EXTERNAL sgemv, sscal, 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 < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, n ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLAUU2', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! IF( upper ) THEN ! ! Compute the product U * U'. ! DO i = 1, n aii = a( i, i ) IF( i < n ) THEN a( i, i ) = sdot( n-i+1, a( i, i ), lda, a( i, i ), lda ) CALL sgemv( 'No transpose', i-1, n-i, one, a( 1, i+1 ), & lda, a( i, i+1 ), lda, aii, a( 1, i ), 1 ) ELSE CALL sscal( i, aii, a( 1, i ), 1 ) END IF END DO ! ELSE ! ! Compute the product L' * L. ! DO i = 1, n aii = a( i, i ) IF( i < n ) THEN a( i, i ) = sdot( n-i+1, a( i, i ), 1, a( i, i ), 1 ) CALL sgemv( 'Transpose', n-i, i-1, one, a( i+1, 1 ), lda, & a( i+1, i ), 1, aii, a( i, 1 ), lda ) ELSE CALL sscal( i, aii, a( i, 1 ), lda ) END IF END DO END IF ! RETURN ! ! End of SLAUU2 ! END SUBROUTINE slauu2 SUBROUTINE slauum( uplo, 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SLAUUM computes the product U * U' or L' * L, where the triangular ! factor U or L is stored in the upper or lower triangular part of ! the array A. ! ! If UPLO = 'U' or 'u' then the upper triangle of the result is stored, ! overwriting the factor U in A. ! If UPLO = 'L' or 'l' then the lower triangle of the result is stored, ! overwriting the factor L in A. ! ! This is the blocked form of the algorithm, calling Level 3 BLAS. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! Specifies whether the triangular factor stored in the array A ! is upper or lower triangular: ! = 'U': Upper triangular ! = 'L': Lower triangular ! ! N (input) INTEGER ! The order of the triangular factor U or L. N >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the triangular factor U or L. ! On exit, if UPLO = 'U', the upper triangle of A is ! overwritten with the upper triangle of the product U * U'; ! if UPLO = 'L', the lower triangle of A is overwritten with ! the lower triangle of the product 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 ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: i, ib, nb ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL lsame, ilaenv ! .. ! .. External Subroutines .. EXTERNAL sgemm, slauu2, ssyrk, strmm, 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 < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, n ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SLAUUM', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Determine the block size for this environment. ! nb = ilaenv( 1, 'SLAUUM', uplo, n, -1, -1, -1 ) ! IF( nb <= 1 .OR. nb >= n ) THEN ! ! Use unblocked code ! CALL slauu2( uplo, n, a, lda, info ) ELSE ! ! Use blocked code ! IF( upper ) THEN ! ! Compute the product U * U'. ! DO i = 1, n, nb ib = MIN( nb, n-i+1 ) CALL strmm( 'Right', 'Upper', 'Transpose', 'Non-unit', & i-1, ib, one, a( i, i ), lda, a( 1, i ), lda ) CALL slauu2( 'Upper', ib, a( i, i ), lda, info ) IF( i+ib <= n ) THEN CALL sgemm( 'No transpose', 'Transpose', i-1, ib, & n-i-ib+1, one, a( 1, i+ib ), lda, & a( i, i+ib ), lda, one, a( 1, i ), lda ) CALL ssyrk( 'Upper', 'No transpose', ib, n-i-ib+1, & one, a( i, i+ib ), lda, one, a( i, i ), lda ) END IF END DO ELSE ! ! Compute the product L' * L. ! DO i = 1, n, nb ib = MIN( nb, n-i+1 ) CALL strmm( 'Left', 'Lower', 'Transpose', 'Non-unit', ib, & i-1, one, a( i, i ), lda, a( i, 1 ), lda ) CALL slauu2( 'Lower', ib, a( i, i ), lda, info ) IF( i+ib <= n ) THEN CALL sgemm( 'Transpose', 'No transpose', ib, i-1, & n-i-ib+1, one, a( i+ib, i ), lda, & a( i+ib, 1 ), lda, one, a( i, 1 ), lda ) CALL ssyrk( 'Lower', 'Transpose', ib, n-i-ib+1, one, & a( i+ib, i ), lda, one, a( i, i ), lda ) END IF END DO END IF END IF ! RETURN ! ! End of SLAUUM ! END SUBROUTINE slauum SUBROUTINE sopgtr( 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN) :: ap( * ) REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SOPGTR generates a real orthogonal matrix Q which is defined as the ! product of n-1 elementary reflectors H(i) of order n, as returned by ! SSPTRD 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 SSPTRD; ! = 'L': Lower triangular packed storage used in previous ! call to SSPTRD. ! ! N (input) INTEGER ! The order of the matrix Q. N >= 0. ! ! AP (input) REAL array, dimension (N*(N+1)/2) ! The vectors which define the elementary reflectors, as ! returned by SSPTRD. ! ! TAU (input) REAL array, dimension (N-1) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SSPTRD. ! ! Q (output) REAL 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) REAL array, dimension (N-1) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: i, iinfo, ij, j ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL sorg2l, sorg2r, 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 < 0 ) THEN info = -2 ELSE IF( ldq < MAX( 1, n ) ) THEN info = -6 END IF IF( info /= 0 ) THEN CALL xerbla( 'SOPGTR', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! IF( upper ) THEN ! ! Q was determined by a call to SSPTRD 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 j = 1, n - 1 DO i = 1, j - 1 q( i, j ) = ap( ij ) ij = ij + 1 END DO ij = ij + 2 q( n, j ) = zero END DO DO i = 1, n - 1 q( i, n ) = zero END DO q( n, n ) = one ! ! Generate Q(1:n-1,1:n-1) ! CALL sorg2l( n-1, n-1, n-1, q, ldq, tau, work, iinfo ) ! ELSE ! ! Q was determined by a call to SSPTRD 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 i = 2, n q( i, 1 ) = zero END DO ij = 3 DO j = 2, n q( 1, j ) = zero DO i = j + 1, n q( i, j ) = ap( ij ) ij = ij + 1 END DO ij = ij + 2 END DO IF( n > 1 ) THEN ! ! Generate Q(2:n,2:n) ! CALL sorg2r( n-1, n-1, n-1, q( 2, 2 ), ldq, tau, work, iinfo ) END IF END IF RETURN ! ! End of SOPGTR ! END SUBROUTINE sopgtr SUBROUTINE sopmtr( side, uplo, trans, m, n, ap, 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 (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: ap( * ) REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SOPMTR 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 SSPTRD using packed ! storage: ! ! 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 triangular packed storage used in previous ! call to SSPTRD; ! = 'L': Lower triangular packed storage used in previous ! call to SSPTRD. ! ! 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. ! ! AP (input) REAL array, dimension ! (M*(M+1)/2) if SIDE = 'L' ! (N*(N+1)/2) if SIDE = 'R' ! The vectors which define the elementary reflectors, as ! returned by SSPTRD. AP is modified by the routine but ! restored on exit. ! ! TAU (input) REAL array, dimension (M-1) if SIDE = 'L' ! or (N-1) if SIDE = 'R' ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SSPTRD. ! ! C (input/output) REAL 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) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: forwrd, left, notran, upper INTEGER :: i, i1, i2, i3, ic, ii, jc, mi, ni, nq REAL :: aii ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL slarf, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 left = lsame( side, 'L' ) notran = lsame( trans, 'N' ) upper = lsame( uplo, 'U' ) ! ! 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.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -2 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) ) THEN info = -3 ELSE IF( m < 0 ) THEN info = -4 ELSE IF( n < 0 ) THEN info = -5 ELSE IF( ldc < MAX( 1, m ) ) THEN info = -9 END IF IF( info /= 0 ) THEN CALL xerbla( 'SOPMTR', -info ) RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 ) RETURN ! IF( upper ) THEN ! ! Q was determined by a call to SSPTRD with UPLO = 'U' ! forwrd = ( left .AND. notran ) .OR. ( .NOT.left .AND. .NOT.notran ) ! IF( forwrd ) THEN i1 = 1 i2 = nq - 1 i3 = 1 ii = 2 ELSE i1 = nq - 1 i2 = 1 i3 = -1 ii = nq*( nq+1 ) / 2 - 1 END IF ! IF( left ) THEN ni = n ELSE mi = m END IF ! DO i = i1, i2, i3 IF( left ) THEN ! ! H(i) is applied to C(1:i,1:n) ! mi = i ELSE ! ! H(i) is applied to C(1:m,1:i) ! ni = i END IF ! ! Apply H(i) ! aii = ap( ii ) ap( ii ) = one CALL slarf( side, mi, ni, ap( ii-i+1 ), 1, tau( i ), c, ldc, work ) ap( ii ) = aii ! IF( forwrd ) THEN ii = ii + i + 2 ELSE ii = ii - i - 1 END IF END DO ELSE ! ! Q was determined by a call to SSPTRD with UPLO = 'L'. ! forwrd = ( left .AND. .NOT.notran ) .OR. ( .NOT.left .AND. notran ) ! IF( forwrd ) THEN i1 = 1 i2 = nq - 1 i3 = 1 ii = 2 ELSE i1 = nq - 1 i2 = 1 i3 = -1 ii = nq*( nq+1 ) / 2 - 1 END IF ! IF( left ) THEN ni = n jc = 1 ELSE mi = m ic = 1 END IF ! DO i = i1, i2, i3 aii = ap( ii ) ap( ii ) = one IF( left ) THEN ! ! H(i) is applied to C(i+1:m,1:n) ! mi = m - i ic = i + 1 ELSE ! ! H(i) is applied to C(1:m,i+1:n) ! ni = n - i jc = i + 1 END IF ! ! Apply H(i) ! CALL slarf( side, mi, ni, ap( ii ), 1, tau( i ), c( ic, jc ), ldc, work ) ap( ii ) = aii ! IF( forwrd ) THEN ii = ii + nq - i + 1 ELSE ii = ii - nq + i - 2 END IF END DO END IF RETURN ! ! End of SOPMTR ! END SUBROUTINE sopmtr SUBROUTINE sorg2l( 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 ! February 29, 1992 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN OUT) :: m INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: tau( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORG2L 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 SGEQLF. ! ! 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) REAL 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 SGEQLF 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SGEQLF. ! ! WORK (workspace) REAL array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument has an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, ii, j, l ! .. ! .. External Subroutines .. EXTERNAL slarf, sscal, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 .OR. n > m ) THEN info = -2 ELSE IF( k < 0 .OR. k > n ) THEN info = -3 ELSE IF( lda < MAX( 1, m ) ) THEN info = -5 END IF IF( info /= 0 ) THEN CALL xerbla( 'SORG2L', -info ) RETURN END IF ! ! Quick return if possible ! IF( n <= 0 ) RETURN ! ! Initialise columns 1:n-k to columns of the unit matrix ! DO j = 1, n - k DO l = 1, m a( l, j ) = zero END DO a( m-n+j, j ) = one END DO ! DO 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 slarf( 'Left', m-n+ii, ii-1, a( 1, ii ), 1, tau( i ), a, lda, work ) CALL sscal( 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 l = m - n + ii + 1, m a( l, ii ) = zero END DO END DO RETURN ! ! End of SORG2L ! END SUBROUTINE sorg2l SUBROUTINE sorg2r( 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 ! February 29, 1992 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: tau( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORG2R 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 SGEQRF. ! ! 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) REAL 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 SGEQRF 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SGEQRF. ! ! WORK (workspace) REAL array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument has an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j, l ! .. ! .. External Subroutines .. EXTERNAL slarf, sscal, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 .OR. n > m ) THEN info = -2 ELSE IF( k < 0 .OR. k > n ) THEN info = -3 ELSE IF( lda < MAX( 1, m ) ) THEN info = -5 END IF IF( info /= 0 ) THEN CALL xerbla( 'SORG2R', -info ) RETURN END IF ! ! Quick return if possible ! IF( n <= 0 ) RETURN ! ! Initialise columns k+1:n to columns of the unit matrix ! DO j = k + 1, n DO l = 1, m a( l, j ) = zero END DO a( j, j ) = one END DO ! DO i = k, 1, -1 ! ! Apply H(i) to A(i:m,i:n) from the left ! IF( i < n ) THEN a( i, i ) = one CALL slarf( 'Left', m-i+1, n-i, a( i, i ), 1, tau( i ), & a( i, i+1 ), lda, work ) END IF IF( i < m ) CALL sscal( m-i, -tau( i ), a( i+1, i ), 1 ) a( i, i ) = one - tau( i ) ! ! Set A(1:i-1,i) to zero ! DO l = 1, i - 1 a( l, i ) = zero END DO END DO RETURN ! ! End of SORG2R ! END SUBROUTINE sorg2r SUBROUTINE sorgbr( 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 (LEN=1), INTENT(IN) :: vect INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORGBR generates one of the real orthogonal matrices Q or P**T ! determined by SGEBRD when reducing a real matrix A to bidiagonal ! form: A = Q * B * P**T. Q and P**T 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 SORGBR returns the first n ! columns of Q, where m >= n >= k; ! if m < k, Q = H(1) H(2) . . . H(m-1) and SORGBR returns Q as an ! M-by-M matrix. ! ! If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T ! is of order N: ! if k < n, P**T = G(k) . . . G(2) G(1) and SORGBR returns the first m ! rows of P**T, where n >= m >= k; ! if k >= n, P**T = G(n-1) . . . G(2) G(1) and SORGBR returns P**T as ! an N-by-N matrix. ! ! Arguments ! ========= ! ! VECT (input) CHARACTER*1 ! Specifies whether the matrix Q or the matrix P**T is ! required, as defined in the transformation applied by SGEBRD: ! = 'Q': generate Q; ! = 'P': generate P**T. ! ! M (input) INTEGER ! The number of rows of the matrix Q or P**T to be returned. ! M >= 0. ! ! N (input) INTEGER ! The number of columns of the matrix Q or P**T 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 SGEBRD. ! If VECT = 'P', the number of rows in the original K-by-N ! matrix reduced by SGEBRD. ! K >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the vectors which define the elementary reflectors, ! as returned by SGEBRD. ! On exit, the M-by-N matrix Q or P**T. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! TAU (input) REAL 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**T, as ! returned by SGEBRD in its array argument TAUQ or TAUP. ! ! WORK (workspace/output) REAL 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 .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, wantq INTEGER :: i, iinfo, j, lwkopt, mn, nb ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL ilaenv, lsame ! .. ! .. External Subroutines .. EXTERNAL sorglq, sorgqr, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 wantq = lsame( vect, 'Q' ) mn = MIN( m, n ) lquery = ( lwork == -1 ) IF( .NOT.wantq .AND. .NOT.lsame( vect, 'P' ) ) THEN info = -1 ELSE IF( m < 0 ) THEN info = -2 ELSE IF( n < 0 .OR. ( wantq .AND. ( n > m .OR. n < MIN( m, & k ) ) ) .OR. ( .NOT.wantq .AND. ( m > n .OR. m < MIN( n, k ) ) ) ) THEN info = -3 ELSE IF( k < 0 ) THEN info = -4 ELSE IF( lda < MAX( 1, m ) ) THEN info = -6 ELSE IF( lwork < MAX( 1, mn ) .AND. .NOT.lquery ) THEN info = -9 END IF ! IF( info == 0 ) THEN IF( wantq ) THEN nb = ilaenv( 1, 'SORGQR', ' ', m, n, k, -1 ) ELSE nb = ilaenv( 1, 'SORGLQ', ' ', m, n, k, -1 ) END IF lwkopt = MAX( 1, mn )*nb work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SORGBR', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 ) THEN work( 1 ) = 1 RETURN END IF ! IF( wantq ) THEN ! ! Form Q, determined by a call to SGEBRD to reduce an m-by-k ! matrix ! IF( m >= k ) THEN ! ! If m >= k, assume m >= n >= k ! CALL sorgqr( 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 j = m, 2, -1 a( 1, j ) = zero DO i = j + 1, m a( i, j ) = a( i, j-1 ) END DO END DO a( 1, 1 ) = one DO i = 2, m a( i, 1 ) = zero END DO IF( m > 1 ) THEN ! ! Form Q(2:m,2:m) ! CALL sorgqr( 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 SGEBRD to reduce a k-by-n ! matrix ! IF( k < n ) THEN ! ! If k < n, assume k <= m <= n ! CALL sorglq( 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 i = 2, n a( i, 1 ) = zero END DO DO j = 2, n DO i = j - 1, 2, -1 a( i, j ) = a( i-1, j ) END DO a( 1, j ) = zero END DO IF( n > 1 ) THEN ! ! Form P'(2:n,2:n) ! CALL sorglq( 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 SORGBR ! END SUBROUTINE sorgbr SUBROUTINE sorghr( n, ilo, ihi, 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, INTENT(IN) :: n INTEGER, INTENT(IN) :: ilo INTEGER, INTENT(IN) :: ihi REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORGHR generates a real orthogonal matrix Q which is defined as the ! product of IHI-ILO elementary reflectors of order N, as returned by ! SGEHRD: ! ! Q = H(ilo) H(ilo+1) . . . H(ihi-1). ! ! Arguments ! ========= ! ! N (input) INTEGER ! The order of the matrix Q. N >= 0. ! ! ILO (input) INTEGER ! IHI (input) INTEGER ! ILO and IHI must have the same values as in the previous call ! of SGEHRD. Q is equal to the unit matrix except in the ! submatrix Q(ilo+1:ihi,ilo+1:ihi). ! 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the vectors which define the elementary reflectors, ! as returned by SGEHRD. ! 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) REAL array, dimension (N-1) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SGEHRD. ! ! WORK (workspace/output) REAL array, dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. LWORK >= IHI-ILO. ! For optimum performance LWORK >= (IHI-ILO)*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 .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: i, iinfo, j, lwkopt, nb, nh ! .. ! .. External Subroutines .. EXTERNAL sorgqr, xerbla ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 nh = ihi - ilo lquery = ( lwork == -1 ) IF( n < 0 ) THEN info = -1 ELSE IF( ilo < 1 .OR. ilo > MAX( 1, n ) ) THEN info = -2 ELSE IF( ihi < MIN( ilo, n ) .OR. ihi > n ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( lwork < MAX( 1, nh ) .AND. .NOT.lquery ) THEN info = -8 END IF ! IF( info == 0 ) THEN nb = ilaenv( 1, 'SORGQR', ' ', nh, nh, nh, -1 ) lwkopt = MAX( 1, nh )*nb work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SORGHR', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) THEN work( 1 ) = 1 RETURN END IF ! ! Shift the vectors which define the elementary reflectors one ! column to the right, and set the first ilo and the last n-ihi ! rows and columns to those of the unit matrix ! DO j = ihi, ilo + 1, -1 DO i = 1, j - 1 a( i, j ) = zero END DO DO i = j + 1, ihi a( i, j ) = a( i, j-1 ) END DO DO i = ihi + 1, n a( i, j ) = zero END DO END DO DO j = 1, ilo DO i = 1, n a( i, j ) = zero END DO a( j, j ) = one END DO DO j = ihi + 1, n DO i = 1, n a( i, j ) = zero END DO a( j, j ) = one END DO ! IF( nh > 0 ) THEN ! ! Generate Q(ilo+1:ihi,ilo+1:ihi) ! CALL sorgqr( nh, nh, nh, a( ilo+1, ilo+1 ), lda, tau( ilo ), & work, lwork, iinfo ) END IF work( 1 ) = lwkopt RETURN ! ! End of SORGHR ! END SUBROUTINE sorghr SUBROUTINE sorgl2( 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: tau( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORGL2 generates an m by n real 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 SGELQF. ! ! 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) REAL 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 SGELQF 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SGELQF. ! ! WORK (workspace) REAL array, dimension (M) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument has an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, j, l ! .. ! .. External Subroutines .. EXTERNAL slarf, sscal, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < m ) THEN info = -2 ELSE IF( k < 0 .OR. k > m ) THEN info = -3 ELSE IF( lda < MAX( 1, m ) ) THEN info = -5 END IF IF( info /= 0 ) THEN CALL xerbla( 'SORGL2', -info ) RETURN END IF ! ! Quick return if possible ! IF( m <= 0 ) RETURN ! IF( k < m ) THEN ! ! Initialise rows k+1:m to rows of the unit matrix ! DO j = 1, n DO l = k + 1, m a( l, j ) = zero END DO IF( j > k .AND. j <= m ) a( j, j ) = one END DO END IF ! DO i = k, 1, -1 ! ! Apply H(i) to A(i:m,i:n) from the right ! IF( i < n ) THEN IF( i < m ) THEN a( i, i ) = one CALL slarf( 'Right', m-i, n-i+1, a( i, i ), lda, & tau( i ), a( i+1, i ), lda, work ) END IF CALL sscal( n-i, -tau( i ), a( i, i+1 ), lda ) END IF a( i, i ) = one - tau( i ) ! ! Set A(i,1:i-1) to zero ! DO l = 1, i - 1 a( i, l ) = zero END DO END DO RETURN ! ! End of SORGL2 ! END SUBROUTINE sorgl2 SUBROUTINE sorglq( 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORGLQ generates an M-by-N real 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 SGELQF. ! ! 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) REAL 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 SGELQF 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SGELQF. ! ! WORK (workspace/output) REAL 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 .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: i, ib, iinfo, iws, j, ki, kk, l, ldwork, lwkopt, nb, nbmin, nx ! .. ! .. External Subroutines .. EXTERNAL slarfb, slarft, sorgl2, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 nb = ilaenv( 1, 'SORGLQ', ' ', m, n, k, -1 ) lwkopt = MAX( 1, m )*nb work( 1 ) = lwkopt lquery = ( lwork == -1 ) IF( m < 0 ) THEN info = -1 ELSE IF( n < m ) THEN info = -2 ELSE IF( k < 0 .OR. k > m ) THEN info = -3 ELSE IF( lda < MAX( 1, m ) ) THEN info = -5 ELSE IF( lwork < MAX( 1, m ) .AND. .NOT.lquery ) THEN info = -8 END IF IF( info /= 0 ) THEN CALL xerbla( 'SORGLQ', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( m <= 0 ) THEN work( 1 ) = 1 RETURN END IF ! nbmin = 2 nx = 0 iws = m IF( nb > 1 .AND. nb < k ) THEN ! ! Determine when to cross over from blocked to unblocked code. ! nx = MAX( 0, ilaenv( 3, 'SORGLQ', ' ', m, n, k, -1 ) ) IF( nx < k ) THEN ! ! Determine if workspace is large enough for blocked code. ! ldwork = m iws = ldwork*nb IF( lwork < 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, 'SORGLQ', ' ', m, n, k, -1 ) ) END IF END IF END IF ! IF( nb >= nbmin .AND. nb < k .AND. nx < 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 j = 1, kk DO i = kk + 1, m a( i, j ) = zero END DO END DO ELSE kk = 0 END IF ! ! Use unblocked code for the last or only block. ! IF( kk < m ) CALL sorgl2( m-kk, n-kk, k-kk, a( kk+1, kk+1 ), lda, & tau( kk+1 ), work, iinfo ) ! IF( kk > 0 ) THEN ! ! Use blocked code ! DO i = ki + 1, 1, -nb ib = MIN( nb, k-i+1 ) IF( i+ib <= m ) THEN ! ! Form the triangular factor of the block reflector ! H = H(i) H(i+1) . . . H(i+ib-1) ! CALL slarft( '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 slarfb( 'Right', '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 sorgl2( ib, n-i+1, ib, a( i, i ), lda, tau( i ), work, iinfo ) ! ! Set columns 1:i-1 of current block to zero ! DO j = 1, i - 1 DO l = i, i + ib - 1 a( l, j ) = zero END DO END DO END DO END IF ! work( 1 ) = iws RETURN ! ! End of SORGLQ ! END SUBROUTINE sorglq SUBROUTINE sorgql( 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORGQL 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 SGEQLF. ! ! 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) REAL 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 SGEQLF 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SGEQLF. ! ! WORK (workspace/output) REAL 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 .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: i, ib, iinfo, iws, j, kk, l, ldwork, lwkopt, nb, nbmin, nx ! .. ! .. External Subroutines .. EXTERNAL slarfb, slarft, sorg2l, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 nb = ilaenv( 1, 'SORGQL', ' ', m, n, k, -1 ) lwkopt = MAX( 1, n )*nb work( 1 ) = lwkopt lquery = ( lwork == -1 ) IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 .OR. n > m ) THEN info = -2 ELSE IF( k < 0 .OR. k > n ) THEN info = -3 ELSE IF( lda < MAX( 1, m ) ) THEN info = -5 ELSE IF( lwork < MAX( 1, n ) .AND. .NOT.lquery ) THEN info = -8 END IF IF( info /= 0 ) THEN CALL xerbla( 'SORGQL', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n <= 0 ) THEN work( 1 ) = 1 RETURN END IF ! nbmin = 2 nx = 0 iws = n IF( nb > 1 .AND. nb < k ) THEN ! ! Determine when to cross over from blocked to unblocked code. ! nx = MAX( 0, ilaenv( 3, 'SORGQL', ' ', m, n, k, -1 ) ) IF( nx < k ) THEN ! ! Determine if workspace is large enough for blocked code. ! ldwork = n iws = ldwork*nb IF( lwork < 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, 'SORGQL', ' ', m, n, k, -1 ) ) END IF END IF END IF ! IF( nb >= nbmin .AND. nb < k .AND. nx < 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 j = 1, n - kk DO i = m - kk + 1, m a( i, j ) = zero END DO END DO ELSE kk = 0 END IF ! ! Use unblocked code for the first or only block. ! CALL sorg2l( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo ) ! IF( kk > 0 ) THEN ! ! Use blocked code ! DO i = k - kk + 1, k, nb ib = MIN( nb, k-i+1 ) IF( n-k+i > 1 ) THEN ! ! Form the triangular factor of the block reflector ! H = H(i+ib-1) . . . H(i+1) H(i) ! CALL slarft( '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 slarfb( '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 sorg2l( 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 j = n - k + i, n - k + i + ib - 1 DO l = m - k + i + ib, m a( l, j ) = zero END DO END DO END DO END IF ! work( 1 ) = iws RETURN ! ! End of SORGQL ! END SUBROUTINE sorgql SUBROUTINE sorgqr( 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORGQR 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 SGEQRF. ! ! 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) REAL 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 SGEQRF 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SGEQRF. ! ! WORK (workspace/output) REAL 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 .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: i, ib, iinfo, iws, j, ki, kk, l, ldwork, lwkopt, nb, nbmin, nx ! .. ! .. External Subroutines .. EXTERNAL slarfb, slarft, sorg2r, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 nb = ilaenv( 1, 'SORGQR', ' ', m, n, k, -1 ) lwkopt = MAX( 1, n )*nb work( 1 ) = lwkopt lquery = ( lwork == -1 ) IF( m < 0 ) THEN info = -1 ELSE IF( n < 0 .OR. n > m ) THEN info = -2 ELSE IF( k < 0 .OR. k > n ) THEN info = -3 ELSE IF( lda < MAX( 1, m ) ) THEN info = -5 ELSE IF( lwork < MAX( 1, n ) .AND. .NOT.lquery ) THEN info = -8 END IF IF( info /= 0 ) THEN CALL xerbla( 'SORGQR', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n <= 0 ) THEN work( 1 ) = 1 RETURN END IF ! nbmin = 2 nx = 0 iws = n IF( nb > 1 .AND. nb < k ) THEN ! ! Determine when to cross over from blocked to unblocked code. ! nx = MAX( 0, ilaenv( 3, 'SORGQR', ' ', m, n, k, -1 ) ) IF( nx < k ) THEN ! ! Determine if workspace is large enough for blocked code. ! ldwork = n iws = ldwork*nb IF( lwork < 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, 'SORGQR', ' ', m, n, k, -1 ) ) END IF END IF END IF ! IF( nb >= nbmin .AND. nb < k .AND. nx < 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 j = kk + 1, n DO i = 1, kk a( i, j ) = zero END DO END DO ELSE kk = 0 END IF ! ! Use unblocked code for the last or only block. ! IF( kk < n ) CALL sorg2r( m-kk, n-kk, k-kk, a( kk+1, kk+1 ), lda, & tau( kk+1 ), work, iinfo ) ! IF( kk > 0 ) THEN ! ! Use blocked code ! DO i = ki + 1, 1, -nb ib = MIN( nb, k-i+1 ) IF( i+ib <= n ) THEN ! ! Form the triangular factor of the block reflector ! H = H(i) H(i+1) . . . H(i+ib-1) ! CALL slarft( '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 slarfb( '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 sorg2r( m-i+1, ib, ib, a( i, i ), lda, tau( i ), work, iinfo ) ! ! Set rows 1:i-1 of current block to zero ! DO j = i, i + ib - 1 DO l = 1, i - 1 a( l, j ) = zero END DO END DO END DO END IF ! work( 1 ) = iws RETURN ! ! End of SORGQR ! END SUBROUTINE sorgqr SUBROUTINE sorgr2( 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 ! February 29, 1992 ! ! .. Scalar Arguments .. INTEGER, INTENT(IN OUT) :: m INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: tau( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORGR2 generates an m by n real matrix Q with orthonormal rows, ! which is defined as the last m rows of a product of k elementary ! reflectors of order n ! ! Q = H(1) H(2) . . . H(k) ! ! as returned by SGERQF. ! ! 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) REAL array, dimension (LDA,N) ! On entry, the (m-k+i)-th row must contain the vector which ! defines the elementary reflector H(i), for i = 1,2,...,k, as ! returned by SGERQF in the last 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SGERQF. ! ! WORK (workspace) REAL array, dimension (M) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument has an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, ii, j, l ! .. ! .. External Subroutines .. EXTERNAL slarf, sscal, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < m ) THEN info = -2 ELSE IF( k < 0 .OR. k > m ) THEN info = -3 ELSE IF( lda < MAX( 1, m ) ) THEN info = -5 END IF IF( info /= 0 ) THEN CALL xerbla( 'SORGR2', -info ) RETURN END IF ! ! Quick return if possible ! IF( m <= 0 ) RETURN ! IF( k < m ) THEN ! ! Initialise rows 1:m-k to rows of the unit matrix ! DO j = 1, n DO l = 1, m - k a( l, j ) = zero END DO IF( j > n-m .AND. j <= n-k ) a( m-n+j, j ) = one END DO END IF ! DO i = 1, k ii = m - k + i ! ! Apply H(i) to A(1:m-k+i,1:n-k+i) from the right ! a( ii, n-m+ii ) = one CALL slarf( 'Right', ii-1, n-m+ii, a( ii, 1 ), lda, tau( i ), a, lda, work ) CALL sscal( n-m+ii-1, -tau( i ), a( ii, 1 ), lda ) a( ii, n-m+ii ) = one - tau( i ) ! ! Set A(m-k+i,n-k+i+1:n) to zero ! DO l = n - m + ii + 1, n a( ii, l ) = zero END DO END DO RETURN ! ! End of SORGR2 ! END SUBROUTINE sorgr2 SUBROUTINE sorgrq( 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORGRQ generates an M-by-N real matrix Q with orthonormal rows, ! which is defined as the last M rows of a product of K elementary ! reflectors of order N ! ! Q = H(1) H(2) . . . H(k) ! ! as returned by SGERQF. ! ! 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) REAL array, dimension (LDA,N) ! On entry, the (m-k+i)-th row must contain the vector which ! defines the elementary reflector H(i), for i = 1,2,...,k, as ! returned by SGERQF in the last 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SGERQF. ! ! WORK (workspace/output) REAL 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 .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: i, ib, ii, iinfo, iws, j, kk, l, ldwork, lwkopt, nb, nbmin, nx ! .. ! .. External Subroutines .. EXTERNAL slarfb, slarft, sorgr2, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 nb = ilaenv( 1, 'SORGRQ', ' ', m, n, k, -1 ) lwkopt = MAX( 1, m )*nb work( 1 ) = lwkopt lquery = ( lwork == -1 ) IF( m < 0 ) THEN info = -1 ELSE IF( n < m ) THEN info = -2 ELSE IF( k < 0 .OR. k > m ) THEN info = -3 ELSE IF( lda < MAX( 1, m ) ) THEN info = -5 ELSE IF( lwork < MAX( 1, m ) .AND. .NOT.lquery ) THEN info = -8 END IF IF( info /= 0 ) THEN CALL xerbla( 'SORGRQ', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( m <= 0 ) THEN work( 1 ) = 1 RETURN END IF ! nbmin = 2 nx = 0 iws = m IF( nb > 1 .AND. nb < k ) THEN ! ! Determine when to cross over from blocked to unblocked code. ! nx = MAX( 0, ilaenv( 3, 'SORGRQ', ' ', m, n, k, -1 ) ) IF( nx < k ) THEN ! ! Determine if workspace is large enough for blocked code. ! ldwork = m iws = ldwork*nb IF( lwork < 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, 'SORGRQ', ' ', m, n, k, -1 ) ) END IF END IF END IF ! IF( nb >= nbmin .AND. nb < k .AND. nx < k ) THEN ! ! Use blocked code after the first block. ! The last kk rows are handled by the block method. ! kk = MIN( k, ( ( k-nx+nb-1 ) / nb )*nb ) ! ! Set A(1:m-kk,n-kk+1:n) to zero. ! DO j = n - kk + 1, n DO i = 1, m - kk a( i, j ) = zero END DO END DO ELSE kk = 0 END IF ! ! Use unblocked code for the first or only block. ! CALL sorgr2( m-kk, n-kk, k-kk, a, lda, tau, work, iinfo ) ! IF( kk > 0 ) THEN ! ! Use blocked code ! DO i = k - kk + 1, k, nb ib = MIN( nb, k-i+1 ) ii = m - k + i IF( ii > 1 ) THEN ! ! Form the triangular factor of the block reflector ! H = H(i+ib-1) . . . H(i+1) H(i) ! CALL slarft( 'Backward', 'Rowwise', n-k+i+ib-1, ib, & a( ii, 1 ), lda, tau( i ), work, ldwork ) ! ! Apply H' to A(1:m-k+i-1,1:n-k+i+ib-1) from the right ! CALL slarfb( 'Right', 'Transpose', 'Backward', 'Rowwise', & ii-1, n-k+i+ib-1, ib, a( ii, 1 ), lda, work, & ldwork, a, lda, work( ib+1 ), ldwork ) END IF ! ! Apply H' to columns 1:n-k+i+ib-1 of current block ! CALL sorgr2( ib, n-k+i+ib-1, ib, a( ii, 1 ), lda, tau( i ), work, iinfo ) ! ! Set columns n-k+i+ib:n of current block to zero ! DO l = n - k + i + ib, n DO j = ii, ii + ib - 1 a( j, l ) = zero END DO END DO END DO END IF ! work( 1 ) = iws RETURN ! ! End of SORGRQ ! END SUBROUTINE sorgrq SUBROUTINE sorgtr( 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN OUT) :: n REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORGTR generates a real orthogonal matrix Q which is defined as the ! product of n-1 elementary reflectors of order N, as returned by ! SSYTRD: ! ! 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 SSYTRD; ! = 'L': Lower triangle of A contains elementary reflectors ! from SSYTRD. ! ! N (input) INTEGER ! The order of the matrix Q. N >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the vectors which define the elementary reflectors, ! as returned by SSYTRD. ! 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) REAL array, dimension (N-1) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SSYTRD. ! ! WORK (workspace/output) REAL 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 .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, upper INTEGER :: i, iinfo, j, lwkopt, nb ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL ilaenv, lsame ! .. ! .. External Subroutines .. EXTERNAL sorgql, sorgqr, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 lquery = ( lwork == -1 ) upper = lsame( uplo, 'U' ) IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, n ) ) THEN info = -4 ELSE IF( lwork < MAX( 1, n-1 ) .AND. .NOT.lquery ) THEN info = -7 END IF ! IF( info == 0 ) THEN IF ( upper ) THEN nb = ilaenv( 1, 'SORGQL', ' ', n-1, n-1, n-1, -1 ) ELSE nb = ilaenv( 1, 'SORGQR', ' ', n-1, n-1, n-1, -1 ) END IF lwkopt = MAX( 1, n-1 )*nb work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SORGTR', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) THEN work( 1 ) = 1 RETURN END IF ! IF( upper ) THEN ! ! Q was determined by a call to SSYTRD 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 j = 1, n - 1 DO i = 1, j - 1 a( i, j ) = a( i, j+1 ) END DO a( n, j ) = zero END DO DO i = 1, n - 1 a( i, n ) = zero END DO a( n, n ) = one ! ! Generate Q(1:n-1,1:n-1) ! CALL sorgql( n-1, n-1, n-1, a, lda, tau, work, lwork, iinfo ) ! ELSE ! ! Q was determined by a call to SSYTRD 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 j = n, 2, -1 a( 1, j ) = zero DO i = j + 1, n a( i, j ) = a( i, j-1 ) END DO END DO a( 1, 1 ) = one DO i = 2, n a( i, 1 ) = zero END DO IF( n > 1 ) THEN ! ! Generate Q(2:n,2:n) ! CALL sorgqr( n-1, n-1, n-1, a( 2, 2 ), lda, tau, work, lwork, iinfo ) END IF END IF work( 1 ) = lwkopt RETURN ! ! End of SORGTR ! END SUBROUTINE sorgtr SUBROUTINE sorm2l( 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 (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: k REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORM2L 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 SGEQLF. 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) REAL 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 ! SGEQLF 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SGEQLF. ! ! C (input/output) REAL 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) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: left, notran INTEGER :: i, i1, i2, i3, mi, ni, nq REAL :: aii ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL slarf, 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 < 0 ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( k < 0 .OR. k > nq ) THEN info = -5 ELSE IF( lda < MAX( 1, nq ) ) THEN info = -7 ELSE IF( ldc < MAX( 1, m ) ) THEN info = -10 END IF IF( info /= 0 ) THEN CALL xerbla( 'SORM2L', -info ) RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 .OR. k == 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 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 slarf( side, mi, ni, a( 1, i ), 1, tau( i ), c, ldc, work ) a( nq-k+i, i ) = aii END DO RETURN ! ! End of SORM2L ! END SUBROUTINE sorm2l SUBROUTINE sorm2r( 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 (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORM2R 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 SGEQRF. 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) REAL 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 ! SGEQRF 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SGEQRF. ! ! C (input/output) REAL 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) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: left, notran INTEGER :: i, i1, i2, i3, ic, jc, mi, ni, nq REAL :: aii ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL slarf, 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 < 0 ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( k < 0 .OR. k > nq ) THEN info = -5 ELSE IF( lda < MAX( 1, nq ) ) THEN info = -7 ELSE IF( ldc < MAX( 1, m ) ) THEN info = -10 END IF IF( info /= 0 ) THEN CALL xerbla( 'SORM2R', -info ) RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 .OR. k == 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 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 slarf( side, mi, ni, a( i, i ), 1, tau( i ), c( ic, jc ), ldc, work ) a( i, i ) = aii END DO RETURN ! ! End of SORM2R ! END SUBROUTINE sorm2r SUBROUTINE sormbr( 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 (LEN=1), INTENT(IN) :: vect CHARACTER (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! If VECT = 'Q', SORMBR 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 ! ! If VECT = 'P', SORMBR overwrites the general real M-by-N matrix C ! with ! SIDE = 'L' SIDE = 'R' ! TRANS = 'N': P * C C * P ! TRANS = 'T': P**T * C C * P**T ! ! Here Q and P**T are the orthogonal matrices determined by SGEBRD when ! reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and ! P**T 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 orthogonal matrix Q or P**T 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**T; ! = 'P': apply P or P**T. ! ! SIDE (input) CHARACTER*1 ! = 'L': apply Q, Q**T, P or P**T from the Left; ! = 'R': apply Q, Q**T, P or P**T from the Right. ! ! TRANS (input) CHARACTER*1 ! = 'N': No transpose, apply Q or P; ! = 'T': Transpose, apply Q**T or P**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 ! If VECT = 'Q', the number of columns in the original ! matrix reduced by SGEBRD. ! If VECT = 'P', the number of rows in the original ! matrix reduced by SGEBRD. ! K >= 0. ! ! A (input) REAL 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 SGEBRD. ! ! 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) REAL 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 SGEBRD in the array argument TAUQ or TAUP. ! ! C (input/output) REAL 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 ! or P*C or P**T*C or C*P or C*P**T. ! ! LDC (input) INTEGER ! The leading dimension of the array C. LDC >= max(1,M). ! ! WORK (workspace/output) REAL 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 (LEN=1) :: transt INTEGER :: i1, i2, iinfo, lwkopt, mi, nb, ni, nq, nw ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL ilaenv, lsame ! .. ! .. External Subroutines .. EXTERNAL sormlq, sormqr, xerbla ! .. ! .. 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 == -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, 'T' ) ) THEN info = -3 ELSE IF( m < 0 ) THEN info = -4 ELSE IF( n < 0 ) THEN info = -5 ELSE IF( k < 0 ) THEN info = -6 ELSE IF( ( applyq .AND. lda < MAX( 1, nq ) ) .OR. & ( .NOT.applyq .AND. lda < MAX( 1, MIN( nq, k ) ) ) ) THEN info = -8 ELSE IF( ldc < MAX( 1, m ) ) THEN info = -11 ELSE IF( lwork < MAX( 1, nw ) .AND. .NOT.lquery ) THEN info = -13 END IF ! IF( info == 0 ) THEN IF( applyq ) THEN IF( left ) THEN nb = ilaenv( 1, 'SORMQR', side // trans, m-1, n, m-1, -1 ) ELSE nb = ilaenv( 1, 'SORMQR', side // trans, m, n-1, n-1, -1 ) END IF ELSE IF( left ) THEN nb = ilaenv( 1, 'SORMLQ', side // trans, m-1, n, m-1, -1 ) ELSE nb = ilaenv( 1, 'SORMLQ', side // trans, m, n-1, n-1, -1 ) END IF END IF lwkopt = MAX( 1, nw )*nb work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SORMBR', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! work( 1 ) = 1 IF( m == 0 .OR. n == 0 ) RETURN ! IF( applyq ) THEN ! ! Apply Q ! IF( nq >= k ) THEN ! ! Q was determined by a call to SGEBRD with nq >= k ! CALL sormqr( side, trans, m, n, k, a, lda, tau, c, ldc, & work, lwork, iinfo ) ELSE IF( nq > 1 ) THEN ! ! Q was determined by a call to SGEBRD 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 sormqr( 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 = 'T' ELSE transt = 'N' END IF IF( nq > k ) THEN ! ! P was determined by a call to SGEBRD with nq > k ! CALL sormlq( side, transt, m, n, k, a, lda, tau, c, ldc, & work, lwork, iinfo ) ELSE IF( nq > 1 ) THEN ! ! P was determined by a call to SGEBRD 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 sormlq( 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 SORMBR ! END SUBROUTINE sormbr SUBROUTINE sormhr( side, trans, m, n, ilo, ihi, 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 (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: ilo INTEGER, INTENT(IN) :: ihi REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORMHR 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 ! IHI-ILO elementary reflectors, as returned by SGEHRD: ! ! Q = H(ilo) H(ilo+1) . . . H(ihi-1). ! ! 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. ! ! ILO (input) INTEGER ! IHI (input) INTEGER ! ILO and IHI must have the same values as in the previous call ! of SGEHRD. Q is equal to the unit matrix except in the ! submatrix Q(ilo+1:ihi,ilo+1:ihi). ! If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and ! ILO = 1 and IHI = 0, if M = 0; ! if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and ! ILO = 1 and IHI = 0, if N = 0. ! ! A (input) REAL array, dimension ! (LDA,M) if SIDE = 'L' ! (LDA,N) if SIDE = 'R' ! The vectors which define the elementary reflectors, as ! returned by SGEHRD. ! ! 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) REAL 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 SGEHRD. ! ! C (input/output) REAL 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) REAL 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 INTEGER :: i1, i2, iinfo, lwkopt, mi, nb, nh, ni, nq, nw ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL ilaenv, lsame ! .. ! .. External Subroutines .. EXTERNAL sormqr, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 nh = ihi - ilo left = lsame( side, 'L' ) lquery = ( lwork == -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.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'T' ) ) & THEN info = -2 ELSE IF( m < 0 ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( ilo < 1 .OR. ilo > MAX( 1, nq ) ) THEN info = -5 ELSE IF( ihi < MIN( ilo, nq ) .OR. ihi > nq ) THEN info = -6 ELSE IF( lda < MAX( 1, nq ) ) THEN info = -8 ELSE IF( ldc < MAX( 1, m ) ) THEN info = -11 ELSE IF( lwork < MAX( 1, nw ) .AND. .NOT.lquery ) THEN info = -13 END IF ! IF( info == 0 ) THEN IF( left ) THEN nb = ilaenv( 1, 'SORMQR', side // trans, nh, n, nh, -1 ) ELSE nb = ilaenv( 1, 'SORMQR', side // trans, m, nh, nh, -1 ) END IF lwkopt = MAX( 1, nw )*nb work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SORMHR', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 .OR. nh == 0 ) THEN work( 1 ) = 1 RETURN END IF ! IF( left ) THEN mi = nh ni = n i1 = ilo + 1 i2 = 1 ELSE mi = m ni = nh i1 = 1 i2 = ilo + 1 END IF ! CALL sormqr( side, trans, mi, ni, nh, a( ilo+1, ilo ), lda, & tau( ilo ), c( i1, i2 ), ldc, work, lwork, iinfo ) ! work( 1 ) = lwkopt RETURN ! ! End of SORMHR ! END SUBROUTINE sormhr SUBROUTINE sorml2( 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 (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORML2 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 SGELQF. 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) REAL 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 ! SGELQF 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SGELQF. ! ! C (input/output) REAL 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) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: left, notran INTEGER :: i, i1, i2, i3, ic, jc, mi, ni, nq REAL :: aii ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL slarf, 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 < 0 ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( k < 0 .OR. k > nq ) THEN info = -5 ELSE IF( lda < MAX( 1, k ) ) THEN info = -7 ELSE IF( ldc < MAX( 1, m ) ) THEN info = -10 END IF IF( info /= 0 ) THEN CALL xerbla( 'SORML2', -info ) RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 .OR. k == 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 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 slarf( side, mi, ni, a( i, i ), lda, tau( i ), c( ic, jc ), ldc, work ) a( i, i ) = aii END DO RETURN ! ! End of SORML2 ! END SUBROUTINE sorml2 SUBROUTINE sormlq( 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 (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORMLQ 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 SGELQF. 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) REAL 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 ! SGELQF 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SGELQF. ! ! C (input/output) REAL 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) REAL 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, PARAMETER :: nbmax = 64 INTEGER, PARAMETER :: ldt = nbmax+1 ! .. ! .. Local Scalars .. LOGICAL :: left, lquery, notran CHARACTER (LEN=1) :: transt INTEGER :: i, i1, i2, i3, ib, ic, iinfo, iws, jc, ldwork, & lwkopt, mi, nb, nbmin, ni, nq, nw ! .. ! .. Local Arrays .. REAL :: t( ldt, nbmax ) ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL lsame, ilaenv ! .. ! .. External Subroutines .. EXTERNAL slarfb, slarft, sorml2, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 left = lsame( side, 'L' ) notran = lsame( trans, 'N' ) lquery = ( lwork == -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 < 0 ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( k < 0 .OR. k > nq ) THEN info = -5 ELSE IF( lda < MAX( 1, k ) ) THEN info = -7 ELSE IF( ldc < MAX( 1, m ) ) THEN info = -10 ELSE IF( lwork < MAX( 1, nw ) .AND. .NOT.lquery ) THEN info = -12 END IF ! IF( info == 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, 'SORMLQ', side // trans, m, n, k, -1 ) ) lwkopt = MAX( 1, nw )*nb work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SORMLQ', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 .OR. k == 0 ) THEN work( 1 ) = 1 RETURN END IF ! nbmin = 2 ldwork = nw IF( nb > 1 .AND. nb < k ) THEN iws = nw*nb IF( lwork < iws ) THEN nb = lwork / ldwork nbmin = MAX( 2, ilaenv( 2, 'SORMLQ', side // trans, m, n, k, -1 ) ) END IF ELSE iws = nw END IF ! IF( nb < nbmin .OR. nb >= k ) THEN ! ! Use unblocked code ! CALL sorml2( 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 = 'T' ELSE transt = 'N' END IF ! DO 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 slarft( '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 slarfb( side, transt, 'Forward', 'Rowwise', mi, ni, ib, & a( i, i ), lda, t, ldt, c( ic, jc ), ldc, work, ldwork ) END DO END IF work( 1 ) = lwkopt RETURN ! ! End of SORMLQ ! END SUBROUTINE sormlq SUBROUTINE sormql( 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 (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORMQL 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 SGEQLF. 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) REAL 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 ! SGEQLF 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SGEQLF. ! ! C (input/output) REAL 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) REAL 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, PARAMETER :: nbmax = 64 INTEGER, PARAMETER :: 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 .. REAL :: t( ldt, nbmax ) ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL lsame, ilaenv ! .. ! .. External Subroutines .. EXTERNAL slarfb, slarft, sorm2l, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 left = lsame( side, 'L' ) notran = lsame( trans, 'N' ) lquery = ( lwork == -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 < 0 ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( k < 0 .OR. k > nq ) THEN info = -5 ELSE IF( lda < MAX( 1, nq ) ) THEN info = -7 ELSE IF( ldc < MAX( 1, m ) ) THEN info = -10 ELSE IF( lwork < MAX( 1, nw ) .AND. .NOT.lquery ) THEN info = -12 END IF ! IF( info == 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, 'SORMQL', side // trans, m, n, k, -1 ) ) lwkopt = MAX( 1, nw )*nb work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SORMQL', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 .OR. k == 0 ) THEN work( 1 ) = 1 RETURN END IF ! nbmin = 2 ldwork = nw IF( nb > 1 .AND. nb < k ) THEN iws = nw*nb IF( lwork < iws ) THEN nb = lwork / ldwork nbmin = MAX( 2, ilaenv( 2, 'SORMQL', side // trans, m, n, k, -1 ) ) END IF ELSE iws = nw END IF ! IF( nb < nbmin .OR. nb >= k ) THEN ! ! Use unblocked code ! CALL sorm2l( 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 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 slarft( '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 slarfb( side, trans, 'Backward', 'Columnwise', mi, ni, & ib, a( 1, i ), lda, t, ldt, c, ldc, work, ldwork ) END DO END IF work( 1 ) = lwkopt RETURN ! ! End of SORMQL ! END SUBROUTINE sormql SUBROUTINE sormqr( 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 (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORMQR 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 SGEQRF. 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) REAL 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 ! SGEQRF 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SGEQRF. ! ! C (input/output) REAL 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) REAL 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, PARAMETER :: nbmax = 64 INTEGER, PARAMETER :: 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 .. REAL :: t( ldt, nbmax ) ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL lsame, ilaenv ! .. ! .. External Subroutines .. EXTERNAL slarfb, slarft, sorm2r, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 left = lsame( side, 'L' ) notran = lsame( trans, 'N' ) lquery = ( lwork == -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 < 0 ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( k < 0 .OR. k > nq ) THEN info = -5 ELSE IF( lda < MAX( 1, nq ) ) THEN info = -7 ELSE IF( ldc < MAX( 1, m ) ) THEN info = -10 ELSE IF( lwork < MAX( 1, nw ) .AND. .NOT.lquery ) THEN info = -12 END IF ! IF( info == 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, 'SORMQR', side // trans, m, n, k, -1 ) ) lwkopt = MAX( 1, nw )*nb work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SORMQR', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 .OR. k == 0 ) THEN work( 1 ) = 1 RETURN END IF ! nbmin = 2 ldwork = nw IF( nb > 1 .AND. nb < k ) THEN iws = nw*nb IF( lwork < iws ) THEN nb = lwork / ldwork nbmin = MAX( 2, ilaenv( 2, 'SORMQR', side // trans, m, n, k, -1 ) ) END IF ELSE iws = nw END IF ! IF( nb < nbmin .OR. nb >= k ) THEN ! ! Use unblocked code ! CALL sorm2r( 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 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 slarft( '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 slarfb( side, trans, 'Forward', 'Columnwise', mi, ni, & ib, a( i, i ), lda, t, ldt, c( ic, jc ), ldc, work, ldwork ) END DO END IF work( 1 ) = lwkopt RETURN ! ! End of SORMQR ! END SUBROUTINE sormqr SUBROUTINE sormr2( 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 (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: k REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORMR2 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 SGERQF. 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) REAL 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 ! SGERQF in the last 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SGERQF. ! ! C (input/output) REAL 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) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: left, notran INTEGER :: i, i1, i2, i3, mi, ni, nq REAL :: aii ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL slarf, 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 < 0 ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( k < 0 .OR. k > nq ) THEN info = -5 ELSE IF( lda < MAX( 1, k ) ) THEN info = -7 ELSE IF( ldc < MAX( 1, m ) ) THEN info = -10 END IF IF( info /= 0 ) THEN CALL xerbla( 'SORMR2', -info ) RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 .OR. k == 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 ELSE mi = m END IF ! DO 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( i, nq-k+i ) a( i, nq-k+i ) = one CALL slarf( side, mi, ni, a( i, 1 ), lda, tau( i ), c, ldc, work ) a( i, nq-k+i ) = aii END DO RETURN ! ! End of SORMR2 ! END SUBROUTINE sormr2 SUBROUTINE sormr3( side, trans, m, n, k, l, 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 ! June 30, 1999 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k INTEGER, INTENT(IN) :: l REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORMR3 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 STZRZF. 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. ! ! L (input) INTEGER ! The number of columns of the matrix A containing ! the meaningful part of the Householder reflectors. ! If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. ! ! A (input) REAL 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 ! STZRZF in the last 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by STZRZF. ! ! C (input/output) REAL 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) REAL 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 ! ! Further Details ! =============== ! ! Based on contributions by ! A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA ! ! ===================================================================== ! ! .. Local Scalars .. LOGICAL :: left, notran INTEGER :: i, i1, i2, i3, ic, ja, jc, mi, ni, nq ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL slarz, 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 < 0 ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( k < 0 .OR. k > nq ) THEN info = -5 ELSE IF( l < 0 .OR. ( left .AND. ( l > m ) ) .OR. & ( .NOT.left .AND. ( l > n ) ) ) THEN info = -6 ELSE IF( lda < MAX( 1, k ) ) THEN info = -8 ELSE IF( ldc < MAX( 1, m ) ) THEN info = -11 END IF IF( info /= 0 ) THEN CALL xerbla( 'SORMR3', -info ) RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 .OR. k == 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 ja = m - l + 1 jc = 1 ELSE mi = m ja = n - l + 1 ic = 1 END IF ! DO 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)' ! CALL slarz( side, mi, ni, l, a( i, ja ), lda, tau( i ), & c( ic, jc ), ldc, work ) ! END DO ! RETURN ! ! End of SORMR3 ! END SUBROUTINE sormr3 SUBROUTINE sormrq( 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 (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORMRQ 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 SGERQF. 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) REAL 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 ! SGERQF in the last 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by SGERQF. ! ! C (input/output) REAL 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) REAL 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, PARAMETER :: nbmax = 64 INTEGER, PARAMETER :: ldt = nbmax+1 ! .. ! .. Local Scalars .. LOGICAL :: left, lquery, notran CHARACTER (LEN=1) :: transt INTEGER :: i, i1, i2, i3, ib, iinfo, iws, ldwork, lwkopt, & mi, nb, nbmin, ni, nq, nw ! .. ! .. Local Arrays .. REAL :: t( ldt, nbmax ) ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL lsame, ilaenv ! .. ! .. External Subroutines .. EXTERNAL slarfb, slarft, sormr2, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 left = lsame( side, 'L' ) notran = lsame( trans, 'N' ) lquery = ( lwork == -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 < 0 ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( k < 0 .OR. k > nq ) THEN info = -5 ELSE IF( lda < MAX( 1, k ) ) THEN info = -7 ELSE IF( ldc < MAX( 1, m ) ) THEN info = -10 ELSE IF( lwork < MAX( 1, nw ) .AND. .NOT.lquery ) THEN info = -12 END IF ! IF( info == 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, 'SORMRQ', side // trans, m, n, k, -1 ) ) lwkopt = MAX( 1, nw )*nb work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SORMRQ', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 .OR. k == 0 ) THEN work( 1 ) = 1 RETURN END IF ! nbmin = 2 ldwork = nw IF( nb > 1 .AND. nb < k ) THEN iws = nw*nb IF( lwork < iws ) THEN nb = lwork / ldwork nbmin = MAX( 2, ilaenv( 2, 'SORMRQ', side // trans, m, n, k, -1 ) ) END IF ELSE iws = nw END IF ! IF( nb < nbmin .OR. nb >= k ) THEN ! ! Use unblocked code ! CALL sormr2( 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 ELSE mi = m END IF ! IF( notran ) THEN transt = 'T' ELSE transt = 'N' END IF ! DO 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 slarft( 'Backward', 'Rowwise', nq-k+i+ib-1, ib, & a( i, 1 ), 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 slarfb( side, transt, 'Backward', 'Rowwise', mi, ni, & ib, a( i, 1 ), lda, t, ldt, c, ldc, work, ldwork ) END DO END IF work( 1 ) = lwkopt RETURN ! ! End of SORMRQ ! END SUBROUTINE sormrq SUBROUTINE sormrz( side, trans, m, n, k, l, 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 (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: k INTEGER, INTENT(IN) :: l REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORMRZ 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 STZRZF. 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. ! ! L (input) INTEGER ! The number of columns of the matrix A containing ! the meaningful part of the Householder reflectors. ! If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. ! ! A (input) REAL 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 ! STZRZF in the last 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) REAL array, dimension (K) ! TAU(i) must contain the scalar factor of the elementary ! reflector H(i), as returned by STZRZF. ! ! C (input/output) REAL 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) REAL 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 ! ! Further Details ! =============== ! ! Based on contributions by ! A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: nbmax = 64 INTEGER, PARAMETER :: ldt = nbmax+1 ! .. ! .. Local Scalars .. LOGICAL :: left, lquery, notran CHARACTER (LEN=1) :: transt INTEGER :: i, i1, i2, i3, ib, ic, iinfo, iws, ja, jc, & ldwork, lwkopt, mi, nb, nbmin, ni, nq, nw ! .. ! .. Local Arrays .. REAL :: t( ldt, nbmax ) ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL lsame, ilaenv ! .. ! .. External Subroutines .. EXTERNAL slarzb, slarzt, sormr3, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 left = lsame( side, 'L' ) notran = lsame( trans, 'N' ) lquery = ( lwork == -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 < 0 ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( k < 0 .OR. k > nq ) THEN info = -5 ELSE IF( l < 0 .OR. ( left .AND. ( l > m ) ) .OR. & ( .NOT.left .AND. ( l > n ) ) ) THEN info = -6 ELSE IF( lda < MAX( 1, k ) ) THEN info = -8 ELSE IF( ldc < MAX( 1, m ) ) THEN info = -11 ELSE IF( lwork < MAX( 1, nw ) .AND. .NOT.lquery ) THEN info = -13 END IF ! IF( info == 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, 'SORMRQ', side // trans, m, n, k, -1 ) ) lwkopt = MAX( 1, nw )*nb work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SORMRZ', -info ) RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 .OR. k == 0 ) THEN work( 1 ) = 1 RETURN END IF ! nbmin = 2 ldwork = nw IF( nb > 1 .AND. nb < k ) THEN iws = nw*nb IF( lwork < iws ) THEN nb = lwork / ldwork nbmin = MAX( 2, ilaenv( 2, 'SORMRQ', side // trans, m, n, k, -1 ) ) END IF ELSE iws = nw END IF ! IF( nb < nbmin .OR. nb >= k ) THEN ! ! Use unblocked code ! CALL sormr3( side, trans, m, n, k, l, 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 ja = m - l + 1 ELSE mi = m ic = 1 ja = n - l + 1 END IF ! IF( notran ) THEN transt = 'T' ELSE transt = 'N' END IF ! DO 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 slarzt( 'Backward', 'Rowwise', l, ib, a( i, ja ), 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 slarzb( side, transt, 'Backward', 'Rowwise', mi, ni, & ib, l, a( i, ja ), lda, t, ldt, c( ic, jc ), ldc, work, ldwork ) END DO ! END IF ! work( 1 ) = lwkopt ! RETURN ! ! End of SORMRZ ! END SUBROUTINE sormrz SUBROUTINE sormtr( 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 (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SORMTR 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 SSYTRD: ! ! 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 SSYTRD; ! = 'L': Lower triangle of A contains elementary reflectors ! from SSYTRD. ! ! 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) REAL array, dimension ! (LDA,M) if SIDE = 'L' ! (LDA,N) if SIDE = 'R' ! The vectors which define the elementary reflectors, as ! returned by SSYTRD. ! ! 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) REAL 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 SSYTRD. ! ! C (input/output) REAL 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) REAL 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, ni, nb, nq, nw ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL ilaenv, lsame ! .. ! .. External Subroutines .. EXTERNAL sormql, sormqr, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 left = lsame( side, 'L' ) upper = lsame( uplo, 'U' ) lquery = ( lwork == -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 < 0 ) THEN info = -4 ELSE IF( n < 0 ) THEN info = -5 ELSE IF( lda < MAX( 1, nq ) ) THEN info = -7 ELSE IF( ldc < MAX( 1, m ) ) THEN info = -10 ELSE IF( lwork < MAX( 1, nw ) .AND. .NOT.lquery ) THEN info = -12 END IF ! IF( info == 0 ) THEN IF( upper ) THEN IF( left ) THEN nb = ilaenv( 1, 'SORMQL', side // trans, m-1, n, m-1, -1 ) ELSE nb = ilaenv( 1, 'SORMQL', side // trans, m, n-1, n-1, -1 ) END IF ELSE IF( left ) THEN nb = ilaenv( 1, 'SORMQR', side // trans, m-1, n, m-1, -1 ) ELSE nb = ilaenv( 1, 'SORMQR', side // trans, m, n-1, n-1, -1 ) END IF END IF lwkopt = MAX( 1, nw )*nb work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SORMTR', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 .OR. nq == 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 SSYTRD with UPLO = 'U' ! CALL sormql( side, trans, mi, ni, nq-1, a( 1, 2 ), lda, tau, c, & ldc, work, lwork, iinfo ) ELSE ! ! Q was determined by a call to SSYTRD with UPLO = 'L' ! IF( left ) THEN i1 = 2 i2 = 1 ELSE i1 = 1 i2 = 2 END IF CALL sormqr( 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 SORMTR ! END SUBROUTINE sormtr SUBROUTINE spbcon( uplo, n, kd, ab, ldab, anorm, rcond, 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 ! September 30, 1994 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: kd REAL, INTENT(IN OUT) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(IN) :: anorm REAL, INTENT(OUT) :: rcond REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPBCON estimates the reciprocal of the condition number (in the ! 1-norm) of a real symmetric positive definite band matrix using the ! Cholesky factorization A = U**T*U or A = L*L**T computed by SPBTRF. ! ! An estimate is obtained for norm(inv(A)), and the reciprocal of the ! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! = 'U': Upper triangular factor stored in AB; ! = 'L': Lower triangular factor stored in AB. ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! KD (input) INTEGER ! The number of superdiagonals of the matrix A if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KD >= 0. ! ! AB (input) REAL array, dimension (LDAB,N) ! The triangular factor U or L from the Cholesky factorization ! A = U**T*U or A = L*L**T of the band matrix A, stored in the ! first KD+1 rows of the array. The j-th column of U or L is ! stored in the j-th column of the array AB as follows: ! if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; ! if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KD+1. ! ! ANORM (input) REAL ! The 1-norm (or infinity-norm) of the symmetric band matrix A. ! ! RCOND (output) REAL ! The reciprocal of the condition number of the matrix A, ! computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an ! estimate of the 1-norm of inv(A) computed in this routine. ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper CHARACTER (LEN=1) :: normin INTEGER :: ix, kase REAL :: ainvnm, scale, scalel, scaleu, smlnum ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: isamax REAL :: slamch EXTERNAL lsame, isamax, slamch ! .. ! .. External Subroutines .. EXTERNAL slacon, slatbs, srscl, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS ! .. ! .. 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 < 0 ) THEN info = -2 ELSE IF( kd < 0 ) THEN info = -3 ELSE IF( ldab < kd+1 ) THEN info = -5 ELSE IF( anorm < zero ) THEN info = -6 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPBCON', -info ) RETURN END IF ! ! Quick return if possible ! rcond = zero IF( n == 0 ) THEN rcond = one RETURN ELSE IF( anorm == zero ) THEN RETURN END IF ! smlnum = slamch( 'Safe minimum' ) ! ! Estimate the 1-norm of the inverse. ! kase = 0 normin = 'N' 10 CONTINUE CALL slacon( n, work( n+1 ), work, iwork, ainvnm, kase ) IF( kase /= 0 ) THEN IF( upper ) THEN ! ! Multiply by inv(U'). ! CALL slatbs( 'Upper', 'Transpose', 'Non-unit', normin, n, & kd, ab, ldab, work, scalel, work( 2*n+1 ), info ) normin = 'Y' ! ! Multiply by inv(U). ! CALL slatbs( 'Upper', 'No transpose', 'Non-unit', normin, n, & kd, ab, ldab, work, scaleu, work( 2*n+1 ), info ) ELSE ! ! Multiply by inv(L). ! CALL slatbs( 'Lower', 'No transpose', 'Non-unit', normin, n, & kd, ab, ldab, work, scalel, work( 2*n+1 ), info ) normin = 'Y' ! ! Multiply by inv(L'). ! CALL slatbs( 'Lower', 'Transpose', 'Non-unit', normin, n, & kd, ab, ldab, work, scaleu, work( 2*n+1 ), info ) END IF ! ! Multiply by 1/SCALE if doing so will not cause overflow. ! scale = scalel*scaleu IF( scale /= one ) THEN ix = isamax( n, work, 1 ) IF( scale < ABS( work( ix ) )*smlnum .OR. scale == zero ) GO TO 20 CALL srscl( n, scale, work, 1 ) END IF GO TO 10 END IF ! ! Compute the estimate of the reciprocal condition number. ! IF( ainvnm /= zero ) rcond = ( one / ainvnm ) / anorm ! 20 CONTINUE ! RETURN ! ! End of SPBCON ! END SUBROUTINE spbcon SUBROUTINE spbequ( uplo, n, kd, ab, ldab, s, scond, amax, 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: kd REAL, INTENT(IN) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(OUT) :: s( * ) REAL, INTENT(OUT) :: scond REAL, INTENT(OUT) :: amax INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPBEQU computes row and column scalings intended to equilibrate a ! symmetric positive definite band matrix A and reduce its condition ! number (with respect to the two-norm). S contains the scale factors, ! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with ! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This ! choice of S puts the condition number of B within a factor N of the ! smallest possible condition number over all possible diagonal ! scalings. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! = 'U': Upper triangular of A is stored; ! = 'L': Lower triangular of A is stored. ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! KD (input) INTEGER ! The number of superdiagonals of the matrix A if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KD >= 0. ! ! AB (input) REAL array, dimension (LDAB,N) ! The upper or lower triangle of the symmetric band matrix A, ! stored in the first KD+1 rows of the array. The j-th column ! of A is stored in the j-th column of the array AB as follows: ! if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). ! ! LDAB (input) INTEGER ! The leading dimension of the array A. LDAB >= KD+1. ! ! S (output) REAL array, dimension (N) ! If INFO = 0, S contains the scale factors for A. ! ! SCOND (output) REAL ! If INFO = 0, S contains the ratio of the smallest S(i) to ! the largest S(i). If SCOND >= 0.1 and AMAX is neither too ! large nor too small, it is not worth scaling by S. ! ! AMAX (output) REAL ! Absolute value of largest matrix element. If AMAX is very ! close to overflow or very close to underflow, the matrix ! should be scaled. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if INFO = i, the i-th diagonal element is nonpositive. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: i, j REAL :: smin ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, 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 < 0 ) THEN info = -2 ELSE IF( kd < 0 ) THEN info = -3 ELSE IF( ldab < kd+1 ) THEN info = -5 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPBEQU', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) THEN scond = one amax = zero RETURN END IF ! IF( upper ) THEN j = kd + 1 ELSE j = 1 END IF ! ! Initialize SMIN and AMAX. ! s( 1 ) = ab( j, 1 ) smin = s( 1 ) amax = s( 1 ) ! ! Find the minimum and maximum diagonal elements. ! DO i = 2, n s( i ) = ab( j, i ) smin = MIN( smin, s( i ) ) amax = MAX( amax, s( i ) ) END DO ! IF( smin <= zero ) THEN ! ! Find the first non-positive diagonal element and return. ! DO i = 1, n IF( s( i ) <= zero ) THEN info = i RETURN END IF END DO ELSE ! ! Set the scale factors to the reciprocals ! of the diagonal elements. ! DO i = 1, n s( i ) = one / SQRT( s( i ) ) END DO ! ! Compute SCOND = min(S(I)) / max(S(I)) ! scond = SQRT( smin ) / SQRT( amax ) END IF RETURN ! ! End of SPBEQU ! END SUBROUTINE spbequ SUBROUTINE spbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, & ldb, x, ldx, ferr, berr, 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 ! September 30, 1994 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: kd INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(IN OUT) :: afb( ldafb, * ) INTEGER, INTENT(IN OUT) :: ldafb REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: ferr( * ) REAL, INTENT(OUT) :: berr( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPBRFS improves the computed solution to a system of linear ! equations when the coefficient matrix is symmetric positive definite ! and banded, and provides error bounds and backward error estimates ! for the solution. ! ! 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. ! ! KD (input) INTEGER ! The number of superdiagonals of the matrix A if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KD >= 0. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of columns ! of the matrices B and X. NRHS >= 0. ! ! AB (input) REAL array, dimension (LDAB,N) ! The upper or lower triangle of the symmetric band matrix A, ! stored in the first KD+1 rows of the array. The j-th column ! of A is stored in the j-th column of the array AB as follows: ! if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KD+1. ! ! AFB (input) REAL array, dimension (LDAFB,N) ! The triangular factor U or L from the Cholesky factorization ! A = U**T*U or A = L*L**T of the band matrix A as computed by ! SPBTRF, in the same storage format as A (see AB). ! ! LDAFB (input) INTEGER ! The leading dimension of the array AFB. LDAFB >= KD+1. ! ! B (input) REAL array, dimension (LDB,NRHS) ! The right hand side matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (input/output) REAL array, dimension (LDX,NRHS) ! On entry, the solution matrix X, as computed by SPBTRS. ! On exit, the improved solution matrix X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! Internal Parameters ! =================== ! ! ITMAX is the maximum number of steps of iterative refinement. ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: itmax = 5 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 REAL, PARAMETER :: three = 3.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: count, i, j, k, kase, l, nz REAL :: eps, lstres, s, safe1, safe2, safmin, xk ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, slacon, spbtrs, ssbmv, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. 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 < 0 ) THEN info = -2 ELSE IF( kd < 0 ) THEN info = -3 ELSE IF( nrhs < 0 ) THEN info = -4 ELSE IF( ldab < kd+1 ) THEN info = -6 ELSE IF( ldafb < kd+1 ) THEN info = -8 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -10 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -12 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPBRFS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) THEN DO j = 1, nrhs ferr( j ) = zero berr( j ) = zero END DO RETURN END IF ! ! NZ = maximum number of nonzero elements in each row of A, plus 1 ! nz = MIN( n+1, 2*kd+2 ) eps = slamch( 'Epsilon' ) safmin = slamch( 'Safe minimum' ) safe1 = nz*safmin safe2 = safe1 / eps ! ! Do for each right hand side ! DO j = 1, nrhs ! count = 1 lstres = three 20 CONTINUE ! ! Loop until stopping criterion is satisfied. ! ! Compute residual R = B - A * X ! CALL scopy( n, b( 1, j ), 1, work( n+1 ), 1 ) CALL ssbmv( uplo, n, kd, -one, ab, ldab, x( 1, j ), 1, one, work( n+1 ), 1 ) ! ! Compute componentwise relative backward error from formula ! ! max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) ! ! where abs(Z) is the componentwise absolute value of the matrix ! or vector Z. If the i-th component of the denominator is less ! than SAFE2, then SAFE1 is added to the i-th components of the ! numerator and denominator before dividing. ! DO i = 1, n work( i ) = ABS( b( i, j ) ) END DO ! ! Compute abs(A)*abs(X) + abs(B). ! IF( upper ) THEN DO k = 1, n s = zero xk = ABS( x( k, j ) ) l = kd + 1 - k DO i = MAX( 1, k-kd ), k - 1 work( i ) = work( i ) + ABS( ab( l+i, k ) )*xk s = s + ABS( ab( l+i, k ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + ABS( ab( kd+1, k ) )*xk + s END DO ELSE DO k = 1, n s = zero xk = ABS( x( k, j ) ) work( k ) = work( k ) + ABS( ab( 1, k ) )*xk l = 1 - k DO i = k + 1, MIN( n, k+kd ) work( i ) = work( i ) + ABS( ab( l+i, k ) )*xk s = s + ABS( ab( l+i, k ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + s END DO END IF s = zero DO i = 1, n IF( work( i ) > safe2 ) THEN s = MAX( s, ABS( work( n+i ) ) / work( i ) ) ELSE s = MAX( s, ( ABS( work( n+i ) )+safe1 ) / ( work( i )+safe1 ) ) END IF END DO berr( j ) = s ! ! Test stopping criterion. Continue iterating if ! 1) The residual BERR(J) is larger than machine epsilon, and ! 2) BERR(J) decreased by at least a factor of 2 during the ! last iteration, and ! 3) At most ITMAX iterations tried. ! IF( berr( j ) > eps .AND. two*berr( j ) <= lstres .AND. & count <= itmax ) THEN ! ! Update solution and try again. ! CALL spbtrs( uplo, n, kd, 1, afb, ldafb, work( n+1 ), n, info ) CALL saxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 GO TO 20 END IF ! ! Bound error from formula ! ! norm(X - XTRUE) / norm(X) .le. FERR = ! norm( abs(inv(A))* ! ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) ! ! where ! norm(Z) is the magnitude of the largest component of Z ! inv(A) is the inverse of A ! abs(Z) is the componentwise absolute value of the matrix or ! vector Z ! NZ is the maximum number of nonzeros in any row of A, plus 1 ! EPS is machine epsilon ! ! The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) ! is incremented by SAFE1 if the i-th component of ! abs(A)*abs(X) + abs(B) is less than SAFE2. ! ! Use SLACON to estimate the infinity-norm of the matrix ! inv(A) * diag(W), ! where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) ! DO i = 1, n IF( work( i ) > safe2 ) THEN work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) ELSE work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) + safe1 END IF END DO ! kase = 0 100 CONTINUE CALL slacon( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ), kase ) IF( kase /= 0 ) THEN IF( kase == 1 ) THEN ! ! Multiply by diag(W)*inv(A'). ! CALL spbtrs( uplo, n, kd, 1, afb, ldafb, work( n+1 ), n, info ) DO i = 1, n work( n+i ) = work( n+i )*work( i ) END DO ELSE IF( kase == 2 ) THEN ! ! Multiply by inv(A)*diag(W). ! DO i = 1, n work( n+i ) = work( n+i )*work( i ) END DO CALL spbtrs( uplo, n, kd, 1, afb, ldafb, work( n+1 ), n, info ) END IF GO TO 100 END IF ! ! Normalize error. ! lstres = zero DO i = 1, n lstres = MAX( lstres, ABS( x( i, j ) ) ) END DO IF( lstres /= zero ) ferr( j ) = ferr( j ) / lstres ! END DO ! RETURN ! ! End of SPBRFS ! END SUBROUTINE spbrfs SUBROUTINE spbstf( uplo, n, kd, ab, ldab, 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: kd REAL, INTENT(IN OUT) :: ab( ldab, * ) INTEGER, INTENT(IN) :: ldab INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPBSTF computes a split Cholesky factorization of a real ! symmetric positive definite band matrix A. ! ! This routine is designed to be used in conjunction with SSBGST. ! ! The factorization has the form A = S**T*S where S is a band matrix ! of the same bandwidth as A and the following structure: ! ! S = ( U ) ! ( M L ) ! ! where U is upper triangular of order m = (n+kd)/2, and L is lower ! triangular of order n-m. ! ! 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. ! ! KD (input) INTEGER ! The number of superdiagonals of the matrix A if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KD >= 0. ! ! AB (input/output) REAL array, dimension (LDAB,N) ! On entry, the upper or lower triangle of the symmetric band ! matrix A, stored in the first kd+1 rows of the array. The ! j-th column of A is stored in the j-th column of the array AB ! as follows: ! if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). ! ! On exit, if INFO = 0, the factor S from the split Cholesky ! factorization A = S**T*S. See Further Details. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KD+1. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! > 0: if INFO = i, the factorization could not be completed, ! because the updated element a(i,i) was negative; the ! matrix A is not positive definite. ! ! Further Details ! =============== ! ! The band storage scheme is illustrated by the following example, when ! N = 7, KD = 2: ! ! S = ( s11 s12 s13 ) ! ( s22 s23 s24 ) ! ( s33 s34 ) ! ( s44 ) ! ( s53 s54 s55 ) ! ( s64 s65 s66 ) ! ( s75 s76 s77 ) ! ! If UPLO = 'U', the array AB holds: ! ! on entry: on exit: ! ! * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75 ! * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76 ! a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 ! ! If UPLO = 'L', the array AB holds: ! ! on entry: on exit: ! ! a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77 ! a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 * ! a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * * ! ! Array elements marked * are not used by the routine. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: j, kld, km, m REAL :: ajj ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL sscal, ssyr, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, 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 < 0 ) THEN info = -2 ELSE IF( kd < 0 ) THEN info = -3 ELSE IF( ldab < kd+1 ) THEN info = -5 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPBSTF', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! kld = MAX( 1, ldab-1 ) ! ! Set the splitting point m. ! m = ( n+kd ) / 2 ! IF( upper ) THEN ! ! Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). ! DO j = n, m + 1, -1 ! ! Compute s(j,j) and test for non-positive-definiteness. ! ajj = ab( kd+1, j ) IF( ajj <= zero ) GO TO 50 ajj = SQRT( ajj ) ab( kd+1, j ) = ajj km = MIN( j-1, kd ) ! ! Compute elements j-km:j-1 of the j-th column and update the ! the leading submatrix within the band. ! CALL sscal( km, one / ajj, ab( kd+1-km, j ), 1 ) CALL ssyr( 'Upper', km, -one, ab( kd+1-km, j ), 1, ab( kd+1, j-km ), kld ) END DO ! ! Factorize the updated submatrix A(1:m,1:m) as U**T*U. ! DO j = 1, m ! ! Compute s(j,j) and test for non-positive-definiteness. ! ajj = ab( kd+1, j ) IF( ajj <= zero ) GO TO 50 ajj = SQRT( ajj ) ab( kd+1, j ) = ajj km = MIN( kd, m-j ) ! ! Compute elements j+1:j+km of the j-th row and update the ! trailing submatrix within the band. ! IF( km > 0 ) THEN CALL sscal( km, one / ajj, ab( kd, j+1 ), kld ) CALL ssyr( 'Upper', km, -one, ab( kd, j+1 ), kld, ab( kd+1, j+1 ), kld ) END IF END DO ELSE ! ! Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m). ! DO j = n, m + 1, -1 ! ! Compute s(j,j) and test for non-positive-definiteness. ! ajj = ab( 1, j ) IF( ajj <= zero ) GO TO 50 ajj = SQRT( ajj ) ab( 1, j ) = ajj km = MIN( j-1, kd ) ! ! Compute elements j-km:j-1 of the j-th row and update the ! trailing submatrix within the band. ! CALL sscal( km, one / ajj, ab( km+1, j-km ), kld ) CALL ssyr( 'Lower', km, -one, ab( km+1, j-km ), kld, ab( 1, j-km ), kld ) END DO ! ! Factorize the updated submatrix A(1:m,1:m) as U**T*U. ! DO j = 1, m ! ! Compute s(j,j) and test for non-positive-definiteness. ! ajj = ab( 1, j ) IF( ajj <= zero ) GO TO 50 ajj = SQRT( ajj ) ab( 1, j ) = ajj km = MIN( kd, m-j ) ! ! Compute elements j+1:j+km of the j-th column and update the ! trailing submatrix within the band. ! IF( km > 0 ) THEN CALL sscal( km, one / ajj, ab( 2, j ), 1 ) CALL ssyr( 'Lower', km, -one, ab( 2, j ), 1, ab( 1, j+1 ), kld ) END IF END DO END IF RETURN ! 50 CONTINUE info = j RETURN ! ! End of SPBSTF ! END SUBROUTINE spbstf SUBROUTINE spbsv( uplo, n, kd, nrhs, ab, ldab, 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 .. CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN OUT) :: kd INTEGER, INTENT(IN OUT) :: nrhs REAL, INTENT(IN OUT) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPBSV computes the solution to a real system of linear equations ! A * X = B, ! where A is an N-by-N symmetric positive definite band matrix and X ! and B are N-by-NRHS matrices. ! ! The Cholesky decomposition is used to factor A as ! A = U**T * U, if UPLO = 'U', or ! A = L * L**T, if UPLO = 'L', ! where U is an upper triangular band matrix, and L is a lower ! triangular band matrix, with the same number of superdiagonals or ! subdiagonals as A. The factored form of A is then used to solve the ! system of equations A * X = B. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! = 'U': Upper triangle of A is stored; ! = 'L': Lower triangle of A is stored. ! ! N (input) INTEGER ! The number of linear equations, i.e., the order of the ! matrix A. N >= 0. ! ! KD (input) INTEGER ! The number of superdiagonals of the matrix A if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KD >= 0. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of columns ! of the matrix B. NRHS >= 0. ! ! AB (input/output) REAL array, dimension (LDAB,N) ! On entry, the upper or lower triangle of the symmetric band ! matrix A, stored in the first KD+1 rows of the array. The ! j-th column of A is stored in the j-th column of the array AB ! as follows: ! if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). ! See below for further details. ! ! On exit, if INFO = 0, the triangular factor U or L from the ! Cholesky factorization A = U**T*U or A = L*L**T of the band ! matrix A, in the same storage format as A. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KD+1. ! ! B (input/output) REAL 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 of A is not ! positive definite, so the factorization could not be ! completed, and the solution has not been computed. ! ! Further Details ! =============== ! ! The band storage scheme is illustrated by the following example, when ! N = 6, KD = 2, and UPLO = 'U': ! ! On entry: On exit: ! ! * * a13 a24 a35 a46 * * u13 u24 u35 u46 ! * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 ! a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 ! ! Similarly, if UPLO = 'L' the format of A is as follows: ! ! On entry: On exit: ! ! a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 ! a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * ! a31 a42 a53 a64 * * l31 l42 l53 l64 * * ! ! Array elements marked * are not used by the routine. ! ! ===================================================================== ! ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL spbtrf, spbtrs, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( kd < 0 ) THEN info = -3 ELSE IF( nrhs < 0 ) THEN info = -4 ELSE IF( ldab < kd+1 ) THEN info = -6 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -8 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPBSV ', -info ) RETURN END IF ! ! Compute the Cholesky factorization A = U'*U or A = L*L'. ! CALL spbtrf( uplo, n, kd, ab, ldab, info ) IF( info == 0 ) THEN ! ! Solve the system A*X = B, overwriting B with X. ! CALL spbtrs( uplo, n, kd, nrhs, ab, ldab, b, ldb, info ) ! END IF RETURN ! ! End of SPBSV ! END SUBROUTINE spbsv SUBROUTINE spbsvx( fact, uplo, n, kd, nrhs, ab, ldab, afb, ldafb, & equed, s, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, 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 (LEN=1), INTENT(IN) :: fact CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: kd INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: ab( ldab, * ) INTEGER, INTENT(IN) :: ldab REAL, INTENT(IN OUT) :: afb( ldafb, * ) INTEGER, INTENT(IN OUT) :: ldafb CHARACTER (LEN=1), INTENT(OUT) :: equed REAL, INTENT(IN) :: s( * ) REAL, INTENT(OUT) :: b( ldb, * ) INTEGER, INTENT(IN) :: ldb REAL, INTENT(OUT) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: rcond REAL, INTENT(OUT) :: ferr( * ) REAL, INTENT(IN OUT) :: berr( * ) REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to ! compute the solution to a real system of linear equations ! A * X = B, ! where A is an N-by-N symmetric positive definite band matrix and X ! and B are N-by-NRHS matrices. ! ! Error bounds on the solution and a condition estimate are also ! provided. ! ! Description ! =========== ! ! The following steps are performed: ! ! 1. If FACT = 'E', real scaling factors are computed to equilibrate ! the system: ! diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B ! Whether or not the system will be equilibrated depends on the ! scaling of the matrix A, but if equilibration is used, A is ! overwritten by diag(S)*A*diag(S) and B by diag(S)*B. ! ! 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to ! factor the matrix A (after equilibration if FACT = 'E') as ! A = U**T * U, if UPLO = 'U', or ! A = L * L**T, if UPLO = 'L', ! where U is an upper triangular band matrix, and L is a lower ! triangular band matrix. ! ! 3. If the leading i-by-i principal minor is not positive definite, ! then the routine returns with INFO = i. Otherwise, the factored ! form of A is used to estimate the condition number of the matrix ! A. If the reciprocal of the condition number is less than machine ! precision, INFO = N+1 is returned as a warning, but the routine ! still goes on to solve for X and compute error bounds as ! described below. ! ! 4. The system of equations is solved for X using the factored form ! of A. ! ! 5. Iterative refinement is applied to improve the computed solution ! matrix and calculate error bounds and backward error estimates ! for it. ! ! 6. If equilibration was used, the matrix X is premultiplied by ! diag(S) so that it solves the original system before ! equilibration. ! ! Arguments ! ========= ! ! FACT (input) CHARACTER*1 ! Specifies whether or not the factored form of the matrix A is ! supplied on entry, and if not, whether the matrix A should be ! equilibrated before it is factored. ! = 'F': On entry, AFB contains the factored form of A. ! If EQUED = 'Y', the matrix A has been equilibrated ! with scaling factors given by S. AB and AFB will not ! be modified. ! = 'N': The matrix A will be copied to AFB and factored. ! = 'E': The matrix A will be equilibrated if necessary, then ! copied to AFB and factored. ! ! UPLO (input) CHARACTER*1 ! = 'U': Upper triangle of A is stored; ! = 'L': Lower triangle of A is stored. ! ! N (input) INTEGER ! The number of linear equations, i.e., the order of the ! matrix A. N >= 0. ! ! KD (input) INTEGER ! The number of superdiagonals of the matrix A if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KD >= 0. ! ! NRHS (input) INTEGER ! The number of right-hand sides, i.e., the number of columns ! of the matrices B and X. NRHS >= 0. ! ! AB (input/output) REAL array, dimension (LDAB,N) ! On entry, the upper or lower triangle of the symmetric band ! matrix A, stored in the first KD+1 rows of the array, except ! if FACT = 'F' and EQUED = 'Y', then A must contain the ! equilibrated matrix diag(S)*A*diag(S). The j-th column of A ! is stored in the j-th column of the array AB as follows: ! if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD). ! See below for further details. ! ! On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by ! diag(S)*A*diag(S). ! ! LDAB (input) INTEGER ! The leading dimension of the array A. LDAB >= KD+1. ! ! AFB (input or output) REAL array, dimension (LDAFB,N) ! If FACT = 'F', then AFB is an input argument and on entry ! contains the triangular factor U or L from the Cholesky ! factorization A = U**T*U or A = L*L**T of the band matrix ! A, in the same storage format as A (see AB). If EQUED = 'Y', ! then AFB is the factored form of the equilibrated matrix A. ! ! If FACT = 'N', then AFB is an output argument and on exit ! returns the triangular factor U or L from the Cholesky ! factorization A = U**T*U or A = L*L**T. ! ! If FACT = 'E', then AFB is an output argument and on exit ! returns the triangular factor U or L from the Cholesky ! factorization A = U**T*U or A = L*L**T of the equilibrated ! matrix A (see the description of A for the form of the ! equilibrated matrix). ! ! LDAFB (input) INTEGER ! The leading dimension of the array AFB. LDAFB >= KD+1. ! ! EQUED (input or output) CHARACTER*1 ! Specifies the form of equilibration that was done. ! = 'N': No equilibration (always true if FACT = 'N'). ! = 'Y': Equilibration was done, i.e., A has been replaced by ! diag(S) * A * diag(S). ! EQUED is an input argument if FACT = 'F'; otherwise, it is an ! output argument. ! ! S (input or output) REAL array, dimension (N) ! The scale factors for A; not accessed if EQUED = 'N'. S is ! an input argument if FACT = 'F'; otherwise, S is an output ! argument. If FACT = 'F' and EQUED = 'Y', each element of S ! must be positive. ! ! B (input/output) REAL array, dimension (LDB,NRHS) ! On entry, the N-by-NRHS right hand side matrix B. ! On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', ! B is overwritten by diag(S) * B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (output) REAL array, dimension (LDX,NRHS) ! If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to ! the original system of equations. Note that if EQUED = 'Y', ! A and B are modified on exit, and the solution to the ! equilibrated system is inv(diag(S))*X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! RCOND (output) REAL ! The estimate of the reciprocal condition number of the matrix ! A after equilibration (if done). If RCOND is less than the ! machine precision (in particular, if RCOND = 0), the matrix ! is singular to working precision. This condition is ! indicated by a return code of INFO > 0. ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER 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, and i is ! <= N: the leading minor of order i of A is ! not positive definite, so the factorization ! could not be completed, and the solution has not ! been computed. RCOND = 0 is returned. ! = N+1: U is nonsingular, but RCOND is less than machine ! precision, meaning that the matrix is singular ! to working precision. Nevertheless, the ! solution and error bounds are computed because ! there are a number of situations where the ! computed solution can be more accurate than the ! value of RCOND would suggest. ! ! Further Details ! =============== ! ! The band storage scheme is illustrated by the following example, when ! N = 6, KD = 2, and UPLO = 'U': ! ! Two-dimensional storage of the symmetric matrix A: ! ! a11 a12 a13 ! a22 a23 a24 ! a33 a34 a35 ! a44 a45 a46 ! a55 a56 ! (aij=conjg(aji)) a66 ! ! Band storage of the upper triangle of A: ! ! * * a13 a24 a35 a46 ! * a12 a23 a34 a45 a56 ! a11 a22 a33 a44 a55 a66 ! ! Similarly, if UPLO = 'L' the format of A is as follows: ! ! a11 a22 a33 a44 a55 a66 ! a21 a32 a43 a54 a65 * ! a31 a42 a53 a64 * * ! ! Array elements marked * are not used by the routine. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: equil, nofact, rcequ, upper INTEGER :: i, infequ, j, j1, j2 REAL :: amax, anorm, bignum, scond, smax, smin, smlnum ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slansb EXTERNAL lsame, slamch, slansb ! .. ! .. External Subroutines .. EXTERNAL scopy, slacpy, slaqsb, spbcon, spbequ, spbrfs, & spbtrf, spbtrs, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! info = 0 nofact = lsame( fact, 'N' ) equil = lsame( fact, 'E' ) upper = lsame( uplo, 'U' ) IF( nofact .OR. equil ) THEN equed = 'N' rcequ = .false. ELSE rcequ = lsame( equed, 'Y' ) smlnum = slamch( 'Safe minimum' ) bignum = one / smlnum END IF ! ! Test the input parameters. ! IF( .NOT.nofact .AND. .NOT.equil .AND. .NOT.lsame( fact, 'F' ) ) THEN info = -1 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( kd < 0 ) THEN info = -4 ELSE IF( nrhs < 0 ) THEN info = -5 ELSE IF( ldab < kd+1 ) THEN info = -7 ELSE IF( ldafb < kd+1 ) THEN info = -9 ELSE IF( lsame( fact, 'F' ) .AND. .NOT. & ( rcequ .OR. lsame( equed, 'N' ) ) ) THEN info = -10 ELSE IF( rcequ ) THEN smin = bignum smax = zero DO j = 1, n smin = MIN( smin, s( j ) ) smax = MAX( smax, s( j ) ) END DO IF( smin <= zero ) THEN info = -11 ELSE IF( n > 0 ) THEN scond = MAX( smin, smlnum ) / MIN( smax, bignum ) ELSE scond = one END IF END IF IF( info == 0 ) THEN IF( ldb < MAX( 1, n ) ) THEN info = -13 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -15 END IF END IF END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SPBSVX', -info ) RETURN END IF ! IF( equil ) THEN ! ! Compute row and column scalings to equilibrate the matrix A. ! CALL spbequ( uplo, n, kd, ab, ldab, s, scond, amax, infequ ) IF( infequ == 0 ) THEN ! ! Equilibrate the matrix. ! CALL slaqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed ) rcequ = lsame( equed, 'Y' ) END IF END IF ! ! Scale the right-hand side. ! IF( rcequ ) THEN DO j = 1, nrhs DO i = 1, n b( i, j ) = s( i )*b( i, j ) END DO END DO END IF ! IF( nofact .OR. equil ) THEN ! ! Compute the Cholesky factorization A = U'*U or A = L*L'. ! IF( upper ) THEN DO j = 1, n j1 = MAX( j-kd, 1 ) CALL scopy( j-j1+1, ab( kd+1-j+j1, j ), 1, afb( kd+1-j+j1, j ), 1 ) END DO ELSE DO j = 1, n j2 = MIN( j+kd, n ) CALL scopy( j2-j+1, ab( 1, j ), 1, afb( 1, j ), 1 ) END DO END IF ! CALL spbtrf( uplo, n, kd, afb, ldafb, info ) ! ! Return if INFO is non-zero. ! IF( info /= 0 ) THEN IF( info > 0 ) rcond = zero RETURN END IF END IF ! ! Compute the norm of the matrix A. ! anorm = slansb( '1', uplo, n, kd, ab, ldab, work ) ! ! Compute the reciprocal of the condition number of A. ! CALL spbcon( uplo, n, kd, afb, ldafb, anorm, rcond, work, iwork, info ) ! ! Set INFO = N+1 if the matrix is singular to working precision. ! IF( rcond < slamch( 'Epsilon' ) ) info = n + 1 ! ! Compute the solution matrix X. ! CALL slacpy( 'Full', n, nrhs, b, ldb, x, ldx ) CALL spbtrs( uplo, n, kd, nrhs, afb, ldafb, x, ldx, info ) ! ! Use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. ! CALL spbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x, & ldx, ferr, berr, work, iwork, info ) ! ! Transform the solution matrix X to a solution of the original ! system. ! IF( rcequ ) THEN DO j = 1, nrhs DO i = 1, n x( i, j ) = s( i )*x( i, j ) END DO END DO DO j = 1, nrhs ferr( j ) = ferr( j ) / scond END DO END IF ! RETURN ! ! End of SPBSVX ! END SUBROUTINE spbsvx SUBROUTINE spbtf2( uplo, n, kd, ab, ldab, 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: kd REAL, INTENT(IN OUT) :: ab( ldab, * ) INTEGER, INTENT(IN) :: ldab INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPBTF2 computes the Cholesky factorization of a real symmetric ! positive definite band 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, U' is the transpose of U, 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. ! ! KD (input) INTEGER ! The number of super-diagonals of the matrix A if UPLO = 'U', ! or the number of sub-diagonals if UPLO = 'L'. KD >= 0. ! ! AB (input/output) REAL array, dimension (LDAB,N) ! On entry, the upper or lower triangle of the symmetric band ! matrix A, stored in the first KD+1 rows of the array. The ! j-th column of A is stored in the j-th column of the array AB ! as follows: ! if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). ! ! On exit, if INFO = 0, the triangular factor U or L from the ! Cholesky factorization A = U'*U or A = L*L' of the band ! matrix A, in the same storage format as A. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KD+1. ! ! 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. ! ! Further Details ! =============== ! ! The band storage scheme is illustrated by the following example, when ! N = 6, KD = 2, and UPLO = 'U': ! ! On entry: On exit: ! ! * * a13 a24 a35 a46 * * u13 u24 u35 u46 ! * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 ! a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 ! ! Similarly, if UPLO = 'L' the format of A is as follows: ! ! On entry: On exit: ! ! a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 ! a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * ! a31 a42 a53 a64 * * l31 l42 l53 l64 * * ! ! Array elements marked * are not used by the routine. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: j, kld, kn REAL :: ajj ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL sscal, ssyr, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, 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 < 0 ) THEN info = -2 ELSE IF( kd < 0 ) THEN info = -3 ELSE IF( ldab < kd+1 ) THEN info = -5 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPBTF2', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! kld = MAX( 1, ldab-1 ) ! IF( upper ) THEN ! ! Compute the Cholesky factorization A = U'*U. ! DO j = 1, n ! ! Compute U(J,J) and test for non-positive-definiteness. ! ajj = ab( kd+1, j ) IF( ajj <= zero ) GO TO 30 ajj = SQRT( ajj ) ab( kd+1, j ) = ajj ! ! Compute elements J+1:J+KN of row J and update the ! trailing submatrix within the band. ! kn = MIN( kd, n-j ) IF( kn > 0 ) THEN CALL sscal( kn, one / ajj, ab( kd, j+1 ), kld ) CALL ssyr( 'Upper', kn, -one, ab( kd, j+1 ), kld, ab( kd+1, j+1 ), kld ) END IF END DO ELSE ! ! Compute the Cholesky factorization A = L*L'. ! DO j = 1, n ! ! Compute L(J,J) and test for non-positive-definiteness. ! ajj = ab( 1, j ) IF( ajj <= zero ) GO TO 30 ajj = SQRT( ajj ) ab( 1, j ) = ajj ! ! Compute elements J+1:J+KN of column J and update the ! trailing submatrix within the band. ! kn = MIN( kd, n-j ) IF( kn > 0 ) THEN CALL sscal( kn, one / ajj, ab( 2, j ), 1 ) CALL ssyr( 'Lower', kn, -one, ab( 2, j ), 1, ab( 1, j+1 ), kld ) END IF END DO END IF RETURN ! 30 CONTINUE info = j RETURN ! ! End of SPBTF2 ! END SUBROUTINE spbtf2 SUBROUTINE spbtrf( uplo, n, kd, ab, ldab, 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: kd REAL, INTENT(IN OUT) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPBTRF computes the Cholesky factorization of a real symmetric ! positive definite band 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. ! ! 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. ! ! KD (input) INTEGER ! The number of superdiagonals of the matrix A if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KD >= 0. ! ! AB (input/output) REAL array, dimension (LDAB,N) ! On entry, the upper or lower triangle of the symmetric band ! matrix A, stored in the first KD+1 rows of the array. The ! j-th column of A is stored in the j-th column of the array AB ! as follows: ! if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). ! ! On exit, if INFO = 0, the triangular factor U or L from the ! Cholesky factorization A = U**T*U or A = L*L**T of the band ! matrix A, in the same storage format as A. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KD+1. ! ! 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. ! ! Further Details ! =============== ! ! The band storage scheme is illustrated by the following example, when ! N = 6, KD = 2, and UPLO = 'U': ! ! On entry: On exit: ! ! * * a13 a24 a35 a46 * * u13 u24 u35 u46 ! * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 ! a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 ! ! Similarly, if UPLO = 'L' the format of A is as follows: ! ! On entry: On exit: ! ! a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66 ! a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 * ! a31 a42 a53 a64 * * l31 l42 l53 l64 * * ! ! Array elements marked * are not used by the routine. ! ! Contributed by ! Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989 ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 INTEGER, PARAMETER :: nbmax = 32 INTEGER, PARAMETER :: ldwork = nbmax+1 ! .. ! .. Local Scalars .. INTEGER :: i, i2, i3, ib, ii, j, jj, nb ! .. ! .. Local Arrays .. REAL :: work( ldwork, nbmax ) ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL lsame, ilaenv ! .. ! .. External Subroutines .. EXTERNAL sgemm, spbtf2, spotf2, ssyrk, strsm, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 IF( ( .NOT.lsame( uplo, 'U' ) ) .AND. ( .NOT.lsame( uplo, 'L' ) ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( kd < 0 ) THEN info = -3 ELSE IF( ldab < kd+1 ) THEN info = -5 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPBTRF', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Determine the block size for this environment ! nb = ilaenv( 1, 'SPBTRF', uplo, n, kd, -1, -1 ) ! ! The block size must not exceed the semi-bandwidth KD, and must not ! exceed the limit set by the size of the local array WORK. ! nb = MIN( nb, nbmax ) ! IF( nb <= 1 .OR. nb > kd ) THEN ! ! Use unblocked code ! CALL spbtf2( uplo, n, kd, ab, ldab, info ) ELSE ! ! Use blocked code ! IF( lsame( uplo, 'U' ) ) THEN ! ! Compute the Cholesky factorization of a symmetric band ! matrix, given the upper triangle of the matrix in band ! storage. ! ! Zero the upper triangle of the work array. ! DO j = 1, nb DO i = 1, j - 1 work( i, j ) = zero END DO END DO ! ! Process the band matrix one diagonal block at a time. ! DO i = 1, n, nb ib = MIN( nb, n-i+1 ) ! ! Factorize the diagonal block ! CALL spotf2( uplo, ib, ab( kd+1, i ), ldab-1, ii ) IF( ii /= 0 ) THEN info = i + ii - 1 GO TO 150 END IF IF( i+ib <= n ) THEN ! ! Update the relevant part of the trailing submatrix. ! If A11 denotes the diagonal block which has just been ! factorized, then we need to update the remaining ! blocks in the diagram: ! ! A11 A12 A13 ! A22 A23 ! A33 ! ! The numbers of rows and columns in the partitioning ! are IB, I2, I3 respectively. The blocks A12, A22 and ! A23 are empty if IB = KD. The upper triangle of A13 ! lies outside the band. ! i2 = MIN( kd-ib, n-i-ib+1 ) i3 = MIN( ib, n-i-kd+1 ) ! IF( i2 > 0 ) THEN ! ! Update A12 ! CALL strsm( 'Left', 'Upper', 'Transpose', & 'Non-unit', ib, i2, one, ab( kd+1, i ), & ldab-1, ab( kd+1-ib, i+ib ), ldab-1 ) ! ! Update A22 ! CALL ssyrk( 'Upper', 'Transpose', i2, ib, -one, & ab( kd+1-ib, i+ib ), ldab-1, one, ab( kd+1, i+ib ), ldab-1 ) END IF ! IF( i3 > 0 ) THEN ! ! Copy the lower triangle of A13 into the work array. ! DO jj = 1, i3 DO ii = jj, ib work( ii, jj ) = ab( ii-jj+1, jj+i+kd-1 ) END DO END DO ! ! Update A13 (in the work array). ! CALL strsm( 'Left', 'Upper', 'Transpose', & 'Non-unit', ib, i3, one, ab( kd+1, i ), ldab-1, work, ldwork ) ! ! Update A23 ! IF( i2 > 0 ) CALL sgemm( 'Transpose', 'No Transpose', i2, i3, & ib, -one, ab( kd+1-ib, i+ib ), ldab-1, work, ldwork, one, & ab( 1+ib, i+kd ), ldab-1 ) ! ! Update A33 ! CALL ssyrk( 'Upper', 'Transpose', i3, ib, -one, & work, ldwork, one, ab( kd+1, i+kd ), ldab-1 ) ! ! Copy the lower triangle of A13 back into place. ! DO jj = 1, i3 DO ii = jj, ib ab( ii-jj+1, jj+i+kd-1 ) = work( ii, jj ) END DO END DO END IF END IF END DO ELSE ! ! Compute the Cholesky factorization of a symmetric band ! matrix, given the lower triangle of the matrix in band ! storage. ! ! Zero the lower triangle of the work array. ! DO j = 1, nb DO i = j + 1, nb work( i, j ) = zero END DO END DO ! ! Process the band matrix one diagonal block at a time. ! DO i = 1, n, nb ib = MIN( nb, n-i+1 ) ! ! Factorize the diagonal block ! CALL spotf2( uplo, ib, ab( 1, i ), ldab-1, ii ) IF( ii /= 0 ) THEN info = i + ii - 1 GO TO 150 END IF IF( i+ib <= n ) THEN ! ! Update the relevant part of the trailing submatrix. ! If A11 denotes the diagonal block which has just been ! factorized, then we need to update the remaining ! blocks in the diagram: ! ! A11 ! A21 A22 ! A31 A32 A33 ! ! The numbers of rows and columns in the partitioning ! are IB, I2, I3 respectively. The blocks A21, A22 and ! A32 are empty if IB = KD. The lower triangle of A31 ! lies outside the band. ! i2 = MIN( kd-ib, n-i-ib+1 ) i3 = MIN( ib, n-i-kd+1 ) ! IF( i2 > 0 ) THEN ! ! Update A21 ! CALL strsm( 'Right', 'Lower', 'Transpose', & 'Non-unit', i2, ib, one, ab( 1, i ), ldab-1, ab( 1+ib, i ), ldab-1 ) ! ! Update A22 ! CALL ssyrk( 'Lower', 'No Transpose', i2, ib, -one, & ab( 1+ib, i ), ldab-1, one, ab( 1, i+ib ), ldab-1 ) END IF ! IF( i3 > 0 ) THEN ! ! Copy the upper triangle of A31 into the work array. ! DO jj = 1, ib DO ii = 1, MIN( jj, i3 ) work( ii, jj ) = ab( kd+1-jj+ii, jj+i-1 ) END DO END DO ! ! Update A31 (in the work array). ! CALL strsm( 'Right', 'Lower', 'Transpose', & 'Non-unit', i3, ib, one, ab( 1, i ), ldab-1, work, ldwork ) ! ! Update A32 ! IF( i2 > 0 ) CALL sgemm( 'No transpose', 'Transpose', i3, i2, & ib, -one, work, ldwork, ab( 1+ib, i ), ldab-1, one, & ab( 1+kd-ib, i+ib ), ldab-1 ) ! ! Update A33 ! CALL ssyrk( 'Lower', 'No Transpose', i3, ib, -one, & work, ldwork, one, ab( 1, i+kd ), ldab-1 ) ! ! Copy the upper triangle of A31 back into place. ! DO jj = 1, ib DO ii = 1, MIN( jj, i3 ) ab( kd+1-jj+ii, jj+i-1 ) = work( ii, jj ) END DO END DO END IF END IF END DO END IF END IF RETURN ! 150 CONTINUE RETURN ! ! End of SPBTRF ! END SUBROUTINE spbtrf SUBROUTINE spbtrs( uplo, n, kd, nrhs, ab, ldab, 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: kd INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN OUT) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPBTRS solves a system of linear equations A*X = B with a symmetric ! positive definite band matrix A using the Cholesky factorization ! A = U**T*U or A = L*L**T computed by SPBTRF. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! = 'U': Upper triangular factor stored in AB; ! = 'L': Lower triangular factor stored in AB. ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! KD (input) INTEGER ! The number of superdiagonals of the matrix A if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KD >= 0. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of columns ! of the matrix B. NRHS >= 0. ! ! AB (input) REAL array, dimension (LDAB,N) ! The triangular factor U or L from the Cholesky factorization ! A = U**T*U or A = L*L**T of the band matrix A, stored in the ! first KD+1 rows of the array. The j-th column of U or L is ! stored in the j-th column of the array AB as follows: ! if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j; ! if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd). ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KD+1. ! ! B (input/output) REAL 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 ! ! ===================================================================== ! ! .. Local Scalars .. LOGICAL :: upper INTEGER :: j ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL stbsv, 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 < 0 ) THEN info = -2 ELSE IF( kd < 0 ) THEN info = -3 ELSE IF( nrhs < 0 ) THEN info = -4 ELSE IF( ldab < kd+1 ) THEN info = -6 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -8 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPBTRS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) RETURN ! IF( upper ) THEN ! ! Solve A*X = B where A = U'*U. ! DO j = 1, nrhs ! ! Solve U'*X = B, overwriting B with X. ! CALL stbsv( 'Upper', 'Transpose', 'Non-unit', n, kd, ab, & ldab, b( 1, j ), 1 ) ! ! Solve U*X = B, overwriting B with X. ! CALL stbsv( 'Upper', 'No transpose', 'Non-unit', n, kd, ab, & ldab, b( 1, j ), 1 ) END DO ELSE ! ! Solve A*X = B where A = L*L'. ! DO j = 1, nrhs ! ! Solve L*X = B, overwriting B with X. ! CALL stbsv( 'Lower', 'No transpose', 'Non-unit', n, kd, ab, & ldab, b( 1, j ), 1 ) ! ! Solve L'*X = B, overwriting B with X. ! CALL stbsv( 'Lower', 'Transpose', 'Non-unit', n, kd, ab, & ldab, b( 1, j ), 1 ) END DO END IF ! RETURN ! ! End of SPBTRS ! END SUBROUTINE spbtrs SUBROUTINE spocon( uplo, n, a, lda, anorm, rcond, 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 ! March 31, 1993 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: anorm REAL, INTENT(OUT) :: rcond REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPOCON estimates the reciprocal of the condition number (in the ! 1-norm) of a real symmetric positive definite matrix using the ! Cholesky factorization A = U**T*U or A = L*L**T computed by SPOTRF. ! ! An estimate is obtained for norm(inv(A)), and the reciprocal of the ! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! ! 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) REAL 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 SPOTRF. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! ANORM (input) REAL ! The 1-norm (or infinity-norm) of the symmetric matrix A. ! ! RCOND (output) REAL ! The reciprocal of the condition number of the matrix A, ! computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an ! estimate of the 1-norm of inv(A) computed in this routine. ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper CHARACTER (LEN=1) :: normin INTEGER :: ix, kase REAL :: ainvnm, scale, scalel, scaleu, smlnum ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: isamax REAL :: slamch EXTERNAL lsame, isamax, slamch ! .. ! .. External Subroutines .. EXTERNAL slacon, slatrs, srscl, 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 < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, n ) ) THEN info = -4 ELSE IF( anorm < zero ) THEN info = -5 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPOCON', -info ) RETURN END IF ! ! Quick return if possible ! rcond = zero IF( n == 0 ) THEN rcond = one RETURN ELSE IF( anorm == zero ) THEN RETURN END IF ! smlnum = slamch( 'Safe minimum' ) ! ! Estimate the 1-norm of inv(A). ! kase = 0 normin = 'N' 10 CONTINUE CALL slacon( n, work( n+1 ), work, iwork, ainvnm, kase ) IF( kase /= 0 ) THEN IF( upper ) THEN ! ! Multiply by inv(U'). ! CALL slatrs( 'Upper', 'Transpose', 'Non-unit', normin, n, a, & lda, work, scalel, work( 2*n+1 ), info ) normin = 'Y' ! ! Multiply by inv(U). ! CALL slatrs( 'Upper', 'No transpose', 'Non-unit', normin, n, & a, lda, work, scaleu, work( 2*n+1 ), info ) ELSE ! ! Multiply by inv(L). ! CALL slatrs( 'Lower', 'No transpose', 'Non-unit', normin, n, & a, lda, work, scalel, work( 2*n+1 ), info ) normin = 'Y' ! ! Multiply by inv(L'). ! CALL slatrs( 'Lower', 'Transpose', 'Non-unit', normin, n, a, & lda, work, scaleu, work( 2*n+1 ), info ) END IF ! ! Multiply by 1/SCALE if doing so will not cause overflow. ! scale = scalel*scaleu IF( scale /= one ) THEN ix = isamax( n, work, 1 ) IF( scale < ABS( work( ix ) )*smlnum .OR. scale == zero ) GO TO 20 CALL srscl( n, scale, work, 1 ) END IF GO TO 10 END IF ! ! Compute the estimate of the reciprocal condition number. ! IF( ainvnm /= zero ) rcond = ( one / ainvnm ) / anorm ! 20 CONTINUE RETURN ! ! End of SPOCON ! END SUBROUTINE spocon SUBROUTINE spoequ( n, a, lda, s, scond, amax, 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, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: s( * ) REAL, INTENT(OUT) :: scond REAL, INTENT(OUT) :: amax INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPOEQU computes row and column scalings intended to equilibrate a ! symmetric positive definite matrix A and reduce its condition number ! (with respect to the two-norm). S contains the scale factors, ! S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with ! elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This ! choice of S puts the condition number of B within a factor N of the ! smallest possible condition number over all possible diagonal ! scalings. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! A (input) REAL array, dimension (LDA,N) ! The N-by-N symmetric positive definite matrix whose scaling ! factors are to be computed. Only the diagonal elements of A ! are referenced. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! S (output) REAL array, dimension (N) ! If INFO = 0, S contains the scale factors for A. ! ! SCOND (output) REAL ! If INFO = 0, S contains the ratio of the smallest S(i) to ! the largest S(i). If SCOND >= 0.1 and AMAX is neither too ! large nor too small, it is not worth scaling by S. ! ! AMAX (output) REAL ! Absolute value of largest matrix element. If AMAX is very ! close to overflow or very close to underflow, the matrix ! should be scaled. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! > 0: if INFO = i, the i-th diagonal element is nonpositive. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i REAL :: smin ! .. ! .. External Subroutines .. EXTERNAL xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 IF( n < 0 ) THEN info = -1 ELSE IF( lda < MAX( 1, n ) ) THEN info = -3 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPOEQU', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) THEN scond = one amax = zero RETURN END IF ! ! Find the minimum and maximum diagonal elements. ! s( 1 ) = a( 1, 1 ) smin = s( 1 ) amax = s( 1 ) DO i = 2, n s( i ) = a( i, i ) smin = MIN( smin, s( i ) ) amax = MAX( amax, s( i ) ) END DO ! IF( smin <= zero ) THEN ! ! Find the first non-positive diagonal element and return. ! DO i = 1, n IF( s( i ) <= zero ) THEN info = i RETURN END IF END DO ELSE ! ! Set the scale factors to the reciprocals ! of the diagonal elements. ! DO i = 1, n s( i ) = one / SQRT( s( i ) ) END DO ! ! Compute SCOND = min(S(I)) / max(S(I)) ! scond = SQRT( smin ) / SQRT( amax ) END IF RETURN ! ! End of SPOEQU ! END SUBROUTINE spoequ SUBROUTINE sporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, & ldx, ferr, berr, 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 ! September 30, 1994 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: af( ldaf, * ) INTEGER, INTENT(IN OUT) :: ldaf REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: ferr( * ) REAL, INTENT(OUT) :: berr( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPORFS improves the computed solution to a system of linear ! equations when the coefficient matrix is symmetric positive definite, ! and provides error bounds and backward error estimates for the ! solution. ! ! 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 matrices B and X. NRHS >= 0. ! ! A (input) REAL 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(1,N). ! ! AF (input) REAL array, dimension (LDAF,N) ! The triangular factor U or L from the Cholesky factorization ! A = U**T*U or A = L*L**T, as computed by SPOTRF. ! ! LDAF (input) INTEGER ! The leading dimension of the array AF. LDAF >= max(1,N). ! ! B (input) REAL array, dimension (LDB,NRHS) ! The right hand side matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (input/output) REAL array, dimension (LDX,NRHS) ! On entry, the solution matrix X, as computed by SPOTRS. ! On exit, the improved solution matrix X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! Internal Parameters ! =================== ! ! ITMAX is the maximum number of steps of iterative refinement. ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: itmax = 5 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 REAL, PARAMETER :: three = 3.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: count, i, j, k, kase, nz REAL :: eps, lstres, s, safe1, safe2, safmin, xk ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, slacon, spotrs, ssymv, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. 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 < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( ldaf < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -9 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -11 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPORFS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) THEN DO j = 1, nrhs ferr( j ) = zero berr( j ) = zero END DO RETURN END IF ! ! NZ = maximum number of nonzero elements in each row of A, plus 1 ! nz = n + 1 eps = slamch( 'Epsilon' ) safmin = slamch( 'Safe minimum' ) safe1 = nz*safmin safe2 = safe1 / eps ! ! Do for each right hand side ! DO j = 1, nrhs ! count = 1 lstres = three 20 CONTINUE ! ! Loop until stopping criterion is satisfied. ! ! Compute residual R = B - A * X ! CALL scopy( n, b( 1, j ), 1, work( n+1 ), 1 ) CALL ssymv( uplo, n, -one, a, lda, x( 1, j ), 1, one, work( n+1 ), 1 ) ! ! Compute componentwise relative backward error from formula ! ! max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) ! ! where abs(Z) is the componentwise absolute value of the matrix ! or vector Z. If the i-th component of the denominator is less ! than SAFE2, then SAFE1 is added to the i-th components of the ! numerator and denominator before dividing. ! DO i = 1, n work( i ) = ABS( b( i, j ) ) END DO ! ! Compute abs(A)*abs(X) + abs(B). ! IF( upper ) THEN DO k = 1, n s = zero xk = ABS( x( k, j ) ) DO i = 1, k - 1 work( i ) = work( i ) + ABS( a( i, k ) )*xk s = s + ABS( a( i, k ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + ABS( a( k, k ) )*xk + s END DO ELSE DO k = 1, n s = zero xk = ABS( x( k, j ) ) work( k ) = work( k ) + ABS( a( k, k ) )*xk DO i = k + 1, n work( i ) = work( i ) + ABS( a( i, k ) )*xk s = s + ABS( a( i, k ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + s END DO END IF s = zero DO i = 1, n IF( work( i ) > safe2 ) THEN s = MAX( s, ABS( work( n+i ) ) / work( i ) ) ELSE s = MAX( s, ( ABS( work( n+i ) )+safe1 ) / ( work( i )+safe1 ) ) END IF END DO berr( j ) = s ! ! Test stopping criterion. Continue iterating if ! 1) The residual BERR(J) is larger than machine epsilon, and ! 2) BERR(J) decreased by at least a factor of 2 during the ! last iteration, and ! 3) At most ITMAX iterations tried. ! IF( berr( j ) > eps .AND. two*berr( j ) <= lstres .AND. & count <= itmax ) THEN ! ! Update solution and try again. ! CALL spotrs( uplo, n, 1, af, ldaf, work( n+1 ), n, info ) CALL saxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 GO TO 20 END IF ! ! Bound error from formula ! ! norm(X - XTRUE) / norm(X) .le. FERR = ! norm( abs(inv(A))* ! ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) ! ! where ! norm(Z) is the magnitude of the largest component of Z ! inv(A) is the inverse of A ! abs(Z) is the componentwise absolute value of the matrix or ! vector Z ! NZ is the maximum number of nonzeros in any row of A, plus 1 ! EPS is machine epsilon ! ! The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) ! is incremented by SAFE1 if the i-th component of ! abs(A)*abs(X) + abs(B) is less than SAFE2. ! ! Use SLACON to estimate the infinity-norm of the matrix ! inv(A) * diag(W), ! where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) ! DO i = 1, n IF( work( i ) > safe2 ) THEN work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) ELSE work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) + safe1 END IF END DO ! kase = 0 100 CONTINUE CALL slacon( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ), kase ) IF( kase /= 0 ) THEN IF( kase == 1 ) THEN ! ! Multiply by diag(W)*inv(A'). ! CALL spotrs( uplo, n, 1, af, ldaf, work( n+1 ), n, info ) DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO ELSE IF( kase == 2 ) THEN ! ! Multiply by inv(A)*diag(W). ! DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO CALL spotrs( uplo, n, 1, af, ldaf, work( n+1 ), n, info ) END IF GO TO 100 END IF ! ! Normalize error. ! lstres = zero DO i = 1, n lstres = MAX( lstres, ABS( x( i, j ) ) ) END DO IF( lstres /= zero ) ferr( j ) = ferr( j ) / lstres ! END DO ! RETURN ! ! End of SPORFS ! END SUBROUTINE sporfs SUBROUTINE sposv( uplo, n, nrhs, a, lda, 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 .. CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN OUT) :: nrhs REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPOSV computes the solution to a real system of linear equations ! A * X = B, ! where A is an N-by-N symmetric positive definite matrix and X and B ! are N-by-NRHS matrices. ! ! The Cholesky decomposition is used to factor A as ! 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 a lower triangular ! matrix. The factored form of A is then used to solve the system of ! equations A * X = B. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! = 'U': Upper triangle of A is stored; ! = 'L': Lower triangle of A is stored. ! ! 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) REAL 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). ! ! B (input/output) REAL 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 of A is not ! positive definite, so the factorization could not be ! completed, and the solution has not been computed. ! ! ===================================================================== ! ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL spotrf, spotrs, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -7 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPOSV ', -info ) RETURN END IF ! ! Compute the Cholesky factorization A = U'*U or A = L*L'. ! CALL spotrf( uplo, n, a, lda, info ) IF( info == 0 ) THEN ! ! Solve the system A*X = B, overwriting B with X. ! CALL spotrs( uplo, n, nrhs, a, lda, b, ldb, info ) ! END IF RETURN ! ! End of SPOSV ! END SUBROUTINE sposv SUBROUTINE sposvx( fact, uplo, n, nrhs, a, lda, af, ldaf, equed, & s, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, 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 (LEN=1), INTENT(IN) :: fact CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN OUT) :: af( ldaf, * ) INTEGER, INTENT(IN OUT) :: ldaf CHARACTER (LEN=1), INTENT(OUT) :: equed REAL, INTENT(IN) :: s( * ) REAL, INTENT(OUT) :: b( ldb, * ) INTEGER, INTENT(IN) :: ldb REAL, INTENT(OUT) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: rcond REAL, INTENT(OUT) :: ferr( * ) REAL, INTENT(IN OUT) :: berr( * ) REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to ! compute the solution to a real system of linear equations ! A * X = B, ! where A is an N-by-N symmetric positive definite matrix and X and B ! are N-by-NRHS matrices. ! ! Error bounds on the solution and a condition estimate are also ! provided. ! ! Description ! =========== ! ! The following steps are performed: ! ! 1. If FACT = 'E', real scaling factors are computed to equilibrate ! the system: ! diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B ! Whether or not the system will be equilibrated depends on the ! scaling of the matrix A, but if equilibration is used, A is ! overwritten by diag(S)*A*diag(S) and B by diag(S)*B. ! ! 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to ! factor the matrix A (after equilibration if FACT = 'E') as ! 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 a lower triangular ! matrix. ! ! 3. If the leading i-by-i principal minor is not positive definite, ! then the routine returns with INFO = i. Otherwise, the factored ! form of A is used to estimate the condition number of the matrix ! A. If the reciprocal of the condition number is less than machine ! precision, INFO = N+1 is returned as a warning, but the routine ! still goes on to solve for X and compute error bounds as ! described below. ! ! 4. The system of equations is solved for X using the factored form ! of A. ! ! 5. Iterative refinement is applied to improve the computed solution ! matrix and calculate error bounds and backward error estimates ! for it. ! ! 6. If equilibration was used, the matrix X is premultiplied by ! diag(S) so that it solves the original system before ! equilibration. ! ! Arguments ! ========= ! ! FACT (input) CHARACTER*1 ! Specifies whether or not the factored form of the matrix A is ! supplied on entry, and if not, whether the matrix A should be ! equilibrated before it is factored. ! = 'F': On entry, AF contains the factored form of A. ! If EQUED = 'Y', the matrix A has been equilibrated ! with scaling factors given by S. A and AF will not ! be modified. ! = 'N': The matrix A will be copied to AF and factored. ! = 'E': The matrix A will be equilibrated if necessary, then ! copied to AF and factored. ! ! UPLO (input) CHARACTER*1 ! = 'U': Upper triangle of A is stored; ! = 'L': Lower triangle of A is stored. ! ! 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 matrices B and X. NRHS >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the symmetric matrix A, except if FACT = 'F' and ! EQUED = 'Y', then A must contain the equilibrated matrix ! diag(S)*A*diag(S). 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. A is not modified if ! FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. ! ! On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by ! diag(S)*A*diag(S). ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! AF (input or output) REAL array, dimension (LDAF,N) ! If FACT = 'F', then AF is an input argument and on entry ! contains the triangular factor U or L from the Cholesky ! factorization A = U**T*U or A = L*L**T, in the same storage ! format as A. If EQUED .ne. 'N', then AF is the factored form ! of the equilibrated matrix diag(S)*A*diag(S). ! ! If FACT = 'N', then AF is an output argument and on exit ! returns the triangular factor U or L from the Cholesky ! factorization A = U**T*U or A = L*L**T of the original ! matrix A. ! ! If FACT = 'E', then AF is an output argument and on exit ! returns the triangular factor U or L from the Cholesky ! factorization A = U**T*U or A = L*L**T of the equilibrated ! matrix A (see the description of A for the form of the ! equilibrated matrix). ! ! LDAF (input) INTEGER ! The leading dimension of the array AF. LDAF >= max(1,N). ! ! EQUED (input or output) CHARACTER*1 ! Specifies the form of equilibration that was done. ! = 'N': No equilibration (always true if FACT = 'N'). ! = 'Y': Equilibration was done, i.e., A has been replaced by ! diag(S) * A * diag(S). ! EQUED is an input argument if FACT = 'F'; otherwise, it is an ! output argument. ! ! S (input or output) REAL array, dimension (N) ! The scale factors for A; not accessed if EQUED = 'N'. S is ! an input argument if FACT = 'F'; otherwise, S is an output ! argument. If FACT = 'F' and EQUED = 'Y', each element of S ! must be positive. ! ! B (input/output) REAL array, dimension (LDB,NRHS) ! On entry, the N-by-NRHS right hand side matrix B. ! On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', ! B is overwritten by diag(S) * B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (output) REAL array, dimension (LDX,NRHS) ! If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to ! the original system of equations. Note that if EQUED = 'Y', ! A and B are modified on exit, and the solution to the ! equilibrated system is inv(diag(S))*X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! RCOND (output) REAL ! The estimate of the reciprocal condition number of the matrix ! A after equilibration (if done). If RCOND is less than the ! machine precision (in particular, if RCOND = 0), the matrix ! is singular to working precision. This condition is ! indicated by a return code of INFO > 0. ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER 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, and i is ! <= N: the leading minor of order i of A is ! not positive definite, so the factorization ! could not be completed, and the solution has not ! been computed. RCOND = 0 is returned. ! = N+1: U is nonsingular, but RCOND is less than machine ! precision, meaning that the matrix is singular ! to working precision. Nevertheless, the ! solution and error bounds are computed because ! there are a number of situations where the ! computed solution can be more accurate than the ! value of RCOND would suggest. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: equil, nofact, rcequ INTEGER :: i, infequ, j REAL :: amax, anorm, bignum, scond, smax, smin, smlnum ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slansy EXTERNAL lsame, slamch, slansy ! .. ! .. External Subroutines .. EXTERNAL slacpy, slaqsy, spocon, spoequ, sporfs, spotrf, & spotrs, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! info = 0 nofact = lsame( fact, 'N' ) equil = lsame( fact, 'E' ) IF( nofact .OR. equil ) THEN equed = 'N' rcequ = .false. ELSE rcequ = lsame( equed, 'Y' ) smlnum = slamch( 'Safe minimum' ) bignum = one / smlnum END IF ! ! Test the input parameters. ! IF( .NOT.nofact .AND. .NOT.equil .AND. .NOT.lsame( fact, 'F' ) ) THEN info = -1 ELSE IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) & THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( nrhs < 0 ) THEN info = -4 ELSE IF( lda < MAX( 1, n ) ) THEN info = -6 ELSE IF( ldaf < MAX( 1, n ) ) THEN info = -8 ELSE IF( lsame( fact, 'F' ) .AND. .NOT. & ( rcequ .OR. lsame( equed, 'N' ) ) ) THEN info = -9 ELSE IF( rcequ ) THEN smin = bignum smax = zero DO j = 1, n smin = MIN( smin, s( j ) ) smax = MAX( smax, s( j ) ) END DO IF( smin <= zero ) THEN info = -10 ELSE IF( n > 0 ) THEN scond = MAX( smin, smlnum ) / MIN( smax, bignum ) ELSE scond = one END IF END IF IF( info == 0 ) THEN IF( ldb < MAX( 1, n ) ) THEN info = -12 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -14 END IF END IF END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SPOSVX', -info ) RETURN END IF ! IF( equil ) THEN ! ! Compute row and column scalings to equilibrate the matrix A. ! CALL spoequ( n, a, lda, s, scond, amax, infequ ) IF( infequ == 0 ) THEN ! ! Equilibrate the matrix. ! CALL slaqsy( uplo, n, a, lda, s, scond, amax, equed ) rcequ = lsame( equed, 'Y' ) END IF END IF ! ! Scale the right hand side. ! IF( rcequ ) THEN DO j = 1, nrhs DO i = 1, n b( i, j ) = s( i )*b( i, j ) END DO END DO END IF ! IF( nofact .OR. equil ) THEN ! ! Compute the Cholesky factorization A = U'*U or A = L*L'. ! CALL slacpy( uplo, n, n, a, lda, af, ldaf ) CALL spotrf( uplo, n, af, ldaf, info ) ! ! Return if INFO is non-zero. ! IF( info /= 0 ) THEN IF( info > 0 ) rcond = zero RETURN END IF END IF ! ! Compute the norm of the matrix A. ! anorm = slansy( '1', uplo, n, a, lda, work ) ! ! Compute the reciprocal of the condition number of A. ! CALL spocon( uplo, n, af, ldaf, anorm, rcond, work, iwork, info ) ! ! Set INFO = N+1 if the matrix is singular to working precision. ! IF( rcond < slamch( 'Epsilon' ) ) info = n + 1 ! ! Compute the solution matrix X. ! CALL slacpy( 'Full', n, nrhs, b, ldb, x, ldx ) CALL spotrs( uplo, n, nrhs, af, ldaf, x, ldx, info ) ! ! Use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. ! CALL sporfs( uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx, & ferr, berr, work, iwork, info ) ! ! Transform the solution matrix X to a solution of the original ! system. ! IF( rcequ ) THEN DO j = 1, nrhs DO i = 1, n x( i, j ) = s( i )*x( i, j ) END DO END DO DO j = 1, nrhs ferr( j ) = ferr( j ) / scond END DO END IF ! RETURN ! ! End of SPOSVX ! END SUBROUTINE sposvx SUBROUTINE spotf2( 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN) :: lda INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPOTF2 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) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: j REAL :: ajj ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: sdot EXTERNAL lsame, sdot ! .. ! .. External Subroutines .. EXTERNAL sgemv, sscal, 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 < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, n ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPOTF2', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! IF( upper ) THEN ! ! Compute the Cholesky factorization A = U'*U. ! DO j = 1, n ! ! Compute U(J,J) and test for non-positive-definiteness. ! ajj = a( j, j ) - sdot( j-1, a( 1, j ), 1, a( 1, j ), 1 ) IF( ajj <= 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 < n ) THEN CALL sgemv( 'Transpose', j-1, n-j, -one, a( 1, j+1 ), & lda, a( 1, j ), 1, one, a( j, j+1 ), lda ) CALL sscal( n-j, one / ajj, a( j, j+1 ), lda ) END IF END DO ELSE ! ! Compute the Cholesky factorization A = L*L'. ! DO j = 1, n ! ! Compute L(J,J) and test for non-positive-definiteness. ! ajj = a( j, j ) - sdot( j-1, a( j, 1 ), lda, a( j, 1 ), lda ) IF( ajj <= 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 < n ) THEN CALL sgemv( 'No transpose', n-j, j-1, -one, a( j+1, 1 ), & lda, a( j, 1 ), lda, one, a( j+1, j ), 1 ) CALL sscal( n-j, one / ajj, a( j+1, j ), 1 ) END IF END DO END IF GO TO 40 ! 30 CONTINUE info = j ! 40 CONTINUE RETURN ! ! End of SPOTF2 ! END SUBROUTINE spotf2 SUBROUTINE spotrf( 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPOTRF 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) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: j, jb, nb ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL lsame, ilaenv ! .. ! .. External Subroutines .. EXTERNAL sgemm, spotf2, ssyrk, strsm, 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 < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, n ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPOTRF', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Determine the block size for this environment. ! nb = ilaenv( 1, 'SPOTRF', uplo, n, -1, -1, -1 ) IF( nb <= 1 .OR. nb >= n ) THEN ! ! Use unblocked code. ! CALL spotf2( uplo, n, a, lda, info ) ELSE ! ! Use blocked code. ! IF( upper ) THEN ! ! Compute the Cholesky factorization A = U'*U. ! DO j = 1, n, nb ! ! Update and factorize the current diagonal block and test ! for non-positive-definiteness. ! jb = MIN( nb, n-j+1 ) CALL ssyrk( 'Upper', 'Transpose', jb, j-1, -one, & a( 1, j ), lda, one, a( j, j ), lda ) CALL spotf2( 'Upper', jb, a( j, j ), lda, info ) IF( info /= 0 ) GO TO 30 IF( j+jb <= n ) THEN ! ! Compute the current block row. ! CALL sgemm( '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 strsm( 'Left', 'Upper', 'Transpose', 'Non-unit', & jb, n-j-jb+1, one, a( j, j ), lda, a( j, j+jb ), lda ) END IF END DO ! ELSE ! ! Compute the Cholesky factorization A = L*L'. ! DO j = 1, n, nb ! ! Update and factorize the current diagonal block and test ! for non-positive-definiteness. ! jb = MIN( nb, n-j+1 ) CALL ssyrk( 'Lower', 'No transpose', jb, j-1, -one, & a( j, 1 ), lda, one, a( j, j ), lda ) CALL spotf2( 'Lower', jb, a( j, j ), lda, info ) IF( info /= 0 ) GO TO 30 IF( j+jb <= n ) THEN ! ! Compute the current block column. ! CALL sgemm( '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 strsm( 'Right', 'Lower', 'Transpose', 'Non-unit', & n-j-jb+1, jb, one, a( j, j ), lda, a( j+jb, j ), lda ) END IF END DO END IF END IF GO TO 40 ! 30 CONTINUE info = info + j - 1 ! 40 CONTINUE RETURN ! ! End of SPOTRF ! END SUBROUTINE spotrf SUBROUTINE spotri( 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPOTRI computes the inverse of a real symmetric positive definite ! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T ! computed by SPOTRF. ! ! 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) REAL array, dimension (LDA,N) ! On entry, the triangular factor U or L from the Cholesky ! factorization A = U**T*U or A = L*L**T, as computed by ! SPOTRF. ! On exit, the upper or lower triangle of the (symmetric) ! inverse of A, overwriting the input factor U or L. ! ! 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 (i,i) element of the factor U or L is ! zero, and the inverse could not be computed. ! ! ===================================================================== ! ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL slauum, strtri, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, n ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPOTRI', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Invert the triangular Cholesky factor U or L. ! CALL strtri( uplo, 'Non-unit', n, a, lda, info ) IF( info > 0 ) RETURN ! ! Form inv(U)*inv(U)' or inv(L)'*inv(L). ! CALL slauum( uplo, n, a, lda, info ) ! RETURN ! ! End of SPOTRI ! END SUBROUTINE spotri SUBROUTINE spotrs( 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPOTRS 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 SPOTRF. ! ! 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) REAL 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 SPOTRF. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! B (input/output) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL strsm, 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 < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -7 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPOTRS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) RETURN ! IF( upper ) THEN ! ! Solve A*X = B where A = U'*U. ! ! Solve U'*X = B, overwriting B with X. ! CALL strsm( 'Left', 'Upper', 'Transpose', 'Non-unit', n, nrhs, & one, a, lda, b, ldb ) ! ! Solve U*X = B, overwriting B with X. ! CALL strsm( '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 strsm( 'Left', 'Lower', 'No transpose', 'Non-unit', n, & nrhs, one, a, lda, b, ldb ) ! ! Solve L'*X = B, overwriting B with X. ! CALL strsm( 'Left', 'Lower', 'Transpose', 'Non-unit', n, nrhs, & one, a, lda, b, ldb ) END IF ! RETURN ! ! End of SPOTRS ! END SUBROUTINE spotrs SUBROUTINE sppcon( uplo, n, ap, anorm, rcond, 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 ! March 31, 1993 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: ap( * ) REAL, INTENT(IN) :: anorm REAL, INTENT(OUT) :: rcond REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPPCON estimates the reciprocal of the condition number (in the ! 1-norm) of a real symmetric positive definite packed matrix using ! the Cholesky factorization A = U**T*U or A = L*L**T computed by ! SPPTRF. ! ! An estimate is obtained for norm(inv(A)), and the reciprocal of the ! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! ! 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) REAL array, dimension (N*(N+1)/2) ! The triangular factor U or L from the Cholesky factorization ! A = U**T*U or A = L*L**T, packed columnwise in a linear ! array. The j-th column of U or L is stored in the array AP ! as follows: ! if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; ! if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. ! ! ANORM (input) REAL ! The 1-norm (or infinity-norm) of the symmetric matrix A. ! ! RCOND (output) REAL ! The reciprocal of the condition number of the matrix A, ! computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an ! estimate of the 1-norm of inv(A) computed in this routine. ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper CHARACTER (LEN=1) :: normin INTEGER :: ix, kase REAL :: ainvnm, scale, scalel, scaleu, smlnum ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: isamax REAL :: slamch EXTERNAL lsame, isamax, slamch ! .. ! .. External Subroutines .. EXTERNAL slacon, slatps, srscl, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS ! .. ! .. 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 < 0 ) THEN info = -2 ELSE IF( anorm < zero ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPPCON', -info ) RETURN END IF ! ! Quick return if possible ! rcond = zero IF( n == 0 ) THEN rcond = one RETURN ELSE IF( anorm == zero ) THEN RETURN END IF ! smlnum = slamch( 'Safe minimum' ) ! ! Estimate the 1-norm of the inverse. ! kase = 0 normin = 'N' 10 CONTINUE CALL slacon( n, work( n+1 ), work, iwork, ainvnm, kase ) IF( kase /= 0 ) THEN IF( upper ) THEN ! ! Multiply by inv(U'). ! CALL slatps( 'Upper', 'Transpose', 'Non-unit', normin, n, & ap, work, scalel, work( 2*n+1 ), info ) normin = 'Y' ! ! Multiply by inv(U). ! CALL slatps( 'Upper', 'No transpose', 'Non-unit', normin, n, & ap, work, scaleu, work( 2*n+1 ), info ) ELSE ! ! Multiply by inv(L). ! CALL slatps( 'Lower', 'No transpose', 'Non-unit', normin, n, & ap, work, scalel, work( 2*n+1 ), info ) normin = 'Y' ! ! Multiply by inv(L'). ! CALL slatps( 'Lower', 'Transpose', 'Non-unit', normin, n, & ap, work, scaleu, work( 2*n+1 ), info ) END IF ! ! Multiply by 1/SCALE if doing so will not cause overflow. ! scale = scalel*scaleu IF( scale /= one ) THEN ix = isamax( n, work, 1 ) IF( scale < ABS( work( ix ) )*smlnum .OR. scale == zero ) GO TO 20 CALL srscl( n, scale, work, 1 ) END IF GO TO 10 END IF ! ! Compute the estimate of the reciprocal condition number. ! IF( ainvnm /= zero ) rcond = ( one / ainvnm ) / anorm ! 20 CONTINUE RETURN ! ! End of SPPCON ! END SUBROUTINE sppcon SUBROUTINE sppequ( uplo, n, ap, s, scond, amax, 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: ap( * ) REAL, INTENT(OUT) :: s( * ) REAL, INTENT(OUT) :: scond REAL, INTENT(OUT) :: amax INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPPEQU computes row and column scalings intended to equilibrate a ! symmetric positive definite matrix A in packed storage and reduce ! its condition number (with respect to the two-norm). S contains the ! scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix ! B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal. ! This choice of S puts the condition number of B within a factor N of ! the smallest possible condition number over all possible diagonal ! scalings. ! ! 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) REAL 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. ! ! S (output) REAL array, dimension (N) ! If INFO = 0, S contains the scale factors for A. ! ! SCOND (output) REAL ! If INFO = 0, S contains the ratio of the smallest S(i) to ! the largest S(i). If SCOND >= 0.1 and AMAX is neither too ! large nor too small, it is not worth scaling by S. ! ! AMAX (output) REAL ! Absolute value of largest matrix element. If AMAX is very ! close to overflow or very close to underflow, the matrix ! should be scaled. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! > 0: if INFO = i, the i-th diagonal element is nonpositive. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: i, jj REAL :: smin ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, 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 < 0 ) THEN info = -2 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPPEQU', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) THEN scond = one amax = zero RETURN END IF ! ! Initialize SMIN and AMAX. ! s( 1 ) = ap( 1 ) smin = s( 1 ) amax = s( 1 ) ! IF( upper ) THEN ! ! UPLO = 'U': Upper triangle of A is stored. ! Find the minimum and maximum diagonal elements. ! jj = 1 DO i = 2, n jj = jj + i s( i ) = ap( jj ) smin = MIN( smin, s( i ) ) amax = MAX( amax, s( i ) ) END DO ! ELSE ! ! UPLO = 'L': Lower triangle of A is stored. ! Find the minimum and maximum diagonal elements. ! jj = 1 DO i = 2, n jj = jj + n - i + 2 s( i ) = ap( jj ) smin = MIN( smin, s( i ) ) amax = MAX( amax, s( i ) ) END DO END IF ! IF( smin <= zero ) THEN ! ! Find the first non-positive diagonal element and return. ! DO i = 1, n IF( s( i ) <= zero ) THEN info = i RETURN END IF END DO ELSE ! ! Set the scale factors to the reciprocals ! of the diagonal elements. ! DO i = 1, n s( i ) = one / SQRT( s( i ) ) END DO ! ! Compute SCOND = min(S(I)) / max(S(I)) ! scond = SQRT( smin ) / SQRT( amax ) END IF RETURN ! ! End of SPPEQU ! END SUBROUTINE sppequ SUBROUTINE spprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, & berr, 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 ! September 30, 1994 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: ap( * ) REAL, INTENT(IN OUT) :: afp( * ) REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: ferr( * ) REAL, INTENT(OUT) :: berr( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPPRFS improves the computed solution to a system of linear ! equations when the coefficient matrix is symmetric positive definite ! and packed, and provides error bounds and backward error estimates ! for the solution. ! ! 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 matrices B and X. NRHS >= 0. ! ! AP (input) REAL 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. ! ! AFP (input) REAL array, dimension (N*(N+1)/2) ! The triangular factor U or L from the Cholesky factorization ! A = U**T*U or A = L*L**T, as computed by SPPTRF/CPPTRF, ! packed columnwise in a linear array in the same format as A ! (see AP). ! ! B (input) REAL array, dimension (LDB,NRHS) ! The right hand side matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (input/output) REAL array, dimension (LDX,NRHS) ! On entry, the solution matrix X, as computed by SPPTRS. ! On exit, the improved solution matrix X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! Internal Parameters ! =================== ! ! ITMAX is the maximum number of steps of iterative refinement. ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: itmax = 5 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 REAL, PARAMETER :: three = 3.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: count, i, ik, j, k, kase, kk, nz REAL :: eps, lstres, s, safe1, safe2, safmin, xk ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, slacon, spptrs, sspmv, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. 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 < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -9 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPPRFS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) THEN DO j = 1, nrhs ferr( j ) = zero berr( j ) = zero END DO RETURN END IF ! ! NZ = maximum number of nonzero elements in each row of A, plus 1 ! nz = n + 1 eps = slamch( 'Epsilon' ) safmin = slamch( 'Safe minimum' ) safe1 = nz*safmin safe2 = safe1 / eps ! ! Do for each right hand side ! DO j = 1, nrhs ! count = 1 lstres = three 20 CONTINUE ! ! Loop until stopping criterion is satisfied. ! ! Compute residual R = B - A * X ! CALL scopy( n, b( 1, j ), 1, work( n+1 ), 1 ) CALL sspmv( uplo, n, -one, ap, x( 1, j ), 1, one, work( n+1 ), 1 ) ! ! Compute componentwise relative backward error from formula ! ! max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) ! ! where abs(Z) is the componentwise absolute value of the matrix ! or vector Z. If the i-th component of the denominator is less ! than SAFE2, then SAFE1 is added to the i-th components of the ! numerator and denominator before dividing. ! DO i = 1, n work( i ) = ABS( b( i, j ) ) END DO ! ! Compute abs(A)*abs(X) + abs(B). ! kk = 1 IF( upper ) THEN DO k = 1, n s = zero xk = ABS( x( k, j ) ) ik = kk DO i = 1, k - 1 work( i ) = work( i ) + ABS( ap( ik ) )*xk s = s + ABS( ap( ik ) )*ABS( x( i, j ) ) ik = ik + 1 END DO work( k ) = work( k ) + ABS( ap( kk+k-1 ) )*xk + s kk = kk + k END DO ELSE DO k = 1, n s = zero xk = ABS( x( k, j ) ) work( k ) = work( k ) + ABS( ap( kk ) )*xk ik = kk + 1 DO i = k + 1, n work( i ) = work( i ) + ABS( ap( ik ) )*xk s = s + ABS( ap( ik ) )*ABS( x( i, j ) ) ik = ik + 1 END DO work( k ) = work( k ) + s kk = kk + ( n-k+1 ) END DO END IF s = zero DO i = 1, n IF( work( i ) > safe2 ) THEN s = MAX( s, ABS( work( n+i ) ) / work( i ) ) ELSE s = MAX( s, ( ABS( work( n+i ) )+safe1 ) / ( work( i )+safe1 ) ) END IF END DO berr( j ) = s ! ! Test stopping criterion. Continue iterating if ! 1) The residual BERR(J) is larger than machine epsilon, and ! 2) BERR(J) decreased by at least a factor of 2 during the ! last iteration, and ! 3) At most ITMAX iterations tried. ! IF( berr( j ) > eps .AND. two*berr( j ) <= lstres .AND. & count <= itmax ) THEN ! ! Update solution and try again. ! CALL spptrs( uplo, n, 1, afp, work( n+1 ), n, info ) CALL saxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 GO TO 20 END IF ! ! Bound error from formula ! ! norm(X - XTRUE) / norm(X) .le. FERR = ! norm( abs(inv(A))* ! ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) ! ! where ! norm(Z) is the magnitude of the largest component of Z ! inv(A) is the inverse of A ! abs(Z) is the componentwise absolute value of the matrix or ! vector Z ! NZ is the maximum number of nonzeros in any row of A, plus 1 ! EPS is machine epsilon ! ! The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) ! is incremented by SAFE1 if the i-th component of ! abs(A)*abs(X) + abs(B) is less than SAFE2. ! ! Use SLACON to estimate the infinity-norm of the matrix ! inv(A) * diag(W), ! where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) ! DO i = 1, n IF( work( i ) > safe2 ) THEN work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) ELSE work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) + safe1 END IF END DO ! kase = 0 100 CONTINUE CALL slacon( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ), kase ) IF( kase /= 0 ) THEN IF( kase == 1 ) THEN ! ! Multiply by diag(W)*inv(A'). ! CALL spptrs( uplo, n, 1, afp, work( n+1 ), n, info ) DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO ELSE IF( kase == 2 ) THEN ! ! Multiply by inv(A)*diag(W). ! DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO CALL spptrs( uplo, n, 1, afp, work( n+1 ), n, info ) END IF GO TO 100 END IF ! ! Normalize error. ! lstres = zero DO i = 1, n lstres = MAX( lstres, ABS( x( i, j ) ) ) END DO IF( lstres /= zero ) ferr( j ) = ferr( j ) / lstres ! END DO ! RETURN ! ! End of SPPRFS ! END SUBROUTINE spprfs SUBROUTINE sppsv( uplo, n, nrhs, ap, 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 .. CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN OUT) :: nrhs REAL, INTENT(IN OUT) :: ap( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPPSV computes the solution to a real system of linear equations ! A * X = B, ! where A is an N-by-N symmetric positive definite matrix stored in ! packed format and X and B are N-by-NRHS matrices. ! ! The Cholesky decomposition is used to factor A as ! 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 a lower triangular ! matrix. The factored form of A is then used to solve the system of ! equations A * X = B. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! = 'U': Upper triangle of A is stored; ! = 'L': Lower triangle of A is stored. ! ! 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. ! ! AP (input/output) REAL 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. ! See below for further details. ! ! On exit, if INFO = 0, the factor U or L from the Cholesky ! factorization A = U**T*U or A = L*L**T, in the same storage ! format as A. ! ! B (input/output) REAL 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 of A is not ! positive definite, so the factorization could not be ! completed, and the solution has not been computed. ! ! Further Details ! =============== ! ! The packed storage scheme is illustrated by the following example ! when N = 4, UPLO = 'U': ! ! Two-dimensional storage of the symmetric matrix A: ! ! a11 a12 a13 a14 ! a22 a23 a24 ! a33 a34 (aij = conjg(aji)) ! a44 ! ! Packed storage of the upper triangle of A: ! ! AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] ! ! ===================================================================== ! ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL spptrf, spptrs, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -6 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPPSV ', -info ) RETURN END IF ! ! Compute the Cholesky factorization A = U'*U or A = L*L'. ! CALL spptrf( uplo, n, ap, info ) IF( info == 0 ) THEN ! ! Solve the system A*X = B, overwriting B with X. ! CALL spptrs( uplo, n, nrhs, ap, b, ldb, info ) ! END IF RETURN ! ! End of SPPSV ! END SUBROUTINE sppsv SUBROUTINE sppsvx( fact, uplo, n, nrhs, ap, afp, equed, s, b, ldb, & x, ldx, rcond, ferr, berr, work, iwork, 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 (LEN=1), INTENT(IN) :: fact CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: ap( * ) REAL, INTENT(IN OUT) :: afp( * ) CHARACTER (LEN=1), INTENT(OUT) :: equed REAL, INTENT(IN) :: s( * ) REAL, INTENT(OUT) :: b( ldb, * ) INTEGER, INTENT(IN) :: ldb REAL, INTENT(OUT) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: rcond REAL, INTENT(OUT) :: ferr( * ) REAL, INTENT(IN OUT) :: berr( * ) REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to ! compute the solution to a real system of linear equations ! A * X = B, ! where A is an N-by-N symmetric positive definite matrix stored in ! packed format and X and B are N-by-NRHS matrices. ! ! Error bounds on the solution and a condition estimate are also ! provided. ! ! Description ! =========== ! ! The following steps are performed: ! ! 1. If FACT = 'E', real scaling factors are computed to equilibrate ! the system: ! diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B ! Whether or not the system will be equilibrated depends on the ! scaling of the matrix A, but if equilibration is used, A is ! overwritten by diag(S)*A*diag(S) and B by diag(S)*B. ! ! 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to ! factor the matrix A (after equilibration if FACT = 'E') as ! 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 a lower triangular ! matrix. ! ! 3. If the leading i-by-i principal minor is not positive definite, ! then the routine returns with INFO = i. Otherwise, the factored ! form of A is used to estimate the condition number of the matrix ! A. If the reciprocal of the condition number is less than machine ! precision, INFO = N+1 is returned as a warning, but the routine ! still goes on to solve for X and compute error bounds as ! described below. ! ! 4. The system of equations is solved for X using the factored form ! of A. ! ! 5. Iterative refinement is applied to improve the computed solution ! matrix and calculate error bounds and backward error estimates ! for it. ! ! 6. If equilibration was used, the matrix X is premultiplied by ! diag(S) so that it solves the original system before ! equilibration. ! ! Arguments ! ========= ! ! FACT (input) CHARACTER*1 ! Specifies whether or not the factored form of the matrix A is ! supplied on entry, and if not, whether the matrix A should be ! equilibrated before it is factored. ! = 'F': On entry, AFP contains the factored form of A. ! If EQUED = 'Y', the matrix A has been equilibrated ! with scaling factors given by S. AP and AFP will not ! be modified. ! = 'N': The matrix A will be copied to AFP and factored. ! = 'E': The matrix A will be equilibrated if necessary, then ! copied to AFP and factored. ! ! UPLO (input) CHARACTER*1 ! = 'U': Upper triangle of A is stored; ! = 'L': Lower triangle of A is stored. ! ! 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 matrices B and X. NRHS >= 0. ! ! AP (input/output) REAL array, dimension (N*(N+1)/2) ! On entry, the upper or lower triangle of the symmetric matrix ! A, packed columnwise in a linear array, except if FACT = 'F' ! and EQUED = 'Y', then A must contain the equilibrated matrix ! diag(S)*A*diag(S). 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. ! See below for further details. A is not modified if ! FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit. ! ! On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by ! diag(S)*A*diag(S). ! ! AFP (input or output) REAL array, dimension ! (N*(N+1)/2) ! If FACT = 'F', then AFP is an input argument and on entry ! contains the triangular factor U or L from the Cholesky ! factorization A = U'*U or A = L*L', in the same storage ! format as A. If EQUED .ne. 'N', then AFP is the factored ! form of the equilibrated matrix A. ! ! If FACT = 'N', then AFP is an output argument and on exit ! returns the triangular factor U or L from the Cholesky ! factorization A = U'*U or A = L*L' of the original matrix A. ! ! If FACT = 'E', then AFP is an output argument and on exit ! returns the triangular factor U or L from the Cholesky ! factorization A = U'*U or A = L*L' of the equilibrated ! matrix A (see the description of AP for the form of the ! equilibrated matrix). ! ! EQUED (input or output) CHARACTER*1 ! Specifies the form of equilibration that was done. ! = 'N': No equilibration (always true if FACT = 'N'). ! = 'Y': Equilibration was done, i.e., A has been replaced by ! diag(S) * A * diag(S). ! EQUED is an input argument if FACT = 'F'; otherwise, it is an ! output argument. ! ! S (input or output) REAL array, dimension (N) ! The scale factors for A; not accessed if EQUED = 'N'. S is ! an input argument if FACT = 'F'; otherwise, S is an output ! argument. If FACT = 'F' and EQUED = 'Y', each element of S ! must be positive. ! ! B (input/output) REAL array, dimension (LDB,NRHS) ! On entry, the N-by-NRHS right hand side matrix B. ! On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y', ! B is overwritten by diag(S) * B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (output) REAL array, dimension (LDX,NRHS) ! If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to ! the original system of equations. Note that if EQUED = 'Y', ! A and B are modified on exit, and the solution to the ! equilibrated system is inv(diag(S))*X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! RCOND (output) REAL ! The estimate of the reciprocal condition number of the matrix ! A after equilibration (if done). If RCOND is less than the ! machine precision (in particular, if RCOND = 0), the matrix ! is singular to working precision. This condition is ! indicated by a return code of INFO > 0. ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER 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, and i is ! <= N: the leading minor of order i of A is ! not positive definite, so the factorization ! could not be completed, and the solution has not ! been computed. RCOND = 0 is returned. ! = N+1: U is nonsingular, but RCOND is less than machine ! precision, meaning that the matrix is singular ! to working precision. Nevertheless, the ! solution and error bounds are computed because ! there are a number of situations where the ! computed solution can be more accurate than the ! value of RCOND would suggest. ! ! Further Details ! =============== ! ! The packed storage scheme is illustrated by the following example ! when N = 4, UPLO = 'U': ! ! Two-dimensional storage of the symmetric matrix A: ! ! a11 a12 a13 a14 ! a22 a23 a24 ! a33 a34 (aij = conjg(aji)) ! a44 ! ! Packed storage of the upper triangle of A: ! ! AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: equil, nofact, rcequ INTEGER :: i, infequ, j REAL :: amax, anorm, bignum, scond, smax, smin, smlnum ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slansp EXTERNAL lsame, slamch, slansp ! .. ! .. External Subroutines .. EXTERNAL scopy, slacpy, slaqsp, sppcon, sppequ, spprfs, & spptrf, spptrs, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! info = 0 nofact = lsame( fact, 'N' ) equil = lsame( fact, 'E' ) IF( nofact .OR. equil ) THEN equed = 'N' rcequ = .false. ELSE rcequ = lsame( equed, 'Y' ) smlnum = slamch( 'Safe minimum' ) bignum = one / smlnum END IF ! ! Test the input parameters. ! IF( .NOT.nofact .AND. .NOT.equil .AND. .NOT.lsame( fact, 'F' ) ) THEN info = -1 ELSE IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) & THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( nrhs < 0 ) THEN info = -4 ELSE IF( lsame( fact, 'F' ) .AND. .NOT. & ( rcequ .OR. lsame( equed, 'N' ) ) ) THEN info = -7 ELSE IF( rcequ ) THEN smin = bignum smax = zero DO j = 1, n smin = MIN( smin, s( j ) ) smax = MAX( smax, s( j ) ) END DO IF( smin <= zero ) THEN info = -8 ELSE IF( n > 0 ) THEN scond = MAX( smin, smlnum ) / MIN( smax, bignum ) ELSE scond = one END IF END IF IF( info == 0 ) THEN IF( ldb < MAX( 1, n ) ) THEN info = -10 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -12 END IF END IF END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SPPSVX', -info ) RETURN END IF ! IF( equil ) THEN ! ! Compute row and column scalings to equilibrate the matrix A. ! CALL sppequ( uplo, n, ap, s, scond, amax, infequ ) IF( infequ == 0 ) THEN ! ! Equilibrate the matrix. ! CALL slaqsp( uplo, n, ap, s, scond, amax, equed ) rcequ = lsame( equed, 'Y' ) END IF END IF ! ! Scale the right-hand side. ! IF( rcequ ) THEN DO j = 1, nrhs DO i = 1, n b( i, j ) = s( i )*b( i, j ) END DO END DO END IF ! IF( nofact .OR. equil ) THEN ! ! Compute the Cholesky factorization A = U'*U or A = L*L'. ! CALL scopy( n*( n+1 ) / 2, ap, 1, afp, 1 ) CALL spptrf( uplo, n, afp, info ) ! ! Return if INFO is non-zero. ! IF( info /= 0 ) THEN IF( info > 0 ) rcond = zero RETURN END IF END IF ! ! Compute the norm of the matrix A. ! anorm = slansp( 'I', uplo, n, ap, work ) ! ! Compute the reciprocal of the condition number of A. ! CALL sppcon( uplo, n, afp, anorm, rcond, work, iwork, info ) ! ! Set INFO = N+1 if the matrix is singular to working precision. ! IF( rcond < slamch( 'Epsilon' ) ) info = n + 1 ! ! Compute the solution matrix X. ! CALL slacpy( 'Full', n, nrhs, b, ldb, x, ldx ) CALL spptrs( uplo, n, nrhs, afp, x, ldx, info ) ! ! Use iterative refinement to improve the computed solution and ! compute error bounds and backward error estimates for it. ! CALL spprfs( uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr, & work, iwork, info ) ! ! Transform the solution matrix X to a solution of the original ! system. ! IF( rcequ ) THEN DO j = 1, nrhs DO i = 1, n x( i, j ) = s( i )*x( i, j ) END DO END DO DO j = 1, nrhs ferr( j ) = ferr( j ) / scond END DO END IF ! RETURN ! ! End of SPPSVX ! END SUBROUTINE sppsvx SUBROUTINE spptrf( uplo, n, ap, 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: ap( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPPTRF computes the Cholesky factorization of a real symmetric ! positive definite matrix A stored in packed format. ! ! 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. ! ! 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) REAL 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. ! See below for further details. ! ! On exit, if INFO = 0, the triangular factor U or L from the ! Cholesky factorization A = U**T*U or A = L*L**T, in the same ! storage format as A. ! ! 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. ! ! Further Details ! ======= ======= ! ! The packed storage scheme is illustrated by the following example ! when N = 4, UPLO = 'U': ! ! Two-dimensional storage of the symmetric matrix A: ! ! a11 a12 a13 a14 ! a22 a23 a24 ! a33 a34 (aij = aji) ! a44 ! ! Packed storage of the upper triangle of A: ! ! AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: j, jc, jj REAL :: ajj ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: sdot EXTERNAL lsame, sdot ! .. ! .. External Subroutines .. EXTERNAL sscal, sspr, stpsv, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC 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 < 0 ) THEN info = -2 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPPTRF', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! IF( upper ) THEN ! ! Compute the Cholesky factorization A = U'*U. ! jj = 0 DO j = 1, n jc = jj + 1 jj = jj + j ! ! Compute elements 1:J-1 of column J. ! IF( j > 1 ) CALL stpsv( 'Upper', 'Transpose', 'Non-unit', j-1, ap, & ap( jc ), 1 ) ! ! Compute U(J,J) and test for non-positive-definiteness. ! ajj = ap( jj ) - sdot( j-1, ap( jc ), 1, ap( jc ), 1 ) IF( ajj <= zero ) THEN ap( jj ) = ajj GO TO 30 END IF ap( jj ) = SQRT( ajj ) END DO ELSE ! ! Compute the Cholesky factorization A = L*L'. ! jj = 1 DO j = 1, n ! ! Compute L(J,J) and test for non-positive-definiteness. ! ajj = ap( jj ) IF( ajj <= zero ) THEN ap( jj ) = ajj GO TO 30 END IF ajj = SQRT( ajj ) ap( jj ) = ajj ! ! Compute elements J+1:N of column J and update the trailing ! submatrix. ! IF( j < n ) THEN CALL sscal( n-j, one / ajj, ap( jj+1 ), 1 ) CALL sspr( 'Lower', n-j, -one, ap( jj+1 ), 1, ap( jj+n-j+1 ) ) jj = jj + n - j + 1 END IF END DO END IF GO TO 40 ! 30 CONTINUE info = j ! 40 CONTINUE RETURN ! ! End of SPPTRF ! END SUBROUTINE spptrf SUBROUTINE spptri( uplo, n, ap, 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: ap( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPPTRI computes the inverse of a real symmetric positive definite ! matrix A using the Cholesky factorization A = U**T*U or A = L*L**T ! computed by SPPTRF. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! = 'U': Upper triangular factor is stored in AP; ! = 'L': Lower triangular factor is stored in AP. ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! AP (input/output) REAL array, dimension (N*(N+1)/2) ! On entry, the triangular factor U or L from the Cholesky ! factorization A = U**T*U or A = L*L**T, packed columnwise as ! a linear array. The j-th column of U or L is stored in the ! array AP as follows: ! if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; ! if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. ! ! On exit, the upper or lower triangle of the (symmetric) ! inverse of A, overwriting the input factor U or L. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! > 0: if INFO = i, the (i,i) element of the factor U or L is ! zero, and the inverse could not be computed. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: j, jc, jj, jjn REAL :: ajj ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: sdot EXTERNAL lsame, sdot ! .. ! .. External Subroutines .. EXTERNAL sscal, sspr, stpmv, stptri, xerbla ! .. ! .. 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 < 0 ) THEN info = -2 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPPTRI', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Invert the triangular Cholesky factor U or L. ! CALL stptri( uplo, 'Non-unit', n, ap, info ) IF( info > 0 ) RETURN ! IF( upper ) THEN ! ! Compute the product inv(U) * inv(U)'. ! jj = 0 DO j = 1, n jc = jj + 1 jj = jj + j IF( j > 1 ) CALL sspr( 'Upper', j-1, one, ap( jc ), 1, ap ) ajj = ap( jj ) CALL sscal( j, ajj, ap( jc ), 1 ) END DO ! ELSE ! ! Compute the product inv(L)' * inv(L). ! jj = 1 DO j = 1, n jjn = jj + n - j + 1 ap( jj ) = sdot( n-j+1, ap( jj ), 1, ap( jj ), 1 ) IF( j < n ) CALL stpmv( 'Lower', 'Transpose', 'Non-unit', n-j, & ap( jjn ), ap( jj+1 ), 1 ) jj = jjn END DO END IF ! RETURN ! ! End of SPPTRI ! END SUBROUTINE spptri SUBROUTINE spptrs( uplo, n, nrhs, ap, 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN OUT) :: ap( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPPTRS solves a system of linear equations A*X = B with a symmetric ! positive definite matrix A in packed storage using the Cholesky ! factorization A = U**T*U or A = L*L**T computed by SPPTRF. ! ! 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. ! ! AP (input) REAL array, dimension (N*(N+1)/2) ! The triangular factor U or L from the Cholesky factorization ! A = U**T*U or A = L*L**T, packed columnwise in a linear ! array. The j-th column of U or L is stored in the array AP ! as follows: ! if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j; ! if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n. ! ! B (input/output) REAL 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 ! ! ===================================================================== ! ! .. Local Scalars .. LOGICAL :: upper INTEGER :: i ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL stpsv, 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 < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -6 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPPTRS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) RETURN ! IF( upper ) THEN ! ! Solve A*X = B where A = U'*U. ! DO i = 1, nrhs ! ! Solve U'*X = B, overwriting B with X. ! CALL stpsv( 'Upper', 'Transpose', 'Non-unit', n, ap, b( 1, i ), 1 ) ! ! Solve U*X = B, overwriting B with X. ! CALL stpsv( 'Upper', 'No transpose', 'Non-unit', n, ap, b( 1, i ), 1 ) END DO ELSE ! ! Solve A*X = B where A = L*L'. ! DO i = 1, nrhs ! ! Solve L*Y = B, overwriting B with X. ! CALL stpsv( 'Lower', 'No transpose', 'Non-unit', n, ap, b( 1, i ), 1 ) ! ! Solve L'*X = Y, overwriting B with X. ! CALL stpsv( 'Lower', 'Transpose', 'Non-unit', n, ap, b( 1, i ), 1 ) END DO END IF ! RETURN ! ! End of SPPTRS ! END SUBROUTINE spptrs SUBROUTINE sptcon( n, d, e, anorm, rcond, 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 .. INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: e( * ) REAL, INTENT(IN) :: anorm REAL, INTENT(OUT) :: rcond REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPTCON computes the reciprocal of the condition number (in the ! 1-norm) of a real symmetric positive definite tridiagonal matrix ! using the factorization A = L*D*L**T or A = U**T*D*U computed by ! SPTTRF. ! ! Norm(inv(A)) is computed by a direct method, and the reciprocal of ! the condition number is computed as ! RCOND = 1 / (ANORM * norm(inv(A))). ! ! Arguments ! ========= ! ! N (input) INTEGER ! The order of the matrix A. N >= 0. ! ! D (input) REAL array, dimension (N) ! The n diagonal elements of the diagonal matrix D from the ! factorization of A, as computed by SPTTRF. ! ! E (input) REAL array, dimension (N-1) ! The (n-1) off-diagonal elements of the unit bidiagonal factor ! U or L from the factorization of A, as computed by SPTTRF. ! ! ANORM (input) REAL ! The 1-norm of the original matrix A. ! ! RCOND (output) REAL ! The reciprocal of the condition number of the matrix A, ! computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the ! 1-norm of inv(A) computed in this routine. ! ! WORK (workspace) REAL array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! Further Details ! =============== ! ! The method used is described in Nicholas J. Higham, "Efficient ! Algorithms for Computing the Condition Number of a Tridiagonal ! Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, ix REAL :: ainvnm ! .. ! .. External Functions .. INTEGER :: isamax EXTERNAL isamax ! .. ! .. External Subroutines .. EXTERNAL xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS ! .. ! .. Executable Statements .. ! ! Test the input arguments. ! info = 0 IF( n < 0 ) THEN info = -1 ELSE IF( anorm < zero ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPTCON', -info ) RETURN END IF ! ! Quick return if possible ! rcond = zero IF( n == 0 ) THEN rcond = one RETURN ELSE IF( anorm == zero ) THEN RETURN END IF ! ! Check that D(1:N) is positive. ! DO i = 1, n IF( d( i ) <= zero ) RETURN END DO ! ! Solve M(A) * x = e, where M(A) = (m(i,j)) is given by ! ! m(i,j) = abs(A(i,j)), i = j, ! m(i,j) = -abs(A(i,j)), i .ne. j, ! ! and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. ! ! Solve M(L) * x = e. ! work( 1 ) = one DO i = 2, n work( i ) = one + work( i-1 )*ABS( e( i-1 ) ) END DO ! ! Solve D * M(L)' * x = b. ! work( n ) = work( n ) / d( n ) DO i = n - 1, 1, -1 work( i ) = work( i ) / d( i ) + work( i+1 )*ABS( e( i ) ) END DO ! ! Compute AINVNM = max(x(i)), 1<=i<=n. ! ix = isamax( n, work, 1 ) ainvnm = ABS( work( ix ) ) ! ! Compute the reciprocal condition number. ! IF( ainvnm /= zero ) rcond = ( one / ainvnm ) / anorm ! RETURN ! ! End of SPTCON ! END SUBROUTINE sptcon SUBROUTINE spteqr( 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 (LEN=1), INTENT(IN) :: compz INTEGER, INTENT(IN) :: n REAL, INTENT(OUT) :: d( * ) REAL, INTENT(OUT) :: e( * ) REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPTEQR computes all eigenvalues and, optionally, eigenvectors of a ! symmetric positive definite tridiagonal matrix by first factoring the ! matrix using SPTTRF, and then calling SBDSQR to compute the singular ! values of the bidiagonal factor. ! ! This routine computes the eigenvalues of the positive definite ! tridiagonal matrix to high relative accuracy. This means that if the ! eigenvalues range over many orders of magnitude in size, then the ! small eigenvalues and corresponding eigenvectors will be computed ! more accurately than, for example, with the standard QR method. ! ! The eigenvectors of a full or band symmetric positive definite matrix ! can also be found if SSYTRD, SSPTRD, or SSBTRD has been used to ! reduce this matrix to tridiagonal form. (The reduction to tridiagonal ! form, however, may preclude the possibility of obtaining high ! relative accuracy in the small eigenvalues of the original matrix, if ! these eigenvalues range over many orders of magnitude.) ! ! Arguments ! ========= ! ! COMPZ (input) CHARACTER*1 ! = 'N': Compute eigenvalues only. ! = 'V': Compute eigenvectors of original symmetric ! matrix also. Array Z contains the orthogonal ! matrix used to reduce the original matrix to ! tridiagonal form. ! = 'I': Compute eigenvectors of tridiagonal matrix also. ! ! N (input) INTEGER ! The order of the matrix. N >= 0. ! ! D (input/output) REAL array, dimension (N) ! On entry, the n diagonal elements of the tridiagonal ! matrix. ! On normal exit, D contains the eigenvalues, in descending ! order. ! ! E (input/output) REAL array, dimension (N-1) ! On entry, the (n-1) subdiagonal elements of the tridiagonal ! matrix. ! On exit, E has been destroyed. ! ! Z (input/output) REAL array, dimension (LDZ, N) ! On entry, if COMPZ = 'V', the orthogonal matrix used in the ! reduction to tridiagonal form. ! On exit, if COMPZ = 'V', the orthonormal eigenvectors of the ! original symmetric matrix; ! if COMPZ = 'I', the orthonormal eigenvectors of the ! tridiagonal matrix. ! If INFO > 0 on exit, Z contains the eigenvectors associated ! with only 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 ! COMPZ = 'V' or 'I', LDZ >= max(1,N). ! ! WORK (workspace) REAL array, dimension (LWORK) ! If COMPZ = 'N', then LWORK = 2*N ! If COMPZ = 'V' or 'I', then LWORK = MAX(1,4*N-4) ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: if INFO = i, and i is: ! <= N the Cholesky factorization of the matrix could ! not be performed because the i-th principal minor ! was not positive definite. ! > N the SVD algorithm failed to converge; ! if INFO = N+i, i off-diagonal elements of the ! bidiagonal factor did not converge to zero. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL sbdsqr, slaset, spttrf, xerbla ! .. ! .. Local Arrays .. REAL :: c( 1, 1 ), vt( 1, 1 ) ! .. ! .. Local Scalars .. INTEGER :: i, icompz, nru ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, 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 < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( ( ldz < 1 ) .OR. ( icompz > 0 .AND. ldz < MAX( 1, & n ) ) ) THEN info = -6 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPTEQR', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! IF( n == 1 ) THEN IF( icompz > 0 ) z( 1, 1 ) = one RETURN END IF IF( icompz == 2 ) CALL slaset( 'Full', n, n, zero, one, z, ldz ) ! ! Call SPTTRF to factor the matrix. ! CALL spttrf( n, d, e, info ) IF( info /= 0 ) RETURN DO i = 1, n d( i ) = SQRT( d( i ) ) END DO DO i = 1, n - 1 e( i ) = e( i )*d( i ) END DO ! ! Call SBDSQR to compute the singular values/vectors of the ! bidiagonal factor. ! IF( icompz > 0 ) THEN nru = n ELSE nru = 0 END IF CALL sbdsqr( 'Lower', n, 0, nru, 0, d, e, vt, 1, z, ldz, c, 1, work, info ) ! ! Square the singular values. ! IF( info == 0 ) THEN DO i = 1, n d( i ) = d( i )*d( i ) END DO ELSE info = n + info END IF ! RETURN ! ! End of SPTEQR ! END SUBROUTINE spteqr SUBROUTINE sptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr, & berr, 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, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: e( * ) REAL, INTENT(IN) :: df( * ) REAL, INTENT(IN) :: ef( * ) REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: ferr( * ) REAL, INTENT(OUT) :: berr( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPTRFS improves the computed solution to a system of linear ! equations when the coefficient matrix is symmetric positive definite ! and tridiagonal, and provides error bounds and backward error ! estimates for the solution. ! ! 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) REAL array, dimension (N) ! The n diagonal elements of the tridiagonal matrix A. ! ! E (input) REAL array, dimension (N-1) ! The (n-1) subdiagonal elements of the tridiagonal matrix A. ! ! DF (input) REAL array, dimension (N) ! The n diagonal elements of the diagonal matrix D from the ! factorization computed by SPTTRF. ! ! EF (input) REAL array, dimension (N-1) ! The (n-1) subdiagonal elements of the unit bidiagonal factor ! L from the factorization computed by SPTTRF. ! ! B (input) REAL array, dimension (LDB,NRHS) ! The right hand side matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (input/output) REAL array, dimension (LDX,NRHS) ! On entry, the solution matrix X, as computed by SPTTRS. ! On exit, the improved solution matrix X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! FERR (output) REAL array, dimension (NRHS) ! The forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (2*N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! Internal Parameters ! =================== ! ! ITMAX is the maximum number of steps of iterative refinement. ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: itmax = 5 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 REAL, PARAMETER :: three = 3.0E+0 ! .. ! .. Local Scalars .. INTEGER :: count, i, ix, j, nz REAL :: bi, cx, dx, eps, ex, lstres, s, safe1, safe2, safmin ! .. ! .. External Subroutines .. EXTERNAL saxpy, spttrs, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. External Functions .. INTEGER :: isamax REAL :: slamch EXTERNAL isamax, slamch ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 IF( n < 0 ) THEN info = -1 ELSE IF( nrhs < 0 ) THEN info = -2 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -8 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -10 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPTRFS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) THEN DO j = 1, nrhs ferr( j ) = zero berr( j ) = zero END DO RETURN END IF ! ! NZ = maximum number of nonzero elements in each row of A, plus 1 ! nz = 4 eps = slamch( 'Epsilon' ) safmin = slamch( 'Safe minimum' ) safe1 = nz*safmin safe2 = safe1 / eps ! ! Do for each right hand side ! DO j = 1, nrhs ! count = 1 lstres = three 20 CONTINUE ! ! Loop until stopping criterion is satisfied. ! ! Compute residual R = B - A * X. Also compute ! abs(A)*abs(x) + abs(b) for use in the backward error bound. ! IF( n == 1 ) THEN bi = b( 1, j ) dx = d( 1 )*x( 1, j ) work( n+1 ) = bi - dx work( 1 ) = ABS( bi ) + ABS( dx ) ELSE bi = b( 1, j ) dx = d( 1 )*x( 1, j ) ex = e( 1 )*x( 2, j ) work( n+1 ) = bi - dx - ex work( 1 ) = ABS( bi ) + ABS( dx ) + ABS( ex ) DO i = 2, n - 1 bi = b( i, j ) cx = e( i-1 )*x( i-1, j ) dx = d( i )*x( i, j ) ex = e( i )*x( i+1, j ) work( n+i ) = bi - cx - dx - ex work( i ) = ABS( bi ) + ABS( cx ) + ABS( dx ) + ABS( ex ) END DO bi = b( n, j ) cx = e( n-1 )*x( n-1, j ) dx = d( n )*x( n, j ) work( n+n ) = bi - cx - dx work( n ) = ABS( bi ) + ABS( cx ) + ABS( dx ) END IF ! ! Compute componentwise relative backward error from formula ! ! max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) ! ! where abs(Z) is the componentwise absolute value of the matrix ! or vector Z. If the i-th component of the denominator is less ! than SAFE2, then SAFE1 is added to the i-th components of the ! numerator and denominator before dividing. ! s = zero DO i = 1, n IF( work( i ) > safe2 ) THEN s = MAX( s, ABS( work( n+i ) ) / work( i ) ) ELSE s = MAX( s, ( ABS( work( n+i ) )+safe1 ) / ( work( i )+safe1 ) ) END IF END DO berr( j ) = s ! ! Test stopping criterion. Continue iterating if ! 1) The residual BERR(J) is larger than machine epsilon, and ! 2) BERR(J) decreased by at least a factor of 2 during the ! last iteration, and ! 3) At most ITMAX iterations tried. ! IF( berr( j ) > eps .AND. two*berr( j ) <= lstres .AND. & count <= itmax ) THEN ! ! Update solution and try again. ! CALL spttrs( n, 1, df, ef, work( n+1 ), n, info ) CALL saxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 GO TO 20 END IF ! ! Bound error from formula ! ! norm(X - XTRUE) / norm(X) .le. FERR = ! norm( abs(inv(A))* ! ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) ! ! where ! norm(Z) is the magnitude of the largest component of Z ! inv(A) is the inverse of A ! abs(Z) is the componentwise absolute value of the matrix or ! vector Z ! NZ is the maximum number of nonzeros in any row of A, plus 1 ! EPS is machine epsilon ! ! The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) ! is incremented by SAFE1 if the i-th component of ! abs(A)*abs(X) + abs(B) is less than SAFE2. ! DO i = 1, n IF( work( i ) > safe2 ) THEN work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) ELSE work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) + safe1 END IF END DO ix = isamax( n, work, 1 ) ferr( j ) = work( ix ) ! ! Estimate the norm of inv(A). ! ! Solve M(A) * x = e, where M(A) = (m(i,j)) is given by ! ! m(i,j) = abs(A(i,j)), i = j, ! m(i,j) = -abs(A(i,j)), i .ne. j, ! ! and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'. ! ! Solve M(L) * x = e. ! work( 1 ) = one DO i = 2, n work( i ) = one + work( i-1 )*ABS( ef( i-1 ) ) END DO ! ! Solve D * M(L)' * x = b. ! work( n ) = work( n ) / df( n ) DO i = n - 1, 1, -1 work( i ) = work( i ) / df( i ) + work( i+1 )*ABS( ef( i ) ) END DO ! ! Compute norm(inv(A)) = max(x(i)), 1<=i<=n. ! ix = isamax( n, work, 1 ) ferr( j ) = ferr( j )*ABS( work( ix ) ) ! ! Normalize error. ! lstres = zero DO i = 1, n lstres = MAX( lstres, ABS( x( i, j ) ) ) END DO IF( lstres /= zero ) ferr( j ) = ferr( j ) / lstres ! END DO ! RETURN ! ! End of SPTRFS ! END SUBROUTINE sptrfs SUBROUTINE sptsv( 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, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: nrhs REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(IN OUT) :: e( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPTSV 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) REAL 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) REAL 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) REAL 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 spttrf, spttrs, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 IF( n < 0 ) THEN info = -1 ELSE IF( nrhs < 0 ) THEN info = -2 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -6 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPTSV ', -info ) RETURN END IF ! ! Compute the L*D*L' (or U'*D*U) factorization of A. ! CALL spttrf( n, d, e, info ) IF( info == 0 ) THEN ! ! Solve the system A*X = B, overwriting B with X. ! CALL spttrs( n, nrhs, d, e, b, ldb, info ) END IF RETURN ! ! End of SPTSV ! END SUBROUTINE sptsv SUBROUTINE sptsvx( fact, n, nrhs, d, e, df, ef, b, ldb, x, ldx, & rcond, ferr, berr, 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 .. CHARACTER (LEN=1), INTENT(IN) :: fact INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: nrhs REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: e( * ) REAL, INTENT(IN OUT) :: df( * ) REAL, INTENT(IN OUT) :: ef( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: rcond REAL, INTENT(IN OUT) :: ferr( * ) REAL, INTENT(IN OUT) :: berr( * ) REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPTSVX uses the factorization A = L*D*L**T to compute 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. ! ! Error bounds on the solution and a condition estimate are also ! provided. ! ! Description ! =========== ! ! The following steps are performed: ! ! 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L ! is a unit lower bidiagonal matrix and D is diagonal. The ! factorization can also be regarded as having the form ! A = U**T*D*U. ! ! 2. If the leading i-by-i principal minor is not positive definite, ! then the routine returns with INFO = i. Otherwise, the factored ! form of A is used to estimate the condition number of the matrix ! A. If the reciprocal of the condition number is less than machine ! precision, INFO = N+1 is returned as a warning, but the routine ! still goes on to solve for X and compute error bounds as ! described below. ! ! 3. The system of equations is solved for X using the factored form ! of A. ! ! 4. Iterative refinement is applied to improve the computed solution ! matrix and calculate error bounds and backward error estimates ! for it. ! ! Arguments ! ========= ! ! FACT (input) CHARACTER*1 ! Specifies whether or not the factored form of A has been ! supplied on entry. ! = 'F': On entry, DF and EF contain the factored form of A. ! D, E, DF, and EF will not be modified. ! = 'N': The matrix A will be copied to DF and EF and ! factored. ! ! 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 matrices B and X. NRHS >= 0. ! ! D (input) REAL array, dimension (N) ! The n diagonal elements of the tridiagonal matrix A. ! ! E (input) REAL array, dimension (N-1) ! The (n-1) subdiagonal elements of the tridiagonal matrix A. ! ! DF (input or output) REAL array, dimension (N) ! If FACT = 'F', then DF is an input argument and on entry ! contains the n diagonal elements of the diagonal matrix D ! from the L*D*L**T factorization of A. ! If FACT = 'N', then DF is an output argument and on exit ! contains the n diagonal elements of the diagonal matrix D ! from the L*D*L**T factorization of A. ! ! EF (input or output) REAL array, dimension (N-1) ! If FACT = 'F', then EF is an input argument and on entry ! contains the (n-1) subdiagonal elements of the unit ! bidiagonal factor L from the L*D*L**T factorization of A. ! If FACT = 'N', then EF is an output argument and on exit ! contains the (n-1) subdiagonal elements of the unit ! bidiagonal factor L from the L*D*L**T factorization of A. ! ! B (input) REAL array, dimension (LDB,NRHS) ! The N-by-NRHS right hand side matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (output) REAL array, dimension (LDX,NRHS) ! If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! RCOND (output) REAL ! The reciprocal condition number of the matrix A. If RCOND ! is less than the machine precision (in particular, if ! RCOND = 0), the matrix is singular to working precision. ! This condition is indicated by a return code of INFO > 0. ! ! FERR (output) REAL array, dimension (NRHS) ! The forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in any ! element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (2*N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! > 0: if INFO = i, and i is ! <= N: the leading minor of order i of A is ! not positive definite, so the factorization ! could not be completed, and the solution has not ! been computed. RCOND = 0 is returned. ! = N+1: U is nonsingular, but RCOND is less than machine ! precision, meaning that the matrix is singular ! to working precision. Nevertheless, the ! solution and error bounds are computed because ! there are a number of situations where the ! computed solution can be more accurate than the ! value of RCOND would suggest. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: nofact REAL :: anorm ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slanst EXTERNAL lsame, slamch, slanst ! .. ! .. External Subroutines .. EXTERNAL scopy, slacpy, sptcon, sptrfs, spttrf, spttrs, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 nofact = lsame( fact, 'N' ) IF( .NOT.nofact .AND. .NOT.lsame( fact, 'F' ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -9 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -11 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPTSVX', -info ) RETURN END IF ! IF( nofact ) THEN ! ! Compute the L*D*L' (or U'*D*U) factorization of A. ! CALL scopy( n, d, 1, df, 1 ) IF( n > 1 ) CALL scopy( n-1, e, 1, ef, 1 ) CALL spttrf( n, df, ef, info ) ! ! Return if INFO is non-zero. ! IF( info /= 0 ) THEN IF( info > 0 ) rcond = zero RETURN END IF END IF ! ! Compute the norm of the matrix A. ! anorm = slanst( '1', n, d, e ) ! ! Compute the reciprocal of the condition number of A. ! CALL sptcon( n, df, ef, anorm, rcond, work, info ) ! ! Set INFO = N+1 if the matrix is singular to working precision. ! IF( rcond < slamch( 'Epsilon' ) ) info = n + 1 ! ! Compute the solution vectors X. ! CALL slacpy( 'Full', n, nrhs, b, ldb, x, ldx ) CALL spttrs( n, nrhs, df, ef, x, ldx, info ) ! ! Use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. ! CALL sptrfs( n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr, berr, work, info ) ! RETURN ! ! End of SPTSVX ! END SUBROUTINE sptsvx SUBROUTINE spttrf( 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, INTENT(IN) :: n REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(IN OUT) :: e( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPTTRF 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) REAL 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) REAL 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 .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, i4 REAL :: ei ! .. ! .. External Subroutines .. EXTERNAL xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MOD ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 IF( n < 0 ) THEN info = -1 CALL xerbla( 'SPTTRF', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Compute the L*D*L' (or U'*D*U) factorization of A. ! i4 = MOD( n-1, 4 ) DO i = 1, i4 IF( d( i ) <= 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 END DO ! DO i = i4 + 1, n - 4, 4 ! ! Drop out of the loop if d(i) <= 0: the matrix is not positive ! definite. ! IF( d( i ) <= 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 ) <= 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 ) <= 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 ) <= 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 END DO ! ! Check d(n) for positive definiteness. ! IF( d( n ) <= zero ) info = n ! 30 CONTINUE RETURN ! ! End of SPTTRF ! END SUBROUTINE spttrf SUBROUTINE spttrs( 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, INTENT(IN) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(IN OUT) :: e( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPTTRS solves a tridiagonal system of the form ! A * X = B ! using the L*D*L' factorization of A computed by SPTTRF. 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) REAL array, dimension (N) ! The n diagonal elements of the diagonal matrix D from the ! L*D*L' factorization of A. ! ! E (input) REAL 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) REAL 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 sptts2, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input arguments. ! info = 0 IF( n < 0 ) THEN info = -1 ELSE IF( nrhs < 0 ) THEN info = -2 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -6 END IF IF( info /= 0 ) THEN CALL xerbla( 'SPTTRS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) RETURN ! ! Determine the number of right-hand sides to solve at a time. ! IF( nrhs == 1 ) THEN nb = 1 ELSE nb = MAX( 1, ilaenv( 1, 'SPTTRS', ' ', n, nrhs, -1, -1 ) ) END IF ! IF( nb >= nrhs ) THEN CALL sptts2( n, nrhs, d, e, b, ldb ) ELSE DO j = 1, nrhs, nb jb = MIN( nrhs-j+1, nb ) CALL sptts2( n, jb, d, e, b( 1, j ), ldb ) END DO END IF ! RETURN ! ! End of SPTTRS ! END SUBROUTINE spttrs SUBROUTINE sptts2( 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, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: e( * ) REAL, INTENT(OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SPTTS2 solves a tridiagonal system of the form ! A * X = B ! using the L*D*L' factorization of A computed by SPTTRF. 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) REAL array, dimension (N) ! The n diagonal elements of the diagonal matrix D from the ! L*D*L' factorization of A. ! ! E (input) REAL 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) REAL 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 sscal ! .. ! .. Executable Statements .. ! ! Quick return if possible ! IF( n <= 1 ) THEN IF( n == 1 ) CALL sscal( nrhs, 1. / 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 j = 1, nrhs ! ! Solve L * x = b. ! DO i = 2, n b( i, j ) = b( i, j ) - b( i-1, j )*e( i-1 ) END DO ! ! Solve D * L' * x = b. ! b( n, j ) = b( n, j ) / d( n ) DO i = n - 1, 1, -1 b( i, j ) = b( i, j ) / d( i ) - b( i+1, j )*e( i ) END DO END DO ! RETURN ! ! End of SPTTS2 ! END SUBROUTINE sptts2 SUBROUTINE srscl( n, sa, sx, incx ) ! ! -- 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, INTENT(IN) :: n REAL, INTENT(IN) :: sa REAL, INTENT(IN OUT) :: sx( * ) INTEGER, INTENT(IN OUT) :: incx ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SRSCL multiplies an n-element real vector x by the real scalar 1/a. ! This is done without overflow or underflow as long as ! the final result x/a does not overflow or underflow. ! ! Arguments ! ========= ! ! N (input) INTEGER ! The number of components of the vector x. ! ! SA (input) REAL ! The scalar a which is used to divide each component of x. ! SA must be >= 0, or the subroutine will divide by zero. ! ! SX (input/output) REAL array, dimension ! (1+(N-1)*abs(INCX)) ! The n-element vector x. ! ! INCX (input) INTEGER ! The increment between successive values of the vector SX. ! > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: done REAL :: bignum, cden, cden1, cnum, cnum1, mul, smlnum ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. External Subroutines .. EXTERNAL slabad, sscal ! .. ! .. Intrinsic Functions .. INTRINSIC ABS ! .. ! .. Executable Statements .. ! ! Quick return if possible ! IF( n <= 0 ) RETURN ! ! Get machine parameters ! smlnum = slamch( 'S' ) bignum = one / smlnum CALL slabad( smlnum, bignum ) ! ! Initialize the denominator to SA and the numerator to 1. ! cden = sa cnum = one ! 10 CONTINUE cden1 = cden*smlnum cnum1 = cnum / bignum IF( ABS( cden1 ) > ABS( cnum ) .AND. cnum /= zero ) THEN ! ! Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. ! mul = smlnum done = .false. cden = cden1 ELSE IF( ABS( cnum1 ) > ABS( cden ) ) THEN ! ! Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. ! mul = bignum done = .false. cnum = cnum1 ELSE ! ! Multiply X by CNUM / CDEN and return. ! mul = cnum / cden done = .true. END IF ! ! Scale the vector X by MUL ! CALL sscal( n, mul, sx, incx ) ! IF( .NOT.done ) GO TO 10 ! RETURN ! ! End of SRSCL ! END SUBROUTINE srscl SUBROUTINE ssbev( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, 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 (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: kd REAL, INTENT(IN) :: ab( ldab, * ) INTEGER, INTENT(IN) :: ldab REAL, INTENT(OUT) :: w( * ) REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSBEV computes all the eigenvalues and, optionally, eigenvectors of ! a real symmetric band 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. ! ! KD (input) INTEGER ! The number of superdiagonals of the matrix A if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KD >= 0. ! ! AB (input/output) REAL array, dimension (LDAB, N) ! On entry, the upper or lower triangle of the symmetric band ! matrix A, stored in the first KD+1 rows of the array. The ! j-th column of A is stored in the j-th column of the array AB ! as follows: ! if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). ! ! On exit, AB is overwritten by values generated during the ! reduction to tridiagonal form. If UPLO = 'U', the first ! superdiagonal and the diagonal of the tridiagonal matrix T ! are returned in rows KD and KD+1 of AB, and if UPLO = 'L', ! the diagonal and first subdiagonal of T are returned in the ! first two rows of AB. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KD + 1. ! ! W (output) REAL array, dimension (N) ! If INFO = 0, the eigenvalues in ascending order. ! ! Z (output) REAL 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) REAL 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 .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: lower, wantz INTEGER :: iinfo, imax, inde, indwrk, iscale REAL :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slansb EXTERNAL lsame, slamch, slansb ! .. ! .. External Subroutines .. EXTERNAL slascl, ssbtrd, sscal, ssteqr, ssterf, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! wantz = lsame( jobz, 'V' ) lower = lsame( uplo, 'L' ) ! 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 < 0 ) THEN info = -3 ELSE IF( kd < 0 ) THEN info = -4 ELSE IF( ldab < kd+1 ) THEN info = -6 ELSE IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) THEN info = -9 END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSBEV ', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! IF( n == 1 ) THEN IF( lower ) THEN w( 1 ) = ab( 1, 1 ) ELSE w( 1 ) = ab( kd+1, 1 ) END IF IF( wantz ) z( 1, 1 ) = one RETURN END IF ! ! Get machine constants. ! safmin = slamch( 'Safe minimum' ) eps = slamch( 'Precision' ) smlnum = safmin / eps bignum = one / smlnum rmin = SQRT( smlnum ) rmax = SQRT( bignum ) ! ! Scale matrix to allowable range, if necessary. ! anrm = slansb( 'M', uplo, n, kd, ab, ldab, work ) iscale = 0 IF( anrm > zero .AND. anrm < rmin ) THEN iscale = 1 sigma = rmin / anrm ELSE IF( anrm > rmax ) THEN iscale = 1 sigma = rmax / anrm END IF IF( iscale == 1 ) THEN IF( lower ) THEN CALL slascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) ELSE CALL slascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) END IF END IF ! ! Call SSBTRD to reduce symmetric band matrix to tridiagonal form. ! inde = 1 indwrk = inde + n CALL ssbtrd( jobz, uplo, n, kd, ab, ldab, w, work( inde ), z, ldz, & work( indwrk ), iinfo ) ! ! For eigenvalues only, call SSTERF. For eigenvectors, call SSTEQR. ! IF( .NOT.wantz ) THEN CALL ssterf( n, w, work( inde ), info ) ELSE CALL ssteqr( jobz, n, w, work( inde ), z, ldz, work( indwrk ), info ) END IF ! ! If matrix was scaled, then rescale eigenvalues appropriately. ! IF( iscale == 1 ) THEN IF( info == 0 ) THEN imax = n ELSE imax = info - 1 END IF CALL sscal( imax, one / sigma, w, 1 ) END IF ! RETURN ! ! End of SSBEV ! END SUBROUTINE ssbev SUBROUTINE ssbevd( jobz, uplo, n, kd, ab, ldab, w, z, ldz, work, & lwork, iwork, liwork, 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 (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: kd REAL, INTENT(IN) :: ab( ldab, * ) INTEGER, INTENT(IN) :: ldab REAL, INTENT(OUT) :: w( * ) REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(IN OUT) :: liwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSBEVD computes all the eigenvalues and, optionally, eigenvectors of ! a real symmetric band matrix A. If eigenvectors are desired, it uses ! a divide and conquer algorithm. ! ! The divide and conquer algorithm makes very mild assumptions about ! floating point arithmetic. It will work on machines with a guard ! digit in add/subtract, or on those binary machines without guard ! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or ! Cray-2. It could conceivably fail on hexadecimal or decimal machines ! without guard digits, but we know of none. ! ! 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. ! ! KD (input) INTEGER ! The number of superdiagonals of the matrix A if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KD >= 0. ! ! AB (input/output) REAL array, dimension (LDAB, N) ! On entry, the upper or lower triangle of the symmetric band ! matrix A, stored in the first KD+1 rows of the array. The ! j-th column of A is stored in the j-th column of the array AB ! as follows: ! if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). ! ! On exit, AB is overwritten by values generated during the ! reduction to tridiagonal form. If UPLO = 'U', the first ! superdiagonal and the diagonal of the tridiagonal matrix T ! are returned in rows KD and KD+1 of AB, and if UPLO = 'L', ! the diagonal and first subdiagonal of T are returned in the ! first two rows of AB. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KD + 1. ! ! W (output) REAL array, dimension (N) ! If INFO = 0, the eigenvalues in ascending order. ! ! Z (output) REAL 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/output) REAL array, ! dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. ! IF N <= 1, LWORK must be at least 1. ! If JOBZ = 'N' and N > 2, LWORK must be at least 2*N. ! If JOBZ = 'V' and N > 2, LWORK must be at least ! ( 1 + 5*N + 2*N**2 ). ! ! 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/output) INTEGER array, dimension (LIWORK) ! On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. ! ! LIWORK (input) INTEGER ! The dimension of the array LIWORK. ! If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. ! If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N. ! ! If LIWORK = -1, then a workspace query is assumed; the ! routine only calculates the optimal size of the IWORK array, ! returns this value as the first entry of the IWORK array, and ! no error message related to LIWORK 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 .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lower, lquery, wantz INTEGER :: iinfo, inde, indwk2, indwrk, iscale, liwmin, llwrk2, lwmin REAL :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slansb EXTERNAL lsame, slamch, slansb ! .. ! .. External Subroutines .. EXTERNAL sgemm, slacpy, slascl, ssbtrd, sscal, sstedc, & ssterf, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! wantz = lsame( jobz, 'V' ) lower = lsame( uplo, 'L' ) lquery = ( lwork == -1 .OR. liwork == -1 ) ! info = 0 IF( n <= 1 ) THEN liwmin = 1 lwmin = 1 ELSE IF( wantz ) THEN liwmin = 3 + 5*n lwmin = 1 + 5*n + 2*n**2 ELSE liwmin = 1 lwmin = 2*n END IF END IF IF( .NOT.( wantz .OR. lsame( jobz, 'N' ) ) ) THEN info = -1 ELSE IF( .NOT.( lower .OR. lsame( uplo, 'U' ) ) ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( kd < 0 ) THEN info = -4 ELSE IF( ldab < kd+1 ) THEN info = -6 ELSE IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) THEN info = -9 ELSE IF( lwork < lwmin .AND. .NOT.lquery ) THEN info = -11 ELSE IF( liwork < liwmin .AND. .NOT.lquery ) THEN info = -13 END IF ! IF( info == 0 ) THEN work( 1 ) = lwmin iwork( 1 ) = liwmin END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSBEVD', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! IF( n == 1 ) THEN w( 1 ) = ab( 1, 1 ) IF( wantz ) z( 1, 1 ) = one RETURN END IF ! ! Get machine constants. ! safmin = slamch( 'Safe minimum' ) eps = slamch( 'Precision' ) smlnum = safmin / eps bignum = one / smlnum rmin = SQRT( smlnum ) rmax = SQRT( bignum ) ! ! Scale matrix to allowable range, if necessary. ! anrm = slansb( 'M', uplo, n, kd, ab, ldab, work ) iscale = 0 IF( anrm > zero .AND. anrm < rmin ) THEN iscale = 1 sigma = rmin / anrm ELSE IF( anrm > rmax ) THEN iscale = 1 sigma = rmax / anrm END IF IF( iscale == 1 ) THEN IF( lower ) THEN CALL slascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) ELSE CALL slascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) END IF END IF ! ! Call SSBTRD to reduce symmetric band matrix to tridiagonal form. ! inde = 1 indwrk = inde + n indwk2 = indwrk + n*n llwrk2 = lwork - indwk2 + 1 CALL ssbtrd( jobz, uplo, n, kd, ab, ldab, w, work( inde ), z, ldz, & work( indwrk ), iinfo ) ! ! For eigenvalues only, call SSTERF. For eigenvectors, call SSTEDC. ! IF( .NOT.wantz ) THEN CALL ssterf( n, w, work( inde ), info ) ELSE CALL sstedc( 'I', n, w, work( inde ), work( indwrk ), n, & work( indwk2 ), llwrk2, iwork, liwork, info ) CALL sgemm( 'N', 'N', n, n, n, one, z, ldz, work( indwrk ), n, & zero, work( indwk2 ), n ) CALL slacpy( 'A', n, n, work( indwk2 ), n, z, ldz ) END IF ! ! If matrix was scaled, then rescale eigenvalues appropriately. ! IF( iscale == 1 ) CALL sscal( n, one / sigma, w, 1 ) ! work( 1 ) = lwmin iwork( 1 ) = liwmin RETURN ! ! End of SSBEVD ! END SUBROUTINE ssbevd SUBROUTINE ssbevx( jobz, range, uplo, n, kd, ab, ldab, q, ldq, vl, & vu, il, iu, abstol, m, w, z, ldz, work, 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 (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: range CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: kd REAL, INTENT(IN) :: ab( ldab, * ) INTEGER, INTENT(IN) :: ldab REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq REAL, INTENT(IN) :: vl REAL, INTENT(IN) :: vu INTEGER, INTENT(IN) :: il INTEGER, INTENT(IN) :: iu REAL, INTENT(IN) :: abstol INTEGER, INTENT(OUT) :: m REAL, INTENT(OUT) :: w( * ) REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN) :: ldz REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: ifail( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSBEVX computes selected eigenvalues and, optionally, eigenvectors ! of a real symmetric band 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. ! ! KD (input) INTEGER ! The number of superdiagonals of the matrix A if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KD >= 0. ! ! AB (input/output) REAL array, dimension (LDAB, N) ! On entry, the upper or lower triangle of the symmetric band ! matrix A, stored in the first KD+1 rows of the array. The ! j-th column of A is stored in the j-th column of the array AB ! as follows: ! if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). ! ! On exit, AB is overwritten by values generated during the ! reduction to tridiagonal form. If UPLO = 'U', the first ! superdiagonal and the diagonal of the tridiagonal matrix T ! are returned in rows KD and KD+1 of AB, and if UPLO = 'L', ! the diagonal and first subdiagonal of T are returned in the ! first two rows of AB. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KD + 1. ! ! Q (output) REAL array, dimension (LDQ, N) ! If JOBZ = 'V', the N-by-N orthogonal matrix used in the ! reduction to tridiagonal form. ! If JOBZ = 'N', the array Q is not referenced. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. If JOBZ = 'V', then ! LDQ >= max(1,N). ! ! VL (input) REAL ! VU (input) REAL ! 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) REAL ! 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 AB to tridiagonal form. ! ! Eigenvalues will be computed most accurately when ABSTOL is ! set to twice the underflow threshold 2*SLAMCH('S'), not zero. ! If this routine returns with INFO>0, indicating that some ! eigenvectors did not converge, try setting ABSTOL to ! 2*SLAMCH('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) REAL array, dimension (N) ! The first M elements contain the selected eigenvalues in ! ascending order. ! ! Z (output) REAL 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) REAL 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 .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: alleig, indeig, lower, valeig, wantz CHARACTER (LEN=1) :: order INTEGER :: i, iinfo, imax, indd, inde, indee, indibl, & indisp, indiwo, indwrk, iscale, itmp1, j, jj, nsplit REAL :: abstll, anrm, bignum, eps, rmax, rmin, safmin, & sigma, smlnum, tmp1, vll, vuu ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slansb EXTERNAL lsame, slamch, slansb ! .. ! .. External Subroutines .. EXTERNAL scopy, sgemv, slacpy, slascl, ssbtrd, sscal, & sstebz, sstein, ssteqr, ssterf, sswap, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! wantz = lsame( jobz, 'V' ) alleig = lsame( range, 'A' ) valeig = lsame( range, 'V' ) indeig = lsame( range, 'I' ) lower = lsame( uplo, 'L' ) ! 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 < 0 ) THEN info = -4 ELSE IF( kd < 0 ) THEN info = -5 ELSE IF( ldab < kd+1 ) THEN info = -7 ELSE IF( wantz .AND. ldq < MAX( 1, n ) ) THEN info = -9 ELSE IF( valeig ) THEN IF( n > 0 .AND. vu <= vl ) info = -11 ELSE IF( indeig ) THEN IF( il < 1 .OR. il > MAX( 1, n ) ) THEN info = -12 ELSE IF( iu < MIN( n, il ) .OR. iu > n ) THEN info = -13 END IF END IF END IF IF( info == 0 ) THEN IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) info = -18 END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSBEVX', -info ) RETURN END IF ! ! Quick return if possible ! m = 0 IF( n == 0 ) RETURN ! IF( n == 1 ) THEN m = 1 IF( lower ) THEN tmp1 = ab( 1, 1 ) ELSE tmp1 = ab( kd+1, 1 ) END IF IF( valeig ) THEN IF( .NOT.( vl < tmp1 .AND. vu >= tmp1 ) ) m = 0 END IF IF( m == 1 ) THEN w( 1 ) = tmp1 IF( wantz ) z( 1, 1 ) = one END IF RETURN END IF ! ! Get machine constants. ! safmin = slamch( 'Safe minimum' ) eps = slamch( '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 IF ( valeig ) THEN vll = vl vuu = vu ELSE vll = zero vuu = zero END IF anrm = slansb( 'M', uplo, n, kd, ab, ldab, work ) IF( anrm > zero .AND. anrm < rmin ) THEN iscale = 1 sigma = rmin / anrm ELSE IF( anrm > rmax ) THEN iscale = 1 sigma = rmax / anrm END IF IF( iscale == 1 ) THEN IF( lower ) THEN CALL slascl( 'B', kd, kd, one, sigma, n, n, ab, ldab, info ) ELSE CALL slascl( 'Q', kd, kd, one, sigma, n, n, ab, ldab, info ) END IF IF( abstol > 0 ) abstll = abstol*sigma IF( valeig ) THEN vll = vl*sigma vuu = vu*sigma END IF END IF ! ! Call SSBTRD to reduce symmetric band matrix to tridiagonal form. ! indd = 1 inde = indd + n indwrk = inde + n CALL ssbtrd( jobz, uplo, n, kd, ab, ldab, work( indd ), & work( inde ), q, ldq, work( indwrk ), iinfo ) ! ! If all eigenvalues are desired and ABSTOL is less than or equal ! to zero, then call SSTERF or SSTEQR. If this fails for some ! eigenvalue, then try SSTEBZ. ! IF( ( alleig .OR. ( indeig .AND. il == 1 .AND. iu == n ) ) .AND. & ( abstol <= zero ) ) THEN CALL scopy( n, work( indd ), 1, w, 1 ) indee = indwrk + 2*n IF( .NOT.wantz ) THEN CALL scopy( n-1, work( inde ), 1, work( indee ), 1 ) CALL ssterf( n, w, work( indee ), info ) ELSE CALL slacpy( 'A', n, n, q, ldq, z, ldz ) CALL scopy( n-1, work( inde ), 1, work( indee ), 1 ) CALL ssteqr( jobz, n, w, work( indee ), z, ldz, work( indwrk ), info ) IF( info == 0 ) THEN DO i = 1, n ifail( i ) = 0 END DO END IF END IF IF( info == 0 ) THEN m = n GO TO 30 END IF info = 0 END IF ! ! Otherwise, call SSTEBZ 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 sstebz( 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 sstein( 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 SSTEIN. ! DO j = 1, m CALL scopy( n, z( 1, j ), 1, work( 1 ), 1 ) CALL sgemv( 'N', n, n, one, q, ldq, work, 1, zero, z( 1, j ), 1 ) END DO END IF ! ! If matrix was scaled, then rescale eigenvalues appropriately. ! 30 CONTINUE IF( iscale == 1 ) THEN IF( info == 0 ) THEN imax = m ELSE imax = info - 1 END IF CALL sscal( imax, one / sigma, w, 1 ) END IF ! ! If eigenvalues are not in order, then sort them, along with ! eigenvectors. ! IF( wantz ) THEN DO j = 1, m - 1 i = 0 tmp1 = w( j ) DO jj = j + 1, m IF( w( jj ) < tmp1 ) THEN i = jj tmp1 = w( jj ) END IF END DO ! IF( i /= 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 sswap( n, z( 1, i ), 1, z( 1, j ), 1 ) IF( info /= 0 ) THEN itmp1 = ifail( i ) ifail( i ) = ifail( j ) ifail( j ) = itmp1 END IF END IF END DO END IF ! RETURN ! ! End of SSBEVX ! END SUBROUTINE ssbevx SUBROUTINE ssbgst( vect, uplo, n, ka, kb, ab, ldab, bb, ldbb, x, & ldx, 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 .. CHARACTER (LEN=1), INTENT(IN) :: vect CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN OUT) :: ka INTEGER, INTENT(IN OUT) :: kb REAL, INTENT(OUT) :: ab( ldab, * ) INTEGER, INTENT(IN) :: ldab REAL, INTENT(IN) :: bb( ldbb, * ) INTEGER, INTENT(IN OUT) :: ldbb REAL, INTENT(IN OUT) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSBGST reduces a real symmetric-definite banded generalized ! eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y, ! such that C has the same bandwidth as A. ! ! B must have been previously factorized as S**T*S by SPBSTF, using a ! split Cholesky factorization. A is overwritten by C = X**T*A*X, where ! X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the ! bandwidth of A. ! ! Arguments ! ========= ! ! VECT (input) CHARACTER*1 ! = 'N': do not form the transformation matrix X; ! = 'V': form X. ! ! 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 matrices A and B. N >= 0. ! ! KA (input) INTEGER ! The number of superdiagonals of the matrix A if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KA >= 0. ! ! KB (input) INTEGER ! The number of superdiagonals of the matrix B if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0. ! ! AB (input/output) REAL array, dimension (LDAB,N) ! On entry, the upper or lower triangle of the symmetric band ! matrix A, stored in the first ka+1 rows of the array. The ! j-th column of A is stored in the j-th column of the array AB ! as follows: ! if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). ! ! On exit, the transformed matrix X**T*A*X, stored in the same ! format as A. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KA+1. ! ! BB (input) REAL array, dimension (LDBB,N) ! The banded factor S from the split Cholesky factorization of ! B, as returned by SPBSTF, stored in the first KB+1 rows of ! the array. ! ! LDBB (input) INTEGER ! The leading dimension of the array BB. LDBB >= KB+1. ! ! X (output) REAL array, dimension (LDX,N) ! If VECT = 'V', the n-by-n matrix X. ! If VECT = 'N', the array X is not referenced. ! ! LDX (input) INTEGER ! The leading dimension of the array X. ! LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise. ! ! WORK (workspace) REAL array, dimension (2*N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: update, upper, wantx INTEGER :: i, i0, i1, i2, inca, j, j1, j1t, j2, j2t, k, & ka1, kb1, kbt, l, m, nr, nrt, nx REAL :: bii, ra, ra1, t ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL sger, slar2v, slargv, slartg, slartv, slaset, & srot, sscal, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. Executable Statements .. ! ! Test the input parameters ! wantx = lsame( vect, 'V' ) upper = lsame( uplo, 'U' ) ka1 = ka + 1 kb1 = kb + 1 info = 0 IF( .NOT.wantx .AND. .NOT.lsame( vect, 'N' ) ) THEN info = -1 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( ka < 0 ) THEN info = -4 ELSE IF( kb < 0 ) THEN info = -5 ELSE IF( ldab < ka+1 ) THEN info = -7 ELSE IF( ldbb < kb+1 ) THEN info = -9 ELSE IF( ldx < 1 .OR. wantx .AND. ldx < MAX( 1, n ) ) THEN info = -11 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSBGST', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! inca = ldab*ka1 ! ! Initialize X to the unit matrix, if needed ! IF( wantx ) CALL slaset( 'Full', n, n, zero, one, x, ldx ) ! ! Set M to the splitting point m. It must be the same value as is ! used in SPBSTF. The chosen value allows the arrays WORK and RWORK ! to be of dimension (N). ! m = ( n+kb ) / 2 ! ! The routine works in two phases, corresponding to the two halves ! of the split Cholesky factorization of B as S**T*S where ! ! S = ( U ) ! ( M L ) ! ! with U upper triangular of order m, and L lower triangular of ! order n-m. S has the same bandwidth as B. ! ! S is treated as a product of elementary matrices: ! ! S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n) ! ! where S(i) is determined by the i-th row of S. ! ! In phase 1, the index i takes the values n, n-1, ... , m+1; ! in phase 2, it takes the values 1, 2, ... , m. ! ! For each value of i, the current matrix A is updated by forming ! inv(S(i))**T*A*inv(S(i)). This creates a triangular bulge outside ! the band of A. The bulge is then pushed down toward the bottom of ! A in phase 1, and up toward the top of A in phase 2, by applying ! plane rotations. ! ! There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1 ! of them are linearly independent, so annihilating a bulge requires ! only 2*kb-1 plane rotations. The rotations are divided into a 1st ! set of kb-1 rotations, and a 2nd set of kb rotations. ! ! Wherever possible, rotations are generated and applied in vector ! operations of length NR between the indices J1 and J2 (sometimes ! replaced by modified values NRT, J1T or J2T). ! ! The cosines and sines of the rotations are stored in the array ! WORK. The cosines of the 1st set of rotations are stored in ! elements n+2:n+m-kb-1 and the sines of the 1st set in elements ! 2:m-kb-1; the cosines of the 2nd set are stored in elements ! n+m-kb+1:2*n and the sines of the second set in elements m-kb+1:n. ! ! The bulges are not formed explicitly; nonzero elements outside the ! band are created only when they are required for generating new ! rotations; they are stored in the array WORK, in positions where ! they are later overwritten by the sines of the rotations which ! annihilate them. ! ! **************************** Phase 1 ***************************** ! ! The logical structure of this phase is: ! ! UPDATE = .TRUE. ! DO I = N, M + 1, -1 ! use S(i) to update A and create a new bulge ! apply rotations to push all bulges KA positions downward ! END DO ! UPDATE = .FALSE. ! DO I = M + KA + 1, N - 1 ! apply rotations to push all bulges KA positions downward ! END DO ! ! To avoid duplicating code, the two loops are merged. ! update = .true. i = n + 1 10 CONTINUE IF( update ) THEN i = i - 1 kbt = MIN( kb, i-1 ) i0 = i - 1 i1 = MIN( n, i+ka ) i2 = i - kbt + ka1 IF( i < m+1 ) THEN update = .false. i = i + 1 i0 = m IF( ka == 0 ) GO TO 480 GO TO 10 END IF ELSE i = i + ka IF( i > n-1 ) GO TO 480 END IF ! IF( upper ) THEN ! ! Transform A, working with the upper triangle ! IF( update ) THEN ! ! Form inv(S(i))**T * A * inv(S(i)) ! bii = bb( kb1, i ) DO j = i, i1 ab( i-j+ka1, j ) = ab( i-j+ka1, j ) / bii END DO DO j = MAX( 1, i-ka ), i ab( j-i+ka1, i ) = ab( j-i+ka1, i ) / bii END DO DO k = i - kbt, i - 1 DO j = i - kbt, k ab( j-k+ka1, k ) = ab( j-k+ka1, k ) - & bb( j-i+kb1, i )*ab( k-i+ka1, i ) - & bb( k-i+kb1, i )*ab( j-i+ka1, i ) + ab( ka1, i )*bb( j-i+kb1, i )* & bb( k-i+kb1, i ) END DO DO j = MAX( 1, i-ka ), i - kbt - 1 ab( j-k+ka1, k ) = ab( j-k+ka1, k ) - & bb( k-i+kb1, i )*ab( j-i+ka1, i ) END DO END DO DO j = i, i1 DO k = MAX( j-ka, i-kbt ), i - 1 ab( k-j+ka1, j ) = ab( k-j+ka1, j ) - & bb( k-i+kb1, i )*ab( i-j+ka1, j ) END DO END DO ! IF( wantx ) THEN ! ! post-multiply X by inv(S(i)) ! CALL sscal( n-m, one / bii, x( m+1, i ), 1 ) IF( kbt > 0 ) CALL sger( n-m, kbt, -one, x( m+1, i ), 1, & bb( kb1-kbt, i ), 1, x( m+1, i-kbt ), ldx ) END IF ! ! store a(i,i1) in RA1 for use in next loop over K ! ra1 = ab( i-i1+ka1, i1 ) END IF ! ! Generate and apply vectors of rotations to chase all the ! existing bulges KA positions down toward the bottom of the ! band ! DO k = 1, kb - 1 IF( update ) THEN ! ! Determine the rotations which would annihilate the bulge ! which has in theory just been created ! IF( i-k+ka < n .AND. i-k > 1 ) THEN ! ! generate rotation to annihilate a(i,i-k+ka+1) ! CALL slartg( ab( k+1, i-k+ka ), ra1, & work( n+i-k+ka-m ), work( i-k+ka-m ), ra ) ! ! create nonzero element a(i-k,i-k+ka+1) outside the ! band and store it in WORK(i-k) ! t = -bb( kb1-k, i )*ra1 work( i-k ) = work( n+i-k+ka-m )*t - work( i-k+ka-m )*ab( 1, i-k+ka ) ab( 1, i-k+ka ) = work( i-k+ka-m )*t + & work( n+i-k+ka-m )*ab( 1, i-k+ka ) ra1 = ra END IF END IF j2 = i - k - 1 + MAX( 1, k-i0+2 )*ka1 nr = ( n-j2+ka ) / ka1 j1 = j2 + ( nr-1 )*ka1 IF( update ) THEN j2t = MAX( j2, i+2*ka-k+1 ) ELSE j2t = j2 END IF nrt = ( n-j2t+ka ) / ka1 DO j = j2t, j1, ka1 ! ! create nonzero element a(j-ka,j+1) outside the band ! and store it in WORK(j-m) ! work( j-m ) = work( j-m )*ab( 1, j+1 ) ab( 1, j+1 ) = work( n+j-m )*ab( 1, j+1 ) END DO ! ! generate rotations in 1st set to annihilate elements which ! have been created outside the band ! IF( nrt > 0 ) & CALL slargv( nrt, ab( 1, j2t ), inca, work( j2t-m ), ka1, & work( n+j2t-m ), ka1 ) IF( nr > 0 ) THEN ! ! apply rotations in 1st set from the right ! DO l = 1, ka - 1 CALL slartv( nr, ab( ka1-l, j2 ), inca, & ab( ka-l, j2+1 ), inca, work( n+j2-m ), work( j2-m ), ka1 ) END DO ! ! apply rotations in 1st set from both sides to diagonal ! blocks ! CALL slar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ), & ab( ka, j2+1 ), inca, work( n+j2-m ), work( j2-m ), ka1 ) ! END IF ! ! start applying rotations in 1st set from the left ! DO l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 IF( nrt > 0 ) CALL slartv( nrt, ab( l, j2+ka1-l ), inca, & ab( l+1, j2+ka1-l ), inca, work( n+j2-m ), work( j2-m ), ka1 ) END DO ! IF( wantx ) THEN ! ! post-multiply X by product of rotations in 1st set ! DO j = j2, j1, ka1 CALL srot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1, & work( n+j-m ), work( j-m ) ) END DO END IF END DO ! IF( update ) THEN IF( i2 <= n .AND. kbt > 0 ) THEN ! ! create nonzero element a(i-kbt,i-kbt+ka+1) outside the ! band and store it in WORK(i-kbt) ! work( i-kbt ) = -bb( kb1-kbt, i )*ra1 END IF END IF ! DO k = kb, 1, -1 IF( update ) THEN j2 = i - k - 1 + MAX( 2, k-i0+1 )*ka1 ELSE j2 = i - k - 1 + MAX( 1, k-i0+1 )*ka1 END IF ! ! finish applying rotations in 2nd set from the left ! DO l = kb - k, 1, -1 nrt = ( n-j2+ka+l ) / ka1 IF( nrt > 0 ) CALL slartv( nrt, ab( l, j2-l+1 ), inca, & ab( l+1, j2-l+1 ), inca, work( n+j2-ka ), work( j2-ka ), ka1 ) END DO nr = ( n-j2+ka ) / ka1 j1 = j2 + ( nr-1 )*ka1 DO j = j1, j2, -ka1 work( j ) = work( j-ka ) work( n+j ) = work( n+j-ka ) END DO DO j = j2, j1, ka1 ! ! create nonzero element a(j-ka,j+1) outside the band ! and store it in WORK(j) ! work( j ) = work( j )*ab( 1, j+1 ) ab( 1, j+1 ) = work( n+j )*ab( 1, j+1 ) END DO IF( update ) THEN IF( i-k < n-ka .AND. k <= kbt ) work( i-k+ka ) = work( i-k ) END IF END DO ! DO k = kb, 1, -1 j2 = i - k - 1 + MAX( 1, k-i0+1 )*ka1 nr = ( n-j2+ka ) / ka1 j1 = j2 + ( nr-1 )*ka1 IF( nr > 0 ) THEN ! ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band ! CALL slargv( nr, ab( 1, j2 ), inca, work( j2 ), ka1, work( n+j2 ), ka1 ) ! ! apply rotations in 2nd set from the right ! DO l = 1, ka - 1 CALL slartv( nr, ab( ka1-l, j2 ), inca, & ab( ka-l, j2+1 ), inca, work( n+j2 ), work( j2 ), ka1 ) END DO ! ! apply rotations in 2nd set from both sides to diagonal ! blocks ! CALL slar2v( nr, ab( ka1, j2 ), ab( ka1, j2+1 ), & ab( ka, j2+1 ), inca, work( n+j2 ), work( j2 ), ka1 ) ! END IF ! ! start applying rotations in 2nd set from the left ! DO l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 IF( nrt > 0 ) CALL slartv( nrt, ab( l, j2+ka1-l ), inca, & ab( l+1, j2+ka1-l ), inca, work( n+j2 ), work( j2 ), ka1 ) END DO ! IF( wantx ) THEN ! ! post-multiply X by product of rotations in 2nd set ! DO j = j2, j1, ka1 CALL srot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1, & work( n+j ), work( j ) ) END DO END IF END DO ! DO k = 1, kb - 1 j2 = i - k - 1 + MAX( 1, k-i0+2 )*ka1 ! ! finish applying rotations in 1st set from the left ! DO l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 IF( nrt > 0 ) CALL slartv( nrt, ab( l, j2+ka1-l ), inca, & ab( l+1, j2+ka1-l ), inca, work( n+j2-m ), work( j2-m ), ka1 ) END DO END DO ! IF( kb > 1 ) THEN DO j = n - 1, i - kb + 2*ka + 1, -1 work( n+j-m ) = work( n+j-ka-m ) work( j-m ) = work( j-ka-m ) END DO END IF ! ELSE ! ! Transform A, working with the lower triangle ! IF( update ) THEN ! ! Form inv(S(i))**T * A * inv(S(i)) ! bii = bb( 1, i ) DO j = i, i1 ab( j-i+1, i ) = ab( j-i+1, i ) / bii END DO DO j = MAX( 1, i-ka ), i ab( i-j+1, j ) = ab( i-j+1, j ) / bii END DO DO k = i - kbt, i - 1 DO j = i - kbt, k ab( k-j+1, j ) = ab( k-j+1, j ) - bb( i-j+1, j )*ab( i-k+1, k ) - & bb( i-k+1, k )*ab( i-j+1, j ) + ab( 1, i )*bb( i-j+1, j )* & bb( i-k+1, k ) END DO DO j = MAX( 1, i-ka ), i - kbt - 1 ab( k-j+1, j ) = ab( k-j+1, j ) - bb( i-k+1, k )*ab( i-j+1, j ) END DO END DO DO j = i, i1 DO k = MAX( j-ka, i-kbt ), i - 1 ab( j-k+1, k ) = ab( j-k+1, k ) - bb( i-k+1, k )*ab( j-i+1, i ) END DO END DO ! IF( wantx ) THEN ! ! post-multiply X by inv(S(i)) ! CALL sscal( n-m, one / bii, x( m+1, i ), 1 ) IF( kbt > 0 ) CALL sger( n-m, kbt, -one, x( m+1, i ), 1, & bb( kbt+1, i-kbt ), ldbb-1, x( m+1, i-kbt ), ldx ) END IF ! ! store a(i1,i) in RA1 for use in next loop over K ! ra1 = ab( i1-i+1, i ) END IF ! ! Generate and apply vectors of rotations to chase all the ! existing bulges KA positions down toward the bottom of the ! band ! DO k = 1, kb - 1 IF( update ) THEN ! ! Determine the rotations which would annihilate the bulge ! which has in theory just been created ! IF( i-k+ka < n .AND. i-k > 1 ) THEN ! ! generate rotation to annihilate a(i-k+ka+1,i) ! CALL slartg( ab( ka1-k, i ), ra1, work( n+i-k+ka-m ), & work( i-k+ka-m ), ra ) ! ! create nonzero element a(i-k+ka+1,i-k) outside the ! band and store it in WORK(i-k) ! t = -bb( k+1, i-k )*ra1 work( i-k ) = work( n+i-k+ka-m )*t - work( i-k+ka-m )*ab( ka1, i-k ) ab( ka1, i-k ) = work( i-k+ka-m )*t + & work( n+i-k+ka-m )*ab( ka1, i-k ) ra1 = ra END IF END IF j2 = i - k - 1 + MAX( 1, k-i0+2 )*ka1 nr = ( n-j2+ka ) / ka1 j1 = j2 + ( nr-1 )*ka1 IF( update ) THEN j2t = MAX( j2, i+2*ka-k+1 ) ELSE j2t = j2 END IF nrt = ( n-j2t+ka ) / ka1 DO j = j2t, j1, ka1 ! ! create nonzero element a(j+1,j-ka) outside the band ! and store it in WORK(j-m) ! work( j-m ) = work( j-m )*ab( ka1, j-ka+1 ) ab( ka1, j-ka+1 ) = work( n+j-m )*ab( ka1, j-ka+1 ) END DO ! ! generate rotations in 1st set to annihilate elements which ! have been created outside the band ! IF( nrt > 0 ) & CALL slargv( nrt, ab( ka1, j2t-ka ), inca, work( j2t-m ), & ka1, work( n+j2t-m ), ka1 ) IF( nr > 0 ) THEN ! ! apply rotations in 1st set from the left ! DO l = 1, ka - 1 CALL slartv( nr, ab( l+1, j2-l ), inca, & ab( l+2, j2-l ), inca, work( n+j2-m ), work( j2-m ), ka1 ) END DO ! ! apply rotations in 1st set from both sides to diagonal ! blocks ! CALL slar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ), & inca, work( n+j2-m ), work( j2-m ), ka1 ) ! END IF ! ! start applying rotations in 1st set from the right ! DO l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 IF( nrt > 0 ) CALL slartv( nrt, ab( ka1-l+1, j2 ), inca, & ab( ka1-l, j2+1 ), inca, work( n+j2-m ), work( j2-m ), ka1 ) END DO ! IF( wantx ) THEN ! ! post-multiply X by product of rotations in 1st set ! DO j = j2, j1, ka1 CALL srot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1, & work( n+j-m ), work( j-m ) ) END DO END IF END DO ! IF( update ) THEN IF( i2 <= n .AND. kbt > 0 ) THEN ! ! create nonzero element a(i-kbt+ka+1,i-kbt) outside the ! band and store it in WORK(i-kbt) ! work( i-kbt ) = -bb( kbt+1, i-kbt )*ra1 END IF END IF ! DO k = kb, 1, -1 IF( update ) THEN j2 = i - k - 1 + MAX( 2, k-i0+1 )*ka1 ELSE j2 = i - k - 1 + MAX( 1, k-i0+1 )*ka1 END IF ! ! finish applying rotations in 2nd set from the right ! DO l = kb - k, 1, -1 nrt = ( n-j2+ka+l ) / ka1 IF( nrt > 0 ) CALL slartv( nrt, ab( ka1-l+1, j2-ka ), inca, & ab( ka1-l, j2-ka+1 ), inca, work( n+j2-ka ), work( j2-ka ), ka1 ) END DO nr = ( n-j2+ka ) / ka1 j1 = j2 + ( nr-1 )*ka1 DO j = j1, j2, -ka1 work( j ) = work( j-ka ) work( n+j ) = work( n+j-ka ) END DO DO j = j2, j1, ka1 ! ! create nonzero element a(j+1,j-ka) outside the band ! and store it in WORK(j) ! work( j ) = work( j )*ab( ka1, j-ka+1 ) ab( ka1, j-ka+1 ) = work( n+j )*ab( ka1, j-ka+1 ) END DO IF( update ) THEN IF( i-k < n-ka .AND. k <= kbt ) work( i-k+ka ) = work( i-k ) END IF END DO ! DO k = kb, 1, -1 j2 = i - k - 1 + MAX( 1, k-i0+1 )*ka1 nr = ( n-j2+ka ) / ka1 j1 = j2 + ( nr-1 )*ka1 IF( nr > 0 ) THEN ! ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band ! CALL slargv( nr, ab( ka1, j2-ka ), inca, work( j2 ), ka1, & work( n+j2 ), ka1 ) ! ! apply rotations in 2nd set from the left ! DO l = 1, ka - 1 CALL slartv( nr, ab( l+1, j2-l ), inca, & ab( l+2, j2-l ), inca, work( n+j2 ), work( j2 ), ka1 ) END DO ! ! apply rotations in 2nd set from both sides to diagonal ! blocks ! CALL slar2v( nr, ab( 1, j2 ), ab( 1, j2+1 ), ab( 2, j2 ), & inca, work( n+j2 ), work( j2 ), ka1 ) ! END IF ! ! start applying rotations in 2nd set from the right ! DO l = ka - 1, kb - k + 1, -1 nrt = ( n-j2+l ) / ka1 IF( nrt > 0 ) CALL slartv( nrt, ab( ka1-l+1, j2 ), inca, & ab( ka1-l, j2+1 ), inca, work( n+j2 ), work( j2 ), ka1 ) END DO ! IF( wantx ) THEN ! ! post-multiply X by product of rotations in 2nd set ! DO j = j2, j1, ka1 CALL srot( n-m, x( m+1, j ), 1, x( m+1, j+1 ), 1, & work( n+j ), work( j ) ) END DO END IF END DO ! DO k = 1, kb - 1 j2 = i - k - 1 + MAX( 1, k-i0+2 )*ka1 ! ! finish applying rotations in 1st set from the right ! DO l = kb - k, 1, -1 nrt = ( n-j2+l ) / ka1 IF( nrt > 0 ) CALL slartv( nrt, ab( ka1-l+1, j2 ), inca, & ab( ka1-l, j2+1 ), inca, work( n+j2-m ), work( j2-m ), ka1 ) END DO END DO ! IF( kb > 1 ) THEN DO j = n - 1, i - kb + 2*ka + 1, -1 work( n+j-m ) = work( n+j-ka-m ) work( j-m ) = work( j-ka-m ) END DO END IF ! END IF ! GO TO 10 ! 480 CONTINUE ! ! **************************** Phase 2 ***************************** ! ! The logical structure of this phase is: ! ! UPDATE = .TRUE. ! DO I = 1, M ! use S(i) to update A and create a new bulge ! apply rotations to push all bulges KA positions upward ! END DO ! UPDATE = .FALSE. ! DO I = M - KA - 1, 2, -1 ! apply rotations to push all bulges KA positions upward ! END DO ! ! To avoid duplicating code, the two loops are merged. ! update = .true. i = 0 490 CONTINUE IF( update ) THEN i = i + 1 kbt = MIN( kb, m-i ) i0 = i + 1 i1 = MAX( 1, i-ka ) i2 = i + kbt - ka1 IF( i > m ) THEN update = .false. i = i - 1 i0 = m + 1 IF( ka == 0 ) RETURN GO TO 490 END IF ELSE i = i - ka IF( i < 2 ) RETURN END IF ! IF( i < m-kbt ) THEN nx = m ELSE nx = n END IF ! IF( upper ) THEN ! ! Transform A, working with the upper triangle ! IF( update ) THEN ! ! Form inv(S(i))**T * A * inv(S(i)) ! bii = bb( kb1, i ) DO j = i1, i ab( j-i+ka1, i ) = ab( j-i+ka1, i ) / bii END DO DO j = i, MIN( n, i+ka ) ab( i-j+ka1, j ) = ab( i-j+ka1, j ) / bii END DO DO k = i + 1, i + kbt DO j = k, i + kbt ab( k-j+ka1, j ) = ab( k-j+ka1, j ) - & bb( i-j+kb1, j )*ab( i-k+ka1, k ) - & bb( i-k+kb1, k )*ab( i-j+ka1, j ) + ab( ka1, i )*bb( i-j+kb1, j )* & bb( i-k+kb1, k ) END DO DO j = i + kbt + 1, MIN( n, i+ka ) ab( k-j+ka1, j ) = ab( k-j+ka1, j ) - & bb( i-k+kb1, k )*ab( i-j+ka1, j ) END DO END DO DO j = i1, i DO k = i + 1, MIN( j+ka, i+kbt ) ab( j-k+ka1, k ) = ab( j-k+ka1, k ) - & bb( i-k+kb1, k )*ab( j-i+ka1, i ) END DO END DO ! IF( wantx ) THEN ! ! post-multiply X by inv(S(i)) ! CALL sscal( nx, one / bii, x( 1, i ), 1 ) IF( kbt > 0 ) CALL sger( nx, kbt, -one, x( 1, i ), 1, bb( kb, i+1 ), & ldbb-1, x( 1, i+1 ), ldx ) END IF ! ! store a(i1,i) in RA1 for use in next loop over K ! ra1 = ab( i1-i+ka1, i ) END IF ! ! Generate and apply vectors of rotations to chase all the ! existing bulges KA positions up toward the top of the band ! DO k = 1, kb - 1 IF( update ) THEN ! ! Determine the rotations which would annihilate the bulge ! which has in theory just been created ! IF( i+k-ka1 > 0 .AND. i+k < m ) THEN ! ! generate rotation to annihilate a(i+k-ka-1,i) ! CALL slartg( ab( k+1, i ), ra1, work( n+i+k-ka ), work( i+k-ka ), ra ) ! ! create nonzero element a(i+k-ka-1,i+k) outside the ! band and store it in WORK(m-kb+i+k) ! t = -bb( kb1-k, i+k )*ra1 work( m-kb+i+k ) = work( n+i+k-ka )*t - work( i+k-ka )*ab( 1, i+k ) ab( 1, i+k ) = work( i+k-ka )*t + work( n+i+k-ka )*ab( 1, i+k ) ra1 = ra END IF END IF j2 = i + k + 1 - MAX( 1, k+i0-m+1 )*ka1 nr = ( j2+ka-1 ) / ka1 j1 = j2 - ( nr-1 )*ka1 IF( update ) THEN j2t = MIN( j2, i-2*ka+k-1 ) ELSE j2t = j2 END IF nrt = ( j2t+ka-1 ) / ka1 DO j = j1, j2t, ka1 ! ! create nonzero element a(j-1,j+ka) outside the band ! and store it in WORK(j) ! work( j ) = work( j )*ab( 1, j+ka-1 ) ab( 1, j+ka-1 ) = work( n+j )*ab( 1, j+ka-1 ) END DO ! ! generate rotations in 1st set to annihilate elements which ! have been created outside the band ! IF( nrt > 0 ) CALL slargv( nrt, ab( 1, j1+ka ), inca, work( j1 ), ka1, & work( n+j1 ), ka1 ) IF( nr > 0 ) THEN ! ! apply rotations in 1st set from the left ! DO l = 1, ka - 1 CALL slartv( nr, ab( ka1-l, j1+l ), inca, & ab( ka-l, j1+l ), inca, work( n+j1 ), work( j1 ), ka1 ) END DO ! ! apply rotations in 1st set from both sides to diagonal ! blocks ! CALL slar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ), & ab( ka, j1 ), inca, work( n+j1 ), work( j1 ), ka1 ) ! END IF ! ! start applying rotations in 1st set from the right ! DO l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 IF( nrt > 0 ) CALL slartv( nrt, ab( l, j1t ), inca, & ab( l+1, j1t-1 ), inca, work( n+j1t ), work( j1t ), ka1 ) END DO ! IF( wantx ) THEN ! ! post-multiply X by product of rotations in 1st set ! DO j = j1, j2, ka1 CALL srot( nx, x( 1, j ), 1, x( 1, j-1 ), 1, work( n+j ), work( j ) ) END DO END IF END DO ! IF( update ) THEN IF( i2 > 0 .AND. kbt > 0 ) THEN ! ! create nonzero element a(i+kbt-ka-1,i+kbt) outside the ! band and store it in WORK(m-kb+i+kbt) ! work( m-kb+i+kbt ) = -bb( kb1-kbt, i+kbt )*ra1 END IF END IF ! DO k = kb, 1, -1 IF( update ) THEN j2 = i + k + 1 - MAX( 2, k+i0-m )*ka1 ELSE j2 = i + k + 1 - MAX( 1, k+i0-m )*ka1 END IF ! ! finish applying rotations in 2nd set from the right ! DO l = kb - k, 1, -1 nrt = ( j2+ka+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 IF( nrt > 0 ) CALL slartv( nrt, ab( l, j1t+ka ), inca, & ab( l+1, j1t+ka-1 ), inca, work( n+m-kb+j1t+ka ), & work( m-kb+j1t+ka ), ka1 ) END DO nr = ( j2+ka-1 ) / ka1 j1 = j2 - ( nr-1 )*ka1 DO j = j1, j2, ka1 work( m-kb+j ) = work( m-kb+j+ka ) work( n+m-kb+j ) = work( n+m-kb+j+ka ) END DO DO j = j1, j2, ka1 ! ! create nonzero element a(j-1,j+ka) outside the band ! and store it in WORK(m-kb+j) ! work( m-kb+j ) = work( m-kb+j )*ab( 1, j+ka-1 ) ab( 1, j+ka-1 ) = work( n+m-kb+j )*ab( 1, j+ka-1 ) END DO IF( update ) THEN IF( i+k > ka1 .AND. k <= kbt ) work( m-kb+i+k-ka ) = work( m-kb+i+k ) END IF END DO ! DO k = kb, 1, -1 j2 = i + k + 1 - MAX( 1, k+i0-m )*ka1 nr = ( j2+ka-1 ) / ka1 j1 = j2 - ( nr-1 )*ka1 IF( nr > 0 ) THEN ! ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band ! CALL slargv( nr, ab( 1, j1+ka ), inca, work( m-kb+j1 ), & ka1, work( n+m-kb+j1 ), ka1 ) ! ! apply rotations in 2nd set from the left ! DO l = 1, ka - 1 CALL slartv( nr, ab( ka1-l, j1+l ), inca, ab( ka-l, j1+l ), inca, & work( n+m-kb+j1 ), work( m-kb+j1 ), ka1 ) END DO ! ! apply rotations in 2nd set from both sides to diagonal ! blocks ! CALL slar2v( nr, ab( ka1, j1 ), ab( ka1, j1-1 ), & ab( ka, j1 ), inca, work( n+m-kb+j1 ), work( m-kb+j1 ), ka1 ) ! END IF ! ! start applying rotations in 2nd set from the right ! DO l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 IF( nrt > 0 ) CALL slartv( nrt, ab( l, j1t ), inca, & ab( l+1, j1t-1 ), inca, work( n+m-kb+j1t ), work( m-kb+j1t ), & ka1 ) END DO ! IF( wantx ) THEN ! ! post-multiply X by product of rotations in 2nd set ! DO j = j1, j2, ka1 CALL srot( nx, x( 1, j ), 1, x( 1, j-1 ), 1, & work( n+m-kb+j ), work( m-kb+j ) ) END DO END IF END DO ! DO k = 1, kb - 1 j2 = i + k + 1 - MAX( 1, k+i0-m+1 )*ka1 ! ! finish applying rotations in 1st set from the right ! DO l = kb - k, 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 IF( nrt > 0 ) CALL slartv( nrt, ab( l, j1t ), inca, & ab( l+1, j1t-1 ), inca, work( n+j1t ), work( j1t ), ka1 ) END DO END DO ! IF( kb > 1 ) THEN DO j = 2, MIN( i+kb, m ) - 2*ka - 1 work( n+j ) = work( n+j+ka ) work( j ) = work( j+ka ) END DO END IF ! ELSE ! ! Transform A, working with the lower triangle ! IF( update ) THEN ! ! Form inv(S(i))**T * A * inv(S(i)) ! bii = bb( 1, i ) DO j = i1, i ab( i-j+1, j ) = ab( i-j+1, j ) / bii END DO DO j = i, MIN( n, i+ka ) ab( j-i+1, i ) = ab( j-i+1, i ) / bii END DO DO k = i + 1, i + kbt DO j = k, i + kbt ab( j-k+1, k ) = ab( j-k+1, k ) - bb( j-i+1, i )*ab( k-i+1, i ) - & bb( k-i+1, i )*ab( j-i+1, i ) + ab( 1, i )*bb( j-i+1, i )* & bb( k-i+1, i ) END DO DO j = i + kbt + 1, MIN( n, i+ka ) ab( j-k+1, k ) = ab( j-k+1, k ) - bb( k-i+1, i )*ab( j-i+1, i ) END DO END DO DO j = i1, i DO k = i + 1, MIN( j+ka, i+kbt ) ab( k-j+1, j ) = ab( k-j+1, j ) - bb( k-i+1, i )*ab( i-j+1, j ) END DO END DO ! IF( wantx ) THEN ! ! post-multiply X by inv(S(i)) ! CALL sscal( nx, one / bii, x( 1, i ), 1 ) IF( kbt > 0 ) CALL sger( nx, kbt, -one, x( 1, i ), 1, bb( 2, i ), 1, & x( 1, i+1 ), ldx ) END IF ! ! store a(i,i1) in RA1 for use in next loop over K ! ra1 = ab( i-i1+1, i1 ) END IF ! ! Generate and apply vectors of rotations to chase all the ! existing bulges KA positions up toward the top of the band ! DO k = 1, kb - 1 IF( update ) THEN ! ! Determine the rotations which would annihilate the bulge ! which has in theory just been created ! IF( i+k-ka1 > 0 .AND. i+k < m ) THEN ! ! generate rotation to annihilate a(i,i+k-ka-1) ! CALL slartg( ab( ka1-k, i+k-ka ), ra1, & work( n+i+k-ka ), work( i+k-ka ), ra ) ! ! create nonzero element a(i+k,i+k-ka-1) outside the ! band and store it in WORK(m-kb+i+k) ! t = -bb( k+1, i )*ra1 work( m-kb+i+k ) = work( n+i+k-ka )*t - & work( i+k-ka )*ab( ka1, i+k-ka ) ab( ka1, i+k-ka ) = work( i+k-ka )*t + & work( n+i+k-ka )*ab( ka1, i+k-ka ) ra1 = ra END IF END IF j2 = i + k + 1 - MAX( 1, k+i0-m+1 )*ka1 nr = ( j2+ka-1 ) / ka1 j1 = j2 - ( nr-1 )*ka1 IF( update ) THEN j2t = MIN( j2, i-2*ka+k-1 ) ELSE j2t = j2 END IF nrt = ( j2t+ka-1 ) / ka1 DO j = j1, j2t, ka1 ! ! create nonzero element a(j+ka,j-1) outside the band ! and store it in WORK(j) ! work( j ) = work( j )*ab( ka1, j-1 ) ab( ka1, j-1 ) = work( n+j )*ab( ka1, j-1 ) END DO ! ! generate rotations in 1st set to annihilate elements which ! have been created outside the band ! IF( nrt > 0 ) CALL slargv( nrt, ab( ka1, j1 ), inca, work( j1 ), ka1, & work( n+j1 ), ka1 ) IF( nr > 0 ) THEN ! ! apply rotations in 1st set from the right ! DO l = 1, ka - 1 CALL slartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ), & inca, work( n+j1 ), work( j1 ), ka1 ) END DO ! ! apply rotations in 1st set from both sides to diagonal ! blocks ! CALL slar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ), & ab( 2, j1-1 ), inca, work( n+j1 ), work( j1 ), ka1 ) ! END IF ! ! start applying rotations in 1st set from the left ! DO l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 IF( nrt > 0 ) CALL slartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca, & ab( ka1-l, j1t-ka1+l ), inca, work( n+j1t ), work( j1t ), ka1 ) END DO ! IF( wantx ) THEN ! ! post-multiply X by product of rotations in 1st set ! DO j = j1, j2, ka1 CALL srot( nx, x( 1, j ), 1, x( 1, j-1 ), 1, work( n+j ), work( j ) ) END DO END IF END DO ! IF( update ) THEN IF( i2 > 0 .AND. kbt > 0 ) THEN ! ! create nonzero element a(i+kbt,i+kbt-ka-1) outside the ! band and store it in WORK(m-kb+i+kbt) ! work( m-kb+i+kbt ) = -bb( kbt+1, i )*ra1 END IF END IF ! DO k = kb, 1, -1 IF( update ) THEN j2 = i + k + 1 - MAX( 2, k+i0-m )*ka1 ELSE j2 = i + k + 1 - MAX( 1, k+i0-m )*ka1 END IF ! ! finish applying rotations in 2nd set from the left ! DO l = kb - k, 1, -1 nrt = ( j2+ka+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 IF( nrt > 0 ) CALL slartv( nrt, ab( ka1-l+1, j1t+l-1 ), inca, & ab( ka1-l, j1t+l-1 ), inca, work( n+m-kb+j1t+ka ), & work( m-kb+j1t+ka ), ka1 ) END DO nr = ( j2+ka-1 ) / ka1 j1 = j2 - ( nr-1 )*ka1 DO j = j1, j2, ka1 work( m-kb+j ) = work( m-kb+j+ka ) work( n+m-kb+j ) = work( n+m-kb+j+ka ) END DO DO j = j1, j2, ka1 ! ! create nonzero element a(j+ka,j-1) outside the band ! and store it in WORK(m-kb+j) ! work( m-kb+j ) = work( m-kb+j )*ab( ka1, j-1 ) ab( ka1, j-1 ) = work( n+m-kb+j )*ab( ka1, j-1 ) END DO IF( update ) THEN IF( i+k > ka1 .AND. k <= kbt ) work( m-kb+i+k-ka ) = work( m-kb+i+k ) END IF END DO ! DO k = kb, 1, -1 j2 = i + k + 1 - MAX( 1, k+i0-m )*ka1 nr = ( j2+ka-1 ) / ka1 j1 = j2 - ( nr-1 )*ka1 IF( nr > 0 ) THEN ! ! generate rotations in 2nd set to annihilate elements ! which have been created outside the band ! CALL slargv( nr, ab( ka1, j1 ), inca, work( m-kb+j1 ), & ka1, work( n+m-kb+j1 ), ka1 ) ! ! apply rotations in 2nd set from the right ! DO l = 1, ka - 1 CALL slartv( nr, ab( l+1, j1 ), inca, ab( l+2, j1-1 ), & inca, work( n+m-kb+j1 ), work( m-kb+j1 ), ka1 ) END DO ! ! apply rotations in 2nd set from both sides to diagonal ! blocks ! CALL slar2v( nr, ab( 1, j1 ), ab( 1, j1-1 ), & ab( 2, j1-1 ), inca, work( n+m-kb+j1 ), work( m-kb+j1 ), ka1 ) ! END IF ! ! start applying rotations in 2nd set from the left ! DO l = ka - 1, kb - k + 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 IF( nrt > 0 ) CALL slartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca, & ab( ka1-l, j1t-ka1+l ), inca, work( n+m-kb+j1t ), work( m-kb+j1t ), & ka1 ) END DO ! IF( wantx ) THEN ! ! post-multiply X by product of rotations in 2nd set ! DO j = j1, j2, ka1 CALL srot( nx, x( 1, j ), 1, x( 1, j-1 ), 1, & work( n+m-kb+j ), work( m-kb+j ) ) END DO END IF END DO ! DO k = 1, kb - 1 j2 = i + k + 1 - MAX( 1, k+i0-m+1 )*ka1 ! ! finish applying rotations in 1st set from the left ! DO l = kb - k, 1, -1 nrt = ( j2+l-1 ) / ka1 j1t = j2 - ( nrt-1 )*ka1 IF( nrt > 0 ) CALL slartv( nrt, ab( ka1-l+1, j1t-ka1+l ), inca, & ab( ka1-l, j1t-ka1+l ), inca, work( n+j1t ), work( j1t ), ka1 ) END DO END DO ! IF( kb > 1 ) THEN DO j = 2, MIN( i+kb, m ) - 2*ka - 1 work( n+j ) = work( n+j+ka ) work( j ) = work( j+ka ) END DO END IF ! END IF ! GO TO 490 ! ! End of SSBGST ! END SUBROUTINE ssbgst SUBROUTINE ssbgv( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, z, & ldz, work, info ) ! ! -- LAPACK driver 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 (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: ka INTEGER, INTENT(IN OUT) :: kb REAL, INTENT(IN OUT) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(IN OUT) :: bb( ldbb, * ) INTEGER, INTENT(IN OUT) :: ldbb REAL, INTENT(IN OUT) :: w( * ) REAL, INTENT(IN OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSBGV computes all the eigenvalues, and optionally, the eigenvectors ! of a real generalized symmetric-definite banded eigenproblem, of ! the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric ! and banded, and B is also positive definite. ! ! Arguments ! ========= ! ! 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. ! ! KA (input) INTEGER ! The number of superdiagonals of the matrix A if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KA >= 0. ! ! KB (input) INTEGER ! The number of superdiagonals of the matrix B if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KB >= 0. ! ! AB (input/output) REAL array, dimension (LDAB, N) ! On entry, the upper or lower triangle of the symmetric band ! matrix A, stored in the first ka+1 rows of the array. The ! j-th column of A is stored in the j-th column of the array AB ! as follows: ! if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). ! ! On exit, the contents of AB are destroyed. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KA+1. ! ! BB (input/output) REAL array, dimension (LDBB, N) ! On entry, the upper or lower triangle of the symmetric band ! matrix B, stored in the first kb+1 rows of the array. The ! j-th column of B is stored in the j-th column of the array BB ! as follows: ! if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; ! if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). ! ! On exit, the factor S from the split Cholesky factorization ! B = S**T*S, as returned by SPBSTF. ! ! LDBB (input) INTEGER ! The leading dimension of the array BB. LDBB >= KB+1. ! ! W (output) REAL array, dimension (N) ! If INFO = 0, the eigenvalues in ascending order. ! ! Z (output) REAL array, dimension (LDZ, N) ! If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of ! eigenvectors, with the i-th column of Z holding the ! eigenvector associated with W(i). The eigenvectors are ! normalized so that Z**T*B*Z = 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 >= N. ! ! WORK (workspace) REAL 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, and i is: ! <= N: the algorithm 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 SPBSTF ! returned INFO = i: B is not positive definite. ! The factorization of B could not be completed and ! no eigenvalues or eigenvectors were computed. ! ! ===================================================================== ! ! .. Local Scalars .. LOGICAL :: upper, wantz CHARACTER (LEN=1) :: vect INTEGER :: iinfo, inde, indwrk ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL spbstf, ssbgst, ssbtrd, ssteqr, ssterf, xerbla ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! wantz = lsame( jobz, 'V' ) upper = lsame( uplo, 'U' ) ! info = 0 IF( .NOT.( wantz .OR. lsame( jobz, 'N' ) ) ) THEN info = -1 ELSE IF( .NOT.( upper .OR. lsame( uplo, 'L' ) ) ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( ka < 0 ) THEN info = -4 ELSE IF( kb < 0 .OR. kb > ka ) THEN info = -5 ELSE IF( ldab < ka+1 ) THEN info = -7 ELSE IF( ldbb < kb+1 ) THEN info = -9 ELSE IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) THEN info = -12 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSBGV ', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Form a split Cholesky factorization of B. ! CALL spbstf( uplo, n, kb, bb, ldbb, info ) IF( info /= 0 ) THEN info = n + info RETURN END IF ! ! Transform problem to standard eigenvalue problem. ! inde = 1 indwrk = inde + n CALL ssbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz, & work( indwrk ), iinfo ) ! ! Reduce to tridiagonal form. ! IF( wantz ) THEN vect = 'U' ELSE vect = 'N' END IF CALL ssbtrd( vect, uplo, n, ka, ab, ldab, w, work( inde ), z, ldz, & work( indwrk ), iinfo ) ! ! For eigenvalues only, call SSTERF. For eigenvectors, call SSTEQR. ! IF( .NOT.wantz ) THEN CALL ssterf( n, w, work( inde ), info ) ELSE CALL ssteqr( jobz, n, w, work( inde ), z, ldz, work( indwrk ), info ) END IF RETURN ! ! End of SSBGV ! END SUBROUTINE ssbgv SUBROUTINE ssbgvd( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, w, & z, ldz, work, lwork, iwork, liwork, 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 (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: ka INTEGER, INTENT(IN OUT) :: kb REAL, INTENT(IN OUT) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(IN OUT) :: bb( ldbb, * ) INTEGER, INTENT(IN OUT) :: ldbb REAL, INTENT(IN OUT) :: w( * ) REAL, INTENT(IN OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(IN OUT) :: liwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSBGVD computes all the eigenvalues, and optionally, the eigenvectors ! of a real generalized symmetric-definite banded eigenproblem, of the ! form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and ! banded, and B is also positive definite. If eigenvectors are ! desired, it uses a divide and conquer algorithm. ! ! The divide and conquer algorithm makes very mild assumptions about ! floating point arithmetic. It will work on machines with a guard ! digit in add/subtract, or on those binary machines without guard ! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or ! Cray-2. It could conceivably fail on hexadecimal or decimal machines ! without guard digits, but we know of none. ! ! Arguments ! ========= ! ! 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. ! ! KA (input) INTEGER ! The number of superdiagonals of the matrix A if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KA >= 0. ! ! KB (input) INTEGER ! The number of superdiagonals of the matrix B if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KB >= 0. ! ! AB (input/output) REAL array, dimension (LDAB, N) ! On entry, the upper or lower triangle of the symmetric band ! matrix A, stored in the first ka+1 rows of the array. The ! j-th column of A is stored in the j-th column of the array AB ! as follows: ! if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). ! ! On exit, the contents of AB are destroyed. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KA+1. ! ! BB (input/output) REAL array, dimension (LDBB, N) ! On entry, the upper or lower triangle of the symmetric band ! matrix B, stored in the first kb+1 rows of the array. The ! j-th column of B is stored in the j-th column of the array BB ! as follows: ! if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; ! if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). ! ! On exit, the factor S from the split Cholesky factorization ! B = S**T*S, as returned by SPBSTF. ! ! LDBB (input) INTEGER ! The leading dimension of the array BB. LDBB >= KB+1. ! ! W (output) REAL array, dimension (N) ! If INFO = 0, the eigenvalues in ascending order. ! ! Z (output) REAL array, dimension (LDZ, N) ! If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of ! eigenvectors, with the i-th column of Z holding the ! eigenvector associated with W(i). The eigenvectors are ! normalized so Z**T*B*Z = 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/output) REAL array, dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. ! If N <= 1, LWORK >= 1. ! If JOBZ = 'N' and N > 1, LWORK >= 3*N. ! If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2. ! ! 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/output) INTEGER array, dimension (LIWORK) ! On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK. ! ! LIWORK (input) INTEGER ! The dimension of the array IWORK. ! If JOBZ = 'N' or N <= 1, LIWORK >= 1. ! If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. ! ! If LIWORK = -1, then a workspace query is assumed; the ! routine only calculates the optimal size of the IWORK array, ! returns this value as the first entry of the IWORK array, and ! no error message related to LIWORK 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, and i is: ! <= N: the algorithm 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 SPBSTF ! returned INFO = i: 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 .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, upper, wantz CHARACTER (LEN=1) :: vect INTEGER :: iinfo, inde, indwk2, indwrk, liwmin, llwrk2, lwmin ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL sgemm, slacpy, spbstf, ssbgst, ssbtrd, sstedc, & ssterf, xerbla ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! wantz = lsame( jobz, 'V' ) upper = lsame( uplo, 'U' ) lquery = ( lwork == -1 .OR. liwork == -1 ) ! info = 0 IF( n <= 1 ) THEN liwmin = 1 lwmin = 1 ELSE IF( wantz ) THEN liwmin = 3 + 5*n lwmin = 1 + 5*n + 2*n**2 ELSE liwmin = 1 lwmin = 2*n END IF END IF ! IF( .NOT.( wantz .OR. lsame( jobz, 'N' ) ) ) THEN info = -1 ELSE IF( .NOT.( upper .OR. lsame( uplo, 'L' ) ) ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( ka < 0 ) THEN info = -4 ELSE IF( kb < 0 .OR. kb > ka ) THEN info = -5 ELSE IF( ldab < ka+1 ) THEN info = -7 ELSE IF( ldbb < kb+1 ) THEN info = -9 ELSE IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) THEN info = -12 ELSE IF( lwork < lwmin .AND. .NOT.lquery ) THEN info = -14 ELSE IF( liwork < liwmin .AND. .NOT.lquery ) THEN info = -16 END IF ! IF( info == 0 ) THEN work( 1 ) = lwmin iwork( 1 ) = liwmin END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSBGVD', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Form a split Cholesky factorization of B. ! CALL spbstf( uplo, n, kb, bb, ldbb, info ) IF( info /= 0 ) THEN info = n + info RETURN END IF ! ! Transform problem to standard eigenvalue problem. ! inde = 1 indwrk = inde + n indwk2 = indwrk + n*n llwrk2 = lwork - indwk2 + 1 CALL ssbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, z, ldz, & work( indwrk ), iinfo ) ! ! Reduce to tridiagonal form. ! IF( wantz ) THEN vect = 'U' ELSE vect = 'N' END IF CALL ssbtrd( vect, uplo, n, ka, ab, ldab, w, work( inde ), z, ldz, & work( indwrk ), iinfo ) ! ! For eigenvalues only, call SSTERF. For eigenvectors, call SSTEDC. ! IF( .NOT.wantz ) THEN CALL ssterf( n, w, work( inde ), info ) ELSE CALL sstedc( 'I', n, w, work( inde ), work( indwrk ), n, & work( indwk2 ), llwrk2, iwork, liwork, info ) CALL sgemm( 'N', 'N', n, n, n, one, z, ldz, work( indwrk ), n, & zero, work( indwk2 ), n ) CALL slacpy( 'A', n, n, work( indwk2 ), n, z, ldz ) END IF ! work( 1 ) = lwmin iwork( 1 ) = liwmin ! RETURN ! ! End of SSBGVD ! END SUBROUTINE ssbgvd SUBROUTINE ssbgvx( jobz, range, uplo, n, ka, kb, ab, ldab, bb, & ldbb, q, ldq, vl, vu, il, iu, abstol, m, w, z, ldz, work, 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 (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: range CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: ka INTEGER, INTENT(IN OUT) :: kb REAL, INTENT(IN OUT) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(IN OUT) :: bb( ldbb, * ) INTEGER, INTENT(IN OUT) :: ldbb REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq REAL, INTENT(IN OUT) :: vl REAL, INTENT(IN OUT) :: vu INTEGER, INTENT(IN) :: il INTEGER, INTENT(IN) :: iu REAL, INTENT(IN OUT) :: abstol INTEGER, INTENT(OUT) :: m REAL, INTENT(IN OUT) :: w( * ) REAL, INTENT(IN OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: ifail( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSBGVX computes selected eigenvalues, and optionally, eigenvectors ! of a real generalized symmetric-definite banded eigenproblem, of ! the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric ! and banded, and B is also positive definite. Eigenvalues and ! eigenvectors can be selected by specifying either all eigenvalues, ! 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 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. ! ! KA (input) INTEGER ! The number of superdiagonals of the matrix A if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KA >= 0. ! ! KB (input) INTEGER ! The number of superdiagonals of the matrix B if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KB >= 0. ! ! AB (input/output) REAL array, dimension (LDAB, N) ! On entry, the upper or lower triangle of the symmetric band ! matrix A, stored in the first ka+1 rows of the array. The ! j-th column of A is stored in the j-th column of the array AB ! as follows: ! if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). ! ! On exit, the contents of AB are destroyed. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KA+1. ! ! BB (input/output) REAL array, dimension (LDBB, N) ! On entry, the upper or lower triangle of the symmetric band ! matrix B, stored in the first kb+1 rows of the array. The ! j-th column of B is stored in the j-th column of the array BB ! as follows: ! if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; ! if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). ! ! On exit, the factor S from the split Cholesky factorization ! B = S**T*S, as returned by SPBSTF. ! ! LDBB (input) INTEGER ! The leading dimension of the array BB. LDBB >= KB+1. ! ! Q (output) REAL array, dimension (LDQ, N) ! If JOBZ = 'V', the n-by-n matrix used in the reduction of ! A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x, ! and consequently C to tridiagonal form. ! If JOBZ = 'N', the array Q is not referenced. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. If JOBZ = 'N', ! LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N). ! ! VL (input) REAL ! VU (input) REAL ! 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) REAL ! 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*SLAMCH('S'), not zero. ! If this routine returns with INFO>0, indicating that some ! eigenvectors did not converge, try setting ABSTOL to ! 2*SLAMCH('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) REAL array, dimension (N) ! If INFO = 0, the eigenvalues in ascending order. ! ! Z (output) REAL array, dimension (LDZ, N) ! If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of ! eigenvectors, with the i-th column of Z holding the ! eigenvector associated with W(i). The eigenvectors are ! normalized so Z**T*B*Z = 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/output) REAL array, dimension (7N) ! ! IWORK (workspace/output) INTEGER array, dimension (5N) ! ! IFAIL (input) INTEGER array, dimension (M) ! 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 eigenvalues 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 ! <= N: if INFO = i, then i eigenvectors failed to converge. ! Their indices are stored in IFAIL. ! > N : SPBSTF returned an error code; i.e., ! 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 .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: alleig, indeig, upper, valeig, wantz CHARACTER (LEN=1) :: order, vect INTEGER :: i, iinfo, indd, inde, indee, indibl, indisp, & indiwo, indwrk, itmp1, j, jj, nsplit REAL :: tmp1 ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL scopy, sgemv, slacpy, spbstf, ssbgst, ssbtrd, & sstebz, sstein, ssteqr, ssterf, sswap, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC 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' ) ! 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.( upper .OR. lsame( uplo, 'L' ) ) ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( ka < 0 ) THEN info = -5 ELSE IF( kb < 0 .OR. kb > ka ) THEN info = -6 ELSE IF( ldab < ka+1 ) THEN info = -8 ELSE IF( ldbb < kb+1 ) THEN info = -10 ELSE IF( ldq < 1 ) THEN info = -12 ELSE IF( valeig .AND. n > 0 .AND. vu <= vl ) THEN info = -14 ELSE IF( indeig .AND. il < 1 ) THEN info = -15 ELSE IF( indeig .AND. ( iu < MIN( n, il ) .OR. iu > n ) ) THEN info = -16 ELSE IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) THEN info = -21 END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSBGVX', -info ) RETURN END IF ! ! Quick return if possible ! m = 0 IF( n == 0 ) THEN work( 1 ) = 1 RETURN END IF ! ! Form a split Cholesky factorization of B. ! CALL spbstf( uplo, n, kb, bb, ldbb, info ) IF( info /= 0 ) THEN info = n + info RETURN END IF ! ! Transform problem to standard eigenvalue problem. ! CALL ssbgst( jobz, uplo, n, ka, kb, ab, ldab, bb, ldbb, q, ldq, work, iinfo ) ! ! Reduce symmetric band matrix to tridiagonal form. ! indd = 1 inde = indd + n indwrk = inde + n IF( wantz ) THEN vect = 'U' ELSE vect = 'N' END IF CALL ssbtrd( vect, uplo, n, ka, ab, ldab, work( indd ), & work( inde ), q, ldq, work( indwrk ), iinfo ) ! ! If all eigenvalues are desired and ABSTOL is less than or equal ! to zero, then call SSTERF or SSTEQR. If this fails for some ! eigenvalue, then try SSTEBZ. ! IF( ( alleig .OR. ( indeig .AND. il == 1 .AND. iu == n ) ) .AND. & ( abstol <= zero ) ) THEN CALL scopy( n, work( indd ), 1, w, 1 ) indee = indwrk + 2*n CALL scopy( n-1, work( inde ), 1, work( indee ), 1 ) IF( .NOT.wantz ) THEN CALL ssterf( n, w, work( indee ), info ) ELSE CALL slacpy( 'A', n, n, q, ldq, z, ldz ) CALL ssteqr( jobz, n, w, work( indee ), z, ldz, work( indwrk ), info ) IF( info == 0 ) THEN DO i = 1, n ifail( i ) = 0 END DO END IF END IF IF( info == 0 ) THEN m = n GO TO 30 END IF info = 0 END IF ! ! Otherwise, call SSTEBZ and, if eigenvectors are desired, ! call SSTEIN. ! IF( wantz ) THEN order = 'B' ELSE order = 'E' END IF indibl = 1 indisp = indibl + n indiwo = indisp + n CALL sstebz( range, order, n, vl, vu, il, iu, abstol, & work( indd ), work( inde ), m, nsplit, w, & iwork( indibl ), iwork( indisp ), work( indwrk ), iwork( indiwo ), info ) ! IF( wantz ) THEN CALL sstein( n, work( indd ), work( inde ), m, w, & iwork( indibl ), iwork( indisp ), z, ldz, & work( indwrk ), iwork( indiwo ), ifail, info ) ! ! Apply transformation matrix used in reduction to tridiagonal ! form to eigenvectors returned by SSTEIN. ! DO j = 1, m CALL scopy( n, z( 1, j ), 1, work( 1 ), 1 ) CALL sgemv( 'N', n, n, one, q, ldq, work, 1, zero, z( 1, j ), 1 ) END DO END IF ! 30 CONTINUE ! ! If eigenvalues are not in order, then sort them, along with ! eigenvectors. ! IF( wantz ) THEN DO j = 1, m - 1 i = 0 tmp1 = w( j ) DO jj = j + 1, m IF( w( jj ) < tmp1 ) THEN i = jj tmp1 = w( jj ) END IF END DO ! IF( i /= 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 sswap( n, z( 1, i ), 1, z( 1, j ), 1 ) IF( info /= 0 ) THEN itmp1 = ifail( i ) ifail( i ) = ifail( j ) ifail( j ) = itmp1 END IF END IF END DO END IF ! RETURN ! ! End of SSBGVX ! END SUBROUTINE ssbgvx SUBROUTINE ssbtrd( vect, uplo, n, kd, ab, ldab, d, e, 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 ! June 30, 1999 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: vect CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: kd REAL, INTENT(OUT) :: ab( ldab, * ) INTEGER, INTENT(IN) :: ldab REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(OUT) :: e( * ) REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSBTRD reduces a real symmetric band matrix A to symmetric ! tridiagonal form T by an orthogonal similarity transformation: ! Q**T * A * Q = T. ! ! Arguments ! ========= ! ! VECT (input) CHARACTER*1 ! = 'N': do not form Q; ! = 'V': form Q; ! = 'U': update a matrix X, by forming X*Q. ! ! 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. ! ! KD (input) INTEGER ! The number of superdiagonals of the matrix A if UPLO = 'U', ! or the number of subdiagonals if UPLO = 'L'. KD >= 0. ! ! AB (input/output) REAL array, dimension (LDAB,N) ! On entry, the upper or lower triangle of the symmetric band ! matrix A, stored in the first KD+1 rows of the array. The ! j-th column of A is stored in the j-th column of the array AB ! as follows: ! if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). ! On exit, the diagonal elements of AB are overwritten by the ! diagonal elements of the tridiagonal matrix T; if KD > 0, the ! elements on the first superdiagonal (if UPLO = 'U') or the ! first subdiagonal (if UPLO = 'L') are overwritten by the ! off-diagonal elements of T; the rest of AB is overwritten by ! values generated during the reduction. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KD+1. ! ! D (output) REAL array, dimension (N) ! The diagonal elements of the tridiagonal matrix T. ! ! E (output) REAL array, dimension (N-1) ! The off-diagonal elements of the tridiagonal matrix T: ! E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. ! ! Q (input/output) REAL array, dimension (LDQ,N) ! On entry, if VECT = 'U', then Q must contain an N-by-N ! matrix X; if VECT = 'N' or 'V', then Q need not be set. ! ! On exit: ! if VECT = 'V', Q contains the N-by-N orthogonal matrix Q; ! if VECT = 'U', Q contains the product X*Q; ! if VECT = 'N', the array Q is not referenced. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. ! LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'. ! ! WORK (workspace) REAL array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! Further Details ! =============== ! ! Modified by Linda Kaufman, Bell Labs. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: initq, upper, wantq INTEGER :: i, i2, ibl, inca, incx, iqaend, iqb, iqend, j, & j1, j1end, j1inc, j2, jend, jin, jinc, k, kd1, & kdm1, kdn, l, last, lend, nq, nr, nrt REAL :: temp ! .. ! .. External Subroutines .. EXTERNAL slar2v, slargv, slartg, slartv, slaset, srot, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. Executable Statements .. ! ! Test the input parameters ! initq = lsame( vect, 'V' ) wantq = initq .OR. lsame( vect, 'U' ) upper = lsame( uplo, 'U' ) kd1 = kd + 1 kdm1 = kd - 1 incx = ldab - 1 iqend = 1 ! info = 0 IF( .NOT.wantq .AND. .NOT.lsame( vect, 'N' ) ) THEN info = -1 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( kd < 0 ) THEN info = -4 ELSE IF( ldab < kd1 ) THEN info = -6 ELSE IF( ldq < MAX( 1, n ) .AND. wantq ) THEN info = -10 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSBTRD', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Initialize Q to the unit matrix, if needed ! IF( initq ) CALL slaset( 'Full', n, n, zero, one, q, ldq ) ! ! Wherever possible, plane rotations are generated and applied in ! vector operations of length NR over the index set J1:J2:KD1. ! ! The cosines and sines of the plane rotations are stored in the ! arrays D and WORK. ! inca = kd1*ldab kdn = MIN( n-1, kd ) IF( upper ) THEN ! IF( kd > 1 ) THEN ! ! Reduce to tridiagonal form, working with upper triangle ! nr = 0 j1 = kdn + 2 j2 = 1 ! DO i = 1, n - 2 ! ! Reduce i-th row of matrix to tridiagonal form ! DO k = kdn + 1, 2, -1 j1 = j1 + kdn j2 = j2 + kdn ! IF( nr > 0 ) THEN ! ! generate plane rotations to annihilate nonzero ! elements which have been created outside the band ! CALL slargv( nr, ab( 1, j1-1 ), inca, work( j1 ), & kd1, d( j1 ), kd1 ) ! ! apply rotations from the right ! ! ! Dependent on the the number of diagonals either ! SLARTV or SROT is used ! IF( nr >= 2*kd-1 ) THEN DO l = 1, kd - 1 CALL slartv( nr, ab( l+1, j1-1 ), inca, & ab( l, j1 ), inca, d( j1 ), work( j1 ), kd1 ) END DO ! ELSE jend = j1 + ( nr-1 )*kd1 DO jinc = j1, jend, kd1 CALL srot( kdm1, ab( 2, jinc-1 ), 1, & ab( 1, jinc ), 1, d( jinc ), work( jinc ) ) END DO END IF END IF ! ! IF( k > 2 ) THEN IF( k <= n-i+1 ) THEN ! ! generate plane rotation to annihilate a(i,i+k-1) ! within the band ! CALL slartg( ab( kd-k+3, i+k-2 ), & ab( kd-k+2, i+k-1 ), d( i+k-1 ), work( i+k-1 ), temp ) ab( kd-k+3, i+k-2 ) = temp ! ! apply rotation from the right ! CALL srot( k-3, ab( kd-k+4, i+k-2 ), 1, & ab( kd-k+3, i+k-1 ), 1, d( i+k-1 ), work( i+k-1 ) ) END IF nr = nr + 1 j1 = j1 - kdn - 1 END IF ! ! apply plane rotations from both sides to diagonal ! blocks ! IF( nr > 0 ) CALL slar2v( nr, ab( kd1, j1-1 ), ab( kd1, j1 ), & ab( kd, j1 ), inca, d( j1 ), work( j1 ), kd1 ) ! ! apply plane rotations from the left ! IF( nr > 0 ) THEN IF( 2*kd-1 < nr ) THEN ! ! Dependent on the the number of diagonals either ! SLARTV or SROT is used ! DO l = 1, kd - 1 IF( j2+l > n ) THEN nrt = nr - 1 ELSE nrt = nr END IF IF( nrt > 0 ) CALL slartv( nrt, ab( kd-l, j1+l ), inca, & ab( kd-l+1, j1+l ), inca, d( j1 ), work( j1 ), kd1 ) END DO ELSE j1end = j1 + kd1*( nr-2 ) IF( j1end >= j1 ) THEN DO jin = j1, j1end, kd1 CALL srot( kd-1, ab( kd-1, jin+1 ), incx, & ab( kd, jin+1 ), incx, d( jin ), work( jin ) ) END DO END IF lend = MIN( kdm1, n-j2 ) last = j1end + kd1 IF( lend > 0 ) CALL srot( lend, ab( kd-1, last+1 ), incx, & ab( kd, last+1 ), incx, d( last ), work( last ) ) END IF END IF ! IF( wantq ) THEN ! ! accumulate product of plane rotations in Q ! IF( initq ) THEN ! ! take advantage of the fact that Q was ! initially the Identity matrix ! iqend = MAX( iqend, j2 ) i2 = MAX( 0, k-3 ) iqaend = 1 + i*kd IF( k == 2 ) iqaend = iqaend + kd iqaend = MIN( iqaend, iqend ) DO j = j1, j2, kd1 ibl = i - i2 / kdm1 i2 = i2 + 1 iqb = MAX( 1, j-ibl ) nq = 1 + iqaend - iqb iqaend = MIN( iqaend+kd, iqend ) CALL srot( nq, q( iqb, j-1 ), 1, q( iqb, j ), & 1, d( j ), work( j ) ) END DO ELSE ! DO j = j1, j2, kd1 CALL srot( n, q( 1, j-1 ), 1, q( 1, j ), 1, d( j ), work( j ) ) END DO END IF ! END IF ! IF( j2+kdn > n ) THEN ! ! adjust J2 to keep within the bounds of the matrix ! nr = nr - 1 j2 = j2 - kdn - 1 END IF ! DO j = j1, j2, kd1 ! ! create nonzero element a(j-1,j+kd) outside the band ! and store it in WORK ! work( j+kd ) = work( j )*ab( 1, j+kd ) ab( 1, j+kd ) = d( j )*ab( 1, j+kd ) END DO END DO END DO END IF ! IF( kd > 0 ) THEN ! ! copy off-diagonal elements to E ! DO i = 1, n - 1 e( i ) = ab( kd, i+1 ) END DO ELSE ! ! set E to zero if original matrix was diagonal ! DO i = 1, n - 1 e( i ) = zero END DO END IF ! ! copy diagonal elements to D ! DO i = 1, n d( i ) = ab( kd1, i ) END DO ! ELSE ! IF( kd > 1 ) THEN ! ! Reduce to tridiagonal form, working with lower triangle ! nr = 0 j1 = kdn + 2 j2 = 1 ! DO i = 1, n - 2 ! ! Reduce i-th column of matrix to tridiagonal form ! DO k = kdn + 1, 2, -1 j1 = j1 + kdn j2 = j2 + kdn ! IF( nr > 0 ) THEN ! ! generate plane rotations to annihilate nonzero ! elements which have been created outside the band ! CALL slargv( nr, ab( kd1, j1-kd1 ), inca, & work( j1 ), kd1, d( j1 ), kd1 ) ! ! apply plane rotations from one side ! ! ! Dependent on the the number of diagonals either ! SLARTV or SROT is used ! IF( nr > 2*kd-1 ) THEN DO l = 1, kd - 1 CALL slartv( nr, ab( kd1-l, j1-kd1+l ), inca, & ab( kd1-l+1, j1-kd1+l ), inca, d( j1 ), work( j1 ), kd1 ) END DO ELSE jend = j1 + kd1*( nr-1 ) DO jinc = j1, jend, kd1 CALL srot( kdm1, ab( kd, jinc-kd ), incx, & ab( kd1, jinc-kd ), incx, d( jinc ), work( jinc ) ) END DO END IF ! END IF ! IF( k > 2 ) THEN IF( k <= n-i+1 ) THEN ! ! generate plane rotation to annihilate a(i+k-1,i) ! within the band ! CALL slartg( ab( k-1, i ), ab( k, i ), & d( i+k-1 ), work( i+k-1 ), temp ) ab( k-1, i ) = temp ! ! apply rotation from the left ! CALL srot( k-3, ab( k-2, i+1 ), ldab-1, & ab( k-1, i+1 ), ldab-1, d( i+k-1 ), work( i+k-1 ) ) END IF nr = nr + 1 j1 = j1 - kdn - 1 END IF ! ! apply plane rotations from both sides to diagonal ! blocks ! IF( nr > 0 ) CALL slar2v( nr, ab( 1, j1-1 ), ab( 1, j1 ), & ab( 2, j1-1 ), inca, d( j1 ), work( j1 ), kd1 ) ! ! apply plane rotations from the right ! ! ! Dependent on the the number of diagonals either ! SLARTV or SROT is used ! IF( nr > 0 ) THEN IF( nr > 2*kd-1 ) THEN DO l = 1, kd - 1 IF( j2+l > n ) THEN nrt = nr - 1 ELSE nrt = nr END IF IF( nrt > 0 ) CALL slartv( nrt, ab( l+2, j1-1 ), inca, & ab( l+1, j1 ), inca, d( j1 ), work( j1 ), kd1 ) END DO ELSE j1end = j1 + kd1*( nr-2 ) IF( j1end >= j1 ) THEN DO j1inc = j1, j1end, kd1 CALL srot( kdm1, ab( 3, j1inc-1 ), 1, & ab( 2, j1inc ), 1, d( j1inc ), work( j1inc ) ) END DO END IF lend = MIN( kdm1, n-j2 ) last = j1end + kd1 IF( lend > 0 ) CALL srot( lend, ab( 3, last-1 ), 1, & ab( 2, last ), 1, d( last ), work( last ) ) END IF END IF ! ! ! IF( wantq ) THEN ! ! accumulate product of plane rotations in Q ! IF( initq ) THEN ! ! take advantage of the fact that Q was ! initially the Identity matrix ! iqend = MAX( iqend, j2 ) i2 = MAX( 0, k-3 ) iqaend = 1 + i*kd IF( k == 2 ) iqaend = iqaend + kd iqaend = MIN( iqaend, iqend ) DO j = j1, j2, kd1 ibl = i - i2 / kdm1 i2 = i2 + 1 iqb = MAX( 1, j-ibl ) nq = 1 + iqaend - iqb iqaend = MIN( iqaend+kd, iqend ) CALL srot( nq, q( iqb, j-1 ), 1, q( iqb, j ), & 1, d( j ), work( j ) ) END DO ELSE ! DO j = j1, j2, kd1 CALL srot( n, q( 1, j-1 ), 1, q( 1, j ), 1, d( j ), work( j ) ) END DO END IF END IF ! IF( j2+kdn > n ) THEN ! ! adjust J2 to keep within the bounds of the matrix ! nr = nr - 1 j2 = j2 - kdn - 1 END IF ! DO j = j1, j2, kd1 ! ! create nonzero element a(j+kd,j-1) outside the ! band and store it in WORK ! work( j+kd ) = work( j )*ab( kd1, j ) ab( kd1, j ) = d( j )*ab( kd1, j ) END DO END DO END DO END IF ! IF( kd > 0 ) THEN ! ! copy off-diagonal elements to E ! DO i = 1, n - 1 e( i ) = ab( 2, i ) END DO ELSE ! ! set E to zero if original matrix was diagonal ! DO i = 1, n - 1 e( i ) = zero END DO END IF ! ! copy diagonal elements to D ! DO i = 1, n d( i ) = ab( 1, i ) END DO END IF ! RETURN ! ! End of SSBTRD ! END SUBROUTINE ssbtrd SUBROUTINE sspcon( uplo, n, ap, ipiv, anorm, rcond, 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 ! March 31, 1993 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: ap( * ) INTEGER, INTENT(IN) :: ipiv( * ) REAL, INTENT(IN) :: anorm REAL, INTENT(OUT) :: rcond REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSPCON estimates the reciprocal of the condition number (in the ! 1-norm) of a real symmetric packed matrix A using the factorization ! A = U*D*U**T or A = L*D*L**T computed by SSPTRF. ! ! An estimate is obtained for norm(inv(A)), and the reciprocal of the ! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! ! 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. ! ! AP (input) REAL 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 SSPTRF, 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 SSPTRF. ! ! ANORM (input) REAL ! The 1-norm of the original matrix A. ! ! RCOND (output) REAL ! The reciprocal of the condition number of the matrix A, ! computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an ! estimate of the 1-norm of inv(A) computed in this routine. ! ! WORK (workspace) REAL array, dimension (2*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: i, ip, kase REAL :: ainvnm ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL slacon, ssptrs, xerbla ! .. ! .. 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 < 0 ) THEN info = -2 ELSE IF( anorm < zero ) THEN info = -5 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSPCON', -info ) RETURN END IF ! ! Quick return if possible ! rcond = zero IF( n == 0 ) THEN rcond = one RETURN ELSE IF( anorm <= zero ) THEN RETURN END IF ! ! Check that the diagonal matrix D is nonsingular. ! IF( upper ) THEN ! ! Upper triangular storage: examine D from bottom to top ! ip = n*( n+1 ) / 2 DO i = n, 1, -1 IF( ipiv( i ) > 0 .AND. ap( ip ) == zero ) RETURN ip = ip - i END DO ELSE ! ! Lower triangular storage: examine D from top to bottom. ! ip = 1 DO i = 1, n IF( ipiv( i ) > 0 .AND. ap( ip ) == zero ) RETURN ip = ip + n - i + 1 END DO END IF ! ! Estimate the 1-norm of the inverse. ! kase = 0 30 CONTINUE CALL slacon( n, work( n+1 ), work, iwork, ainvnm, kase ) IF( kase /= 0 ) THEN ! ! Multiply by inv(L*D*L') or inv(U*D*U'). ! CALL ssptrs( uplo, n, 1, ap, ipiv, work, n, info ) GO TO 30 END IF ! ! Compute the estimate of the reciprocal condition number. ! IF( ainvnm /= zero ) rcond = ( one / ainvnm ) / anorm ! RETURN ! ! End of SSPCON ! END SUBROUTINE sspcon SUBROUTINE sspev( jobz, uplo, n, ap, w, z, ldz, work, 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 (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: ap( * ) REAL, INTENT(OUT) :: w( * ) REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSPEV 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) REAL 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) REAL array, dimension (N) ! If INFO = 0, the eigenvalues in ascending order. ! ! Z (output) REAL 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) REAL 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 .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: wantz INTEGER :: iinfo, imax, inde, indtau, indwrk, iscale REAL :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slansp EXTERNAL lsame, slamch, slansp ! .. ! .. External Subroutines .. EXTERNAL sopgtr, sscal, ssptrd, ssteqr, ssterf, 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 < 0 ) THEN info = -3 ELSE IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) THEN info = -7 END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSPEV ', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! IF( n == 1 ) THEN w( 1 ) = ap( 1 ) IF( wantz ) z( 1, 1 ) = one RETURN END IF ! ! Get machine constants. ! safmin = slamch( 'Safe minimum' ) eps = slamch( 'Precision' ) smlnum = safmin / eps bignum = one / smlnum rmin = SQRT( smlnum ) rmax = SQRT( bignum ) ! ! Scale matrix to allowable range, if necessary. ! anrm = slansp( 'M', uplo, n, ap, work ) iscale = 0 IF( anrm > zero .AND. anrm < rmin ) THEN iscale = 1 sigma = rmin / anrm ELSE IF( anrm > rmax ) THEN iscale = 1 sigma = rmax / anrm END IF IF( iscale == 1 ) THEN CALL sscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) END IF ! ! Call SSPTRD to reduce symmetric packed matrix to tridiagonal form. ! inde = 1 indtau = inde + n CALL ssptrd( uplo, n, ap, w, work( inde ), work( indtau ), iinfo ) ! ! For eigenvalues only, call SSTERF. For eigenvectors, first call ! SOPGTR to generate the orthogonal matrix, then call SSTEQR. ! IF( .NOT.wantz ) THEN CALL ssterf( n, w, work( inde ), info ) ELSE indwrk = indtau + n CALL sopgtr( uplo, n, ap, work( indtau ), z, ldz, work( indwrk ), iinfo ) CALL ssteqr( jobz, n, w, work( inde ), z, ldz, work( indtau ), info ) END IF ! ! If matrix was scaled, then rescale eigenvalues appropriately. ! IF( iscale == 1 ) THEN IF( info == 0 ) THEN imax = n ELSE imax = info - 1 END IF CALL sscal( imax, one / sigma, w, 1 ) END IF ! RETURN ! ! End of SSPEV ! END SUBROUTINE sspev SUBROUTINE sspevd( jobz, uplo, n, ap, w, z, ldz, work, lwork, & iwork, liwork, 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 (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: ap( * ) REAL, INTENT(OUT) :: w( * ) REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(IN OUT) :: liwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSPEVD computes all the eigenvalues and, optionally, eigenvectors ! of a real symmetric matrix A in packed storage. If eigenvectors are ! desired, it uses a divide and conquer algorithm. ! ! The divide and conquer algorithm makes very mild assumptions about ! floating point arithmetic. It will work on machines with a guard ! digit in add/subtract, or on those binary machines without guard ! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or ! Cray-2. It could conceivably fail on hexadecimal or decimal machines ! without guard digits, but we know of none. ! ! 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) REAL 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) REAL array, dimension (N) ! If INFO = 0, the eigenvalues in ascending order. ! ! Z (output) REAL 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/output) REAL array, ! dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. ! If N <= 1, LWORK must be at least 1. ! If JOBZ = 'N' and N > 1, LWORK must be at least 2*N. ! If JOBZ = 'V' and N > 1, LWORK must be at least ! 1 + 6*N + N**2. ! ! 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/output) INTEGER array, dimension (LIWORK) ! On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. ! ! LIWORK (input) INTEGER ! The dimension of the array IWORK. ! If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. ! If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. ! ! If LIWORK = -1, then a workspace query is assumed; the ! routine only calculates the optimal size of the IWORK array, ! returns this value as the first entry of the IWORK array, and ! no error message related to LIWORK 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 .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, wantz INTEGER :: iinfo, inde, indtau, indwrk, iscale, liwmin, llwork, lwmin REAL :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slansp EXTERNAL lsame, slamch, slansp ! .. ! .. External Subroutines .. EXTERNAL sopmtr, sscal, ssptrd, sstedc, ssterf, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! wantz = lsame( jobz, 'V' ) lquery = ( lwork == -1 .OR. liwork == -1 ) ! info = 0 IF( n <= 1 ) THEN liwmin = 1 lwmin = 1 ELSE IF( wantz ) THEN liwmin = 3 + 5*n lwmin = 1 + 6*n + n**2 ELSE liwmin = 1 lwmin = 2*n END IF END IF 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 < 0 ) THEN info = -3 ELSE IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) THEN info = -7 ELSE IF( lwork < lwmin .AND. .NOT.lquery ) THEN info = -9 ELSE IF( liwork < liwmin .AND. .NOT.lquery ) THEN info = -11 END IF ! IF( info == 0 ) THEN work( 1 ) = lwmin iwork( 1 ) = liwmin END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSPEVD', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! IF( n == 1 ) THEN w( 1 ) = ap( 1 ) IF( wantz ) z( 1, 1 ) = one RETURN END IF ! ! Get machine constants. ! safmin = slamch( 'Safe minimum' ) eps = slamch( 'Precision' ) smlnum = safmin / eps bignum = one / smlnum rmin = SQRT( smlnum ) rmax = SQRT( bignum ) ! ! Scale matrix to allowable range, if necessary. ! anrm = slansp( 'M', uplo, n, ap, work ) iscale = 0 IF( anrm > zero .AND. anrm < rmin ) THEN iscale = 1 sigma = rmin / anrm ELSE IF( anrm > rmax ) THEN iscale = 1 sigma = rmax / anrm END IF IF( iscale == 1 ) THEN CALL sscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) END IF ! ! Call SSPTRD to reduce symmetric packed matrix to tridiagonal form. ! inde = 1 indtau = inde + n CALL ssptrd( uplo, n, ap, w, work( inde ), work( indtau ), iinfo ) ! ! For eigenvalues only, call SSTERF. For eigenvectors, first call ! SSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the ! tridiagonal matrix, then call SOPMTR to multiply it by the ! Householder transformations represented in AP. ! IF( .NOT.wantz ) THEN CALL ssterf( n, w, work( inde ), info ) ELSE indwrk = indtau + n llwork = lwork - indwrk + 1 CALL sstedc( 'I', n, w, work( inde ), z, ldz, work( indwrk ), & llwork, iwork, liwork, info ) CALL sopmtr( 'L', uplo, 'N', n, n, ap, work( indtau ), z, ldz, & work( indwrk ), iinfo ) END IF ! ! If matrix was scaled, then rescale eigenvalues appropriately. ! IF( iscale == 1 ) CALL sscal( n, one / sigma, w, 1 ) ! work( 1 ) = lwmin iwork( 1 ) = liwmin RETURN ! ! End of SSPEVD ! END SUBROUTINE sspevd SUBROUTINE sspevx( jobz, range, uplo, n, ap, vl, vu, il, iu, & abstol, m, w, z, ldz, work, 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 (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: range CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: ap( * ) REAL, INTENT(IN) :: vl REAL, INTENT(IN) :: vu INTEGER, INTENT(IN) :: il INTEGER, INTENT(IN) :: iu REAL, INTENT(IN) :: abstol INTEGER, INTENT(OUT) :: m REAL, INTENT(OUT) :: w( * ) REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN) :: ldz REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: ifail( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSPEVX computes selected eigenvalues and, optionally, eigenvectors ! of a real symmetric matrix A in packed storage. Eigenvalues/vectors ! 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. ! ! AP (input/output) REAL 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. ! ! VL (input) REAL ! VU (input) REAL ! 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) REAL ! 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 AP to tridiagonal form. ! ! Eigenvalues will be computed most accurately when ABSTOL is ! set to twice the underflow threshold 2*SLAMCH('S'), not zero. ! If this routine returns with INFO>0, indicating that some ! eigenvectors did not converge, try setting ABSTOL to ! 2*SLAMCH('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) REAL array, dimension (N) ! If INFO = 0, the selected eigenvalues in ascending order. ! ! Z (output) REAL 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) REAL array, dimension (8*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 .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: alleig, indeig, valeig, wantz CHARACTER (LEN=1) :: order INTEGER :: i, iinfo, imax, indd, inde, indee, indibl, & indisp, indiwo, indtau, indwrk, iscale, itmp1, j, jj, nsplit REAL :: abstll, anrm, bignum, eps, rmax, rmin, safmin, & sigma, smlnum, tmp1, vll, vuu ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slansp EXTERNAL lsame, slamch, slansp ! .. ! .. External Subroutines .. EXTERNAL scopy, sopgtr, sopmtr, sscal, ssptrd, sstebz, & sstein, ssteqr, ssterf, sswap, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! wantz = lsame( jobz, 'V' ) alleig = lsame( range, 'A' ) valeig = lsame( range, 'V' ) indeig = lsame( range, 'I' ) ! 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.( lsame( uplo, 'L' ) .OR. lsame( uplo, 'U' ) ) ) & THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( valeig ) THEN IF( n > 0 .AND. vu <= vl ) info = -7 ELSE IF( indeig ) THEN IF( il < 1 .OR. il > MAX( 1, n ) ) THEN info = -8 ELSE IF( iu < MIN( n, il ) .OR. iu > n ) THEN info = -9 END IF END IF END IF IF( info == 0 ) THEN IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) info = -14 END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSPEVX', -info ) RETURN END IF ! ! Quick return if possible ! m = 0 IF( n == 0 ) RETURN ! IF( n == 1 ) THEN IF( alleig .OR. indeig ) THEN m = 1 w( 1 ) = ap( 1 ) ELSE IF( vl < ap( 1 ) .AND. vu >= ap( 1 ) ) THEN m = 1 w( 1 ) = ap( 1 ) END IF END IF IF( wantz ) z( 1, 1 ) = one RETURN END IF ! ! Get machine constants. ! safmin = slamch( 'Safe minimum' ) eps = slamch( '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 IF ( valeig ) THEN vll = vl vuu = vu ELSE vll = zero vuu = zero END IF anrm = slansp( 'M', uplo, n, ap, work ) IF( anrm > zero .AND. anrm < rmin ) THEN iscale = 1 sigma = rmin / anrm ELSE IF( anrm > rmax ) THEN iscale = 1 sigma = rmax / anrm END IF IF( iscale == 1 ) THEN CALL sscal( ( n*( n+1 ) ) / 2, sigma, ap, 1 ) IF( abstol > 0 ) abstll = abstol*sigma IF( valeig ) THEN vll = vl*sigma vuu = vu*sigma END IF END IF ! ! Call SSPTRD to reduce symmetric packed matrix to tridiagonal form. ! indtau = 1 inde = indtau + n indd = inde + n indwrk = indd + n CALL ssptrd( uplo, n, ap, work( indd ), work( inde ), work( indtau ), iinfo ) ! ! If all eigenvalues are desired and ABSTOL is less than or equal ! to zero, then call SSTERF or SOPGTR and SSTEQR. If this fails ! for some eigenvalue, then try SSTEBZ. ! IF( ( alleig .OR. ( indeig .AND. il == 1 .AND. iu == n ) ) .AND. & ( abstol <= zero ) ) THEN CALL scopy( n, work( indd ), 1, w, 1 ) indee = indwrk + 2*n IF( .NOT.wantz ) THEN CALL scopy( n-1, work( inde ), 1, work( indee ), 1 ) CALL ssterf( n, w, work( indee ), info ) ELSE CALL sopgtr( uplo, n, ap, work( indtau ), z, ldz, work( indwrk ), iinfo ) CALL scopy( n-1, work( inde ), 1, work( indee ), 1 ) CALL ssteqr( jobz, n, w, work( indee ), z, ldz, work( indwrk ), info ) IF( info == 0 ) THEN DO i = 1, n ifail( i ) = 0 END DO END IF END IF IF( info == 0 ) THEN m = n GO TO 20 END IF info = 0 END IF ! ! Otherwise, call SSTEBZ 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 sstebz( 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 sstein( 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 SSTEIN. ! CALL sopmtr( 'L', uplo, 'N', n, m, ap, work( indtau ), z, ldz, & work( indwrk ), info ) END IF ! ! If matrix was scaled, then rescale eigenvalues appropriately. ! 20 CONTINUE IF( iscale == 1 ) THEN IF( info == 0 ) THEN imax = m ELSE imax = info - 1 END IF CALL sscal( imax, one / sigma, w, 1 ) END IF ! ! If eigenvalues are not in order, then sort them, along with ! eigenvectors. ! IF( wantz ) THEN DO j = 1, m - 1 i = 0 tmp1 = w( j ) DO jj = j + 1, m IF( w( jj ) < tmp1 ) THEN i = jj tmp1 = w( jj ) END IF END DO ! IF( i /= 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 sswap( n, z( 1, i ), 1, z( 1, j ), 1 ) IF( info /= 0 ) THEN itmp1 = ifail( i ) ifail( i ) = ifail( j ) ifail( j ) = itmp1 END IF END IF END DO END IF ! RETURN ! ! End of SSPEVX ! END SUBROUTINE sspevx SUBROUTINE sspgst( itype, uplo, n, ap, bp, 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, INTENT(IN) :: itype CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(OUT) :: ap( * ) REAL, INTENT(IN) :: bp( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSPGST reduces a real symmetric-definite generalized eigenproblem ! to standard form, using packed storage. ! ! 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 SPPTRF. ! ! 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. ! ! AP (input/output) REAL 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, if INFO = 0, the transformed matrix, stored in the ! same format as A. ! ! BP (input) REAL array, dimension (N*(N+1)/2) ! The triangular factor from the Cholesky factorization of B, ! stored in the same format as A, as returned by SPPTRF. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0 REAL, PARAMETER :: half = 0.5 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: j, j1, j1j1, jj, k, k1, k1k1, kk REAL :: ajj, akk, bjj, bkk, ct ! .. ! .. External Subroutines .. EXTERNAL saxpy, sscal, sspmv, sspr2, stpmv, stpsv, xerbla ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: sdot EXTERNAL lsame, sdot ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 upper = lsame( uplo, 'U' ) IF( itype < 1 .OR. itype > 3 ) THEN info = -1 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSPGST', -info ) RETURN END IF ! IF( itype == 1 ) THEN IF( upper ) THEN ! ! Compute inv(U')*A*inv(U) ! ! J1 and JJ are the indices of A(1,j) and A(j,j) ! jj = 0 DO j = 1, n j1 = jj + 1 jj = jj + j ! ! Compute the j-th column of the upper triangle of A ! bjj = bp( jj ) CALL stpsv( uplo, 'Transpose', 'Nonunit', j, bp, ap( j1 ), 1 ) CALL sspmv( uplo, j-1, -one, ap, bp( j1 ), 1, one, ap( j1 ), 1 ) CALL sscal( j-1, one / bjj, ap( j1 ), 1 ) ap( jj ) = ( ap( jj )-sdot( j-1, ap( j1 ), 1, bp( j1 ), 1 ) ) / bjj END DO ELSE ! ! Compute inv(L)*A*inv(L') ! ! KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) ! kk = 1 DO k = 1, n k1k1 = kk + n - k + 1 ! ! Update the lower triangle of A(k:n,k:n) ! akk = ap( kk ) bkk = bp( kk ) akk = akk / bkk**2 ap( kk ) = akk IF( k < n ) THEN CALL sscal( n-k, one / bkk, ap( kk+1 ), 1 ) ct = -half*akk CALL saxpy( n-k, ct, bp( kk+1 ), 1, ap( kk+1 ), 1 ) CALL sspr2( uplo, n-k, -one, ap( kk+1 ), 1, & bp( kk+1 ), 1, ap( k1k1 ) ) CALL saxpy( n-k, ct, bp( kk+1 ), 1, ap( kk+1 ), 1 ) CALL stpsv( uplo, 'No transpose', 'Non-unit', n-k, & bp( k1k1 ), ap( kk+1 ), 1 ) END IF kk = k1k1 END DO END IF ELSE IF( upper ) THEN ! ! Compute U*A*U' ! ! K1 and KK are the indices of A(1,k) and A(k,k) ! kk = 0 DO k = 1, n k1 = kk + 1 kk = kk + k ! ! Update the upper triangle of A(1:k,1:k) ! akk = ap( kk ) bkk = bp( kk ) CALL stpmv( uplo, 'No transpose', 'Non-unit', k-1, bp, ap( k1 ), 1 ) ct = half*akk CALL saxpy( k-1, ct, bp( k1 ), 1, ap( k1 ), 1 ) CALL sspr2( uplo, k-1, one, ap( k1 ), 1, bp( k1 ), 1, ap ) CALL saxpy( k-1, ct, bp( k1 ), 1, ap( k1 ), 1 ) CALL sscal( k-1, bkk, ap( k1 ), 1 ) ap( kk ) = akk*bkk**2 END DO ELSE ! ! Compute L'*A*L ! ! JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) ! jj = 1 DO j = 1, n j1j1 = jj + n - j + 1 ! ! Compute the j-th column of the lower triangle of A ! ajj = ap( jj ) bjj = bp( jj ) ap( jj ) = ajj*bjj + sdot( n-j, ap( jj+1 ), 1, bp( jj+1 ), 1 ) CALL sscal( n-j, bjj, ap( jj+1 ), 1 ) CALL sspmv( uplo, n-j, one, ap( j1j1 ), bp( jj+1 ), 1, & one, ap( jj+1 ), 1 ) CALL stpmv( uplo, 'Transpose', 'Non-unit', n-j+1, & bp( jj ), ap( jj ), 1 ) jj = j1j1 END DO END IF END IF RETURN ! ! End of SSPGST ! END SUBROUTINE sspgst SUBROUTINE sspgv( itype, jobz, uplo, n, ap, bp, w, z, ldz, work, info ) ! ! -- LAPACK driver 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, INTENT(IN) :: itype CHARACTER (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: ap( * ) REAL, INTENT(IN OUT) :: bp( * ) REAL, INTENT(IN OUT) :: w( * ) REAL, INTENT(IN OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSPGV 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, stored in packed format, ! 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. ! ! AP (input/output) REAL 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, the contents of AP are destroyed. ! ! BP (input/output) REAL array, dimension (N*(N+1)/2) ! On entry, the upper or lower triangle of the symmetric matrix ! B, packed columnwise in a linear array. The j-th column of B ! is stored in the array BP as follows: ! if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; ! if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. ! ! On exit, the triangular factor U or L from the Cholesky ! factorization B = U**T*U or B = L*L**T, in the same storage ! format as B. ! ! W (output) REAL array, dimension (N) ! If INFO = 0, the eigenvalues in ascending order. ! ! Z (output) REAL array, dimension (LDZ, N) ! If JOBZ = 'V', then if INFO = 0, Z 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 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) REAL array, dimension (3*N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! > 0: SPPTRF or SSPEV returned an error code: ! <= N: if INFO = i, SSPEV 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. ! ! ===================================================================== ! ! .. Local Scalars .. LOGICAL :: upper, wantz CHARACTER (LEN=1) :: trans INTEGER :: j, neig ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL spptrf, sspev, sspgst, stpmv, stpsv, xerbla ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! wantz = lsame( jobz, 'V' ) upper = lsame( uplo, 'U' ) ! info = 0 IF( itype < 0 .OR. itype > 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 < 0 ) THEN info = -4 ELSE IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) THEN info = -9 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSPGV ', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Form a Cholesky factorization of B. ! CALL spptrf( uplo, n, bp, info ) IF( info /= 0 ) THEN info = n + info RETURN END IF ! ! Transform problem to standard eigenvalue problem and solve. ! CALL sspgst( itype, uplo, n, ap, bp, info ) CALL sspev( jobz, uplo, n, ap, w, z, ldz, work, info ) ! IF( wantz ) THEN ! ! Backtransform eigenvectors to the original problem. ! neig = n IF( info > 0 ) neig = info - 1 IF( itype == 1 .OR. itype == 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 ! DO j = 1, neig CALL stpsv( uplo, trans, 'Non-unit', n, bp, z( 1, j ), 1 ) END DO ! ELSE IF( itype == 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 ! DO j = 1, neig CALL stpmv( uplo, trans, 'Non-unit', n, bp, z( 1, j ), 1 ) END DO END IF END IF RETURN ! ! End of SSPGV ! END SUBROUTINE sspgv SUBROUTINE sspgvd( itype, jobz, uplo, n, ap, bp, w, z, ldz, work, & lwork, iwork, liwork, 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 .. INTEGER, INTENT(IN) :: itype CHARACTER (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: ap( * ) REAL, INTENT(IN OUT) :: bp( * ) REAL, INTENT(IN OUT) :: w( * ) REAL, INTENT(IN OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(IN OUT) :: liwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSPGVD 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, stored in packed format, and B is also ! positive definite. ! If eigenvectors are desired, it uses a divide and conquer algorithm. ! ! The divide and conquer algorithm makes very mild assumptions about ! floating point arithmetic. It will work on machines with a guard ! digit in add/subtract, or on those binary machines without guard ! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or ! Cray-2. It could conceivably fail on hexadecimal or decimal machines ! without guard digits, but we know of none. ! ! 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. ! ! AP (input/output) REAL 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, the contents of AP are destroyed. ! ! BP (input/output) REAL array, dimension (N*(N+1)/2) ! On entry, the upper or lower triangle of the symmetric matrix ! B, packed columnwise in a linear array. The j-th column of B ! is stored in the array BP as follows: ! if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; ! if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. ! ! On exit, the triangular factor U or L from the Cholesky ! factorization B = U**T*U or B = L*L**T, in the same storage ! format as B. ! ! W (output) REAL array, dimension (N) ! If INFO = 0, the eigenvalues in ascending order. ! ! Z (output) REAL array, dimension (LDZ, N) ! If JOBZ = 'V', then if INFO = 0, Z 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 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/output) REAL array, dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. ! If N <= 1, LWORK >= 1. ! If JOBZ = 'N' and N > 1, LWORK >= 2*N. ! If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. ! ! 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/output) INTEGER array, dimension (LIWORK) ! On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. ! ! LIWORK (input) INTEGER ! The dimension of the array IWORK. ! If JOBZ = 'N' or N <= 1, LIWORK >= 1. ! If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. ! ! If LIWORK = -1, then a workspace query is assumed; the ! routine only calculates the optimal size of the IWORK array, ! returns this value as the first entry of the IWORK array, and ! no error message related to LIWORK is issued by XERBLA. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! > 0: SPPTRF or SSPEVD returned an error code: ! <= N: if INFO = i, SSPEVD 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. ! ! Further Details ! =============== ! ! Based on contributions by ! Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: two = 2.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, upper, wantz CHARACTER (LEN=1) :: trans INTEGER :: j, lgn, liwmin, lwmin, neig ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL spptrf, sspevd, sspgst, stpmv, stpsv, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC INT, LOG, MAX, REAL ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! wantz = lsame( jobz, 'V' ) upper = lsame( uplo, 'U' ) lquery = ( lwork == -1 .OR. liwork == -1 ) ! info = 0 IF( n <= 1 ) THEN lgn = 0 liwmin = 1 lwmin = 1 ELSE lgn = INT( LOG( REAL( n ) ) / LOG( two ) ) IF( 2**lgn < n ) lgn = lgn + 1 IF( 2**lgn < n ) lgn = lgn + 1 IF( wantz ) THEN liwmin = 3 + 5*n lwmin = 1 + 5*n + 2*n*lgn + 2*n**2 ELSE liwmin = 1 lwmin = 2*n END IF END IF ! IF( itype < 0 .OR. itype > 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 < 0 ) THEN info = -4 ELSE IF( ldz < MAX( 1, n ) ) THEN info = -9 ELSE IF( lwork < lwmin .AND. .NOT.lquery ) THEN info = -11 ELSE IF( liwork < liwmin .AND. .NOT.lquery ) THEN info = -13 END IF ! IF( info == 0 ) THEN work( 1 ) = lwmin iwork( 1 ) = liwmin END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSPGVD', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Form a Cholesky factorization of BP. ! CALL spptrf( uplo, n, bp, info ) IF( info /= 0 ) THEN info = n + info RETURN END IF ! ! Transform problem to standard eigenvalue problem and solve. ! CALL sspgst( itype, uplo, n, ap, bp, info ) CALL sspevd( jobz, uplo, n, ap, w, z, ldz, work, lwork, iwork, liwork, info ) lwmin = MAX( REAL( lwmin ), REAL( work( 1 ) ) ) liwmin = MAX( REAL( liwmin ), REAL( iwork( 1 ) ) ) ! IF( wantz ) THEN ! ! Backtransform eigenvectors to the original problem. ! neig = n IF( info > 0 ) neig = info - 1 IF( itype == 1 .OR. itype == 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 ! DO j = 1, neig CALL stpsv( uplo, trans, 'Non-unit', n, bp, z( 1, j ), 1 ) END DO ! ELSE IF( itype == 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 ! DO j = 1, neig CALL stpmv( uplo, trans, 'Non-unit', n, bp, z( 1, j ), 1 ) END DO END IF END IF ! work( 1 ) = lwmin iwork( 1 ) = liwmin ! RETURN ! ! End of SSPGVD ! END SUBROUTINE sspgvd SUBROUTINE sspgvx( itype, jobz, range, uplo, n, ap, bp, vl, vu, & il, iu, abstol, m, w, z, ldz, work, 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 .. INTEGER, INTENT(IN) :: itype CHARACTER (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: range CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: ap( * ) REAL, INTENT(IN OUT) :: bp( * ) REAL, INTENT(IN OUT) :: vl REAL, INTENT(IN OUT) :: vu INTEGER, INTENT(IN OUT) :: il INTEGER, INTENT(IN OUT) :: iu REAL, INTENT(IN OUT) :: abstol INTEGER, INTENT(OUT) :: m REAL, INTENT(IN OUT) :: w( * ) REAL, INTENT(IN OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(IN OUT) :: ifail( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSPGVX 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, stored in packed storage, 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. ! ! AP (input/output) REAL 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, the contents of AP are destroyed. ! ! BP (input/output) REAL array, dimension (N*(N+1)/2) ! On entry, the upper or lower triangle of the symmetric matrix ! B, packed columnwise in a linear array. The j-th column of B ! is stored in the array BP as follows: ! if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; ! if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. ! ! On exit, the triangular factor U or L from the Cholesky ! factorization B = U**T*U or B = L*L**T, in the same storage ! format as B. ! ! VL (input) REAL ! VU (input) REAL ! 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) REAL ! 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*SLAMCH('S'), not zero. ! If this routine returns with INFO>0, indicating that some ! eigenvectors did not converge, try setting ABSTOL to ! 2*SLAMCH('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) REAL array, dimension (N) ! On normal exit, the first M elements contain the selected ! eigenvalues in ascending order. ! ! Z (output) REAL 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) REAL array, dimension (8*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: SPPTRF or SSPEVX returned an error code: ! <= N: if INFO = i, SSPEVX 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 ! ! ===================================================================== ! ! .. Local Scalars .. LOGICAL :: alleig, indeig, upper, valeig, wantz CHARACTER (LEN=1) :: trans INTEGER :: j ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL spptrf, sspevx, sspgst, stpmv, stpsv, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC 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' ) ! info = 0 IF( itype < 0 .OR. itype > 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 < 0 ) THEN info = -5 ELSE IF( valeig .AND. n > 0 .AND. vu <= vl ) THEN info = -9 ELSE IF( indeig .AND. il < 1 ) THEN info = -10 ELSE IF( indeig .AND. ( iu < MIN( n, il ) .OR. iu > n ) ) THEN info = -11 ELSE IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) THEN info = -16 END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSPGVX', -info ) RETURN END IF ! ! Quick return if possible ! m = 0 IF( n == 0 ) THEN work( 1 ) = 1 RETURN END IF ! ! Form a Cholesky factorization of B. ! CALL spptrf( uplo, n, bp, info ) IF( info /= 0 ) THEN info = n + info RETURN END IF ! ! Transform problem to standard eigenvalue problem and solve. ! CALL sspgst( itype, uplo, n, ap, bp, info ) CALL sspevx( jobz, range, uplo, n, ap, vl, vu, il, iu, abstol, m, & w, z, ldz, work, iwork, ifail, info ) ! IF( wantz ) THEN ! ! Backtransform eigenvectors to the original problem. ! IF( info > 0 ) m = info - 1 IF( itype == 1 .OR. itype == 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 ! DO j = 1, m CALL stpsv( uplo, trans, 'Non-unit', n, bp, z( 1, j ), 1 ) END DO ! ELSE IF( itype == 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 ! DO j = 1, m CALL stpmv( uplo, trans, 'Non-unit', n, bp, z( 1, j ), 1 ) END DO END IF END IF ! RETURN ! ! End of SSPGVX ! END SUBROUTINE sspgvx SUBROUTINE ssprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, & ferr, berr, 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 ! September 30, 1994 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: ap( * ) REAL, INTENT(IN OUT) :: afp( * ) INTEGER, INTENT(IN OUT) :: ipiv( * ) REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: ferr( * ) REAL, INTENT(OUT) :: berr( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSPRFS improves the computed solution to a system of linear ! equations when the coefficient matrix is symmetric indefinite ! and packed, and provides error bounds and backward error estimates ! for the solution. ! ! 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 matrices B and X. NRHS >= 0. ! ! AP (input) REAL 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)*(2*n-j)/2) = A(i,j) for j<=i<=n. ! ! AFP (input) REAL array, dimension (N*(N+1)/2) ! The factored form of the matrix A. AFP contains the block ! diagonal matrix D and the multipliers used to obtain the ! factor U or L from the factorization A = U*D*U**T or ! A = L*D*L**T as computed by SSPTRF, 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 SSPTRF. ! ! B (input) REAL array, dimension (LDB,NRHS) ! The right hand side matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (input/output) REAL array, dimension (LDX,NRHS) ! On entry, the solution matrix X, as computed by SSPTRS. ! On exit, the improved solution matrix X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! Internal Parameters ! =================== ! ! ITMAX is the maximum number of steps of iterative refinement. ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: itmax = 5 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 REAL, PARAMETER :: three = 3.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: count, i, ik, j, k, kase, kk, nz REAL :: eps, lstres, s, safe1, safe2, safmin, xk ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, slacon, sspmv, ssptrs, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. 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 < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -8 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -10 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSPRFS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) THEN DO j = 1, nrhs ferr( j ) = zero berr( j ) = zero END DO RETURN END IF ! ! NZ = maximum number of nonzero elements in each row of A, plus 1 ! nz = n + 1 eps = slamch( 'Epsilon' ) safmin = slamch( 'Safe minimum' ) safe1 = nz*safmin safe2 = safe1 / eps ! ! Do for each right hand side ! DO j = 1, nrhs ! count = 1 lstres = three 20 CONTINUE ! ! Loop until stopping criterion is satisfied. ! ! Compute residual R = B - A * X ! CALL scopy( n, b( 1, j ), 1, work( n+1 ), 1 ) CALL sspmv( uplo, n, -one, ap, x( 1, j ), 1, one, work( n+1 ), 1 ) ! ! Compute componentwise relative backward error from formula ! ! max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) ! ! where abs(Z) is the componentwise absolute value of the matrix ! or vector Z. If the i-th component of the denominator is less ! than SAFE2, then SAFE1 is added to the i-th components of the ! numerator and denominator before dividing. ! DO i = 1, n work( i ) = ABS( b( i, j ) ) END DO ! ! Compute abs(A)*abs(X) + abs(B). ! kk = 1 IF( upper ) THEN DO k = 1, n s = zero xk = ABS( x( k, j ) ) ik = kk DO i = 1, k - 1 work( i ) = work( i ) + ABS( ap( ik ) )*xk s = s + ABS( ap( ik ) )*ABS( x( i, j ) ) ik = ik + 1 END DO work( k ) = work( k ) + ABS( ap( kk+k-1 ) )*xk + s kk = kk + k END DO ELSE DO k = 1, n s = zero xk = ABS( x( k, j ) ) work( k ) = work( k ) + ABS( ap( kk ) )*xk ik = kk + 1 DO i = k + 1, n work( i ) = work( i ) + ABS( ap( ik ) )*xk s = s + ABS( ap( ik ) )*ABS( x( i, j ) ) ik = ik + 1 END DO work( k ) = work( k ) + s kk = kk + ( n-k+1 ) END DO END IF s = zero DO i = 1, n IF( work( i ) > safe2 ) THEN s = MAX( s, ABS( work( n+i ) ) / work( i ) ) ELSE s = MAX( s, ( ABS( work( n+i ) )+safe1 ) / ( work( i )+safe1 ) ) END IF END DO berr( j ) = s ! ! Test stopping criterion. Continue iterating if ! 1) The residual BERR(J) is larger than machine epsilon, and ! 2) BERR(J) decreased by at least a factor of 2 during the ! last iteration, and ! 3) At most ITMAX iterations tried. ! IF( berr( j ) > eps .AND. two*berr( j ) <= lstres .AND. & count <= itmax ) THEN ! ! Update solution and try again. ! CALL ssptrs( uplo, n, 1, afp, ipiv, work( n+1 ), n, info ) CALL saxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 GO TO 20 END IF ! ! Bound error from formula ! ! norm(X - XTRUE) / norm(X) .le. FERR = ! norm( abs(inv(A))* ! ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) ! ! where ! norm(Z) is the magnitude of the largest component of Z ! inv(A) is the inverse of A ! abs(Z) is the componentwise absolute value of the matrix or ! vector Z ! NZ is the maximum number of nonzeros in any row of A, plus 1 ! EPS is machine epsilon ! ! The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) ! is incremented by SAFE1 if the i-th component of ! abs(A)*abs(X) + abs(B) is less than SAFE2. ! ! Use SLACON to estimate the infinity-norm of the matrix ! inv(A) * diag(W), ! where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) ! DO i = 1, n IF( work( i ) > safe2 ) THEN work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) ELSE work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) + safe1 END IF END DO ! kase = 0 100 CONTINUE CALL slacon( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ), kase ) IF( kase /= 0 ) THEN IF( kase == 1 ) THEN ! ! Multiply by diag(W)*inv(A'). ! CALL ssptrs( uplo, n, 1, afp, ipiv, work( n+1 ), n, info ) DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO ELSE IF( kase == 2 ) THEN ! ! Multiply by inv(A)*diag(W). ! DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO CALL ssptrs( uplo, n, 1, afp, ipiv, work( n+1 ), n, info ) END IF GO TO 100 END IF ! ! Normalize error. ! lstres = zero DO i = 1, n lstres = MAX( lstres, ABS( x( i, j ) ) ) END DO IF( lstres /= zero ) ferr( j ) = ferr( j ) / lstres ! END DO ! RETURN ! ! End of SSPRFS ! END SUBROUTINE ssprfs SUBROUTINE sspsv( uplo, n, nrhs, ap, 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 .. CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN OUT) :: nrhs REAL, INTENT(IN OUT) :: ap( * ) INTEGER, INTENT(IN OUT) :: ipiv( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSPSV computes the solution to a real system of linear equations ! A * X = B, ! where A is an N-by-N symmetric matrix stored in packed format and X ! and B are N-by-NRHS matrices. ! ! The diagonal pivoting method is used to factor A as ! A = U * D * U**T, if UPLO = 'U', or ! A = L * D * L**T, if UPLO = 'L', ! where U (or L) is a product of permutation and unit upper (lower) ! triangular matrices, D is symmetric and block diagonal with 1-by-1 ! and 2-by-2 diagonal blocks. The factored form of A is then used to ! solve the system of equations A * X = B. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! = 'U': Upper triangle of A is stored; ! = 'L': Lower triangle of A is stored. ! ! 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. ! ! AP (input/output) REAL 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. ! See below for further details. ! ! On exit, the block diagonal matrix D and the multipliers used ! to obtain the factor U or L from the factorization ! A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as ! a packed triangular matrix in the same storage format as A. ! ! IPIV (output) INTEGER array, dimension (N) ! Details of the interchanges and the block structure of D, as ! determined by SSPTRF. 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. ! ! B (input/output) REAL 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, D(i,i) is exactly zero. The factorization ! has been completed, but the block diagonal matrix D is ! exactly singular, so the solution could not be ! computed. ! ! Further Details ! =============== ! ! The packed storage scheme is illustrated by the following example ! when N = 4, UPLO = 'U': ! ! Two-dimensional storage of the symmetric matrix A: ! ! a11 a12 a13 a14 ! a22 a23 a24 ! a33 a34 (aij = aji) ! a44 ! ! Packed storage of the upper triangle of A: ! ! AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] ! ! ===================================================================== ! ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL ssptrf, ssptrs, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -7 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSPSV ', -info ) RETURN END IF ! ! Compute the factorization A = U*D*U' or A = L*D*L'. ! CALL ssptrf( uplo, n, ap, ipiv, info ) IF( info == 0 ) THEN ! ! Solve the system A*X = B, overwriting B with X. ! CALL ssptrs( uplo, n, nrhs, ap, ipiv, b, ldb, info ) ! END IF RETURN ! ! End of SSPSV ! END SUBROUTINE sspsv SUBROUTINE sspsvx( fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, & ldx, rcond, ferr, berr, work, iwork, 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 (LEN=1), INTENT(IN) :: fact CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: nrhs REAL, INTENT(IN) :: ap( * ) REAL, INTENT(IN OUT) :: afp( * ) INTEGER, INTENT(IN OUT) :: ipiv( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: rcond REAL, INTENT(IN OUT) :: ferr( * ) REAL, INTENT(IN OUT) :: berr( * ) REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSPSVX uses the diagonal pivoting factorization A = U*D*U**T or ! A = L*D*L**T to compute the solution to a real system of linear ! equations A * X = B, where A is an N-by-N symmetric matrix stored ! in packed format and X and B are N-by-NRHS matrices. ! ! Error bounds on the solution and a condition estimate are also ! provided. ! ! Description ! =========== ! ! The following steps are performed: ! ! 1. If FACT = 'N', the diagonal pivoting method is used to factor A as ! A = U * D * U**T, if UPLO = 'U', or ! A = L * D * L**T, if UPLO = 'L', ! 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. ! ! 2. If some D(i,i)=0, so that D is exactly singular, then the routine ! returns with INFO = i. Otherwise, the factored form of A is used ! to estimate the condition number of the matrix A. If the ! reciprocal of the condition number is less than machine precision, ! INFO = N+1 is returned as a warning, but the routine still goes on ! to solve for X and compute error bounds as described below. ! ! 3. The system of equations is solved for X using the factored form ! of A. ! ! 4. Iterative refinement is applied to improve the computed solution ! matrix and calculate error bounds and backward error estimates ! for it. ! ! Arguments ! ========= ! ! FACT (input) CHARACTER*1 ! Specifies whether or not the factored form of A has been ! supplied on entry. ! = 'F': On entry, AFP and IPIV contain the factored form of ! A. AP, AFP and IPIV will not be modified. ! = 'N': The matrix A will be copied to AFP and factored. ! ! UPLO (input) CHARACTER*1 ! = 'U': Upper triangle of A is stored; ! = 'L': Lower triangle of A is stored. ! ! 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 matrices B and X. NRHS >= 0. ! ! AP (input) REAL 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)*(2*n-j)/2) = A(i,j) for j<=i<=n. ! See below for further details. ! ! AFP (input or output) REAL array, dimension ! (N*(N+1)/2) ! If FACT = 'F', then AFP is an input argument and on entry ! contains the block diagonal matrix D and the multipliers used ! to obtain the factor U or L from the factorization ! A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as ! a packed triangular matrix in the same storage format as A. ! ! If FACT = 'N', then AFP is an output argument and on exit ! contains the block diagonal matrix D and the multipliers used ! to obtain the factor U or L from the factorization ! A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as ! a packed triangular matrix in the same storage format as A. ! ! IPIV (input or output) INTEGER array, dimension (N) ! If FACT = 'F', then IPIV is an input argument and on entry ! contains details of the interchanges and the block structure ! of D, as determined by SSPTRF. ! 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. ! ! If FACT = 'N', then IPIV is an output argument and on exit ! contains details of the interchanges and the block structure ! of D, as determined by SSPTRF. ! ! B (input) REAL array, dimension (LDB,NRHS) ! The N-by-NRHS right hand side matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (output) REAL array, dimension (LDX,NRHS) ! If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! RCOND (output) REAL ! The estimate of the reciprocal condition number of the matrix ! A. If RCOND is less than the machine precision (in ! particular, if RCOND = 0), the matrix is singular to working ! precision. This condition is indicated by a return code of ! INFO > 0. ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER 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, and i is ! <= N: D(i,i) is exactly zero. The factorization ! has been completed but the factor D is exactly ! singular, so the solution and error bounds could ! not be computed. RCOND = 0 is returned. ! = N+1: D is nonsingular, but RCOND is less than machine ! precision, meaning that the matrix is singular ! to working precision. Nevertheless, the ! solution and error bounds are computed because ! there are a number of situations where the ! computed solution can be more accurate than the ! value of RCOND would suggest. ! ! Further Details ! =============== ! ! The packed storage scheme is illustrated by the following example ! when N = 4, UPLO = 'U': ! ! Two-dimensional storage of the symmetric matrix A: ! ! a11 a12 a13 a14 ! a22 a23 a24 ! a33 a34 (aij = aji) ! a44 ! ! Packed storage of the upper triangle of A: ! ! AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: nofact REAL :: anorm ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slansp EXTERNAL lsame, slamch, slansp ! .. ! .. External Subroutines .. EXTERNAL scopy, slacpy, sspcon, ssprfs, ssptrf, ssptrs, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 nofact = lsame( fact, 'N' ) IF( .NOT.nofact .AND. .NOT.lsame( fact, 'F' ) ) THEN info = -1 ELSE IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) & THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( nrhs < 0 ) THEN info = -4 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -9 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -11 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSPSVX', -info ) RETURN END IF ! IF( nofact ) THEN ! ! Compute the factorization A = U*D*U' or A = L*D*L'. ! CALL scopy( n*( n+1 ) / 2, ap, 1, afp, 1 ) CALL ssptrf( uplo, n, afp, ipiv, info ) ! ! Return if INFO is non-zero. ! IF( info /= 0 ) THEN IF( info > 0 ) rcond = zero RETURN END IF END IF ! ! Compute the norm of the matrix A. ! anorm = slansp( 'I', uplo, n, ap, work ) ! ! Compute the reciprocal of the condition number of A. ! CALL sspcon( uplo, n, afp, ipiv, anorm, rcond, work, iwork, info ) ! ! Set INFO = N+1 if the matrix is singular to working precision. ! IF( rcond < slamch( 'Epsilon' ) ) info = n + 1 ! ! Compute the solution vectors X. ! CALL slacpy( 'Full', n, nrhs, b, ldb, x, ldx ) CALL ssptrs( uplo, n, nrhs, afp, ipiv, x, ldx, info ) ! ! Use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. ! CALL ssprfs( uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr, & berr, work, iwork, info ) ! RETURN ! ! End of SSPSVX ! END SUBROUTINE sspsvx SUBROUTINE ssptrd( 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 ! March 31, 1993 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN OUT) :: ap( * ) REAL, INTENT(OUT) :: d( * ) REAL, INTENT(OUT) :: e( * ) REAL, INTENT(IN OUT) :: tau( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSPTRD 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) REAL 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) REAL array, dimension (N) ! The diagonal elements of the tridiagonal matrix T: ! D(i) = A(i,i). ! ! E (output) REAL 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) REAL 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 .. REAL, PARAMETER :: one = 1.0 REAL, PARAMETER :: zero = 0.0 REAL, PARAMETER :: half = 1.0 / 2.0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: i, i1, i1i1, ii REAL :: alpha, taui ! .. ! .. External Subroutines .. EXTERNAL saxpy, slarfg, sspmv, sspr2, xerbla ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: sdot EXTERNAL lsame, sdot ! .. ! .. 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 < 0 ) THEN info = -2 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSPTRD', -info ) RETURN END IF ! ! Quick return if possible ! IF( n <= 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 i = n - 1, 1, -1 ! ! Generate elementary reflector H(i) = I - tau * v * v' ! to annihilate A(1:i-1,i+1) ! CALL slarfg( i, ap( i1+i-1 ), ap( i1 ), 1, taui ) e( i ) = ap( i1+i-1 ) ! IF( taui /= 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 sspmv( uplo, i, taui, ap, ap( i1 ), 1, zero, tau, 1 ) ! ! Compute w := y - 1/2 * tau * (y'*v) * v ! alpha = -half*taui*sdot( i, tau, 1, ap( i1 ), 1 ) CALL saxpy( i, alpha, ap( i1 ), 1, tau, 1 ) ! ! Apply the transformation as a rank-2 update: ! A := A - v * w' - w * v' ! CALL sspr2( 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 END DO 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 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 slarfg( n-i, ap( ii+1 ), ap( ii+2 ), 1, taui ) e( i ) = ap( ii+1 ) ! IF( taui /= 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 sspmv( 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*sdot( n-i, tau( i ), 1, ap( ii+1 ), 1 ) CALL saxpy( 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 sspr2( 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 END DO d( n ) = ap( ii ) END IF ! RETURN ! ! End of SSPTRD ! END SUBROUTINE ssptrd SUBROUTINE ssptrf( 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN OUT) :: ap( * ) INTEGER, INTENT(OUT) :: ipiv( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSPTRF 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) REAL 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 .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: eight = 8.0E+0 REAL, PARAMETER :: sevten = 17.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: i, imax, j, jmax, k, kc, kk, knc, kp, kpc, kstep, kx, npp REAL :: absakk, alpha, colmax, d11, d12, d21, d22, r1, & rowmax, t, wk, wkm1, wkp1 ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: isamax EXTERNAL lsame, isamax ! .. ! .. External Subroutines .. EXTERNAL sscal, sspr, sswap, 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 < 0 ) THEN info = -2 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSPTRF', -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 < 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 > 1 ) THEN imax = isamax( k-1, ap( kc ), 1 ) colmax = ABS( ap( kc+imax-1 ) ) ELSE colmax = zero END IF ! IF( MAX( absakk, colmax ) == zero ) THEN ! ! Column K is zero: set INFO and continue ! IF( info == 0 ) info = k kp = k ELSE IF( absakk >= 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 j = imax + 1, k IF( ABS( ap( kx ) ) > rowmax ) THEN rowmax = ABS( ap( kx ) ) jmax = j END IF kx = kx + j END DO kpc = ( imax-1 )*imax / 2 + 1 IF( imax > 1 ) THEN jmax = isamax( imax-1, ap( kpc ), 1 ) rowmax = MAX( rowmax, ABS( ap( kpc+jmax-1 ) ) ) END IF ! IF( absakk >= alpha*colmax*( colmax / rowmax ) ) THEN ! ! no interchange, use 1-by-1 pivot block ! kp = k ELSE IF( ABS( ap( kpc+imax-1 ) ) >= 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 == 2 ) knc = knc - k + 1 IF( kp /= kk ) THEN ! ! Interchange rows and columns KK and KP in the leading ! submatrix A(1:k,1:k) ! CALL sswap( kp-1, ap( knc ), 1, ap( kpc ), 1 ) kx = kpc + kp - 1 DO j = kp + 1, kk - 1 kx = kx + j - 1 t = ap( knc+j-1 ) ap( knc+j-1 ) = ap( kx ) ap( kx ) = t END DO t = ap( knc+kk-1 ) ap( knc+kk-1 ) = ap( kpc+kp-1 ) ap( kpc+kp-1 ) = t IF( kstep == 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 == 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 sspr( uplo, k-1, -r1, ap( kc ), 1, ap ) ! ! Store U(k) in column k ! CALL sscal( 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 > 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 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 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 END DO ap( j+( k-1 )*k / 2 ) = wk ap( j+( k-2 )*( k-1 ) / 2 ) = wkm1 END DO ! END IF ! END IF END IF ! ! Store details of the interchanges in IPIV ! IF( kstep == 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 > 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 < n ) THEN imax = k + isamax( n-k, ap( kc+1 ), 1 ) colmax = ABS( ap( kc+imax-k ) ) ELSE colmax = zero END IF ! IF( MAX( absakk, colmax ) == zero ) THEN ! ! Column K is zero: set INFO and continue ! IF( info == 0 ) info = k kp = k ELSE IF( absakk >= 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 j = k, imax - 1 IF( ABS( ap( kx ) ) > rowmax ) THEN rowmax = ABS( ap( kx ) ) jmax = j END IF kx = kx + n - j END DO kpc = npp - ( n-imax+1 )*( n-imax+2 ) / 2 + 1 IF( imax < n ) THEN jmax = imax + isamax( n-imax, ap( kpc+1 ), 1 ) rowmax = MAX( rowmax, ABS( ap( kpc+jmax-imax ) ) ) END IF ! IF( absakk >= alpha*colmax*( colmax / rowmax ) ) THEN ! ! no interchange, use 1-by-1 pivot block ! kp = k ELSE IF( ABS( ap( kpc ) ) >= 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 == 2 ) knc = knc + n - k + 1 IF( kp /= kk ) THEN ! ! Interchange rows and columns KK and KP in the trailing ! submatrix A(k:n,k:n) ! IF( kp < n ) CALL sswap( n-kp, ap( knc+kp-kk+1 ), 1, ap( kpc+1 ), & 1 ) kx = knc + kp - kk DO j = kk + 1, kp - 1 kx = kx + n - j + 1 t = ap( knc+j-kk ) ap( knc+j-kk ) = ap( kx ) ap( kx ) = t END DO t = ap( knc ) ap( knc ) = ap( kpc ) ap( kpc ) = t IF( kstep == 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 == 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 < 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 sspr( uplo, n-k, -r1, ap( kc+1 ), 1, ap( kc+n-k+1 ) ) ! ! Store L(k) in column K ! CALL sscal( 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 < 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 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 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 END DO ! ap( j+( k-1 )*( 2*n-k ) / 2 ) = wk ap( j+k*( 2*n-k-1 ) / 2 ) = wkp1 ! END DO END IF END IF END IF ! ! Store details of the interchanges in IPIV ! IF( kstep == 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 SSPTRF ! END SUBROUTINE ssptrf SUBROUTINE ssptri( uplo, n, ap, 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN OUT) :: ap( * ) INTEGER, INTENT(IN) :: ipiv( * ) REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSPTRI computes the inverse of a real symmetric indefinite matrix ! A in packed storage using the factorization A = U*D*U**T or ! A = L*D*L**T computed by SSPTRF. ! ! 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. ! ! AP (input/output) REAL array, dimension (N*(N+1)/2) ! On entry, the block diagonal matrix D and the multipliers ! used to obtain the factor U or L as computed by SSPTRF, ! stored as a packed triangular matrix. ! ! On exit, if INFO = 0, the (symmetric) inverse of the original ! matrix, stored as a packed triangular matrix. The j-th column ! of inv(A) is stored in the array AP as follows: ! if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; ! if UPLO = 'L', ! AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. ! ! IPIV (input) INTEGER array, dimension (N) ! Details of the interchanges and the block structure of D ! as determined by SSPTRF. ! ! WORK (workspace) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: j, k, kc, kcnext, kp, kpc, kstep, kx, npp REAL :: ak, akkp1, akp1, d, t, temp ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: sdot EXTERNAL lsame, sdot ! .. ! .. External Subroutines .. EXTERNAL scopy, sspmv, sswap, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS ! .. ! .. 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 < 0 ) THEN info = -2 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSPTRI', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Check that the diagonal matrix D is nonsingular. ! IF( upper ) THEN ! ! Upper triangular storage: examine D from bottom to top ! kp = n*( n+1 ) / 2 DO info = n, 1, -1 IF( ipiv( info ) > 0 .AND. ap( kp ) == zero ) RETURN kp = kp - info END DO ELSE ! ! Lower triangular storage: examine D from top to bottom. ! kp = 1 DO info = 1, n IF( ipiv( info ) > 0 .AND. ap( kp ) == zero ) RETURN kp = kp + n - info + 1 END DO 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 kc = 1 30 CONTINUE ! ! If K > N, exit from loop. ! IF( k > n ) GO TO 50 ! kcnext = kc + k IF( ipiv( k ) > 0 ) THEN ! ! 1 x 1 diagonal block ! ! Invert the diagonal block. ! ap( kc+k-1 ) = one / ap( kc+k-1 ) ! ! Compute column K of the inverse. ! IF( k > 1 ) THEN CALL scopy( k-1, ap( kc ), 1, work, 1 ) CALL sspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ), 1 ) ap( kc+k-1 ) = ap( kc+k-1 ) - sdot( k-1, work, 1, ap( kc ), 1 ) END IF kstep = 1 ELSE ! ! 2 x 2 diagonal block ! ! Invert the diagonal block. ! t = ABS( ap( kcnext+k-1 ) ) ak = ap( kc+k-1 ) / t akp1 = ap( kcnext+k ) / t akkp1 = ap( kcnext+k-1 ) / t d = t*( ak*akp1-one ) ap( kc+k-1 ) = akp1 / d ap( kcnext+k ) = ak / d ap( kcnext+k-1 ) = -akkp1 / d ! ! Compute columns K and K+1 of the inverse. ! IF( k > 1 ) THEN CALL scopy( k-1, ap( kc ), 1, work, 1 ) CALL sspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kc ), 1 ) ap( kc+k-1 ) = ap( kc+k-1 ) - sdot( k-1, work, 1, ap( kc ), 1 ) ap( kcnext+k-1 ) = ap( kcnext+k-1 ) - & sdot( k-1, ap( kc ), 1, ap( kcnext ), 1 ) CALL scopy( k-1, ap( kcnext ), 1, work, 1 ) CALL sspmv( uplo, k-1, -one, ap, work, 1, zero, ap( kcnext ), 1 ) ap( kcnext+k ) = ap( kcnext+k ) - sdot( k-1, work, 1, ap( kcnext ), 1 ) END IF kstep = 2 kcnext = kcnext + k + 1 END IF ! kp = ABS( ipiv( k ) ) IF( kp /= k ) THEN ! ! Interchange rows and columns K and KP in the leading ! submatrix A(1:k+1,1:k+1) ! kpc = ( kp-1 )*kp / 2 + 1 CALL sswap( kp-1, ap( kc ), 1, ap( kpc ), 1 ) kx = kpc + kp - 1 DO j = kp + 1, k - 1 kx = kx + j - 1 temp = ap( kc+j-1 ) ap( kc+j-1 ) = ap( kx ) ap( kx ) = temp END DO temp = ap( kc+k-1 ) ap( kc+k-1 ) = ap( kpc+kp-1 ) ap( kpc+kp-1 ) = temp IF( kstep == 2 ) THEN temp = ap( kc+k+k-1 ) ap( kc+k+k-1 ) = ap( kc+k+kp-1 ) ap( kc+k+kp-1 ) = temp END IF END IF ! k = k + kstep kc = kcnext GO TO 30 50 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. ! npp = n*( n+1 ) / 2 k = n kc = npp 60 CONTINUE ! ! If K < 1, exit from loop. ! IF( k < 1 ) GO TO 80 ! kcnext = kc - ( n-k+2 ) IF( ipiv( k ) > 0 ) THEN ! ! 1 x 1 diagonal block ! ! Invert the diagonal block. ! ap( kc ) = one / ap( kc ) ! ! Compute column K of the inverse. ! IF( k < n ) THEN CALL scopy( n-k, ap( kc+1 ), 1, work, 1 ) CALL sspmv( uplo, n-k, -one, ap( kc+n-k+1 ), work, 1, & zero, ap( kc+1 ), 1 ) ap( kc ) = ap( kc ) - sdot( n-k, work, 1, ap( kc+1 ), 1 ) END IF kstep = 1 ELSE ! ! 2 x 2 diagonal block ! ! Invert the diagonal block. ! t = ABS( ap( kcnext+1 ) ) ak = ap( kcnext ) / t akp1 = ap( kc ) / t akkp1 = ap( kcnext+1 ) / t d = t*( ak*akp1-one ) ap( kcnext ) = akp1 / d ap( kc ) = ak / d ap( kcnext+1 ) = -akkp1 / d ! ! Compute columns K-1 and K of the inverse. ! IF( k < n ) THEN CALL scopy( n-k, ap( kc+1 ), 1, work, 1 ) CALL sspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1, & zero, ap( kc+1 ), 1 ) ap( kc ) = ap( kc ) - sdot( n-k, work, 1, ap( kc+1 ), 1 ) ap( kcnext+1 ) = ap( kcnext+1 ) - sdot( n-k, ap( kc+1 ), 1, & ap( kcnext+2 ), 1 ) CALL scopy( n-k, ap( kcnext+2 ), 1, work, 1 ) CALL sspmv( uplo, n-k, -one, ap( kc+( n-k+1 ) ), work, 1, & zero, ap( kcnext+2 ), 1 ) ap( kcnext ) = ap( kcnext ) - sdot( n-k, work, 1, ap( kcnext+2 ), 1 ) END IF kstep = 2 kcnext = kcnext - ( n-k+3 ) END IF ! kp = ABS( ipiv( k ) ) IF( kp /= k ) THEN ! ! Interchange rows and columns K and KP in the trailing ! submatrix A(k-1:n,k-1:n) ! kpc = npp - ( n-kp+1 )*( n-kp+2 ) / 2 + 1 IF( kp < n ) CALL sswap( n-kp, ap( kc+kp-k+1 ), 1, ap( kpc+1 ), 1 ) kx = kc + kp - k DO j = k + 1, kp - 1 kx = kx + n - j + 1 temp = ap( kc+j-k ) ap( kc+j-k ) = ap( kx ) ap( kx ) = temp END DO temp = ap( kc ) ap( kc ) = ap( kpc ) ap( kpc ) = temp IF( kstep == 2 ) THEN temp = ap( kc-n+k-1 ) ap( kc-n+k-1 ) = ap( kc-n+kp-1 ) ap( kc-n+kp-1 ) = temp END IF END IF ! k = k - kstep kc = kcnext GO TO 60 80 CONTINUE END IF ! RETURN ! ! End of SSPTRI ! END SUBROUTINE ssptri SUBROUTINE ssptrs( 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: ap( * ) INTEGER, INTENT(IN) :: ipiv( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSPTRS 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 SSPTRF. ! ! 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) REAL 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 SSPTRF, 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 SSPTRF. ! ! B (input/output) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: j, k, kc, kp REAL :: ak, akm1, akm1k, bk, bkm1, denom ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL sgemv, sger, sscal, sswap, 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 < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -7 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSPTRS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 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 < 1 ) GO TO 30 ! kc = kc - k IF( ipiv( k ) > 0 ) THEN ! ! 1 x 1 diagonal block ! ! Interchange rows K and IPIV(K). ! kp = ipiv( k ) IF( kp /= k ) CALL sswap( 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 sger( k-1, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb, b( 1, 1 ), ldb ) ! ! Multiply by the inverse of the diagonal block. ! CALL sscal( 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 /= k-1 ) CALL sswap( 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 sger( k-2, nrhs, -one, ap( kc ), 1, b( k, 1 ), ldb, b( 1, 1 ), ldb ) CALL sger( 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 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 END DO 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 > n ) GO TO 50 ! IF( ipiv( k ) > 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 sgemv( '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 /= k ) CALL sswap( 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 sgemv( 'Transpose', k-1, nrhs, -one, b, ldb, ap( kc ), & 1, one, b( k, 1 ), ldb ) CALL sgemv( '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 /= k ) CALL sswap( 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 > n ) GO TO 80 ! IF( ipiv( k ) > 0 ) THEN ! ! 1 x 1 diagonal block ! ! Interchange rows K and IPIV(K). ! kp = ipiv( k ) IF( kp /= k ) CALL sswap( 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 < n ) CALL sger( 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 sscal( 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 /= k+1 ) CALL sswap( 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 < n-1 ) THEN CALL sger( n-k-1, nrhs, -one, ap( kc+2 ), 1, b( k, 1 ), & ldb, b( k+2, 1 ), ldb ) CALL sger( 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 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 END DO 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 < 1 ) GO TO 100 ! kc = kc - ( n-k+1 ) IF( ipiv( k ) > 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 < n ) CALL sgemv( '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 /= k ) CALL sswap( 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 < n ) THEN CALL sgemv( 'Transpose', n-k, nrhs, -one, b( k+1, 1 ), & ldb, ap( kc+1 ), 1, one, b( k, 1 ), ldb ) CALL sgemv( '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 /= k ) CALL sswap( 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 SSPTRS ! END SUBROUTINE ssptrs SUBROUTINE sstebz( 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 (LEN=1), INTENT(IN) :: range CHARACTER (LEN=1), INTENT(IN) :: order INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN) :: vl REAL, INTENT(IN) :: vu INTEGER, INTENT(IN) :: il INTEGER, INTENT(IN) :: iu REAL, INTENT(IN) :: abstol REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: e( * ) INTEGER, INTENT(OUT) :: m INTEGER, INTENT(OUT) :: nsplit REAL, INTENT(OUT) :: w( * ) INTEGER, INTENT(OUT) :: iblock( * ) INTEGER, INTENT(OUT) :: isplit( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSTEBZ 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) REAL ! VU (input) REAL ! 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) REAL ! 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*SLAMCH('S'), not zero. ! ! D (input) REAL array, dimension (N) ! The n diagonal elements of the tridiagonal matrix T. ! ! E (input) REAL 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) REAL array, dimension (N) ! On exit, the first M elements of W will contain the ! eigenvalues. (SSTEBZ 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. (SSTEBZ 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) REAL 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 REAL, 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 REAL, 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 .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: half = 1.0E0 / two REAL, PARAMETER :: fudge = 2.0E0 REAL, PARAMETER :: relfac = 2.0E0 ! .. ! .. 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 REAL :: 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 REAL :: slamch EXTERNAL lsame, ilaenv, slamch ! .. ! .. External Subroutines .. EXTERNAL slaebz, 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 <= 0 ) THEN info = -1 ELSE IF( iorder <= 0 ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( irange == 2 ) THEN IF( vl >= vu ) info = -5 ELSE IF( irange == 3 .AND. ( il < 1 .OR. il > MAX( 1, n ) ) ) & THEN info = -6 ELSE IF( irange == 3 .AND. ( iu < MIN( n, il ) .OR. iu > n ) ) & THEN info = -7 END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSTEBZ', -info ) RETURN END IF ! ! Initialize error flags ! info = 0 ncnvrg = .false. toofew = .false. ! ! Quick return if possible ! m = 0 IF( n == 0 ) RETURN ! ! Simplifications: ! IF( irange == 3 .AND. il == 1 .AND. iu == 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 = slamch( 'S' ) ulp = slamch( 'P' ) rtoli = ulp*relfac nb = ilaenv( 1, 'SSTEBZ', ' ', n, -1, -1, -1 ) IF( nb <= 1 ) nb = 0 ! ! Special Case when N=1 ! IF( n == 1 ) THEN nsplit = 1 isplit( 1 ) = 1 IF( irange == 2 .AND. ( vl >= d( 1 ) .OR. vu < 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 j = 2, n tmp1 = e( j-1 )**2 IF( ABS( d( j )*d( j-1 ) )*ulp**2+safemn > tmp1 ) THEN isplit( nsplit ) = j - 1 nsplit = nsplit + 1 work( j-1 ) = zero ELSE work( j-1 ) = tmp1 pivmin = MAX( pivmin, tmp1 ) END IF END DO isplit( nsplit ) = n pivmin = pivmin*safemn ! ! Compute Interval and ATOLI ! IF( irange == 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 j = 1, n - 1 tmp2 = SQRT( work( j ) ) gu = MAX( gu, d( j )+tmp1+tmp2 ) gl = MIN( gl, d( j )-tmp1-tmp2 ) tmp1 = tmp2 END DO ! 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 <= 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 slaebz( 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 ) == 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 < 0 .OR. nwl >= n .OR. nwu < 1 .OR. nwu > 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 j = 2, n - 1 tnorm = MAX( tnorm, ABS( d( j ) )+ABS( e( j-1 ) )+ ABS( e( j ) ) ) END DO ! IF( abstol <= zero ) THEN atoli = ulp*tnorm ELSE atoli = abstol END IF ! IF( irange == 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 jb = 1, nsplit ioff = iend ibegin = ioff + 1 iend = isplit( jb ) in = iend - ioff ! IF( in == 1 ) THEN ! ! Special Case -- IN=1 ! IF( irange == 1 .OR. wl >= d( ibegin )-pivmin ) nwl = nwl + 1 IF( irange == 1 .OR. wu >= d( ibegin )-pivmin ) nwu = nwu + 1 IF( irange == 1 .OR. ( wl < d( ibegin )-pivmin .AND. wu >= & 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 j = ibegin, iend - 1 tmp2 = ABS( e( j ) ) gu = MAX( gu, d( j )+tmp1+tmp2 ) gl = MIN( gl, d( j )-tmp1-tmp2 ) tmp1 = tmp2 END DO ! 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 <= zero ) THEN atoli = ulp*MAX( ABS( gl ), ABS( gu ) ) ELSE atoli = abstol END IF ! IF( irange > 1 ) THEN IF( gu < wl ) THEN nwl = nwl + in nwu = nwu + in CYCLE END IF gl = MAX( gl, wl ) gu = MIN( gu, wu ) IF( gl >= gu ) CYCLE END IF ! ! Set Up Initial Interval ! work( n+1 ) = gl work( n+in+1 ) = gu CALL slaebz( 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 slaebz( 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 j = 1, iout tmp1 = half*( work( j+n )+work( j+in+n ) ) ! ! Flag non-convergence. ! IF( j > iout-iinfo ) THEN ncnvrg = .true. ib = -jb ELSE ib = jb END IF DO je = iwork( j ) + 1 + iwoff, & iwork( j+in ) + iwoff w( je ) = tmp1 iblock( je ) = ib END DO END DO ! m = m + im END IF END DO ! ! If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU ! If NWL+1 < IL or NWU > IU, discard extra eigenvalues. ! IF( irange == 3 ) THEN im = 0 idiscl = il - 1 - nwl idiscu = nwu - iu ! IF( idiscl > 0 .OR. idiscu > 0 ) THEN DO je = 1, m IF( w( je ) <= wlu .AND. idiscl > 0 ) THEN idiscl = idiscl - 1 ELSE IF( w( je ) >= wul .AND. idiscu > 0 ) THEN idiscu = idiscu - 1 ELSE im = im + 1 w( im ) = w( je ) iblock( im ) = iblock( je ) END IF END DO m = im END IF IF( idiscl > 0 .OR. idiscu > 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 > 0 ) THEN wkill = wu DO jdisc = 1, idiscl iw = 0 DO je = 1, m IF( iblock( je ) /= 0 .AND. ( w( je ) < wkill .OR. iw == 0 ) ) THEN iw = je wkill = w( je ) END IF END DO iblock( iw ) = 0 END DO END IF IF( idiscu > 0 ) THEN ! wkill = wl DO jdisc = 1, idiscu iw = 0 DO je = 1, m IF( iblock( je ) /= 0 .AND. ( w( je ) > wkill .OR. iw == 0 ) ) THEN iw = je wkill = w( je ) END IF END DO iblock( iw ) = 0 END DO END IF im = 0 DO je = 1, m IF( iblock( je ) /= 0 ) THEN im = im + 1 w( im ) = w( je ) iblock( im ) = iblock( je ) END IF END DO m = im END IF IF( idiscl < 0 .OR. idiscu < 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 == 1 .AND. nsplit > 1 ) THEN DO je = 1, m - 1 ie = 0 tmp1 = w( je ) DO j = je + 1, m IF( w( j ) < tmp1 ) THEN ie = j tmp1 = w( j ) END IF END DO ! IF( ie /= 0 ) THEN itmp1 = iblock( ie ) w( ie ) = w( je ) iblock( ie ) = iblock( je ) w( je ) = tmp1 iblock( je ) = itmp1 END IF END DO END IF ! info = 0 IF( ncnvrg ) info = info + 1 IF( toofew ) info = info + 2 RETURN ! ! End of SSTEBZ ! END SUBROUTINE sstebz SUBROUTINE sstedc( compz, n, d, e, z, ldz, work, lwork, iwork, liwork, 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 (LEN=1), INTENT(IN) :: compz INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(IN) :: e( * ) REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(IN OUT) :: liwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSTEDC computes all eigenvalues and, optionally, eigenvectors of a ! symmetric tridiagonal matrix using the divide and conquer method. ! The eigenvectors of a full or band real symmetric matrix can also be ! found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this ! matrix to tridiagonal form. ! ! This code makes very mild assumptions about floating point ! arithmetic. It will work on machines with a guard digit in ! add/subtract, or on those binary machines without guard digits ! which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. ! It could conceivably fail on hexadecimal or decimal machines ! without guard digits, but we know of none. See SLAED3 for details. ! ! Arguments ! ========= ! ! COMPZ (input) CHARACTER*1 ! = 'N': Compute eigenvalues only. ! = 'I': Compute eigenvectors of tridiagonal matrix also. ! = 'V': Compute eigenvectors of original dense symmetric ! matrix also. On entry, Z contains the orthogonal ! matrix used to reduce the original matrix to ! tridiagonal form. ! ! N (input) INTEGER ! The dimension of the symmetric tridiagonal matrix. N >= 0. ! ! D (input/output) REAL 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) REAL array, dimension (N-1) ! On entry, the subdiagonal elements of the tridiagonal matrix. ! On exit, E has been destroyed. ! ! Z (input/output) REAL 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 INFO = 0, then 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 COMPZ = 'N', then Z is not referenced. ! ! LDZ (input) INTEGER ! The leading dimension of the array Z. LDZ >= 1. ! If eigenvectors are desired, then LDZ >= max(1,N). ! ! WORK (workspace/output) REAL array, ! dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. ! If COMPZ = 'N' or N <= 1 then LWORK must be at least 1. ! If COMPZ = 'V' and N > 1 then LWORK must be at least ! ( 1 + 3*N + 2*N*lg N + 3*N**2 ), ! where lg( N ) = smallest integer k such ! that 2**k >= N. ! If COMPZ = 'I' and N > 1 then LWORK must be at least ! ( 1 + 4*N + N**2 ). ! ! 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/output) INTEGER array, dimension (LIWORK) ! On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. ! ! LIWORK (input) INTEGER ! The dimension of the array IWORK. ! If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1. ! If COMPZ = 'V' and N > 1 then LIWORK must be at least ! ( 6 + 6*N + 5*N*lg N ). ! If COMPZ = 'I' and N > 1 then LIWORK must be at least ! ( 3 + 5*N ). ! ! If LIWORK = -1, then a workspace query is assumed; the ! routine only calculates the optimal size of the IWORK array, ! returns this value as the first entry of the IWORK array, and ! no error message related to LIWORK is issued by XERBLA. ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: The algorithm failed to compute an eigenvalue while ! working on the submatrix lying in rows and columns ! INFO/(N+1) through mod(INFO,N+1). ! ! Further Details ! =============== ! ! Based on contributions by ! Jeff Rutter, Computer Science Division, University of California ! at Berkeley, USA ! Modified by Francoise Tisseur, University of Tennessee. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 ! .. ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: END, i, icompz, ii, j, k, lgn, liwmin, lwmin, & m, smlsiz, start, storez, strtrw REAL :: eps, orgnrm, p, tiny ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slanst EXTERNAL ilaenv, lsame, slamch, slanst ! .. ! .. External Subroutines .. EXTERNAL sgemm, slacpy, slaed0, slascl, slaset, slasrt, & ssteqr, ssterf, sswap, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX, MOD, REAL, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 lquery = ( lwork == -1 .OR. liwork == -1 ) ! 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( n <= 1 .OR. icompz <= 0 ) THEN liwmin = 1 lwmin = 1 ELSE lgn = INT( LOG( REAL( n ) ) / LOG( two ) ) IF( 2**lgn < n ) lgn = lgn + 1 IF( 2**lgn < n ) lgn = lgn + 1 IF( icompz == 1 ) THEN lwmin = 1 + 3*n + 2*n*lgn + 3*n**2 liwmin = 6 + 6*n + 5*n*lgn ELSE IF( icompz == 2 ) THEN lwmin = 1 + 4*n + n**2 liwmin = 3 + 5*n END IF END IF IF( icompz < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( ( ldz < 1 ) .OR. ( icompz > 0 .AND. ldz < MAX( 1, & n ) ) ) THEN info = -6 ELSE IF( lwork < lwmin .AND. .NOT.lquery ) THEN info = -8 ELSE IF( liwork < liwmin .AND. .NOT.lquery ) THEN info = -10 END IF ! IF( info == 0 ) THEN work( 1 ) = lwmin iwork( 1 ) = liwmin END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSTEDC', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN IF( n == 1 ) THEN IF( icompz /= 0 ) z( 1, 1 ) = one RETURN END IF ! smlsiz = ilaenv( 9, 'SSTEDC', ' ', 0, 0, 0, 0 ) ! ! If the following conditional clause is removed, then the routine ! will use the Divide and Conquer routine to compute only the ! eigenvalues, which requires (3N + 3N**2) real workspace and ! (2 + 5N + 2N lg(N)) integer workspace. ! Since on many architectures SSTERF is much faster than any other ! algorithm for finding eigenvalues only, it is used here ! as the default. ! ! If COMPZ = 'N', use SSTERF to compute the eigenvalues. ! IF( icompz == 0 ) THEN CALL ssterf( n, d, e, info ) RETURN END IF ! ! If N is smaller than the minimum divide size (SMLSIZ+1), then ! solve the problem with another solver. ! IF( n <= smlsiz ) THEN IF( icompz == 0 ) THEN CALL ssterf( n, d, e, info ) RETURN ELSE IF( icompz == 2 ) THEN CALL ssteqr( 'I', n, d, e, z, ldz, work, info ) RETURN ELSE CALL ssteqr( 'V', n, d, e, z, ldz, work, info ) RETURN END IF END IF ! ! If COMPZ = 'V', the Z matrix must be stored elsewhere for later ! use. ! IF( icompz == 1 ) THEN storez = 1 + n*n ELSE storez = 1 END IF ! IF( icompz == 2 ) THEN CALL slaset( 'Full', n, n, zero, one, z, ldz ) END IF ! ! Scale. ! orgnrm = slanst( 'M', n, d, e ) IF( orgnrm == zero ) RETURN ! eps = slamch( 'Epsilon' ) ! start = 1 ! ! while ( START <= N ) ! 10 CONTINUE IF( start <= n ) THEN ! ! Let END be the position of the next subdiagonal entry such that ! E( END ) <= TINY or END = N if no such subdiagonal exists. The ! matrix identified by the elements between START and END ! constitutes an independent sub-problem. ! END = start 20 CONTINUE IF( END < n ) THEN tiny = eps*SQRT( ABS( d( END ) ) )*SQRT( ABS( d( END+1 ) ) ) IF( ABS( e( END ) ) > tiny ) THEN END = END + 1 GO TO 20 END IF END IF ! ! (Sub) Problem determined. Compute its size and solve it. ! m = END - start + 1 IF( m == 1 ) THEN start = END + 1 GO TO 10 END IF IF( m > smlsiz ) THEN info = smlsiz ! ! Scale. ! orgnrm = slanst( 'M', m, d( start ), e( start ) ) CALL slascl( 'G', 0, 0, orgnrm, one, m, 1, d( start ), m, info ) CALL slascl( 'G', 0, 0, orgnrm, one, m-1, 1, e( start ), m-1, info ) ! IF( icompz == 1 ) THEN strtrw = 1 ELSE strtrw = start END IF CALL slaed0( icompz, n, m, d( start ), e( start ), & z( strtrw, start ), ldz, work( 1 ), n, work( storez ), iwork, info ) IF( info /= 0 ) THEN info = ( info / ( m+1 )+start-1 )*( n+1 ) + & MOD( info, ( m+1 ) ) + start - 1 RETURN END IF ! ! Scale back. ! CALL slascl( 'G', 0, 0, one, orgnrm, m, 1, d( start ), m, info ) ! ELSE IF( icompz == 1 ) THEN ! ! Since QR won't update a Z matrix which is larger than the ! length of D, we must solve the sub-problem in a workspace and ! then multiply back into Z. ! CALL ssteqr( 'I', m, d( start ), e( start ), work, m, & work( m*m+1 ), info ) CALL slacpy( 'A', n, m, z( 1, start ), ldz, work( storez ), n ) CALL sgemm( 'N', 'N', n, m, m, one, work( storez ), ldz, & work, m, zero, z( 1, start ), ldz ) ELSE IF( icompz == 2 ) THEN CALL ssteqr( 'I', m, d( start ), e( start ), & z( start, start ), ldz, work, info ) ELSE CALL ssterf( m, d( start ), e( start ), info ) END IF IF( info /= 0 ) THEN info = start*( n+1 ) + END RETURN END IF END IF ! start = END + 1 GO TO 10 END IF ! ! endwhile ! ! If the problem split any number of times, then the eigenvalues ! will not be properly ordered. Here we permute the eigenvalues ! (and the associated eigenvectors) into ascending order. ! IF( m /= n ) THEN IF( icompz == 0 ) THEN ! ! Use Quick Sort ! CALL slasrt( 'I', n, d, info ) ! ELSE ! ! Use Selection Sort to minimize swaps of eigenvectors ! DO ii = 2, n i = ii - 1 k = i p = d( i ) DO j = ii, n IF( d( j ) < p ) THEN k = j p = d( j ) END IF END DO IF( k /= i ) THEN d( k ) = d( i ) d( i ) = p CALL sswap( n, z( 1, i ), 1, z( 1, k ), 1 ) END IF END DO END IF END IF ! work( 1 ) = lwmin iwork( 1 ) = liwmin ! RETURN ! ! End of SSTEDC ! END SUBROUTINE sstedc SUBROUTINE sstegr( jobz, range, n, d, e, vl, vu, il, iu, abstol, & m, w, z, ldz, isuppz, work, lwork, iwork, liwork, info ) ! ! -- LAPACK computational 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 (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: range INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: e( * ) REAL, INTENT(IN) :: vl REAL, INTENT(IN) :: vu INTEGER, INTENT(IN OUT) :: il INTEGER, INTENT(IN OUT) :: iu REAL, INTENT(IN) :: abstol INTEGER, INTENT(OUT) :: m REAL, INTENT(OUT) :: w( * ) REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz INTEGER, INTENT(IN OUT) :: isuppz( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(IN OUT) :: liwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSTEGR computes selected eigenvalues and, optionally, eigenvectors ! of a real symmetric tridiagonal matrix T. Eigenvalues and ! eigenvectors can be selected by specifying either a range of values ! or a range of indices for the desired eigenvalues. The eigenvalues ! are computed by the dqds algorithm, while orthogonal eigenvectors are ! computed from various ``good'' L D L^T representations (also known as ! Relatively Robust Representations). Gram-Schmidt orthogonalization is ! avoided as far as possible. More specifically, the various steps of ! the algorithm are as follows. For the i-th unreduced block of T, ! (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T ! is a relatively robust representation, ! (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high ! relative accuracy by the dqds algorithm, ! (c) If there is a cluster of close eigenvalues, "choose" sigma_i ! close to the cluster, and go to step (a), ! (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T, ! compute the corresponding eigenvector by forming a ! rank-revealing twisted factorization. ! The desired accuracy of the output can be specified by the input ! parameter ABSTOL. ! ! For more details, see "A new O(n^2) algorithm for the symmetric ! tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon, ! Computer Science Division Technical Report No. UCB/CSD-97-971, ! UC Berkeley, May 1997. ! ! Note 1 : Currently SSTEGR is only set up to find ALL the n ! eigenvalues and eigenvectors of T in O(n^2) time ! Note 2 : Currently the routine SSTEIN is called when an appropriate ! sigma_i cannot be chosen in step (c) above. SSTEIN invokes modified ! Gram-Schmidt when eigenvalues are close. ! Note 3 : SSTEGR works only on machines which follow ieee-754 ! floating-point standard in their handling of infinities and NaNs. ! Normal execution of SSTEGR may create NaNs and infinities and hence ! may abort due to a floating point exception in environments which ! do not conform to the ieee standard. ! ! 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. !********* Only RANGE = 'A' is currently supported ********************* ! ! N (input) INTEGER ! The order of the matrix. N >= 0. ! ! D (input/output) REAL array, dimension (N) ! On entry, the n diagonal elements of the tridiagonal matrix ! T. On exit, D is overwritten. ! ! E (input/output) REAL array, dimension (N) ! On entry, the (n-1) subdiagonal elements of the tridiagonal ! matrix T in elements 1 to N-1 of E; E(N) need not be set. ! On exit, E is overwritten. ! ! VL (input) REAL ! VU (input) REAL ! 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) REAL ! The absolute error tolerance for the ! eigenvalues/eigenvectors. IF JOBZ = 'V', the eigenvalues and ! eigenvectors output have residual norms bounded by ABSTOL, ! and the dot products between different eigenvectors are ! bounded by ABSTOL. If ABSTOL is less than N*EPS*|T|, then ! N*EPS*|T| will be used in its place, where EPS is the ! machine precision and |T| is the 1-norm of the tridiagonal ! matrix. The eigenvalues are computed to an accuracy of ! EPS*|T| irrespective of ABSTOL. If high relative accuracy ! is important, set ABSTOL to DLAMCH( 'Safe minimum' ). ! See Barlow and Demmel "Computing Accurate Eigensystems of ! Scaled Diagonally Dominant Matrices", LAPACK Working Note #7 ! for a discussion of which matrices define their eigenvalues ! to high relative accuracy. ! ! 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) REAL array, dimension (N) ! The first M elements contain the selected eigenvalues in ! ascending order. ! ! Z (output) REAL 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 T ! corresponding to the selected eigenvalues, with the i-th ! column of Z holding the eigenvector associated with W(i). ! 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). ! ! ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) ) ! The support of the eigenvectors in Z, i.e., the indices ! indicating the nonzero elements in Z. The i-th eigenvector ! is nonzero only in elements ISUPPZ( 2*i-1 ) through ! ISUPPZ( 2*i ). ! ! WORK (workspace/output) REAL array, dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal ! (and minimal) LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. LWORK >= max(1,18*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. ! ! IWORK (workspace/output) INTEGER array, dimension (LIWORK) ! On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. ! ! LIWORK (input) INTEGER ! The dimension of the array IWORK. LIWORK >= max(1,10*N) ! ! If LIWORK = -1, then a workspace query is assumed; the ! routine only calculates the optimal size of the IWORK array, ! returns this value as the first entry of the IWORK array, and ! no error message related to LIWORK 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 = 1, internal error in SLARRE, ! if INFO = 2, internal error in SLARRV. ! ! Further Details ! =============== ! ! Based on contributions by ! Inderjit Dhillon, IBM Almaden, USA ! Osni Marques, LBNL/NERSC, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: alleig, indeig, lquery, valeig, wantz INTEGER :: i, ibegin, iend, iindbl, iindwk, iinfo, iinspl, & indgrs, indwof, indwrk, itmp, j, jj, liwmin, lwmin, nsplit REAL :: bignum, eps, rmax, rmin, safmin, scale, smlnum, thresh, tmp, tnrm, tol ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slanst EXTERNAL lsame, slamch, slanst ! .. ! .. External Subroutines .. EXTERNAL slarre, slarrv, slaset, sscal, sswap, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, REAL, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! wantz = lsame( jobz, 'V' ) alleig = lsame( range, 'A' ) valeig = lsame( range, 'V' ) indeig = lsame( range, 'I' ) ! lquery = ( ( lwork == -1 ) .OR. ( liwork == -1 ) ) lwmin = 18*n liwmin = 10*n ! info = 0 IF( .NOT.( wantz .OR. lsame( jobz, 'N' ) ) ) THEN info = -1 ELSE IF( .NOT.( alleig .OR. valeig .OR. indeig ) ) THEN info = -2 ! ! The following two lines need to be removed once the ! RANGE = 'V' and RANGE = 'I' options are provided. ! ELSE IF( valeig .OR. indeig ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( valeig .AND. n > 0 .AND. vu <= vl ) THEN info = -7 ELSE IF( indeig .AND. il < 1 ) THEN info = -8 ! The following change should be made in DSTEVX also, otherwise ! IL can be specified as N+1 and IU as N. ! ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN ELSE IF( indeig .AND. ( iu < il .OR. iu > n ) ) THEN info = -9 ELSE IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) THEN info = -14 ELSE IF( lwork < lwmin .AND. .NOT.lquery ) THEN info = -17 ELSE IF( liwork < liwmin .AND. .NOT.lquery ) THEN info = -19 END IF IF( info == 0 ) THEN work( 1 ) = lwmin iwork( 1 ) = liwmin END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSTEGR', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! m = 0 IF( n == 0 ) RETURN ! IF( n == 1 ) THEN IF( alleig .OR. indeig ) THEN m = 1 w( 1 ) = d( 1 ) ELSE IF( vl < d( 1 ) .AND. vu >= d( 1 ) ) THEN m = 1 w( 1 ) = d( 1 ) END IF END IF IF( wantz ) z( 1, 1 ) = one RETURN END IF ! ! Get machine constants. ! safmin = slamch( 'Safe minimum' ) eps = slamch( '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. ! scale = one tnrm = slanst( 'M', n, d, e ) IF( tnrm > zero .AND. tnrm < rmin ) THEN scale = rmin / tnrm ELSE IF( tnrm > rmax ) THEN scale = rmax / tnrm END IF IF( scale /= one ) THEN CALL sscal( n, scale, d, 1 ) CALL sscal( n-1, scale, e, 1 ) tnrm = tnrm*scale END IF indgrs = 1 indwof = 2*n + 1 indwrk = 3*n + 1 ! iinspl = 1 iindbl = n + 1 iindwk = 2*n + 1 ! CALL slaset( 'Full', n, n, zero, zero, z, ldz ) ! ! Compute the desired eigenvalues of the tridiagonal after splitting ! into smaller subblocks if the corresponding of-diagonal elements ! are small ! thresh = eps*tnrm CALL slarre( n, d, e, thresh, nsplit, iwork( iinspl ), m, w, & work( indwof ), work( indgrs ), work( indwrk ), iinfo ) IF( iinfo /= 0 ) THEN info = 1 RETURN END IF ! IF( wantz ) THEN ! ! Compute the desired eigenvectors corresponding to the computed ! eigenvalues ! tol = MAX( abstol, REAL( n )*thresh ) ibegin = 1 DO i = 1, nsplit iend = iwork( iinspl+i-1 ) DO j = ibegin, iend iwork( iindbl+j-1 ) = i END DO ibegin = iend + 1 END DO ! CALL slarrv( n, d, e, iwork( iinspl ), m, w, iwork( iindbl ), & work( indgrs ), tol, z, ldz, isuppz, & work( indwrk ), iwork( iindwk ), iinfo ) IF( iinfo /= 0 ) THEN info = 2 RETURN END IF ! END IF ! ibegin = 1 DO i = 1, nsplit iend = iwork( iinspl+i-1 ) DO j = ibegin, iend w( j ) = w( j ) + work( indwof+i-1 ) END DO ibegin = iend + 1 END DO ! ! If matrix was scaled, then rescale eigenvalues appropriately. ! IF( scale /= one ) THEN CALL sscal( m, one / scale, w, 1 ) END IF ! ! If eigenvalues are not in order, then sort them, along with ! eigenvectors. ! IF( nsplit > 1 ) THEN DO j = 1, m - 1 i = 0 tmp = w( j ) DO jj = j + 1, m IF( w( jj ) < tmp ) THEN i = jj tmp = w( jj ) END IF END DO IF( i /= 0 ) THEN w( i ) = w( j ) w( j ) = tmp IF( wantz ) THEN CALL sswap( n, z( 1, i ), 1, z( 1, j ), 1 ) itmp = isuppz( 2*i-1 ) isuppz( 2*i-1 ) = isuppz( 2*j-1 ) isuppz( 2*j-1 ) = itmp itmp = isuppz( 2*i ) isuppz( 2*i ) = isuppz( 2*j ) isuppz( 2*j ) = itmp END IF END IF END DO END IF ! work( 1 ) = lwmin iwork( 1 ) = liwmin RETURN ! ! End of SSTEGR ! END SUBROUTINE sstegr SUBROUTINE sstein( 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, INTENT(IN) :: n REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: e( * ) INTEGER, INTENT(IN) :: m REAL, INTENT(IN) :: w( * ) INTEGER, INTENT(IN) :: iblock( * ) INTEGER, INTENT(IN) :: isplit( * ) REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: ifail( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSTEIN 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) REAL array, dimension (N) ! The n diagonal elements of the tridiagonal matrix T. ! ! E (input) REAL 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) REAL 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 SSTEBZ 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 SSTEBZ 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 SSTEBZ is expected here. ) ! ! Z (output) REAL 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) REAL 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 .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: ten = 1.0E+1 REAL, PARAMETER :: odm3 = 1.0E-3 REAL, PARAMETER :: odm1 = 1.0E-1 INTEGER, PARAMETER :: maxits = 5 INTEGER, PARAMETER :: extra = 2 ! .. ! .. Local Scalars .. INTEGER :: b1, blksiz, bn, gpind, i, iinfo, indrv1, & indrv2, indrv3, indrv4, indrv5, its, j, j1, jblk, jmax, nblk, nrmchk REAL :: ctr, eps, eps1, nrm, onenrm, ortol, pertol, & scl, sep, stpcrt, tol, xj, xjm ! .. ! .. Local Arrays .. INTEGER :: iseed( 4 ) ! .. ! .. External Functions .. INTEGER :: isamax REAL :: sasum, sdot, slamch, snrm2 EXTERNAL isamax, sasum, sdot, slamch, snrm2 ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, slagtf, slagts, slarnv, sscal, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 DO i = 1, m ifail( i ) = 0 END DO ! IF( n < 0 ) THEN info = -1 ELSE IF( m < 0 .OR. m > n ) THEN info = -4 ELSE IF( ldz < MAX( 1, n ) ) THEN info = -9 ELSE DO j = 2, m IF( iblock( j ) < iblock( j-1 ) ) THEN info = -6 EXIT END IF IF( iblock( j ) == iblock( j-1 ) .AND. w( j ) < w( j-1 ) ) THEN info = -5 EXIT END IF END DO 30 CONTINUE END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSTEIN', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. m == 0 ) THEN RETURN ELSE IF( n == 1 ) THEN z( 1, 1 ) = one RETURN END IF ! ! Get machine constants. ! eps = slamch( 'Precision' ) ! ! Initialize seed for random number generator SLARNV. ! DO i = 1, 4 iseed( i ) = 1 END DO ! ! Initialize pointers. ! indrv1 = 0 indrv2 = indrv1 + n indrv3 = indrv2 + n indrv4 = indrv3 + n indrv5 = indrv4 + n ! ! Compute eigenvectors of matrix blocks. ! j1 = 1 loop160: DO nblk = 1, iblock( m ) ! ! Find starting and ending indices of block nblk. ! IF( nblk == 1 ) THEN b1 = 1 ELSE b1 = isplit( nblk-1 ) + 1 END IF bn = isplit( nblk ) blksiz = bn - b1 + 1 IF( blksiz == 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 i = b1 + 1, bn - 1 onenrm = MAX( onenrm, ABS( d( i ) )+ABS( e( i-1 ) )+ ABS( e( i ) ) ) END DO ortol = odm3*onenrm ! stpcrt = SQRT( odm1 / blksiz ) ! ! Loop through eigenvalues of block nblk. ! 60 CONTINUE jblk = 0 DO j = j1, m IF( iblock( j ) /= nblk ) THEN j1 = j CYCLE loop160 END IF jblk = jblk + 1 xj = w( j ) ! ! Skip all the work if the block size is one. ! IF( blksiz == 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 > 1 ) THEN eps1 = ABS( eps*xj ) pertol = ten*eps1 sep = xj - xjm IF( sep < pertol ) xj = xjm + pertol END IF ! its = 0 nrmchk = 0 ! ! Get random starting vector. ! CALL slarnv( 2, iseed, blksiz, work( indrv1+1 ) ) ! ! Copy the matrix T so it won't be destroyed in factorization. ! CALL scopy( blksiz, d( b1 ), 1, work( indrv4+1 ), 1 ) CALL scopy( blksiz-1, e( b1 ), 1, work( indrv2+2 ), 1 ) CALL scopy( blksiz-1, e( b1 ), 1, work( indrv3+1 ), 1 ) ! ! Compute LU factors with partial pivoting ( PT = LU ) ! tol = zero CALL slagtf( 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 > maxits ) GO TO 100 ! ! Normalize and scale the righthand side vector Pb. ! scl = blksiz*onenrm*MAX( eps, ABS( work( indrv4+blksiz ) ) ) / & sasum( blksiz, work( indrv1+1 ), 1 ) CALL sscal( blksiz, scl, work( indrv1+1 ), 1 ) ! ! Solve the system LU = Pb. ! CALL slagts( -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 == 1 ) GO TO 90 IF( ABS( xj-xjm ) > ortol ) gpind = j IF( gpind /= j ) THEN DO i = gpind, j - 1 ctr = -sdot( blksiz, work( indrv1+1 ), 1, z( b1, i ), 1 ) CALL saxpy( blksiz, ctr, z( b1, i ), 1, work( indrv1+1 ), 1 ) END DO END IF ! ! Check the infinity norm of the iterate. ! 90 CONTINUE jmax = isamax( blksiz, work( indrv1+1 ), 1 ) nrm = ABS( work( indrv1+jmax ) ) ! ! Continue for additional iterations after norm reaches ! stopping criterion. ! IF( nrm < stpcrt ) GO TO 70 nrmchk = nrmchk + 1 IF( nrmchk < 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 / snrm2( blksiz, work( indrv1+1 ), 1 ) jmax = isamax( blksiz, work( indrv1+1 ), 1 ) IF( work( indrv1+jmax ) < zero ) scl = -scl CALL sscal( blksiz, scl, work( indrv1+1 ), 1 ) 120 CONTINUE DO i = 1, n z( i, j ) = zero END DO DO i = 1, blksiz z( b1+i-1, j ) = work( indrv1+i ) END DO ! ! Save the shift to check eigenvalue spacing at next ! iteration. ! xjm = xj ! END DO END DO loop160 ! RETURN ! ! End of SSTEIN ! END SUBROUTINE sstein SUBROUTINE ssteqr( 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 (LEN=1), INTENT(IN) :: compz INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(OUT) :: e( * ) REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSTEQR 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 SSYTRD or SSPTRD or SSBTRD 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) REAL 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) REAL array, dimension (N-1) ! On entry, the (n-1) subdiagonal elements of the tridiagonal ! matrix. ! On exit, E has been destroyed. ! ! Z (input/output) REAL 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 INFO = 0, then 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 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) REAL 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 .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: three = 3.0E0 INTEGER, 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 REAL :: anorm, b, c, eps, eps2, f, g, p, r, rt1, rt2, & s, safmax, safmin, ssfmax, ssfmin, tst ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slanst, slapy2 EXTERNAL lsame, slamch, slanst, slapy2 ! .. ! .. External Subroutines .. EXTERNAL slae2, slaev2, slartg, slascl, slaset, slasr, & slasrt, sswap, xerbla ! .. ! .. 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 < 0 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( ( ldz < 1 ) .OR. ( icompz > 0 .AND. ldz < MAX( 1, & n ) ) ) THEN info = -6 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSTEQR', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! IF( n == 1 ) THEN IF( icompz == 2 ) z( 1, 1 ) = one RETURN END IF ! ! Determine the unit roundoff and over/underflow thresholds. ! eps = slamch( 'E' ) eps2 = eps**2 safmin = slamch( 'S' ) safmax = one / safmin ssfmax = SQRT( safmax ) / three ssfmin = SQRT( safmin ) / eps2 ! ! Compute the eigenvalues and eigenvectors of the tridiagonal ! matrix. ! IF( icompz == 2 ) CALL slaset( 'Full', 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 > n ) GO TO 160 IF( l1 > 1 ) e( l1-1 ) = zero IF( l1 <= nm1 ) THEN DO m = l1, nm1 tst = ABS( e( m ) ) IF( tst == zero ) GO TO 30 IF( tst <= ( SQRT( ABS( d( m ) ) )*SQRT( ABS( d( m+ 1 ) ) ) )*eps ) THEN e( m ) = zero GO TO 30 END IF END DO END IF m = n ! 30 CONTINUE l = l1 lsv = l lend = m lendsv = lend l1 = m + 1 IF( lend == l ) GO TO 10 ! ! Scale submatrix in rows and columns L to LEND ! anorm = slanst( 'I', lend-l+1, d( l ), e( l ) ) iscale = 0 IF( anorm == zero ) GO TO 10 IF( anorm > ssfmax ) THEN iscale = 1 CALL slascl( 'G', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n, info ) CALL slascl( 'G', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n, info ) ELSE IF( anorm < ssfmin ) THEN iscale = 2 CALL slascl( 'G', 0, 0, anorm, ssfmin, lend-l+1, 1, d( l ), n, info ) CALL slascl( 'G', 0, 0, anorm, ssfmin, lend-l, 1, e( l ), n, info ) END IF ! ! Choose between QL and QR iteration ! IF( ABS( d( lend ) ) < ABS( d( l ) ) ) THEN lend = lsv l = lendsv END IF ! IF( lend > l ) THEN ! ! QL Iteration ! ! Look for small subdiagonal element. ! 40 CONTINUE IF( l /= lend ) THEN lendm1 = lend - 1 DO m = l, lendm1 tst = ABS( e( m ) )**2 IF( tst <= ( eps2*ABS( d( m ) ) )*ABS( d( m+1 ) )+ safmin )GO TO 60 END DO END IF ! m = lend ! 60 CONTINUE IF( m < lend ) e( m ) = zero p = d( l ) IF( m == l ) GO TO 80 ! ! If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 ! to compute its eigensystem. ! IF( m == l+1 ) THEN IF( icompz > 0 ) THEN CALL slaev2( d( l ), e( l ), d( l+1 ), rt1, rt2, c, s ) work( l ) = c work( n-1+l ) = s CALL slasr( 'R', 'V', 'B', n, 2, work( l ), & work( n-1+l ), z( 1, l ), ldz ) ELSE CALL slae2( 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 <= lend ) GO TO 40 GO TO 140 END IF ! IF( jtot == nmaxit ) GO TO 140 jtot = jtot + 1 ! ! Form shift. ! g = ( d( l+1 )-p ) / ( two*e( l ) ) r = slapy2( g, one ) g = d( m ) - p + ( e( l ) / ( g+SIGN( r, g ) ) ) ! s = one c = one p = zero ! ! Inner loop ! mm1 = m - 1 DO i = mm1, l, -1 f = s*e( i ) b = c*e( i ) CALL slartg( g, f, c, s, r ) IF( i /= 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 > 0 ) THEN work( i ) = c work( n-1+i ) = -s END IF ! END DO ! ! If eigenvectors are desired, then apply saved rotations. ! IF( icompz > 0 ) THEN mm = m - l + 1 CALL slasr( '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 <= lend ) GO TO 40 GO TO 140 ! ELSE ! ! QR Iteration ! ! Look for small superdiagonal element. ! 90 CONTINUE IF( l /= lend ) THEN lendp1 = lend + 1 DO m = l, lendp1, -1 tst = ABS( e( m-1 ) )**2 IF( tst <= ( eps2*ABS( d( m ) ) )*ABS( d( m-1 ) )+ safmin )GO TO 110 END DO END IF ! m = lend ! 110 CONTINUE IF( m > lend ) e( m-1 ) = zero p = d( l ) IF( m == l ) GO TO 130 ! ! If remaining matrix is 2-by-2, use SLAE2 or SLAEV2 ! to compute its eigensystem. ! IF( m == l-1 ) THEN IF( icompz > 0 ) THEN CALL slaev2( d( l-1 ), e( l-1 ), d( l ), rt1, rt2, c, s ) work( m ) = c work( n-1+m ) = s CALL slasr( 'R', 'V', 'F', n, 2, work( m ), & work( n-1+m ), z( 1, l-1 ), ldz ) ELSE CALL slae2( 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 >= lend ) GO TO 90 GO TO 140 END IF ! IF( jtot == nmaxit ) GO TO 140 jtot = jtot + 1 ! ! Form shift. ! g = ( d( l-1 )-p ) / ( two*e( l-1 ) ) r = slapy2( 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 i = m, lm1 f = s*e( i ) b = c*e( i ) CALL slartg( g, f, c, s, r ) IF( i /= 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 > 0 ) THEN work( i ) = c work( n-1+i ) = s END IF ! END DO ! ! If eigenvectors are desired, then apply saved rotations. ! IF( icompz > 0 ) THEN mm = l - m + 1 CALL slasr( '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 >= lend ) GO TO 90 GO TO 140 ! END IF ! ! Undo scaling if necessary ! 140 CONTINUE IF( iscale == 1 ) THEN CALL slascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1, d( lsv ), n, info ) CALL slascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv, 1, e( lsv ), n, info ) ELSE IF( iscale == 2 ) THEN CALL slascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1, d( lsv ), n, info ) CALL slascl( '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 < nmaxit ) GO TO 10 DO i = 1, n - 1 IF( e( i ) /= zero ) info = info + 1 END DO GO TO 190 ! ! Order eigenvalues and eigenvectors. ! 160 CONTINUE IF( icompz == 0 ) THEN ! ! Use Quick Sort ! CALL slasrt( 'I', n, d, info ) ! ELSE ! ! Use Selection Sort to minimize swaps of eigenvectors ! DO ii = 2, n i = ii - 1 k = i p = d( i ) DO j = ii, n IF( d( j ) < p ) THEN k = j p = d( j ) END IF END DO IF( k /= i ) THEN d( k ) = d( i ) d( i ) = p CALL sswap( n, z( 1, i ), 1, z( 1, k ), 1 ) END IF END DO END IF ! 190 CONTINUE RETURN ! ! End of SSTEQR ! END SUBROUTINE ssteqr SUBROUTINE ssterf( 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, INTENT(IN) :: n REAL, INTENT(IN OUT) :: d( * ) REAL, INTENT(OUT) :: e( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSTERF 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) REAL 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) REAL 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 .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 REAL, PARAMETER :: two = 2.0E0 REAL, PARAMETER :: three = 3.0E0 INTEGER, PARAMETER :: maxit = 30 ! .. ! .. Local Scalars .. INTEGER :: i, iscale, jtot, l, l1, lend, lendsv, lsv, m, nmaxit REAL :: alpha, anorm, bb, c, eps, eps2, gamma, oldc, & oldgam, p, r, rt1, rt2, rte, s, safmax, safmin, sigma, ssfmax, ssfmin ! .. ! .. External Functions .. REAL :: slamch, slanst, slapy2 EXTERNAL slamch, slanst, slapy2 ! .. ! .. External Subroutines .. EXTERNAL slae2, slascl, slasrt, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, SIGN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 ! ! Quick return if possible ! IF( n < 0 ) THEN info = -1 CALL xerbla( 'SSTERF', -info ) RETURN END IF IF( n <= 1 ) RETURN ! ! Determine the unit roundoff for this environment. ! eps = slamch( 'E' ) eps2 = eps**2 safmin = slamch( 'S' ) safmax = one / safmin ssfmax = SQRT( safmax ) / three ssfmin = SQRT( safmin ) / eps2 ! ! Compute the eigenvalues of the tridiagonal matrix. ! 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 ! 10 CONTINUE IF( l1 > n ) GO TO 170 IF( l1 > 1 ) e( l1-1 ) = zero DO m = l1, n - 1 IF( ABS( e( m ) ) <= ( SQRT( ABS( d( m ) ) )* & SQRT( ABS( d( m+1 ) ) ) )*eps ) THEN e( m ) = zero GO TO 30 END IF END DO m = n ! 30 CONTINUE l = l1 lsv = l lend = m lendsv = lend l1 = m + 1 IF( lend == l ) GO TO 10 ! ! Scale submatrix in rows and columns L to LEND ! anorm = slanst( 'I', lend-l+1, d( l ), e( l ) ) iscale = 0 IF( anorm > ssfmax ) THEN iscale = 1 CALL slascl( 'G', 0, 0, anorm, ssfmax, lend-l+1, 1, d( l ), n, info ) CALL slascl( 'G', 0, 0, anorm, ssfmax, lend-l, 1, e( l ), n, info ) ELSE IF( anorm < ssfmin ) THEN iscale = 2 CALL slascl( 'G', 0, 0, anorm, ssfmin, lend-l+1, 1, d( l ), n, info ) CALL slascl( 'G', 0, 0, anorm, ssfmin, lend-l, 1, e( l ), n, info ) END IF ! DO i = l, lend - 1 e( i ) = e( i )**2 END DO ! ! Choose between QL and QR iteration ! IF( ABS( d( lend ) ) < ABS( d( l ) ) ) THEN lend = lsv l = lendsv END IF ! IF( lend >= l ) THEN ! ! QL Iteration ! ! Look for small subdiagonal element. ! 50 CONTINUE IF( l /= lend ) THEN DO m = l, lend - 1 IF( ABS( e( m ) ) <= eps2*ABS( d( m )*d( m+1 ) ) ) GO TO 70 END DO END IF m = lend ! 70 CONTINUE IF( m < lend ) e( m ) = zero p = d( l ) IF( m == l ) GO TO 90 ! ! If remaining matrix is 2 by 2, use SLAE2 to compute its ! eigenvalues. ! IF( m == l+1 ) THEN rte = SQRT( e( l ) ) CALL slae2( d( l ), rte, d( l+1 ), rt1, rt2 ) d( l ) = rt1 d( l+1 ) = rt2 e( l ) = zero l = l + 2 IF( l <= lend ) GO TO 50 GO TO 150 END IF ! IF( jtot == nmaxit ) GO TO 150 jtot = jtot + 1 ! ! Form shift. ! rte = SQRT( e( l ) ) sigma = ( d( l+1 )-p ) / ( two*rte ) r = slapy2( sigma, one ) sigma = p - ( rte / ( sigma+SIGN( r, sigma ) ) ) ! c = one s = zero gamma = d( m ) - sigma p = gamma*gamma ! ! Inner loop ! DO i = m - 1, l, -1 bb = e( i ) r = p + bb IF( i /= 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 /= zero ) THEN p = ( gamma*gamma ) / c ELSE p = oldc*bb END IF END DO ! e( l ) = s*p d( l ) = sigma + gamma GO TO 50 ! ! Eigenvalue found. ! 90 CONTINUE d( l ) = p ! l = l + 1 IF( l <= lend ) GO TO 50 GO TO 150 ! ELSE ! ! QR Iteration ! ! Look for small superdiagonal element. ! 100 CONTINUE DO m = l, lend + 1, -1 IF( ABS( e( m-1 ) ) <= eps2*ABS( d( m )*d( m-1 ) ) ) GO TO 120 END DO m = lend ! 120 CONTINUE IF( m > lend ) e( m-1 ) = zero p = d( l ) IF( m == l ) GO TO 140 ! ! If remaining matrix is 2 by 2, use SLAE2 to compute its ! eigenvalues. ! IF( m == l-1 ) THEN rte = SQRT( e( l-1 ) ) CALL slae2( d( l ), rte, d( l-1 ), rt1, rt2 ) d( l ) = rt1 d( l-1 ) = rt2 e( l-1 ) = zero l = l - 2 IF( l >= lend ) GO TO 100 GO TO 150 END IF ! IF( jtot == nmaxit ) GO TO 150 jtot = jtot + 1 ! ! Form shift. ! rte = SQRT( e( l-1 ) ) sigma = ( d( l-1 )-p ) / ( two*rte ) r = slapy2( sigma, one ) sigma = p - ( rte / ( sigma+SIGN( r, sigma ) ) ) ! c = one s = zero gamma = d( m ) - sigma p = gamma*gamma ! ! Inner loop ! DO i = m, l - 1 bb = e( i ) r = p + bb IF( i /= 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 /= zero ) THEN p = ( gamma*gamma ) / c ELSE p = oldc*bb END IF END DO ! e( l-1 ) = s*p d( l ) = sigma + gamma GO TO 100 ! ! Eigenvalue found. ! 140 CONTINUE d( l ) = p ! l = l - 1 IF( l >= lend ) GO TO 100 GO TO 150 ! END IF ! ! Undo scaling if necessary ! 150 CONTINUE IF( iscale == 1 ) CALL slascl( 'G', 0, 0, ssfmax, anorm, lendsv-lsv+1, 1, & d( lsv ), n, info ) IF( iscale == 2 ) CALL slascl( 'G', 0, 0, ssfmin, anorm, lendsv-lsv+1, 1, & d( lsv ), n, info ) ! ! Check for no convergence to an eigenvalue after a total ! of N*MAXIT iterations. ! IF( jtot < nmaxit ) GO TO 10 DO i = 1, n - 1 IF( e( i ) /= zero ) info = info + 1 END DO GO TO 180 ! ! Sort eigenvalues in increasing order. ! 170 CONTINUE CALL slasrt( 'I', n, d, info ) ! 180 CONTINUE RETURN ! ! End of SSTERF ! END SUBROUTINE ssterf SUBROUTINE sstev( jobz, n, d, e, z, ldz, work, info ) ! ! -- LAPACK driver 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 (LEN=1), INTENT(IN) :: jobz INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: e( * ) REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSTEV computes all eigenvalues and, optionally, eigenvectors of a ! real symmetric tridiagonal matrix A. ! ! Arguments ! ========= ! ! JOBZ (input) CHARACTER*1 ! = 'N': Compute eigenvalues only; ! = 'V': Compute eigenvalues and eigenvectors. ! ! N (input) INTEGER ! The order of the matrix. N >= 0. ! ! D (input/output) REAL array, dimension (N) ! On entry, the n diagonal elements of the tridiagonal matrix ! A. ! On exit, if INFO = 0, the eigenvalues in ascending order. ! ! E (input/output) REAL array, dimension (N) ! On entry, the (n-1) subdiagonal elements of the tridiagonal ! matrix A, stored in elements 1 to N-1 of E; E(N) need not ! be set, but is used by the routine. ! On exit, the contents of E are destroyed. ! ! Z (output) REAL 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 D(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) REAL array, dimension (max(1,2*N-2)) ! If JOBZ = 'N', WORK 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, the algorithm failed to converge; i ! off-diagonal elements of E did not converge to zero. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: wantz INTEGER :: imax, iscale REAL :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tnrm ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slanst EXTERNAL lsame, slamch, slanst ! .. ! .. External Subroutines .. EXTERNAL sscal, ssteqr, ssterf, 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( n < 0 ) THEN info = -2 ELSE IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) THEN info = -6 END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSTEV ', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! IF( n == 1 ) THEN IF( wantz ) z( 1, 1 ) = one RETURN END IF ! ! Get machine constants. ! safmin = slamch( 'Safe minimum' ) eps = slamch( 'Precision' ) smlnum = safmin / eps bignum = one / smlnum rmin = SQRT( smlnum ) rmax = SQRT( bignum ) ! ! Scale matrix to allowable range, if necessary. ! iscale = 0 tnrm = slanst( 'M', n, d, e ) IF( tnrm > zero .AND. tnrm < rmin ) THEN iscale = 1 sigma = rmin / tnrm ELSE IF( tnrm > rmax ) THEN iscale = 1 sigma = rmax / tnrm END IF IF( iscale == 1 ) THEN CALL sscal( n, sigma, d, 1 ) CALL sscal( n-1, sigma, e( 1 ), 1 ) END IF ! ! For eigenvalues only, call SSTERF. For eigenvalues and ! eigenvectors, call SSTEQR. ! IF( .NOT.wantz ) THEN CALL ssterf( n, d, e, info ) ELSE CALL ssteqr( 'I', n, d, e, z, ldz, work, info ) END IF ! ! If matrix was scaled, then rescale eigenvalues appropriately. ! IF( iscale == 1 ) THEN IF( info == 0 ) THEN imax = n ELSE imax = info - 1 END IF CALL sscal( imax, one / sigma, d, 1 ) END IF ! RETURN ! ! End of SSTEV ! END SUBROUTINE sstev SUBROUTINE sstevd( jobz, n, d, e, z, ldz, work, lwork, iwork, liwork, 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 (LEN=1), INTENT(IN) :: jobz INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: e( * ) REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(IN OUT) :: liwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSTEVD computes all eigenvalues and, optionally, eigenvectors of a ! real symmetric tridiagonal matrix. If eigenvectors are desired, it ! uses a divide and conquer algorithm. ! ! The divide and conquer algorithm makes very mild assumptions about ! floating point arithmetic. It will work on machines with a guard ! digit in add/subtract, or on those binary machines without guard ! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or ! Cray-2. It could conceivably fail on hexadecimal or decimal machines ! without guard digits, but we know of none. ! ! Arguments ! ========= ! ! JOBZ (input) CHARACTER*1 ! = 'N': Compute eigenvalues only; ! = 'V': Compute eigenvalues and eigenvectors. ! ! N (input) INTEGER ! The order of the matrix. N >= 0. ! ! D (input/output) REAL array, dimension (N) ! On entry, the n diagonal elements of the tridiagonal matrix ! A. ! On exit, if INFO = 0, the eigenvalues in ascending order. ! ! E (input/output) REAL array, dimension (N) ! On entry, the (n-1) subdiagonal elements of the tridiagonal ! matrix A, stored in elements 1 to N-1 of E; E(N) need not ! be set, but is used by the routine. ! On exit, the contents of E are destroyed. ! ! Z (output) REAL 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 D(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/output) REAL array, ! dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. ! If JOBZ = 'N' or N <= 1 then LWORK must be at least 1. ! If JOBZ = 'V' and N > 1 then LWORK must be at least ! ( 1 + 4*N + N**2 ). ! ! 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/output) INTEGER array, dimension (LIWORK) ! On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. ! ! LIWORK (input) INTEGER ! The dimension of the array IWORK. ! If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1. ! If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N. ! ! If LIWORK = -1, then a workspace query is assumed; the ! routine only calculates the optimal size of the IWORK array, ! returns this value as the first entry of the IWORK array, and ! no error message related to LIWORK 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 E did not converge to zero. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, wantz INTEGER :: iscale, liwmin, lwmin REAL :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tnrm ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slanst EXTERNAL lsame, slamch, slanst ! .. ! .. External Subroutines .. EXTERNAL sscal, sstedc, ssterf, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! wantz = lsame( jobz, 'V' ) lquery = ( lwork == -1 .OR. liwork == -1 ) ! info = 0 liwmin = 1 lwmin = 1 IF( n > 1 .AND. wantz ) THEN lwmin = 1 + 4*n + n**2 liwmin = 3 + 5*n END IF ! IF( .NOT.( wantz .OR. lsame( jobz, 'N' ) ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) THEN info = -6 ELSE IF( lwork < lwmin .AND. .NOT.lquery ) THEN info = -8 ELSE IF( liwork < liwmin .AND. .NOT.lquery ) THEN info = -10 END IF ! IF( info == 0 ) THEN work( 1 ) = lwmin iwork( 1 ) = liwmin END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSTEVD', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! IF( n == 1 ) THEN IF( wantz ) z( 1, 1 ) = one RETURN END IF ! ! Get machine constants. ! safmin = slamch( 'Safe minimum' ) eps = slamch( 'Precision' ) smlnum = safmin / eps bignum = one / smlnum rmin = SQRT( smlnum ) rmax = SQRT( bignum ) ! ! Scale matrix to allowable range, if necessary. ! iscale = 0 tnrm = slanst( 'M', n, d, e ) IF( tnrm > zero .AND. tnrm < rmin ) THEN iscale = 1 sigma = rmin / tnrm ELSE IF( tnrm > rmax ) THEN iscale = 1 sigma = rmax / tnrm END IF IF( iscale == 1 ) THEN CALL sscal( n, sigma, d, 1 ) CALL sscal( n-1, sigma, e( 1 ), 1 ) END IF ! ! For eigenvalues only, call SSTERF. For eigenvalues and ! eigenvectors, call SSTEDC. ! IF( .NOT.wantz ) THEN CALL ssterf( n, d, e, info ) ELSE CALL sstedc( 'I', n, d, e, z, ldz, work, lwork, iwork, liwork, info ) END IF ! ! If matrix was scaled, then rescale eigenvalues appropriately. ! IF( iscale == 1 ) CALL sscal( n, one / sigma, d, 1 ) ! work( 1 ) = lwmin iwork( 1 ) = liwmin ! RETURN ! ! End of SSTEVD ! END SUBROUTINE sstevd SUBROUTINE sstevr( jobz, range, n, d, e, vl, vu, il, iu, abstol, & m, w, z, ldz, isuppz, work, lwork, iwork, liwork, 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 (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: range INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: e( * ) REAL, INTENT(IN) :: vl REAL, INTENT(IN) :: vu INTEGER, INTENT(IN) :: il INTEGER, INTENT(IN) :: iu REAL, INTENT(IN OUT) :: abstol INTEGER, INTENT(OUT) :: m REAL, INTENT(OUT) :: w( * ) REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN) :: ldz INTEGER, INTENT(IN OUT) :: isuppz( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(IN OUT) :: liwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSTEVR computes selected eigenvalues and, optionally, eigenvectors ! of a real symmetric tridiagonal matrix T. Eigenvalues and ! eigenvectors can be selected by specifying either a range of values ! or a range of indices for the desired eigenvalues. ! ! Whenever possible, SSTEVR calls SSTEGR to compute the ! eigenspectrum using Relatively Robust Representations. SSTEGR ! computes eigenvalues by the dqds algorithm, while orthogonal ! eigenvectors are computed from various "good" L D L^T representations ! (also known as Relatively Robust Representations). Gram-Schmidt ! orthogonalization is avoided as far as possible. More specifically, ! the various steps of the algorithm are as follows. For the i-th ! unreduced block of T, ! (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T ! is a relatively robust representation, ! (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high ! relative accuracy by the dqds algorithm, ! (c) If there is a cluster of close eigenvalues, "choose" sigma_i ! close to the cluster, and go to step (a), ! (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T, ! compute the corresponding eigenvector by forming a ! rank-revealing twisted factorization. ! The desired accuracy of the output can be specified by the input ! parameter ABSTOL. ! ! For more details, see "A new O(n^2) algorithm for the symmetric ! tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon, ! Computer Science Division Technical Report No. UCB//CSD-97-971, ! UC Berkeley, May 1997. ! ! ! Note 1 : SSTEVR calls SSTEGR when the full spectrum is requested ! on machines which conform to the ieee-754 floating point standard. ! SSTEVR calls SSTEBZ and SSTEIN on non-ieee machines and ! when partial spectrum requests are made. ! ! Normal execution of SSTEGR may create NaNs and infinities and ! hence may abort due to a floating point exception in environments ! which do not handle NaNs and infinities in the ieee standard default ! manner. ! ! 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. !********* For RANGE = 'V' or 'I', SSTEBZ and SSTEIN are called ! ! N (input) INTEGER ! The order of the matrix. N >= 0. ! ! D (input/output) REAL array, dimension (N) ! On entry, the n diagonal elements of the tridiagonal matrix ! A. ! On exit, D may be multiplied by a constant factor chosen ! to avoid over/underflow in computing the eigenvalues. ! ! E (input/output) REAL array, dimension (N) ! On entry, the (n-1) subdiagonal elements of the tridiagonal ! matrix A in elements 1 to N-1 of E; E(N) need not be set. ! On exit, E may be multiplied by a constant factor chosen ! to avoid over/underflow in computing the eigenvalues. ! ! VL (input) REAL ! VU (input) REAL ! 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) REAL ! 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. ! ! See "Computing Small Singular Values of Bidiagonal Matrices ! with Guaranteed High Relative Accuracy," by Demmel and ! Kahan, LAPACK Working Note #3. ! ! If high relative accuracy is important, set ABSTOL to ! SLAMCH( 'Safe minimum' ). Doing so will guarantee that ! eigenvalues are computed to high relative accuracy when ! possible in future releases. The current code does not ! make any guarantees about high relative accuracy, but ! future releases will. See J. Barlow and J. Demmel, ! "Computing Accurate Eigensystems of Scaled Diagonally ! Dominant Matrices", LAPACK Working Note #7, for a discussion ! of which matrices define their eigenvalues to high relative ! accuracy. ! ! 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) REAL array, dimension (N) ! The first M elements contain the selected eigenvalues in ! ascending order. ! ! Z (output) REAL 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). ! 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). ! ! ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) ! The support of the eigenvectors in Z, i.e., the indices ! indicating the nonzero elements in Z. The i-th eigenvector ! is nonzero only in elements ISUPPZ( 2*i-1 ) through ! ISUPPZ( 2*i ). ! ! WORK (workspace/output) REAL array, dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal (and ! minimal) LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. LWORK >= 20*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. ! ! IWORK (workspace/output) INTEGER array, dimension (LIWORK) ! On exit, if INFO = 0, IWORK(1) returns the optimal (and ! minimal) LIWORK. ! ! LIWORK (input) INTEGER ! The dimension of the array IWORK. LIWORK >= 10*N. ! ! If LIWORK = -1, then a workspace query is assumed; the ! routine only calculates the optimal size of the IWORK array, ! returns this value as the first entry of the IWORK array, and ! no error message related to LIWORK is issued by XERBLA. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! > 0: Internal error ! ! Further Details ! =============== ! ! Based on contributions by ! Inderjit Dhillon, IBM Almaden, USA ! Osni Marques, LBNL/NERSC, USA ! Ken Stanley, Computer Science Division, University of ! California at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: alleig, indeig, lquery, valeig, wantz CHARACTER (LEN=1) :: order INTEGER :: i, ieeeok, imax, indibl, indifl, indisp, & indiwo, iscale, itmp1, j, jj, liwmin, lwmin, nsplit REAL :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, tnrm, vll, vuu ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slanst EXTERNAL lsame, ilaenv, slamch, slanst ! .. ! .. External Subroutines .. EXTERNAL scopy, sscal, sstebz, sstegr, sstein, ssterf, sswap, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! ! Test the input parameters. ! ieeeok = ilaenv( 10, 'SSTEVR', 'N', 1, 2, 3, 4 ) ! wantz = lsame( jobz, 'V' ) alleig = lsame( range, 'A' ) valeig = lsame( range, 'V' ) indeig = lsame( range, 'I' ) ! lquery = ( ( lwork == -1 ) .OR. ( liwork == -1 ) ) lwmin = 20*n liwmin = 10*n ! ! 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( n < 0 ) THEN info = -3 ELSE IF( valeig ) THEN IF( n > 0 .AND. vu <= vl ) info = -7 ELSE IF( indeig ) THEN IF( il < 1 .OR. il > MAX( 1, n ) ) THEN info = -8 ELSE IF( iu < MIN( n, il ) .OR. iu > n ) THEN info = -9 END IF END IF END IF IF( info == 0 ) THEN IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) THEN info = -14 ELSE IF( lwork < lwmin .AND. .NOT.lquery ) THEN info = -17 ELSE IF( liwork < liwmin .AND. .NOT.lquery ) THEN info = -19 END IF END IF ! IF( info == 0 ) THEN work( 1 ) = lwmin iwork( 1 ) = liwmin END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSTEVR', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! m = 0 IF( n == 0 ) RETURN ! IF( n == 1 ) THEN IF( alleig .OR. indeig ) THEN m = 1 w( 1 ) = d( 1 ) ELSE IF( vl < d( 1 ) .AND. vu >= d( 1 ) ) THEN m = 1 w( 1 ) = d( 1 ) END IF END IF IF( wantz ) z( 1, 1 ) = one RETURN END IF ! ! Get machine constants. ! safmin = slamch( 'Safe minimum' ) eps = slamch( '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 vll = vl vuu = vu ! tnrm = slanst( 'M', n, d, e ) IF( tnrm > zero .AND. tnrm < rmin ) THEN iscale = 1 sigma = rmin / tnrm ELSE IF( tnrm > rmax ) THEN iscale = 1 sigma = rmax / tnrm END IF IF( iscale == 1 ) THEN CALL sscal( n, sigma, d, 1 ) CALL sscal( n-1, sigma, e( 1 ), 1 ) IF( valeig ) THEN vll = vl*sigma vuu = vu*sigma END IF END IF ! ! If all eigenvalues are desired, then ! call SSTERF or SSTEGR. If this fails for some eigenvalue, then ! try SSTEBZ. ! ! IF( ( alleig .OR. ( indeig .AND. il == 1 .AND. iu == n ) ) .AND. & ieeeok == 1 ) THEN CALL scopy( n-1, e( 1 ), 1, work( 1 ), 1 ) IF( .NOT.wantz ) THEN CALL scopy( n, d, 1, w, 1 ) CALL ssterf( n, w, work, info ) ELSE CALL scopy( n, d, 1, work( n+1 ), 1 ) CALL sstegr( jobz, range, n, work( n+1 ), work, vl, vu, il, & iu, abstol, m, w, z, ldz, isuppz, & work( 2*n+1 ), lwork-2*n, iwork, liwork, info ) ! END IF IF( info == 0 ) THEN m = n GO TO 10 END IF info = 0 END IF ! ! Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. ! IF( wantz ) THEN order = 'B' ELSE order = 'E' END IF indibl = 1 indisp = indibl + n indifl = indisp + n indiwo = indifl + n CALL sstebz( range, order, n, vll, vuu, il, iu, abstol, d, e, m, & nsplit, w, iwork( indibl ), iwork( indisp ), work, iwork( indiwo ), info ) ! IF( wantz ) THEN CALL sstein( n, d, e, m, w, iwork( indibl ), iwork( indisp ), & z, ldz, work, iwork( indiwo ), iwork( indifl ), info ) END IF ! ! If matrix was scaled, then rescale eigenvalues appropriately. ! 10 CONTINUE IF( iscale == 1 ) THEN IF( info == 0 ) THEN imax = m ELSE imax = info - 1 END IF CALL sscal( imax, one / sigma, w, 1 ) END IF ! ! If eigenvalues are not in order, then sort them, along with ! eigenvectors. ! IF( wantz ) THEN DO j = 1, m - 1 i = 0 tmp1 = w( j ) DO jj = j + 1, m IF( w( jj ) < tmp1 ) THEN i = jj tmp1 = w( jj ) END IF END DO ! IF( i /= 0 ) THEN itmp1 = iwork( i ) w( i ) = w( j ) iwork( i ) = iwork( j ) w( j ) = tmp1 iwork( j ) = itmp1 CALL sswap( n, z( 1, i ), 1, z( 1, j ), 1 ) END IF END DO END IF ! ! Causes problems with tests 19 & 20: ! IF (wantz .and. INDEIG ) Z( 1,1) = Z(1,1) / 1.002 + .002 ! ! work( 1 ) = lwmin iwork( 1 ) = liwmin RETURN ! ! End of SSTEVR ! END SUBROUTINE sstevr SUBROUTINE sstevx( jobz, range, n, d, e, vl, vu, il, iu, abstol, & m, w, z, ldz, work, 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 (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: range INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: d( * ) REAL, INTENT(IN) :: e( * ) REAL, INTENT(IN) :: vl REAL, INTENT(IN) :: vu INTEGER, INTENT(IN) :: il INTEGER, INTENT(IN) :: iu REAL, INTENT(IN OUT) :: abstol INTEGER, INTENT(OUT) :: m REAL, INTENT(OUT) :: w( * ) REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN) :: ldz REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: ifail( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSTEVX computes selected eigenvalues and, optionally, eigenvectors ! of a real symmetric tridiagonal 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. ! ! N (input) INTEGER ! The order of the matrix. N >= 0. ! ! D (input/output) REAL array, dimension (N) ! On entry, the n diagonal elements of the tridiagonal matrix ! A. ! On exit, D may be multiplied by a constant factor chosen ! to avoid over/underflow in computing the eigenvalues. ! ! E (input/output) REAL array, dimension (N) ! On entry, the (n-1) subdiagonal elements of the tridiagonal ! matrix A in elements 1 to N-1 of E; E(N) need not be set. ! On exit, E may be multiplied by a constant factor chosen ! to avoid over/underflow in computing the eigenvalues. ! ! VL (input) REAL ! VU (input) REAL ! 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) REAL ! 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. ! ! Eigenvalues will be computed most accurately when ABSTOL is ! set to twice the underflow threshold 2*SLAMCH('S'), not zero. ! If this routine returns with INFO>0, indicating that some ! eigenvectors did not converge, try setting ABSTOL to ! 2*SLAMCH('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) REAL array, dimension (N) ! The first M elements contain the selected eigenvalues in ! ascending order. ! ! Z (output) REAL 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 (INFO > 0), 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) REAL array, dimension (5*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 .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: alleig, indeig, valeig, wantz CHARACTER (LEN=1) :: order INTEGER :: i, imax, indibl, indisp, indiwo, indwrk, & iscale, itmp1, j, jj, nsplit REAL :: bignum, eps, rmax, rmin, safmin, sigma, smlnum, tmp1, tnrm, vll, vuu ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slanst EXTERNAL lsame, slamch, slanst ! .. ! .. External Subroutines .. EXTERNAL scopy, sscal, sstebz, sstein, ssteqr, ssterf, sswap, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! wantz = lsame( jobz, 'V' ) alleig = lsame( range, 'A' ) valeig = lsame( range, 'V' ) indeig = lsame( range, 'I' ) ! 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( n < 0 ) THEN info = -3 ELSE IF( valeig ) THEN IF( n > 0 .AND. vu <= vl ) info = -7 ELSE IF( indeig ) THEN IF( il < 1 .OR. il > MAX( 1, n ) ) THEN info = -8 ELSE IF( iu < MIN( n, il ) .OR. iu > n ) THEN info = -9 END IF END IF END IF IF( info == 0 ) THEN IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) info = -14 END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSTEVX', -info ) RETURN END IF ! ! Quick return if possible ! m = 0 IF( n == 0 ) RETURN ! IF( n == 1 ) THEN IF( alleig .OR. indeig ) THEN m = 1 w( 1 ) = d( 1 ) ELSE IF( vl < d( 1 ) .AND. vu >= d( 1 ) ) THEN m = 1 w( 1 ) = d( 1 ) END IF END IF IF( wantz ) z( 1, 1 ) = one RETURN END IF ! ! Get machine constants. ! safmin = slamch( 'Safe minimum' ) eps = slamch( '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 IF ( valeig ) THEN vll = vl vuu = vu ELSE vll = zero vuu = zero END IF tnrm = slanst( 'M', n, d, e ) IF( tnrm > zero .AND. tnrm < rmin ) THEN iscale = 1 sigma = rmin / tnrm ELSE IF( tnrm > rmax ) THEN iscale = 1 sigma = rmax / tnrm END IF IF( iscale == 1 ) THEN CALL sscal( n, sigma, d, 1 ) CALL sscal( n-1, sigma, e( 1 ), 1 ) IF( valeig ) THEN vll = vl*sigma vuu = vu*sigma END IF END IF ! ! If all eigenvalues are desired and ABSTOL is less than zero, then ! call SSTERF or SSTEQR. If this fails for some eigenvalue, then ! try SSTEBZ. ! IF( ( alleig .OR. ( indeig .AND. il == 1 .AND. iu == n ) ) .AND. & ( abstol <= zero ) ) THEN CALL scopy( n, d, 1, w, 1 ) CALL scopy( n-1, e( 1 ), 1, work( 1 ), 1 ) indwrk = n + 1 IF( .NOT.wantz ) THEN CALL ssterf( n, w, work, info ) ELSE CALL ssteqr( 'I', n, w, work, z, ldz, work( indwrk ), info ) IF( info == 0 ) THEN DO i = 1, n ifail( i ) = 0 END DO END IF END IF IF( info == 0 ) THEN m = n GO TO 20 END IF info = 0 END IF ! ! Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. ! IF( wantz ) THEN order = 'B' ELSE order = 'E' END IF indwrk = 1 indibl = 1 indisp = indibl + n indiwo = indisp + n CALL sstebz( range, order, n, vll, vuu, il, iu, abstol, d, e, m, & nsplit, w, iwork( indibl ), iwork( indisp ), & work( indwrk ), iwork( indiwo ), info ) ! IF( wantz ) THEN CALL sstein( n, d, e, m, w, iwork( indibl ), iwork( indisp ), & z, ldz, work( indwrk ), iwork( indiwo ), ifail, info ) END IF ! ! If matrix was scaled, then rescale eigenvalues appropriately. ! 20 CONTINUE IF( iscale == 1 ) THEN IF( info == 0 ) THEN imax = m ELSE imax = info - 1 END IF CALL sscal( imax, one / sigma, w, 1 ) END IF ! ! If eigenvalues are not in order, then sort them, along with ! eigenvectors. ! IF( wantz ) THEN DO j = 1, m - 1 i = 0 tmp1 = w( j ) DO jj = j + 1, m IF( w( jj ) < tmp1 ) THEN i = jj tmp1 = w( jj ) END IF END DO ! IF( i /= 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 sswap( n, z( 1, i ), 1, z( 1, j ), 1 ) IF( info /= 0 ) THEN itmp1 = ifail( i ) ifail( i ) = ifail( j ) ifail( j ) = itmp1 END IF END IF END DO END IF ! RETURN ! ! End of SSTEVX ! END SUBROUTINE sstevx SUBROUTINE ssycon( uplo, n, a, lda, ipiv, anorm, rcond, 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 ! March 31, 1993 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(IN) :: ipiv( * ) REAL, INTENT(IN) :: anorm REAL, INTENT(OUT) :: rcond REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYCON estimates the reciprocal of the condition number (in the ! 1-norm) of a real symmetric matrix A using the factorization ! A = U*D*U**T or A = L*D*L**T computed by SSYTRF. ! ! An estimate is obtained for norm(inv(A)), and the reciprocal of the ! condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). ! ! 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) REAL array, dimension (LDA,N) ! The block diagonal matrix D and the multipliers used to ! obtain the factor U or L as computed by SSYTRF. ! ! 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 SSYTRF. ! ! ANORM (input) REAL ! The 1-norm of the original matrix A. ! ! RCOND (output) REAL ! The reciprocal of the condition number of the matrix A, ! computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an ! estimate of the 1-norm of inv(A) computed in this routine. ! ! WORK (workspace) REAL array, dimension (2*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: i, kase REAL :: ainvnm ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL slacon, ssytrs, 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 < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, n ) ) THEN info = -4 ELSE IF( anorm < zero ) THEN info = -6 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSYCON', -info ) RETURN END IF ! ! Quick return if possible ! rcond = zero IF( n == 0 ) THEN rcond = one RETURN ELSE IF( anorm <= zero ) THEN RETURN END IF ! ! Check that the diagonal matrix D is nonsingular. ! IF( upper ) THEN ! ! Upper triangular storage: examine D from bottom to top ! DO i = n, 1, -1 IF( ipiv( i ) > 0 .AND. a( i, i ) == zero ) RETURN END DO ELSE ! ! Lower triangular storage: examine D from top to bottom. ! DO i = 1, n IF( ipiv( i ) > 0 .AND. a( i, i ) == zero ) RETURN END DO END IF ! ! Estimate the 1-norm of the inverse. ! kase = 0 30 CONTINUE CALL slacon( n, work( n+1 ), work, iwork, ainvnm, kase ) IF( kase /= 0 ) THEN ! ! Multiply by inv(L*D*L') or inv(U*D*U'). ! CALL ssytrs( uplo, n, 1, a, lda, ipiv, work, n, info ) GO TO 30 END IF ! ! Compute the estimate of the reciprocal condition number. ! IF( ainvnm /= zero ) rcond = ( one / ainvnm ) / anorm ! RETURN ! ! End of SSYCON ! END SUBROUTINE ssycon SUBROUTINE ssyev( 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 (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(OUT) :: w( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYEV 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) REAL 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) REAL array, dimension (N) ! If INFO = 0, the eigenvalues in ascending order. ! ! WORK (workspace/output) REAL 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 SSYTRD 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 .. REAL, PARAMETER :: zero = 0.0E0 REAL, PARAMETER :: one = 1.0E0 ! .. ! .. Local Scalars .. LOGICAL :: lower, lquery, wantz INTEGER :: iinfo, imax, inde, indtau, indwrk, iscale, llwork, lopt, lwkopt, nb REAL :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slansy EXTERNAL ilaenv, lsame, slamch, slansy ! .. ! .. External Subroutines .. EXTERNAL slascl, sorgtr, sscal, ssteqr, ssterf, ssytrd, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! wantz = lsame( jobz, 'V' ) lower = lsame( uplo, 'L' ) lquery = ( lwork == -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 < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( lwork < MAX( 1, 3*n-1 ) .AND. .NOT.lquery ) THEN info = -8 END IF ! IF( info == 0 ) THEN nb = ilaenv( 1, 'SSYTRD', uplo, n, -1, -1, -1 ) lwkopt = MAX( 1, ( nb+2 )*n ) work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSYEV ', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) THEN work( 1 ) = 1 RETURN END IF ! IF( n == 1 ) THEN w( 1 ) = a( 1, 1 ) work( 1 ) = 3 IF( wantz ) a( 1, 1 ) = one RETURN END IF ! ! Get machine constants. ! safmin = slamch( 'Safe minimum' ) eps = slamch( 'Precision' ) smlnum = safmin / eps bignum = one / smlnum rmin = SQRT( smlnum ) rmax = SQRT( bignum ) ! ! Scale matrix to allowable range, if necessary. ! anrm = slansy( 'M', uplo, n, a, lda, work ) iscale = 0 IF( anrm > zero .AND. anrm < rmin ) THEN iscale = 1 sigma = rmin / anrm ELSE IF( anrm > rmax ) THEN iscale = 1 sigma = rmax / anrm END IF IF( iscale == 1 ) CALL slascl( uplo, 0, 0, one, sigma, n, n, a, lda, info ) ! ! Call SSYTRD to reduce symmetric matrix to tridiagonal form. ! inde = 1 indtau = inde + n indwrk = indtau + n llwork = lwork - indwrk + 1 CALL ssytrd( uplo, n, a, lda, w, work( inde ), work( indtau ), & work( indwrk ), llwork, iinfo ) lopt = 2*n + work( indwrk ) ! ! For eigenvalues only, call SSTERF. For eigenvectors, first call ! SORGTR to generate the orthogonal matrix, then call SSTEQR. ! IF( .NOT.wantz ) THEN CALL ssterf( n, w, work( inde ), info ) ELSE CALL sorgtr( uplo, n, a, lda, work( indtau ), work( indwrk ), & llwork, iinfo ) CALL ssteqr( jobz, n, w, work( inde ), a, lda, work( indtau ), info ) END IF ! ! If matrix was scaled, then rescale eigenvalues appropriately. ! IF( iscale == 1 ) THEN IF( info == 0 ) THEN imax = n ELSE imax = info - 1 END IF CALL sscal( imax, one / sigma, w, 1 ) END IF ! ! Set WORK(1) to optimal workspace size. ! work( 1 ) = lwkopt ! RETURN ! ! End of SSYEV ! END SUBROUTINE ssyev SUBROUTINE ssyevd( jobz, uplo, n, a, lda, w, work, lwork, iwork, & liwork, 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 (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(OUT) :: w( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(IN OUT) :: liwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYEVD computes all eigenvalues and, optionally, eigenvectors of a ! real symmetric matrix A. If eigenvectors are desired, it uses a ! divide and conquer algorithm. ! ! The divide and conquer algorithm makes very mild assumptions about ! floating point arithmetic. It will work on machines with a guard ! digit in add/subtract, or on those binary machines without guard ! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or ! Cray-2. It could conceivably fail on hexadecimal or decimal machines ! without guard digits, but we know of none. ! ! Because of large use of BLAS of level 3, SSYEVD needs N**2 more ! workspace than SSYEVX. ! ! 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) REAL 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) REAL array, dimension (N) ! If INFO = 0, the eigenvalues in ascending order. ! ! WORK (workspace/output) REAL array, ! dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. ! If N <= 1, LWORK must be at least 1. ! If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1. ! If JOBZ = 'V' and N > 1, LWORK must be at least ! 1 + 6*N + 2*N**2. ! ! 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/output) INTEGER array, dimension (LIWORK) ! On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. ! ! LIWORK (input) INTEGER ! The dimension of the array IWORK. ! If N <= 1, LIWORK must be at least 1. ! If JOBZ = 'N' and N > 1, LIWORK must be at least 1. ! If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. ! ! If LIWORK = -1, then a workspace query is assumed; the ! routine only calculates the optimal size of the IWORK array, ! returns this value as the first entry of the IWORK array, and ! no error message related to LIWORK 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. ! ! Further Details ! =============== ! ! Based on contributions by ! Jeff Rutter, Computer Science Division, University of California ! at Berkeley, USA ! Modified by Francoise Tisseur, University of Tennessee. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. ! LOGICAL :: lower, lquery, wantz INTEGER :: iinfo, inde, indtau, indwk2, indwrk, iscale, & liopt, liwmin, llwork, llwrk2, lopt, lwmin REAL :: anrm, bignum, eps, rmax, rmin, safmin, sigma, smlnum ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch, slansy EXTERNAL lsame, slamch, slansy ! .. ! .. External Subroutines .. EXTERNAL slacpy, slascl, sormtr, sscal, sstedc, ssterf, & ssytrd, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! wantz = lsame( jobz, 'V' ) lower = lsame( uplo, 'L' ) lquery = ( lwork == -1 .OR. liwork == -1 ) ! info = 0 IF( n <= 1 ) THEN liwmin = 1 lwmin = 1 lopt = lwmin liopt = liwmin ELSE IF( wantz ) THEN liwmin = 3 + 5*n lwmin = 1 + 6*n + 2*n**2 ELSE liwmin = 1 lwmin = 2*n + 1 END IF lopt = lwmin liopt = liwmin END IF IF( .NOT.( wantz .OR. lsame( jobz, 'N' ) ) ) THEN info = -1 ELSE IF( .NOT.( lower .OR. lsame( uplo, 'U' ) ) ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( lwork < lwmin .AND. .NOT.lquery ) THEN info = -8 ELSE IF( liwork < liwmin .AND. .NOT.lquery ) THEN info = -10 END IF ! IF( info == 0 ) THEN work( 1 ) = lopt iwork( 1 ) = liopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSYEVD', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! IF( n == 1 ) THEN w( 1 ) = a( 1, 1 ) IF( wantz ) a( 1, 1 ) = one RETURN END IF ! ! Get machine constants. ! safmin = slamch( 'Safe minimum' ) eps = slamch( 'Precision' ) smlnum = safmin / eps bignum = one / smlnum rmin = SQRT( smlnum ) rmax = SQRT( bignum ) ! ! Scale matrix to allowable range, if necessary. ! anrm = slansy( 'M', uplo, n, a, lda, work ) iscale = 0 IF( anrm > zero .AND. anrm < rmin ) THEN iscale = 1 sigma = rmin / anrm ELSE IF( anrm > rmax ) THEN iscale = 1 sigma = rmax / anrm END IF IF( iscale == 1 ) CALL slascl( uplo, 0, 0, one, sigma, n, n, a, lda, info ) ! ! Call SSYTRD to reduce symmetric matrix to tridiagonal form. ! inde = 1 indtau = inde + n indwrk = indtau + n llwork = lwork - indwrk + 1 indwk2 = indwrk + n*n llwrk2 = lwork - indwk2 + 1 ! CALL ssytrd( uplo, n, a, lda, w, work( inde ), work( indtau ), & work( indwrk ), llwork, iinfo ) lopt = 2*n + work( indwrk ) ! ! For eigenvalues only, call SSTERF. For eigenvectors, first call ! SSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the ! tridiagonal matrix, then call SORMTR to multiply it by the ! Householder transformations stored in A. ! IF( .NOT.wantz ) THEN CALL ssterf( n, w, work( inde ), info ) ELSE CALL sstedc( 'I', n, w, work( inde ), work( indwrk ), n, & work( indwk2 ), llwrk2, iwork, liwork, info ) CALL sormtr( 'L', uplo, 'N', n, n, a, lda, work( indtau ), & work( indwrk ), n, work( indwk2 ), llwrk2, iinfo ) CALL slacpy( 'A', n, n, work( indwrk ), n, a, lda ) lopt = MAX( lopt, 1+6*n+2*n**2 ) END IF ! ! If matrix was scaled, then rescale eigenvalues appropriately. ! IF( iscale == 1 ) CALL sscal( n, one / sigma, w, 1 ) ! work( 1 ) = lopt iwork( 1 ) = liopt ! RETURN ! ! End of SSYEVD ! END SUBROUTINE ssyevd SUBROUTINE ssyevr( jobz, range, uplo, n, a, lda, vl, vu, il, iu, & abstol, m, w, z, ldz, isuppz, work, lwork, iwork, liwork, 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 (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: range CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN) :: vl REAL, INTENT(IN) :: vu INTEGER, INTENT(IN) :: il INTEGER, INTENT(IN) :: iu REAL, INTENT(IN) :: abstol INTEGER, INTENT(OUT) :: m REAL, INTENT(OUT) :: w( * ) REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN) :: ldz INTEGER, INTENT(IN OUT) :: isuppz( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(IN OUT) :: liwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYEVR computes selected eigenvalues and, optionally, eigenvectors ! of a real symmetric tridiagonal matrix T. Eigenvalues and ! eigenvectors can be selected by specifying either a range of values ! or a range of indices for the desired eigenvalues. ! ! Whenever possible, SSYEVR calls SSTEGR to compute the ! eigenspectrum using Relatively Robust Representations. SSTEGR ! computes eigenvalues by the dqds algorithm, while orthogonal ! eigenvectors are computed from various "good" L D L^T representations ! (also known as Relatively Robust Representations). Gram-Schmidt ! orthogonalization is avoided as far as possible. More specifically, ! the various steps of the algorithm are as follows. For the i-th ! unreduced block of T, ! (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T ! is a relatively robust representation, ! (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high ! relative accuracy by the dqds algorithm, ! (c) If there is a cluster of close eigenvalues, "choose" sigma_i ! close to the cluster, and go to step (a), ! (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T, ! compute the corresponding eigenvector by forming a ! rank-revealing twisted factorization. ! The desired accuracy of the output can be specified by the input ! parameter ABSTOL. ! ! For more details, see "A new O(n^2) algorithm for the symmetric ! tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon, ! Computer Science Division Technical Report No. UCB//CSD-97-971, ! UC Berkeley, May 1997. ! ! ! Note 1 : SSYEVR calls SSTEGR when the full spectrum is requested ! on machines which conform to the ieee-754 floating point standard. ! SSYEVR calls SSTEBZ and SSTEIN on non-ieee machines and ! when partial spectrum requests are made. ! ! Normal execution of SSTEGR may create NaNs and infinities and ! hence may abort due to a floating point exception in environments ! which do not handle NaNs and infinities in the ieee standard default ! manner. ! ! 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. !********* For RANGE = 'V' or 'I', SSTEBZ and SSTEIN are called ! ! 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) REAL 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) REAL ! VU (input) REAL ! 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) REAL ! 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. ! ! See "Computing Small Singular Values of Bidiagonal Matrices ! with Guaranteed High Relative Accuracy," by Demmel and ! Kahan, LAPACK Working Note #3. ! ! If high relative accuracy is important, set ABSTOL to ! SLAMCH( 'Safe minimum' ). Doing so will guarantee that ! eigenvalues are computed to high relative accuracy when ! possible in future releases. The current code does not ! make any guarantees about high relative accuracy, but ! furutre releases will. See J. Barlow and J. Demmel, ! "Computing Accurate Eigensystems of Scaled Diagonally ! Dominant Matrices", LAPACK Working Note #7, for a discussion ! of which matrices define their eigenvalues to high relative ! accuracy. ! ! 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) REAL array, dimension (N) ! The first M elements contain the selected eigenvalues in ! ascending order. ! ! Z (output) REAL 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 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). ! ! ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) ! The support of the eigenvectors in Z, i.e., the indices ! indicating the nonzero elements in Z. The i-th eigenvector ! is nonzero only in elements ISUPPZ( 2*i-1 ) through ! ISUPPZ( 2*i ). ! ! WORK (workspace/output) REAL 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,26*N). ! For optimal efficiency, LWORK >= (NB+6)*N, ! where NB is the max of the blocksize for SSYTRD and SORMTR ! 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/output) INTEGER array, dimension (LIWORK) ! On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. ! ! LIWORK (input) INTEGER ! The dimension of the array IWORK. LIWORK >= max(1,10*N). ! ! If LIWORK = -1, then a workspace query is assumed; the ! routine only calculates the optimal size of the IWORK array, ! returns this value as the first entry of the IWORK array, and ! no error message related to LIWORK is issued by XERBLA. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! > 0: Internal error ! ! Further Details ! =============== ! ! Based on contributions by ! Inderjit Dhillon, IBM Almaden, USA ! Osni Marques, LBNL/NERSC, USA ! Ken Stanley, Computer Science Division, University of ! California at Berkeley, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: alleig, indeig, lower, lquery, valeig, wantz CHARACTER (LEN=1) :: order INTEGER :: i, ieeeok, iinfo, imax, indd, inddd, inde, & indee, indibl, indifl, indisp, indiwo, indtau, & indwk, indwkn, iscale, itmp1, j, jj, liwmin, & llwork, llwrkn, lwkopt, lwmin, nb, nsplit REAL :: abstll, anrm, bignum, eps, rmax, rmin, safmin, & sigma, smlnum, tmp1, vll, vuu ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slansy EXTERNAL lsame, ilaenv, slamch, slansy ! .. ! .. External Subroutines .. EXTERNAL scopy, sormtr, sscal, sstebz, sstegr, sstein, & ssterf, sswap, ssytrd, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! ieeeok = ilaenv( 10, 'SSYEVR', 'N', 1, 2, 3, 4 ) ! lower = lsame( uplo, 'L' ) wantz = lsame( jobz, 'V' ) alleig = lsame( range, 'A' ) valeig = lsame( range, 'V' ) indeig = lsame( range, 'I' ) ! lquery = ( ( lwork == -1 ) .OR. ( liwork == -1 ) ) ! lwmin = MAX( 1, 26*n ) liwmin = MAX( 1, 10*n ) ! 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 < 0 ) THEN info = -4 ELSE IF( lda < MAX( 1, n ) ) THEN info = -6 ELSE IF( valeig ) THEN IF( n > 0 .AND. vu <= vl ) info = -8 ELSE IF( indeig ) THEN IF( il < 1 .OR. il > MAX( 1, n ) ) THEN info = -9 ELSE IF( iu < MIN( n, il ) .OR. iu > n ) THEN info = -10 END IF END IF END IF IF( info == 0 ) THEN IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) THEN info = -15 ELSE IF( lwork < lwmin .AND. .NOT.lquery ) THEN info = -18 ELSE IF( liwork < liwmin .AND. .NOT.lquery ) THEN info = -20 END IF END IF ! IF( info == 0 ) THEN nb = ilaenv( 1, 'CHETRD', uplo, n, -1, -1, -1 ) nb = MAX( nb, ilaenv( 1, 'CUNMTR', uplo, n, -1, -1, -1 ) ) lwkopt = MAX( ( nb+1 )*n, lwmin ) work( 1 ) = lwkopt iwork( 1 ) = liwmin END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSYEVR', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! m = 0 IF( n == 0 ) THEN work( 1 ) = 1 RETURN END IF ! IF( n == 1 ) THEN work( 1 ) = 7 IF( alleig .OR. indeig ) THEN m = 1 w( 1 ) = a( 1, 1 ) ELSE IF( vl < a( 1, 1 ) .AND. vu >= 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 = slamch( 'Safe minimum' ) eps = slamch( '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 = slansy( 'M', uplo, n, a, lda, work ) IF( anrm > zero .AND. anrm < rmin ) THEN iscale = 1 sigma = rmin / anrm ELSE IF( anrm > rmax ) THEN iscale = 1 sigma = rmax / anrm END IF IF( iscale == 1 ) THEN IF( lower ) THEN DO j = 1, n CALL sscal( n-j+1, sigma, a( j, j ), 1 ) END DO ELSE DO j = 1, n CALL sscal( j, sigma, a( 1, j ), 1 ) END DO END IF IF( abstol > 0 ) abstll = abstol*sigma IF( valeig ) THEN vll = vl*sigma vuu = vu*sigma END IF END IF ! ! Call SSYTRD to reduce symmetric matrix to tridiagonal form. ! indtau = 1 inde = indtau + n indd = inde + n indee = indd + n inddd = indee + n indifl = inddd + n indwk = indifl + n llwork = lwork - indwk + 1 CALL ssytrd( uplo, n, a, lda, work( indd ), work( inde ), & work( indtau ), work( indwk ), llwork, iinfo ) ! ! If all eigenvalues are desired ! then call SSTERF or SSTEGR and SORMTR. ! IF( ( alleig .OR. ( indeig .AND. il == 1 .AND. iu == n ) ) .AND. & ieeeok == 1 ) THEN IF( .NOT.wantz ) THEN CALL scopy( n, work( indd ), 1, w, 1 ) CALL scopy( n-1, work( inde ), 1, work( indee ), 1 ) CALL ssterf( n, w, work( indee ), info ) ELSE CALL scopy( n-1, work( inde ), 1, work( indee ), 1 ) CALL scopy( n, work( indd ), 1, work( inddd ), 1 ) ! CALL sstegr( jobz, range, n, work( inddd ), work( indee ), & vl, vu, il, iu, abstol, m, w, z, ldz, isuppz, & work( indwk ), lwork, iwork, liwork, info ) ! ! ! ! Apply orthogonal matrix used in reduction to tridiagonal ! form to eigenvectors returned by SSTEIN. ! IF( wantz .AND. info == 0 ) THEN indwkn = inde llwrkn = lwork - indwkn + 1 CALL sormtr( 'L', uplo, 'N', n, m, a, lda, & work( indtau ), z, ldz, work( indwkn ), llwrkn, iinfo ) END IF END IF ! ! IF( info == 0 ) THEN m = n GO TO 30 END IF info = 0 END IF ! ! Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. ! Also call SSTEBZ and SSTEIN if SSTEGR fails. ! IF( wantz ) THEN order = 'B' ELSE order = 'E' END IF indifl = 1 indibl = indifl + n indisp = indibl + n indiwo = indisp + n CALL sstebz( range, order, n, vll, vuu, il, iu, abstll, & work( indd ), work( inde ), m, nsplit, w, & iwork( indibl ), iwork( indisp ), work( indwk ), iwork( indiwo ), info ) ! IF( wantz ) THEN CALL sstein( n, work( indd ), work( inde ), m, w, & iwork( indibl ), iwork( indisp ), z, ldz, & work( indwk ), iwork( indiwo ), iwork( indifl ), info ) ! ! Apply orthogonal matrix used in reduction to tridiagonal ! form to eigenvectors returned by SSTEIN. ! indwkn = inde llwrkn = lwork - indwkn + 1 CALL sormtr( '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. ! 30 CONTINUE IF( iscale == 1 ) THEN IF( info == 0 ) THEN imax = m ELSE imax = info - 1 END IF CALL sscal( imax, one / sigma, w, 1 ) END IF ! ! If eigenvalues are not in order, then sort them, along with ! eigenvectors. ! IF( wantz ) THEN DO j = 1, m - 1 i = 0 tmp1 = w( j ) DO jj = j + 1, m IF( w( jj ) < tmp1 ) THEN i = jj tmp1 = w( jj ) END IF END DO ! IF( i /= 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 sswap( n, z( 1, i ), 1, z( 1, j ), 1 ) END IF END DO END IF ! ! Set WORK(1) to optimal workspace size. ! work( 1 ) = lwkopt iwork( 1 ) = liwmin ! RETURN ! ! End of SSYEVR ! END SUBROUTINE ssyevr SUBROUTINE ssyevx( 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 (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: range CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN) :: vl REAL, INTENT(IN) :: vu INTEGER, INTENT(IN) :: il INTEGER, INTENT(IN) :: iu REAL, INTENT(IN) :: abstol INTEGER, INTENT(OUT) :: m REAL, INTENT(OUT) :: w( * ) REAL, INTENT(OUT) :: z( ldz, * ) INTEGER, INTENT(IN) :: ldz REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: ifail( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYEVX 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) REAL 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) REAL ! VU (input) REAL ! 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) REAL ! 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*SLAMCH('S'), not zero. ! If this routine returns with INFO>0, indicating that some ! eigenvectors did not converge, try setting ABSTOL to ! 2*SLAMCH('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) REAL array, dimension (N) ! On normal exit, the first M elements contain the selected ! eigenvalues in ascending order. ! ! Z (output) REAL 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) REAL 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 SSYTRD and SORMTR ! 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 .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: alleig, indeig, lower, lquery, valeig, wantz CHARACTER (LEN=1) :: order INTEGER :: i, iinfo, imax, indd, inde, indee, indibl, & indisp, indiwo, indtau, indwkn, indwrk, iscale, & itmp1, j, jj, llwork, llwrkn, lopt, lwkopt, nb, nsplit REAL :: abstll, anrm, bignum, eps, rmax, rmin, safmin, & sigma, smlnum, tmp1, vll, vuu ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slansy EXTERNAL lsame, ilaenv, slamch, slansy ! .. ! .. External Subroutines .. EXTERNAL scopy, slacpy, sorgtr, sormtr, sscal, sstebz, & sstein, ssteqr, ssterf, sswap, ssytrd, 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 == -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 < 0 ) THEN info = -4 ELSE IF( lda < MAX( 1, n ) ) THEN info = -6 ELSE IF( valeig ) THEN IF( n > 0 .AND. vu <= vl ) info = -8 ELSE IF( indeig ) THEN IF( il < 1 .OR. il > MAX( 1, n ) ) THEN info = -9 ELSE IF( iu < MIN( n, il ) .OR. iu > n ) THEN info = -10 END IF END IF END IF IF( info == 0 ) THEN IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) THEN info = -15 ELSE IF( lwork < MAX( 1, 8*n ) .AND. .NOT.lquery ) THEN info = -17 END IF END IF ! IF( info == 0 ) THEN nb = ilaenv( 1, 'SSYTRD', uplo, n, -1, -1, -1 ) nb = MAX( nb, ilaenv( 1, 'SORMTR', uplo, n, -1, -1, -1 ) ) lwkopt = ( nb+3 )*n work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSYEVX', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! m = 0 IF( n == 0 ) THEN work( 1 ) = 1 RETURN END IF ! IF( n == 1 ) THEN work( 1 ) = 7 IF( alleig .OR. indeig ) THEN m = 1 w( 1 ) = a( 1, 1 ) ELSE IF( vl < a( 1, 1 ) .AND. vu >= 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 = slamch( 'Safe minimum' ) eps = slamch( '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 = slansy( 'M', uplo, n, a, lda, work ) IF( anrm > zero .AND. anrm < rmin ) THEN iscale = 1 sigma = rmin / anrm ELSE IF( anrm > rmax ) THEN iscale = 1 sigma = rmax / anrm END IF IF( iscale == 1 ) THEN IF( lower ) THEN DO j = 1, n CALL sscal( n-j+1, sigma, a( j, j ), 1 ) END DO ELSE DO j = 1, n CALL sscal( j, sigma, a( 1, j ), 1 ) END DO END IF IF( abstol > 0 ) abstll = abstol*sigma IF( valeig ) THEN vll = vl*sigma vuu = vu*sigma END IF END IF ! ! Call SSYTRD to reduce symmetric matrix to tridiagonal form. ! indtau = 1 inde = indtau + n indd = inde + n indwrk = indd + n llwork = lwork - indwrk + 1 CALL ssytrd( 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 SSTERF or SORGTR and SSTEQR. If this fails for ! some eigenvalue, then try SSTEBZ. ! IF( ( alleig .OR. ( indeig .AND. il == 1 .AND. iu == n ) ) .AND. & ( abstol <= zero ) ) THEN CALL scopy( n, work( indd ), 1, w, 1 ) indee = indwrk + 2*n IF( .NOT.wantz ) THEN CALL scopy( n-1, work( inde ), 1, work( indee ), 1 ) CALL ssterf( n, w, work( indee ), info ) ELSE CALL slacpy( 'A', n, n, a, lda, z, ldz ) CALL sorgtr( uplo, n, z, ldz, work( indtau ), & work( indwrk ), llwork, iinfo ) CALL scopy( n-1, work( inde ), 1, work( indee ), 1 ) CALL ssteqr( jobz, n, w, work( indee ), z, ldz, work( indwrk ), info ) IF( info == 0 ) THEN DO i = 1, n ifail( i ) = 0 END DO END IF END IF IF( info == 0 ) THEN m = n GO TO 40 END IF info = 0 END IF ! ! Otherwise, call SSTEBZ 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 sstebz( 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 sstein( 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 SSTEIN. ! indwkn = inde llwrkn = lwork - indwkn + 1 CALL sormtr( '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 == 1 ) THEN IF( info == 0 ) THEN imax = m ELSE imax = info - 1 END IF CALL sscal( imax, one / sigma, w, 1 ) END IF ! ! If eigenvalues are not in order, then sort them, along with ! eigenvectors. ! IF( wantz ) THEN DO j = 1, m - 1 i = 0 tmp1 = w( j ) DO jj = j + 1, m IF( w( jj ) < tmp1 ) THEN i = jj tmp1 = w( jj ) END IF END DO ! IF( i /= 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 sswap( n, z( 1, i ), 1, z( 1, j ), 1 ) IF( info /= 0 ) THEN itmp1 = ifail( i ) ifail( i ) = ifail( j ) ifail( j ) = itmp1 END IF END IF END DO END IF ! ! Set WORK(1) to optimal workspace size. ! work( 1 ) = lwkopt ! RETURN ! ! End of SSYEVX ! END SUBROUTINE ssyevx SUBROUTINE ssygs2( 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 .. INTEGER, INTENT(IN) :: itype CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYGS2 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 SPOTRF. ! ! 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) REAL 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) REAL array, dimension (LDB,N) ! The triangular factor from the Cholesky factorization of B, ! as returned by SPOTRF. ! ! 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 .. REAL, PARAMETER :: one = 1.0 REAL, PARAMETER :: half = 0.5 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: k REAL :: akk, bkk, ct ! .. ! .. External Subroutines .. EXTERNAL saxpy, sscal, ssyr2, strmv, strsv, 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 < 1 .OR. itype > 3 ) THEN info = -1 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -7 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSYGS2', -info ) RETURN END IF ! IF( itype == 1 ) THEN IF( upper ) THEN ! ! Compute inv(U')*A*inv(U) ! DO 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 < n ) THEN CALL sscal( n-k, one / bkk, a( k, k+1 ), lda ) ct = -half*akk CALL saxpy( n-k, ct, b( k, k+1 ), ldb, a( k, k+1 ), lda ) CALL ssyr2( uplo, n-k, -one, a( k, k+1 ), lda, & b( k, k+1 ), ldb, a( k+1, k+1 ), lda ) CALL saxpy( n-k, ct, b( k, k+1 ), ldb, a( k, k+1 ), lda ) CALL strsv( uplo, 'Transpose', 'Non-unit', n-k, & b( k+1, k+1 ), ldb, a( k, k+1 ), lda ) END IF END DO ELSE ! ! Compute inv(L)*A*inv(L') ! DO 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 < n ) THEN CALL sscal( n-k, one / bkk, a( k+1, k ), 1 ) ct = -half*akk CALL saxpy( n-k, ct, b( k+1, k ), 1, a( k+1, k ), 1 ) CALL ssyr2( uplo, n-k, -one, a( k+1, k ), 1, & b( k+1, k ), 1, a( k+1, k+1 ), lda ) CALL saxpy( n-k, ct, b( k+1, k ), 1, a( k+1, k ), 1 ) CALL strsv( uplo, 'No transpose', 'Non-unit', n-k, & b( k+1, k+1 ), ldb, a( k+1, k ), 1 ) END IF END DO END IF ELSE IF( upper ) THEN ! ! Compute U*A*U' ! DO k = 1, n ! ! Update the upper triangle of A(1:k,1:k) ! akk = a( k, k ) bkk = b( k, k ) CALL strmv( uplo, 'No transpose', 'Non-unit', k-1, b, & ldb, a( 1, k ), 1 ) ct = half*akk CALL saxpy( k-1, ct, b( 1, k ), 1, a( 1, k ), 1 ) CALL ssyr2( uplo, k-1, one, a( 1, k ), 1, b( 1, k ), 1, a, lda ) CALL saxpy( k-1, ct, b( 1, k ), 1, a( 1, k ), 1 ) CALL sscal( k-1, bkk, a( 1, k ), 1 ) a( k, k ) = akk*bkk**2 END DO ELSE ! ! Compute L'*A*L ! DO k = 1, n ! ! Update the lower triangle of A(1:k,1:k) ! akk = a( k, k ) bkk = b( k, k ) CALL strmv( uplo, 'Transpose', 'Non-unit', k-1, b, ldb, a( k, 1 ), lda ) ct = half*akk CALL saxpy( k-1, ct, b( k, 1 ), ldb, a( k, 1 ), lda ) CALL ssyr2( uplo, k-1, one, a( k, 1 ), lda, b( k, 1 ), ldb, a, lda ) CALL saxpy( k-1, ct, b( k, 1 ), ldb, a( k, 1 ), lda ) CALL sscal( k-1, bkk, a( k, 1 ), lda ) a( k, k ) = akk*bkk**2 END DO END IF END IF RETURN ! ! End of SSYGS2 ! END SUBROUTINE ssygs2 SUBROUTINE ssygst( 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 .. INTEGER, INTENT(IN) :: itype CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYGST 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 SPOTRF. ! ! 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) REAL 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) REAL array, dimension (LDB,N) ! The triangular factor from the Cholesky factorization of B, ! as returned by SPOTRF. ! ! 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 .. REAL, PARAMETER :: one = 1.0 REAL, PARAMETER :: half = 0.5 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: k, kb, nb ! .. ! .. External Subroutines .. EXTERNAL ssygs2, ssymm, ssyr2k, strmm, strsm, 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 < 1 .OR. itype > 3 ) THEN info = -1 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -7 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSYGST', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Determine the block size for this environment. ! nb = ilaenv( 1, 'SSYGST', uplo, n, -1, -1, -1 ) ! IF( nb <= 1 .OR. nb >= n ) THEN ! ! Use unblocked code ! CALL ssygs2( itype, uplo, n, a, lda, b, ldb, info ) ELSE ! ! Use blocked code ! IF( itype == 1 ) THEN IF( upper ) THEN ! ! Compute inv(U')*A*inv(U) ! DO k = 1, n, nb kb = MIN( n-k+1, nb ) ! ! Update the upper triangle of A(k:n,k:n) ! CALL ssygs2( itype, uplo, kb, a( k, k ), lda, b( k, k ), ldb, info ) IF( k+kb <= n ) THEN CALL strsm( 'Left', uplo, 'Transpose', 'Non-unit', & kb, n-k-kb+1, one, b( k, k ), ldb, a( k, k+kb ), lda ) CALL ssymm( 'Left', uplo, kb, n-k-kb+1, -half, & a( k, k ), lda, b( k, k+kb ), ldb, one, a( k, k+kb ), lda ) CALL ssyr2k( 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 ssymm( 'Left', uplo, kb, n-k-kb+1, -half, & a( k, k ), lda, b( k, k+kb ), ldb, one, a( k, k+kb ), lda ) CALL strsm( '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 END DO ELSE ! ! Compute inv(L)*A*inv(L') ! DO k = 1, n, nb kb = MIN( n-k+1, nb ) ! ! Update the lower triangle of A(k:n,k:n) ! CALL ssygs2( itype, uplo, kb, a( k, k ), lda, b( k, k ), ldb, info ) IF( k+kb <= n ) THEN CALL strsm( 'Right', uplo, 'Transpose', 'Non-unit', & n-k-kb+1, kb, one, b( k, k ), ldb, a( k+kb, k ), lda ) CALL ssymm( 'Right', uplo, n-k-kb+1, kb, -half, & a( k, k ), lda, b( k+kb, k ), ldb, one, a( k+kb, k ), lda ) CALL ssyr2k( 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 ssymm( 'Right', uplo, n-k-kb+1, kb, -half, & a( k, k ), lda, b( k+kb, k ), ldb, one, a( k+kb, k ), lda ) CALL strsm( '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 END DO END IF ELSE IF( upper ) THEN ! ! Compute U*A*U' ! DO 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 strmm( 'Left', uplo, 'No transpose', 'Non-unit', & k-1, kb, one, b, ldb, a( 1, k ), lda ) CALL ssymm( 'Right', uplo, k-1, kb, half, a( k, k ), & lda, b( 1, k ), ldb, one, a( 1, k ), lda ) CALL ssyr2k( uplo, 'No transpose', k-1, kb, one, & a( 1, k ), lda, b( 1, k ), ldb, one, a, lda ) CALL ssymm( 'Right', uplo, k-1, kb, half, a( k, k ), & lda, b( 1, k ), ldb, one, a( 1, k ), lda ) CALL strmm( 'Right', uplo, 'Transpose', 'Non-unit', & k-1, kb, one, b( k, k ), ldb, a( 1, k ), lda ) CALL ssygs2( itype, uplo, kb, a( k, k ), lda, b( k, k ), ldb, info ) END DO ELSE ! ! Compute L'*A*L ! DO 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 strmm( 'Right', uplo, 'No transpose', 'Non-unit', & kb, k-1, one, b, ldb, a( k, 1 ), lda ) CALL ssymm( 'Left', uplo, kb, k-1, half, a( k, k ), & lda, b( k, 1 ), ldb, one, a( k, 1 ), lda ) CALL ssyr2k( uplo, 'Transpose', k-1, kb, one, & a( k, 1 ), lda, b( k, 1 ), ldb, one, a, lda ) CALL ssymm( 'Left', uplo, kb, k-1, half, a( k, k ), & lda, b( k, 1 ), ldb, one, a( k, 1 ), lda ) CALL strmm( 'Left', uplo, 'Transpose', 'Non-unit', kb, & k-1, one, b( k, k ), ldb, a( k, 1 ), lda ) CALL ssygs2( itype, uplo, kb, a( k, k ), lda, b( k, k ), ldb, info ) END DO END IF END IF END IF RETURN ! ! End of SSYGST ! END SUBROUTINE ssygst SUBROUTINE ssygv( 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 .. INTEGER, INTENT(IN) :: itype CHARACTER (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: w( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYGV 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) REAL 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) REAL 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) REAL array, dimension (N) ! If INFO = 0, the eigenvalues in ascending order. ! ! WORK (workspace/output) REAL 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 SSYTRD 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: SPOTRF or SSYEV returned an error code: ! <= N: if INFO = i, SSYEV 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, upper, wantz CHARACTER (LEN=1) :: trans INTEGER :: lwkopt, nb, neig ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL ilaenv, lsame ! .. ! .. External Subroutines .. EXTERNAL spotrf, ssyev, ssygst, strmm, strsm, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! wantz = lsame( jobz, 'V' ) upper = lsame( uplo, 'U' ) lquery = ( lwork == -1 ) ! info = 0 IF( itype < 1 .OR. itype > 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 < 0 ) THEN info = -4 ELSE IF( lda < MAX( 1, n ) ) THEN info = -6 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -8 ELSE IF( lwork < MAX( 1, 3*n-1 ) .AND. .NOT.lquery ) THEN info = -11 END IF ! IF( info == 0 ) THEN nb = ilaenv( 1, 'SSYTRD', uplo, n, -1, -1, -1 ) lwkopt = ( nb+2 )*n work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSYGV ', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Form a Cholesky factorization of B. ! CALL spotrf( uplo, n, b, ldb, info ) IF( info /= 0 ) THEN info = n + info RETURN END IF ! ! Transform problem to standard eigenvalue problem and solve. ! CALL ssygst( itype, uplo, n, a, lda, b, ldb, info ) CALL ssyev( jobz, uplo, n, a, lda, w, work, lwork, info ) ! IF( wantz ) THEN ! ! Backtransform eigenvectors to the original problem. ! neig = n IF( info > 0 ) neig = info - 1 IF( itype == 1 .OR. itype == 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 strsm( 'Left', uplo, trans, 'Non-unit', n, neig, one, & b, ldb, a, lda ) ! ELSE IF( itype == 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 strmm( 'Left', uplo, trans, 'Non-unit', n, neig, one, & b, ldb, a, lda ) END IF END IF ! work( 1 ) = lwkopt RETURN ! ! End of SSYGV ! END SUBROUTINE ssygv SUBROUTINE ssygvd( itype, jobz, uplo, n, a, lda, b, ldb, w, work, & lwork, iwork, liwork, 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 .. INTEGER, INTENT(IN) :: itype CHARACTER (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: w( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(IN OUT) :: liwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYGVD 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. ! If eigenvectors are desired, it uses a divide and conquer algorithm. ! ! The divide and conquer algorithm makes very mild assumptions about ! floating point arithmetic. It will work on machines with a guard ! digit in add/subtract, or on those binary machines without guard ! digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or ! Cray-2. It could conceivably fail on hexadecimal or decimal machines ! without guard digits, but we know of none. ! ! 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) REAL 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) REAL array, dimension (LDB, 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). ! ! W (output) REAL array, dimension (N) ! If INFO = 0, the eigenvalues in ascending order. ! ! WORK (workspace/output) REAL array, dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. ! If N <= 1, LWORK >= 1. ! If JOBZ = 'N' and N > 1, LWORK >= 2*N+1. ! If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. ! ! 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/output) INTEGER array, dimension (LIWORK) ! On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. ! ! LIWORK (input) INTEGER ! The dimension of the array IWORK. ! If N <= 1, LIWORK >= 1. ! If JOBZ = 'N' and N > 1, LIWORK >= 1. ! If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. ! ! If LIWORK = -1, then a workspace query is assumed; the ! routine only calculates the optimal size of the IWORK array, ! returns this value as the first entry of the IWORK array, and ! no error message related to LIWORK is issued by XERBLA. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! > 0: SPOTRF or SSYEVD returned an error code: ! <= N: if INFO = i, SSYEVD 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. ! ! Further Details ! =============== ! ! Based on contributions by ! Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, upper, wantz CHARACTER (LEN=1) :: trans INTEGER :: liopt, liwmin, lopt, lwmin, neig ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL spotrf, ssyevd, ssygst, strmm, strsm, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, REAL ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! wantz = lsame( jobz, 'V' ) upper = lsame( uplo, 'U' ) lquery = ( lwork == -1 .OR. liwork == -1 ) ! info = 0 IF( n <= 1 ) THEN liwmin = 1 lwmin = 1 lopt = lwmin liopt = liwmin ELSE IF( wantz ) THEN liwmin = 3 + 5*n lwmin = 1 + 6*n + 2*n**2 ELSE liwmin = 1 lwmin = 2*n + 1 END IF lopt = lwmin liopt = liwmin END IF IF( itype < 0 .OR. itype > 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 < 0 ) THEN info = -4 ELSE IF( lda < MAX( 1, n ) ) THEN info = -6 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -8 ELSE IF( lwork < lwmin .AND. .NOT.lquery ) THEN info = -11 ELSE IF( liwork < liwmin .AND. .NOT.lquery ) THEN info = -13 END IF ! IF( info == 0 ) THEN work( 1 ) = lopt iwork( 1 ) = liopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSYGVD', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Form a Cholesky factorization of B. ! CALL spotrf( uplo, n, b, ldb, info ) IF( info /= 0 ) THEN info = n + info RETURN END IF ! ! Transform problem to standard eigenvalue problem and solve. ! CALL ssygst( itype, uplo, n, a, lda, b, ldb, info ) CALL ssyevd( jobz, uplo, n, a, lda, w, work, lwork, iwork, liwork, info ) lopt = MAX( REAL( lopt ), REAL( work( 1 ) ) ) liopt = MAX( REAL( liopt ), REAL( iwork( 1 ) ) ) ! IF( wantz ) THEN ! ! Backtransform eigenvectors to the original problem. ! neig = n IF( info > 0 ) neig = info - 1 IF( itype == 1 .OR. itype == 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 strsm( 'Left', uplo, trans, 'Non-unit', n, neig, one, & b, ldb, a, lda ) ! ELSE IF( itype == 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 strmm( 'Left', uplo, trans, 'Non-unit', n, neig, one, & b, ldb, a, lda ) END IF END IF ! work( 1 ) = lopt iwork( 1 ) = liopt ! RETURN ! ! End of SSYGVD ! END SUBROUTINE ssygvd SUBROUTINE ssygvx( 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 .. INTEGER, INTENT(IN) :: itype CHARACTER (LEN=1), INTENT(IN) :: jobz CHARACTER (LEN=1), INTENT(IN) :: range CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: vl REAL, INTENT(IN) :: vu INTEGER, INTENT(IN OUT) :: il INTEGER, INTENT(IN OUT) :: iu REAL, INTENT(IN OUT) :: abstol INTEGER, INTENT(OUT) :: m REAL, INTENT(IN OUT) :: w( * ) REAL, INTENT(IN OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(IN OUT) :: ifail( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYGVX 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) REAL 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) REAL 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) REAL ! VU (input) REAL ! 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) REAL ! 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*SLAMCH('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) REAL array, dimension (N) ! On normal exit, the first M elements contain the selected ! eigenvalues in ascending order. ! ! Z (output) REAL 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) REAL 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 SSYTRD 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: SPOTRF or SSYEVX returned an error code: ! <= N: if INFO = i, SSYEVX 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: alleig, indeig, lquery, upper, valeig, wantz CHARACTER (LEN=1) :: trans INTEGER :: lopt, lwkopt, nb ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL ilaenv, lsame ! .. ! .. External Subroutines .. EXTERNAL spotrf, ssyevx, ssygst, strmm, strsm, 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 == -1 ) ! info = 0 IF( itype < 0 .OR. itype > 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 < 0 ) THEN info = -5 ELSE IF( lda < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -9 ELSE IF( valeig .AND. n > 0 ) THEN IF( vu <= vl ) info = -11 ELSE IF( indeig .AND. il < 1 ) THEN info = -12 ELSE IF( indeig .AND. ( iu < MIN( n, il ) .OR. iu > n ) ) THEN info = -13 ELSE IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) THEN info = -18 ELSE IF( lwork < MAX( 1, 8*n ) .AND. .NOT.lquery ) THEN info = -20 END IF ! IF( info == 0 ) THEN nb = ilaenv( 1, 'SSYTRD', uplo, n, -1, -1, -1 ) lwkopt = ( nb+3 )*n work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSYGVX', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! m = 0 IF( n == 0 ) THEN work( 1 ) = 1 RETURN END IF ! ! Form a Cholesky factorization of B. ! CALL spotrf( uplo, n, b, ldb, info ) IF( info /= 0 ) THEN info = n + info RETURN END IF ! ! Transform problem to standard eigenvalue problem and solve. ! CALL ssygst( itype, uplo, n, a, lda, b, ldb, info ) CALL ssyevx( 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 > 0 ) m = info - 1 IF( itype == 1 .OR. itype == 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 strsm( 'Left', uplo, trans, 'Non-unit', n, m, one, b, ldb, z, ldz ) ! ELSE IF( itype == 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 strmm( '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 SSYGVX ! END SUBROUTINE ssygvx SUBROUTINE ssyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, & x, ldx, ferr, berr, 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 ! September 30, 1994 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: af( ldaf, * ) INTEGER, INTENT(IN OUT) :: ldaf INTEGER, INTENT(IN OUT) :: ipiv( * ) REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: ferr( * ) REAL, INTENT(OUT) :: berr( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYRFS improves the computed solution to a system of linear ! equations when the coefficient matrix is symmetric indefinite, and ! provides error bounds and backward error estimates for the solution. ! ! 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 matrices B and X. NRHS >= 0. ! ! A (input) REAL 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(1,N). ! ! AF (input) REAL array, dimension (LDAF,N) ! The factored form of the matrix A. AF contains the block ! diagonal matrix D and the multipliers used to obtain the ! factor U or L from the factorization A = U*D*U**T or ! A = L*D*L**T as computed by SSYTRF. ! ! LDAF (input) INTEGER ! The leading dimension of the array AF. LDAF >= max(1,N). ! ! IPIV (input) INTEGER array, dimension (N) ! Details of the interchanges and the block structure of D ! as determined by SSYTRF. ! ! B (input) REAL array, dimension (LDB,NRHS) ! The right hand side matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (input/output) REAL array, dimension (LDX,NRHS) ! On entry, the solution matrix X, as computed by SSYTRS. ! On exit, the improved solution matrix X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! Internal Parameters ! =================== ! ! ITMAX is the maximum number of steps of iterative refinement. ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: itmax = 5 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 REAL, PARAMETER :: three = 3.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: count, i, j, k, kase, nz REAL :: eps, lstres, s, safe1, safe2, safmin, xk ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, slacon, ssymv, ssytrs, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. 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 < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( ldaf < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -10 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -12 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSYRFS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) THEN DO j = 1, nrhs ferr( j ) = zero berr( j ) = zero END DO RETURN END IF ! ! NZ = maximum number of nonzero elements in each row of A, plus 1 ! nz = n + 1 eps = slamch( 'Epsilon' ) safmin = slamch( 'Safe minimum' ) safe1 = nz*safmin safe2 = safe1 / eps ! ! Do for each right hand side ! DO j = 1, nrhs ! count = 1 lstres = three 20 CONTINUE ! ! Loop until stopping criterion is satisfied. ! ! Compute residual R = B - A * X ! CALL scopy( n, b( 1, j ), 1, work( n+1 ), 1 ) CALL ssymv( uplo, n, -one, a, lda, x( 1, j ), 1, one, work( n+1 ), 1 ) ! ! Compute componentwise relative backward error from formula ! ! max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) ! ! where abs(Z) is the componentwise absolute value of the matrix ! or vector Z. If the i-th component of the denominator is less ! than SAFE2, then SAFE1 is added to the i-th components of the ! numerator and denominator before dividing. ! DO i = 1, n work( i ) = ABS( b( i, j ) ) END DO ! ! Compute abs(A)*abs(X) + abs(B). ! IF( upper ) THEN DO k = 1, n s = zero xk = ABS( x( k, j ) ) DO i = 1, k - 1 work( i ) = work( i ) + ABS( a( i, k ) )*xk s = s + ABS( a( i, k ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + ABS( a( k, k ) )*xk + s END DO ELSE DO k = 1, n s = zero xk = ABS( x( k, j ) ) work( k ) = work( k ) + ABS( a( k, k ) )*xk DO i = k + 1, n work( i ) = work( i ) + ABS( a( i, k ) )*xk s = s + ABS( a( i, k ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + s END DO END IF s = zero DO i = 1, n IF( work( i ) > safe2 ) THEN s = MAX( s, ABS( work( n+i ) ) / work( i ) ) ELSE s = MAX( s, ( ABS( work( n+i ) )+safe1 ) / ( work( i )+safe1 ) ) END IF END DO berr( j ) = s ! ! Test stopping criterion. Continue iterating if ! 1) The residual BERR(J) is larger than machine epsilon, and ! 2) BERR(J) decreased by at least a factor of 2 during the ! last iteration, and ! 3) At most ITMAX iterations tried. ! IF( berr( j ) > eps .AND. two*berr( j ) <= lstres .AND. & count <= itmax ) THEN ! ! Update solution and try again. ! CALL ssytrs( uplo, n, 1, af, ldaf, ipiv, work( n+1 ), n, info ) CALL saxpy( n, one, work( n+1 ), 1, x( 1, j ), 1 ) lstres = berr( j ) count = count + 1 GO TO 20 END IF ! ! Bound error from formula ! ! norm(X - XTRUE) / norm(X) .le. FERR = ! norm( abs(inv(A))* ! ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) ! ! where ! norm(Z) is the magnitude of the largest component of Z ! inv(A) is the inverse of A ! abs(Z) is the componentwise absolute value of the matrix or ! vector Z ! NZ is the maximum number of nonzeros in any row of A, plus 1 ! EPS is machine epsilon ! ! The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) ! is incremented by SAFE1 if the i-th component of ! abs(A)*abs(X) + abs(B) is less than SAFE2. ! ! Use SLACON to estimate the infinity-norm of the matrix ! inv(A) * diag(W), ! where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) ! DO i = 1, n IF( work( i ) > safe2 ) THEN work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) ELSE work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) + safe1 END IF END DO ! kase = 0 100 CONTINUE CALL slacon( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ), kase ) IF( kase /= 0 ) THEN IF( kase == 1 ) THEN ! ! Multiply by diag(W)*inv(A'). ! CALL ssytrs( uplo, n, 1, af, ldaf, ipiv, work( n+1 ), n, info ) DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO ELSE IF( kase == 2 ) THEN ! ! Multiply by inv(A)*diag(W). ! DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO CALL ssytrs( uplo, n, 1, af, ldaf, ipiv, work( n+1 ), n, info ) END IF GO TO 100 END IF ! ! Normalize error. ! lstres = zero DO i = 1, n lstres = MAX( lstres, ABS( x( i, j ) ) ) END DO IF( lstres /= zero ) ferr( j ) = ferr( j ) / lstres ! END DO ! RETURN ! ! End of SSYRFS ! END SUBROUTINE ssyrfs SUBROUTINE ssysv( uplo, n, nrhs, a, lda, ipiv, b, ldb, 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: nrhs REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(IN OUT) :: ipiv( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYSV computes the solution to a real system of linear equations ! A * X = B, ! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS ! matrices. ! ! The diagonal pivoting method is used to factor A as ! A = U * D * U**T, if UPLO = 'U', or ! A = L * D * L**T, if UPLO = 'L', ! 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. The factored form of A is then ! used to solve the system of equations A * X = B. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! = 'U': Upper triangle of A is stored; ! = 'L': Lower triangle of A is stored. ! ! 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) REAL 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 block diagonal matrix D and the ! multipliers used to obtain the factor U or L from the ! factorization A = U*D*U**T or A = L*D*L**T as computed by ! SSYTRF. ! ! 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, as ! determined by SSYTRF. 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. ! ! B (input/output) REAL 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). ! ! WORK (workspace/output) REAL array, dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The length of WORK. LWORK >= 1, and for best performance ! LWORK >= N*NB, where NB is the optimal blocksize for ! SSYTRF. ! ! 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, so the solution could not be computed. ! ! ===================================================================== ! ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: lwkopt, nb ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL ilaenv, lsame ! .. ! .. External Subroutines .. EXTERNAL ssytrf, ssytrs, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 lquery = ( lwork == -1 ) IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -8 ELSE IF( lwork < 1 .AND. .NOT.lquery ) THEN info = -10 END IF ! IF( info == 0 ) THEN nb = ilaenv( 1, 'SSYTRF', uplo, n, -1, -1, -1 ) lwkopt = n*nb work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSYSV ', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Compute the factorization A = U*D*U' or A = L*D*L'. ! CALL ssytrf( uplo, n, a, lda, ipiv, work, lwork, info ) IF( info == 0 ) THEN ! ! Solve the system A*X = B, overwriting B with X. ! CALL ssytrs( uplo, n, nrhs, a, lda, ipiv, b, ldb, info ) ! END IF ! work( 1 ) = lwkopt ! RETURN ! ! End of SSYSV ! END SUBROUTINE ssysv SUBROUTINE ssysvx( fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, & ldb, x, ldx, rcond, ferr, berr, work, lwork, iwork, 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 (LEN=1), INTENT(IN) :: fact CHARACTER (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: nrhs REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN OUT) :: af( ldaf, * ) INTEGER, INTENT(IN OUT) :: ldaf INTEGER, INTENT(IN OUT) :: ipiv( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: rcond REAL, INTENT(IN OUT) :: ferr( * ) REAL, INTENT(IN OUT) :: berr( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYSVX uses the diagonal pivoting factorization to compute the ! solution to a real system of linear equations A * X = B, ! where A is an N-by-N symmetric matrix and X and B are N-by-NRHS ! matrices. ! ! Error bounds on the solution and a condition estimate are also ! provided. ! ! Description ! =========== ! ! The following steps are performed: ! ! 1. If FACT = 'N', the diagonal pivoting method is used to factor A. ! The form of the factorization is ! A = U * D * U**T, if UPLO = 'U', or ! A = L * D * L**T, if UPLO = 'L', ! 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. ! ! 2. If some D(i,i)=0, so that D is exactly singular, then the routine ! returns with INFO = i. Otherwise, the factored form of A is used ! to estimate the condition number of the matrix A. If the ! reciprocal of the condition number is less than machine precision, ! INFO = N+1 is returned as a warning, but the routine still goes on ! to solve for X and compute error bounds as described below. ! ! 3. The system of equations is solved for X using the factored form ! of A. ! ! 4. Iterative refinement is applied to improve the computed solution ! matrix and calculate error bounds and backward error estimates ! for it. ! ! Arguments ! ========= ! ! FACT (input) CHARACTER*1 ! Specifies whether or not the factored form of A has been ! supplied on entry. ! = 'F': On entry, AF and IPIV contain the factored form of ! A. AF and IPIV will not be modified. ! = 'N': The matrix A will be copied to AF and factored. ! ! UPLO (input) CHARACTER*1 ! = 'U': Upper triangle of A is stored; ! = 'L': Lower triangle of A is stored. ! ! 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 matrices B and X. NRHS >= 0. ! ! A (input) REAL 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(1,N). ! ! AF (input or output) REAL array, dimension (LDAF,N) ! If FACT = 'F', then AF is an input argument and on entry ! contains the block diagonal matrix D and the multipliers used ! to obtain the factor U or L from the factorization ! A = U*D*U**T or A = L*D*L**T as computed by SSYTRF. ! ! If FACT = 'N', then AF is an output argument and on exit ! returns the block diagonal matrix D and the multipliers used ! to obtain the factor U or L from the factorization ! A = U*D*U**T or A = L*D*L**T. ! ! LDAF (input) INTEGER ! The leading dimension of the array AF. LDAF >= max(1,N). ! ! IPIV (input or output) INTEGER array, dimension (N) ! If FACT = 'F', then IPIV is an input argument and on entry ! contains details of the interchanges and the block structure ! of D, as determined by SSYTRF. ! 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. ! ! If FACT = 'N', then IPIV is an output argument and on exit ! contains details of the interchanges and the block structure ! of D, as determined by SSYTRF. ! ! B (input) REAL array, dimension (LDB,NRHS) ! The N-by-NRHS right hand side matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (output) REAL array, dimension (LDX,NRHS) ! If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! RCOND (output) REAL ! The estimate of the reciprocal condition number of the matrix ! A. If RCOND is less than the machine precision (in ! particular, if RCOND = 0), the matrix is singular to working ! precision. This condition is indicated by a return code of ! INFO > 0. ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace/output) REAL array, dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The length of WORK. LWORK >= 3*N, and for best performance ! LWORK >= N*NB, where NB is the optimal blocksize for ! SSYTRF. ! ! 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 (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! > 0: if INFO = i, and i is ! <= N: D(i,i) is exactly zero. The factorization ! has been completed but the factor D is exactly ! singular, so the solution and error bounds could ! not be computed. RCOND = 0 is returned. ! = N+1: D is nonsingular, but RCOND is less than machine ! precision, meaning that the matrix is singular ! to working precision. Nevertheless, the ! solution and error bounds are computed because ! there are a number of situations where the ! computed solution can be more accurate than the ! value of RCOND would suggest. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, nofact INTEGER :: lwkopt, nb REAL :: anorm ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv REAL :: slamch, slansy EXTERNAL ilaenv, lsame, slamch, slansy ! .. ! .. External Subroutines .. EXTERNAL slacpy, ssycon, ssyrfs, ssytrf, ssytrs, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 nofact = lsame( fact, 'N' ) lquery = ( lwork == -1 ) IF( .NOT.nofact .AND. .NOT.lsame( fact, 'F' ) ) THEN info = -1 ELSE IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) & THEN info = -2 ELSE IF( n < 0 ) THEN info = -3 ELSE IF( nrhs < 0 ) THEN info = -4 ELSE IF( lda < MAX( 1, n ) ) THEN info = -6 ELSE IF( ldaf < MAX( 1, n ) ) THEN info = -8 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -11 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -13 ELSE IF( lwork < MAX( 1, 3*n ) .AND. .NOT.lquery ) THEN info = -18 END IF ! IF( info == 0 ) THEN nb = ilaenv( 1, 'SSYTRF', uplo, n, -1, -1, -1 ) lwkopt = n*nb work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSYSVX', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! IF( nofact ) THEN ! ! Compute the factorization A = U*D*U' or A = L*D*L'. ! CALL slacpy( uplo, n, n, a, lda, af, ldaf ) CALL ssytrf( uplo, n, af, ldaf, ipiv, work, lwork, info ) ! ! Return if INFO is non-zero. ! IF( info /= 0 ) THEN IF( info > 0 ) rcond = zero RETURN END IF END IF ! ! Compute the norm of the matrix A. ! anorm = slansy( 'I', uplo, n, a, lda, work ) ! ! Compute the reciprocal of the condition number of A. ! CALL ssycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work, iwork, info ) ! ! Set INFO = N+1 if the matrix is singular to working precision. ! IF( rcond < slamch( 'Epsilon' ) ) info = n + 1 ! ! Compute the solution vectors X. ! CALL slacpy( 'Full', n, nrhs, b, ldb, x, ldx ) CALL ssytrs( uplo, n, nrhs, af, ldaf, ipiv, x, ldx, info ) ! ! Use iterative refinement to improve the computed solutions and ! compute error bounds and backward error estimates for them. ! CALL ssyrfs( uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, & ldx, ferr, berr, work, iwork, info ) ! RETURN ! ! End of SSYSVX ! END SUBROUTINE ssysvx SUBROUTINE ssytd2( 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: d( * ) REAL, INTENT(OUT) :: e( * ) REAL, INTENT(IN OUT) :: tau( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYTD2 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) REAL 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) REAL array, dimension (N) ! The diagonal elements of the tridiagonal matrix T: ! D(i) = A(i,i). ! ! E (output) REAL 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) REAL 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 .. REAL, PARAMETER :: one = 1.0 REAL, PARAMETER :: zero = 0.0 REAL, PARAMETER :: half = 1.0 / 2.0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: i REAL :: alpha, taui ! .. ! .. External Subroutines .. EXTERNAL saxpy, slarfg, ssymv, ssyr2, xerbla ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: sdot EXTERNAL lsame, sdot ! .. ! .. 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 < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, n ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSYTD2', -info ) RETURN END IF ! ! Quick return if possible ! IF( n <= 0 ) RETURN ! IF( upper ) THEN ! ! Reduce the upper triangle of A ! DO i = n - 1, 1, -1 ! ! Generate elementary reflector H(i) = I - tau * v * v' ! to annihilate A(1:i-1,i+1) ! CALL slarfg( i, a( i, i+1 ), a( 1, i+1 ), 1, taui ) e( i ) = a( i, i+1 ) ! IF( taui /= 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 ssymv( 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*sdot( i, tau, 1, a( 1, i+1 ), 1 ) CALL saxpy( i, alpha, a( 1, i+1 ), 1, tau, 1 ) ! ! Apply the transformation as a rank-2 update: ! A := A - v * w' - w * v' ! CALL ssyr2( 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 END DO d( 1 ) = a( 1, 1 ) ELSE ! ! Reduce the lower triangle of A ! DO i = 1, n - 1 ! ! Generate elementary reflector H(i) = I - tau * v * v' ! to annihilate A(i+2:n,i) ! CALL slarfg( n-i, a( i+1, i ), a( MIN( i+2, n ), i ), 1, taui ) e( i ) = a( i+1, i ) ! IF( taui /= 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 ssymv( 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*sdot( n-i, tau( i ), 1, a( i+1, i ), 1 ) CALL saxpy( 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 ssyr2( 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 END DO d( n ) = a( n, n ) END IF ! RETURN ! ! End of SSYTD2 ! END SUBROUTINE ssytd2 SUBROUTINE ssytf2( 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN) :: lda INTEGER, INTENT(OUT) :: ipiv( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYTF2 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) REAL 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 .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: eight = 8.0E+0 REAL, PARAMETER :: sevten = 17.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: i, imax, j, jmax, k, kk, kp, kstep REAL :: absakk, alpha, colmax, d11, d12, d21, d22, r1, & rowmax, t, wk, wkm1, wkp1 ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: isamax EXTERNAL lsame, isamax ! .. ! .. External Subroutines .. EXTERNAL sscal, sswap, ssyr, 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 < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, n ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSYTF2', -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 < 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 > 1 ) THEN imax = isamax( k-1, a( 1, k ), 1 ) colmax = ABS( a( imax, k ) ) ELSE colmax = zero END IF ! IF( MAX( absakk, colmax ) == zero ) THEN ! ! Column K is zero: set INFO and continue ! IF( info == 0 ) info = k kp = k ELSE IF( absakk >= 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 + isamax( k-imax, a( imax, imax+1 ), lda ) rowmax = ABS( a( imax, jmax ) ) IF( imax > 1 ) THEN jmax = isamax( imax-1, a( 1, imax ), 1 ) rowmax = MAX( rowmax, ABS( a( jmax, imax ) ) ) END IF ! IF( absakk >= alpha*colmax*( colmax / rowmax ) ) THEN ! ! no interchange, use 1-by-1 pivot block ! kp = k ELSE IF( ABS( a( imax, imax ) ) >= 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 /= kk ) THEN ! ! Interchange rows and columns KK and KP in the leading ! submatrix A(1:k,1:k) ! CALL sswap( kp-1, a( 1, kk ), 1, a( 1, kp ), 1 ) CALL sswap( 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 == 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 == 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 ssyr( uplo, k-1, -r1, a( 1, k ), 1, a, lda ) ! ! Store U(k) in column k ! CALL sscal( 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 > 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 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 i = j, 1, -1 a( i, j ) = a( i, j ) - a( i, k )*wk - a( i, k-1 )*wkm1 END DO a( j, k ) = wk a( j, k-1 ) = wkm1 END DO ! END IF ! END IF END IF ! ! Store details of the interchanges in IPIV ! IF( kstep == 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 > 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 < n ) THEN imax = k + isamax( n-k, a( k+1, k ), 1 ) colmax = ABS( a( imax, k ) ) ELSE colmax = zero END IF ! IF( MAX( absakk, colmax ) == zero ) THEN ! ! Column K is zero: set INFO and continue ! IF( info == 0 ) info = k kp = k ELSE IF( absakk >= 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 + isamax( imax-k, a( imax, k ), lda ) rowmax = ABS( a( imax, jmax ) ) IF( imax < n ) THEN jmax = imax + isamax( n-imax, a( imax+1, imax ), 1 ) rowmax = MAX( rowmax, ABS( a( jmax, imax ) ) ) END IF ! IF( absakk >= alpha*colmax*( colmax / rowmax ) ) THEN ! ! no interchange, use 1-by-1 pivot block ! kp = k ELSE IF( ABS( a( imax, imax ) ) >= 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 /= kk ) THEN ! ! Interchange rows and columns KK and KP in the trailing ! submatrix A(k:n,k:n) ! IF( kp < n ) CALL sswap( n-kp, a( kp+1, kk ), 1, a( kp+1, kp ), 1 ) CALL sswap( 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 == 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 == 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 < 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 ssyr( uplo, n-k, -d11, a( k+1, k ), 1, a( k+1, k+1 ), lda ) ! ! Store L(k) in column K ! CALL sscal( n-k, d11, a( k+1, k ), 1 ) END IF ELSE ! ! 2-by-2 pivot block D(k) ! IF( k < 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 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 i = j, n a( i, j ) = a( i, j ) - a( i, k )*wk - a( i, k+1 )*wkp1 END DO ! a( j, k ) = wk a( j, k+1 ) = wkp1 ! END DO END IF END IF END IF ! ! Store details of the interchanges in IPIV ! IF( kstep == 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 SSYTF2 ! END SUBROUTINE ssytf2 SUBROUTINE ssytrd( 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: d( * ) REAL, INTENT(IN) :: e( * ) REAL, INTENT(IN OUT) :: tau( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYTRD 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) REAL 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) REAL array, dimension (N) ! The diagonal elements of the tridiagonal matrix T: ! D(i) = A(i,i). ! ! E (output) REAL 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) REAL array, dimension (N-1) ! The scalar factors of the elementary reflectors (see Further ! Details). ! ! WORK (workspace/output) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, upper INTEGER :: i, iinfo, iws, j, kk, ldwork, lwkopt, nb, nbmin, nx ! .. ! .. External Subroutines .. EXTERNAL slatrd, ssyr2k, ssytd2, 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 == -1 ) IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, n ) ) THEN info = -4 ELSE IF( lwork < 1 .AND. .NOT.lquery ) THEN info = -9 END IF ! IF( info == 0 ) THEN ! ! Determine the block size. ! nb = ilaenv( 1, 'SSYTRD', uplo, n, -1, -1, -1 ) lwkopt = n*nb work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSYTRD', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) THEN work( 1 ) = 1 RETURN END IF ! nx = n iws = 1 IF( nb > 1 .AND. nb < 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, 'SSYTRD', uplo, n, -1, -1, -1 ) ) IF( nx < n ) THEN ! ! Determine if workspace is large enough for blocked code. ! ldwork = n iws = ldwork*nb IF( lwork < 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, 'SSYTRD', uplo, n, -1, -1, -1 ) IF( nb < 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 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 slatrd( 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 ssyr2k( 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 j = i, i + nb - 1 a( j-1, j ) = e( j-1 ) d( j ) = a( j, j ) END DO END DO ! ! Use unblocked code to reduce the last or only block ! CALL ssytd2( uplo, kk, a, lda, d, e, tau, iinfo ) ELSE ! ! Reduce the lower triangle of A ! DO 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 slatrd( 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 ssyr2k( 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 j = i, i + nb - 1 a( j+1, j ) = e( j ) d( j ) = a( j, j ) END DO END DO ! ! Use unblocked code to reduce the last or only block ! CALL ssytd2( uplo, n-i+1, a( i, i ), lda, d( i ), e( i ), tau( i ), iinfo ) END IF ! work( 1 ) = lwkopt RETURN ! ! End of SSYTRD ! END SUBROUTINE ssytrd SUBROUTINE ssytrf( 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(IN OUT) :: ipiv( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYTRF 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) REAL 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) REAL 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 slasyf, ssytf2, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 upper = lsame( uplo, 'U' ) lquery = ( lwork == -1 ) IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, n ) ) THEN info = -4 ELSE IF( lwork < 1 .AND. .NOT.lquery ) THEN info = -7 END IF ! IF( info == 0 ) THEN ! ! Determine the block size ! nb = ilaenv( 1, 'SSYTRF', uplo, n, -1, -1, -1 ) lwkopt = n*nb work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'SSYTRF', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! nbmin = 2 ldwork = n IF( nb > 1 .AND. nb < n ) THEN iws = ldwork*nb IF( lwork < iws ) THEN nb = MAX( lwork / ldwork, 1 ) nbmin = MAX( 2, ilaenv( 2, 'SSYTRF', uplo, n, -1, -1, -1 ) ) END IF ELSE iws = 1 END IF IF( nb < 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 SLASYF; ! 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 < 1 ) GO TO 40 ! IF( k > nb ) THEN ! ! Factorize columns k-kb+1:k of A and use blocked code to ! update columns 1:k-kb ! CALL slasyf( uplo, k, nb, kb, a, lda, ipiv, work, ldwork, iinfo ) ELSE ! ! Use unblocked code to factorize columns 1:k of A ! CALL ssytf2( uplo, k, a, lda, ipiv, iinfo ) kb = k END IF ! ! Set INFO on the first occurrence of a zero pivot ! IF( info == 0 .AND. iinfo > 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 SLASYF; ! 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 > n ) GO TO 40 ! IF( k <= n-nb ) THEN ! ! Factorize columns k:k+kb-1 of A and use blocked code to ! update columns k+kb:n ! CALL slasyf( 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 ssytf2( 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 == 0 .AND. iinfo > 0 ) info = iinfo + k - 1 ! ! Adjust IPIV ! DO j = k, k + kb - 1 IF( ipiv( j ) > 0 ) THEN ipiv( j ) = ipiv( j ) + k - 1 ELSE ipiv( j ) = ipiv( j ) - k + 1 END IF END DO ! ! 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 SSYTRF ! END SUBROUTINE ssytrf SUBROUTINE ssytri( 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(IN) :: ipiv( * ) REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYTRI 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 ! SSYTRF. ! ! 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) REAL 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 SSYTRF. ! ! 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 SSYTRF. ! ! WORK (workspace) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: k, kp, kstep REAL :: ak, akkp1, akp1, d, t, temp ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: sdot EXTERNAL lsame, sdot ! .. ! .. External Subroutines .. EXTERNAL scopy, sswap, ssymv, 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 < 0 ) THEN info = -2 ELSE IF( lda < MAX( 1, n ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSYTRI', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Check that the diagonal matrix D is nonsingular. ! IF( upper ) THEN ! ! Upper triangular storage: examine D from bottom to top ! DO info = n, 1, -1 IF( ipiv( info ) > 0 .AND. a( info, info ) == zero ) RETURN END DO ELSE ! ! Lower triangular storage: examine D from top to bottom. ! DO info = 1, n IF( ipiv( info ) > 0 .AND. a( info, info ) == zero ) RETURN END DO 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 > n ) GO TO 40 ! IF( ipiv( k ) > 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 > 1 ) THEN CALL scopy( k-1, a( 1, k ), 1, work, 1 ) CALL ssymv( uplo, k-1, -one, a, lda, work, 1, zero, a( 1, k ), 1 ) a( k, k ) = a( k, k ) - sdot( 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 > 1 ) THEN CALL scopy( k-1, a( 1, k ), 1, work, 1 ) CALL ssymv( uplo, k-1, -one, a, lda, work, 1, zero, a( 1, k ), 1 ) a( k, k ) = a( k, k ) - sdot( k-1, work, 1, a( 1, k ), 1 ) a( k, k+1 ) = a( k, k+1 ) - sdot( k-1, a( 1, k ), 1, a( 1, k+1 ), 1 ) CALL scopy( k-1, a( 1, k+1 ), 1, work, 1 ) CALL ssymv( uplo, k-1, -one, a, lda, work, 1, zero, a( 1, k+1 ), 1 ) a( k+1, k+1 ) = a( k+1, k+1 ) - sdot( k-1, work, 1, a( 1, k+1 ), 1 ) END IF kstep = 2 END IF ! kp = ABS( ipiv( k ) ) IF( kp /= k ) THEN ! ! Interchange rows and columns K and KP in the leading ! submatrix A(1:k+1,1:k+1) ! CALL sswap( kp-1, a( 1, k ), 1, a( 1, kp ), 1 ) CALL sswap( 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 == 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 < 1 ) GO TO 60 ! IF( ipiv( k ) > 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 < n ) THEN CALL scopy( n-k, a( k+1, k ), 1, work, 1 ) CALL ssymv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1, & zero, a( k+1, k ), 1 ) a( k, k ) = a( k, k ) - sdot( 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 < n ) THEN CALL scopy( n-k, a( k+1, k ), 1, work, 1 ) CALL ssymv( uplo, n-k, -one, a( k+1, k+1 ), lda, work, 1, & zero, a( k+1, k ), 1 ) a( k, k ) = a( k, k ) - sdot( n-k, work, 1, a( k+1, k ), 1 ) a( k, k-1 ) = a( k, k-1 ) - sdot( n-k, a( k+1, k ), 1, a( k+1, k-1 ), & 1 ) CALL scopy( n-k, a( k+1, k-1 ), 1, work, 1 ) CALL ssymv( 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 ) - sdot( n-k, work, 1, a( k+1, k-1 ), 1 ) END IF kstep = 2 END IF ! kp = ABS( ipiv( k ) ) IF( kp /= k ) THEN ! ! Interchange rows and columns K and KP in the trailing ! submatrix A(k-1:n,k-1:n) ! IF( kp < n ) CALL sswap( n-kp, a( kp+1, k ), 1, a( kp+1, kp ), 1 ) CALL sswap( 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 == 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 SSYTRI ! END SUBROUTINE ssytri SUBROUTINE ssytrs( uplo, 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 (LEN=1), INTENT(IN) :: uplo INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(IN) :: ipiv( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! SSYTRS solves a system of linear equations A*X = B with a real ! symmetric matrix A using the factorization A = U*D*U**T or ! A = L*D*L**T computed by SSYTRF. ! ! 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. ! ! A (input) REAL array, dimension (LDA,N) ! The block diagonal matrix D and the multipliers used to ! obtain the factor U or L as computed by SSYTRF. ! ! 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 SSYTRF. ! ! B (input/output) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: upper INTEGER :: j, k, kp REAL :: ak, akm1, akm1k, bk, bkm1, denom ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL sgemv, sger, sscal, sswap, 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 < 0 ) THEN info = -2 ELSE IF( nrhs < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -8 END IF IF( info /= 0 ) THEN CALL xerbla( 'SSYTRS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 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 10 CONTINUE ! ! If K < 1, exit from loop. ! IF( k < 1 ) GO TO 30 ! IF( ipiv( k ) > 0 ) THEN ! ! 1 x 1 diagonal block ! ! Interchange rows K and IPIV(K). ! kp = ipiv( k ) IF( kp /= k ) CALL sswap( 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 sger( k-1, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb, b( 1, 1 ), ldb ) ! ! Multiply by the inverse of the diagonal block. ! CALL sscal( nrhs, one / a( k, k ), 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 /= k-1 ) CALL sswap( 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 sger( k-2, nrhs, -one, a( 1, k ), 1, b( k, 1 ), ldb, b( 1, 1 ), ldb ) CALL sger( k-2, nrhs, -one, a( 1, k-1 ), 1, b( k-1, 1 ), & ldb, b( 1, 1 ), ldb ) ! ! Multiply by the inverse of the diagonal block. ! akm1k = a( k-1, k ) akm1 = a( k-1, k-1 ) / akm1k ak = a( k, k ) / akm1k denom = akm1*ak - one DO 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 END DO 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 40 CONTINUE ! ! If K > N, exit from loop. ! IF( k > n ) GO TO 50 ! IF( ipiv( k ) > 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 sgemv( 'Transpose', k-1, nrhs, -one, b, ldb, a( 1, k ), & 1, one, b( k, 1 ), ldb ) ! ! Interchange rows K and IPIV(K). ! kp = ipiv( k ) IF( kp /= k ) CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) 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 sgemv( 'Transpose', k-1, nrhs, -one, b, ldb, a( 1, k ), & 1, one, b( k, 1 ), ldb ) CALL sgemv( 'Transpose', k-1, nrhs, -one, b, ldb, & a( 1, k+1 ), 1, one, b( k+1, 1 ), ldb ) ! ! Interchange rows K and -IPIV(K). ! kp = -ipiv( k ) IF( kp /= k ) CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) 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 60 CONTINUE ! ! If K > N, exit from loop. ! IF( k > n ) GO TO 80 ! IF( ipiv( k ) > 0 ) THEN ! ! 1 x 1 diagonal block ! ! Interchange rows K and IPIV(K). ! kp = ipiv( k ) IF( kp /= k ) CALL sswap( 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 < n ) CALL sger( n-k, nrhs, -one, a( k+1, k ), 1, b( k, 1 ), & ldb, b( k+1, 1 ), ldb ) ! ! Multiply by the inverse of the diagonal block. ! CALL sscal( nrhs, one / a( k, k ), 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 /= k+1 ) CALL sswap( 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 < n-1 ) THEN CALL sger( n-k-1, nrhs, -one, a( k+2, k ), 1, b( k, 1 ), & ldb, b( k+2, 1 ), ldb ) CALL sger( n-k-1, nrhs, -one, a( k+2, k+1 ), 1, & b( k+1, 1 ), ldb, b( k+2, 1 ), ldb ) END IF ! ! Multiply by the inverse of the diagonal block. ! akm1k = a( k+1, k ) akm1 = a( k, k ) / akm1k ak = a( k+1, k+1 ) / akm1k denom = akm1*ak - one DO 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 END DO 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 90 CONTINUE ! ! If K < 1, exit from loop. ! IF( k < 1 ) GO TO 100 ! IF( ipiv( k ) > 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 < n ) CALL sgemv( 'Transpose', n-k, nrhs, -one, b( k+1, 1 ), & ldb, a( k+1, k ), 1, one, b( k, 1 ), ldb ) ! ! Interchange rows K and IPIV(K). ! kp = ipiv( k ) IF( kp /= k ) CALL sswap( 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 < n ) THEN CALL sgemv( 'Transpose', n-k, nrhs, -one, b( k+1, 1 ), & ldb, a( k+1, k ), 1, one, b( k, 1 ), ldb ) CALL sgemv( 'Transpose', n-k, nrhs, -one, b( k+1, 1 ), & ldb, a( k+1, k-1 ), 1, one, b( k-1, 1 ), ldb ) END IF ! ! Interchange rows K and -IPIV(K). ! kp = -ipiv( k ) IF( kp /= k ) CALL sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb ) k = k - 2 END IF ! GO TO 90 100 CONTINUE END IF ! RETURN ! ! End of SSYTRS ! END SUBROUTINE ssytrs SUBROUTINE stbcon( norm, uplo, diag, n, kd, ab, ldab, rcond, 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 ! March 31, 1993 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: norm CHARACTER (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: diag INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: kd REAL, INTENT(IN) :: ab( ldab, * ) INTEGER, INTENT(IN) :: ldab REAL, INTENT(OUT) :: rcond REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STBCON estimates the reciprocal of the condition number of a ! triangular band matrix A, in either the 1-norm or the infinity-norm. ! ! The norm of A is computed and an estimate is obtained for ! norm(inv(A)), then the reciprocal of the condition number is ! computed as ! RCOND = 1 / ( norm(A) * norm(inv(A)) ). ! ! Arguments ! ========= ! ! NORM (input) CHARACTER*1 ! Specifies whether the 1-norm condition number or the ! infinity-norm condition number is required: ! = '1' or 'O': 1-norm; ! = 'I': Infinity-norm. ! ! 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. ! ! KD (input) INTEGER ! The number of superdiagonals or subdiagonals of the ! triangular band matrix A. KD >= 0. ! ! AB (input) REAL array, dimension (LDAB,N) ! The upper or lower triangular band matrix A, stored in the ! first kd+1 rows of the array. The j-th column of A is stored ! in the j-th column of the array AB as follows: ! if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). ! If DIAG = 'U', the diagonal elements of A are not referenced ! and are assumed to be 1. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KD+1. ! ! RCOND (output) REAL ! The reciprocal of the condition number of the matrix A, ! computed as RCOND = 1/(norm(A) * norm(inv(A))). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: nounit, onenrm, upper CHARACTER (LEN=1) :: normin INTEGER :: ix, kase, kase1 REAL :: ainvnm, anorm, scale, smlnum, xnorm ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: isamax REAL :: slamch, slantb EXTERNAL lsame, isamax, slamch, slantb ! .. ! .. External Subroutines .. EXTERNAL slacon, slatbs, srscl, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, REAL ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 upper = lsame( uplo, 'U' ) onenrm = norm == '1' .OR. lsame( norm, 'O' ) nounit = lsame( diag, 'N' ) ! IF( .NOT.onenrm .AND. .NOT.lsame( norm, 'I' ) ) THEN info = -1 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -2 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( kd < 0 ) THEN info = -5 ELSE IF( ldab < kd+1 ) THEN info = -7 END IF IF( info /= 0 ) THEN CALL xerbla( 'STBCON', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) THEN rcond = one RETURN END IF ! rcond = zero smlnum = slamch( 'Safe minimum' )*REAL( MAX( 1, n ) ) ! ! Compute the norm of the triangular matrix A. ! anorm = slantb( norm, uplo, diag, n, kd, ab, ldab, work ) ! ! Continue only if ANORM > 0. ! IF( anorm > zero ) THEN ! ! Estimate the norm of the inverse of A. ! ainvnm = zero normin = 'N' IF( onenrm ) THEN kase1 = 1 ELSE kase1 = 2 END IF kase = 0 10 CONTINUE CALL slacon( n, work( n+1 ), work, iwork, ainvnm, kase ) IF( kase /= 0 ) THEN IF( kase == kase1 ) THEN ! ! Multiply by inv(A). ! CALL slatbs( uplo, 'No transpose', diag, normin, n, kd, & ab, ldab, work, scale, work( 2*n+1 ), info ) ELSE ! ! Multiply by inv(A'). ! CALL slatbs( uplo, 'Transpose', diag, normin, n, kd, ab, & ldab, work, scale, work( 2*n+1 ), info ) END IF normin = 'Y' ! ! Multiply by 1/SCALE if doing so will not cause overflow. ! IF( scale /= one ) THEN ix = isamax( n, work, 1 ) xnorm = ABS( work( ix ) ) IF( scale < xnorm*smlnum .OR. scale == zero ) GO TO 20 CALL srscl( n, scale, work, 1 ) END IF GO TO 10 END IF ! ! Compute the estimate of the reciprocal condition number. ! IF( ainvnm /= zero ) rcond = ( one / anorm ) / ainvnm END IF ! 20 CONTINUE RETURN ! ! End of STBCON ! END SUBROUTINE stbcon SUBROUTINE stbrfs( uplo, trans, diag, n, kd, nrhs, ab, ldab, b, & ldb, x, ldx, ferr, berr, 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 ! September 30, 1994 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: trans CHARACTER (LEN=1), INTENT(IN) :: diag INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: kd INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: ferr( * ) REAL, INTENT(OUT) :: berr( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STBRFS provides error bounds and backward error estimates for the ! solution to a system of linear equations with a triangular band ! coefficient matrix. ! ! The solution matrix X must be computed by STBTRS or some other ! means before entering this routine. STBRFS does not do iterative ! refinement because doing so cannot improve the backward error. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! = 'U': A is upper triangular; ! = 'L': A is lower triangular. ! ! 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 = Transpose) ! ! 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. ! ! KD (input) INTEGER ! The number of superdiagonals or subdiagonals of the ! triangular band matrix A. KD >= 0. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of columns ! of the matrices B and X. NRHS >= 0. ! ! AB (input) REAL array, dimension (LDAB,N) ! The upper or lower triangular band matrix A, stored in the ! first kd+1 rows of the array. The j-th column of A is stored ! in the j-th column of the array AB as follows: ! if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). ! If DIAG = 'U', the diagonal elements of A are not referenced ! and are assumed to be 1. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KD+1. ! ! B (input) REAL array, dimension (LDB,NRHS) ! The right hand side matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (input) REAL array, dimension (LDX,NRHS) ! The solution matrix X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: notran, nounit, upper CHARACTER (LEN=1) :: transt INTEGER :: i, j, k, kase, nz REAL :: eps, lstres, s, safe1, safe2, safmin, xk ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, slacon, stbmv, stbsv, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 upper = lsame( uplo, 'U' ) notran = lsame( trans, 'N' ) nounit = lsame( diag, 'N' ) ! IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -1 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT. & lsame( trans, 'C' ) ) THEN info = -2 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( kd < 0 ) THEN info = -5 ELSE IF( nrhs < 0 ) THEN info = -6 ELSE IF( ldab < kd+1 ) THEN info = -8 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -10 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -12 END IF IF( info /= 0 ) THEN CALL xerbla( 'STBRFS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) THEN DO j = 1, nrhs ferr( j ) = zero berr( j ) = zero END DO RETURN END IF ! IF( notran ) THEN transt = 'T' ELSE transt = 'N' END IF ! ! NZ = maximum number of nonzero elements in each row of A, plus 1 ! nz = kd + 2 eps = slamch( 'Epsilon' ) safmin = slamch( 'Safe minimum' ) safe1 = nz*safmin safe2 = safe1 / eps ! ! Do for each right hand side ! DO j = 1, nrhs ! ! Compute residual R = B - op(A) * X, ! where op(A) = A or A', depending on TRANS. ! CALL scopy( n, x( 1, j ), 1, work( n+1 ), 1 ) CALL stbmv( uplo, trans, diag, n, kd, ab, ldab, work( n+1 ), 1 ) CALL saxpy( n, -one, b( 1, j ), 1, work( n+1 ), 1 ) ! ! Compute componentwise relative backward error from formula ! ! max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) ! ! where abs(Z) is the componentwise absolute value of the matrix ! or vector Z. If the i-th component of the denominator is less ! than SAFE2, then SAFE1 is added to the i-th components of the ! numerator and denominator before dividing. ! DO i = 1, n work( i ) = ABS( b( i, j ) ) END DO ! IF( notran ) THEN ! ! Compute abs(A)*abs(X) + abs(B). ! IF( upper ) THEN IF( nounit ) THEN DO k = 1, n xk = ABS( x( k, j ) ) DO i = MAX( 1, k-kd ), k work( i ) = work( i ) + ABS( ab( kd+1+i-k, k ) )*xk END DO END DO ELSE DO k = 1, n xk = ABS( x( k, j ) ) DO i = MAX( 1, k-kd ), k - 1 work( i ) = work( i ) + ABS( ab( kd+1+i-k, k ) )*xk END DO work( k ) = work( k ) + xk END DO END IF ELSE IF( nounit ) THEN DO k = 1, n xk = ABS( x( k, j ) ) DO i = k, MIN( n, k+kd ) work( i ) = work( i ) + ABS( ab( 1+i-k, k ) )*xk END DO END DO ELSE DO k = 1, n xk = ABS( x( k, j ) ) DO i = k + 1, MIN( n, k+kd ) work( i ) = work( i ) + ABS( ab( 1+i-k, k ) )*xk END DO work( k ) = work( k ) + xk END DO END IF END IF ELSE ! ! Compute abs(A')*abs(X) + abs(B). ! IF( upper ) THEN IF( nounit ) THEN DO k = 1, n s = zero DO i = MAX( 1, k-kd ), k s = s + ABS( ab( kd+1+i-k, k ) )* ABS( x( i, j ) ) END DO work( k ) = work( k ) + s END DO ELSE DO k = 1, n s = ABS( x( k, j ) ) DO i = MAX( 1, k-kd ), k - 1 s = s + ABS( ab( kd+1+i-k, k ) )* ABS( x( i, j ) ) END DO work( k ) = work( k ) + s END DO END IF ELSE IF( nounit ) THEN DO k = 1, n s = zero DO i = k, MIN( n, k+kd ) s = s + ABS( ab( 1+i-k, k ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + s END DO ELSE DO k = 1, n s = ABS( x( k, j ) ) DO i = k + 1, MIN( n, k+kd ) s = s + ABS( ab( 1+i-k, k ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + s END DO END IF END IF END IF s = zero DO i = 1, n IF( work( i ) > safe2 ) THEN s = MAX( s, ABS( work( n+i ) ) / work( i ) ) ELSE s = MAX( s, ( ABS( work( n+i ) )+safe1 ) / ( work( i )+safe1 ) ) END IF END DO berr( j ) = s ! ! Bound error from formula ! ! norm(X - XTRUE) / norm(X) .le. FERR = ! norm( abs(inv(op(A)))* ! ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) ! ! where ! norm(Z) is the magnitude of the largest component of Z ! inv(op(A)) is the inverse of op(A) ! abs(Z) is the componentwise absolute value of the matrix or ! vector Z ! NZ is the maximum number of nonzeros in any row of A, plus 1 ! EPS is machine epsilon ! ! The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) ! is incremented by SAFE1 if the i-th component of ! abs(op(A))*abs(X) + abs(B) is less than SAFE2. ! ! Use SLACON to estimate the infinity-norm of the matrix ! inv(op(A)) * diag(W), ! where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) ! DO i = 1, n IF( work( i ) > safe2 ) THEN work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) ELSE work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) + safe1 END IF END DO ! kase = 0 210 CONTINUE CALL slacon( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ), kase ) IF( kase /= 0 ) THEN IF( kase == 1 ) THEN ! ! Multiply by diag(W)*inv(op(A)'). ! CALL stbsv( uplo, transt, diag, n, kd, ab, ldab, work( n+1 ), 1 ) DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO ELSE ! ! Multiply by inv(op(A))*diag(W). ! DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO CALL stbsv( uplo, trans, diag, n, kd, ab, ldab, work( n+1 ), 1 ) END IF GO TO 210 END IF ! ! Normalize error. ! lstres = zero DO i = 1, n lstres = MAX( lstres, ABS( x( i, j ) ) ) END DO IF( lstres /= zero ) ferr( j ) = ferr( j ) / lstres ! END DO ! RETURN ! ! End of STBRFS ! END SUBROUTINE stbrfs SUBROUTINE stbtrs( uplo, trans, diag, n, kd, nrhs, ab, ldab, 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 (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN OUT) :: trans CHARACTER (LEN=1), INTENT(IN) :: diag INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: kd INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: ab( ldab, * ) INTEGER, INTENT(IN OUT) :: ldab REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STBTRS solves a triangular system of the form ! ! A * X = B or A**T * X = B, ! ! where A is a triangular band matrix of order N, and B is an ! N-by NRHS matrix. A check is made to verify that A is nonsingular. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! = 'U': A is upper triangular; ! = 'L': A is lower triangular. ! ! TRANS (input) CHARACTER*1 ! Specifies the form the system of equations: ! = 'N': A * X = B (No transpose) ! = 'T': A**T * X = B (Transpose) ! = 'C': A**H * X = B (Conjugate transpose = Transpose) ! ! 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. ! ! KD (input) INTEGER ! The number of superdiagonals or subdiagonals of the ! triangular band matrix A. KD >= 0. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of columns ! of the matrix B. NRHS >= 0. ! ! AB (input) REAL array, dimension (LDAB,N) ! The upper or lower triangular band matrix A, stored in the ! first kd+1 rows of AB. The j-th column of A is stored ! in the j-th column of the array AB as follows: ! if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; ! if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). ! If DIAG = 'U', the diagonal elements of A are not referenced ! and are assumed to be 1. ! ! LDAB (input) INTEGER ! The leading dimension of the array AB. LDAB >= KD+1. ! ! B (input/output) REAL array, dimension (LDB,NRHS) ! On entry, the right hand side matrix B. ! On exit, if INFO = 0, 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 ! > 0: if INFO = i, the i-th diagonal element of A is zero, ! indicating that the matrix is singular and the ! solutions X have not been computed. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: nounit, upper INTEGER :: j ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL stbsv, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 nounit = lsame( diag, 'N' ) upper = lsame( uplo, 'U' ) IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -1 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT. & lsame( trans, 'T' ) .AND. .NOT.lsame( trans, 'C' ) ) THEN info = -2 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( kd < 0 ) THEN info = -5 ELSE IF( nrhs < 0 ) THEN info = -6 ELSE IF( ldab < kd+1 ) THEN info = -8 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -10 END IF IF( info /= 0 ) THEN CALL xerbla( 'STBTRS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Check for singularity. ! IF( nounit ) THEN IF( upper ) THEN DO info = 1, n IF( ab( kd+1, info ) == zero ) RETURN END DO ELSE DO info = 1, n IF( ab( 1, info ) == zero ) RETURN END DO END IF END IF info = 0 ! ! Solve A * X = B or A' * X = B. ! DO j = 1, nrhs CALL stbsv( uplo, trans, diag, n, kd, ab, ldab, b( 1, j ), 1 ) END DO ! RETURN ! ! End of STBTRS ! END SUBROUTINE stbtrs SUBROUTINE stgevc( side, howmny, select, n, a, lda, b, ldb, vl, & ldvl, vr, ldvr, mm, m, 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 .. CHARACTER (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: howmny LOGICAL, INTENT(IN) :: select( * ) INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(OUT) :: vl( ldvl, * ) INTEGER, INTENT(IN OUT) :: ldvl REAL, INTENT(OUT) :: vr( ldvr, * ) INTEGER, INTENT(IN OUT) :: ldvr INTEGER, INTENT(IN OUT) :: mm INTEGER, INTENT(OUT) :: m REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! ! Purpose ! ======= ! ! STGEVC computes some or all of the right and/or left generalized ! eigenvectors of a pair of real upper triangular matrices (A,B). ! ! The right generalized eigenvector x and the left generalized ! eigenvector y of (A,B) corresponding to a generalized eigenvalue ! w are defined by: ! ! (A - wB) * x = 0 and y**H * (A - wB) = 0 ! ! where y**H denotes the conjugate tranpose of y. ! ! If an eigenvalue w is determined by zero diagonal elements of both A ! and B, a unit vector is returned as the corresponding eigenvector. ! ! If all eigenvectors are requested, the routine may either return ! the matrices X and/or Y of right or left eigenvectors of (A,B), or ! the products Z*X and/or Q*Y, where Z and Q are input orthogonal ! matrices. If (A,B) was obtained from the generalized real-Schur ! factorization of an original pair of matrices ! (A0,B0) = (Q*A*Z**H,Q*B*Z**H), ! then Z*X and Q*Y are the matrices of right or left eigenvectors of ! A. ! ! A must be block upper triangular, with 1-by-1 and 2-by-2 diagonal ! blocks. Corresponding to each 2-by-2 diagonal block is a complex ! conjugate pair of eigenvalues and eigenvectors; only one ! eigenvector of the pair is computed, namely the one corresponding ! to the eigenvalue with positive imaginary part. ! ! Arguments ! ========= ! ! SIDE (input) CHARACTER*1 ! = 'R': compute right eigenvectors only; ! = 'L': compute left eigenvectors only; ! = 'B': compute both right and left eigenvectors. ! ! HOWMNY (input) CHARACTER*1 ! = 'A': compute all right and/or left eigenvectors; ! = 'B': compute all right and/or left eigenvectors, and ! backtransform them using the input matrices supplied ! in VR and/or VL; ! = 'S': compute selected right and/or left eigenvectors, ! specified by the logical array SELECT. ! ! SELECT (input) LOGICAL array, dimension (N) ! If HOWMNY='S', SELECT specifies the eigenvectors to be ! computed. ! If HOWMNY='A' or 'B', SELECT is not referenced. ! To select the real eigenvector corresponding to the real ! eigenvalue w(j), SELECT(j) must be set to .TRUE. To select ! the complex eigenvector corresponding to a complex conjugate ! pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must ! be set to .TRUE.. ! ! N (input) INTEGER ! The order of the matrices A and B. N >= 0. ! ! A (input) REAL array, dimension (LDA,N) ! The upper quasi-triangular matrix A. ! ! LDA (input) INTEGER ! The leading dimension of array A. LDA >= max(1, N). ! ! B (input) REAL array, dimension (LDB,N) ! The upper triangular matrix B. If A has a 2-by-2 diagonal ! block, then the corresponding 2-by-2 block of B must be ! diagonal with positive elements. ! ! LDB (input) INTEGER ! The leading dimension of array B. LDB >= max(1,N). ! ! VL (input/output) REAL 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 orthogonal matrix Q ! of left Schur vectors returned by SHGEQZ). ! 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. ! ! A complex eigenvector corresponding to a complex eigenvalue ! is stored in two consecutive columns, the first holding the ! real part, and the second the imaginary part. ! ! LDVL (input) INTEGER ! The leading dimension of array VL. ! LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. ! ! VR (input/output) REAL 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 orthogonal matrix Z ! of right Schur vectors returned by SHGEQZ). ! 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. ! ! A complex eigenvector corresponding to a complex eigenvalue ! is stored in two consecutive columns, the first holding the ! real part and the second the imaginary part. ! ! 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 real eigenvector occupies one ! column and each selected complex eigenvector occupies two ! columns. ! ! WORK (workspace) REAL array, dimension (6*N) ! ! INFO (output) INTEGER ! = 0: successful exit. ! < 0: if INFO = -i, the i-th argument had an illegal value. ! > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex ! eigenvalue. ! ! Further Details ! =============== ! ! Allocation of workspace: ! ---------- -- --------- ! ! WORK( j ) = 1-norm of j-th column of A, above the diagonal ! WORK( N+j ) = 1-norm of j-th column of B, above the diagonal ! WORK( 2*N+1:3*N ) = real part of eigenvector ! WORK( 3*N+1:4*N ) = imaginary part of eigenvector ! WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector ! WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector ! ! Rowwise vs. columnwise solution methods: ! ------- -- ---------- -------- ------- ! ! Finding a generalized eigenvector consists basically of solving the ! singular triangular system ! ! (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left) ! ! Consider finding the i-th right eigenvector (assume all eigenvalues ! are real). The equation to be solved is: ! n i ! 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1 ! k=j k=j ! ! where C = (A - w B) (The components v(i+1:n) are 0.) ! ! The "rowwise" method is: ! ! (1) v(i) := 1 ! for j = i-1,. . .,1: ! i ! (2) compute s = - sum C(j,k) v(k) and ! k=j+1 ! ! (3) v(j) := s / C(j,j) ! ! Step 2 is sometimes called the "dot product" step, since it is an ! inner product between the j-th row and the portion of the eigenvector ! that has been computed so far. ! ! The "columnwise" method consists basically in doing the sums ! for all the rows in parallel. As each v(j) is computed, the ! contribution of v(j) times the j-th column of C is added to the ! partial sums. Since FORTRAN arrays are stored columnwise, this has ! the advantage that at each step, the elements of C that are accessed ! are adjacent to one another, whereas with the rowwise method, the ! elements accessed at a step are spaced LDA (and LDB) words apart. ! ! When finding left eigenvectors, the matrix in question is the ! transpose of the one in storage, so the rowwise method then ! actually accesses columns of A and B at each step, and so is the ! preferred method. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: safety = 1.0E+2 ! .. ! .. Local Scalars .. LOGICAL :: compl, compr, il2by2, ilabad, ilall, ilback, & ilbbad, ilcomp, ilcplx, lsa, lsb INTEGER :: i, ibeg, ieig, iend, ihwmny, iinfo, im, iside, & j, ja, jc, je, jr, jw, na, nw REAL :: acoef, acoefa, anorm, ascale, bcoefa, bcoefi, & bcoefr, big, bignum, bnorm, bscale, cim2a, & cim2b, cimaga, cimagb, cre2a, cre2b, creala, & crealb, dmin, safmin, salfar, sbeta, scale, & small, temp, temp2, temp2i, temp2r, ulp, xmax, xscale ! .. ! .. Local Arrays .. REAL :: bdiag( 2 ), sum( 2, 2 ), suma( 2, 2 ), sumb( 2, 2 ) ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. External Subroutines .. EXTERNAL sgemv, slabad, slacpy, slag2, slaln2, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. 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 ilall = .true. 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 < 0 ) THEN info = -1 ELSE IF( ihwmny < 0 ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( lda < MAX( 1, n ) ) THEN info = -6 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -8 END IF IF( info /= 0 ) THEN CALL xerbla( 'STGEVC', -info ) RETURN END IF ! ! Count the number of eigenvectors to be computed ! IF( .NOT.ilall ) THEN im = 0 ilcplx = .false. DO j = 1, n IF( ilcplx ) THEN ilcplx = .false. CYCLE END IF IF( j < n ) THEN IF( a( j+1, j ) /= zero ) ilcplx = .true. END IF IF( ilcplx ) THEN IF( select( j ) .OR. select( j+1 ) ) im = im + 2 ELSE IF( select( j ) ) im = im + 1 END IF END DO ELSE im = n END IF ! ! Check 2-by-2 diagonal blocks of A, B ! ilabad = .false. ilbbad = .false. DO j = 1, n - 1 IF( a( j+1, j ) /= zero ) THEN IF( b( j, j ) == zero .OR. b( j+1, j+1 ) == zero .OR. & b( j, j+1 ) /= zero )ilbbad = .true. IF( j < n-1 ) THEN IF( a( j+2, j+1 ) /= zero ) ilabad = .true. END IF END IF END DO ! IF( ilabad ) THEN info = -5 ELSE IF( ilbbad ) THEN info = -7 ELSE IF( compl .AND. ldvl < n .OR. ldvl < 1 ) THEN info = -10 ELSE IF( compr .AND. ldvr < n .OR. ldvr < 1 ) THEN info = -12 ELSE IF( mm < im ) THEN info = -13 END IF IF( info /= 0 ) THEN CALL xerbla( 'STGEVC', -info ) RETURN END IF ! ! Quick return if possible ! m = im IF( n == 0 ) RETURN ! ! Machine Constants ! safmin = slamch( 'Safe minimum' ) big = one / safmin CALL slabad( safmin, big ) ulp = slamch( 'Epsilon' )*slamch( '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 (i.e., excluding all elements belonging to the diagonal ! blocks) of A and B to check for possible overflow in the ! triangular solver. ! anorm = ABS( a( 1, 1 ) ) IF( n > 1 ) anorm = anorm + ABS( a( 2, 1 ) ) bnorm = ABS( b( 1, 1 ) ) work( 1 ) = zero work( n+1 ) = zero ! DO j = 2, n temp = zero temp2 = zero IF( a( j, j-1 ) == zero ) THEN iend = j - 1 ELSE iend = j - 2 END IF DO i = 1, iend temp = temp + ABS( a( i, j ) ) temp2 = temp2 + ABS( b( i, j ) ) END DO work( j ) = temp work( n+j ) = temp2 DO i = iend + 1, MIN( j+1, n ) temp = temp + ABS( a( i, j ) ) temp2 = temp2 + ABS( b( i, j ) ) END DO anorm = MAX( anorm, temp ) bnorm = MAX( bnorm, temp2 ) END DO ! ascale = one / MAX( anorm, safmin ) bscale = one / MAX( bnorm, safmin ) ! ! Left eigenvectors ! IF( compl ) THEN ieig = 0 ! ! Main loop over eigenvalues ! ilcplx = .false. DO je = 1, n ! ! Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or ! (b) this would be the second of a complex pair. ! Check for complex eigenvalue, so as to be sure of which ! entry(-ies) of SELECT to look at. ! IF( ilcplx ) THEN ilcplx = .false. CYCLE END IF nw = 1 IF( je < n ) THEN IF( a( je+1, je ) /= zero ) THEN ilcplx = .true. nw = 2 END IF END IF IF( ilall ) THEN ilcomp = .true. ELSE IF( ilcplx ) THEN ilcomp = select( je ) .OR. select( je+1 ) ELSE ilcomp = select( je ) END IF IF( .NOT.ilcomp ) CYCLE ! ! Decide if (a) singular pencil, (b) real eigenvalue, or ! (c) complex eigenvalue. ! IF( .NOT.ilcplx ) THEN IF( ABS( a( je, je ) ) <= safmin .AND. & ABS( b( je, je ) ) <= safmin ) THEN ! ! Singular matrix pencil -- return unit eigenvector ! ieig = ieig + 1 DO jr = 1, n vl( jr, ieig ) = zero END DO vl( ieig, ieig ) = one CYCLE END IF END IF ! ! Clear vector ! DO jr = 1, nw*n work( 2*n+jr ) = zero END DO ! T ! Compute coefficients in ( a A - b B ) y = 0 ! a is ACOEF ! b is BCOEFR + i*BCOEFI ! IF( .NOT.ilcplx ) THEN ! ! Real eigenvalue ! temp = one / MAX( ABS( a( je, je ) )*ascale, & ABS( b( je, je ) )*bscale, safmin ) salfar = ( temp*a( je, je ) )*ascale sbeta = ( temp*b( je, je ) )*bscale acoef = sbeta*ascale bcoefr = salfar*bscale bcoefi = zero ! ! Scale to avoid underflow ! scale = one lsa = ABS( sbeta ) >= safmin .AND. ABS( acoef ) < small lsb = ABS( salfar ) >= safmin .AND. ABS( bcoefr ) < small IF( lsa ) scale = ( small / ABS( sbeta ) )*MIN( anorm, big ) IF( lsb ) scale = MAX( scale, ( small / ABS( salfar ) )* & MIN( bnorm, big ) ) IF( lsa .OR. lsb ) THEN scale = MIN( scale, one / ( safmin*MAX( one, ABS( acoef ), & ABS( bcoefr ) ) ) ) IF( lsa ) THEN acoef = ascale*( scale*sbeta ) ELSE acoef = scale*acoef END IF IF( lsb ) THEN bcoefr = bscale*( scale*salfar ) ELSE bcoefr = scale*bcoefr END IF END IF acoefa = ABS( acoef ) bcoefa = ABS( bcoefr ) ! ! First component is 1 ! work( 2*n+je ) = one xmax = one ELSE ! ! Complex eigenvalue ! CALL slag2( a( je, je ), lda, b( je, je ), ldb, & safmin*safety, acoef, temp, bcoefr, temp2, bcoefi ) bcoefi = -bcoefi IF( bcoefi == zero ) THEN info = je RETURN END IF ! ! Scale to avoid over/underflow ! acoefa = ABS( acoef ) bcoefa = ABS( bcoefr ) + ABS( bcoefi ) scale = one IF( acoefa*ulp < safmin .AND. acoefa >= safmin ) & scale = ( safmin / ulp ) / acoefa IF( bcoefa*ulp < safmin .AND. bcoefa >= safmin ) & scale = MAX( scale, ( safmin / ulp ) / bcoefa ) IF( safmin*acoefa > ascale ) scale = ascale / ( safmin*acoefa ) IF( safmin*bcoefa > bscale ) & scale = MIN( scale, bscale / ( safmin*bcoefa ) ) IF( scale /= one ) THEN acoef = scale*acoef acoefa = ABS( acoef ) bcoefr = scale*bcoefr bcoefi = scale*bcoefi bcoefa = ABS( bcoefr ) + ABS( bcoefi ) END IF ! ! Compute first two components of eigenvector ! temp = acoef*a( je+1, je ) temp2r = acoef*a( je, je ) - bcoefr*b( je, je ) temp2i = -bcoefi*b( je, je ) IF( ABS( temp ) > ABS( temp2r )+ABS( temp2i ) ) THEN work( 2*n+je ) = one work( 3*n+je ) = zero work( 2*n+je+1 ) = -temp2r / temp work( 3*n+je+1 ) = -temp2i / temp ELSE work( 2*n+je+1 ) = one work( 3*n+je+1 ) = zero temp = acoef*a( je, je+1 ) work( 2*n+je ) = ( bcoefr*b( je+1, je+1 )-acoef* & a( je+1, je+1 ) ) / temp work( 3*n+je ) = bcoefi*b( je+1, je+1 ) / temp END IF xmax = MAX( ABS( work( 2*n+je ) )+ABS( work( 3*n+je ) ), & ABS( work( 2*n+je+1 ) )+ABS( work( 3*n+je+1 ) ) ) END IF ! dmin = MAX( ulp*acoefa*anorm, ulp*bcoefa*bnorm, safmin ) ! ! T ! Triangular solve of (a A - b B) y = 0 ! ! T ! (rowwise in (a A - b B) , or columnwise in (a A - b B) ) ! il2by2 = .false. ! DO j = je + nw, n IF( il2by2 ) THEN il2by2 = .false. CYCLE END IF ! na = 1 bdiag( 1 ) = b( j, j ) IF( j < n ) THEN IF( a( j+1, j ) /= zero ) THEN il2by2 = .true. bdiag( 2 ) = b( j+1, j+1 ) na = 2 END IF END IF ! ! Check whether scaling is necessary for dot products ! xscale = one / MAX( one, xmax ) temp = MAX( work( j ), work( n+j ), & acoefa*work( j )+bcoefa*work( n+j ) ) IF( il2by2 ) temp = MAX( temp, work( j+1 ), work( n+j+1 ), & acoefa*work( j+1 )+bcoefa*work( n+j+1 ) ) IF( temp > bignum*xscale ) THEN DO jw = 0, nw - 1 DO jr = je, j - 1 work( ( jw+2 )*n+jr ) = xscale* work( ( jw+2 )*n+jr ) END DO END DO xmax = xmax*xscale END IF ! ! Compute dot products ! ! j-1 ! SUM = sum conjg( a*A(k,j) - b*B(k,j) )*x(k) ! k=je ! ! To reduce the op count, this is done as ! ! _ j-1 _ j-1 ! a*conjg( sum A(k,j)*x(k) ) - b*conjg( sum B(k,j)*x(k) ) ! k=je k=je ! ! which may cause underflow problems if A or B are close ! to underflow. (E.g., less than SMALL.) ! ! ! A series of compiler directives to defeat vectorization ! for the next loop ! !$PL$ CMCHAR=' ' !DIR$ NEXTSCALAR !$DIR SCALAR !DIR$ NEXT SCALAR !VD$L NOVECTOR !VD$ NOVECTOR !VDIR NOVECTOR !VOCL LOOP,SCALAR !IBM PREFER SCALAR !$PL$ CMCHAR='*' ! DO jw = 1, nw ! !$PL$ CMCHAR=' ' !DIR$ NEXTSCALAR !$DIR SCALAR !DIR$ NEXT SCALAR !VD$L NOVECTOR !VD$ NOVECTOR !VDIR NOVECTOR !VOCL LOOP,SCALAR !IBM PREFER SCALAR !$PL$ CMCHAR='*' ! DO ja = 1, na suma( ja, jw ) = zero sumb( ja, jw ) = zero ! DO jr = je, j - 1 suma( ja, jw ) = suma( ja, jw ) + a( jr, j+ja-1 )* & work( ( jw+1 )*n+jr ) sumb( ja, jw ) = sumb( ja, jw ) + b( jr, j+ja-1 )* & work( ( jw+1 )*n+jr ) END DO END DO END DO ! !$PL$ CMCHAR=' ' !DIR$ NEXTSCALAR !$DIR SCALAR !DIR$ NEXT SCALAR !VD$L NOVECTOR !VD$ NOVECTOR !VDIR NOVECTOR !VOCL LOOP,SCALAR !IBM PREFER SCALAR !$PL$ CMCHAR='*' ! DO ja = 1, na IF( ilcplx ) THEN sum( ja, 1 ) = -acoef*suma( ja, 1 ) + bcoefr*sumb( ja, 1 ) - & bcoefi*sumb( ja, 2 ) sum( ja, 2 ) = -acoef*suma( ja, 2 ) + bcoefr*sumb( ja, 2 ) + & bcoefi*sumb( ja, 1 ) ELSE sum( ja, 1 ) = -acoef*suma( ja, 1 ) + bcoefr*sumb( ja, 1 ) END IF END DO ! ! T ! Solve ( a A - b B ) y = SUM(,) ! with scaling and perturbation of the denominator ! CALL slaln2( .true., na, nw, dmin, acoef, a( j, j ), lda, & bdiag( 1 ), bdiag( 2 ), sum, 2, bcoefr, & bcoefi, work( 2*n+j ), n, scale, temp, iinfo ) IF( scale < one ) THEN DO jw = 0, nw - 1 DO jr = je, j - 1 work( ( jw+2 )*n+jr ) = scale* work( ( jw+2 )*n+jr ) END DO END DO xmax = scale*xmax END IF xmax = MAX( xmax, temp ) END DO ! ! Copy eigenvector to VL, back transforming if ! HOWMNY='B'. ! ieig = ieig + 1 IF( ilback ) THEN DO jw = 0, nw - 1 CALL sgemv( 'N', n, n+1-je, one, vl( 1, je ), ldvl, & work( ( jw+2 )*n+je ), 1, zero, work( ( jw+4 )*n+1 ), 1 ) END DO CALL slacpy( ' ', n, nw, work( 4*n+1 ), n, vl( 1, je ), ldvl ) ibeg = 1 ELSE CALL slacpy( ' ', n, nw, work( 2*n+1 ), n, vl( 1, ieig ), ldvl ) ibeg = je END IF ! ! Scale eigenvector ! xmax = zero IF( ilcplx ) THEN DO j = ibeg, n xmax = MAX( xmax, ABS( vl( j, ieig ) )+ ABS( vl( j, ieig+1 ) ) ) END DO ELSE DO j = ibeg, n xmax = MAX( xmax, ABS( vl( j, ieig ) ) ) END DO END IF ! IF( xmax > safmin ) THEN xscale = one / xmax ! DO jw = 0, nw - 1 DO jr = ibeg, n vl( jr, ieig+jw ) = xscale*vl( jr, ieig+jw ) END DO END DO END IF ieig = ieig + nw - 1 ! END DO END IF ! ! Right eigenvectors ! IF( compr ) THEN ieig = im + 1 ! ! Main loop over eigenvalues ! ilcplx = .false. DO je = n, 1, -1 ! ! Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or ! (b) this would be the second of a complex pair. ! Check for complex eigenvalue, so as to be sure of which ! entry(-ies) of SELECT to look at -- if complex, SELECT(JE) ! or SELECT(JE-1). ! If this is a complex pair, the 2-by-2 diagonal block ! corresponding to the eigenvalue is in rows/columns JE-1:JE ! IF( ilcplx ) THEN ilcplx = .false. CYCLE END IF nw = 1 IF( je > 1 ) THEN IF( a( je, je-1 ) /= zero ) THEN ilcplx = .true. nw = 2 END IF END IF IF( ilall ) THEN ilcomp = .true. ELSE IF( ilcplx ) THEN ilcomp = select( je ) .OR. select( je-1 ) ELSE ilcomp = select( je ) END IF IF( .NOT.ilcomp ) CYCLE ! ! Decide if (a) singular pencil, (b) real eigenvalue, or ! (c) complex eigenvalue. ! IF( .NOT.ilcplx ) THEN IF( ABS( a( je, je ) ) <= safmin .AND. & ABS( b( je, je ) ) <= safmin ) THEN ! ! Singular matrix pencil -- unit eigenvector ! ieig = ieig - 1 DO jr = 1, n vr( jr, ieig ) = zero END DO vr( ieig, ieig ) = one CYCLE END IF END IF ! ! Clear vector ! DO jw = 0, nw - 1 DO jr = 1, n work( ( jw+2 )*n+jr ) = zero END DO END DO ! ! Compute coefficients in ( a A - b B ) x = 0 ! a is ACOEF ! b is BCOEFR + i*BCOEFI ! IF( .NOT.ilcplx ) THEN ! ! Real eigenvalue ! temp = one / MAX( ABS( a( je, je ) )*ascale, & ABS( b( je, je ) )*bscale, safmin ) salfar = ( temp*a( je, je ) )*ascale sbeta = ( temp*b( je, je ) )*bscale acoef = sbeta*ascale bcoefr = salfar*bscale bcoefi = zero ! ! Scale to avoid underflow ! scale = one lsa = ABS( sbeta ) >= safmin .AND. ABS( acoef ) < small lsb = ABS( salfar ) >= safmin .AND. ABS( bcoefr ) < small IF( lsa ) scale = ( small / ABS( sbeta ) )*MIN( anorm, big ) IF( lsb ) scale = MAX( scale, ( small / ABS( salfar ) )* & MIN( bnorm, big ) ) IF( lsa .OR. lsb ) THEN scale = MIN( scale, one / ( safmin*MAX( one, ABS( acoef ), & ABS( bcoefr ) ) ) ) IF( lsa ) THEN acoef = ascale*( scale*sbeta ) ELSE acoef = scale*acoef END IF IF( lsb ) THEN bcoefr = bscale*( scale*salfar ) ELSE bcoefr = scale*bcoefr END IF END IF acoefa = ABS( acoef ) bcoefa = ABS( bcoefr ) ! ! First component is 1 ! work( 2*n+je ) = one xmax = one ! ! Compute contribution from column JE of A and B to sum ! (See "Further Details", above.) ! DO jr = 1, je - 1 work( 2*n+jr ) = bcoefr*b( jr, je ) - acoef*a( jr, je ) END DO ELSE ! ! Complex eigenvalue ! CALL slag2( a( je-1, je-1 ), lda, b( je-1, je-1 ), ldb, & safmin*safety, acoef, temp, bcoefr, temp2, bcoefi ) IF( bcoefi == zero ) THEN info = je - 1 RETURN END IF ! ! Scale to avoid over/underflow ! acoefa = ABS( acoef ) bcoefa = ABS( bcoefr ) + ABS( bcoefi ) scale = one IF( acoefa*ulp < safmin .AND. acoefa >= safmin ) & scale = ( safmin / ulp ) / acoefa IF( bcoefa*ulp < safmin .AND. bcoefa >= safmin ) & scale = MAX( scale, ( safmin / ulp ) / bcoefa ) IF( safmin*acoefa > ascale ) scale = ascale / ( safmin*acoefa ) IF( safmin*bcoefa > bscale ) & scale = MIN( scale, bscale / ( safmin*bcoefa ) ) IF( scale /= one ) THEN acoef = scale*acoef acoefa = ABS( acoef ) bcoefr = scale*bcoefr bcoefi = scale*bcoefi bcoefa = ABS( bcoefr ) + ABS( bcoefi ) END IF ! ! Compute first two components of eigenvector ! and contribution to sums ! temp = acoef*a( je, je-1 ) temp2r = acoef*a( je, je ) - bcoefr*b( je, je ) temp2i = -bcoefi*b( je, je ) IF( ABS( temp ) >= ABS( temp2r )+ABS( temp2i ) ) THEN work( 2*n+je ) = one work( 3*n+je ) = zero work( 2*n+je-1 ) = -temp2r / temp work( 3*n+je-1 ) = -temp2i / temp ELSE work( 2*n+je-1 ) = one work( 3*n+je-1 ) = zero temp = acoef*a( je-1, je ) work( 2*n+je ) = ( bcoefr*b( je-1, je-1 )-acoef* & a( je-1, je-1 ) ) / temp work( 3*n+je ) = bcoefi*b( je-1, je-1 ) / temp END IF ! xmax = MAX( ABS( work( 2*n+je ) )+ABS( work( 3*n+je ) ), & ABS( work( 2*n+je-1 ) )+ABS( work( 3*n+je-1 ) ) ) ! ! Compute contribution from columns JE and JE-1 ! of A and B to the sums. ! creala = acoef*work( 2*n+je-1 ) cimaga = acoef*work( 3*n+je-1 ) crealb = bcoefr*work( 2*n+je-1 ) - bcoefi*work( 3*n+je-1 ) cimagb = bcoefi*work( 2*n+je-1 ) + bcoefr*work( 3*n+je-1 ) cre2a = acoef*work( 2*n+je ) cim2a = acoef*work( 3*n+je ) cre2b = bcoefr*work( 2*n+je ) - bcoefi*work( 3*n+je ) cim2b = bcoefi*work( 2*n+je ) + bcoefr*work( 3*n+je ) DO jr = 1, je - 2 work( 2*n+jr ) = -creala*a( jr, je-1 ) + crealb*b( jr, je-1 ) - & cre2a*a( jr, je ) + cre2b*b( jr, je ) work( 3*n+jr ) = -cimaga*a( jr, je-1 ) + cimagb*b( jr, je-1 ) - & cim2a*a( jr, je ) + cim2b*b( jr, je ) END DO END IF ! dmin = MAX( ulp*acoefa*anorm, ulp*bcoefa*bnorm, safmin ) ! ! Columnwise triangular solve of (a A - b B) x = 0 ! il2by2 = .false. DO j = je - nw, 1, -1 ! ! If a 2-by-2 block, is in position j-1:j, wait until ! next iteration to process it (when it will be j:j+1) ! IF( .NOT.il2by2 .AND. j > 1 ) THEN IF( a( j, j-1 ) /= zero ) THEN il2by2 = .true. CYCLE END IF END IF bdiag( 1 ) = b( j, j ) IF( il2by2 ) THEN na = 2 bdiag( 2 ) = b( j+1, j+1 ) ELSE na = 1 END IF ! ! Compute x(j) (and x(j+1), if 2-by-2 block) ! CALL slaln2( .false., na, nw, dmin, acoef, a( j, j ), & lda, bdiag( 1 ), bdiag( 2 ), work( 2*n+j ), & n, bcoefr, bcoefi, sum, 2, scale, temp, iinfo ) IF( scale < one ) THEN ! DO jw = 0, nw - 1 DO jr = 1, je work( ( jw+2 )*n+jr ) = scale* work( ( jw+2 )*n+jr ) END DO END DO END IF xmax = MAX( scale*xmax, temp ) ! DO jw = 1, nw DO ja = 1, na work( ( jw+1 )*n+j+ja-1 ) = sum( ja, jw ) END DO END DO ! ! w = w + x(j)*(a A(*,j) - b B(*,j) ) with scaling ! IF( j > 1 ) THEN ! ! Check whether scaling is necessary for sum. ! xscale = one / MAX( one, xmax ) temp = acoefa*work( j ) + bcoefa*work( n+j ) IF( il2by2 ) temp = MAX( temp, acoefa*work( j+1 )+bcoefa* & work( n+j+1 ) ) temp = MAX( temp, acoefa, bcoefa ) IF( temp > bignum*xscale ) THEN ! DO jw = 0, nw - 1 DO jr = 1, je work( ( jw+2 )*n+jr ) = xscale* work( ( jw+2 )*n+jr ) END DO END DO xmax = xmax*xscale END IF ! ! Compute the contributions of the off-diagonals of ! column j (and j+1, if 2-by-2 block) of A and B to the ! sums. ! ! DO ja = 1, na IF( ilcplx ) THEN creala = acoef*work( 2*n+j+ja-1 ) cimaga = acoef*work( 3*n+j+ja-1 ) crealb = bcoefr*work( 2*n+j+ja-1 ) - bcoefi*work( 3*n+j+ja-1 ) cimagb = bcoefi*work( 2*n+j+ja-1 ) + bcoefr*work( 3*n+j+ja-1 ) DO jr = 1, j - 1 work( 2*n+jr ) = work( 2*n+jr ) - creala*a( jr, j+ja-1 ) + & crealb*b( jr, j+ja-1 ) work( 3*n+jr ) = work( 3*n+jr ) - cimaga*a( jr, j+ja-1 ) + & cimagb*b( jr, j+ja-1 ) END DO ELSE creala = acoef*work( 2*n+j+ja-1 ) crealb = bcoefr*work( 2*n+j+ja-1 ) DO jr = 1, j - 1 work( 2*n+jr ) = work( 2*n+jr ) - creala*a( jr, j+ja-1 ) + & crealb*b( jr, j+ja-1 ) END DO END IF END DO END IF ! il2by2 = .false. END DO ! ! Copy eigenvector to VR, back transforming if ! HOWMNY='B'. ! ieig = ieig - nw IF( ilback ) THEN ! DO jw = 0, nw - 1 DO jr = 1, n work( ( jw+4 )*n+jr ) = work( ( jw+2 )*n+1 )* vr( jr, 1 ) END DO ! ! A series of compiler directives to defeat ! vectorization for the next loop ! ! DO jc = 2, je DO jr = 1, n work( ( jw+4 )*n+jr ) = work( ( jw+4 )*n+jr ) + & work( ( jw+2 )*n+jc )*vr( jr, jc ) END DO END DO END DO ! DO jw = 0, nw - 1 DO jr = 1, n vr( jr, ieig+jw ) = work( ( jw+4 )*n+jr ) END DO END DO ! iend = n ELSE DO jw = 0, nw - 1 DO jr = 1, n vr( jr, ieig+jw ) = work( ( jw+2 )*n+jr ) END DO END DO ! iend = je END IF ! ! Scale eigenvector ! xmax = zero IF( ilcplx ) THEN DO j = 1, iend xmax = MAX( xmax, ABS( vr( j, ieig ) )+ ABS( vr( j, ieig+1 ) ) ) END DO ELSE DO j = 1, iend xmax = MAX( xmax, ABS( vr( j, ieig ) ) ) END DO END IF ! IF( xmax > safmin ) THEN xscale = one / xmax DO jw = 0, nw - 1 DO jr = 1, iend vr( jr, ieig+jw ) = xscale*vr( jr, ieig+jw ) END DO END DO END IF END DO END IF ! RETURN ! ! End of STGEVC ! END SUBROUTINE stgevc SUBROUTINE stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, & ldz, j1, n1, n2, work, lwork, 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 .. LOGICAL, INTENT(IN) :: wantq LOGICAL, INTENT(IN) :: wantz INTEGER, INTENT(IN) :: n REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq REAL, INTENT(IN OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz INTEGER, INTENT(IN OUT) :: j1 INTEGER, INTENT(IN OUT) :: n1 INTEGER, INTENT(IN OUT) :: n2 REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) ! of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair ! (A, B) by an orthogonal equivalence transformation. ! ! (A, B) must be in generalized real Schur canonical form (as returned ! by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 ! diagonal blocks. B is upper triangular. ! ! Optionally, the matrices Q and Z of generalized Schur vectors are ! updated. ! ! Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' ! Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' ! ! ! Arguments ! ========= ! ! WANTQ (input) LOGICAL ! .TRUE. : update the left transformation matrix Q; ! .FALSE.: do not update Q. ! ! WANTZ (input) LOGICAL ! .TRUE. : update the right transformation matrix Z; ! .FALSE.: do not update Z. ! ! N (input) INTEGER ! The order of the matrices A and B. N >= 0. ! ! A (input/output) REAL arrays, dimensions (LDA,N) ! On entry, the matrix A in the pair (A, B). ! On exit, the updated matrix A. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! B (input/output) REAL arrays, dimensions (LDB,N) ! On entry, the matrix B in the pair (A, B). ! On exit, the updated matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! Q (input/output) REAL array, dimension (LDZ,N) ! On entry, if WANTQ = .TRUE., the orthogonal matrix Q. ! On exit, the updated matrix Q. ! Not referenced if WANTQ = .FALSE.. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. LDQ >= 1. ! If WANTQ = .TRUE., LDQ >= N. ! ! Z (input/output) REAL array, dimension (LDZ,N) ! On entry, if WANTZ =.TRUE., the orthogonal matrix Z. ! On exit, the updated matrix Z. ! Not referenced if WANTZ = .FALSE.. ! ! LDZ (input) INTEGER ! The leading dimension of the array Z. LDZ >= 1. ! If WANTZ = .TRUE., LDZ >= N. ! ! J1 (input) INTEGER ! The index to the first block (A11, B11). 1 <= J1 <= N. ! ! N1 (input) INTEGER ! The order of the first block (A11, B11). N1 = 0, 1 or 2. ! ! N2 (input) INTEGER ! The order of the second block (A22, B22). N2 = 0, 1 or 2. ! ! WORK (workspace) REAL array, dimension (LWORK). ! ! LWORK (input) INTEGER ! The dimension of the array WORK. ! LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 ) ! ! INFO (output) INTEGER ! =0: Successful exit ! >0: If INFO = 1, the transformed matrix (A, B) would be ! too far from generalized Schur form; the blocks are ! not swapped and (A, B) and (Q, Z) are unchanged. ! The problem of swapping is too ill-conditioned. ! <0: If INFO = -16: LWORK is too small. Appropriate value ! for LWORK is returned in WORK(1). ! ! Further Details ! =============== ! ! Based on contributions by ! Bo Kagstrom and Peter Poromaa, Department of Computing Science, ! Umea University, S-901 87 Umea, Sweden. ! ! In the current code both weak and strong stability tests are ! performed. The user can omit the strong stability test by changing ! the internal logical parameter WANDS to .FALSE.. See ref. [2] for ! details. ! ! [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the ! Generalized Real Schur Form of a Regular Matrix Pair (A, B), in ! M.S. Moonen et al (eds), Linear Algebra for Large Scale and ! Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. ! ! [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified ! Eigenvalues of a Regular Matrix Pair (A, B) and Condition ! Estimation: Theory, Algorithms and Software, ! Report UMINF - 94.04, Department of Computing Science, Umea ! University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working ! Note 87. To appear in Numerical Algorithms, 1996. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: ten = 1.0E+01 INTEGER, PARAMETER :: ldst = 4 LOGICAL, PARAMETER :: wands = .true. ! .. ! .. Local Scalars .. LOGICAL :: strong, weak INTEGER :: i, idum, linfo, m REAL :: bqra21, brqa21, ddum, dnorm, dscale, dsum, eps, & f, g, sa, sb, scale, smlnum, ss, thresh, ws ! .. ! .. Local Arrays .. INTEGER :: iwork( ldst ) REAL :: ai( 2 ), ar( 2 ), be( 2 ), ir( ldst, ldst ), & ircop( ldst, ldst ), li( ldst, ldst ), & licop( ldst, ldst ), s( ldst, ldst ), scpy( ldst, ldst ), t( ldst, ldst ), & taul( ldst ), taur( ldst ), tcpy( ldst, ldst ) ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. External Subroutines .. EXTERNAL scopy, sgemm, sgeqr2, sgerq2, slacpy, slagv2, & slartg, slassq, sorg2r, sorgr2, sorm2r, sormr2, srot, sscal, stgsy2 ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT ! .. ! .. Executable Statements .. ! info = 0 ! ! Quick return if possible ! IF( n <= 1 .OR. n1 <= 0 .OR. n2 <= 0 ) RETURN IF( n1 > n .OR. ( j1+n1 ) > n ) RETURN m = n1 + n2 IF( lwork < MAX( n*m, m*m*2 ) ) THEN info = -16 work( 1 ) = MAX( n*m, m*m*2 ) RETURN END IF ! weak = .false. strong = .false. ! ! Make a local copy of selected block ! CALL scopy( ldst*ldst, zero, 0, li, 1 ) CALL scopy( ldst*ldst, zero, 0, ir, 1 ) CALL slacpy( 'Full', m, m, a( j1, j1 ), lda, s, ldst ) CALL slacpy( 'Full', m, m, b( j1, j1 ), ldb, t, ldst ) ! ! Compute threshold for testing acceptance of swapping. ! eps = slamch( 'P' ) smlnum = slamch( 'S' ) / eps dscale = zero dsum = one CALL slacpy( 'Full', m, m, s, ldst, work, m ) CALL slassq( m*m, work, 1, dscale, dsum ) CALL slacpy( 'Full', m, m, t, ldst, work, m ) CALL slassq( m*m, work, 1, dscale, dsum ) dnorm = dscale*SQRT( dsum ) thresh = MAX( ten*eps*dnorm, smlnum ) ! IF( m == 2 ) THEN ! ! CASE 1: Swap 1-by-1 and 1-by-1 blocks. ! ! Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks ! using Givens rotations and perform the swap tentatively. ! f = s( 2, 2 )*t( 1, 1 ) - t( 2, 2 )*s( 1, 1 ) g = s( 2, 2 )*t( 1, 2 ) - t( 2, 2 )*s( 1, 2 ) sb = ABS( t( 2, 2 ) ) sa = ABS( s( 2, 2 ) ) CALL slartg( f, g, ir( 1, 2 ), ir( 1, 1 ), ddum ) ir( 2, 1 ) = -ir( 1, 2 ) ir( 2, 2 ) = ir( 1, 1 ) CALL srot( 2, s( 1, 1 ), 1, s( 1, 2 ), 1, ir( 1, 1 ), ir( 2, 1 ) ) CALL srot( 2, t( 1, 1 ), 1, t( 1, 2 ), 1, ir( 1, 1 ), ir( 2, 1 ) ) IF( sa >= sb ) THEN CALL slartg( s( 1, 1 ), s( 2, 1 ), li( 1, 1 ), li( 2, 1 ), ddum ) ELSE CALL slartg( t( 1, 1 ), t( 2, 1 ), li( 1, 1 ), li( 2, 1 ), ddum ) END IF CALL srot( 2, s( 1, 1 ), ldst, s( 2, 1 ), ldst, li( 1, 1 ), li( 2, 1 ) ) CALL srot( 2, t( 1, 1 ), ldst, t( 2, 1 ), ldst, li( 1, 1 ), li( 2, 1 ) ) li( 2, 2 ) = li( 1, 1 ) li( 1, 2 ) = -li( 2, 1 ) ! ! Weak stability test: ! |S21| + |T21| <= O(EPS * F-norm((S, T))) ! ws = ABS( s( 2, 1 ) ) + ABS( t( 2, 1 ) ) weak = ws <= thresh IF( .NOT.weak ) GO TO 70 ! IF( wands ) THEN ! ! Strong stability test: ! F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B))) ! CALL slacpy( 'Full', m, m, a( j1, j1 ), lda, work( m*m+1 ), m ) CALL sgemm( 'N', 'N', m, m, m, one, li, ldst, s, ldst, zero, work, m ) CALL sgemm( 'N', 'T', m, m, m, -one, work, m, ir, ldst, one, & work( m*m+1 ), m ) dscale = zero dsum = one CALL slassq( m*m, work( m*m+1 ), 1, dscale, dsum ) ! CALL slacpy( 'Full', m, m, b( j1, j1 ), ldb, work( m*m+1 ), m ) CALL sgemm( 'N', 'N', m, m, m, one, li, ldst, t, ldst, zero, work, m ) CALL sgemm( 'N', 'T', m, m, m, -one, work, m, ir, ldst, one, & work( m*m+1 ), m ) CALL slassq( m*m, work( m*m+1 ), 1, dscale, dsum ) ss = dscale*SQRT( dsum ) strong = ss <= thresh IF( .NOT.strong ) GO TO 70 END IF ! ! Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and ! (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). ! CALL srot( j1+1, a( 1, j1 ), 1, a( 1, j1+1 ), 1, ir( 1, 1 ), ir( 2, 1 ) ) CALL srot( j1+1, b( 1, j1 ), 1, b( 1, j1+1 ), 1, ir( 1, 1 ), ir( 2, 1 ) ) CALL srot( n-j1+1, a( j1, j1 ), lda, a( j1+1, j1 ), lda, & li( 1, 1 ), li( 2, 1 ) ) CALL srot( n-j1+1, b( j1, j1 ), ldb, b( j1+1, j1 ), ldb, & li( 1, 1 ), li( 2, 1 ) ) ! ! Set N1-by-N2 (2,1) - blocks to ZERO. ! a( j1+1, j1 ) = zero b( j1+1, j1 ) = zero ! ! Accumulate transformations into Q and Z if requested. ! IF( wantz ) CALL srot( n, z( 1, j1 ), 1, z( 1, j1+1 ), 1, ir( 1, 1 ), & ir( 2, 1 ) ) IF( wantq ) CALL srot( n, q( 1, j1 ), 1, q( 1, j1+1 ), 1, li( 1, 1 ), & li( 2, 1 ) ) ! ! Exit with INFO = 0 if swap was successfully performed. ! RETURN ! ELSE ! ! CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 ! and 2-by-2 blocks. ! ! Solve the generalized Sylvester equation ! S11 * R - L * S22 = SCALE * S12 ! T11 * R - L * T22 = SCALE * T12 ! for R and L. Solutions in LI and IR. ! CALL slacpy( 'Full', n1, n2, t( 1, n1+1 ), ldst, li, ldst ) CALL slacpy( 'Full', n1, n2, s( 1, n1+1 ), ldst, ir( n2+1, n1+1 ), ldst ) CALL stgsy2( 'N', 0, n1, n2, s, ldst, s( n1+1, n1+1 ), ldst, & ir( n2+1, n1+1 ), ldst, t, ldst, t( n1+1, n1+1 ), & ldst, li, ldst, scale, dsum, dscale, iwork, idum, linfo ) ! ! Compute orthogonal matrix QL: ! ! QL' * LI = [ TL ] ! [ 0 ] ! where ! LI = [ -L ] ! [ SCALE * identity(N2) ] ! DO i = 1, n2 CALL sscal( n1, -one, li( 1, i ), 1 ) li( n1+i, i ) = scale END DO CALL sgeqr2( m, n2, li, ldst, taul, work, linfo ) IF( linfo /= 0 ) GO TO 70 CALL sorg2r( m, m, n2, li, ldst, taul, work, linfo ) IF( linfo /= 0 ) GO TO 70 ! ! Compute orthogonal matrix RQ: ! ! IR * RQ' = [ 0 TR], ! ! where IR = [ SCALE * identity(N1), R ] ! DO i = 1, n1 ir( n2+i, i ) = scale END DO CALL sgerq2( n1, m, ir( n2+1, 1 ), ldst, taur, work, linfo ) IF( linfo /= 0 ) GO TO 70 CALL sorgr2( m, m, n1, ir, ldst, taur, work, linfo ) IF( linfo /= 0 ) GO TO 70 ! ! Perform the swapping tentatively: ! CALL sgemm( 'T', 'N', m, m, m, one, li, ldst, s, ldst, zero, work, m ) CALL sgemm( 'N', 'T', m, m, m, one, work, m, ir, ldst, zero, s, ldst ) CALL sgemm( 'T', 'N', m, m, m, one, li, ldst, t, ldst, zero, work, m ) CALL sgemm( 'N', 'T', m, m, m, one, work, m, ir, ldst, zero, t, ldst ) CALL slacpy( 'F', m, m, s, ldst, scpy, ldst ) CALL slacpy( 'F', m, m, t, ldst, tcpy, ldst ) CALL slacpy( 'F', m, m, ir, ldst, ircop, ldst ) CALL slacpy( 'F', m, m, li, ldst, licop, ldst ) ! ! Triangularize the B-part by an RQ factorization. ! Apply transformation (from left) to A-part, giving S. ! CALL sgerq2( m, m, t, ldst, taur, work, linfo ) IF( linfo /= 0 ) GO TO 70 CALL sormr2( 'R', 'T', m, m, m, t, ldst, taur, s, ldst, work, linfo ) IF( linfo /= 0 ) GO TO 70 CALL sormr2( 'L', 'N', m, m, m, t, ldst, taur, ir, ldst, work, linfo ) IF( linfo /= 0 ) GO TO 70 ! ! Compute F-norm(S21) in BRQA21. (T21 is 0.) ! dscale = zero dsum = one DO i = 1, n2 CALL slassq( n1, s( n2+1, i ), 1, dscale, dsum ) END DO brqa21 = dscale*SQRT( dsum ) ! ! Triangularize the B-part by a QR factorization. ! Apply transformation (from right) to A-part, giving S. ! CALL sgeqr2( m, m, tcpy, ldst, taul, work, linfo ) IF( linfo /= 0 ) GO TO 70 CALL sorm2r( 'L', 'T', m, m, m, tcpy, ldst, taul, scpy, ldst, work, info ) CALL sorm2r( 'R', 'N', m, m, m, tcpy, ldst, taul, licop, ldst, work, info ) IF( linfo /= 0 ) GO TO 70 ! ! Compute F-norm(S21) in BQRA21. (T21 is 0.) ! dscale = zero dsum = one DO i = 1, n2 CALL slassq( n1, scpy( n2+1, i ), 1, dscale, dsum ) END DO bqra21 = dscale*SQRT( dsum ) ! ! Decide which method to use. ! Weak stability test: ! F-norm(S21) <= O(EPS * F-norm((S, T))) ! IF( bqra21 <= brqa21 .AND. bqra21 <= thresh ) THEN CALL slacpy( 'F', m, m, scpy, ldst, s, ldst ) CALL slacpy( 'F', m, m, tcpy, ldst, t, ldst ) CALL slacpy( 'F', m, m, ircop, ldst, ir, ldst ) CALL slacpy( 'F', m, m, licop, ldst, li, ldst ) ELSE IF( brqa21 >= thresh ) THEN GO TO 70 END IF ! ! Set lower triangle of B-part to zero ! DO i = 2, m CALL scopy( m-i+1, zero, 0, t( i, i-1 ), 1 ) END DO ! IF( wands ) THEN ! ! Strong stability test: ! F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B))) ! CALL slacpy( 'Full', m, m, a( j1, j1 ), lda, work( m*m+1 ), m ) CALL sgemm( 'N', 'N', m, m, m, one, li, ldst, s, ldst, zero, work, m ) CALL sgemm( 'N', 'N', m, m, m, -one, work, m, ir, ldst, one, & work( m*m+1 ), m ) dscale = zero dsum = one CALL slassq( m*m, work( m*m+1 ), 1, dscale, dsum ) ! CALL slacpy( 'Full', m, m, b( j1, j1 ), ldb, work( m*m+1 ), m ) CALL sgemm( 'N', 'N', m, m, m, one, li, ldst, t, ldst, zero, work, m ) CALL sgemm( 'N', 'N', m, m, m, -one, work, m, ir, ldst, one, & work( m*m+1 ), m ) CALL slassq( m*m, work( m*m+1 ), 1, dscale, dsum ) ss = dscale*SQRT( dsum ) strong = ( ss <= thresh ) IF( .NOT.strong ) GO TO 70 ! END IF ! ! If the swap is accepted ("weakly" and "strongly"), apply the ! transformations and set N1-by-N2 (2,1)-block to zero. ! DO i = 1, n2 CALL scopy( n1, zero, 0, s( n2+1, i ), 1 ) END DO ! ! copy back M-by-M diagonal block starting at index J1 of (A, B) ! CALL slacpy( 'F', m, m, s, ldst, a( j1, j1 ), lda ) CALL slacpy( 'F', m, m, t, ldst, b( j1, j1 ), ldb ) CALL scopy( ldst*ldst, zero, 0, t, 1 ) ! ! Standardize existing 2-by-2 blocks. ! CALL scopy( m*m, zero, 0, work, 1 ) work( 1 ) = one t( 1, 1 ) = one idum = lwork - m*m - 2 IF( n2 > 1 ) THEN CALL slagv2( a( j1, j1 ), lda, b( j1, j1 ), ldb, ar, ai, be, & work( 1 ), work( 2 ), t( 1, 1 ), t( 2, 1 ) ) work( m+1 ) = -work( 2 ) work( m+2 ) = work( 1 ) t( n2, n2 ) = t( 1, 1 ) t( 1, 2 ) = -t( 2, 1 ) END IF work( m*m ) = one t( m, m ) = one ! IF( n1 > 1 ) THEN CALL slagv2( a( j1+n2, j1+n2 ), lda, b( j1+n2, j1+n2 ), ldb, & taur, taul, work( m*m+1 ), work( n2*m+n2+1 ), & work( n2*m+n2+2 ), t( n2+1, n2+1 ), t( m, m-1 ) ) work( m*m ) = work( n2*m+n2+1 ) work( m*m-1 ) = -work( n2*m+n2+2 ) t( m, m ) = t( n2+1, n2+1 ) t( m-1, m ) = -t( m, m-1 ) END IF CALL sgemm( 'T', 'N', n2, n1, n2, one, work, m, a( j1, j1+n2 ), & lda, zero, work( m*m+1 ), n2 ) CALL slacpy( 'Full', n2, n1, work( m*m+1 ), n2, a( j1, j1+n2 ), lda ) CALL sgemm( 'T', 'N', n2, n1, n2, one, work, m, b( j1, j1+n2 ), & ldb, zero, work( m*m+1 ), n2 ) CALL slacpy( 'Full', n2, n1, work( m*m+1 ), n2, b( j1, j1+n2 ), ldb ) CALL sgemm( 'N', 'N', m, m, m, one, li, ldst, work, m, zero, & work( m*m+1 ), m ) CALL slacpy( 'Full', m, m, work( m*m+1 ), m, li, ldst ) CALL sgemm( 'N', 'N', n2, n1, n1, one, a( j1, j1+n2 ), lda, & t( n2+1, n2+1 ), ldst, zero, work, n2 ) CALL slacpy( 'Full', n2, n1, work, n2, a( j1, j1+n2 ), lda ) CALL sgemm( 'N', 'N', n2, n1, n1, one, b( j1, j1+n2 ), lda, & t( n2+1, n2+1 ), ldst, zero, work, n2 ) CALL slacpy( 'Full', n2, n1, work, n2, b( j1, j1+n2 ), ldb ) CALL sgemm( 'T', 'N', m, m, m, one, ir, ldst, t, ldst, zero, work, m ) CALL slacpy( 'Full', m, m, work, m, ir, ldst ) ! ! Accumulate transformations into Q and Z if requested. ! IF( wantq ) THEN CALL sgemm( 'N', 'N', n, m, m, one, q( 1, j1 ), ldq, li, & ldst, zero, work, n ) CALL slacpy( 'Full', n, m, work, n, q( 1, j1 ), ldq ) ! END IF ! IF( wantz ) THEN CALL sgemm( 'N', 'N', n, m, m, one, z( 1, j1 ), ldz, ir, & ldst, zero, work, n ) CALL slacpy( 'Full', n, m, work, n, z( 1, j1 ), ldz ) ! END IF ! ! Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and ! (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). ! i = j1 + m IF( i <= n ) THEN CALL sgemm( 'T', 'N', m, n-i+1, m, one, li, ldst, & a( j1, i ), lda, zero, work, m ) CALL slacpy( 'Full', m, n-i+1, work, m, a( j1, i ), lda ) CALL sgemm( 'T', 'N', m, n-i+1, m, one, li, ldst, & b( j1, i ), lda, zero, work, m ) CALL slacpy( 'Full', m, n-i+1, work, m, b( j1, i ), lda ) END IF i = j1 - 1 IF( i > 0 ) THEN CALL sgemm( 'N', 'N', i, m, m, one, a( 1, j1 ), lda, ir, & ldst, zero, work, i ) CALL slacpy( 'Full', i, m, work, i, a( 1, j1 ), lda ) CALL sgemm( 'N', 'N', i, m, m, one, b( 1, j1 ), ldb, ir, & ldst, zero, work, i ) CALL slacpy( 'Full', i, m, work, i, b( 1, j1 ), ldb ) END IF ! ! Exit with INFO = 0 if swap was successfully performed. ! RETURN ! END IF ! ! Exit with INFO = 1 if swap was rejected. ! 70 CONTINUE ! info = 1 RETURN ! ! End of STGEX2 ! END SUBROUTINE stgex2 SUBROUTINE stgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, & ldz, ifst, ilst, 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 .. LOGICAL, INTENT(IN OUT) :: wantq LOGICAL, INTENT(IN OUT) :: wantz INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq REAL, INTENT(IN OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz INTEGER, INTENT(IN OUT) :: ifst INTEGER, INTENT(IN OUT) :: ilst REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STGEXC reorders the generalized real Schur decomposition of a real ! matrix pair (A,B) using an orthogonal equivalence transformation ! ! (A, B) = Q * (A, B) * Z', ! ! so that the diagonal block of (A, B) with row index IFST is moved ! to row ILST. ! ! (A, B) must be in generalized real Schur canonical form (as returned ! by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 ! diagonal blocks. B is upper triangular. ! ! Optionally, the matrices Q and Z of generalized Schur vectors are ! updated. ! ! Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)' ! Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)' ! ! ! Arguments ! ========= ! ! WANTQ (input) LOGICAL ! .TRUE. : update the left transformation matrix Q; ! .FALSE.: do not update Q. ! ! WANTZ (input) LOGICAL ! .TRUE. : update the right transformation matrix Z; ! .FALSE.: do not update Z. ! ! N (input) INTEGER ! The order of the matrices A and B. N >= 0. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the matrix A in generalized real Schur canonical ! form. ! On exit, the updated matrix A, again in generalized ! real Schur canonical form. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! B (input/output) REAL array, dimension (LDB,N) ! On entry, the matrix B in generalized real Schur canonical ! form (A,B). ! On exit, the updated matrix B, again in generalized ! real Schur canonical form (A,B). ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! Q (input/output) REAL array, dimension (LDZ,N) ! On entry, if WANTQ = .TRUE., the orthogonal matrix Q. ! On exit, the updated matrix Q. ! If WANTQ = .FALSE., Q is not referenced. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. LDQ >= 1. ! If WANTQ = .TRUE., LDQ >= N. ! ! Z (input/output) REAL array, dimension (LDZ,N) ! On entry, if WANTZ = .TRUE., the orthogonal matrix Z. ! On exit, the updated matrix Z. ! If WANTZ = .FALSE., Z is not referenced. ! ! LDZ (input) INTEGER ! The leading dimension of the array Z. LDZ >= 1. ! If WANTZ = .TRUE., LDZ >= N. ! ! IFST (input/output) INTEGER ! ILST (input/output) INTEGER ! Specify the reordering of the diagonal blocks of (A, B). ! The block with row index IFST is moved to row ILST, by a ! sequence of swapping between adjacent blocks. ! On exit, if IFST pointed on entry to the second row of ! a 2-by-2 block, it is changed to point to the first row; ! ILST always points to the first row of the block in its ! final position (which may differ from its input value by ! +1 or -1). 1 <= IFST, ILST <= N. ! ! WORK (workspace/output) REAL array, dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. LWORK >= 4*N + 16. ! ! 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. ! =1: The transformed matrix pair (A, B) would be too far ! from generalized Schur form; the problem is ill- ! conditioned. (A, B) may have been partially reordered, ! and ILST points to the first row of the current ! position of the block being moved. ! ! Further Details ! =============== ! ! Based on contributions by ! Bo Kagstrom and Peter Poromaa, Department of Computing Science, ! Umea University, S-901 87 Umea, Sweden. ! ! [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the ! Generalized Real Schur Form of a Regular Matrix Pair (A, B), in ! M.S. Moonen et al (eds), Linear Algebra for Large Scale and ! Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: here, lwmin, nbf, nbl, nbnext ! .. ! .. External Subroutines .. EXTERNAL stgex2, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Decode and test input arguments. ! info = 0 lwmin = MAX( 1, 4*n+16 ) lquery = ( lwork == -1 ) IF( n < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldq < 1 .OR. wantq .AND. ( ldq < MAX( 1, n ) ) ) THEN info = -9 ELSE IF( ldz < 1 .OR. wantz .AND. ( ldz < MAX( 1, n ) ) ) THEN info = -11 ELSE IF( ifst < 1 .OR. ifst > n ) THEN info = -12 ELSE IF( ilst < 1 .OR. ilst > n ) THEN info = -13 ELSE IF( lwork < lwmin .AND. .NOT.lquery ) THEN info = -15 END IF ! IF( info == 0 ) THEN work( 1 ) = lwmin END IF ! IF( info /= 0 ) THEN CALL xerbla( 'STGEXC', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n <= 1 ) RETURN ! ! Determine the first row of the specified block and find out ! if it is 1-by-1 or 2-by-2. ! IF( ifst > 1 ) THEN IF( a( ifst, ifst-1 ) /= zero ) ifst = ifst - 1 END IF nbf = 1 IF( ifst < n ) THEN IF( a( ifst+1, ifst ) /= zero ) nbf = 2 END IF ! ! Determine the first row of the final block ! and find out if it is 1-by-1 or 2-by-2. ! IF( ilst > 1 ) THEN IF( a( ilst, ilst-1 ) /= zero ) ilst = ilst - 1 END IF nbl = 1 IF( ilst < n ) THEN IF( a( ilst+1, ilst ) /= zero ) nbl = 2 END IF IF( ifst == ilst ) RETURN ! IF( ifst < ilst ) THEN ! ! Update ILST. ! IF( nbf == 2 .AND. nbl == 1 ) ilst = ilst - 1 IF( nbf == 1 .AND. nbl == 2 ) ilst = ilst + 1 ! here = ifst ! 10 CONTINUE ! ! Swap with next one below. ! IF( nbf == 1 .OR. nbf == 2 ) THEN ! ! Current block either 1-by-1 or 2-by-2. ! nbnext = 1 IF( here+nbf+1 <= n ) THEN IF( a( here+nbf+1, here+nbf ) /= zero ) nbnext = 2 END IF CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, & ldz, here, nbf, nbnext, work, lwork, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF here = here + nbnext ! ! Test if 2-by-2 block breaks into two 1-by-1 blocks. ! IF( nbf == 2 ) THEN IF( a( here+1, here ) == zero ) nbf = 3 END IF ! ELSE ! ! Current block consists of two 1-by-1 blocks, each of which ! must be swapped individually. ! nbnext = 1 IF( here+3 <= n ) THEN IF( a( here+3, here+2 ) /= zero ) nbnext = 2 END IF CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, & ldz, here+1, 1, nbnext, work, lwork, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF IF( nbnext == 1 ) THEN ! ! Swap two 1-by-1 blocks. ! CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, & ldz, here, 1, 1, work, lwork, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF here = here + 1 ! ELSE ! ! Recompute NBNEXT in case of 2-by-2 split. ! IF( a( here+2, here+1 ) == zero ) nbnext = 1 IF( nbnext == 2 ) THEN ! ! 2-by-2 block did not split. ! CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, & z, ldz, here, 1, nbnext, work, lwork, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF here = here + 2 ELSE ! ! 2-by-2 block did split. ! CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, & z, ldz, here, 1, 1, work, lwork, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF here = here + 1 CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, & z, ldz, here, 1, 1, work, lwork, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF here = here + 1 END IF ! END IF END IF IF( here < ilst ) GO TO 10 ELSE here = ifst ! 20 CONTINUE ! ! Swap with next one below. ! IF( nbf == 1 .OR. nbf == 2 ) THEN ! ! Current block either 1-by-1 or 2-by-2. ! nbnext = 1 IF( here >= 3 ) THEN IF( a( here-1, here-2 ) /= zero ) nbnext = 2 END IF CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, & ldz, here-nbnext, nbnext, nbf, work, lwork, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF here = here - nbnext ! ! Test if 2-by-2 block breaks into two 1-by-1 blocks. ! IF( nbf == 2 ) THEN IF( a( here+1, here ) == zero ) nbf = 3 END IF ! ELSE ! ! Current block consists of two 1-by-1 blocks, each of which ! must be swapped individually. ! nbnext = 1 IF( here >= 3 ) THEN IF( a( here-1, here-2 ) /= zero ) nbnext = 2 END IF CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, & ldz, here-nbnext, nbnext, 1, work, lwork, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF IF( nbnext == 1 ) THEN ! ! Swap two 1-by-1 blocks. ! CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, z, & ldz, here, nbnext, 1, work, lwork, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF here = here - 1 ELSE ! ! Recompute NBNEXT in case of 2-by-2 split. ! IF( a( here, here-1 ) == zero ) nbnext = 1 IF( nbnext == 2 ) THEN ! ! 2-by-2 block did not split. ! CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, & z, ldz, here-1, 2, 1, work, lwork, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF here = here - 2 ELSE ! ! 2-by-2 block did split. ! CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, & z, ldz, here, 1, 1, work, lwork, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF here = here - 1 CALL stgex2( wantq, wantz, n, a, lda, b, ldb, q, ldq, & z, ldz, here, 1, 1, work, lwork, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF here = here - 1 END IF END IF END IF IF( here > ilst ) GO TO 20 END IF ilst = here work( 1 ) = lwmin RETURN ! ! End of STGEXC ! END SUBROUTINE stgexc SUBROUTINE stgsen( ijob, wantq, wantz, select, n, a, lda, b, ldb, & alphar, alphai, beta, q, ldq, z, ldz, m, pl, & pr, dif, work, lwork, iwork, liwork, 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, INTENT(IN) :: ijob LOGICAL, INTENT(IN OUT) :: wantq LOGICAL, INTENT(IN OUT) :: wantz LOGICAL, INTENT(IN) :: select( * ) INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(OUT) :: alphar( * ) REAL, INTENT(OUT) :: alphai( * ) REAL, INTENT(OUT) :: beta( * ) REAL, INTENT(OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq REAL, INTENT(IN OUT) :: z( ldz, * ) INTEGER, INTENT(IN OUT) :: ldz INTEGER, INTENT(OUT) :: m REAL, INTENT(OUT) :: pl REAL, INTENT(OUT) :: pr REAL, INTENT(OUT) :: dif( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(IN OUT) :: liwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STGSEN reorders the generalized real Schur decomposition of a real ! matrix pair (A, B) (in terms of an orthonormal equivalence trans- ! formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues ! appears in the leading diagonal blocks of the upper quasi-triangular ! matrix A and the upper triangular B. The leading columns of Q and ! Z form orthonormal bases of the corresponding left and right eigen- ! spaces (deflating subspaces). (A, B) must be in generalized real ! Schur canonical form (as returned by SGGES), i.e. A is block upper ! triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper ! triangular. ! ! STGSEN also computes the generalized eigenvalues ! ! w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j) ! ! of the reordered matrix pair (A, B). ! ! Optionally, STGSEN computes the estimates of reciprocal condition ! numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), ! (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) ! between the matrix pairs (A11, B11) and (A22,B22) that correspond to ! the selected cluster and the eigenvalues outside the cluster, resp., ! and norms of "projections" onto left and right eigenspaces w.r.t. ! the selected cluster in the (1,1)-block. ! ! Arguments ! ========= ! ! IJOB (input) INTEGER ! Specifies whether condition numbers are required for the ! cluster of eigenvalues (PL and PR) or the deflating subspaces ! (Difu and Difl): ! =0: Only reorder w.r.t. SELECT. No extras. ! =1: Reciprocal of norms of "projections" onto left and right ! eigenspaces w.r.t. the selected cluster (PL and PR). ! =2: Upper bounds on Difu and Difl. F-norm-based estimate ! (DIF(1:2)). ! =3: Estimate of Difu and Difl. 1-norm-based estimate ! (DIF(1:2)). ! About 5 times as expensive as IJOB = 2. ! =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic ! version to get it all. ! =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) ! ! WANTQ (input) LOGICAL ! .TRUE. : update the left transformation matrix Q; ! .FALSE.: do not update Q. ! ! WANTZ (input) LOGICAL ! .TRUE. : update the right transformation matrix Z; ! .FALSE.: do not update Z. ! ! SELECT (input) LOGICAL array, dimension (N) ! SELECT specifies the eigenvalues in the selected cluster. ! To select a real eigenvalue w(j), SELECT(j) must be set to ! .TRUE.. To select a complex conjugate pair of eigenvalues ! w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, ! either SELECT(j) or SELECT(j+1) or both must be set to ! .TRUE.; a complex conjugate pair of eigenvalues must be ! either both included in the cluster or both excluded. ! ! N (input) INTEGER ! The order of the matrices A and B. N >= 0. ! ! A (input/output) REAL array, dimension(LDA,N) ! On entry, the upper quasi-triangular matrix A, with (A, B) in ! generalized real Schur canonical form. ! On exit, A is overwritten by the reordered matrix A. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! B (input/output) REAL array, dimension(LDB,N) ! On entry, the upper triangular matrix B, with (A, B) in ! generalized real Schur canonical form. ! On exit, B is overwritten by the reordered matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! ALPHAR (output) REAL array, dimension (N) ! ALPHAI (output) REAL array, dimension (N) ! BETA (output) REAL array, dimension (N) ! On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will ! be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i ! and BETA(j),j=1,...,N are the diagonals of the complex Schur ! form (S,T) that would result if the 2-by-2 diagonal blocks of ! the real generalized Schur form of (A,B) were further reduced ! to triangular form using complex unitary transformations. ! If ALPHAI(j) is zero, then the j-th eigenvalue is real; if ! positive, then the j-th and (j+1)-st eigenvalues are a ! complex conjugate pair, with ALPHAI(j+1) negative. ! ! Q (input/output) REAL array, dimension (LDQ,N) ! On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. ! On exit, Q has been postmultiplied by the left orthogonal ! transformation matrix which reorder (A, B); The leading M ! columns of Q form orthonormal bases for the specified pair of ! left eigenspaces (deflating subspaces). ! If WANTQ = .FALSE., Q is not referenced. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. LDQ >= 1; ! and if WANTQ = .TRUE., LDQ >= N. ! ! Z (input/output) REAL array, dimension (LDZ,N) ! On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. ! On exit, Z has been postmultiplied by the left orthogonal ! transformation matrix which reorder (A, B); The leading M ! columns of Z form orthonormal bases for the specified pair of ! left eigenspaces (deflating subspaces). ! If WANTZ = .FALSE., Z is not referenced. ! ! LDZ (input) INTEGER ! The leading dimension of the array Z. LDZ >= 1; ! If WANTZ = .TRUE., LDZ >= N. ! ! M (output) INTEGER ! The dimension of the specified pair of left and right eigen- ! spaces (deflating subspaces). 0 <= M <= N. ! ! PL, PR (output) REAL ! If IJOB = 1, 4 or 5, PL, PR are lower bounds on the ! reciprocal of the norm of "projections" onto left and right ! eigenspaces with respect to the selected cluster. ! 0 < PL, PR <= 1. ! If M = 0 or M = N, PL = PR = 1. ! If IJOB = 0, 2 or 3, PL and PR are not referenced. ! ! DIF (output) REAL array, dimension (2). ! If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. ! If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on ! Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based ! estimates of Difu and Difl. ! If M = 0 or N, DIF(1:2) = F-norm([A, B]). ! If IJOB = 0 or 1, DIF is not referenced. ! ! WORK (workspace/output) REAL array, dimension (LWORK) ! IF IJOB = 0, WORK is not referenced. Otherwise, ! on exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. LWORK >= 4*N+16. ! If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)). ! If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)). ! ! 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/output) INTEGER array, dimension (LIWORK) ! IF IJOB = 0, IWORK is not referenced. Otherwise, ! on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. ! ! LIWORK (input) INTEGER ! The dimension of the array IWORK. LIWORK >= 1. ! If IJOB = 1, 2 or 4, LIWORK >= N+6. ! If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6). ! ! If LIWORK = -1, then a workspace query is assumed; the ! routine only calculates the optimal size of the IWORK array, ! returns this value as the first entry of the IWORK array, and ! no error message related to LIWORK is issued by XERBLA. ! ! INFO (output) INTEGER ! =0: Successful exit. ! <0: If INFO = -i, the i-th argument had an illegal value. ! =1: Reordering of (A, B) failed because the transformed ! matrix pair (A, B) would be too far from generalized ! Schur form; the problem is very ill-conditioned. ! (A, B) may have been partially reordered. ! If requested, 0 is returned in DIF(*), PL and PR. ! ! Further Details ! =============== ! ! STGSEN first collects the selected eigenvalues by computing ! orthogonal U and W that move them to the top left corner of (A, B). ! In other words, the selected eigenvalues are the eigenvalues of ! (A11, B11) in: ! ! U'*(A, B)*W = (A11 A12) (B11 B12) n1 ! ( 0 A22),( 0 B22) n2 ! n1 n2 n1 n2 ! ! where N = n1+n2 and U' means the transpose of U. The first n1 columns ! of U and W span the specified pair of left and right eigenspaces ! (deflating subspaces) of (A, B). ! ! If (A, B) has been obtained from the generalized real Schur ! decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the ! reordered generalized real Schur form of (C, D) is given by ! ! (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)', ! ! and the first n1 columns of Q*U and Z*W span the corresponding ! deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). ! ! Note that if the selected eigenvalue is sufficiently ill-conditioned, ! then its value may differ significantly from its value before ! reordering. ! ! The reciprocal condition numbers of the left and right eigenspaces ! spanned by the first n1 columns of U and W (or Q*U and Z*W) may ! be returned in DIF(1:2), corresponding to Difu and Difl, resp. ! ! The Difu and Difl are defined as: ! ! Difu[(A11, B11), (A22, B22)] = sigma-min( Zu ) ! and ! Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], ! ! where sigma-min(Zu) is the smallest singular value of the ! (2*n1*n2)-by-(2*n1*n2) matrix ! ! Zu = [ kron(In2, A11) -kron(A22', In1) ] ! [ kron(In2, B11) -kron(B22', In1) ]. ! ! Here, Inx is the identity matrix of size nx and A22' is the ! transpose of A22. kron(X, Y) is the Kronecker product between ! the matrices X and Y. ! ! When DIF(2) is small, small changes in (A, B) can cause large changes ! in the deflating subspace. An approximate (asymptotic) bound on the ! maximum angular error in the computed deflating subspaces is ! ! EPS * norm((A, B)) / DIF(2), ! ! where EPS is the machine precision. ! ! The reciprocal norm of the projectors on the left and right ! eigenspaces associated with (A11, B11) may be returned in PL and PR. ! They are computed as follows. First we compute L and R so that ! P*(A, B)*Q is block diagonal, where ! ! P = ( I -L ) n1 Q = ( I R ) n1 ! ( 0 I ) n2 and ( 0 I ) n2 ! n1 n2 n1 n2 ! ! and (L, R) is the solution to the generalized Sylvester equation ! ! A11*R - L*A22 = -A12 ! B11*R - L*B22 = -B12 ! ! Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). ! An approximate (asymptotic) bound on the average absolute error of ! the selected eigenvalues is ! ! EPS * norm((A, B)) / PL. ! ! There are also global error bounds which valid for perturbations up ! to a certain restriction: A lower bound (x) on the smallest ! F-norm(E,F) for which an eigenvalue of (A11, B11) may move and ! coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), ! (i.e. (A + E, B + F), is ! ! x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)). ! ! An approximate bound on x can be computed from DIF(1:2), PL and PR. ! ! If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed ! (L', R') and unperturbed (L, R) left and right deflating subspaces ! associated with the selected cluster in the (1,1)-blocks can be ! bounded as ! ! max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) ! max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) ! ! See LAPACK User's Guide section 4.11 or the following references ! for more information. ! ! Note that if the default method for computing the Frobenius-norm- ! based estimate DIF is not wanted (see SLATDF), then the parameter ! IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF ! (IJOB = 2 will be used)). See STGSYL for more details. ! ! Based on contributions by ! Bo Kagstrom and Peter Poromaa, Department of Computing Science, ! Umea University, S-901 87 Umea, Sweden. ! ! References ! ========== ! ! [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the ! Generalized Real Schur Form of a Regular Matrix Pair (A, B), in ! M.S. Moonen et al (eds), Linear Algebra for Large Scale and ! Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. ! ! [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified ! Eigenvalues of a Regular Matrix Pair (A, B) and Condition ! Estimation: Theory, Algorithms and Software, ! Report UMINF - 94.04, Department of Computing Science, Umea ! University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working ! Note 87. To appear in Numerical Algorithms, 1996. ! ! [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software ! for Solving the Generalized Sylvester Equation and Estimating the ! Separation between Regular Matrix Pairs, Report UMINF - 93.23, ! Department of Computing Science, Umea University, S-901 87 Umea, ! Sweden, December 1993, Revised April 1994, Also as LAPACK Working ! Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, ! 1996. ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: idifjb = 3 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, pair, swap, wantd, wantd1, wantd2, wantp INTEGER :: i, ierr, ijb, k, kase, kk, ks, liwmin, lwmin, mn2, n1, n2 REAL :: dscale, dsum, eps, rdscal, smlnum ! .. ! .. External Subroutines .. EXTERNAL slacon, slacpy, slag2, slassq, stgexc, stgsyl, xerbla ! .. ! .. External Functions .. REAL :: slamch EXTERNAL slamch ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, SIGN, SQRT ! .. ! .. Executable Statements .. ! ! Decode and test the input parameters ! info = 0 lquery = ( lwork == -1 .OR. liwork == -1 ) ! IF( ijob < 0 .OR. ijob > 5 ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -5 ELSE IF( lda < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -9 ELSE IF( ldq < 1 .OR. ( wantq .AND. ldq < n ) ) THEN info = -14 ELSE IF( ldz < 1 .OR. ( wantz .AND. ldz < n ) ) THEN info = -16 END IF ! IF( info /= 0 ) THEN CALL xerbla( 'STGSEN', -info ) RETURN END IF ! ! Get machine constants ! eps = slamch( 'P' ) smlnum = slamch( 'S' ) / eps ierr = 0 ! wantp = ijob == 1 .OR. ijob >= 4 wantd1 = ijob == 2 .OR. ijob == 4 wantd2 = ijob == 3 .OR. ijob == 5 wantd = wantd1 .OR. wantd2 ! ! Set M to the dimension of the specified pair of deflating ! subspaces. ! m = 0 pair = .false. DO k = 1, n IF( pair ) THEN pair = .false. ELSE IF( k < n ) THEN IF( a( k+1, k ) == zero ) THEN IF( select( k ) ) m = m + 1 ELSE pair = .true. IF( select( k ) .OR. select( k+1 ) ) m = m + 2 END IF ELSE IF( select( n ) ) m = m + 1 END IF END IF END DO ! IF( ijob == 1 .OR. ijob == 2 .OR. ijob == 4 ) THEN lwmin = MAX( 1, 4*n+16, 2*m*(n-m) ) liwmin = MAX( 1, n+6 ) ELSE IF( ijob == 3 .OR. ijob == 5 ) THEN lwmin = MAX( 1, 4*n+16, 4*m*(n-m) ) liwmin = MAX( 1, 2*m*(n-m), n+6 ) ELSE lwmin = MAX( 1, 4*n+16 ) liwmin = 1 END IF ! work( 1 ) = lwmin iwork( 1 ) = liwmin ! IF( lwork < lwmin .AND. .NOT.lquery ) THEN info = -22 ELSE IF( liwork < liwmin .AND. .NOT.lquery ) THEN info = -24 END IF ! IF( info /= 0 ) THEN CALL xerbla( 'STGSEN', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible. ! IF( m == n .OR. m == 0 ) THEN IF( wantp ) THEN pl = one pr = one END IF IF( wantd ) THEN dscale = zero dsum = one DO i = 1, n CALL slassq( n, a( 1, i ), 1, dscale, dsum ) CALL slassq( n, b( 1, i ), 1, dscale, dsum ) END DO dif( 1 ) = dscale*SQRT( dsum ) dif( 2 ) = dif( 1 ) END IF GO TO 60 END IF ! ! Collect the selected blocks at the top-left corner of (A, B). ! ks = 0 pair = .false. DO k = 1, n IF( pair ) THEN pair = .false. ELSE ! swap = select( k ) IF( k < n ) THEN IF( a( k+1, k ) /= zero ) THEN pair = .true. swap = swap .OR. select( k+1 ) END IF END IF ! IF( swap ) THEN ks = ks + 1 ! ! Swap the K-th block to position KS. ! Perform the reordering of diagonal blocks in (A, B) ! by orthogonal transformation matrices and update ! Q and Z accordingly (if requested): ! kk = k IF( k /= ks ) CALL stgexc( wantq, wantz, n, a, lda, b, ldb, q, ldq, & z, ldz, kk, ks, work, lwork, ierr ) ! IF( ierr > 0 ) THEN ! ! Swap is rejected: exit. ! info = 1 IF( wantp ) THEN pl = zero pr = zero END IF IF( wantd ) THEN dif( 1 ) = zero dif( 2 ) = zero END IF GO TO 60 END IF ! IF( pair ) ks = ks + 1 END IF END IF END DO IF( wantp ) THEN ! ! Solve generalized Sylvester equation for R and L ! and compute PL and PR. ! n1 = m n2 = n - m i = n1 + 1 ijb = 0 CALL slacpy( 'Full', n1, n2, a( 1, i ), lda, work, n1 ) CALL slacpy( 'Full', n1, n2, b( 1, i ), ldb, work( n1*n2+1 ), n1 ) CALL stgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work, & n1, b, ldb, b( i, i ), ldb, work( n1*n2+1 ), n1, & dscale, dif( 1 ), work( n1*n2*2+1 ), lwork-2*n1*n2, iwork, ierr ) ! ! Estimate the reciprocal of norms of "projections" onto left ! and right eigenspaces. ! rdscal = zero dsum = one CALL slassq( n1*n2, work, 1, rdscal, dsum ) pl = rdscal*SQRT( dsum ) IF( pl == zero ) THEN pl = one ELSE pl = dscale / ( SQRT( dscale*dscale / pl+pl )*SQRT( pl ) ) END IF rdscal = zero dsum = one CALL slassq( n1*n2, work( n1*n2+1 ), 1, rdscal, dsum ) pr = rdscal*SQRT( dsum ) IF( pr == zero ) THEN pr = one ELSE pr = dscale / ( SQRT( dscale*dscale / pr+pr )*SQRT( pr ) ) END IF END IF ! IF( wantd ) THEN ! ! Compute estimates of Difu and Difl. ! IF( wantd1 ) THEN n1 = m n2 = n - m i = n1 + 1 ijb = idifjb ! ! Frobenius norm-based Difu-estimate. ! CALL stgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, work, & n1, b, ldb, b( i, i ), ldb, work( n1*n2+1 ), & n1, dscale, dif( 1 ), work( 2*n1*n2+1 ), lwork-2*n1*n2, iwork, ierr ) ! ! Frobenius norm-based Difl-estimate. ! CALL stgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, work, & n2, b( i, i ), ldb, b, ldb, work( n1*n2+1 ), & n2, dscale, dif( 2 ), work( 2*n1*n2+1 ), lwork-2*n1*n2, iwork, ierr ) ELSE ! ! ! Compute 1-norm-based estimates of Difu and Difl using ! reversed communication with SLACON. In each step a ! generalized Sylvester equation or a transposed variant ! is solved. ! kase = 0 n1 = m n2 = n - m i = n1 + 1 ijb = 0 mn2 = 2*n1*n2 ! ! 1-norm-based estimate of Difu. ! 40 CONTINUE CALL slacon( mn2, work( mn2+1 ), work, iwork, dif( 1 ), kase ) IF( kase /= 0 ) THEN IF( kase == 1 ) THEN ! ! Solve generalized Sylvester equation. ! CALL stgsyl( 'N', ijb, n1, n2, a, lda, a( i, i ), lda, & work, n1, b, ldb, b( i, i ), ldb, & work( n1*n2+1 ), n1, dscale, dif( 1 ), & work( 2*n1*n2+1 ), lwork-2*n1*n2, iwork, ierr ) ELSE ! ! Solve the transposed variant. ! CALL stgsyl( 'T', ijb, n1, n2, a, lda, a( i, i ), lda, & work, n1, b, ldb, b( i, i ), ldb, & work( n1*n2+1 ), n1, dscale, dif( 1 ), & work( 2*n1*n2+1 ), lwork-2*n1*n2, iwork, ierr ) END IF GO TO 40 END IF dif( 1 ) = dscale / dif( 1 ) ! ! 1-norm-based estimate of Difl. ! 50 CONTINUE CALL slacon( mn2, work( mn2+1 ), work, iwork, dif( 2 ), kase ) IF( kase /= 0 ) THEN IF( kase == 1 ) THEN ! ! Solve generalized Sylvester equation. ! CALL stgsyl( 'N', ijb, n2, n1, a( i, i ), lda, a, lda, & work, n2, b( i, i ), ldb, b, ldb, & work( n1*n2+1 ), n2, dscale, dif( 2 ), & work( 2*n1*n2+1 ), lwork-2*n1*n2, iwork, ierr ) ELSE ! ! Solve the transposed variant. ! CALL stgsyl( 'T', ijb, n2, n1, a( i, i ), lda, a, lda, & work, n2, b( i, i ), ldb, b, ldb, & work( n1*n2+1 ), n2, dscale, dif( 2 ), & work( 2*n1*n2+1 ), lwork-2*n1*n2, iwork, ierr ) END IF GO TO 50 END IF dif( 2 ) = dscale / dif( 2 ) ! END IF END IF ! 60 CONTINUE ! ! Compute generalized eigenvalues of reordered pair (A, B) and ! normalize the generalized Schur form. ! pair = .false. DO k = 1, n IF( pair ) THEN pair = .false. ELSE ! IF( k < n ) THEN IF( a( k+1, k ) /= zero ) THEN pair = .true. END IF END IF ! IF( pair ) THEN ! ! Compute the eigenvalue(s) at position K. ! work( 1 ) = a( k, k ) work( 2 ) = a( k+1, k ) work( 3 ) = a( k, k+1 ) work( 4 ) = a( k+1, k+1 ) work( 5 ) = b( k, k ) work( 6 ) = b( k+1, k ) work( 7 ) = b( k, k+1 ) work( 8 ) = b( k+1, k+1 ) CALL slag2( work, 2, work( 5 ), 2, smlnum*eps, beta( k ), & beta( k+1 ), alphar( k ), alphar( k+1 ), alphai( k ) ) alphai( k+1 ) = -alphai( k ) ! ELSE ! IF( SIGN( one, b( k, k ) ) < zero ) THEN ! ! If B(K,K) is negative, make it positive ! DO i = 1, n a( k, i ) = -a( k, i ) b( k, i ) = -b( k, i ) q( i, k ) = -q( i, k ) END DO END IF ! alphar( k ) = a( k, k ) alphai( k ) = zero beta( k ) = b( k, k ) ! END IF END IF END DO ! work( 1 ) = lwmin iwork( 1 ) = liwmin ! RETURN ! ! End of STGSEN ! END SUBROUTINE stgsen SUBROUTINE stgsja( jobu, jobv, jobq, m, p, n, k, l, a, lda, b, & ldb, tola, tolb, alpha, beta, u, ldu, v, ldv, q, ldq, work, ncycle, 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 (LEN=1), INTENT(IN) :: jobu CHARACTER (LEN=1), INTENT(IN) :: jobv CHARACTER (LEN=1), INTENT(IN) :: jobq INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN OUT) :: p INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN OUT) :: k INTEGER, INTENT(IN OUT) :: l REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: tola REAL, INTENT(IN) :: tolb REAL, INTENT(OUT) :: alpha( * ) REAL, INTENT(OUT) :: beta( * ) REAL, INTENT(IN OUT) :: u( ldu, * ) INTEGER, INTENT(IN OUT) :: ldu REAL, INTENT(IN OUT) :: v( ldv, * ) INTEGER, INTENT(IN OUT) :: ldv REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: ncycle INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STGSJA computes the generalized singular value decomposition (GSVD) ! of two real upper triangular (or trapezoidal) matrices A and B. ! ! On entry, it is assumed that matrices A and B have the following ! forms, which may be obtained by the preprocessing subroutine SGGSVP ! from a general M-by-N matrix A and P-by-N matrix B: ! ! N-K-L K L ! A = K ( 0 A12 A13 ) if M-K-L >= 0; ! L ( 0 0 A23 ) ! M-K-L ( 0 0 0 ) ! ! N-K-L K L ! A = K ( 0 A12 A13 ) if M-K-L < 0; ! M-K ( 0 0 A23 ) ! ! N-K-L K L ! B = L ( 0 0 B13 ) ! P-L ( 0 0 0 ) ! ! where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular ! upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, ! otherwise A23 is (M-K)-by-L upper trapezoidal. ! ! On exit, ! ! U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ), ! ! where U, V and Q are orthogonal matrices, Z' denotes the transpose ! of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are ! ``diagonal'' matrices, which are of the following structures: ! ! If M-K-L >= 0, ! ! K L ! D1 = K ( I 0 ) ! L ( 0 C ) ! M-K-L ( 0 0 ) ! ! K L ! D2 = L ( 0 S ) ! P-L ( 0 0 ) ! ! N-K-L K L ! ( 0 R ) = K ( 0 R11 R12 ) K ! L ( 0 0 R22 ) L ! ! where ! ! C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), ! S = diag( BETA(K+1), ... , BETA(K+L) ), ! C**2 + S**2 = I. ! ! R is stored in A(1:K+L,N-K-L+1:N) on exit. ! ! If M-K-L < 0, ! ! K M-K K+L-M ! D1 = K ( I 0 0 ) ! M-K ( 0 C 0 ) ! ! K M-K K+L-M ! D2 = M-K ( 0 S 0 ) ! K+L-M ( 0 0 I ) ! P-L ( 0 0 0 ) ! ! N-K-L K M-K K+L-M ! ( 0 R ) = K ( 0 R11 R12 R13 ) ! M-K ( 0 0 R22 R23 ) ! K+L-M ( 0 0 0 R33 ) ! ! where ! C = diag( ALPHA(K+1), ... , ALPHA(M) ), ! S = diag( BETA(K+1), ... , BETA(M) ), ! C**2 + S**2 = I. ! ! R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored ! ( 0 R22 R23 ) ! in B(M-K+1:L,N+M-K-L+1:N) on exit. ! ! The computation of the orthogonal transformation matrices U, V or Q ! is optional. These matrices may either be formed explicitly, or they ! may be postmultiplied into input matrices U1, V1, or Q1. ! ! Arguments ! ========= ! ! JOBU (input) CHARACTER*1 ! = 'U': U must contain an orthogonal matrix U1 on entry, and ! the product U1*U is returned; ! = 'I': U is initialized to the unit matrix, and the ! orthogonal matrix U is returned; ! = 'N': U is not computed. ! ! JOBV (input) CHARACTER*1 ! = 'V': V must contain an orthogonal matrix V1 on entry, and ! the product V1*V is returned; ! = 'I': V is initialized to the unit matrix, and the ! orthogonal matrix V is returned; ! = 'N': V is not computed. ! ! JOBQ (input) CHARACTER*1 ! = 'Q': Q must contain an orthogonal matrix Q1 on entry, and ! the product Q1*Q is returned; ! = 'I': Q is initialized to the unit matrix, and the ! orthogonal matrix Q is returned; ! = 'N': Q is not computed. ! ! M (input) INTEGER ! The number of rows of the matrix A. M >= 0. ! ! P (input) INTEGER ! The number of rows of the matrix B. P >= 0. ! ! N (input) INTEGER ! The number of columns of the matrices A and B. N >= 0. ! ! K (input) INTEGER ! L (input) INTEGER ! K and L specify the subblocks in the input matrices A and B: ! A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N) ! of A and B, whose GSVD is going to be computed by STGSJA. ! See Further details. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the M-by-N matrix A. ! On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular ! matrix R or part of R. See Purpose for details. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! B (input/output) REAL array, dimension (LDB,N) ! On entry, the P-by-N matrix B. ! On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains ! a part of R. See Purpose for details. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,P). ! ! TOLA (input) REAL ! TOLB (input) REAL ! TOLA and TOLB are the convergence criteria for the Jacobi- ! Kogbetliantz iteration procedure. Generally, they are the ! same as used in the preprocessing step, say ! TOLA = max(M,N)*norm(A)*MACHEPS, ! TOLB = max(P,N)*norm(B)*MACHEPS. ! ! ALPHA (output) REAL array, dimension (N) ! BETA (output) REAL array, dimension (N) ! On exit, ALPHA and BETA contain the generalized singular ! value pairs of A and B; ! ALPHA(1:K) = 1, ! BETA(1:K) = 0, ! and if M-K-L >= 0, ! ALPHA(K+1:K+L) = diag(C), ! BETA(K+1:K+L) = diag(S), ! or if M-K-L < 0, ! ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 ! BETA(K+1:M) = S, BETA(M+1:K+L) = 1. ! Furthermore, if K+L < N, ! ALPHA(K+L+1:N) = 0 and ! BETA(K+L+1:N) = 0. ! ! U (input/output) REAL array, dimension (LDU,M) ! On entry, if JOBU = 'U', U must contain a matrix U1 (usually ! the orthogonal matrix returned by SGGSVP). ! On exit, ! if JOBU = 'I', U contains the orthogonal matrix U; ! if JOBU = 'U', U contains the product U1*U. ! If JOBU = 'N', U is not referenced. ! ! LDU (input) INTEGER ! The leading dimension of the array U. LDU >= max(1,M) if ! JOBU = 'U'; LDU >= 1 otherwise. ! ! V (input/output) REAL array, dimension (LDV,P) ! On entry, if JOBV = 'V', V must contain a matrix V1 (usually ! the orthogonal matrix returned by SGGSVP). ! On exit, ! if JOBV = 'I', V contains the orthogonal matrix V; ! if JOBV = 'V', V contains the product V1*V. ! If JOBV = 'N', V is not referenced. ! ! LDV (input) INTEGER ! The leading dimension of the array V. LDV >= max(1,P) if ! JOBV = 'V'; LDV >= 1 otherwise. ! ! Q (input/output) REAL array, dimension (LDQ,N) ! On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually ! the orthogonal matrix returned by SGGSVP). ! On exit, ! if JOBQ = 'I', Q contains the orthogonal matrix Q; ! if JOBQ = 'Q', Q contains the product Q1*Q. ! If JOBQ = 'N', Q is not referenced. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. LDQ >= max(1,N) if ! JOBQ = 'Q'; LDQ >= 1 otherwise. ! ! WORK (workspace) REAL array, dimension (2*N) ! ! NCYCLE (output) INTEGER ! The number of cycles required for convergence. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value. ! = 1: the procedure does not converge after MAXIT cycles. ! ! Internal Parameters ! =================== ! ! MAXIT INTEGER ! MAXIT specifies the total loops that the iterative procedure ! may take. If after MAXIT cycles, the routine fails to ! converge, we return INFO = 1. ! ! Further Details ! =============== ! ! STGSJA essentially uses a variant of Kogbetliantz algorithm to reduce ! min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L ! matrix B13 to the form: ! ! U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1, ! ! where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose ! of Z. C1 and S1 are diagonal matrices satisfying ! ! C1**2 + S1**2 = I, ! ! and R1 is an L-by-L nonsingular upper triangular matrix. ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: maxit = 40 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. ! LOGICAL :: initq, initu, initv, upper, wantq, wantu, wantv INTEGER :: i, j, kcycle REAL :: a1, a2, a3, b1, b2, b3, csq, csu, csv, error, & gamma, rwk, snq, snu, snv, ssmin ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL scopy, slags2, slapll, slartg, slaset, srot, sscal, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN ! .. ! .. Executable Statements .. ! ! Decode and test the input parameters ! initu = lsame( jobu, 'I' ) wantu = initu .OR. lsame( jobu, 'U' ) ! initv = lsame( jobv, 'I' ) wantv = initv .OR. lsame( jobv, 'V' ) ! initq = lsame( jobq, 'I' ) wantq = initq .OR. lsame( jobq, 'Q' ) ! info = 0 IF( .NOT.( initu .OR. wantu .OR. lsame( jobu, 'N' ) ) ) THEN info = -1 ELSE IF( .NOT.( initv .OR. wantv .OR. lsame( jobv, 'N' ) ) ) THEN info = -2 ELSE IF( .NOT.( initq .OR. wantq .OR. lsame( jobq, 'N' ) ) ) THEN info = -3 ELSE IF( m < 0 ) THEN info = -4 ELSE IF( p < 0 ) THEN info = -5 ELSE IF( n < 0 ) THEN info = -6 ELSE IF( lda < MAX( 1, m ) ) THEN info = -10 ELSE IF( ldb < MAX( 1, p ) ) THEN info = -12 ELSE IF( ldu < 1 .OR. ( wantu .AND. ldu < m ) ) THEN info = -18 ELSE IF( ldv < 1 .OR. ( wantv .AND. ldv < p ) ) THEN info = -20 ELSE IF( ldq < 1 .OR. ( wantq .AND. ldq < n ) ) THEN info = -22 END IF IF( info /= 0 ) THEN CALL xerbla( 'STGSJA', -info ) RETURN END IF ! ! Initialize U, V and Q, if necessary ! IF( initu ) CALL slaset( 'Full', m, m, zero, one, u, ldu ) IF( initv ) CALL slaset( 'Full', p, p, zero, one, v, ldv ) IF( initq ) CALL slaset( 'Full', n, n, zero, one, q, ldq ) ! ! Loop until convergence ! upper = .false. DO kcycle = 1, maxit ! upper = .NOT.upper ! DO i = 1, l - 1 DO j = i + 1, l ! a1 = zero a2 = zero a3 = zero IF( k+i <= m ) a1 = a( k+i, n-l+i ) IF( k+j <= m ) a3 = a( k+j, n-l+j ) ! b1 = b( i, n-l+i ) b3 = b( j, n-l+j ) ! IF( upper ) THEN IF( k+i <= m ) a2 = a( k+i, n-l+j ) b2 = b( i, n-l+j ) ELSE IF( k+j <= m ) a2 = a( k+j, n-l+i ) b2 = b( j, n-l+i ) END IF ! CALL slags2( upper, a1, a2, a3, b1, b2, b3, csu, snu, & csv, snv, csq, snq ) ! ! Update (K+I)-th and (K+J)-th rows of matrix A: U'*A ! IF( k+j <= m ) CALL srot( l, a( k+j, n-l+1 ), lda, a( k+i, n-l+1 ), & lda, csu, snu ) ! ! Update I-th and J-th rows of matrix B: V'*B ! CALL srot( l, b( j, n-l+1 ), ldb, b( i, n-l+1 ), ldb, csv, snv ) ! ! Update (N-L+I)-th and (N-L+J)-th columns of matrices ! A and B: A*Q and B*Q ! CALL srot( MIN( k+l, m ), a( 1, n-l+j ), 1, a( 1, n-l+i ), 1, csq, snq ) ! CALL srot( l, b( 1, n-l+j ), 1, b( 1, n-l+i ), 1, csq, snq ) ! IF( upper ) THEN IF( k+i <= m ) a( k+i, n-l+j ) = zero b( i, n-l+j ) = zero ELSE IF( k+j <= m ) a( k+j, n-l+i ) = zero b( j, n-l+i ) = zero END IF ! ! Update orthogonal matrices U, V, Q, if desired. ! IF( wantu .AND. k+j <= m ) & CALL srot( m, u( 1, k+j ), 1, u( 1, k+i ), 1, csu, snu ) ! IF( wantv ) CALL srot( p, v( 1, j ), 1, v( 1, i ), 1, csv, snv ) ! IF( wantq ) CALL srot( n, q( 1, n-l+j ), 1, q( 1, n-l+i ), 1, csq, & snq ) ! END DO END DO ! IF( .NOT.upper ) THEN ! ! The matrices A13 and B13 were lower triangular at the start ! of the cycle, and are now upper triangular. ! ! Convergence test: test the parallelism of the corresponding ! rows of A and B. ! error = zero DO i = 1, MIN( l, m-k ) CALL scopy( l-i+1, a( k+i, n-l+i ), lda, work, 1 ) CALL scopy( l-i+1, b( i, n-l+i ), ldb, work( l+1 ), 1 ) CALL slapll( l-i+1, work, 1, work( l+1 ), 1, ssmin ) error = MAX( error, ssmin ) END DO ! IF( ABS( error ) <= MIN( tola, tolb ) ) GO TO 50 END IF ! ! End of cycle loop ! END DO ! ! The algorithm has not converged after MAXIT cycles. ! info = 1 GO TO 100 ! 50 CONTINUE ! ! If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. ! Compute the generalized singular value pairs (ALPHA, BETA), and ! set the triangular matrix R to array A. ! DO i = 1, k alpha( i ) = one beta( i ) = zero END DO ! DO i = 1, MIN( l, m-k ) ! a1 = a( k+i, n-l+i ) b1 = b( i, n-l+i ) ! IF( a1 /= zero ) THEN gamma = b1 / a1 ! ! change sign if necessary ! IF( gamma < zero ) THEN CALL sscal( l-i+1, -one, b( i, n-l+i ), ldb ) IF( wantv ) CALL sscal( p, -one, v( 1, i ), 1 ) END IF ! CALL slartg( ABS( gamma ), one, beta( k+i ), alpha( k+i ), rwk ) ! IF( alpha( k+i ) >= beta( k+i ) ) THEN CALL sscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ), lda ) ELSE CALL sscal( l-i+1, one / beta( k+i ), b( i, n-l+i ), ldb ) CALL scopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ), lda ) END IF ! ELSE ! alpha( k+i ) = zero beta( k+i ) = one CALL scopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ), lda ) ! END IF ! END DO ! ! Post-assignment ! DO i = m + 1, k + l alpha( i ) = zero beta( i ) = one END DO ! IF( k+l < n ) THEN DO i = k + l + 1, n alpha( i ) = zero beta( i ) = zero END DO END IF ! 100 CONTINUE ncycle = kcycle RETURN ! ! End of STGSJA ! END SUBROUTINE stgsja SUBROUTINE stgsna( job, howmny, select, n, a, lda, b, ldb, vl, & ldvl, vr, ldvr, s, dif, mm, m, work, lwork, 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 (LEN=1), INTENT(IN) :: job CHARACTER (LEN=1), INTENT(IN) :: howmny LOGICAL, INTENT(IN) :: select( * ) INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: vl( ldvl, * ) INTEGER, INTENT(IN OUT) :: ldvl REAL, INTENT(IN) :: vr( ldvr, * ) INTEGER, INTENT(IN OUT) :: ldvr REAL, INTENT(OUT) :: s( * ) REAL, INTENT(OUT) :: dif( * ) INTEGER, INTENT(IN) :: mm INTEGER, INTENT(OUT) :: m REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STGSNA estimates reciprocal condition numbers for specified ! eigenvalues and/or eigenvectors of a matrix pair (A, B) in ! generalized real Schur canonical form (or of any matrix pair ! (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where ! Z' denotes the transpose of Z. ! ! (A, B) must be in generalized real Schur form (as returned by SGGES), ! i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal ! blocks. B is upper triangular. ! ! ! Arguments ! ========= ! ! JOB (input) CHARACTER*1 ! Specifies whether condition numbers are required for ! eigenvalues (S) or eigenvectors (DIF): ! = 'E': for eigenvalues only (S); ! = 'V': for eigenvectors only (DIF); ! = 'B': for both eigenvalues and eigenvectors (S and DIF). ! ! HOWMNY (input) CHARACTER*1 ! = 'A': compute condition numbers for all eigenpairs; ! = 'S': compute condition numbers for selected eigenpairs ! specified by the array SELECT. ! ! SELECT (input) LOGICAL array, dimension (N) ! If HOWMNY = 'S', SELECT specifies the eigenpairs for which ! condition numbers are required. To select condition numbers ! for the eigenpair corresponding to a real eigenvalue w(j), ! SELECT(j) must be set to .TRUE.. To select condition numbers ! corresponding to a complex conjugate pair of eigenvalues w(j) ! and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be ! set to .TRUE.. ! If HOWMNY = 'A', SELECT is not referenced. ! ! N (input) INTEGER ! The order of the square matrix pair (A, B). N >= 0. ! ! A (input) REAL array, dimension (LDA,N) ! The upper quasi-triangular matrix A in the pair (A,B). ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! B (input) REAL array, dimension (LDB,N) ! The upper triangular matrix B in the pair (A,B). ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! VL (input) REAL array, dimension (LDVL,M) ! If JOB = 'E' or 'B', VL must contain left eigenvectors of ! (A, B), corresponding to the eigenpairs specified by HOWMNY ! and SELECT. The eigenvectors must be stored in consecutive ! columns of VL, as returned by STGEVC. ! If JOB = 'V', VL is not referenced. ! ! LDVL (input) INTEGER ! The leading dimension of the array VL. LDVL >= 1. ! If JOB = 'E' or 'B', LDVL >= N. ! ! VR (input) REAL array, dimension (LDVR,M) ! If JOB = 'E' or 'B', VR must contain right eigenvectors of ! (A, B), corresponding to the eigenpairs specified by HOWMNY ! and SELECT. The eigenvectors must be stored in consecutive ! columns ov VR, as returned by STGEVC. ! If JOB = 'V', VR is not referenced. ! ! LDVR (input) INTEGER ! The leading dimension of the array VR. LDVR >= 1. ! If JOB = 'E' or 'B', LDVR >= N. ! ! S (output) REAL array, dimension (MM) ! If JOB = 'E' or 'B', the reciprocal condition numbers of the ! selected eigenvalues, stored in consecutive elements of the ! array. For a complex conjugate pair of eigenvalues two ! consecutive elements of S are set to the same value. Thus ! S(j), DIF(j), and the j-th columns of VL and VR all ! correspond to the same eigenpair (but not in general the ! j-th eigenpair, unless all eigenpairs are selected). ! If JOB = 'V', S is not referenced. ! ! DIF (output) REAL array, dimension (MM) ! If JOB = 'V' or 'B', the estimated reciprocal condition ! numbers of the selected eigenvectors, stored in consecutive ! elements of the array. For a complex eigenvector two ! consecutive elements of DIF are set to the same value. If ! the eigenvalues cannot be reordered to compute DIF(j), DIF(j) ! is set to 0; this can only occur when the true value would be ! very small anyway. ! If JOB = 'E', DIF is not referenced. ! ! MM (input) INTEGER ! The number of elements in the arrays S and DIF. MM >= M. ! ! M (output) INTEGER ! The number of elements of the arrays S and DIF used to store ! the specified condition numbers; for each selected real ! eigenvalue one element is used, and for each selected complex ! conjugate pair of eigenvalues, two elements are used. ! If HOWMNY = 'A', M is set to N. ! ! WORK (workspace/output) REAL array, dimension (LWORK) ! If JOB = 'E', WORK is not referenced. Otherwise, ! on exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. LWORK >= N. ! If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16. ! ! 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 (N + 6) ! If JOB = 'E', IWORK is not referenced. ! ! INFO (output) INTEGER ! =0: Successful exit ! <0: If INFO = -i, the i-th argument had an illegal value ! ! ! Further Details ! =============== ! ! The reciprocal of the condition number of a generalized eigenvalue ! w = (a, b) is defined as ! ! S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v)) ! ! where u and v are the left and right eigenvectors of (A, B) ! corresponding to w; |z| denotes the absolute value of the complex ! number, and norm(u) denotes the 2-norm of the vector u. ! The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv) ! of the matrix pair (A, B). If both a and b equal zero, then (A B) is ! singular and S(I) = -1 is returned. ! ! An approximate error bound on the chordal distance between the i-th ! computed generalized eigenvalue w and the corresponding exact ! eigenvalue lambda is ! ! chord(w, lambda) <= EPS * norm(A, B) / S(I) ! ! where EPS is the machine precision. ! ! The reciprocal of the condition number DIF(i) of right eigenvector u ! and left eigenvector v corresponding to the generalized eigenvalue w ! is defined as follows: ! ! a) If the i-th eigenvalue w = (a,b) is real ! ! Suppose U and V are orthogonal transformations such that ! ! U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1 ! ( 0 S22 ),( 0 T22 ) n-1 ! 1 n-1 1 n-1 ! ! Then the reciprocal condition number DIF(i) is ! ! Difl((a, b), (S22, T22)) = sigma-min( Zl ), ! ! where sigma-min(Zl) denotes the smallest singular value of the ! 2(n-1)-by-2(n-1) matrix ! ! Zl = [ kron(a, In-1) -kron(1, S22) ] ! [ kron(b, In-1) -kron(1, T22) ] . ! ! Here In-1 is the identity matrix of size n-1. kron(X, Y) is the ! Kronecker product between the matrices X and Y. ! ! Note that if the default method for computing DIF(i) is wanted ! (see SLATDF), then the parameter DIFDRI (see below) should be ! changed from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). ! See STGSYL for more details. ! ! b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair, ! ! Suppose U and V are orthogonal transformations such that ! ! U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2 ! ( 0 S22 ),( 0 T22) n-2 ! 2 n-2 2 n-2 ! ! and (S11, T11) corresponds to the complex conjugate eigenvalue ! pair (w, conjg(w)). There exist unitary matrices U1 and V1 such ! that ! ! U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 ) ! ( 0 s22 ) ( 0 t22 ) ! ! where the generalized eigenvalues w = s11/t11 and ! conjg(w) = s22/t22. ! ! Then the reciprocal condition number DIF(i) is bounded by ! ! min( d1, max( 1, |real(s11)/real(s22)| )*d2 ) ! ! where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where ! Z1 is the complex 2-by-2 matrix ! ! Z1 = [ s11 -s22 ] ! [ t11 -t22 ], ! ! This is done by computing (using real arithmetic) the ! roots of the characteristical polynomial det(Z1' * Z1 - lambda I), ! where Z1' denotes the conjugate transpose of Z1 and det(X) denotes ! the determinant of X. ! ! and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an ! upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2) ! ! Z2 = [ kron(S11', In-2) -kron(I2, S22) ] ! [ kron(T11', In-2) -kron(I2, T22) ] ! ! Note that if the default method for computing DIF is wanted (see ! SLATDF), then the parameter DIFDRI (see below) should be changed ! from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). See STGSYL ! for more details. ! ! For each eigenvalue/vector specified by SELECT, DIF stores a ! Frobenius norm-based estimate of Difl. ! ! An approximate error bound for the i-th computed eigenvector VL(i) or ! VR(i) is given by ! ! EPS * norm(A, B) / DIF(i). ! ! See ref. [2-3] for more details and further references. ! ! Based on contributions by ! Bo Kagstrom and Peter Poromaa, Department of Computing Science, ! Umea University, S-901 87 Umea, Sweden. ! ! References ! ========== ! ! [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the ! Generalized Real Schur Form of a Regular Matrix Pair (A, B), in ! M.S. Moonen et al (eds), Linear Algebra for Large Scale and ! Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. ! ! [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified ! Eigenvalues of a Regular Matrix Pair (A, B) and Condition ! Estimation: Theory, Algorithms and Software, ! Report UMINF - 94.04, Department of Computing Science, Umea ! University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working ! Note 87. To appear in Numerical Algorithms, 1996. ! ! [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software ! for Solving the Generalized Sylvester Equation and Estimating the ! Separation between Regular Matrix Pairs, Report UMINF - 93.23, ! Department of Computing Science, Umea University, S-901 87 Umea, ! Sweden, December 1993, Revised April 1994, Also as LAPACK Working ! Note 75. To appear in ACM Trans. on Math. Software, Vol 22, ! No 1, 1996. ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: difdri = 3 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 REAL, PARAMETER :: four = 4.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, pair, somcon, wantbh, wantdf, wants INTEGER :: i, ierr, ifst, ilst, iz, k, ks, lwmin, n1, n2 REAL :: alphai, alphar, alprqt, beta, c1, c2, cond, & eps, lnrm, rnrm, root1, root2, scale, smlnum, & tmpii, tmpir, tmpri, tmprr, uhav, uhavi, uhbv, uhbvi ! .. ! .. Local Arrays .. REAL :: dummy( 1 ), dummy1( 1 ) ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: sdot, slamch, slapy2, snrm2 EXTERNAL lsame, sdot, slamch, slapy2, snrm2 ! .. ! .. External Subroutines .. EXTERNAL sgemv, slacpy, slag2, stgexc, stgsyl, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN, SQRT ! .. ! .. Executable Statements .. ! ! Decode and test the input parameters ! wantbh = lsame( job, 'B' ) wants = lsame( job, 'E' ) .OR. wantbh wantdf = lsame( job, 'V' ) .OR. wantbh ! somcon = lsame( howmny, 'S' ) ! info = 0 lquery = ( lwork == -1 ) ! IF( lsame( job, 'V' ) .OR. lsame( job, 'B' ) ) THEN lwmin = MAX( 1, 2*n*(n+2)+16 ) ELSE lwmin = 1 END IF ! IF( .NOT.wants .AND. .NOT.wantdf ) THEN info = -1 ELSE IF( .NOT.lsame( howmny, 'A' ) .AND. .NOT.somcon ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( lda < MAX( 1, n ) ) THEN info = -6 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -8 ELSE IF( wants .AND. ldvl < n ) THEN info = -10 ELSE IF( wants .AND. ldvr < n ) THEN info = -12 ELSE ! ! Set M to the number of eigenpairs for which condition numbers ! are required, and test MM. ! IF( somcon ) THEN m = 0 pair = .false. DO k = 1, n IF( pair ) THEN pair = .false. ELSE IF( k < n ) THEN IF( a( k+1, k ) == zero ) THEN IF( select( k ) ) m = m + 1 ELSE pair = .true. IF( select( k ) .OR. select( k+1 ) ) m = m + 2 END IF ELSE IF( select( n ) ) m = m + 1 END IF END IF END DO ELSE m = n END IF ! IF( mm < m ) THEN info = -15 ELSE IF( lwork < lwmin .AND. .NOT.lquery ) THEN info = -18 ! ELSE IF( WANTDF .AND. LWORK.LT.2*N*( N+2 )+16 ) THEN ! INFO = -18 END IF END IF ! IF( info == 0 ) THEN work( 1 ) = lwmin END IF ! IF( info /= 0 ) THEN CALL xerbla( 'STGSNA', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Get machine constants ! eps = slamch( 'P' ) smlnum = slamch( 'S' ) / eps ks = 0 pair = .false. ! DO k = 1, n ! ! Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block. ! IF( pair ) THEN pair = .false. CYCLE ELSE IF( k < n ) pair = a( k+1, k ) /= zero END IF ! ! Determine whether condition numbers are required for the k-th ! eigenpair. ! IF( somcon ) THEN IF( pair ) THEN IF( .NOT.select( k ) .AND. .NOT.select( k+1 ) ) CYCLE ELSE IF( .NOT.select( k ) ) CYCLE END IF END IF ! ks = ks + 1 ! IF( wants ) THEN ! ! Compute the reciprocal condition number of the k-th ! eigenvalue. ! IF( pair ) THEN ! ! Complex eigenvalue pair. ! rnrm = slapy2( snrm2( n, vr( 1, ks ), 1 ), & snrm2( n, vr( 1, ks+1 ), 1 ) ) lnrm = slapy2( snrm2( n, vl( 1, ks ), 1 ), & snrm2( n, vl( 1, ks+1 ), 1 ) ) CALL sgemv( 'N', n, n, one, a, lda, vr( 1, ks ), 1, zero, work, 1 ) tmprr = sdot( n, work, 1, vl( 1, ks ), 1 ) tmpri = sdot( n, work, 1, vl( 1, ks+1 ), 1 ) CALL sgemv( 'N', n, n, one, a, lda, vr( 1, ks+1 ), 1, zero, work, 1 ) tmpii = sdot( n, work, 1, vl( 1, ks+1 ), 1 ) tmpir = sdot( n, work, 1, vl( 1, ks ), 1 ) uhav = tmprr + tmpii uhavi = tmpir - tmpri CALL sgemv( 'N', n, n, one, b, ldb, vr( 1, ks ), 1, zero, work, 1 ) tmprr = sdot( n, work, 1, vl( 1, ks ), 1 ) tmpri = sdot( n, work, 1, vl( 1, ks+1 ), 1 ) CALL sgemv( 'N', n, n, one, b, ldb, vr( 1, ks+1 ), 1, zero, work, 1 ) tmpii = sdot( n, work, 1, vl( 1, ks+1 ), 1 ) tmpir = sdot( n, work, 1, vl( 1, ks ), 1 ) uhbv = tmprr + tmpii uhbvi = tmpir - tmpri uhav = slapy2( uhav, uhavi ) uhbv = slapy2( uhbv, uhbvi ) cond = slapy2( uhav, uhbv ) s( ks ) = cond / ( rnrm*lnrm ) s( ks+1 ) = s( ks ) ! ELSE ! ! Real eigenvalue. ! rnrm = snrm2( n, vr( 1, ks ), 1 ) lnrm = snrm2( n, vl( 1, ks ), 1 ) CALL sgemv( 'N', n, n, one, a, lda, vr( 1, ks ), 1, zero, work, 1 ) uhav = sdot( n, work, 1, vl( 1, ks ), 1 ) CALL sgemv( 'N', n, n, one, b, ldb, vr( 1, ks ), 1, zero, work, 1 ) uhbv = sdot( n, work, 1, vl( 1, ks ), 1 ) cond = slapy2( uhav, uhbv ) IF( cond == zero ) THEN s( ks ) = -one ELSE s( ks ) = cond / ( rnrm*lnrm ) END IF END IF END IF ! IF( wantdf ) THEN IF( n == 1 ) THEN dif( ks ) = slapy2( a( 1, 1 ), b( 1, 1 ) ) CYCLE END IF ! ! Estimate the reciprocal condition number of the k-th ! eigenvectors. IF( pair ) THEN ! ! Copy the 2-by 2 pencil beginning at (A(k,k), B(k, k)). ! Compute the eigenvalue(s) at position K. ! work( 1 ) = a( k, k ) work( 2 ) = a( k+1, k ) work( 3 ) = a( k, k+1 ) work( 4 ) = a( k+1, k+1 ) work( 5 ) = b( k, k ) work( 6 ) = b( k+1, k ) work( 7 ) = b( k, k+1 ) work( 8 ) = b( k+1, k+1 ) CALL slag2( work, 2, work( 5 ), 2, smlnum*eps, beta, & dummy1( 1 ), alphar, dummy( 1 ), alphai ) alprqt = one c1 = two*( alphar*alphar+alphai*alphai+beta*beta ) c2 = four*beta*beta*alphai*alphai root1 = c1 + SQRT( c1*c1-4.0*c2 ) root2 = c2 / root1 root1 = root1 / two cond = MIN( SQRT( root1 ), SQRT( root2 ) ) END IF ! ! Copy the matrix (A, B) to the array WORK and swap the ! diagonal block beginning at A(k,k) to the (1,1) position. ! CALL slacpy( 'Full', n, n, a, lda, work, n ) CALL slacpy( 'Full', n, n, b, ldb, work( n*n+1 ), n ) ifst = k ilst = 1 ! CALL stgexc( .false., .false., n, work, n, work( n*n+1 ), n, & dummy, 1, dummy1, 1, ifst, ilst, work( n*n*2+1 ), lwork-2*n*n, ierr ) ! IF( ierr > 0 ) THEN ! ! Ill-conditioned problem - swap rejected. ! dif( ks ) = zero ELSE ! ! Reordering successful, solve generalized Sylvester ! equation for R and L, ! A22 * R - L * A11 = A12 ! B22 * R - L * B11 = B12, ! and compute estimate of Difl((A11,B11), (A22, B22)). ! n1 = 1 IF( work( 2 ) /= zero ) n1 = 2 n2 = n - n1 IF( n2 == 0 ) THEN dif( ks ) = cond ELSE i = n*n + 1 iz = 2*n*n + 1 CALL stgsyl( 'N', difdri, n2, n1, work( n*n1+n1+1 ), & n, work, n, work( n1+1 ), n, work( n*n1+n1+i ), n, work( i ), n, & work( n1+i ), n, scale, dif( ks ), & work( iz+1 ), lwork-2*n*n, iwork, ierr ) ! IF( pair ) dif( ks ) = MIN( MAX( one, alprqt )*dif( ks ), & cond ) END IF END IF IF( pair ) dif( ks+1 ) = dif( ks ) END IF IF( pair ) ks = ks + 1 ! END DO work( 1 ) = lwmin RETURN ! ! End of STGSNA ! END SUBROUTINE stgsna SUBROUTINE stgsy2( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d, & ldd, e, lde, f, ldf, scale, rdsum, rdscal, iwork, pq, 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 .. CHARACTER (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: ijob INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(IN) :: d( ldd, * ) INTEGER, INTENT(IN OUT) :: ldd REAL, INTENT(IN) :: e( lde, * ) INTEGER, INTENT(IN OUT) :: lde REAL, INTENT(IN OUT) :: f( ldf, * ) INTEGER, INTENT(IN OUT) :: ldf REAL, INTENT(OUT) :: scale REAL, INTENT(IN OUT) :: rdsum REAL, INTENT(IN OUT) :: rdscal INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: pq INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STGSY2 solves the generalized Sylvester equation: ! ! A * R - L * B = scale * C (1) ! D * R - L * E = scale * F, ! ! using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices, ! (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, ! N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E) ! must be in generalized Schur canonical form, i.e. A, B are upper ! quasi triangular and D, E are upper triangular. The solution (R, L) ! overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor ! chosen to avoid overflow. ! ! In matrix notation solving equation (1) corresponds to solve ! Z*x = scale*b, where Z is defined as ! ! Z = [ kron(In, A) -kron(B', Im) ] (2) ! [ kron(In, D) -kron(E', Im) ], ! ! Ik is the identity matrix of size k and X' is the transpose of X. ! kron(X, Y) is the Kronecker product between the matrices X and Y. ! In the process of solving (1), we solve a number of such systems ! where Dim(In), Dim(In) = 1 or 2. ! ! If TRANS = 'T', solve the transposed system Z'*y = scale*b for y, ! which is equivalent to solve for R and L in ! ! A' * R + D' * L = scale * C (3) ! R * B' + L * E' = scale * -F ! ! This case is used to compute an estimate of Dif[(A, D), (B, E)] = ! sigma_min(Z) using reverse communicaton with SLACON. ! ! STGSY2 also (IJOB >= 1) contributes to the computation in STGSYL ! of an upper bound on the separation between to matrix pairs. Then ! the input (A, D), (B, E) are sub-pencils of the matrix pair in ! STGSYL. See STGSYL for details. ! ! Arguments ! ========= ! ! TRANS (input) CHARACTER ! = 'N', solve the generalized Sylvester equation (1). ! = 'T': solve the 'transposed' system (3). ! ! IJOB (input) INTEGER ! Specifies what kind of functionality to be performed. ! = 0: solve (1) only. ! = 1: A contribution from this subsystem to a Frobenius ! norm-based estimate of the separation between two matrix ! pairs is computed. (look ahead strategy is used). ! = 2: A contribution from this subsystem to a Frobenius ! norm-based estimate of the separation between two matrix ! pairs is computed. (SGECON on sub-systems is used.) ! Not referenced if TRANS = 'T'. ! ! M (input) INTEGER ! On entry, M specifies the order of A and D, and the row ! dimension of C, F, R and L. ! ! N (input) INTEGER ! On entry, N specifies the order of B and E, and the column ! dimension of C, F, R and L. ! ! A (input) REAL array, dimension (LDA, M) ! On entry, A contains an upper quasi triangular matrix. ! ! LDA (input) INTEGER ! The leading dimension of the matrix A. LDA >= max(1, M). ! ! B (input) REAL array, dimension (LDB, N) ! On entry, B contains an upper quasi triangular matrix. ! ! LDB (input) INTEGER ! The leading dimension of the matrix B. LDB >= max(1, N). ! ! C (input/ output) REAL array, dimension (LDC, N) ! On entry, C contains the right-hand-side of the first matrix ! equation in (1). ! On exit, if IJOB = 0, C has been overwritten by the ! solution R. ! ! LDC (input) INTEGER ! The leading dimension of the matrix C. LDC >= max(1, M). ! ! D (input) REAL array, dimension (LDD, M) ! On entry, D contains an upper triangular matrix. ! ! LDD (input) INTEGER ! The leading dimension of the matrix D. LDD >= max(1, M). ! ! E (input) REAL array, dimension (LDE, N) ! On entry, E contains an upper triangular matrix. ! ! LDE (input) INTEGER ! The leading dimension of the matrix E. LDE >= max(1, N). ! ! F (input/ output) REAL array, dimension (LDF, N) ! On entry, F contains the right-hand-side of the second matrix ! equation in (1). ! On exit, if IJOB = 0, F has been overwritten by the ! solution L. ! ! LDF (input) INTEGER ! The leading dimension of the matrix F. LDF >= max(1, M). ! ! SCALE (output) REAL ! On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions ! R and L (C and F on entry) will hold the solutions to a ! slightly perturbed system but the input matrices A, B, D and ! E have not been changed. If SCALE = 0, R and L will hold the ! solutions to the homogeneous system with C = F = 0. Normally, ! SCALE = 1. ! ! RDSUM (input/output) REAL ! On entry, the sum of squares of computed contributions to ! the Dif-estimate under computation by STGSYL, where the ! scaling factor RDSCAL (see below) has been factored out. ! On exit, the corresponding sum of squares updated with the ! contributions from the current sub-system. ! If TRANS = 'T' RDSUM is not touched. ! NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL. ! ! RDSCAL (input/output) REAL ! On entry, scaling factor used to prevent overflow in RDSUM. ! On exit, RDSCAL is updated w.r.t. the current contributions ! in RDSUM. ! If TRANS = 'T', RDSCAL is not touched. ! NOTE: RDSCAL only makes sense when STGSY2 is called by ! STGSYL. ! ! IWORK (workspace) INTEGER array, dimension (M+N+2) ! ! PQ (output) INTEGER ! On exit, the number of subsystems (of size 2-by-2, 4-by-4 and ! 8-by-8) solved by this routine. ! ! INFO (output) INTEGER ! On exit, if INFO is set to ! =0: Successful exit ! <0: If INFO = -i, the i-th argument had an illegal value. ! >0: The matrix pairs (A, D) and (B, E) have common or very ! close eigenvalues. ! ! Further Details ! =============== ! ! Based on contributions by ! Bo Kagstrom and Peter Poromaa, Department of Computing Science, ! Umea University, S-901 87 Umea, Sweden. ! ! ===================================================================== ! ! .. Parameters .. INTEGER, PARAMETER :: ldz = 8 REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: notran INTEGER :: i, ie, ierr, ii, is, isp1, j, je, jj, js, jsp1, & k, mb, nb, p, q, zdim REAL :: alpha, scaloc ! .. ! .. Local Arrays .. INTEGER :: ipiv( ldz ), jpiv( ldz ) REAL :: rhs( ldz ), z( ldz, ldz ) ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, sgemm, sgemv, sger, sgesc2, & sgetc2, sscal, slatdf, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Decode and test input parameters ! info = 0 ierr = 0 notran = lsame( trans, 'N' ) IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) ) THEN info = -1 ELSE IF( ( ijob < 0 ) .OR. ( ijob > 2 ) ) THEN info = -2 ELSE IF( m <= 0 ) THEN info = -3 ELSE IF( n <= 0 ) THEN info = -4 ELSE IF( lda < MAX( 1, m ) ) THEN info = -5 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -8 ELSE IF( ldc < MAX( 1, m ) ) THEN info = -10 ELSE IF( ldd < MAX( 1, m ) ) THEN info = -12 ELSE IF( lde < MAX( 1, n ) ) THEN info = -14 ELSE IF( ldf < MAX( 1, m ) ) THEN info = -16 END IF IF( info /= 0 ) THEN CALL xerbla( 'STGSY2', -info ) RETURN END IF ! ! Determine block structure of A ! pq = 0 p = 0 i = 1 10 CONTINUE IF( i > m ) GO TO 20 p = p + 1 iwork( p ) = i IF( i == m ) GO TO 20 IF( a( i+1, i ) /= zero ) THEN i = i + 2 ELSE i = i + 1 END IF GO TO 10 20 CONTINUE iwork( p+1 ) = m + 1 ! ! Determine block structure of B ! q = p + 1 j = 1 30 CONTINUE IF( j > n ) GO TO 40 q = q + 1 iwork( q ) = j IF( j == n ) GO TO 40 IF( b( j+1, j ) /= zero ) THEN j = j + 2 ELSE j = j + 1 END IF GO TO 30 40 CONTINUE iwork( q+1 ) = n + 1 pq = p*( q-p-1 ) ! IF( notran ) THEN ! ! Solve (I, J) - subsystem ! A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) ! D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) ! for I = P, P - 1, ..., 1; J = 1, 2, ..., Q ! scale = one scaloc = one DO j = p + 2, q js = iwork( j ) jsp1 = js + 1 je = iwork( j+1 ) - 1 nb = je - js + 1 DO i = p, 1, -1 ! is = iwork( i ) isp1 = is + 1 ie = iwork( i+1 ) - 1 mb = ie - is + 1 zdim = mb*nb*2 ! IF( ( mb == 1 ) .AND. ( nb == 1 ) ) THEN ! ! Build a 2-by-2 system Z * x = RHS ! z( 1, 1 ) = a( is, is ) z( 2, 1 ) = d( is, is ) z( 1, 2 ) = -b( js, js ) z( 2, 2 ) = -e( js, js ) ! ! Set up right hand side(s) ! rhs( 1 ) = c( is, js ) rhs( 2 ) = f( is, js ) ! ! Solve Z * x = RHS ! CALL sgetc2( zdim, z, ldz, ipiv, jpiv, ierr ) IF( ierr > 0 ) info = ierr ! IF( ijob == 0 ) THEN CALL sgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) IF( scaloc /= one ) THEN DO k = 1, n CALL sscal( m, scaloc, c( 1, k ), 1 ) CALL sscal( m, scaloc, f( 1, k ), 1 ) END DO scale = scale*scaloc END IF ELSE CALL slatdf( ijob, zdim, z, ldz, rhs, rdsum, rdscal, ipiv, jpiv ) END IF ! ! Unpack solution vector(s) ! c( is, js ) = rhs( 1 ) f( is, js ) = rhs( 2 ) ! ! Substitute R(I, J) and L(I, J) into remaining ! equation. ! IF( i > 1 ) THEN alpha = -rhs( 1 ) CALL saxpy( is-1, alpha, a( 1, is ), 1, c( 1, js ), 1 ) CALL saxpy( is-1, alpha, d( 1, is ), 1, f( 1, js ), 1 ) END IF IF( j < q ) THEN CALL saxpy( n-je, rhs( 2 ), b( js, je+1 ), ldb, c( is, je+1 ), ldc ) CALL saxpy( n-je, rhs( 2 ), e( js, je+1 ), lde, f( is, je+1 ), ldf ) END IF ! ELSE IF( ( mb == 1 ) .AND. ( nb == 2 ) ) THEN ! ! Build a 4-by-4 system Z * x = RHS ! z( 1, 1 ) = a( is, is ) z( 2, 1 ) = zero z( 3, 1 ) = d( is, is ) z( 4, 1 ) = zero ! z( 1, 2 ) = zero z( 2, 2 ) = a( is, is ) z( 3, 2 ) = zero z( 4, 2 ) = d( is, is ) ! z( 1, 3 ) = -b( js, js ) z( 2, 3 ) = -b( js, jsp1 ) z( 3, 3 ) = -e( js, js ) z( 4, 3 ) = -e( js, jsp1 ) ! z( 1, 4 ) = -b( jsp1, js ) z( 2, 4 ) = -b( jsp1, jsp1 ) z( 3, 4 ) = zero z( 4, 4 ) = -e( jsp1, jsp1 ) ! ! Set up right hand side(s) ! rhs( 1 ) = c( is, js ) rhs( 2 ) = c( is, jsp1 ) rhs( 3 ) = f( is, js ) rhs( 4 ) = f( is, jsp1 ) ! ! Solve Z * x = RHS ! CALL sgetc2( zdim, z, ldz, ipiv, jpiv, ierr ) IF( ierr > 0 ) info = ierr ! IF( ijob == 0 ) THEN CALL sgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) IF( scaloc /= one ) THEN DO k = 1, n CALL sscal( m, scaloc, c( 1, k ), 1 ) CALL sscal( m, scaloc, f( 1, k ), 1 ) END DO scale = scale*scaloc END IF ELSE CALL slatdf( ijob, zdim, z, ldz, rhs, rdsum, rdscal, ipiv, jpiv ) END IF ! ! Unpack solution vector(s) ! c( is, js ) = rhs( 1 ) c( is, jsp1 ) = rhs( 2 ) f( is, js ) = rhs( 3 ) f( is, jsp1 ) = rhs( 4 ) ! ! Substitute R(I, J) and L(I, J) into remaining ! equation. ! IF( i > 1 ) THEN CALL sger( is-1, nb, -one, a( 1, is ), 1, rhs( 1 ), & 1, c( 1, js ), ldc ) CALL sger( is-1, nb, -one, d( 1, is ), 1, rhs( 1 ), & 1, f( 1, js ), ldf ) END IF IF( j < q ) THEN CALL saxpy( n-je, rhs( 3 ), b( js, je+1 ), ldb, c( is, je+1 ), ldc ) CALL saxpy( n-je, rhs( 3 ), e( js, je+1 ), lde, f( is, je+1 ), ldf ) CALL saxpy( n-je, rhs( 4 ), b( jsp1, je+1 ), ldb, & c( is, je+1 ), ldc ) CALL saxpy( n-je, rhs( 4 ), e( jsp1, je+1 ), lde, & f( is, je+1 ), ldf ) END IF ! ELSE IF( ( mb == 2 ) .AND. ( nb == 1 ) ) THEN ! ! Build a 4-by-4 system Z * x = RHS ! z( 1, 1 ) = a( is, is ) z( 2, 1 ) = a( isp1, is ) z( 3, 1 ) = d( is, is ) z( 4, 1 ) = zero ! z( 1, 2 ) = a( is, isp1 ) z( 2, 2 ) = a( isp1, isp1 ) z( 3, 2 ) = d( is, isp1 ) z( 4, 2 ) = d( isp1, isp1 ) ! z( 1, 3 ) = -b( js, js ) z( 2, 3 ) = zero z( 3, 3 ) = -e( js, js ) z( 4, 3 ) = zero ! z( 1, 4 ) = zero z( 2, 4 ) = -b( js, js ) z( 3, 4 ) = zero z( 4, 4 ) = -e( js, js ) ! ! Set up right hand side(s) ! rhs( 1 ) = c( is, js ) rhs( 2 ) = c( isp1, js ) rhs( 3 ) = f( is, js ) rhs( 4 ) = f( isp1, js ) ! ! Solve Z * x = RHS ! CALL sgetc2( zdim, z, ldz, ipiv, jpiv, ierr ) IF( ierr > 0 ) info = ierr IF( ijob == 0 ) THEN CALL sgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) IF( scaloc /= one ) THEN DO k = 1, n CALL sscal( m, scaloc, c( 1, k ), 1 ) CALL sscal( m, scaloc, f( 1, k ), 1 ) END DO scale = scale*scaloc END IF ELSE CALL slatdf( ijob, zdim, z, ldz, rhs, rdsum, rdscal, ipiv, jpiv ) END IF ! ! Unpack solution vector(s) ! c( is, js ) = rhs( 1 ) c( isp1, js ) = rhs( 2 ) f( is, js ) = rhs( 3 ) f( isp1, js ) = rhs( 4 ) ! ! Substitute R(I, J) and L(I, J) into remaining ! equation. ! IF( i > 1 ) THEN CALL sgemv( 'N', is-1, mb, -one, a( 1, is ), lda, & rhs( 1 ), 1, one, c( 1, js ), 1 ) CALL sgemv( 'N', is-1, mb, -one, d( 1, is ), ldd, & rhs( 1 ), 1, one, f( 1, js ), 1 ) END IF IF( j < q ) THEN CALL sger( mb, n-je, one, rhs( 3 ), 1, & b( js, je+1 ), ldb, c( is, je+1 ), ldc ) CALL sger( mb, n-je, one, rhs( 3 ), 1, & e( js, je+1 ), ldb, f( is, je+1 ), ldc ) END IF ! ELSE IF( ( mb == 2 ) .AND. ( nb == 2 ) ) THEN ! ! Build an 8-by-8 system Z * x = RHS ! CALL scopy( ldz*ldz, zero, 0, z, 1 ) ! z( 1, 1 ) = a( is, is ) z( 2, 1 ) = a( isp1, is ) z( 5, 1 ) = d( is, is ) ! z( 1, 2 ) = a( is, isp1 ) z( 2, 2 ) = a( isp1, isp1 ) z( 5, 2 ) = d( is, isp1 ) z( 6, 2 ) = d( isp1, isp1 ) ! z( 3, 3 ) = a( is, is ) z( 4, 3 ) = a( isp1, is ) z( 7, 3 ) = d( is, is ) ! z( 3, 4 ) = a( is, isp1 ) z( 4, 4 ) = a( isp1, isp1 ) z( 7, 4 ) = d( is, isp1 ) z( 8, 4 ) = d( isp1, isp1 ) ! z( 1, 5 ) = -b( js, js ) z( 3, 5 ) = -b( js, jsp1 ) z( 5, 5 ) = -e( js, js ) z( 7, 5 ) = -e( js, jsp1 ) ! z( 2, 6 ) = -b( js, js ) z( 4, 6 ) = -b( js, jsp1 ) z( 6, 6 ) = -e( js, js ) z( 8, 6 ) = -e( js, jsp1 ) ! z( 1, 7 ) = -b( jsp1, js ) z( 3, 7 ) = -b( jsp1, jsp1 ) z( 7, 7 ) = -e( jsp1, jsp1 ) ! z( 2, 8 ) = -b( jsp1, js ) z( 4, 8 ) = -b( jsp1, jsp1 ) z( 8, 8 ) = -e( jsp1, jsp1 ) ! ! Set up right hand side(s) ! k = 1 ii = mb*nb + 1 DO jj = 0, nb - 1 CALL scopy( mb, c( is, js+jj ), 1, rhs( k ), 1 ) CALL scopy( mb, f( is, js+jj ), 1, rhs( ii ), 1 ) k = k + mb ii = ii + mb END DO ! ! Solve Z * x = RHS ! CALL sgetc2( zdim, z, ldz, ipiv, jpiv, ierr ) IF( ierr > 0 ) info = ierr IF( ijob == 0 ) THEN CALL sgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) IF( scaloc /= one ) THEN DO k = 1, n CALL sscal( m, scaloc, c( 1, k ), 1 ) CALL sscal( m, scaloc, f( 1, k ), 1 ) END DO scale = scale*scaloc END IF ELSE CALL slatdf( ijob, zdim, z, ldz, rhs, rdsum, rdscal, ipiv, jpiv ) END IF ! ! Unpack solution vector(s) ! k = 1 ii = mb*nb + 1 DO jj = 0, nb - 1 CALL scopy( mb, rhs( k ), 1, c( is, js+jj ), 1 ) CALL scopy( mb, rhs( ii ), 1, f( is, js+jj ), 1 ) k = k + mb ii = ii + mb END DO ! ! Substitute R(I, J) and L(I, J) into remaining ! equation. ! IF( i > 1 ) THEN CALL sgemm( 'N', 'N', is-1, nb, mb, -one, & a( 1, is ), lda, rhs( 1 ), mb, one, c( 1, js ), ldc ) CALL sgemm( 'N', 'N', is-1, nb, mb, -one, & d( 1, is ), ldd, rhs( 1 ), mb, one, f( 1, js ), ldf ) END IF IF( j < q ) THEN k = mb*nb + 1 CALL sgemm( 'N', 'N', mb, n-je, nb, one, rhs( k ), & mb, b( js, je+1 ), ldb, one, c( is, je+1 ), ldc ) CALL sgemm( 'N', 'N', mb, n-je, nb, one, rhs( k ), & mb, e( js, je+1 ), lde, one, f( is, je+1 ), ldf ) END IF ! END IF ! END DO END DO ELSE ! ! Solve (I, J) - subsystem ! A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J) ! R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) ! for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1 ! scale = one scaloc = one DO i = 1, p ! is = iwork( i ) isp1 = is + 1 ie = iwork( i+1 ) - 1 mb = ie - is + 1 DO j = q, p + 2, -1 ! js = iwork( j ) jsp1 = js + 1 je = iwork( j+1 ) - 1 nb = je - js + 1 zdim = mb*nb*2 IF( ( mb == 1 ) .AND. ( nb == 1 ) ) THEN ! ! Build a 2-by-2 system Z' * x = RHS ! z( 1, 1 ) = a( is, is ) z( 2, 1 ) = -b( js, js ) z( 1, 2 ) = d( is, is ) z( 2, 2 ) = -e( js, js ) ! ! Set up right hand side(s) ! rhs( 1 ) = c( is, js ) rhs( 2 ) = f( is, js ) ! ! Solve Z' * x = RHS ! CALL sgetc2( zdim, z, ldz, ipiv, jpiv, ierr ) IF( ierr > 0 ) info = ierr ! CALL sgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) IF( scaloc /= one ) THEN DO k = 1, n CALL sscal( m, scaloc, c( 1, k ), 1 ) CALL sscal( m, scaloc, f( 1, k ), 1 ) END DO scale = scale*scaloc END IF ! ! Unpack solution vector(s) ! c( is, js ) = rhs( 1 ) f( is, js ) = rhs( 2 ) ! ! Substitute R(I, J) and L(I, J) into remaining ! equation. ! IF( j > p+2 ) THEN alpha = rhs( 1 ) CALL saxpy( js-1, alpha, b( 1, js ), 1, f( is, 1 ), ldf ) alpha = rhs( 2 ) CALL saxpy( js-1, alpha, e( 1, js ), 1, f( is, 1 ), ldf ) END IF IF( i < p ) THEN alpha = -rhs( 1 ) CALL saxpy( m-ie, alpha, a( is, ie+1 ), lda, c( ie+1, js ), 1 ) alpha = -rhs( 2 ) CALL saxpy( m-ie, alpha, d( is, ie+1 ), ldd, c( ie+1, js ), 1 ) END IF ! ELSE IF( ( mb == 1 ) .AND. ( nb == 2 ) ) THEN ! ! Build a 4-by-4 system Z' * x = RHS ! z( 1, 1 ) = a( is, is ) z( 2, 1 ) = zero z( 3, 1 ) = -b( js, js ) z( 4, 1 ) = -b( jsp1, js ) ! z( 1, 2 ) = zero z( 2, 2 ) = a( is, is ) z( 3, 2 ) = -b( js, jsp1 ) z( 4, 2 ) = -b( jsp1, jsp1 ) ! z( 1, 3 ) = d( is, is ) z( 2, 3 ) = zero z( 3, 3 ) = -e( js, js ) z( 4, 3 ) = zero ! z( 1, 4 ) = zero z( 2, 4 ) = d( is, is ) z( 3, 4 ) = -e( js, jsp1 ) z( 4, 4 ) = -e( jsp1, jsp1 ) ! ! Set up right hand side(s) ! rhs( 1 ) = c( is, js ) rhs( 2 ) = c( is, jsp1 ) rhs( 3 ) = f( is, js ) rhs( 4 ) = f( is, jsp1 ) ! ! Solve Z' * x = RHS ! CALL sgetc2( zdim, z, ldz, ipiv, jpiv, ierr ) IF( ierr > 0 ) info = ierr CALL sgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) IF( scaloc /= one ) THEN DO k = 1, n CALL sscal( m, scaloc, c( 1, k ), 1 ) CALL sscal( m, scaloc, f( 1, k ), 1 ) END DO scale = scale*scaloc END IF ! ! Unpack solution vector(s) ! c( is, js ) = rhs( 1 ) c( is, jsp1 ) = rhs( 2 ) f( is, js ) = rhs( 3 ) f( is, jsp1 ) = rhs( 4 ) ! ! Substitute R(I, J) and L(I, J) into remaining ! equation. ! IF( j > p+2 ) THEN CALL saxpy( js-1, rhs( 1 ), b( 1, js ), 1, f( is, 1 ), ldf ) CALL saxpy( js-1, rhs( 2 ), b( 1, jsp1 ), 1, f( is, 1 ), ldf ) CALL saxpy( js-1, rhs( 3 ), e( 1, js ), 1, f( is, 1 ), ldf ) CALL saxpy( js-1, rhs( 4 ), e( 1, jsp1 ), 1, f( is, 1 ), ldf ) END IF IF( i < p ) THEN CALL sger( m-ie, nb, -one, a( is, ie+1 ), lda, & rhs( 1 ), 1, c( ie+1, js ), ldc ) CALL sger( m-ie, nb, -one, d( is, ie+1 ), ldd, & rhs( 3 ), 1, c( ie+1, js ), ldc ) END IF ! ELSE IF( ( mb == 2 ) .AND. ( nb == 1 ) ) THEN ! ! Build a 4-by-4 system Z' * x = RHS ! z( 1, 1 ) = a( is, is ) z( 2, 1 ) = a( is, isp1 ) z( 3, 1 ) = -b( js, js ) z( 4, 1 ) = zero ! z( 1, 2 ) = a( isp1, is ) z( 2, 2 ) = a( isp1, isp1 ) z( 3, 2 ) = zero z( 4, 2 ) = -b( js, js ) ! z( 1, 3 ) = d( is, is ) z( 2, 3 ) = d( is, isp1 ) z( 3, 3 ) = -e( js, js ) z( 4, 3 ) = zero ! z( 1, 4 ) = zero z( 2, 4 ) = d( isp1, isp1 ) z( 3, 4 ) = zero z( 4, 4 ) = -e( js, js ) ! ! Set up right hand side(s) ! rhs( 1 ) = c( is, js ) rhs( 2 ) = c( isp1, js ) rhs( 3 ) = f( is, js ) rhs( 4 ) = f( isp1, js ) ! ! Solve Z' * x = RHS ! CALL sgetc2( zdim, z, ldz, ipiv, jpiv, ierr ) IF( ierr > 0 ) info = ierr ! CALL sgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) IF( scaloc /= one ) THEN DO k = 1, n CALL sscal( m, scaloc, c( 1, k ), 1 ) CALL sscal( m, scaloc, f( 1, k ), 1 ) END DO scale = scale*scaloc END IF ! ! Unpack solution vector(s) ! c( is, js ) = rhs( 1 ) c( isp1, js ) = rhs( 2 ) f( is, js ) = rhs( 3 ) f( isp1, js ) = rhs( 4 ) ! ! Substitute R(I, J) and L(I, J) into remaining ! equation. ! IF( j > p+2 ) THEN CALL sger( mb, js-1, one, rhs( 1 ), 1, b( 1, js ), & 1, f( is, 1 ), ldf ) CALL sger( mb, js-1, one, rhs( 3 ), 1, e( 1, js ), & 1, f( is, 1 ), ldf ) END IF IF( i < p ) THEN CALL sgemv( 'T', mb, m-ie, -one, a( is, ie+1 ), & lda, rhs( 1 ), 1, one, c( ie+1, js ), 1 ) CALL sgemv( 'T', mb, m-ie, -one, d( is, ie+1 ), & ldd, rhs( 3 ), 1, one, c( ie+1, js ), 1 ) END IF ! ELSE IF( ( mb == 2 ) .AND. ( nb == 2 ) ) THEN ! ! Build an 8-by-8 system Z' * x = RHS ! CALL scopy( ldz*ldz, zero, 0, z, 1 ) ! z( 1, 1 ) = a( is, is ) z( 2, 1 ) = a( is, isp1 ) z( 5, 1 ) = -b( js, js ) z( 7, 1 ) = -b( jsp1, js ) ! z( 1, 2 ) = a( isp1, is ) z( 2, 2 ) = a( isp1, isp1 ) z( 6, 2 ) = -b( js, js ) z( 8, 2 ) = -b( jsp1, js ) ! z( 3, 3 ) = a( is, is ) z( 4, 3 ) = a( is, isp1 ) z( 5, 3 ) = -b( js, jsp1 ) z( 7, 3 ) = -b( jsp1, jsp1 ) ! z( 3, 4 ) = a( isp1, is ) z( 4, 4 ) = a( isp1, isp1 ) z( 6, 4 ) = -b( js, jsp1 ) z( 8, 4 ) = -b( jsp1, jsp1 ) ! z( 1, 5 ) = d( is, is ) z( 2, 5 ) = d( is, isp1 ) z( 5, 5 ) = -e( js, js ) ! z( 2, 6 ) = d( isp1, isp1 ) z( 6, 6 ) = -e( js, js ) ! z( 3, 7 ) = d( is, is ) z( 4, 7 ) = d( is, isp1 ) z( 5, 7 ) = -e( js, jsp1 ) z( 7, 7 ) = -e( jsp1, jsp1 ) ! z( 4, 8 ) = d( isp1, isp1 ) z( 6, 8 ) = -e( js, jsp1 ) z( 8, 8 ) = -e( jsp1, jsp1 ) ! ! Set up right hand side(s) ! k = 1 ii = mb*nb + 1 DO jj = 0, nb - 1 CALL scopy( mb, c( is, js+jj ), 1, rhs( k ), 1 ) CALL scopy( mb, f( is, js+jj ), 1, rhs( ii ), 1 ) k = k + mb ii = ii + mb END DO ! ! ! Solve Z' * x = RHS ! CALL sgetc2( zdim, z, ldz, ipiv, jpiv, ierr ) IF( ierr > 0 ) info = ierr ! CALL sgesc2( zdim, z, ldz, rhs, ipiv, jpiv, scaloc ) IF( scaloc /= one ) THEN DO k = 1, n CALL sscal( m, scaloc, c( 1, k ), 1 ) CALL sscal( m, scaloc, f( 1, k ), 1 ) END DO scale = scale*scaloc END IF ! ! Unpack solution vector(s) ! k = 1 ii = mb*nb + 1 DO jj = 0, nb - 1 CALL scopy( mb, rhs( k ), 1, c( is, js+jj ), 1 ) CALL scopy( mb, rhs( ii ), 1, f( is, js+jj ), 1 ) k = k + mb ii = ii + mb END DO ! ! Substitute R(I, J) and L(I, J) into remaining ! equation. ! IF( j > p+2 ) THEN CALL sgemm( 'N', 'T', mb, js-1, nb, one, & c( is, js ), ldc, b( 1, js ), ldb, one, f( is, 1 ), ldf ) CALL sgemm( 'N', 'T', mb, js-1, nb, one, & f( is, js ), ldf, e( 1, js ), lde, one, f( is, 1 ), ldf ) END IF IF( i < p ) THEN CALL sgemm( 'T', 'N', m-ie, nb, mb, -one, & a( is, ie+1 ), lda, c( is, js ), ldc, one, c( ie+1, js ), ldc ) CALL sgemm( 'T', 'N', m-ie, nb, mb, -one, & d( is, ie+1 ), ldd, f( is, js ), ldf, one, c( ie+1, js ), ldc ) END IF ! END IF ! END DO END DO ! END IF RETURN ! ! End of STGSY2 ! END SUBROUTINE stgsy2 SUBROUTINE stgsyl( trans, ijob, m, n, a, lda, b, ldb, c, ldc, d, & ldd, e, lde, f, ldf, scale, dif, work, lwork, 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 (LEN=1), INTENT(IN) :: trans INTEGER, INTENT(IN) :: ijob INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN OUT) :: ldc REAL, INTENT(IN OUT) :: d( ldd, * ) INTEGER, INTENT(IN OUT) :: ldd REAL, INTENT(IN OUT) :: e( lde, * ) INTEGER, INTENT(IN OUT) :: lde REAL, INTENT(IN OUT) :: f( ldf, * ) INTEGER, INTENT(IN OUT) :: ldf REAL, INTENT(IN OUT) :: scale REAL, INTENT(OUT) :: dif REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: lwork INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STGSYL solves the generalized Sylvester equation: ! ! A * R - L * B = scale * C (1) ! D * R - L * E = scale * F ! ! where R and L are unknown m-by-n matrices, (A, D), (B, E) and ! (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, ! respectively, with real entries. (A, D) and (B, E) must be in ! generalized (real) Schur canonical form, i.e. A, B are upper quasi ! triangular and D, E are upper triangular. ! ! The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output ! scaling factor chosen to avoid overflow. ! ! In matrix notation (1) is equivalent to solve Zx = scale b, where ! Z is defined as ! ! Z = [ kron(In, A) -kron(B', Im) ] (2) ! [ kron(In, D) -kron(E', Im) ]. ! ! Here Ik is the identity matrix of size k and X' is the transpose of ! X. kron(X, Y) is the Kronecker product between the matrices X and Y. ! ! If TRANS = 'T', STGSYL solves the transposed system Z'*y = scale*b, ! which is equivalent to solve for R and L in ! ! A' * R + D' * L = scale * C (3) ! R * B' + L * E' = scale * (-F) ! ! This case (TRANS = 'T') is used to compute an one-norm-based estimate ! of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) ! and (B,E), using SLACON. ! ! If IJOB >= 1, STGSYL computes a Frobenius norm-based estimate ! of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the ! reciprocal of the smallest singular value of Z. See [1-2] for more ! information. ! ! This is a level 3 BLAS algorithm. ! ! Arguments ! ========= ! ! TRANS (input) CHARACTER*1 ! = 'N', solve the generalized Sylvester equation (1). ! = 'T', solve the 'transposed' system (3). ! ! IJOB (input) INTEGER ! Specifies what kind of functionality to be performed. ! =0: solve (1) only. ! =1: The functionality of 0 and 3. ! =2: The functionality of 0 and 4. ! =3: Only an estimate of Dif[(A,D), (B,E)] is computed. ! (look ahead strategy IJOB = 1 is used). ! =4: Only an estimate of Dif[(A,D), (B,E)] is computed. ! ( SGECON on sub-systems is used ). ! Not referenced if TRANS = 'T'. ! ! M (input) INTEGER ! The order of the matrices A and D, and the row dimension of ! the matrices C, F, R and L. ! ! N (input) INTEGER ! The order of the matrices B and E, and the column dimension ! of the matrices C, F, R and L. ! ! A (input) REAL array, dimension (LDA, M) ! The upper quasi triangular matrix A. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1, M). ! ! B (input) REAL array, dimension (LDB, N) ! The upper quasi triangular matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1, N). ! ! C (input/output) REAL array, dimension (LDC, N) ! On entry, C contains the right-hand-side of the first matrix ! equation in (1) or (3). ! On exit, if IJOB = 0, 1 or 2, C has been overwritten by ! the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, ! the solution achieved during the computation of the ! Dif-estimate. ! ! LDC (input) INTEGER ! The leading dimension of the array C. LDC >= max(1, M). ! ! D (input) REAL array, dimension (LDD, M) ! The upper triangular matrix D. ! ! LDD (input) INTEGER ! The leading dimension of the array D. LDD >= max(1, M). ! ! E (input) REAL array, dimension (LDE, N) ! The upper triangular matrix E. ! ! LDE (input) INTEGER ! The leading dimension of the array E. LDE >= max(1, N). ! ! F (input/output) REAL array, dimension (LDF, N) ! On entry, F contains the right-hand-side of the second matrix ! equation in (1) or (3). ! On exit, if IJOB = 0, 1 or 2, F has been overwritten by ! the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, ! the solution achieved during the computation of the ! Dif-estimate. ! ! LDF (input) INTEGER ! The leading dimension of the array F. LDF >= max(1, M). ! ! DIF (output) REAL ! On exit DIF is the reciprocal of a lower bound of the ! reciprocal of the Dif-function, i.e. DIF is an upper bound of ! Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2). ! IF IJOB = 0 or TRANS = 'T', DIF is not touched. ! ! SCALE (output) REAL ! On exit SCALE is the scaling factor in (1) or (3). ! If 0 < SCALE < 1, C and F hold the solutions R and L, resp., ! to a slightly perturbed system but the input matrices A, B, D ! and E have not been changed. If SCALE = 0, C and F hold the ! solutions R and L, respectively, to the homogeneous system ! with C = F = 0. Normally, SCALE = 1. ! ! WORK (workspace/output) REAL array, dimension (LWORK) ! If IJOB = 0, WORK is not referenced. Otherwise, ! on exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. LWORK > = 1. ! If IJOB = 1 or 2 and TRANS = 'N', LWORK >= 2*M*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. ! ! IWORK (workspace) INTEGER array, dimension (M+N+6) ! ! INFO (output) INTEGER ! =0: successful exit ! <0: If INFO = -i, the i-th argument had an illegal value. ! >0: (A, D) and (B, E) have common or close eigenvalues. ! ! Further Details ! =============== ! ! Based on contributions by ! Bo Kagstrom and Peter Poromaa, Department of Computing Science, ! Umea University, S-901 87 Umea, Sweden. ! ! [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software ! for Solving the Generalized Sylvester Equation and Estimating the ! Separation between Regular Matrix Pairs, Report UMINF - 93.23, ! Department of Computing Science, Umea University, S-901 87 Umea, ! Sweden, December 1993, Revised April 1994, Also as LAPACK Working ! Note 75. To appear in ACM Trans. on Math. Software, Vol 22, ! No 1, 1996. ! ! [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester ! Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. ! Appl., 15(4):1045-1060, 1994 ! ! [3] B. Kagstrom and L. Westin, Generalized Schur Methods with ! Condition Estimators for Solving the Generalized Sylvester ! Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, ! July 1989, pp 745-751. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, notran INTEGER :: i, ie, ifunc, iround, is, isolve, j, je, js, k, & linfo, lwmin, mb, nb, p, ppqq, pq, q REAL :: dscale, dsum, scale2, scaloc ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL lsame, ilaenv ! .. ! .. External Subroutines .. EXTERNAL scopy, sgemm, slacpy, sscal, stgsy2, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, REAL, SQRT ! .. ! .. Executable Statements .. ! ! Decode and test input parameters ! info = 0 notran = lsame( trans, 'N' ) lquery = ( lwork == -1 ) ! IF( ( ijob == 1 .OR. ijob == 2 ) .AND. notran ) THEN lwmin = MAX( 1, 2*m*n ) ELSE lwmin = 1 END IF ! IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) ) THEN info = -1 ELSE IF( ( ijob < 0 ) .OR. ( ijob > 4 ) ) THEN info = -2 ELSE IF( m <= 0 ) THEN info = -3 ELSE IF( n <= 0 ) THEN info = -4 ELSE IF( lda < MAX( 1, m ) ) THEN info = -6 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -8 ELSE IF( ldc < MAX( 1, m ) ) THEN info = -10 ELSE IF( ldd < MAX( 1, m ) ) THEN info = -12 ELSE IF( lde < MAX( 1, n ) ) THEN info = -14 ELSE IF( ldf < MAX( 1, m ) ) THEN info = -16 ELSE IF( lwork < lwmin .AND. .NOT.lquery ) THEN info = -20 END IF ! IF( info == 0 ) THEN work( 1 ) = lwmin END IF ! IF( info /= 0 ) THEN CALL xerbla( 'STGSYL', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Determine optimal block sizes MB and NB ! mb = ilaenv( 2, 'STGSYL', trans, m, n, -1, -1 ) nb = ilaenv( 5, 'STGSYL', trans, m, n, -1, -1 ) ! isolve = 1 ifunc = 0 IF( ijob >= 3 .AND. notran ) THEN ifunc = ijob - 2 DO j = 1, n CALL scopy( m, zero, 0, c( 1, j ), 1 ) CALL scopy( m, zero, 0, f( 1, j ), 1 ) END DO ELSE IF( ijob >= 1 .AND. notran ) THEN isolve = 2 END IF ! IF( ( mb <= 1 .AND. nb <= 1 ) .OR. ( mb >= m .AND. nb >= n ) ) THEN ! DO iround = 1, isolve ! ! Use unblocked Level 2 solver ! dscale = zero dsum = one pq = 0 CALL stgsy2( trans, ifunc, m, n, a, lda, b, ldb, c, ldc, d, & ldd, e, lde, f, ldf, scale, dsum, dscale, iwork, pq, info ) IF( dscale /= zero ) THEN IF( ijob == 1 .OR. ijob == 3 ) THEN dif = SQRT( REAL( 2*m*n ) ) / ( dscale*SQRT( dsum ) ) ELSE dif = SQRT( REAL( pq ) ) / ( dscale*SQRT( dsum ) ) END IF END IF ! IF( isolve == 2 .AND. iround == 1 ) THEN ifunc = ijob scale2 = scale CALL slacpy( 'F', m, n, c, ldc, work, m ) CALL slacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) DO j = 1, n CALL scopy( m, zero, 0, c( 1, j ), 1 ) CALL scopy( m, zero, 0, f( 1, j ), 1 ) END DO ELSE IF( isolve == 2 .AND. iround == 2 ) THEN CALL slacpy( 'F', m, n, work, m, c, ldc ) CALL slacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) scale = scale2 END IF END DO ! RETURN END IF ! ! Determine block structure of A ! p = 0 i = 1 40 CONTINUE IF( i > m ) GO TO 50 p = p + 1 iwork( p ) = i i = i + mb IF( i >= m ) GO TO 50 IF( a( i, i-1 ) /= zero ) i = i + 1 GO TO 40 50 CONTINUE ! iwork( p+1 ) = m + 1 IF( iwork( p ) == iwork( p+1 ) ) p = p - 1 ! ! Determine block structure of B ! q = p + 1 j = 1 60 CONTINUE IF( j > n ) GO TO 70 q = q + 1 iwork( q ) = j j = j + nb IF( j >= n ) GO TO 70 IF( b( j, j-1 ) /= zero ) j = j + 1 GO TO 60 70 CONTINUE ! iwork( q+1 ) = n + 1 IF( iwork( q ) == iwork( q+1 ) ) q = q - 1 ! IF( notran ) THEN ! DO iround = 1, isolve ! ! Solve (I, J)-subsystem ! A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) ! D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) ! for I = P, P - 1,..., 1; J = 1, 2,..., Q ! dscale = zero dsum = one pq = 0 scale = one DO j = p + 2, q js = iwork( j ) je = iwork( j+1 ) - 1 nb = je - js + 1 DO i = p, 1, -1 is = iwork( i ) ie = iwork( i+1 ) - 1 mb = ie - is + 1 ppqq = 0 CALL stgsy2( trans, ifunc, mb, nb, a( is, is ), lda, & b( js, js ), ldb, c( is, js ), ldc, & d( is, is ), ldd, e( js, js ), lde, & f( is, js ), ldf, scaloc, dsum, dscale, iwork( q+2 ), ppqq, linfo ) IF( linfo > 0 ) info = linfo ! pq = pq + ppqq IF( scaloc /= one ) THEN DO k = 1, js - 1 CALL sscal( m, scaloc, c( 1, k ), 1 ) CALL sscal( m, scaloc, f( 1, k ), 1 ) END DO DO k = js, je CALL sscal( is-1, scaloc, c( 1, k ), 1 ) CALL sscal( is-1, scaloc, f( 1, k ), 1 ) END DO DO k = js, je CALL sscal( m-ie, scaloc, c( ie+1, k ), 1 ) CALL sscal( m-ie, scaloc, f( ie+1, k ), 1 ) END DO DO k = je + 1, n CALL sscal( m, scaloc, c( 1, k ), 1 ) CALL sscal( m, scaloc, f( 1, k ), 1 ) END DO scale = scale*scaloc END IF ! ! Substitute R(I, J) and L(I, J) into remaining ! equation. ! IF( i > 1 ) THEN CALL sgemm( 'N', 'N', is-1, nb, mb, -one, & a( 1, is ), lda, c( is, js ), ldc, one, c( 1, js ), ldc ) CALL sgemm( 'N', 'N', is-1, nb, mb, -one, & d( 1, is ), ldd, c( is, js ), ldc, one, f( 1, js ), ldf ) END IF IF( j < q ) THEN CALL sgemm( 'N', 'N', mb, n-je, nb, one, & f( is, js ), ldf, b( js, je+1 ), ldb, one, c( is, je+1 ), ldc ) CALL sgemm( 'N', 'N', mb, n-je, nb, one, & f( is, js ), ldf, e( js, je+1 ), lde, one, f( is, je+1 ), ldf ) END IF END DO END DO IF( dscale /= zero ) THEN IF( ijob == 1 .OR. ijob == 3 ) THEN dif = SQRT( REAL( 2*m*n ) ) / ( dscale*SQRT( dsum ) ) ELSE dif = SQRT( REAL( pq ) ) / ( dscale*SQRT( dsum ) ) END IF END IF IF( isolve == 2 .AND. iround == 1 ) THEN ifunc = ijob scale2 = scale CALL slacpy( 'F', m, n, c, ldc, work, m ) CALL slacpy( 'F', m, n, f, ldf, work( m*n+1 ), m ) DO j = 1, n CALL scopy( m, zero, 0, c( 1, j ), 1 ) CALL scopy( m, zero, 0, f( 1, j ), 1 ) END DO ELSE IF( isolve == 2 .AND. iround == 2 ) THEN CALL slacpy( 'F', m, n, work, m, c, ldc ) CALL slacpy( 'F', m, n, work( m*n+1 ), m, f, ldf ) scale = scale2 END IF END DO ! ELSE ! ! Solve transposed (I, J)-subsystem ! A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J) ! R(I, J) * B(J, J)' + L(I, J) * E(J, J)' = -F(I, J) ! for I = 1,2,..., P; J = Q, Q-1,..., 1 ! scale = one DO i = 1, p is = iwork( i ) ie = iwork( i+1 ) - 1 mb = ie - is + 1 DO j = q, p + 2, -1 js = iwork( j ) je = iwork( j+1 ) - 1 nb = je - js + 1 CALL stgsy2( trans, ifunc, mb, nb, a( is, is ), lda, & b( js, js ), ldb, c( is, js ), ldc, & d( is, is ), ldd, e( js, js ), lde, & f( is, js ), ldf, scaloc, dsum, dscale, iwork( q+2 ), ppqq, linfo ) IF( linfo > 0 ) info = linfo IF( scaloc /= one ) THEN DO k = 1, js - 1 CALL sscal( m, scaloc, c( 1, k ), 1 ) CALL sscal( m, scaloc, f( 1, k ), 1 ) END DO DO k = js, je CALL sscal( is-1, scaloc, c( 1, k ), 1 ) CALL sscal( is-1, scaloc, f( 1, k ), 1 ) END DO DO k = js, je CALL sscal( m-ie, scaloc, c( ie+1, k ), 1 ) CALL sscal( m-ie, scaloc, f( ie+1, k ), 1 ) END DO DO k = je + 1, n CALL sscal( m, scaloc, c( 1, k ), 1 ) CALL sscal( m, scaloc, f( 1, k ), 1 ) END DO scale = scale*scaloc END IF ! ! Substitute R(I, J) and L(I, J) into remaining equation. ! IF( j > p+2 ) THEN CALL sgemm( 'N', 'T', mb, js-1, nb, one, c( is, js ), & ldc, b( 1, js ), ldb, one, f( is, 1 ), ldf ) CALL sgemm( 'N', 'T', mb, js-1, nb, one, f( is, js ), & ldf, e( 1, js ), lde, one, f( is, 1 ), ldf ) END IF IF( i < p ) THEN CALL sgemm( 'T', 'N', m-ie, nb, mb, -one, & a( is, ie+1 ), lda, c( is, js ), ldc, one, c( ie+1, js ), ldc ) CALL sgemm( 'T', 'N', m-ie, nb, mb, -one, & d( is, ie+1 ), ldd, f( is, js ), ldf, one, c( ie+1, js ), ldc ) END IF END DO END DO ! END IF ! work( 1 ) = lwmin ! RETURN ! ! End of STGSYL ! END SUBROUTINE stgsyl SUBROUTINE stpcon( norm, uplo, diag, n, ap, rcond, 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 ! March 31, 1993 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: norm CHARACTER (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: diag INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: ap( * ) REAL, INTENT(OUT) :: rcond REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STPCON estimates the reciprocal of the condition number of a packed ! triangular matrix A, in either the 1-norm or the infinity-norm. ! ! The norm of A is computed and an estimate is obtained for ! norm(inv(A)), then the reciprocal of the condition number is ! computed as ! RCOND = 1 / ( norm(A) * norm(inv(A)) ). ! ! Arguments ! ========= ! ! NORM (input) CHARACTER*1 ! Specifies whether the 1-norm condition number or the ! infinity-norm condition number is required: ! = '1' or 'O': 1-norm; ! = 'I': Infinity-norm. ! ! 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. ! ! AP (input) REAL array, dimension (N*(N+1)/2) ! The upper or lower triangular 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. ! If DIAG = 'U', the diagonal elements of A are not referenced ! and are assumed to be 1. ! ! RCOND (output) REAL ! The reciprocal of the condition number of the matrix A, ! computed as RCOND = 1/(norm(A) * norm(inv(A))). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: nounit, onenrm, upper CHARACTER (LEN=1) :: normin INTEGER :: ix, kase, kase1 REAL :: ainvnm, anorm, scale, smlnum, xnorm ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: isamax REAL :: slamch, slantp EXTERNAL lsame, isamax, slamch, slantp ! .. ! .. External Subroutines .. EXTERNAL slacon, slatps, srscl, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, REAL ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 upper = lsame( uplo, 'U' ) onenrm = norm == '1' .OR. lsame( norm, 'O' ) nounit = lsame( diag, 'N' ) ! IF( .NOT.onenrm .AND. .NOT.lsame( norm, 'I' ) ) THEN info = -1 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -2 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'STPCON', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) THEN rcond = one RETURN END IF ! rcond = zero smlnum = slamch( 'Safe minimum' )*REAL( MAX( 1, n ) ) ! ! Compute the norm of the triangular matrix A. ! anorm = slantp( norm, uplo, diag, n, ap, work ) ! ! Continue only if ANORM > 0. ! IF( anorm > zero ) THEN ! ! Estimate the norm of the inverse of A. ! ainvnm = zero normin = 'N' IF( onenrm ) THEN kase1 = 1 ELSE kase1 = 2 END IF kase = 0 10 CONTINUE CALL slacon( n, work( n+1 ), work, iwork, ainvnm, kase ) IF( kase /= 0 ) THEN IF( kase == kase1 ) THEN ! ! Multiply by inv(A). ! CALL slatps( uplo, 'No transpose', diag, normin, n, ap, & work, scale, work( 2*n+1 ), info ) ELSE ! ! Multiply by inv(A'). ! CALL slatps( uplo, 'Transpose', diag, normin, n, ap, & work, scale, work( 2*n+1 ), info ) END IF normin = 'Y' ! ! Multiply by 1/SCALE if doing so will not cause overflow. ! IF( scale /= one ) THEN ix = isamax( n, work, 1 ) xnorm = ABS( work( ix ) ) IF( scale < xnorm*smlnum .OR. scale == zero ) GO TO 20 CALL srscl( n, scale, work, 1 ) END IF GO TO 10 END IF ! ! Compute the estimate of the reciprocal condition number. ! IF( ainvnm /= zero ) rcond = ( one / anorm ) / ainvnm END IF ! 20 CONTINUE RETURN ! ! End of STPCON ! END SUBROUTINE stpcon SUBROUTINE stprfs( uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, & ferr, berr, 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 ! September 30, 1994 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: trans CHARACTER (LEN=1), INTENT(IN) :: diag INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: ap( * ) REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: ferr( * ) REAL, INTENT(OUT) :: berr( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STPRFS provides error bounds and backward error estimates for the ! solution to a system of linear equations with a triangular packed ! coefficient matrix. ! ! The solution matrix X must be computed by STPTRS or some other ! means before entering this routine. STPRFS does not do iterative ! refinement because doing so cannot improve the backward error. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! = 'U': A is upper triangular; ! = 'L': A is lower triangular. ! ! 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 = Transpose) ! ! 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. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of columns ! of the matrices B and X. NRHS >= 0. ! ! AP (input) REAL array, dimension (N*(N+1)/2) ! The upper or lower triangular 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. ! If DIAG = 'U', the diagonal elements of A are not referenced ! and are assumed to be 1. ! ! B (input) REAL array, dimension (LDB,NRHS) ! The right hand side matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (input) REAL array, dimension (LDX,NRHS) ! The solution matrix X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: notran, nounit, upper CHARACTER (LEN=1) :: transt INTEGER :: i, j, k, kase, kc, nz REAL :: eps, lstres, s, safe1, safe2, safmin, xk ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, slacon, stpmv, stpsv, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 upper = lsame( uplo, 'U' ) notran = lsame( trans, 'N' ) nounit = lsame( diag, 'N' ) ! IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -1 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT. & lsame( trans, 'C' ) ) THEN info = -2 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( nrhs < 0 ) THEN info = -5 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -8 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -10 END IF IF( info /= 0 ) THEN CALL xerbla( 'STPRFS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) THEN DO j = 1, nrhs ferr( j ) = zero berr( j ) = zero END DO RETURN END IF ! IF( notran ) THEN transt = 'T' ELSE transt = 'N' END IF ! ! NZ = maximum number of nonzero elements in each row of A, plus 1 ! nz = n + 1 eps = slamch( 'Epsilon' ) safmin = slamch( 'Safe minimum' ) safe1 = nz*safmin safe2 = safe1 / eps ! ! Do for each right hand side ! DO j = 1, nrhs ! ! Compute residual R = B - op(A) * X, ! where op(A) = A or A', depending on TRANS. ! CALL scopy( n, x( 1, j ), 1, work( n+1 ), 1 ) CALL stpmv( uplo, trans, diag, n, ap, work( n+1 ), 1 ) CALL saxpy( n, -one, b( 1, j ), 1, work( n+1 ), 1 ) ! ! Compute componentwise relative backward error from formula ! ! max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) ! ! where abs(Z) is the componentwise absolute value of the matrix ! or vector Z. If the i-th component of the denominator is less ! than SAFE2, then SAFE1 is added to the i-th components of the ! numerator and denominator before dividing. ! DO i = 1, n work( i ) = ABS( b( i, j ) ) END DO ! IF( notran ) THEN ! ! Compute abs(A)*abs(X) + abs(B). ! IF( upper ) THEN kc = 1 IF( nounit ) THEN DO k = 1, n xk = ABS( x( k, j ) ) DO i = 1, k work( i ) = work( i ) + ABS( ap( kc+i-1 ) )*xk END DO kc = kc + k END DO ELSE DO k = 1, n xk = ABS( x( k, j ) ) DO i = 1, k - 1 work( i ) = work( i ) + ABS( ap( kc+i-1 ) )*xk END DO work( k ) = work( k ) + xk kc = kc + k END DO END IF ELSE kc = 1 IF( nounit ) THEN DO k = 1, n xk = ABS( x( k, j ) ) DO i = k, n work( i ) = work( i ) + ABS( ap( kc+i-k ) )*xk END DO kc = kc + n - k + 1 END DO ELSE DO k = 1, n xk = ABS( x( k, j ) ) DO i = k + 1, n work( i ) = work( i ) + ABS( ap( kc+i-k ) )*xk END DO work( k ) = work( k ) + xk kc = kc + n - k + 1 END DO END IF END IF ELSE ! ! Compute abs(A')*abs(X) + abs(B). ! IF( upper ) THEN kc = 1 IF( nounit ) THEN DO k = 1, n s = zero DO i = 1, k s = s + ABS( ap( kc+i-1 ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + s kc = kc + k END DO ELSE DO k = 1, n s = ABS( x( k, j ) ) DO i = 1, k - 1 s = s + ABS( ap( kc+i-1 ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + s kc = kc + k END DO END IF ELSE kc = 1 IF( nounit ) THEN DO k = 1, n s = zero DO i = k, n s = s + ABS( ap( kc+i-k ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + s kc = kc + n - k + 1 END DO ELSE DO k = 1, n s = ABS( x( k, j ) ) DO i = k + 1, n s = s + ABS( ap( kc+i-k ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + s kc = kc + n - k + 1 END DO END IF END IF END IF s = zero DO i = 1, n IF( work( i ) > safe2 ) THEN s = MAX( s, ABS( work( n+i ) ) / work( i ) ) ELSE s = MAX( s, ( ABS( work( n+i ) )+safe1 ) / ( work( i )+safe1 ) ) END IF END DO berr( j ) = s ! ! Bound error from formula ! ! norm(X - XTRUE) / norm(X) .le. FERR = ! norm( abs(inv(op(A)))* ! ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) ! ! where ! norm(Z) is the magnitude of the largest component of Z ! inv(op(A)) is the inverse of op(A) ! abs(Z) is the componentwise absolute value of the matrix or ! vector Z ! NZ is the maximum number of nonzeros in any row of A, plus 1 ! EPS is machine epsilon ! ! The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) ! is incremented by SAFE1 if the i-th component of ! abs(op(A))*abs(X) + abs(B) is less than SAFE2. ! ! Use SLACON to estimate the infinity-norm of the matrix ! inv(op(A)) * diag(W), ! where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) ! DO i = 1, n IF( work( i ) > safe2 ) THEN work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) ELSE work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) + safe1 END IF END DO ! kase = 0 210 CONTINUE CALL slacon( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ), kase ) IF( kase /= 0 ) THEN IF( kase == 1 ) THEN ! ! Multiply by diag(W)*inv(op(A)'). ! CALL stpsv( uplo, transt, diag, n, ap, work( n+1 ), 1 ) DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO ELSE ! ! Multiply by inv(op(A))*diag(W). ! DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO CALL stpsv( uplo, trans, diag, n, ap, work( n+1 ), 1 ) END IF GO TO 210 END IF ! ! Normalize error. ! lstres = zero DO i = 1, n lstres = MAX( lstres, ABS( x( i, j ) ) ) END DO IF( lstres /= zero ) ferr( j ) = ferr( j ) / lstres ! END DO ! RETURN ! ! End of STPRFS ! END SUBROUTINE stprfs SUBROUTINE stptri( uplo, diag, n, ap, 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 (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: diag INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: ap( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STPTRI computes the inverse of a real upper or lower triangular ! matrix A stored in packed format. ! ! 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. ! ! AP (input/output) REAL array, dimension (N*(N+1)/2) ! On entry, the upper or lower triangular matrix A, stored ! 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. ! See below for further details. ! On exit, the (triangular) inverse of the original matrix, in ! the same packed storage format. ! ! 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. ! ! Further Details ! =============== ! ! A triangular matrix A can be transferred to packed storage using one ! of the following program segments: ! ! UPLO = 'U': UPLO = 'L': ! ! JC = 1 JC = 1 ! DO 2 J = 1, N DO 2 J = 1, N ! DO 1 I = 1, J DO 1 I = J, N ! AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) ! 1 CONTINUE 1 CONTINUE ! JC = JC + J JC = JC + N - J + 1 ! 2 CONTINUE 2 CONTINUE ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: nounit, upper INTEGER :: j, jc, jclast, jj REAL :: ajj ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL sscal, stpmv, xerbla ! .. ! .. 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 < 0 ) THEN info = -3 END IF IF( info /= 0 ) THEN CALL xerbla( 'STPTRI', -info ) RETURN END IF ! ! Check for singularity if non-unit. ! IF( nounit ) THEN IF( upper ) THEN jj = 0 DO info = 1, n jj = jj + info IF( ap( jj ) == zero ) RETURN END DO ELSE jj = 1 DO info = 1, n IF( ap( jj ) == zero ) RETURN jj = jj + n - info + 1 END DO END IF info = 0 END IF ! IF( upper ) THEN ! ! Compute inverse of upper triangular matrix. ! jc = 1 DO j = 1, n IF( nounit ) THEN ap( jc+j-1 ) = one / ap( jc+j-1 ) ajj = -ap( jc+j-1 ) ELSE ajj = -one END IF ! ! Compute elements 1:j-1 of j-th column. ! CALL stpmv( 'Upper', 'No transpose', diag, j-1, ap, ap( jc ), 1 ) CALL sscal( j-1, ajj, ap( jc ), 1 ) jc = jc + j END DO ! ELSE ! ! Compute inverse of lower triangular matrix. ! jc = n*( n+1 ) / 2 DO j = n, 1, -1 IF( nounit ) THEN ap( jc ) = one / ap( jc ) ajj = -ap( jc ) ELSE ajj = -one END IF IF( j < n ) THEN ! ! Compute elements j+1:n of j-th column. ! CALL stpmv( 'Lower', 'No transpose', diag, n-j, & ap( jclast ), ap( jc+1 ), 1 ) CALL sscal( n-j, ajj, ap( jc+1 ), 1 ) END IF jclast = jc jc = jc - n + j - 2 END DO END IF ! RETURN ! ! End of STPTRI ! END SUBROUTINE stptri SUBROUTINE stptrs( uplo, trans, diag, n, nrhs, ap, 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 (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN OUT) :: trans CHARACTER (LEN=1), INTENT(IN) :: diag INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: ap( * ) REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STPTRS solves a triangular system of the form ! ! A * X = B or A**T * X = B, ! ! where A is a triangular matrix of order N stored in packed format, ! and B is an N-by-NRHS matrix. A check is made to verify that A is ! nonsingular. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! = 'U': A is upper triangular; ! = 'L': A is lower triangular. ! ! 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 = Transpose) ! ! 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. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of columns ! of the matrix B. NRHS >= 0. ! ! AP (input) REAL array, dimension (N*(N+1)/2) ! The upper or lower triangular 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. ! ! B (input/output) REAL array, dimension (LDB,NRHS) ! On entry, the right hand side matrix B. ! On exit, if INFO = 0, 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 ! > 0: if INFO = i, the i-th diagonal element of A is zero, ! indicating that the matrix is singular and the ! solutions X have not been computed. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: nounit, upper INTEGER :: j, jc ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL stpsv, 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.lsame( trans, 'N' ) .AND. .NOT. & lsame( trans, 'T' ) .AND. .NOT.lsame( trans, 'C' ) ) THEN info = -2 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( nrhs < 0 ) THEN info = -5 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -8 END IF IF( info /= 0 ) THEN CALL xerbla( 'STPTRS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Check for singularity. ! IF( nounit ) THEN IF( upper ) THEN jc = 1 DO info = 1, n IF( ap( jc+info-1 ) == zero ) RETURN jc = jc + info END DO ELSE jc = 1 DO info = 1, n IF( ap( jc ) == zero ) RETURN jc = jc + n - info + 1 END DO END IF END IF info = 0 ! ! Solve A * x = b or A' * x = b. ! DO j = 1, nrhs CALL stpsv( uplo, trans, diag, n, ap, b( 1, j ), 1 ) END DO ! RETURN ! ! End of STPTRS ! END SUBROUTINE stptrs SUBROUTINE strcon( norm, uplo, diag, n, a, lda, rcond, 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 ! March 31, 1993 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: norm CHARACTER (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: diag INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(OUT) :: rcond REAL, INTENT(IN) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STRCON estimates the reciprocal of the condition number of a ! triangular matrix A, in either the 1-norm or the infinity-norm. ! ! The norm of A is computed and an estimate is obtained for ! norm(inv(A)), then the reciprocal of the condition number is ! computed as ! RCOND = 1 / ( norm(A) * norm(inv(A)) ). ! ! Arguments ! ========= ! ! NORM (input) CHARACTER*1 ! Specifies whether the 1-norm condition number or the ! infinity-norm condition number is required: ! = '1' or 'O': 1-norm; ! = 'I': Infinity-norm. ! ! 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) REAL array, dimension (LDA,N) ! 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. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! RCOND (output) REAL ! The reciprocal of the condition number of the matrix A, ! computed as RCOND = 1/(norm(A) * norm(inv(A))). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: nounit, onenrm, upper CHARACTER (LEN=1) :: normin INTEGER :: ix, kase, kase1 REAL :: ainvnm, anorm, scale, smlnum, xnorm ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: isamax REAL :: slamch, slantr EXTERNAL lsame, isamax, slamch, slantr ! .. ! .. External Subroutines .. EXTERNAL slacon, slatrs, srscl, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, REAL ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 upper = lsame( uplo, 'U' ) onenrm = norm == '1' .OR. lsame( norm, 'O' ) nounit = lsame( diag, 'N' ) ! IF( .NOT.onenrm .AND. .NOT.lsame( norm, 'I' ) ) THEN info = -1 ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -2 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( lda < MAX( 1, n ) ) THEN info = -6 END IF IF( info /= 0 ) THEN CALL xerbla( 'STRCON', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) THEN rcond = one RETURN END IF ! rcond = zero smlnum = slamch( 'Safe minimum' )*REAL( MAX( 1, n ) ) ! ! Compute the norm of the triangular matrix A. ! anorm = slantr( norm, uplo, diag, n, n, a, lda, work ) ! ! Continue only if ANORM > 0. ! IF( anorm > zero ) THEN ! ! Estimate the norm of the inverse of A. ! ainvnm = zero normin = 'N' IF( onenrm ) THEN kase1 = 1 ELSE kase1 = 2 END IF kase = 0 10 CONTINUE CALL slacon( n, work( n+1 ), work, iwork, ainvnm, kase ) IF( kase /= 0 ) THEN IF( kase == kase1 ) THEN ! ! Multiply by inv(A). ! CALL slatrs( uplo, 'No transpose', diag, normin, n, a, & lda, work, scale, work( 2*n+1 ), info ) ELSE ! ! Multiply by inv(A'). ! CALL slatrs( uplo, 'Transpose', diag, normin, n, a, lda, & work, scale, work( 2*n+1 ), info ) END IF normin = 'Y' ! ! Multiply by 1/SCALE if doing so will not cause overflow. ! IF( scale /= one ) THEN ix = isamax( n, work, 1 ) xnorm = ABS( work( ix ) ) IF( scale < xnorm*smlnum .OR. scale == zero ) GO TO 20 CALL srscl( n, scale, work, 1 ) END IF GO TO 10 END IF ! ! Compute the estimate of the reciprocal condition number. ! IF( ainvnm /= zero ) rcond = ( one / anorm ) / ainvnm END IF ! 20 CONTINUE RETURN ! ! End of STRCON ! END SUBROUTINE strcon SUBROUTINE strevc( side, howmny, select, n, t, ldt, vl, ldvl, vr, & ldvr, mm, m, 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 .. CHARACTER (LEN=1), INTENT(IN) :: side CHARACTER (LEN=1), INTENT(IN) :: howmny LOGICAL, INTENT(OUT) :: select( * ) INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN) :: t( ldt, * ) INTEGER, INTENT(IN OUT) :: ldt REAL, INTENT(IN OUT) :: vl( ldvl, * ) INTEGER, INTENT(IN OUT) :: ldvl REAL, INTENT(IN OUT) :: vr( ldvr, * ) INTEGER, INTENT(IN OUT) :: ldvr INTEGER, INTENT(IN) :: mm INTEGER, INTENT(OUT) :: m REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STREVC computes some or all of the right and/or left eigenvectors of ! a real upper quasi-triangular matrix T. ! ! The right eigenvector x and the left eigenvector y of T corresponding ! to an eigenvalue w are defined by: ! ! T*x = w*x, y'*T = w*y' ! ! where y' denotes the conjugate transpose of the vector y. ! ! If all eigenvectors are requested, the routine may either return the ! matrices X and/or Y of right or left eigenvectors of T, or the ! products Q*X and/or Q*Y, where Q is an input orthogonal ! matrix. If T was obtained from the real-Schur factorization of an ! original matrix A = Q*T*Q', then Q*X and Q*Y are the matrices of ! right or left eigenvectors of A. ! ! T must be in Schur canonical form (as returned by SHSEQR), that is, ! block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each ! 2-by-2 diagonal block has its diagonal elements equal and its ! off-diagonal elements of opposite sign. Corresponding to each 2-by-2 ! diagonal block is a complex conjugate pair of eigenvalues and ! eigenvectors; only one eigenvector of the pair is computed, namely ! the one corresponding to the eigenvalue with positive imaginary part. ! ! Arguments ! ========= ! ! SIDE (input) CHARACTER*1 ! = 'R': compute right eigenvectors only; ! = 'L': compute left eigenvectors only; ! = 'B': compute both right and left eigenvectors. ! ! HOWMNY (input) CHARACTER*1 ! = 'A': compute all right and/or left eigenvectors; ! = 'B': compute all right and/or left eigenvectors, ! and backtransform them using the input matrices ! supplied in VR and/or VL; ! = 'S': compute selected right and/or left eigenvectors, ! specified by the logical array SELECT. ! ! SELECT (input/output) LOGICAL array, dimension (N) ! If HOWMNY = 'S', SELECT specifies the eigenvectors to be ! computed. ! If HOWMNY = 'A' or 'B', SELECT is not referenced. ! To select the real eigenvector corresponding to a real ! eigenvalue w(j), SELECT(j) must be set to .TRUE.. To select ! the complex eigenvector corresponding to a complex conjugate ! pair w(j) and w(j+1), either SELECT(j) or SELECT(j+1) must be ! set to .TRUE.; then on exit SELECT(j) is .TRUE. and ! SELECT(j+1) is .FALSE.. ! ! N (input) INTEGER ! The order of the matrix T. N >= 0. ! ! T (input) REAL array, dimension (LDT,N) ! The upper quasi-triangular matrix T in Schur canonical form. ! ! LDT (input) INTEGER ! The leading dimension of the array T. LDT >= max(1,N). ! ! VL (input/output) REAL 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 orthogonal matrix Q ! of Schur vectors returned by SHSEQR). ! On exit, if SIDE = 'L' or 'B', VL contains: ! if HOWMNY = 'A', the matrix Y of left eigenvectors of T; ! VL has the same quasi-lower triangular form ! as T'. If T(i,i) is a real eigenvalue, then ! the i-th column VL(i) of VL is its ! corresponding eigenvector. If T(i:i+1,i:i+1) ! is a 2-by-2 block whose eigenvalues are ! complex-conjugate eigenvalues of T, then ! VL(i)+sqrt(-1)*VL(i+1) is the complex ! eigenvector corresponding to the eigenvalue ! with positive real part. ! if HOWMNY = 'B', the matrix Q*Y; ! if HOWMNY = 'S', the left eigenvectors of T specified by ! SELECT, stored consecutively in the columns ! of VL, in the same order as their ! eigenvalues. ! A complex eigenvector corresponding to a complex eigenvalue ! is stored in two consecutive columns, the first holding the ! real part, and the second the imaginary part. ! If SIDE = 'R', VL is not referenced. ! ! LDVL (input) INTEGER ! The leading dimension of the array VL. LDVL >= max(1,N) if ! SIDE = 'L' or 'B'; LDVL >= 1 otherwise. ! ! VR (input/output) REAL 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 orthogonal matrix Q ! of Schur vectors returned by SHSEQR). ! On exit, if SIDE = 'R' or 'B', VR contains: ! if HOWMNY = 'A', the matrix X of right eigenvectors of T; ! VR has the same quasi-upper triangular form ! as T. If T(i,i) is a real eigenvalue, then ! the i-th column VR(i) of VR is its ! corresponding eigenvector. If T(i:i+1,i:i+1) ! is a 2-by-2 block whose eigenvalues are ! complex-conjugate eigenvalues of T, then ! VR(i)+sqrt(-1)*VR(i+1) is the complex ! eigenvector corresponding to the eigenvalue ! with positive real part. ! if HOWMNY = 'B', the matrix Q*X; ! if HOWMNY = 'S', the right eigenvectors of T specified by ! SELECT, stored consecutively in the columns ! of VR, in the same order as their ! eigenvalues. ! A complex eigenvector corresponding to a complex eigenvalue ! is stored in two consecutive columns, the first holding the ! real part and the second the imaginary part. ! 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 real eigenvector occupies one column and each ! selected complex eigenvector occupies two columns. ! ! WORK (workspace) REAL array, dimension (3*N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! Further Details ! =============== ! ! The algorithm used in this program is basically backward (forward) ! substitution, with scaling to make the the code robust against ! possible overflow. ! ! Each eigenvector is normalized so that the element of largest ! magnitude has magnitude 1; here the magnitude of a complex number ! (x,y) is taken to be |x| + |y|. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: allv, bothv, leftv, over, pair, rightv, somev INTEGER :: i, ierr, ii, ip, is, j, j1, j2, jnxt, k, ki, n2 REAL :: beta, bignum, emax, ovfl, REC, remax, scale, & smin, smlnum, ulp, unfl, vcrit, vmax, wi, wr, xnorm ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: isamax REAL :: sdot, slamch EXTERNAL lsame, isamax, sdot, slamch ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, sgemv, slabad, slaln2, sscal, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT ! .. ! .. Local Arrays .. REAL :: x( 2, 2 ) ! .. ! .. Executable Statements .. ! ! Decode and test the input parameters ! bothv = lsame( side, 'B' ) rightv = lsame( side, 'R' ) .OR. bothv leftv = lsame( side, 'L' ) .OR. bothv ! allv = lsame( howmny, 'A' ) over = lsame( howmny, 'B' ) somev = lsame( howmny, 'S' ) ! info = 0 IF( .NOT.rightv .AND. .NOT.leftv ) THEN info = -1 ELSE IF( .NOT.allv .AND. .NOT.over .AND. .NOT.somev ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( ldt < MAX( 1, n ) ) THEN info = -6 ELSE IF( ldvl < 1 .OR. ( leftv .AND. ldvl < n ) ) THEN info = -8 ELSE IF( ldvr < 1 .OR. ( rightv .AND. ldvr < n ) ) THEN info = -10 ELSE ! ! Set M to the number of columns required to store the selected ! eigenvectors, standardize the array SELECT if necessary, and ! test MM. ! IF( somev ) THEN m = 0 pair = .false. DO j = 1, n IF( pair ) THEN pair = .false. select( j ) = .false. ELSE IF( j < n ) THEN IF( t( j+1, j ) == zero ) THEN IF( select( j ) ) m = m + 1 ELSE pair = .true. IF( select( j ) .OR. select( j+1 ) ) THEN select( j ) = .true. m = m + 2 END IF END IF ELSE IF( select( n ) ) m = m + 1 END IF END IF END DO ELSE m = n END IF ! IF( mm < m ) THEN info = -11 END IF END IF IF( info /= 0 ) THEN CALL xerbla( 'STREVC', -info ) RETURN END IF ! ! Quick return if possible. ! IF( n == 0 ) RETURN ! ! Set the constants to control overflow. ! unfl = slamch( 'Safe minimum' ) ovfl = one / unfl CALL slabad( unfl, ovfl ) ulp = slamch( 'Precision' ) smlnum = unfl*( n / ulp ) bignum = ( one-ulp ) / smlnum ! ! Compute 1-norm of each column of strictly upper triangular ! part of T to control overflow in triangular solver. ! work( 1 ) = zero DO j = 2, n work( j ) = zero DO i = 1, j - 1 work( j ) = work( j ) + ABS( t( i, j ) ) END DO END DO ! ! Index IP is used to specify the real or complex eigenvalue: ! IP = 0, real eigenvalue, ! 1, first of conjugate complex pair: (wr,wi) ! -1, second of conjugate complex pair: (wr,wi) ! n2 = 2*n ! IF( rightv ) THEN ! ! Compute right eigenvectors. ! ip = 0 is = m DO ki = n, 1, -1 ! IF( ip == 1 ) GO TO 130 IF( ki == 1 ) GO TO 40 IF( t( ki, ki-1 ) == zero ) GO TO 40 ip = -1 ! 40 CONTINUE IF( somev ) THEN IF( ip == 0 ) THEN IF( .NOT.select( ki ) ) GO TO 130 ELSE IF( .NOT.select( ki-1 ) ) GO TO 130 END IF END IF ! ! Compute the KI-th eigenvalue (WR,WI). ! wr = t( ki, ki ) wi = zero IF( ip /= 0 ) wi = SQRT( ABS( t( ki, ki-1 ) ) )* & SQRT( ABS( t( ki-1, ki ) ) ) smin = MAX( ulp*( ABS( wr )+ABS( wi ) ), smlnum ) ! IF( ip == 0 ) THEN ! ! Real right eigenvector ! work( ki+n ) = one ! ! Form right-hand side ! DO k = 1, ki - 1 work( k+n ) = -t( k, ki ) END DO ! ! Solve the upper quasi-triangular system: ! (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. ! jnxt = ki - 1 DO j = ki - 1, 1, -1 IF( j > jnxt ) CYCLE j1 = j j2 = j jnxt = j - 1 IF( j > 1 ) THEN IF( t( j, j-1 ) /= zero ) THEN j1 = j - 1 jnxt = j - 2 END IF END IF ! IF( j1 == j2 ) THEN ! ! 1-by-1 diagonal block ! CALL slaln2( .false., 1, 1, smin, one, t( j, j ), & ldt, one, one, work( j+n ), n, wr, zero, x, 2, scale, xnorm, ierr ) ! ! Scale X(1,1) to avoid overflow when updating ! the right-hand side. ! IF( xnorm > one ) THEN IF( work( j ) > bignum / xnorm ) THEN x( 1, 1 ) = x( 1, 1 ) / xnorm scale = scale / xnorm END IF END IF ! ! Scale if necessary ! IF( scale /= one ) CALL sscal( ki, scale, work( 1+n ), 1 ) work( j+n ) = x( 1, 1 ) ! ! Update right-hand side ! CALL saxpy( j-1, -x( 1, 1 ), t( 1, j ), 1, work( 1+n ), 1 ) ! ELSE ! ! 2-by-2 diagonal block ! CALL slaln2( .false., 2, 1, smin, one, & t( j-1, j-1 ), ldt, one, one, work( j-1+n ), n, wr, zero, x, 2, & scale, xnorm, ierr ) ! ! Scale X(1,1) and X(2,1) to avoid overflow when ! updating the right-hand side. ! IF( xnorm > one ) THEN beta = MAX( work( j-1 ), work( j ) ) IF( beta > bignum / xnorm ) THEN x( 1, 1 ) = x( 1, 1 ) / xnorm x( 2, 1 ) = x( 2, 1 ) / xnorm scale = scale / xnorm END IF END IF ! ! Scale if necessary ! IF( scale /= one ) CALL sscal( ki, scale, work( 1+n ), 1 ) work( j-1+n ) = x( 1, 1 ) work( j+n ) = x( 2, 1 ) ! ! Update right-hand side ! CALL saxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1, work( 1+n ), 1 ) CALL saxpy( j-2, -x( 2, 1 ), t( 1, j ), 1, work( 1+n ), 1 ) END IF END DO ! ! Copy the vector x or Q*x to VR and normalize. ! IF( .NOT.over ) THEN CALL scopy( ki, work( 1+n ), 1, vr( 1, is ), 1 ) ! ii = isamax( ki, vr( 1, is ), 1 ) remax = one / ABS( vr( ii, is ) ) CALL sscal( ki, remax, vr( 1, is ), 1 ) ! DO k = ki + 1, n vr( k, is ) = zero END DO ELSE IF( ki > 1 ) CALL sgemv( 'N', n, ki-1, one, vr, ldvr, & work( 1+n ), 1, work( ki+n ), vr( 1, ki ), 1 ) ! ii = isamax( n, vr( 1, ki ), 1 ) remax = one / ABS( vr( ii, ki ) ) CALL sscal( n, remax, vr( 1, ki ), 1 ) END IF ! ELSE ! ! Complex right eigenvector. ! ! Initial solve ! [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. ! [ (T(KI,KI-1) T(KI,KI) ) ] ! IF( ABS( t( ki-1, ki ) ) >= ABS( t( ki, ki-1 ) ) ) THEN work( ki-1+n ) = one work( ki+n2 ) = wi / t( ki-1, ki ) ELSE work( ki-1+n ) = -wi / t( ki, ki-1 ) work( ki+n2 ) = one END IF work( ki+n ) = zero work( ki-1+n2 ) = zero ! ! Form right-hand side ! DO k = 1, ki - 2 work( k+n ) = -work( ki-1+n )*t( k, ki-1 ) work( k+n2 ) = -work( ki+n2 )*t( k, ki ) END DO ! ! Solve upper quasi-triangular system: ! (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) ! jnxt = ki - 2 DO j = ki - 2, 1, -1 IF( j > jnxt ) CYCLE j1 = j j2 = j jnxt = j - 1 IF( j > 1 ) THEN IF( t( j, j-1 ) /= zero ) THEN j1 = j - 1 jnxt = j - 2 END IF END IF ! IF( j1 == j2 ) THEN ! ! 1-by-1 diagonal block ! CALL slaln2( .false., 1, 2, smin, one, t( j, j ), & ldt, one, one, work( j+n ), n, wr, wi, x, 2, scale, xnorm, ierr ) ! ! Scale X(1,1) and X(1,2) to avoid overflow when ! updating the right-hand side. ! IF( xnorm > one ) THEN IF( work( j ) > bignum / xnorm ) THEN x( 1, 1 ) = x( 1, 1 ) / xnorm x( 1, 2 ) = x( 1, 2 ) / xnorm scale = scale / xnorm END IF END IF ! ! Scale if necessary ! IF( scale /= one ) THEN CALL sscal( ki, scale, work( 1+n ), 1 ) CALL sscal( ki, scale, work( 1+n2 ), 1 ) END IF work( j+n ) = x( 1, 1 ) work( j+n2 ) = x( 1, 2 ) ! ! Update the right-hand side ! CALL saxpy( j-1, -x( 1, 1 ), t( 1, j ), 1, work( 1+n ), 1 ) CALL saxpy( j-1, -x( 1, 2 ), t( 1, j ), 1, work( 1+n2 ), 1 ) ! ELSE ! ! 2-by-2 diagonal block ! CALL slaln2( .false., 2, 2, smin, one, & t( j-1, j-1 ), ldt, one, one, & work( j-1+n ), n, wr, wi, x, 2, scale, xnorm, ierr ) ! ! Scale X to avoid overflow when updating ! the right-hand side. ! IF( xnorm > one ) THEN beta = MAX( work( j-1 ), work( j ) ) IF( beta > bignum / xnorm ) THEN REC = one / xnorm x( 1, 1 ) = x( 1, 1 )*REC x( 1, 2 ) = x( 1, 2 )*REC x( 2, 1 ) = x( 2, 1 )*REC x( 2, 2 ) = x( 2, 2 )*REC scale = scale*REC END IF END IF ! ! Scale if necessary ! IF( scale /= one ) THEN CALL sscal( ki, scale, work( 1+n ), 1 ) CALL sscal( ki, scale, work( 1+n2 ), 1 ) END IF work( j-1+n ) = x( 1, 1 ) work( j+n ) = x( 2, 1 ) work( j-1+n2 ) = x( 1, 2 ) work( j+n2 ) = x( 2, 2 ) ! ! Update the right-hand side ! CALL saxpy( j-2, -x( 1, 1 ), t( 1, j-1 ), 1, work( 1+n ), 1 ) CALL saxpy( j-2, -x( 2, 1 ), t( 1, j ), 1, work( 1+n ), 1 ) CALL saxpy( j-2, -x( 1, 2 ), t( 1, j-1 ), 1, work( 1+n2 ), 1 ) CALL saxpy( j-2, -x( 2, 2 ), t( 1, j ), 1, work( 1+n2 ), 1 ) END IF END DO ! ! Copy the vector x or Q*x to VR and normalize. ! IF( .NOT.over ) THEN CALL scopy( ki, work( 1+n ), 1, vr( 1, is-1 ), 1 ) CALL scopy( ki, work( 1+n2 ), 1, vr( 1, is ), 1 ) ! emax = zero DO k = 1, ki emax = MAX( emax, ABS( vr( k, is-1 ) )+ ABS( vr( k, is ) ) ) END DO ! remax = one / emax CALL sscal( ki, remax, vr( 1, is-1 ), 1 ) CALL sscal( ki, remax, vr( 1, is ), 1 ) ! DO k = ki + 1, n vr( k, is-1 ) = zero vr( k, is ) = zero END DO ! ELSE ! IF( ki > 2 ) THEN CALL sgemv( 'N', n, ki-2, one, vr, ldvr, & work( 1+n ), 1, work( ki-1+n ), vr( 1, ki-1 ), 1 ) CALL sgemv( 'N', n, ki-2, one, vr, ldvr, & work( 1+n2 ), 1, work( ki+n2 ), vr( 1, ki ), 1 ) ELSE CALL sscal( n, work( ki-1+n ), vr( 1, ki-1 ), 1 ) CALL sscal( n, work( ki+n2 ), vr( 1, ki ), 1 ) END IF ! emax = zero DO k = 1, n emax = MAX( emax, ABS( vr( k, ki-1 ) )+ ABS( vr( k, ki ) ) ) END DO remax = one / emax CALL sscal( n, remax, vr( 1, ki-1 ), 1 ) CALL sscal( n, remax, vr( 1, ki ), 1 ) END IF END IF ! is = is - 1 IF( ip /= 0 ) is = is - 1 130 CONTINUE IF( ip == 1 ) ip = 0 IF( ip == -1 ) ip = 1 END DO END IF ! IF( leftv ) THEN ! ! Compute left eigenvectors. ! ip = 0 is = 1 DO ki = 1, n ! IF( ip == -1 ) GO TO 250 IF( ki == n ) GO TO 150 IF( t( ki+1, ki ) == zero ) GO TO 150 ip = 1 ! 150 CONTINUE IF( somev ) THEN IF( .NOT.select( ki ) ) GO TO 250 END IF ! ! Compute the KI-th eigenvalue (WR,WI). ! wr = t( ki, ki ) wi = zero IF( ip /= 0 ) wi = SQRT( ABS( t( ki, ki+1 ) ) )* & SQRT( ABS( t( ki+1, ki ) ) ) smin = MAX( ulp*( ABS( wr )+ABS( wi ) ), smlnum ) ! IF( ip == 0 ) THEN ! ! Real left eigenvector. ! work( ki+n ) = one ! ! Form right-hand side ! DO k = ki + 1, n work( k+n ) = -t( ki, k ) END DO ! ! Solve the quasi-triangular system: ! (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK ! vmax = one vcrit = bignum ! jnxt = ki + 1 DO j = ki + 1, n IF( j < jnxt ) CYCLE j1 = j j2 = j jnxt = j + 1 IF( j < n ) THEN IF( t( j+1, j ) /= zero ) THEN j2 = j + 1 jnxt = j + 2 END IF END IF ! IF( j1 == j2 ) THEN ! ! 1-by-1 diagonal block ! ! Scale if necessary to avoid overflow when forming ! the right-hand side. ! IF( work( j ) > vcrit ) THEN REC = one / vmax CALL sscal( n-ki+1, REC, work( ki+n ), 1 ) vmax = one vcrit = bignum END IF ! work( j+n ) = work( j+n ) - sdot( j-ki-1, t( ki+1, j ), 1, & work( ki+1+n ), 1 ) ! ! Solve (T(J,J)-WR)'*X = WORK ! CALL slaln2( .false., 1, 1, smin, one, t( j, j ), & ldt, one, one, work( j+n ), n, wr, zero, x, 2, scale, xnorm, ierr ) ! ! Scale if necessary ! IF( scale /= one ) CALL sscal( n-ki+1, scale, work( ki+n ), 1 ) work( j+n ) = x( 1, 1 ) vmax = MAX( ABS( work( j+n ) ), vmax ) vcrit = bignum / vmax ! ELSE ! ! 2-by-2 diagonal block ! ! Scale if necessary to avoid overflow when forming ! the right-hand side. ! beta = MAX( work( j ), work( j+1 ) ) IF( beta > vcrit ) THEN REC = one / vmax CALL sscal( n-ki+1, REC, work( ki+n ), 1 ) vmax = one vcrit = bignum END IF ! work( j+n ) = work( j+n ) - sdot( j-ki-1, t( ki+1, j ), 1, & work( ki+1+n ), 1 ) ! work( j+1+n ) = work( j+1+n ) - sdot( j-ki-1, t( ki+1, j+1 ), 1, & work( ki+1+n ), 1 ) ! ! Solve ! [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 ) ! [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) ! CALL slaln2( .true., 2, 1, smin, one, t( j, j ), & ldt, one, one, work( j+n ), n, wr, zero, x, 2, scale, xnorm, ierr ) ! ! Scale if necessary ! IF( scale /= one ) CALL sscal( n-ki+1, scale, work( ki+n ), 1 ) work( j+n ) = x( 1, 1 ) work( j+1+n ) = x( 2, 1 ) ! vmax = MAX( ABS( work( j+n ) ), ABS( work( j+1+n ) ), vmax ) vcrit = bignum / vmax ! END IF END DO ! ! Copy the vector x or Q*x to VL and normalize. ! IF( .NOT.over ) THEN CALL scopy( n-ki+1, work( ki+n ), 1, vl( ki, is ), 1 ) ! ii = isamax( n-ki+1, vl( ki, is ), 1 ) + ki - 1 remax = one / ABS( vl( ii, is ) ) CALL sscal( n-ki+1, remax, vl( ki, is ), 1 ) ! DO k = 1, ki - 1 vl( k, is ) = zero END DO ! ELSE ! IF( ki < n ) CALL sgemv( 'N', n, n-ki, one, vl( 1, ki+1 ), ldvl, & work( ki+1+n ), 1, work( ki+n ), vl( 1, ki ), 1 ) ! ii = isamax( n, vl( 1, ki ), 1 ) remax = one / ABS( vl( ii, ki ) ) CALL sscal( n, remax, vl( 1, ki ), 1 ) ! END IF ! ELSE ! ! Complex left eigenvector. ! ! Initial solve: ! ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0. ! ((T(KI+1,KI) T(KI+1,KI+1)) ) ! IF( ABS( t( ki, ki+1 ) ) >= ABS( t( ki+1, ki ) ) ) THEN work( ki+n ) = wi / t( ki, ki+1 ) work( ki+1+n2 ) = one ELSE work( ki+n ) = one work( ki+1+n2 ) = -wi / t( ki+1, ki ) END IF work( ki+1+n ) = zero work( ki+n2 ) = zero ! ! Form right-hand side ! DO k = ki + 2, n work( k+n ) = -work( ki+n )*t( ki, k ) work( k+n2 ) = -work( ki+1+n2 )*t( ki+1, k ) END DO ! ! Solve complex quasi-triangular system: ! ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 ! vmax = one vcrit = bignum ! jnxt = ki + 2 DO j = ki + 2, n IF( j < jnxt ) CYCLE j1 = j j2 = j jnxt = j + 1 IF( j < n ) THEN IF( t( j+1, j ) /= zero ) THEN j2 = j + 1 jnxt = j + 2 END IF END IF ! IF( j1 == j2 ) THEN ! ! 1-by-1 diagonal block ! ! Scale if necessary to avoid overflow when ! forming the right-hand side elements. ! IF( work( j ) > vcrit ) THEN REC = one / vmax CALL sscal( n-ki+1, REC, work( ki+n ), 1 ) CALL sscal( n-ki+1, REC, work( ki+n2 ), 1 ) vmax = one vcrit = bignum END IF ! work( j+n ) = work( j+n ) - sdot( j-ki-2, t( ki+2, j ), 1, & work( ki+2+n ), 1 ) work( j+n2 ) = work( j+n2 ) - sdot( j-ki-2, t( ki+2, j ), 1, & work( ki+2+n2 ), 1 ) ! ! Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 ! CALL slaln2( .false., 1, 2, smin, one, t( j, j ), & ldt, one, one, work( j+n ), n, wr, -wi, x, 2, scale, xnorm, ierr ) ! ! Scale if necessary ! IF( scale /= one ) THEN CALL sscal( n-ki+1, scale, work( ki+n ), 1 ) CALL sscal( n-ki+1, scale, work( ki+n2 ), 1 ) END IF work( j+n ) = x( 1, 1 ) work( j+n2 ) = x( 1, 2 ) vmax = MAX( ABS( work( j+n ) ), ABS( work( j+n2 ) ), vmax ) vcrit = bignum / vmax ! ELSE ! ! 2-by-2 diagonal block ! ! Scale if necessary to avoid overflow when forming ! the right-hand side elements. ! beta = MAX( work( j ), work( j+1 ) ) IF( beta > vcrit ) THEN REC = one / vmax CALL sscal( n-ki+1, REC, work( ki+n ), 1 ) CALL sscal( n-ki+1, REC, work( ki+n2 ), 1 ) vmax = one vcrit = bignum END IF ! work( j+n ) = work( j+n ) - sdot( j-ki-2, t( ki+2, j ), 1, & work( ki+2+n ), 1 ) ! work( j+n2 ) = work( j+n2 ) - sdot( j-ki-2, t( ki+2, j ), 1, & work( ki+2+n2 ), 1 ) ! work( j+1+n ) = work( j+1+n ) - sdot( j-ki-2, t( ki+2, j+1 ), 1, & work( ki+2+n ), 1 ) ! work( j+1+n2 ) = work( j+1+n2 ) - & sdot( j-ki-2, t( ki+2, j+1 ), 1, work( ki+2+n2 ), 1 ) ! ! Solve 2-by-2 complex linear equation ! ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B ! ([T(j+1,j) T(j+1,j+1)] ) ! CALL slaln2( .true., 2, 2, smin, one, t( j, j ), & ldt, one, one, work( j+n ), n, wr, -wi, x, 2, scale, xnorm, ierr ) ! ! Scale if necessary ! IF( scale /= one ) THEN CALL sscal( n-ki+1, scale, work( ki+n ), 1 ) CALL sscal( n-ki+1, scale, work( ki+n2 ), 1 ) END IF work( j+n ) = x( 1, 1 ) work( j+n2 ) = x( 1, 2 ) work( j+1+n ) = x( 2, 1 ) work( j+1+n2 ) = x( 2, 2 ) vmax = MAX( ABS( x( 1, 1 ) ), ABS( x( 1, 2 ) ), & ABS( x( 2, 1 ) ), ABS( x( 2, 2 ) ), vmax ) vcrit = bignum / vmax ! END IF END DO ! ! Copy the vector x or Q*x to VL and normalize. ! 210 CONTINUE IF( .NOT.over ) THEN CALL scopy( n-ki+1, work( ki+n ), 1, vl( ki, is ), 1 ) CALL scopy( n-ki+1, work( ki+n2 ), 1, vl( ki, is+1 ), 1 ) ! emax = zero DO k = ki, n emax = MAX( emax, ABS( vl( k, is ) )+ ABS( vl( k, is+1 ) ) ) END DO remax = one / emax CALL sscal( n-ki+1, remax, vl( ki, is ), 1 ) CALL sscal( n-ki+1, remax, vl( ki, is+1 ), 1 ) ! DO k = 1, ki - 1 vl( k, is ) = zero vl( k, is+1 ) = zero END DO ELSE IF( ki < n-1 ) THEN CALL sgemv( 'N', n, n-ki-1, one, vl( 1, ki+2 ), & ldvl, work( ki+2+n ), 1, work( ki+n ), vl( 1, ki ), 1 ) CALL sgemv( 'N', n, n-ki-1, one, vl( 1, ki+2 ), & ldvl, work( ki+2+n2 ), 1, work( ki+1+n2 ), vl( 1, ki+1 ), 1 ) ELSE CALL sscal( n, work( ki+n ), vl( 1, ki ), 1 ) CALL sscal( n, work( ki+1+n2 ), vl( 1, ki+1 ), 1 ) END IF ! emax = zero DO k = 1, n emax = MAX( emax, ABS( vl( k, ki ) )+ ABS( vl( k, ki+1 ) ) ) END DO remax = one / emax CALL sscal( n, remax, vl( 1, ki ), 1 ) CALL sscal( n, remax, vl( 1, ki+1 ), 1 ) ! END IF ! END IF ! is = is + 1 IF( ip /= 0 ) is = is + 1 250 CONTINUE IF( ip == -1 ) ip = 0 IF( ip == 1 ) ip = -1 ! END DO ! END IF ! RETURN ! ! End of STREVC ! END SUBROUTINE strevc SUBROUTINE strexc( compq, n, t, ldt, q, ldq, ifst, ilst, 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 (LEN=1), INTENT(IN) :: compq INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: t( ldt, * ) INTEGER, INTENT(IN OUT) :: ldt REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq INTEGER, INTENT(IN OUT) :: ifst INTEGER, INTENT(IN OUT) :: ilst REAL, INTENT(IN OUT) :: work( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STREXC reorders the real Schur factorization of a real matrix ! A = Q*T*Q**T, so that the diagonal block of T with row index IFST is ! moved to row ILST. ! ! The real Schur form T is reordered by an orthogonal similarity ! transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors ! is updated by postmultiplying it with Z. ! ! T must be in Schur canonical form (as returned by SHSEQR), that is, ! block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each ! 2-by-2 diagonal block has its diagonal elements equal and its ! off-diagonal elements of opposite sign. ! ! Arguments ! ========= ! ! COMPQ (input) CHARACTER*1 ! = 'V': update the matrix Q of Schur vectors; ! = 'N': do not update Q. ! ! N (input) INTEGER ! The order of the matrix T. N >= 0. ! ! T (input/output) REAL array, dimension (LDT,N) ! On entry, the upper quasi-triangular matrix T, in Schur ! Schur canonical form. ! On exit, the reordered upper quasi-triangular matrix, again ! in Schur canonical form. ! ! LDT (input) INTEGER ! The leading dimension of the array T. LDT >= max(1,N). ! ! Q (input/output) REAL array, dimension (LDQ,N) ! On entry, if COMPQ = 'V', the matrix Q of Schur vectors. ! On exit, if COMPQ = 'V', Q has been postmultiplied by the ! orthogonal transformation matrix Z which reorders T. ! If COMPQ = 'N', Q is not referenced. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. LDQ >= max(1,N). ! ! IFST (input/output) INTEGER ! ILST (input/output) INTEGER ! Specify the reordering of the diagonal blocks of T. ! The block with row index IFST is moved to row ILST, by a ! sequence of transpositions between adjacent blocks. ! On exit, if IFST pointed on entry to the second row of a ! 2-by-2 block, it is changed to point to the first row; ILST ! always points to the first row of the block in its final ! position (which may differ from its input value by +1 or -1). ! 1 <= IFST <= N; 1 <= ILST <= N. ! ! WORK (workspace) REAL array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! = 1: two adjacent blocks were too close to swap (the problem ! is very ill-conditioned); T may have been partially ! reordered, and ILST points to the first row of the ! current position of the block being moved. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: wantq INTEGER :: here, nbf, nbl, nbnext ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL slaexc, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Decode and test the input arguments. ! info = 0 wantq = lsame( compq, 'V' ) IF( .NOT.wantq .AND. .NOT.lsame( compq, 'N' ) ) THEN info = -1 ELSE IF( n < 0 ) THEN info = -2 ELSE IF( ldt < MAX( 1, n ) ) THEN info = -4 ELSE IF( ldq < 1 .OR. ( wantq .AND. ldq < MAX( 1, n ) ) ) THEN info = -6 ELSE IF( ifst < 1 .OR. ifst > n ) THEN info = -7 ELSE IF( ilst < 1 .OR. ilst > n ) THEN info = -8 END IF IF( info /= 0 ) THEN CALL xerbla( 'STREXC', -info ) RETURN END IF ! ! Quick return if possible ! IF( n <= 1 ) RETURN ! ! Determine the first row of specified block ! and find out it is 1 by 1 or 2 by 2. ! IF( ifst > 1 ) THEN IF( t( ifst, ifst-1 ) /= zero ) ifst = ifst - 1 END IF nbf = 1 IF( ifst < n ) THEN IF( t( ifst+1, ifst ) /= zero ) nbf = 2 END IF ! ! Determine the first row of the final block ! and find out it is 1 by 1 or 2 by 2. ! IF( ilst > 1 ) THEN IF( t( ilst, ilst-1 ) /= zero ) ilst = ilst - 1 END IF nbl = 1 IF( ilst < n ) THEN IF( t( ilst+1, ilst ) /= zero ) nbl = 2 END IF ! IF( ifst == ilst ) RETURN ! IF( ifst < ilst ) THEN ! ! Update ILST ! IF( nbf == 2 .AND. nbl == 1 ) ilst = ilst - 1 IF( nbf == 1 .AND. nbl == 2 ) ilst = ilst + 1 ! here = ifst ! 10 CONTINUE ! ! Swap block with next one below ! IF( nbf == 1 .OR. nbf == 2 ) THEN ! ! Current block either 1 by 1 or 2 by 2 ! nbnext = 1 IF( here+nbf+1 <= n ) THEN IF( t( here+nbf+1, here+nbf ) /= zero ) nbnext = 2 END IF CALL slaexc( wantq, n, t, ldt, q, ldq, here, nbf, nbnext, work, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF here = here + nbnext ! ! Test if 2 by 2 block breaks into two 1 by 1 blocks ! IF( nbf == 2 ) THEN IF( t( here+1, here ) == zero ) nbf = 3 END IF ! ELSE ! ! Current block consists of two 1 by 1 blocks each of which ! must be swapped individually ! nbnext = 1 IF( here+3 <= n ) THEN IF( t( here+3, here+2 ) /= zero ) nbnext = 2 END IF CALL slaexc( wantq, n, t, ldt, q, ldq, here+1, 1, nbnext, work, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF IF( nbnext == 1 ) THEN ! ! Swap two 1 by 1 blocks, no problems possible ! CALL slaexc( wantq, n, t, ldt, q, ldq, here, 1, nbnext, work, info ) here = here + 1 ELSE ! ! Recompute NBNEXT in case 2 by 2 split ! IF( t( here+2, here+1 ) == zero ) nbnext = 1 IF( nbnext == 2 ) THEN ! ! 2 by 2 Block did not split ! CALL slaexc( wantq, n, t, ldt, q, ldq, here, 1, nbnext, work, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF here = here + 2 ELSE ! ! 2 by 2 Block did split ! CALL slaexc( wantq, n, t, ldt, q, ldq, here, 1, 1, work, info ) CALL slaexc( wantq, n, t, ldt, q, ldq, here+1, 1, 1, work, info ) here = here + 2 END IF END IF END IF IF( here < ilst ) GO TO 10 ! ELSE ! here = ifst 20 CONTINUE ! ! Swap block with next one above ! IF( nbf == 1 .OR. nbf == 2 ) THEN ! ! Current block either 1 by 1 or 2 by 2 ! nbnext = 1 IF( here >= 3 ) THEN IF( t( here-1, here-2 ) /= zero ) nbnext = 2 END IF CALL slaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext, & nbf, work, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF here = here - nbnext ! ! Test if 2 by 2 block breaks into two 1 by 1 blocks ! IF( nbf == 2 ) THEN IF( t( here+1, here ) == zero ) nbf = 3 END IF ! ELSE ! ! Current block consists of two 1 by 1 blocks each of which ! must be swapped individually ! nbnext = 1 IF( here >= 3 ) THEN IF( t( here-1, here-2 ) /= zero ) nbnext = 2 END IF CALL slaexc( wantq, n, t, ldt, q, ldq, here-nbnext, nbnext, & 1, work, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF IF( nbnext == 1 ) THEN ! ! Swap two 1 by 1 blocks, no problems possible ! CALL slaexc( wantq, n, t, ldt, q, ldq, here, nbnext, 1, work, info ) here = here - 1 ELSE ! ! Recompute NBNEXT in case 2 by 2 split ! IF( t( here, here-1 ) == zero ) nbnext = 1 IF( nbnext == 2 ) THEN ! ! 2 by 2 Block did not split ! CALL slaexc( wantq, n, t, ldt, q, ldq, here-1, 2, 1, work, info ) IF( info /= 0 ) THEN ilst = here RETURN END IF here = here - 2 ELSE ! ! 2 by 2 Block did split ! CALL slaexc( wantq, n, t, ldt, q, ldq, here, 1, 1, work, info ) CALL slaexc( wantq, n, t, ldt, q, ldq, here-1, 1, 1, work, info ) here = here - 2 END IF END IF END IF IF( here > ilst ) GO TO 20 END IF ilst = here ! RETURN ! ! End of STREXC ! END SUBROUTINE strexc SUBROUTINE strrfs( uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, & ldx, ferr, berr, 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 ! September 30, 1994 ! ! .. Scalar Arguments .. CHARACTER (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: trans CHARACTER (LEN=1), INTENT(IN) :: diag INTEGER, INTENT(IN OUT) :: n INTEGER, INTENT(IN) :: nrhs REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN) :: x( ldx, * ) INTEGER, INTENT(IN OUT) :: ldx REAL, INTENT(OUT) :: ferr( * ) REAL, INTENT(OUT) :: berr( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STRRFS provides error bounds and backward error estimates for the ! solution to a system of linear equations with a triangular ! coefficient matrix. ! ! The solution matrix X must be computed by STRTRS or some other ! means before entering this routine. STRRFS does not do iterative ! refinement because doing so cannot improve the backward error. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! = 'U': A is upper triangular; ! = 'L': A is lower triangular. ! ! 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 = Transpose) ! ! 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. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of columns ! of the matrices B and X. NRHS >= 0. ! ! A (input) REAL array, dimension (LDA,N) ! 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. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! B (input) REAL array, dimension (LDB,NRHS) ! The right hand side matrix B. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! X (input) REAL array, dimension (LDX,NRHS) ! The solution matrix X. ! ! LDX (input) INTEGER ! The leading dimension of the array X. LDX >= max(1,N). ! ! FERR (output) REAL array, dimension (NRHS) ! The estimated forward error bound for each solution vector ! X(j) (the j-th column of the solution matrix X). ! If XTRUE is the true solution corresponding to X(j), FERR(j) ! is an estimated upper bound for the magnitude of the largest ! element in (X(j) - XTRUE) divided by the magnitude of the ! largest element in X(j). The estimate is as reliable as ! the estimate for RCOND, and is almost always a slight ! overestimate of the true error. ! ! BERR (output) REAL array, dimension (NRHS) ! The componentwise relative backward error of each solution ! vector X(j) (i.e., the smallest relative change in ! any element of A or B that makes X(j) an exact solution). ! ! WORK (workspace) REAL array, dimension (3*N) ! ! IWORK (workspace) INTEGER array, dimension (N) ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: notran, nounit, upper CHARACTER (LEN=1) :: transt INTEGER :: i, j, k, kase, nz REAL :: eps, lstres, s, safe1, safe2, safmin, xk ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, slacon, strmv, strsv, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slamch EXTERNAL lsame, slamch ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 upper = lsame( uplo, 'U' ) notran = lsame( trans, 'N' ) nounit = lsame( diag, 'N' ) ! IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -1 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) .AND. .NOT. & lsame( trans, 'C' ) ) THEN info = -2 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( nrhs < 0 ) THEN info = -5 ELSE IF( lda < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -9 ELSE IF( ldx < MAX( 1, n ) ) THEN info = -11 END IF IF( info /= 0 ) THEN CALL xerbla( 'STRRFS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 .OR. nrhs == 0 ) THEN DO j = 1, nrhs ferr( j ) = zero berr( j ) = zero END DO RETURN END IF ! IF( notran ) THEN transt = 'T' ELSE transt = 'N' END IF ! ! NZ = maximum number of nonzero elements in each row of A, plus 1 ! nz = n + 1 eps = slamch( 'Epsilon' ) safmin = slamch( 'Safe minimum' ) safe1 = nz*safmin safe2 = safe1 / eps ! ! Do for each right hand side ! DO j = 1, nrhs ! ! Compute residual R = B - op(A) * X, ! where op(A) = A or A', depending on TRANS. ! CALL scopy( n, x( 1, j ), 1, work( n+1 ), 1 ) CALL strmv( uplo, trans, diag, n, a, lda, work( n+1 ), 1 ) CALL saxpy( n, -one, b( 1, j ), 1, work( n+1 ), 1 ) ! ! Compute componentwise relative backward error from formula ! ! max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) ! ! where abs(Z) is the componentwise absolute value of the matrix ! or vector Z. If the i-th component of the denominator is less ! than SAFE2, then SAFE1 is added to the i-th components of the ! numerator and denominator before dividing. ! DO i = 1, n work( i ) = ABS( b( i, j ) ) END DO ! IF( notran ) THEN ! ! Compute abs(A)*abs(X) + abs(B). ! IF( upper ) THEN IF( nounit ) THEN DO k = 1, n xk = ABS( x( k, j ) ) DO i = 1, k work( i ) = work( i ) + ABS( a( i, k ) )*xk END DO END DO ELSE DO k = 1, n xk = ABS( x( k, j ) ) DO i = 1, k - 1 work( i ) = work( i ) + ABS( a( i, k ) )*xk END DO work( k ) = work( k ) + xk END DO END IF ELSE IF( nounit ) THEN DO k = 1, n xk = ABS( x( k, j ) ) DO i = k, n work( i ) = work( i ) + ABS( a( i, k ) )*xk END DO END DO ELSE DO k = 1, n xk = ABS( x( k, j ) ) DO i = k + 1, n work( i ) = work( i ) + ABS( a( i, k ) )*xk END DO work( k ) = work( k ) + xk END DO END IF END IF ELSE ! ! Compute abs(A')*abs(X) + abs(B). ! IF( upper ) THEN IF( nounit ) THEN DO k = 1, n s = zero DO i = 1, k s = s + ABS( a( i, k ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + s END DO ELSE DO k = 1, n s = ABS( x( k, j ) ) DO i = 1, k - 1 s = s + ABS( a( i, k ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + s END DO END IF ELSE IF( nounit ) THEN DO k = 1, n s = zero DO i = k, n s = s + ABS( a( i, k ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + s END DO ELSE DO k = 1, n s = ABS( x( k, j ) ) DO i = k + 1, n s = s + ABS( a( i, k ) )*ABS( x( i, j ) ) END DO work( k ) = work( k ) + s END DO END IF END IF END IF s = zero DO i = 1, n IF( work( i ) > safe2 ) THEN s = MAX( s, ABS( work( n+i ) ) / work( i ) ) ELSE s = MAX( s, ( ABS( work( n+i ) )+safe1 ) / ( work( i )+safe1 ) ) END IF END DO berr( j ) = s ! ! Bound error from formula ! ! norm(X - XTRUE) / norm(X) .le. FERR = ! norm( abs(inv(op(A)))* ! ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) ! ! where ! norm(Z) is the magnitude of the largest component of Z ! inv(op(A)) is the inverse of op(A) ! abs(Z) is the componentwise absolute value of the matrix or ! vector Z ! NZ is the maximum number of nonzeros in any row of A, plus 1 ! EPS is machine epsilon ! ! The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) ! is incremented by SAFE1 if the i-th component of ! abs(op(A))*abs(X) + abs(B) is less than SAFE2. ! ! Use SLACON to estimate the infinity-norm of the matrix ! inv(op(A)) * diag(W), ! where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) ! DO i = 1, n IF( work( i ) > safe2 ) THEN work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) ELSE work( i ) = ABS( work( n+i ) ) + nz*eps*work( i ) + safe1 END IF END DO ! kase = 0 210 CONTINUE CALL slacon( n, work( 2*n+1 ), work( n+1 ), iwork, ferr( j ), kase ) IF( kase /= 0 ) THEN IF( kase == 1 ) THEN ! ! Multiply by diag(W)*inv(op(A)'). ! CALL strsv( uplo, transt, diag, n, a, lda, work( n+1 ), 1 ) DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO ELSE ! ! Multiply by inv(op(A))*diag(W). ! DO i = 1, n work( n+i ) = work( i )*work( n+i ) END DO CALL strsv( uplo, trans, diag, n, a, lda, work( n+1 ), 1 ) END IF GO TO 210 END IF ! ! Normalize error. ! lstres = zero DO i = 1, n lstres = MAX( lstres, ABS( x( i, j ) ) ) END DO IF( lstres /= zero ) ferr( j ) = ferr( j ) / lstres ! END DO ! RETURN ! ! End of STRRFS ! END SUBROUTINE strrfs SUBROUTINE strsen( job, compq, select, n, t, ldt, q, ldq, wr, wi, & m, s, sep, work, lwork, iwork, liwork, 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 (LEN=1), INTENT(IN) :: job CHARACTER (LEN=1), INTENT(IN) :: compq LOGICAL, INTENT(IN) :: select( * ) INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: t( ldt, * ) INTEGER, INTENT(IN) :: ldt REAL, INTENT(IN OUT) :: q( ldq, * ) INTEGER, INTENT(IN OUT) :: ldq REAL, INTENT(OUT) :: wr( * ) REAL, INTENT(OUT) :: wi( * ) INTEGER, INTENT(OUT) :: m REAL, INTENT(OUT) :: s REAL, INTENT(OUT) :: sep REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: iwork( * ) INTEGER, INTENT(IN OUT) :: liwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STRSEN reorders the real Schur factorization of a real matrix ! A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in ! the leading diagonal blocks of the upper quasi-triangular matrix T, ! and the leading columns of Q form an orthonormal basis of the ! corresponding right invariant subspace. ! ! Optionally the routine computes the reciprocal condition numbers of ! the cluster of eigenvalues and/or the invariant subspace. ! ! T must be in Schur canonical form (as returned by SHSEQR), that is, ! block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each ! 2-by-2 diagonal block has its diagonal elemnts equal and its ! off-diagonal elements of opposite sign. ! ! Arguments ! ========= ! ! JOB (input) CHARACTER*1 ! Specifies whether condition numbers are required for the ! cluster of eigenvalues (S) or the invariant subspace (SEP): ! = 'N': none; ! = 'E': for eigenvalues only (S); ! = 'V': for invariant subspace only (SEP); ! = 'B': for both eigenvalues and invariant subspace (S and ! SEP). ! ! COMPQ (input) CHARACTER*1 ! = 'V': update the matrix Q of Schur vectors; ! = 'N': do not update Q. ! ! SELECT (input) LOGICAL array, dimension (N) ! SELECT specifies the eigenvalues in the selected cluster. To ! select a real eigenvalue w(j), SELECT(j) must be set to ! .TRUE.. To select a complex conjugate pair of eigenvalues ! w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, ! either SELECT(j) or SELECT(j+1) or both must be set to ! .TRUE.; a complex conjugate pair of eigenvalues must be ! either both included in the cluster or both excluded. ! ! N (input) INTEGER ! The order of the matrix T. N >= 0. ! ! T (input/output) REAL array, dimension (LDT,N) ! On entry, the upper quasi-triangular matrix T, in Schur ! canonical form. ! On exit, T is overwritten by the reordered matrix T, again in ! Schur canonical form, with the selected eigenvalues in the ! leading diagonal blocks. ! ! LDT (input) INTEGER ! The leading dimension of the array T. LDT >= max(1,N). ! ! Q (input/output) REAL array, dimension (LDQ,N) ! On entry, if COMPQ = 'V', the matrix Q of Schur vectors. ! On exit, if COMPQ = 'V', Q has been postmultiplied by the ! orthogonal transformation matrix which reorders T; the ! leading M columns of Q form an orthonormal basis for the ! specified invariant subspace. ! If COMPQ = 'N', Q is not referenced. ! ! LDQ (input) INTEGER ! The leading dimension of the array Q. ! LDQ >= 1; and if COMPQ = 'V', LDQ >= N. ! ! WR (output) REAL array, dimension (N) ! WI (output) REAL array, dimension (N) ! The real and imaginary parts, respectively, of the reordered ! eigenvalues of T. The eigenvalues are stored in the same ! order as on the diagonal of T, with WR(i) = T(i,i) and, if ! T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and ! WI(i+1) = -WI(i). Note that if a complex eigenvalue is ! sufficiently ill-conditioned, then its value may differ ! significantly from its value before reordering. ! ! M (output) INTEGER ! The dimension of the specified invariant subspace. ! 0 < = M <= N. ! ! S (output) REAL ! If JOB = 'E' or 'B', S is a lower bound on the reciprocal ! condition number for the selected cluster of eigenvalues. ! S cannot underestimate the true reciprocal condition number ! by more than a factor of sqrt(N). If M = 0 or N, S = 1. ! If JOB = 'N' or 'V', S is not referenced. ! ! SEP (output) REAL ! If JOB = 'V' or 'B', SEP is the estimated reciprocal ! condition number of the specified invariant subspace. If ! M = 0 or N, SEP = norm(T). ! If JOB = 'N' or 'E', SEP is not referenced. ! ! WORK (workspace/output) REAL array, dimension (LWORK) ! On exit, if INFO = 0, WORK(1) returns the optimal LWORK. ! ! LWORK (input) INTEGER ! The dimension of the array WORK. ! If JOB = 'N', LWORK >= max(1,N); ! if JOB = 'E', LWORK >= M*(N-M); ! if JOB = 'V' or 'B', LWORK >= 2*M*(N-M). ! ! 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 (LIWORK) ! IF JOB = 'N' or 'E', IWORK is not referenced. ! ! LIWORK (input) INTEGER ! The dimension of the array IWORK. ! If JOB = 'N' or 'E', LIWORK >= 1; ! if JOB = 'V' or 'B', LIWORK >= M*(N-M). ! ! If LIWORK = -1, then a workspace query is assumed; the ! routine only calculates the optimal size of the IWORK array, ! returns this value as the first entry of the IWORK array, and ! no error message related to LIWORK is issued by XERBLA. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! = 1: reordering of T failed because some eigenvalues are too ! close to separate (the problem is very ill-conditioned); ! T may have been partially reordered, and WR and WI ! contain the eigenvalues in the same order as in T; S and ! SEP (if requested) are set to zero. ! ! Further Details ! =============== ! ! STRSEN first collects the selected eigenvalues by computing an ! orthogonal transformation Z to move them to the top left corner of T. ! In other words, the selected eigenvalues are the eigenvalues of T11 ! in: ! ! Z'*T*Z = ( T11 T12 ) n1 ! ( 0 T22 ) n2 ! n1 n2 ! ! where N = n1+n2 and Z' means the transpose of Z. The first n1 columns ! of Z span the specified invariant subspace of T. ! ! If T has been obtained from the real Schur factorization of a matrix ! A = Q*T*Q', then the reordered real Schur factorization of A is given ! by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span ! the corresponding invariant subspace of A. ! ! The reciprocal condition number of the average of the eigenvalues of ! T11 may be returned in S. S lies between 0 (very badly conditioned) ! and 1 (very well conditioned). It is computed as follows. First we ! compute R so that ! ! P = ( I R ) n1 ! ( 0 0 ) n2 ! n1 n2 ! ! is the projector on the invariant subspace associated with T11. ! R is the solution of the Sylvester equation: ! ! T11*R - R*T22 = T12. ! ! Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote ! the two-norm of M. Then S is computed as the lower bound ! ! (1 + F-norm(R)**2)**(-1/2) ! ! on the reciprocal of 2-norm(P), the true reciprocal condition number. ! S cannot underestimate 1 / 2-norm(P) by more than a factor of ! sqrt(N). ! ! An approximate error bound for the computed average of the ! eigenvalues of T11 is ! ! EPS * norm(T) / S ! ! where EPS is the machine precision. ! ! The reciprocal condition number of the right invariant subspace ! spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. ! SEP is defined as the separation of T11 and T22: ! ! sep( T11, T22 ) = sigma-min( C ) ! ! where sigma-min(C) is the smallest singular value of the ! n1*n2-by-n1*n2 matrix ! ! C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) ! ! I(m) is an m by m identity matrix, and kprod denotes the Kronecker ! product. We estimate sigma-min(C) by the reciprocal of an estimate of ! the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) ! cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2). ! ! When SEP is small, small changes in T can cause large changes in ! the invariant subspace. An approximate bound on the maximum angular ! error in the computed right invariant subspace is ! ! EPS * norm(T) / SEP ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery, pair, swap, wantbh, wantq, wants, wantsp INTEGER :: ierr, k, kase, kk, ks, liwmin, lwmin, n1, n2, nn REAL :: est, rnorm, scale ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: slange EXTERNAL lsame, slange ! .. ! .. External Subroutines .. EXTERNAL slacon, slacpy, strexc, strsyl, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT ! .. ! .. Executable Statements .. ! ! Decode and test the input parameters ! wantbh = lsame( job, 'B' ) wants = lsame( job, 'E' ) .OR. wantbh wantsp = lsame( job, 'V' ) .OR. wantbh wantq = lsame( compq, 'V' ) ! info = 0 lquery = ( lwork == -1 ) IF( .NOT.lsame( job, 'N' ) .AND. .NOT.wants .AND. .NOT.wantsp ) THEN info = -1 ELSE IF( .NOT.lsame( compq, 'N' ) .AND. .NOT.wantq ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( ldt < MAX( 1, n ) ) THEN info = -6 ELSE IF( ldq < 1 .OR. ( wantq .AND. ldq < n ) ) THEN info = -8 ELSE ! ! Set M to the dimension of the specified invariant subspace, ! and test LWORK and LIWORK. ! m = 0 pair = .false. DO k = 1, n IF( pair ) THEN pair = .false. ELSE IF( k < n ) THEN IF( t( k+1, k ) == zero ) THEN IF( select( k ) ) m = m + 1 ELSE pair = .true. IF( select( k ) .OR. select( k+1 ) ) m = m + 2 END IF ELSE IF( select( n ) ) m = m + 1 END IF END IF END DO ! n1 = m n2 = n - m nn = n1*n2 ! IF( wantsp ) THEN lwmin = MAX( 1, 2*nn ) liwmin = MAX( 1, nn ) ELSE IF( lsame( job, 'N' ) ) THEN lwmin = MAX( 1, n ) liwmin = 1 ELSE IF( lsame( job, 'E' ) ) THEN lwmin = MAX( 1, nn ) liwmin = 1 END IF ! IF( lwork < lwmin .AND. .NOT.lquery ) THEN info = -15 ELSE IF( liwork < liwmin .AND. .NOT.lquery ) THEN info = -17 END IF END IF ! IF( info == 0 ) THEN work( 1 ) = lwmin iwork( 1 ) = liwmin END IF ! IF( info /= 0 ) THEN CALL xerbla( 'STRSEN', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible. ! IF( m == n .OR. m == 0 ) THEN IF( wants ) s = one IF( wantsp ) sep = slange( '1', n, n, t, ldt, work ) GO TO 40 END IF ! ! Collect the selected blocks at the top-left corner of T. ! ks = 0 pair = .false. DO k = 1, n IF( pair ) THEN pair = .false. ELSE swap = select( k ) IF( k < n ) THEN IF( t( k+1, k ) /= zero ) THEN pair = .true. swap = swap .OR. select( k+1 ) END IF END IF IF( swap ) THEN ks = ks + 1 ! ! Swap the K-th block to position KS. ! ierr = 0 kk = k IF( k /= ks ) CALL strexc( compq, n, t, ldt, q, ldq, kk, ks, work, & ierr ) IF( ierr == 1 .OR. ierr == 2 ) THEN ! ! Blocks too close to swap: exit. ! info = 1 IF( wants ) s = zero IF( wantsp ) sep = zero GO TO 40 END IF IF( pair ) ks = ks + 1 END IF END IF END DO ! IF( wants ) THEN ! ! Solve Sylvester equation for R: ! ! T11*R - R*T22 = scale*T12 ! CALL slacpy( 'F', n1, n2, t( 1, n1+1 ), ldt, work, n1 ) CALL strsyl( 'N', 'N', -1, n1, n2, t, ldt, t( n1+1, n1+1 ), & ldt, work, n1, scale, ierr ) ! ! Estimate the reciprocal of the condition number of the cluster ! of eigenvalues. ! rnorm = slange( 'F', n1, n2, work, n1, work ) IF( rnorm == zero ) THEN s = one ELSE s = scale / ( SQRT( scale*scale / rnorm+rnorm )* SQRT( rnorm ) ) END IF END IF ! IF( wantsp ) THEN ! ! Estimate sep(T11,T22). ! est = zero kase = 0 30 CONTINUE CALL slacon( nn, work( nn+1 ), work, iwork, est, kase ) IF( kase /= 0 ) THEN IF( kase == 1 ) THEN ! ! Solve T11*R - R*T22 = scale*X. ! CALL strsyl( 'N', 'N', -1, n1, n2, t, ldt, & t( n1+1, n1+1 ), ldt, work, n1, scale, ierr ) ELSE ! ! Solve T11'*R - R*T22' = scale*X. ! CALL strsyl( 'T', 'T', -1, n1, n2, t, ldt, & t( n1+1, n1+1 ), ldt, work, n1, scale, ierr ) END IF GO TO 30 END IF ! sep = scale / est END IF ! 40 CONTINUE ! ! Store the output eigenvalues in WR and WI. ! DO k = 1, n wr( k ) = t( k, k ) wi( k ) = zero END DO DO k = 1, n - 1 IF( t( k+1, k ) /= zero ) THEN wi( k ) = SQRT( ABS( t( k, k+1 ) ) )* SQRT( ABS( t( k+1, k ) ) ) wi( k+1 ) = -wi( k ) END IF END DO ! work( 1 ) = lwmin iwork( 1 ) = liwmin ! RETURN ! ! End of STRSEN ! END SUBROUTINE strsen SUBROUTINE strsna( job, howmny, select, n, t, ldt, vl, ldvl, vr, & ldvr, s, sep, mm, m, work, ldwork, iwork, 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 (LEN=1), INTENT(IN) :: job CHARACTER (LEN=1), INTENT(IN) :: howmny LOGICAL, INTENT(IN) :: select( * ) INTEGER, INTENT(IN OUT) :: n REAL, INTENT(IN) :: t( ldt, * ) INTEGER, INTENT(IN OUT) :: ldt REAL, INTENT(IN) :: vl( ldvl, * ) INTEGER, INTENT(IN OUT) :: ldvl REAL, INTENT(IN) :: vr( ldvr, * ) INTEGER, INTENT(IN OUT) :: ldvr REAL, INTENT(OUT) :: s( * ) REAL, INTENT(OUT) :: sep( * ) INTEGER, INTENT(IN) :: mm INTEGER, INTENT(OUT) :: m REAL, INTENT(IN OUT) :: work( ldwork, * ) INTEGER, INTENT(IN OUT) :: ldwork INTEGER, INTENT(IN OUT) :: iwork( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STRSNA estimates reciprocal condition numbers for specified ! eigenvalues and/or right eigenvectors of a real upper ! quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q ! orthogonal). ! ! T must be in Schur canonical form (as returned by SHSEQR), that is, ! block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each ! 2-by-2 diagonal block has its diagonal elements equal and its ! off-diagonal elements of opposite sign. ! ! Arguments ! ========= ! ! JOB (input) CHARACTER*1 ! Specifies whether condition numbers are required for ! eigenvalues (S) or eigenvectors (SEP): ! = 'E': for eigenvalues only (S); ! = 'V': for eigenvectors only (SEP); ! = 'B': for both eigenvalues and eigenvectors (S and SEP). ! ! HOWMNY (input) CHARACTER*1 ! = 'A': compute condition numbers for all eigenpairs; ! = 'S': compute condition numbers for selected eigenpairs ! specified by the array SELECT. ! ! SELECT (input) LOGICAL array, dimension (N) ! If HOWMNY = 'S', SELECT specifies the eigenpairs for which ! condition numbers are required. To select condition numbers ! for the eigenpair corresponding to a real eigenvalue w(j), ! SELECT(j) must be set to .TRUE.. To select condition numbers ! corresponding to a complex conjugate pair of eigenvalues w(j) ! and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be ! set to .TRUE.. ! If HOWMNY = 'A', SELECT is not referenced. ! ! N (input) INTEGER ! The order of the matrix T. N >= 0. ! ! T (input) REAL array, dimension (LDT,N) ! The upper quasi-triangular matrix T, in Schur canonical form. ! ! LDT (input) INTEGER ! The leading dimension of the array T. LDT >= max(1,N). ! ! VL (input) REAL array, dimension (LDVL,M) ! If JOB = 'E' or 'B', VL must contain left eigenvectors of T ! (or of any Q*T*Q**T with Q orthogonal), corresponding to the ! eigenpairs specified by HOWMNY and SELECT. The eigenvectors ! must be stored in consecutive columns of VL, as returned by ! SHSEIN or STREVC. ! If JOB = 'V', VL is not referenced. ! ! LDVL (input) INTEGER ! The leading dimension of the array VL. ! LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. ! ! VR (input) REAL array, dimension (LDVR,M) ! If JOB = 'E' or 'B', VR must contain right eigenvectors of T ! (or of any Q*T*Q**T with Q orthogonal), corresponding to the ! eigenpairs specified by HOWMNY and SELECT. The eigenvectors ! must be stored in consecutive columns of VR, as returned by ! SHSEIN or STREVC. ! If JOB = 'V', VR is not referenced. ! ! LDVR (input) INTEGER ! The leading dimension of the array VR. ! LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. ! ! S (output) REAL array, dimension (MM) ! If JOB = 'E' or 'B', the reciprocal condition numbers of the ! selected eigenvalues, stored in consecutive elements of the ! array. For a complex conjugate pair of eigenvalues two ! consecutive elements of S are set to the same value. Thus ! S(j), SEP(j), and the j-th columns of VL and VR all ! correspond to the same eigenpair (but not in general the ! j-th eigenpair, unless all eigenpairs are selected). ! If JOB = 'V', S is not referenced. ! ! SEP (output) REAL array, dimension (MM) ! If JOB = 'V' or 'B', the estimated reciprocal condition ! numbers of the selected eigenvectors, stored in consecutive ! elements of the array. For a complex eigenvector two ! consecutive elements of SEP are set to the same value. If ! the eigenvalues cannot be reordered to compute SEP(j), SEP(j) ! is set to 0; this can only occur when the true value would be ! very small anyway. ! If JOB = 'E', SEP is not referenced. ! ! MM (input) INTEGER ! The number of elements in the arrays S (if JOB = 'E' or 'B') ! and/or SEP (if JOB = 'V' or 'B'). MM >= M. ! ! M (output) INTEGER ! The number of elements of the arrays S and/or SEP actually ! used to store the estimated condition numbers. ! If HOWMNY = 'A', M is set to N. ! ! WORK (workspace) REAL array, dimension (LDWORK,N+1) ! If JOB = 'E', WORK is not referenced. ! ! LDWORK (input) INTEGER ! The leading dimension of the array WORK. ! LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. ! ! IWORK (workspace) INTEGER array, dimension (N) ! If JOB = 'E', IWORK is not referenced. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! Further Details ! =============== ! ! The reciprocal of the condition number of an eigenvalue lambda is ! defined as ! ! S(lambda) = |v'*u| / (norm(u)*norm(v)) ! ! where u and v are the right and left eigenvectors of T corresponding ! to lambda; v' denotes the conjugate-transpose of v, and norm(u) ! denotes the Euclidean norm. These reciprocal condition numbers always ! lie between zero (very badly conditioned) and one (very well ! conditioned). If n = 1, S(lambda) is defined to be 1. ! ! An approximate error bound for a computed eigenvalue W(i) is given by ! ! EPS * norm(T) / S(i) ! ! where EPS is the machine precision. ! ! The reciprocal of the condition number of the right eigenvector u ! corresponding to lambda is defined as follows. Suppose ! ! T = ( lambda c ) ! ( 0 T22 ) ! ! Then the reciprocal condition number is ! ! SEP( lambda, T22 ) = sigma-min( T22 - lambda*I ) ! ! where sigma-min denotes the smallest singular value. We approximate ! the smallest singular value by the reciprocal of an estimate of the ! one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is ! defined to be abs(T(1,1)). ! ! An approximate error bound for a computed right eigenvector VR(i) ! is given by ! ! EPS * norm(T) / SEP(i) ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: two = 2.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: pair, somcon, wantbh, wants, wantsp INTEGER :: i, ierr, ifst, ilst, j, k, kase, ks, n2, nn REAL :: bignum, cond, cs, delta, dumm, eps, est, lnrm, & mu, prod, prod1, prod2, rnrm, scale, smlnum, sn ! .. ! .. Local Arrays .. REAL :: dummy( 1 ) ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: sdot, slamch, slapy2, snrm2 EXTERNAL lsame, sdot, slamch, slapy2, snrm2 ! .. ! .. External Subroutines .. EXTERNAL slabad, slacon, slacpy, slaqtr, strexc, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT ! .. ! .. Executable Statements .. ! ! Decode and test the input parameters ! wantbh = lsame( job, 'B' ) wants = lsame( job, 'E' ) .OR. wantbh wantsp = lsame( job, 'V' ) .OR. wantbh ! somcon = lsame( howmny, 'S' ) ! info = 0 IF( .NOT.wants .AND. .NOT.wantsp ) THEN info = -1 ELSE IF( .NOT.lsame( howmny, 'A' ) .AND. .NOT.somcon ) THEN info = -2 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( ldt < MAX( 1, n ) ) THEN info = -6 ELSE IF( ldvl < 1 .OR. ( wants .AND. ldvl < n ) ) THEN info = -8 ELSE IF( ldvr < 1 .OR. ( wants .AND. ldvr < n ) ) THEN info = -10 ELSE ! ! Set M to the number of eigenpairs for which condition numbers ! are required, and test MM. ! IF( somcon ) THEN m = 0 pair = .false. DO k = 1, n IF( pair ) THEN pair = .false. ELSE IF( k < n ) THEN IF( t( k+1, k ) == zero ) THEN IF( select( k ) ) m = m + 1 ELSE pair = .true. IF( select( k ) .OR. select( k+1 ) ) m = m + 2 END IF ELSE IF( select( n ) ) m = m + 1 END IF END IF END DO ELSE m = n END IF ! IF( mm < m ) THEN info = -13 ELSE IF( ldwork < 1 .OR. ( wantsp .AND. ldwork < n ) ) THEN info = -16 END IF END IF IF( info /= 0 ) THEN CALL xerbla( 'STRSNA', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! IF( n == 1 ) THEN IF( somcon ) THEN IF( .NOT.select( 1 ) ) RETURN END IF IF( wants ) s( 1 ) = one IF( wantsp ) sep( 1 ) = ABS( t( 1, 1 ) ) RETURN END IF ! ! Get machine constants ! eps = slamch( 'P' ) smlnum = slamch( 'S' ) / eps bignum = one / smlnum CALL slabad( smlnum, bignum ) ! ks = 0 pair = .false. DO k = 1, n ! ! Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block. ! IF( pair ) THEN pair = .false. CYCLE ELSE IF( k < n ) pair = t( k+1, k ) /= zero END IF ! ! Determine whether condition numbers are required for the k-th ! eigenpair. ! IF( somcon ) THEN IF( pair ) THEN IF( .NOT.select( k ) .AND. .NOT.select( k+1 ) ) CYCLE ELSE IF( .NOT.select( k ) ) CYCLE END IF END IF ! ks = ks + 1 ! IF( wants ) THEN ! ! Compute the reciprocal condition number of the k-th ! eigenvalue. ! IF( .NOT.pair ) THEN ! ! Real eigenvalue. ! prod = sdot( n, vr( 1, ks ), 1, vl( 1, ks ), 1 ) rnrm = snrm2( n, vr( 1, ks ), 1 ) lnrm = snrm2( n, vl( 1, ks ), 1 ) s( ks ) = ABS( prod ) / ( rnrm*lnrm ) ELSE ! ! Complex eigenvalue. ! prod1 = sdot( n, vr( 1, ks ), 1, vl( 1, ks ), 1 ) prod1 = prod1 + sdot( n, vr( 1, ks+1 ), 1, vl( 1, ks+1 ), 1 ) prod2 = sdot( n, vl( 1, ks ), 1, vr( 1, ks+1 ), 1 ) prod2 = prod2 - sdot( n, vl( 1, ks+1 ), 1, vr( 1, ks ), 1 ) rnrm = slapy2( snrm2( n, vr( 1, ks ), 1 ), & snrm2( n, vr( 1, ks+1 ), 1 ) ) lnrm = slapy2( snrm2( n, vl( 1, ks ), 1 ), & snrm2( n, vl( 1, ks+1 ), 1 ) ) cond = slapy2( prod1, prod2 ) / ( rnrm*lnrm ) s( ks ) = cond s( ks+1 ) = cond END IF END IF ! IF( wantsp ) THEN ! ! Estimate the reciprocal condition number of the k-th ! eigenvector. ! ! Copy the matrix T to the array WORK and swap the diagonal ! block beginning at T(k,k) to the (1,1) position. ! CALL slacpy( 'Full', n, n, t, ldt, work, ldwork ) ifst = k ilst = 1 CALL strexc( 'No Q', n, work, ldwork, dummy, 1, ifst, ilst, & work( 1, n+1 ), ierr ) ! IF( ierr == 1 .OR. ierr == 2 ) THEN ! ! Could not swap because blocks not well separated ! scale = one est = bignum ELSE ! ! Reordering successful ! IF( work( 2, 1 ) == zero ) THEN ! ! Form C = T22 - lambda*I in WORK(2:N,2:N). ! DO i = 2, n work( i, i ) = work( i, i ) - work( 1, 1 ) END DO n2 = 1 nn = n - 1 ELSE ! ! Triangularize the 2 by 2 block by unitary ! transformation U = [ cs i*ss ] ! [ i*ss cs ]. ! such that the (1,1) position of WORK is complex ! eigenvalue lambda with positive imaginary part. (2,2) ! position of WORK is the complex eigenvalue lambda ! with negative imaginary part. ! mu = SQRT( ABS( work( 1, 2 ) ) )* SQRT( ABS( work( 2, 1 ) ) ) delta = slapy2( mu, work( 2, 1 ) ) cs = mu / delta sn = -work( 2, 1 ) / delta ! ! Form ! ! C' = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ] ! [ mu ] ! [ .. ] ! [ .. ] ! [ mu ] ! where C' is conjugate transpose of complex matrix C, ! and RWORK is stored starting in the N+1-st column of ! WORK. ! DO j = 3, n work( 2, j ) = cs*work( 2, j ) work( j, j ) = work( j, j ) - work( 1, 1 ) END DO work( 2, 2 ) = zero ! work( 1, n+1 ) = two*mu DO i = 2, n - 1 work( i, n+1 ) = sn*work( 1, i+1 ) END DO n2 = 2 nn = 2*( n-1 ) END IF ! ! Estimate norm(inv(C')) ! est = zero kase = 0 50 CONTINUE CALL slacon( nn, work( 1, n+2 ), work( 1, n+4 ), iwork, est, kase ) IF( kase /= 0 ) THEN IF( kase == 1 ) THEN IF( n2 == 1 ) THEN ! ! Real eigenvalue: solve C'*x = scale*c. ! CALL slaqtr( .true., .true., n-1, work( 2, 2 ), & ldwork, dummy, dumm, scale, work( 1, n+4 ), work( 1, n+6 ), & ierr ) ELSE ! ! Complex eigenvalue: solve ! C'*(p+iq) = scale*(c+id) in real arithmetic. ! CALL slaqtr( .true., .false., n-1, work( 2, 2 ), & ldwork, work( 1, n+1 ), mu, scale, & work( 1, n+4 ), work( 1, n+6 ), ierr ) END IF ELSE IF( n2 == 1 ) THEN ! ! Real eigenvalue: solve C*x = scale*c. ! CALL slaqtr( .false., .true., n-1, work( 2, 2 ), & ldwork, dummy, dumm, scale, work( 1, n+4 ), work( 1, n+6 ), & ierr ) ELSE ! ! Complex eigenvalue: solve ! C*(p+iq) = scale*(c+id) in real arithmetic. ! CALL slaqtr( .false., .false., n-1, work( 2, 2 ), ldwork, & work( 1, n+1 ), mu, scale, work( 1, n+4 ), work( 1, n+6 ), & ierr ) ! END IF END IF ! GO TO 50 END IF END IF ! sep( ks ) = scale / MAX( est, smlnum ) IF( pair ) sep( ks+1 ) = sep( ks ) END IF ! IF( pair ) ks = ks + 1 ! END DO RETURN ! ! End of STRSNA ! END SUBROUTINE strsna SUBROUTINE strsyl( trana, tranb, isgn, m, n, a, lda, b, ldb, c, & ldc, scale, 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 (LEN=1), INTENT(IN) :: trana CHARACTER (LEN=1), INTENT(IN) :: tranb INTEGER, INTENT(IN) :: isgn INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN) :: lda REAL, INTENT(IN) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb REAL, INTENT(IN OUT) :: c( ldc, * ) INTEGER, INTENT(IN) :: ldc REAL, INTENT(OUT) :: scale INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STRSYL solves the real Sylvester matrix equation: ! ! op(A)*X + X*op(B) = scale*C or ! op(A)*X - X*op(B) = scale*C, ! ! where op(A) = A or A**T, and A and B are both upper quasi- ! triangular. A is M-by-M and B is N-by-N; the right hand side C and ! the solution X are M-by-N; and scale is an output scale factor, set ! <= 1 to avoid overflow in X. ! ! A and B must be in Schur canonical form (as returned by SHSEQR), that ! is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; ! each 2-by-2 diagonal block has its diagonal elements equal and its ! off-diagonal elements of opposite sign. ! ! Arguments ! ========= ! ! TRANA (input) CHARACTER*1 ! Specifies the option op(A): ! = 'N': op(A) = A (No transpose) ! = 'T': op(A) = A**T (Transpose) ! = 'C': op(A) = A**H (Conjugate transpose = Transpose) ! ! TRANB (input) CHARACTER*1 ! Specifies the option op(B): ! = 'N': op(B) = B (No transpose) ! = 'T': op(B) = B**T (Transpose) ! = 'C': op(B) = B**H (Conjugate transpose = Transpose) ! ! ISGN (input) INTEGER ! Specifies the sign in the equation: ! = +1: solve op(A)*X + X*op(B) = scale*C ! = -1: solve op(A)*X - X*op(B) = scale*C ! ! M (input) INTEGER ! The order of the matrix A, and the number of rows in the ! matrices X and C. M >= 0. ! ! N (input) INTEGER ! The order of the matrix B, and the number of columns in the ! matrices X and C. N >= 0. ! ! A (input) REAL array, dimension (LDA,M) ! The upper quasi-triangular matrix A, in Schur canonical form. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! B (input) REAL array, dimension (LDB,N) ! The upper quasi-triangular matrix B, in Schur canonical form. ! ! LDB (input) INTEGER ! The leading dimension of the array B. LDB >= max(1,N). ! ! C (input/output) REAL array, dimension (LDC,N) ! On entry, the M-by-N right hand side matrix C. ! On exit, C is overwritten by the solution matrix X. ! ! LDC (input) INTEGER ! The leading dimension of the array C. LDC >= max(1,M) ! ! SCALE (output) REAL ! The scale factor, scale, set <= 1 to avoid overflow in X. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! = 1: A and B have common or very close eigenvalues; perturbed ! values were used to solve the equation (but the matrices ! A and B are unchanged). ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: notrna, notrnb INTEGER :: ierr, j, k, k1, k2, knext, l, l1, l2, lnext REAL :: a11, bignum, da11, db, eps, scaloc, sgn, smin, & smlnum, suml, sumr, xnorm ! .. ! .. Local Arrays .. REAL :: dum( 1 ), vec( 2, 2 ), x( 2, 2 ) ! .. ! .. External Functions .. LOGICAL :: lsame REAL :: sdot, slamch, slange EXTERNAL lsame, sdot, slamch, slange ! .. ! .. External Subroutines .. EXTERNAL slabad, slaln2, slasy2, sscal, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC ABS, MAX, REAL ! .. ! .. Executable Statements .. ! ! Decode and Test input parameters ! notrna = lsame( trana, 'N' ) notrnb = lsame( tranb, 'N' ) ! info = 0 IF( .NOT.notrna .AND. .NOT.lsame( trana, 'T' ) .AND. .NOT. & lsame( trana, 'C' ) ) THEN info = -1 ELSE IF( .NOT.notrnb .AND. .NOT.lsame( tranb, 'T' ) .AND. .NOT. & lsame( tranb, 'C' ) ) THEN info = -2 ELSE IF( isgn /= 1 .AND. isgn /= -1 ) THEN info = -3 ELSE IF( m < 0 ) THEN info = -4 ELSE IF( n < 0 ) THEN info = -5 ELSE IF( lda < MAX( 1, m ) ) THEN info = -7 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -9 ELSE IF( ldc < MAX( 1, m ) ) THEN info = -11 END IF IF( info /= 0 ) THEN CALL xerbla( 'STRSYL', -info ) RETURN END IF ! ! Quick return if possible ! IF( m == 0 .OR. n == 0 ) RETURN ! ! Set constants to control overflow ! eps = slamch( 'P' ) smlnum = slamch( 'S' ) bignum = one / smlnum CALL slabad( smlnum, bignum ) smlnum = smlnum*REAL( m*n ) / eps bignum = one / smlnum ! smin = MAX( smlnum, eps*slange( 'M', m, m, a, lda, dum ), & eps*slange( 'M', n, n, b, ldb, dum ) ) ! scale = one sgn = isgn ! IF( notrna .AND. notrnb ) THEN ! ! Solve A*X + ISGN*X*B = scale*C. ! ! The (K,L)th block of X is determined starting from ! bottom-left corner column by column by ! ! A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) ! ! Where ! M L-1 ! R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]. ! I=K+1 J=1 ! ! Start column loop (index = L) ! L1 (L2) : column index of the first (first) row of X(K,L). ! lnext = 1 DO l = 1, n IF( l < lnext ) CYCLE IF( l == n ) THEN l1 = l l2 = l ELSE IF( b( l+1, l ) /= zero ) THEN l1 = l l2 = l + 1 lnext = l + 2 ELSE l1 = l l2 = l lnext = l + 1 END IF END IF ! ! Start row loop (index = K) ! K1 (K2): row index of the first (last) row of X(K,L). ! knext = m DO k = m, 1, -1 IF( k > knext ) CYCLE IF( k == 1 ) THEN k1 = k k2 = k ELSE IF( a( k, k-1 ) /= zero ) THEN k1 = k - 1 k2 = k knext = k - 2 ELSE k1 = k k2 = k knext = k - 1 END IF END IF ! IF( l1 == l2 .AND. k1 == k2 ) THEN suml = sdot( m-k1, a( k1, MIN( k1+1, m ) ), lda, & c( MIN( k1+1, m ), l1 ), 1 ) sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) scaloc = one ! a11 = a( k1, k1 ) + sgn*b( l1, l1 ) da11 = ABS( a11 ) IF( da11 <= smin ) THEN a11 = smin da11 = smin info = 1 END IF db = ABS( vec( 1, 1 ) ) IF( da11 < one .AND. db > one ) THEN IF( db > bignum*da11 ) scaloc = one / db END IF x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 ! IF( scaloc /= one ) THEN DO j = 1, n CALL sscal( m, scaloc, c( 1, j ), 1 ) END DO scale = scale*scaloc END IF c( k1, l1 ) = x( 1, 1 ) ! ELSE IF( l1 == l2 .AND. k1 /= k2 ) THEN ! suml = sdot( m-k2, a( k1, MIN( k2+1, m ) ), lda, & c( MIN( k2+1, m ), l1 ), 1 ) sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) ! suml = sdot( m-k2, a( k2, MIN( k2+1, m ) ), lda, & c( MIN( k2+1, m ), l1 ), 1 ) sumr = sdot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) ! CALL slaln2( .false., 2, 1, smin, one, a( k1, k1 ), & lda, one, one, vec, 2, -sgn*b( l1, l1 ), & zero, x, 2, scaloc, xnorm, ierr ) IF( ierr /= 0 ) info = 1 ! IF( scaloc /= one ) THEN DO j = 1, n CALL sscal( m, scaloc, c( 1, j ), 1 ) END DO scale = scale*scaloc END IF c( k1, l1 ) = x( 1, 1 ) c( k2, l1 ) = x( 2, 1 ) ! ELSE IF( l1 /= l2 .AND. k1 == k2 ) THEN ! suml = sdot( m-k1, a( k1, MIN( k1+1, m ) ), lda, & c( MIN( k1+1, m ), l1 ), 1 ) sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) ! suml = sdot( m-k1, a( k1, MIN( k1+1, m ) ), lda, & c( MIN( k1+1, m ), l2 ), 1 ) sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) ! CALL slaln2( .true., 2, 1, smin, one, b( l1, l1 ), & ldb, one, one, vec, 2, -sgn*a( k1, k1 ), & zero, x, 2, scaloc, xnorm, ierr ) IF( ierr /= 0 ) info = 1 ! IF( scaloc /= one ) THEN DO j = 1, n CALL sscal( m, scaloc, c( 1, j ), 1 ) END DO scale = scale*scaloc END IF c( k1, l1 ) = x( 1, 1 ) c( k1, l2 ) = x( 2, 1 ) ! ELSE IF( l1 /= l2 .AND. k1 /= k2 ) THEN ! suml = sdot( m-k2, a( k1, MIN( k2+1, m ) ), lda, & c( MIN( k2+1, m ), l1 ), 1 ) sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) ! suml = sdot( m-k2, a( k1, MIN( k2+1, m ) ), lda, & c( MIN( k2+1, m ), l2 ), 1 ) sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) ! suml = sdot( m-k2, a( k2, MIN( k2+1, m ) ), lda, & c( MIN( k2+1, m ), l1 ), 1 ) sumr = sdot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) ! suml = sdot( m-k2, a( k2, MIN( k2+1, m ) ), lda, & c( MIN( k2+1, m ), l2 ), 1 ) sumr = sdot( l1-1, c( k2, 1 ), ldc, b( 1, l2 ), 1 ) vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) ! CALL slasy2( .false., .false., isgn, 2, 2, & a( k1, k1 ), lda, b( l1, l1 ), ldb, vec, & 2, scaloc, x, 2, xnorm, ierr ) IF( ierr /= 0 ) info = 1 ! IF( scaloc /= one ) THEN DO j = 1, n CALL sscal( m, scaloc, c( 1, j ), 1 ) END DO scale = scale*scaloc END IF c( k1, l1 ) = x( 1, 1 ) c( k1, l2 ) = x( 1, 2 ) c( k2, l1 ) = x( 2, 1 ) c( k2, l2 ) = x( 2, 2 ) END IF ! END DO ! END DO ! ELSE IF( .NOT.notrna .AND. notrnb ) THEN ! ! Solve A' *X + ISGN*X*B = scale*C. ! ! The (K,L)th block of X is determined starting from ! upper-left corner column by column by ! ! A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) ! ! Where ! K-1 L-1 ! R(K,L) = SUM [A(I,K)'*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)] ! I=1 J=1 ! ! Start column loop (index = L) ! L1 (L2): column index of the first (last) row of X(K,L) ! lnext = 1 DO l = 1, n IF( l < lnext ) CYCLE IF( l == n ) THEN l1 = l l2 = l ELSE IF( b( l+1, l ) /= zero ) THEN l1 = l l2 = l + 1 lnext = l + 2 ELSE l1 = l l2 = l lnext = l + 1 END IF END IF ! ! Start row loop (index = K) ! K1 (K2): row index of the first (last) row of X(K,L) ! knext = 1 DO k = 1, m IF( k < knext ) CYCLE IF( k == m ) THEN k1 = k k2 = k ELSE IF( a( k+1, k ) /= zero ) THEN k1 = k k2 = k + 1 knext = k + 2 ELSE k1 = k k2 = k knext = k + 1 END IF END IF ! IF( l1 == l2 .AND. k1 == k2 ) THEN suml = sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) scaloc = one ! a11 = a( k1, k1 ) + sgn*b( l1, l1 ) da11 = ABS( a11 ) IF( da11 <= smin ) THEN a11 = smin da11 = smin info = 1 END IF db = ABS( vec( 1, 1 ) ) IF( da11 < one .AND. db > one ) THEN IF( db > bignum*da11 ) scaloc = one / db END IF x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 ! IF( scaloc /= one ) THEN DO j = 1, n CALL sscal( m, scaloc, c( 1, j ), 1 ) END DO scale = scale*scaloc END IF c( k1, l1 ) = x( 1, 1 ) ! ELSE IF( l1 == l2 .AND. k1 /= k2 ) THEN ! suml = sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) ! suml = sdot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) sumr = sdot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) ! CALL slaln2( .true., 2, 1, smin, one, a( k1, k1 ), & lda, one, one, vec, 2, -sgn*b( l1, l1 ), & zero, x, 2, scaloc, xnorm, ierr ) IF( ierr /= 0 ) info = 1 ! IF( scaloc /= one ) THEN DO j = 1, n CALL sscal( m, scaloc, c( 1, j ), 1 ) END DO scale = scale*scaloc END IF c( k1, l1 ) = x( 1, 1 ) c( k2, l1 ) = x( 2, 1 ) ! ELSE IF( l1 /= l2 .AND. k1 == k2 ) THEN ! suml = sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) ! suml = sdot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) ! CALL slaln2( .true., 2, 1, smin, one, b( l1, l1 ), & ldb, one, one, vec, 2, -sgn*a( k1, k1 ), & zero, x, 2, scaloc, xnorm, ierr ) IF( ierr /= 0 ) info = 1 ! IF( scaloc /= one ) THEN DO j = 1, n CALL sscal( m, scaloc, c( 1, j ), 1 ) END DO scale = scale*scaloc END IF c( k1, l1 ) = x( 1, 1 ) c( k1, l2 ) = x( 2, 1 ) ! ELSE IF( l1 /= l2 .AND. k1 /= k2 ) THEN ! suml = sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l1 ), 1 ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) ! suml = sdot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) sumr = sdot( l1-1, c( k1, 1 ), ldc, b( 1, l2 ), 1 ) vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) ! suml = sdot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) sumr = sdot( l1-1, c( k2, 1 ), ldc, b( 1, l1 ), 1 ) vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) ! suml = sdot( k1-1, a( 1, k2 ), 1, c( 1, l2 ), 1 ) sumr = sdot( l1-1, c( k2, 1 ), ldc, b( 1, l2 ), 1 ) vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) ! CALL slasy2( .true., .false., isgn, 2, 2, a( k1, k1 ), & lda, b( l1, l1 ), ldb, vec, 2, scaloc, x, 2, xnorm, ierr ) IF( ierr /= 0 ) info = 1 ! IF( scaloc /= one ) THEN DO j = 1, n CALL sscal( m, scaloc, c( 1, j ), 1 ) END DO scale = scale*scaloc END IF c( k1, l1 ) = x( 1, 1 ) c( k1, l2 ) = x( 1, 2 ) c( k2, l1 ) = x( 2, 1 ) c( k2, l2 ) = x( 2, 2 ) END IF ! END DO END DO ! ELSE IF( .NOT.notrna .AND. .NOT.notrnb ) THEN ! ! Solve A'*X + ISGN*X*B' = scale*C. ! ! The (K,L)th block of X is determined starting from ! top-right corner column by column by ! ! A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L) ! ! Where ! K-1 N ! R(K,L) = SUM [A(I,K)'*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)']. ! I=1 J=L+1 ! ! Start column loop (index = L) ! L1 (L2): column index of the first (last) row of X(K,L) ! lnext = n DO l = n, 1, -1 IF( l > lnext ) CYCLE IF( l == 1 ) THEN l1 = l l2 = l ELSE IF( b( l, l-1 ) /= zero ) THEN l1 = l - 1 l2 = l lnext = l - 2 ELSE l1 = l l2 = l lnext = l - 1 END IF END IF ! ! Start row loop (index = K) ! K1 (K2): row index of the first (last) row of X(K,L) ! knext = 1 DO k = 1, m IF( k < knext ) CYCLE IF( k == m ) THEN k1 = k k2 = k ELSE IF( a( k+1, k ) /= zero ) THEN k1 = k k2 = k + 1 knext = k + 2 ELSE k1 = k k2 = k knext = k + 1 END IF END IF ! IF( l1 == l2 .AND. k1 == k2 ) THEN suml = sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) sumr = sdot( n-l1, c( k1, MIN( l1+1, n ) ), ldc, & b( l1, MIN( l1+1, n ) ), ldb ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) scaloc = one ! a11 = a( k1, k1 ) + sgn*b( l1, l1 ) da11 = ABS( a11 ) IF( da11 <= smin ) THEN a11 = smin da11 = smin info = 1 END IF db = ABS( vec( 1, 1 ) ) IF( da11 < one .AND. db > one ) THEN IF( db > bignum*da11 ) scaloc = one / db END IF x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 ! IF( scaloc /= one ) THEN DO j = 1, n CALL sscal( m, scaloc, c( 1, j ), 1 ) END DO scale = scale*scaloc END IF c( k1, l1 ) = x( 1, 1 ) ! ELSE IF( l1 == l2 .AND. k1 /= k2 ) THEN ! suml = sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) sumr = sdot( n-l2, c( k1, MIN( l2+1, n ) ), ldc, & b( l1, MIN( l2+1, n ) ), ldb ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) ! suml = sdot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) sumr = sdot( n-l2, c( k2, MIN( l2+1, n ) ), ldc, & b( l1, MIN( l2+1, n ) ), ldb ) vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) ! CALL slaln2( .true., 2, 1, smin, one, a( k1, k1 ), & lda, one, one, vec, 2, -sgn*b( l1, l1 ), & zero, x, 2, scaloc, xnorm, ierr ) IF( ierr /= 0 ) info = 1 ! IF( scaloc /= one ) THEN DO j = 1, n CALL sscal( m, scaloc, c( 1, j ), 1 ) END DO scale = scale*scaloc END IF c( k1, l1 ) = x( 1, 1 ) c( k2, l1 ) = x( 2, 1 ) ! ELSE IF( l1 /= l2 .AND. k1 == k2 ) THEN ! suml = sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) sumr = sdot( n-l2, c( k1, MIN( l2+1, n ) ), ldc, & b( l1, MIN( l2+1, n ) ), ldb ) vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) ! suml = sdot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) sumr = sdot( n-l2, c( k1, MIN( l2+1, n ) ), ldc, & b( l2, MIN( l2+1, n ) ), ldb ) vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) ! CALL slaln2( .false., 2, 1, smin, one, b( l1, l1 ), & ldb, one, one, vec, 2, -sgn*a( k1, k1 ), & zero, x, 2, scaloc, xnorm, ierr ) IF( ierr /= 0 ) info = 1 ! IF( scaloc /= one ) THEN DO j = 1, n CALL sscal( m, scaloc, c( 1, j ), 1 ) END DO scale = scale*scaloc END IF c( k1, l1 ) = x( 1, 1 ) c( k1, l2 ) = x( 2, 1 ) ! ELSE IF( l1 /= l2 .AND. k1 /= k2 ) THEN ! suml = sdot( k1-1, a( 1, k1 ), 1, c( 1, l1 ), 1 ) sumr = sdot( n-l2, c( k1, MIN( l2+1, n ) ), ldc, & b( l1, MIN( l2+1, n ) ), ldb ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) ! suml = sdot( k1-1, a( 1, k1 ), 1, c( 1, l2 ), 1 ) sumr = sdot( n-l2, c( k1, MIN( l2+1, n ) ), ldc, & b( l2, MIN( l2+1, n ) ), ldb ) vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) ! suml = sdot( k1-1, a( 1, k2 ), 1, c( 1, l1 ), 1 ) sumr = sdot( n-l2, c( k2, MIN( l2+1, n ) ), ldc, & b( l1, MIN( l2+1, n ) ), ldb ) vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) ! suml = sdot( k1-1, a( 1, k2 ), 1, c( 1, l2 ), 1 ) sumr = sdot( n-l2, c( k2, MIN( l2+1, n ) ), ldc, & b( l2, MIN(l2+1, n ) ), ldb ) vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) ! CALL slasy2( .true., .true., isgn, 2, 2, a( k1, k1 ), & lda, b( l1, l1 ), ldb, vec, 2, scaloc, x, 2, xnorm, ierr ) IF( ierr /= 0 ) info = 1 ! IF( scaloc /= one ) THEN DO j = 1, n CALL sscal( m, scaloc, c( 1, j ), 1 ) END DO scale = scale*scaloc END IF c( k1, l1 ) = x( 1, 1 ) c( k1, l2 ) = x( 1, 2 ) c( k2, l1 ) = x( 2, 1 ) c( k2, l2 ) = x( 2, 2 ) END IF ! END DO END DO ! ELSE IF( notrna .AND. .NOT.notrnb ) THEN ! ! Solve A*X + ISGN*X*B' = scale*C. ! ! The (K,L)th block of X is determined starting from ! bottom-right corner column by column by ! ! A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L) ! ! Where ! M N ! R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)']. ! I=K+1 J=L+1 ! ! Start column loop (index = L) ! L1 (L2): column index of the first (last) row of X(K,L) ! lnext = n DO l = n, 1, -1 IF( l > lnext ) CYCLE IF( l == 1 ) THEN l1 = l l2 = l ELSE IF( b( l, l-1 ) /= zero ) THEN l1 = l - 1 l2 = l lnext = l - 2 ELSE l1 = l l2 = l lnext = l - 1 END IF END IF ! ! Start row loop (index = K) ! K1 (K2): row index of the first (last) row of X(K,L) ! knext = m DO k = m, 1, -1 IF( k > knext ) CYCLE IF( k == 1 ) THEN k1 = k k2 = k ELSE IF( a( k, k-1 ) /= zero ) THEN k1 = k - 1 k2 = k knext = k - 2 ELSE k1 = k k2 = k knext = k - 1 END IF END IF ! IF( l1 == l2 .AND. k1 == k2 ) THEN suml = sdot( m-k1, a( k1, MIN(k1+1, m ) ), lda, & c( MIN( k1+1, m ), l1 ), 1 ) sumr = sdot( n-l1, c( k1, MIN( l1+1, n ) ), ldc, & b( l1, MIN( l1+1, n ) ), ldb ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) scaloc = one ! a11 = a( k1, k1 ) + sgn*b( l1, l1 ) da11 = ABS( a11 ) IF( da11 <= smin ) THEN a11 = smin da11 = smin info = 1 END IF db = ABS( vec( 1, 1 ) ) IF( da11 < one .AND. db > one ) THEN IF( db > bignum*da11 ) scaloc = one / db END IF x( 1, 1 ) = ( vec( 1, 1 )*scaloc ) / a11 ! IF( scaloc /= one ) THEN DO j = 1, n CALL sscal( m, scaloc, c( 1, j ), 1 ) END DO scale = scale*scaloc END IF c( k1, l1 ) = x( 1, 1 ) ! ELSE IF( l1 == l2 .AND. k1 /= k2 ) THEN ! suml = sdot( m-k2, a( k1, MIN( k2+1, m ) ), lda, & c( MIN( k2+1, m ), l1 ), 1 ) sumr = sdot( n-l2, c( k1, MIN( l2+1, n ) ), ldc, & b( l1, MIN( l2+1, n ) ), ldb ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) ! suml = sdot( m-k2, a( k2, MIN( k2+1, m ) ), lda, & c( MIN( k2+1, m ), l1 ), 1 ) sumr = sdot( n-l2, c( k2, MIN( l2+1, n ) ), ldc, & b( l1, MIN( l2+1, n ) ), ldb ) vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) ! CALL slaln2( .false., 2, 1, smin, one, a( k1, k1 ), & lda, one, one, vec, 2, -sgn*b( l1, l1 ), & zero, x, 2, scaloc, xnorm, ierr ) IF( ierr /= 0 ) info = 1 ! IF( scaloc /= one ) THEN DO j = 1, n CALL sscal( m, scaloc, c( 1, j ), 1 ) END DO scale = scale*scaloc END IF c( k1, l1 ) = x( 1, 1 ) c( k2, l1 ) = x( 2, 1 ) ! ELSE IF( l1 /= l2 .AND. k1 == k2 ) THEN ! suml = sdot( m-k1, a( k1, MIN( k1+1, m ) ), lda, & c( MIN( k1+1, m ), l1 ), 1 ) sumr = sdot( n-l2, c( k1, MIN( l2+1, n ) ), ldc, & b( l1, MIN( l2+1, n ) ), ldb ) vec( 1, 1 ) = sgn*( c( k1, l1 )-( suml+sgn*sumr ) ) ! suml = sdot( m-k1, a( k1, MIN( k1+1, m ) ), lda, & c( MIN( k1+1, m ), l2 ), 1 ) sumr = sdot( n-l2, c( k1, MIN( l2+1, n ) ), ldc, & b( l2, MIN( l2+1, n ) ), ldb ) vec( 2, 1 ) = sgn*( c( k1, l2 )-( suml+sgn*sumr ) ) ! CALL slaln2( .false., 2, 1, smin, one, b( l1, l1 ), & ldb, one, one, vec, 2, -sgn*a( k1, k1 ), & zero, x, 2, scaloc, xnorm, ierr ) IF( ierr /= 0 ) info = 1 ! IF( scaloc /= one ) THEN DO j = 1, n CALL sscal( m, scaloc, c( 1, j ), 1 ) END DO scale = scale*scaloc END IF c( k1, l1 ) = x( 1, 1 ) c( k1, l2 ) = x( 2, 1 ) ! ELSE IF( l1 /= l2 .AND. k1 /= k2 ) THEN ! suml = sdot( m-k2, a( k1, MIN( k2+1, m ) ), lda, & c( MIN( k2+1, m ), l1 ), 1 ) sumr = sdot( n-l2, c( k1, MIN( l2+1, n ) ), ldc, & b( l1, MIN( l2+1, n ) ), ldb ) vec( 1, 1 ) = c( k1, l1 ) - ( suml+sgn*sumr ) ! suml = sdot( m-k2, a( k1, MIN( k2+1, m ) ), lda, & c( MIN( k2+1, m ), l2 ), 1 ) sumr = sdot( n-l2, c( k1, MIN( l2+1, n ) ), ldc, & b( l2, MIN( l2+1, n ) ), ldb ) vec( 1, 2 ) = c( k1, l2 ) - ( suml+sgn*sumr ) ! suml = sdot( m-k2, a( k2, MIN( k2+1, m ) ), lda, & c( MIN( k2+1, m ), l1 ), 1 ) sumr = sdot( n-l2, c( k2, MIN( l2+1, n ) ), ldc, & b( l1, MIN( l2+1, n ) ), ldb ) vec( 2, 1 ) = c( k2, l1 ) - ( suml+sgn*sumr ) ! suml = sdot( m-k2, a( k2, MIN( k2+1, m ) ), lda, & c( MIN( k2+1, m ), l2 ), 1 ) sumr = sdot( n-l2, c( k2, MIN( l2+1, n ) ), ldc, & b( l2, MIN( l2+1, n ) ), ldb ) vec( 2, 2 ) = c( k2, l2 ) - ( suml+sgn*sumr ) ! CALL slasy2( .false., .true., isgn, 2, 2, a( k1, k1 ), & lda, b( l1, l1 ), ldb, vec, 2, scaloc, x, 2, xnorm, ierr ) IF( ierr /= 0 ) info = 1 ! IF( scaloc /= one ) THEN DO j = 1, n CALL sscal( m, scaloc, c( 1, j ), 1 ) END DO scale = scale*scaloc END IF c( k1, l1 ) = x( 1, 1 ) c( k1, l2 ) = x( 1, 2 ) c( k2, l1 ) = x( 2, 1 ) c( k2, l2 ) = x( 2, 2 ) END IF ! END DO END DO ! END IF ! RETURN ! ! End of STRSYL ! END SUBROUTINE strsyl SUBROUTINE strti2( 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 (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: diag INTEGER, INTENT(IN) :: n REAL, INTENT(OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STRTI2 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) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: nounit, upper INTEGER :: j REAL :: ajj ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL sscal, strmv, 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 < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 END IF IF( info /= 0 ) THEN CALL xerbla( 'STRTI2', -info ) RETURN END IF ! IF( upper ) THEN ! ! Compute inverse of upper triangular matrix. ! DO 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 strmv( 'Upper', 'No transpose', diag, j-1, a, lda, a( 1, j ), 1 ) CALL sscal( j-1, ajj, a( 1, j ), 1 ) END DO ELSE ! ! Compute inverse of lower triangular matrix. ! DO 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 < n ) THEN ! ! Compute elements j+1:n of j-th column. ! CALL strmv( 'Lower', 'No transpose', diag, n-j, & a( j+1, j+1 ), lda, a( j+1, j ), 1 ) CALL sscal( n-j, ajj, a( j+1, j ), 1 ) END IF END DO END IF ! RETURN ! ! End of STRTI2 ! END SUBROUTINE strti2 SUBROUTINE strtri( 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 (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN) :: diag INTEGER, INTENT(IN) :: n REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STRTRI 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) REAL 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 .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: nounit, upper INTEGER :: j, jb, nb, nn ! .. ! .. External Functions .. LOGICAL :: lsame INTEGER :: ilaenv EXTERNAL lsame, ilaenv ! .. ! .. External Subroutines .. EXTERNAL strmm, strsm, strti2, 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 < 0 ) THEN info = -3 ELSE IF( lda < MAX( 1, n ) ) THEN info = -5 END IF IF( info /= 0 ) THEN CALL xerbla( 'STRTRI', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Check for singularity if non-unit. ! IF( nounit ) THEN DO info = 1, n IF( a( info, info ) == zero ) RETURN END DO info = 0 END IF ! ! Determine the block size for this environment. ! nb = ilaenv( 1, 'STRTRI', uplo // diag, n, -1, -1, -1 ) IF( nb <= 1 .OR. nb >= n ) THEN ! ! Use unblocked code ! CALL strti2( uplo, diag, n, a, lda, info ) ELSE ! ! Use blocked code ! IF( upper ) THEN ! ! Compute inverse of upper triangular matrix ! DO j = 1, n, nb jb = MIN( nb, n-j+1 ) ! ! Compute rows 1:j-1 of current block column ! CALL strmm( 'Left', 'Upper', 'No transpose', diag, j-1, & jb, one, a, lda, a( 1, j ), lda ) CALL strsm( 'Right', 'Upper', 'No transpose', diag, j-1, & jb, -one, a( j, j ), lda, a( 1, j ), lda ) ! ! Compute inverse of current diagonal block ! CALL strti2( 'Upper', diag, jb, a( j, j ), lda, info ) END DO ELSE ! ! Compute inverse of lower triangular matrix ! nn = ( ( n-1 ) / nb )*nb + 1 DO j = nn, 1, -nb jb = MIN( nb, n-j+1 ) IF( j+jb <= n ) THEN ! ! Compute rows j+jb:n of current block column ! CALL strmm( 'Left', 'Lower', 'No transpose', diag, & n-j-jb+1, jb, one, a( j+jb, j+jb ), lda, a( j+jb, j ), lda ) CALL strsm( '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 strti2( 'Lower', diag, jb, a( j, j ), lda, info ) END DO END IF END IF ! RETURN ! ! End of STRTRI ! END SUBROUTINE strtri SUBROUTINE strtrs( uplo, trans, diag, 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 (LEN=1), INTENT(IN) :: uplo CHARACTER (LEN=1), INTENT(IN OUT) :: trans CHARACTER (LEN=1), INTENT(IN) :: diag INTEGER, INTENT(IN) :: n INTEGER, INTENT(IN OUT) :: nrhs REAL, INTENT(IN) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(IN OUT) :: b( ldb, * ) INTEGER, INTENT(IN OUT) :: ldb INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STRTRS solves a triangular system of the form ! ! A * X = B or A**T * X = B, ! ! where A is a triangular matrix of order N, and B is an N-by-NRHS ! matrix. A check is made to verify that A is nonsingular. ! ! Arguments ! ========= ! ! UPLO (input) CHARACTER*1 ! = 'U': A is upper triangular; ! = 'L': A is lower triangular. ! ! 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 = Transpose) ! ! 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. ! ! NRHS (input) INTEGER ! The number of right hand sides, i.e., the number of columns ! of the matrix B. NRHS >= 0. ! ! A (input) REAL array, dimension (LDA,N) ! 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. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,N). ! ! B (input/output) REAL array, dimension (LDB,NRHS) ! On entry, the right hand side matrix B. ! On exit, if INFO = 0, 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 ! > 0: if INFO = i, the i-th diagonal element of A is zero, ! indicating that the matrix is singular and the solutions ! X have not been computed. ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 REAL, PARAMETER :: one = 1.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: nounit ! .. ! .. External Functions .. LOGICAL :: lsame EXTERNAL lsame ! .. ! .. External Subroutines .. EXTERNAL strsm, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 nounit = lsame( diag, 'N' ) IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN info = -1 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT. & lsame( trans, 'T' ) .AND. .NOT.lsame( trans, 'C' ) ) THEN info = -2 ELSE IF( .NOT.nounit .AND. .NOT.lsame( diag, 'U' ) ) THEN info = -3 ELSE IF( n < 0 ) THEN info = -4 ELSE IF( nrhs < 0 ) THEN info = -5 ELSE IF( lda < MAX( 1, n ) ) THEN info = -7 ELSE IF( ldb < MAX( 1, n ) ) THEN info = -9 END IF IF( info /= 0 ) THEN CALL xerbla( 'STRTRS', -info ) RETURN END IF ! ! Quick return if possible ! IF( n == 0 ) RETURN ! ! Check for singularity. ! IF( nounit ) THEN DO info = 1, n IF( a( info, info ) == zero ) RETURN END DO END IF info = 0 ! ! Solve A * x = b or A' * x = b. ! CALL strsm( 'Left', uplo, trans, diag, n, nrhs, one, a, lda, b, ldb ) ! RETURN ! ! End of STRTRS ! END SUBROUTINE strtrs SUBROUTINE stzrqf( m, n, a, lda, 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 .. INTEGER, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: tau( * ) INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! This routine is deprecated and has been replaced by routine STZRZF. ! ! STZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A ! to upper triangular form by means of orthogonal transformations. ! ! The upper trapezoidal matrix A is factored as ! ! A = ( R 0 ) * Z, ! ! where Z is an N-by-N orthogonal matrix and R is an M-by-M upper ! triangular matrix. ! ! 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 >= M. ! ! A (input/output) REAL array, dimension (LDA,N) ! On entry, the leading M-by-N upper trapezoidal part of the ! array A must contain the matrix to be factorized. ! On exit, the leading M-by-M upper triangular part of A ! contains the upper triangular matrix R, and elements M+1 to ! N of the first M rows of A, with the array TAU, represent the ! orthogonal matrix Z as a product of M elementary reflectors. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! TAU (output) REAL array, dimension (M) ! The scalar factors of the elementary reflectors. ! ! INFO (output) INTEGER ! = 0: successful exit ! < 0: if INFO = -i, the i-th argument had an illegal value ! ! Further Details ! =============== ! ! The factorization is obtained by Householder's method. The kth ! transformation matrix, Z( k ), which is used to introduce zeros into ! the ( m - k + 1 )th row of A, is given in the form ! ! Z( k ) = ( I 0 ), ! ( 0 T( k ) ) ! ! where ! ! T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), ! ( 0 ) ! ( z( k ) ) ! ! tau is a scalar and z( k ) is an ( n - m ) element vector. ! tau and z( k ) are chosen to annihilate the elements of the kth row ! of X. ! ! The scalar tau is returned in the kth element of TAU and the vector ! u( k ) in the kth row of A, such that the elements of z( k ) are ! in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in ! the upper triangular part of A. ! ! Z is given by ! ! Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: one = 1.0E+0 REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. INTEGER :: i, k, m1 ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. External Subroutines .. EXTERNAL saxpy, scopy, sgemv, sger, slarfg, xerbla ! .. ! .. Executable Statements .. ! ! Test the input parameters. ! info = 0 IF( m < 0 ) THEN info = -1 ELSE IF( n < m ) THEN info = -2 ELSE IF( lda < MAX( 1, m ) ) THEN info = -4 END IF IF( info /= 0 ) THEN CALL xerbla( 'STZRQF', -info ) RETURN END IF ! ! Perform the factorization. ! IF( m == 0 ) RETURN IF( m == n ) THEN DO i = 1, n tau( i ) = zero END DO ELSE m1 = MIN( m+1, n ) DO k = m, 1, -1 ! ! Use a Householder reflection to zero the kth row of A. ! First set up the reflection. ! CALL slarfg( n-m+1, a( k, k ), a( k, m1 ), lda, tau( k ) ) ! IF( ( tau( k ) /= zero ) .AND. ( k > 1 ) ) THEN ! ! We now perform the operation A := A*P( k ). ! ! Use the first ( k - 1 ) elements of TAU to store a( k ), ! where a( k ) consists of the first ( k - 1 ) elements of ! the kth column of A. Also let B denote the first ! ( k - 1 ) rows of the last ( n - m ) columns of A. ! CALL scopy( k-1, a( 1, k ), 1, tau, 1 ) ! ! Form w = a( k ) + B*z( k ) in TAU. ! CALL sgemv( 'No transpose', k-1, n-m, one, a( 1, m1 ), & lda, a( k, m1 ), lda, one, tau, 1 ) ! ! Now form a( k ) := a( k ) - tau*w ! and B := B - tau*w*z( k )'. ! CALL saxpy( k-1, -tau( k ), tau, 1, a( 1, k ), 1 ) CALL sger( k-1, n-m, -tau( k ), tau, 1, a( k, m1 ), lda, & a( 1, m1 ), lda ) END IF END DO END IF ! RETURN ! ! End of STZRQF ! END SUBROUTINE stzrqf SUBROUTINE stzrzf( 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, INTENT(IN) :: m INTEGER, INTENT(IN) :: n REAL, INTENT(IN OUT) :: a( lda, * ) INTEGER, INTENT(IN OUT) :: lda REAL, INTENT(OUT) :: tau( * ) REAL, INTENT(OUT) :: work( * ) INTEGER, INTENT(IN) :: lwork INTEGER, INTENT(OUT) :: info ! .. ! .. Array Arguments .. ! .. ! ! Purpose ! ======= ! ! STZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A ! to upper triangular form by means of orthogonal transformations. ! ! The upper trapezoidal matrix A is factored as ! ! A = ( R 0 ) * Z, ! ! where Z is an N-by-N orthogonal matrix and R is an M-by-M upper ! triangular matrix. ! ! 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) REAL array, dimension (LDA,N) ! On entry, the leading M-by-N upper trapezoidal part of the ! array A must contain the matrix to be factorized. ! On exit, the leading M-by-M upper triangular part of A ! contains the upper triangular matrix R, and elements M+1 to ! N of the first M rows of A, with the array TAU, represent the ! orthogonal matrix Z as a product of M elementary reflectors. ! ! LDA (input) INTEGER ! The leading dimension of the array A. LDA >= max(1,M). ! ! TAU (output) REAL array, dimension (M) ! The scalar factors of the elementary reflectors. ! ! WORK (workspace/output) REAL 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 ! =============== ! ! Based on contributions by ! A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA ! ! The factorization is obtained by Householder's method. The kth ! transformation matrix, Z( k ), which is used to introduce zeros into ! the ( m - k + 1 )th row of A, is given in the form ! ! Z( k ) = ( I 0 ), ! ( 0 T( k ) ) ! ! where ! ! T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ), ! ( 0 ) ! ( z( k ) ) ! ! tau is a scalar and z( k ) is an ( n - m ) element vector. ! tau and z( k ) are chosen to annihilate the elements of the kth row ! of X. ! ! The scalar tau is returned in the kth element of TAU and the vector ! u( k ) in the kth row of A, such that the elements of z( k ) are ! in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in ! the upper triangular part of A. ! ! Z is given by ! ! Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). ! ! ===================================================================== ! ! .. Parameters .. REAL, PARAMETER :: zero = 0.0E+0 ! .. ! .. Local Scalars .. LOGICAL :: lquery INTEGER :: i, ib, iws, ki, kk, ldwork, lwkopt, m1, mu, nb, nbmin, nx ! .. ! .. External Subroutines .. EXTERNAL slarzb, slarzt, slatrz, xerbla ! .. ! .. Intrinsic Functions .. INTRINSIC MAX, MIN ! .. ! .. External Functions .. INTEGER :: ilaenv EXTERNAL ilaenv ! .. ! .. Executable Statements .. ! ! Test the input arguments ! info = 0 lquery = ( lwork == -1 ) IF( m < 0 ) THEN info = -1 ELSE IF( n < m ) THEN info = -2 ELSE IF( lda < MAX( 1, m ) ) THEN info = -4 ELSE IF( lwork < MAX( 1, m ) .AND. .NOT.lquery ) THEN info = -7 END IF ! IF( info == 0 ) THEN ! ! Determine the block size. ! nb = ilaenv( 1, 'SGERQF', ' ', m, n, -1, -1 ) lwkopt = m*nb work( 1 ) = lwkopt END IF ! IF( info /= 0 ) THEN CALL xerbla( 'STZRZF', -info ) RETURN ELSE IF( lquery ) THEN RETURN END IF ! ! Quick return if possible ! IF( m == 0 ) THEN work( 1 ) = 1 RETURN ELSE IF( m == n ) THEN DO i = 1, n tau( i ) = zero END DO work( 1 ) = 1 RETURN END IF ! nbmin = 2 nx = 1 iws = m IF( nb > 1 .AND. nb < m ) THEN ! ! Determine when to cross over from blocked to unblocked code. ! nx = MAX( 0, ilaenv( 3, 'SGERQF', ' ', m, n, -1, -1 ) ) IF( nx < m ) THEN ! ! Determine if workspace is large enough for blocked code. ! ldwork = m iws = ldwork*nb IF( lwork < 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, 'SGERQF', ' ', m, n, -1, -1 ) ) END IF END IF END IF ! IF( nb >= nbmin .AND. nb < m .AND. nx < m ) THEN ! ! Use blocked code initially. ! The last kk rows are handled by the block method. ! m1 = MIN( m+1, n ) ki = ( ( m-nx-1 ) / nb )*nb kk = MIN( m, ki+nb ) ! DO i = m - kk + ki + 1, m - kk + 1, -nb ib = MIN( m-i+1, nb ) ! ! Compute the TZ factorization of the current block ! A(i:i+ib-1,i:n) ! CALL slatrz( ib, n-i+1, n-m, a( i, i ), lda, tau( i ), work ) IF( i > 1 ) THEN ! ! Form the triangular factor of the block reflector ! H = H(i+ib-1) . . . H(i+1) H(i) ! CALL slarzt( 'Backward', 'Rowwise', n-m, ib, a( i, m1 ), & lda, tau( i ), work, ldwork ) ! ! Apply H to A(1:i-1,i:n) from the right ! CALL slarzb( 'Right', 'No transpose', 'Backward', & 'Rowwise', i-1, n-i+1, ib, n-m, a( i, m1 ), & lda, work, ldwork, a( 1, i ), lda, work( ib+1 ), ldwork ) END IF END DO mu = i + nb - 1 ELSE mu = m END IF ! ! Use unblocked code to factor the last or only block ! IF( mu > 0 ) CALL slatrz( mu, n, n-m, a, lda, tau, work ) ! work( 1 ) = lwkopt ! RETURN ! ! End of STZRZF ! END SUBROUTINE stzrzf SUBROUTINE xerbla( srname, info ) ! ! -- 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 (LEN=6), INTENT(IN OUT) :: srname INTEGER, INTENT(IN) :: 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. ! ! ===================================================================== ! ! .. Executable Statements .. ! WRITE( *, FMT = 9999 )srname, info ! STOP ! 9999 FORMAT( ' ** On entry to ', a6, ' parameter number ', i2, ' had ', & 'an illegal value' ) ! ! End of XERBLA ! END SUBROUTINE xerbla function isamax ( n, x, incx ) ! !******************************************************************************* ! !! ISAMAX finds the index of the vector element of maximum absolute value. ! ! ! Modified: ! ! 08 April 1999 ! ! Reference: ! ! Lawson, Hanson, Kincaid, Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real X(*), the vector to be examined. ! ! Input, integer INCX, the increment between successive entries of SX. ! ! Output, integer ISAMAX, the index of the element of SX of maximum ! absolute value. ! implicit none ! integer i integer incx integer isamax integer ix integer n real samax real x(*) ! if ( n <= 0 ) then isamax = 0 else if ( n == 1 ) then isamax = 1 else if ( incx == 1 ) then isamax = 1 samax = abs ( x(1) ) do i = 2, n if ( abs ( x(i) ) > samax ) then isamax = i samax = abs ( x(i) ) END IF end do else if ( incx >= 0 ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 END IF isamax = 1 samax = abs ( x(ix) ) ix = ix + incx do i = 2, n if ( abs ( x(ix) ) > samax ) then isamax = i samax = abs ( x(ix) ) END IF ix = ix + incx end do END IF return end function sasum ( n, x, incx ) ! !******************************************************************************* ! !! SASUM sums the absolute values of the entries of a vector. ! ! ! Modified: ! ! 15 February 2001 ! ! Reference: ! ! Lawson, Hanson, Kincaid, Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real X(*), the vector to be examined. ! ! Input, integer INCX, the increment between successive entries of X. ! INCX must not be negative. ! ! Output, real SASUM, the sum of the absolute values of X. ! implicit none ! integer incx integer n real sasum real x(*) ! sasum = sum ( abs ( x(1:1+(n-1)*incx:incx) ) ) return end subroutine saxpy ( n, sa, x, incx, y, incy ) ! !******************************************************************************* ! !! SAXPY adds a constant times one vector to another. ! ! ! Modified: ! ! 08 April 1999 ! ! Reference: ! ! Lawson, Hanson, Kincaid, Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real SA, the multiplier. ! ! Input, real X(*), the vector to be scaled and added to Y. ! ! Input, integer INCX, the increment between successive entries of X. ! ! Input/output, real Y(*), the vector to which a multiple of X is to ! be added. ! ! Input, integer INCY, the increment between successive entries of Y. ! implicit none ! integer i integer incx integer incy integer ix integer iy integer n real sa real x(*) real y(*) ! if ( n <= 0 ) then else if ( sa == 0.0E+00 ) then else if ( incx == 1 .and. incy == 1 ) then y(1:n) = y(1:n) + sa * x(1:n) else if ( incx >= 0 ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 END IF if ( incy >= 0 ) then iy = 1 else iy = ( - n + 1 ) * incy + 1 END IF do i = 1, n y(iy) = y(iy) + sa * x(ix) ix = ix + incx iy = iy + incy end do END IF return end subroutine scopy ( n, x, incx, y, incy ) ! !******************************************************************************* ! !! SCOPY copies one real vector into another. ! ! ! Modified: ! ! 08 April 1999 ! ! Reference: ! ! Lawson, Hanson, Kincaid, Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real X(*), the vector to be copied into Y. ! ! Input, integer INCX, the increment between successive entries of X. ! ! Output, real Y(*), the copy of X. ! ! Input, integer INCY, the increment between successive elements of Y. ! implicit none ! integer i integer incx integer incy integer ix integer iy integer n real x(*) real y(*) ! if ( n <= 0 ) then else if ( incx == 1 .and. incy == 1 ) then y(1:n) = x(1:n) else if ( incx >= 0 ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 END IF if ( incy >= 0 ) then iy = 1 else iy = ( - n + 1 ) * incy + 1 END IF do i = 1, n y(iy) = x(ix) ix = ix + incx iy = iy + incy end do END IF return end function sdot ( n, x, incx, y, incy ) ! !******************************************************************************* ! !! SDOT forms the dot product of two vectors. ! ! ! Modified: ! ! 02 June 2000 ! ! Reference: ! ! Lawson, Hanson, Kincaid, Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vectors. ! ! Input, real X(*), one of the vectors to be multiplied. ! ! Input, integer INCX, the increment between successive entries of X. ! ! Input, real Y(*), one of the vectors to be multiplied. ! ! Input, integer INCY, the increment between successive elements of Y. ! ! Output, real SDOT, the dot product of X and Y. ! implicit none ! integer i integer incx integer incy integer ix integer iy integer n real sdot real stemp real x(*) real y(*) ! if ( n <= 0 ) then sdot = 0.0E+00 else if ( incx == 1 .and. incy == 1 ) then sdot = dot_product ( x(1:n), y(1:n) ) else if ( incx >= 0 ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 END IF if ( incy >= 0 ) then iy = 1 else iy = ( - n + 1 ) * incy + 1 END IF stemp = 0.0E+00 do i = 1, n stemp = stemp + x(ix) * y(iy) ix = ix + incx iy = iy + incy end do sdot = stemp END IF return end subroutine sgbmv ( trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, incy ) ! !******************************************************************************* ! !! SGBMV computes Y := ALPHA * A * X + BETA * Y or Y := ALPHA * A' * X + BETA * Y. ! ! ! Discussion: ! ! ALPHA and BETA are scalars, X and Y are vectors and A is an ! M by N band matrix, with KL sub-diagonals and KU super-diagonals. ! ! Author: ! ! Jack Dongarra, Argonne National Lab. ! Jeremy du Croz, NAG Central Office. ! Sven Hammarling, NAG Central Office. ! Richard Hanson, Sandia National Labs. ! ! Parameters: ! ! trans - character. ! on entry, trans specifies the operation to be performed as ! follows: ! ! trans = 'N' or 'N' y := alpha * a * x + beta*y. ! ! trans = 'T' or 'T' y := alpha * a' * x + beta*y. ! ! trans = 'C' or 'C' y := alpha * a' * x + beta*y. ! ! unchanged on exit. ! ! m - integer. ! on entry, m specifies the number of rows of the matrix a. ! m must be at least 0. ! unchanged on exit. ! ! n - integer. ! on entry, n specifies the number of columns of the matrix a. ! n must be at least 0. ! unchanged on exit. ! ! kl - integer. ! on entry, kl specifies the number of sub-diagonals of the ! matrix a. kl must satisfy 0 <= kl. ! unchanged on exit. ! ! ku - integer. ! on entry, ku specifies the number of super-diagonals of the ! matrix a. ku must satisfy 0 <= ku. ! unchanged on exit. ! ! alpha - real . ! on entry, alpha specifies the scalar alpha. ! unchanged on exit. ! ! a - real array of dimension ( lda, n ). ! before entry, the leading ( kl + ku + 1 ) by n part of the ! array a must contain the matrix of coefficients, supplied ! column by column, with the leading diagonal of the matrix in ! row ( ku + 1 ) of the array, the first super-diagonal ! starting at position 2 in row ku, the first sub-diagonal ! starting at position 1 in row ( ku + 2 ), and so on. ! elements in the array a that do not correspond to elements ! in the band matrix (such as the top left ku by ku triangle) ! are not referenced. ! the following program segment will transfer a band matrix ! from conventional full matrix storage to band storage: ! ! do j = 1, n ! k = ku + 1 - j ! do i = max ( 1, j - ku ), min ( m, j + kl ) ! a( k + i,j) = matrix(i,j) ! end do ! end do ! ! unchanged on exit. ! ! lda - integer. ! on entry, lda specifies the first dimension of a as declared ! in the calling (sub) program. lda must be at least ! ( kl + ku + 1 ). ! unchanged on exit. ! ! x - real array of dimension at least ! ( 1 + ( n - 1 ) * abs( incx ) ) when trans = 'N' or 'N' ! and at least ! ( 1 + ( m - 1 ) * abs( incx ) ) otherwise. ! before entry, the incremented array x must contain the ! vector x. ! unchanged on exit. ! ! incx - integer. ! on entry, incx specifies the increment for the elements of ! x. incx must not be 0. ! unchanged on exit. ! ! beta - real . ! on entry, beta specifies the scalar beta. when beta is ! supplied as zero then y need not be set on input. ! unchanged on exit. ! ! y - real array of dimension at least ! ( 1 + ( m - 1 ) * abs( incy ) ) when trans = 'N' or 'N' ! and at least ! ( 1 + ( n - 1 ) * abs( incy ) ) otherwise. ! before entry, the incremented array y must contain the ! vector y. on exit, y is overwritten by the updated vector y. ! ! incy - integer. ! on entry, incy specifies the increment for the elements of ! y. incy must not be 0. ! unchanged on exit. ! implicit none ! integer lda ! real a(lda,*) real alpha real beta integer i integer incx integer incy integer info integer ix integer iy integer j integer jx integer jy integer k integer kl integer ku integer kup1 integer kx integer ky integer lenx integer leny logical, external :: lsame integer m integer n character trans real temp real x(*) external xerbla real y(*) ! ! Test the input parameters. ! info = 0 if ( .not.lsame ( trans, 'N' ) .and. & .not.lsame ( trans, 'T' ) .and. & .not.lsame ( trans, 'C' ) ) then info = 1 else if ( m < 0 ) then info = 2 else if ( n < 0 ) then info = 3 else if ( kl < 0 ) then info = 4 else if ( ku < 0 ) then info = 5 else if ( lda < ( kl + ku + 1 ) ) then info = 8 else if ( incx == 0 ) then info = 10 else if ( incy == 0 ) then info = 13 END IF if ( info /= 0 ) then call xerbla ( 'sgbmv ', info ) return END IF ! ! Quick return if possible. ! if ( m == 0 ) then return else if ( n == 0 ) then return else if ( alpha == 0.0 .and. beta == 1.0 ) then return END IF ! ! set lenx and leny, the lengths of the vectors x and y, and set ! up the start points in x and y. ! if ( lsame ( trans, 'N' ) ) then lenx = n leny = m else lenx = m leny = n END IF if ( incx > 0 ) then kx = 1 else kx = 1 - ( lenx - 1 ) * incx END IF if ( incy > 0 ) then ky = 1 else ky = 1 - ( leny - 1 ) * incy END IF ! ! Start the operations. in this version the elements of A are ! accessed sequentially with one pass through the band part of A. ! ! First form y := beta*y. ! if ( beta /= 1.0 ) then if ( incy == 1 ) then if ( beta == 0.0 ) then y(1:leny) = 0.0 else y(1:leny) = beta * y(1:leny) END IF else iy = ky if ( beta == 0.0 ) then do i = 1, leny y(iy) = 0.0 iy = iy + incy end do else do i = 1, leny y(iy) = beta * y(iy) iy = iy + incy end do END IF END IF END IF if ( alpha == 0.0 ) then return END IF kup1 = ku + 1 if ( lsame ( trans, 'N' ) ) then ! ! Form y := alpha * a * x + y. ! jx = kx if ( incy == 1 ) then do j = 1, n if ( x(jx) /= 0.0 ) then temp = alpha * x(jx) k = kup1 - j do i = max ( 1, j - ku ), min ( m, j + kl ) y(i) = y(i) + temp * a( k + i,j) end do END IF jx = jx + incx end do else do j = 1, n if ( x(jx) /= 0.0 ) then temp = alpha * x(jx) iy = ky k = kup1 - j do i = max ( 1, j - ku ), min ( m, j + kl ) y(iy) = y(iy) + temp * a( k + i,j) iy = iy + incy end do END IF jx = jx + incx if ( j>ku ) then ky = ky + incy END IF end do END IF else ! ! Form y := alpha * a' * x + y. ! jy = ky if ( incx == 1 ) then do j = 1, n temp = 0.0 k = kup1 - j do i = max ( 1, j - ku ), min ( m, j + kl ) temp = temp + a( k + i,j) * x(i) end do y(jy) = y(jy) + alpha * temp jy = jy + incy end do else do j = 1, n temp = 0.0 ix = kx k = kup1 - j do i = max ( 1, j - ku ), min ( m, j + kl ) temp = temp + a( k + i,j) * x(ix) ix = ix + incx end do y(jy) = y(jy) + alpha * temp jy = jy + incy if ( j>ku ) then kx = kx + incx END IF end do END IF END IF return end subroutine sgemm ( transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, & ldc ) ! !******************************************************************************* ! !! SGEMM performs one of the matrix-matrix operations ! ! c := alpha*op( a )*op( b ) + beta*c, ! ! where op( x ) is one of ! ! op( x ) = x or op( x ) = x', ! ! alpha and beta are scalars, and a, b and c are matrices, with op( a ) ! an m by k matrix, op( b ) a k by n matrix and c an m by n matrix. ! ! Author: ! ! Jack Dongarra, Argonne National Laboratory. ! Iain Duff, AERE Harwell. ! Jeremy du Croz, Numerical Algorithms Group LTD. ! Sven Hammarling, Numerical Algorithms Group LTD. ! ! Parameters: ! ! transa - character. ! on entry, transa specifies the form of op( a ) to be used in ! the matrix multiplication as follows: ! ! transa = 'n' or 'n', op( a ) = a. ! ! transa = 't' or 't', op( a ) = a'. ! ! transa = 'c' or 'C', op( a ) = a'. ! ! unchanged on exit. ! ! transb - character. ! on entry, transb specifies the form of op( b ) to be used in ! the matrix multiplication as follows: ! ! transb = 'n' or 'n', op( b ) = b. ! ! transb = 't' or 't', op( b ) = b'. ! ! transb = 'c' or 'C', op( b ) = b'. ! ! unchanged on exit. ! ! m - integer. ! on entry, m specifies the number of rows of the matrix ! op( a ) and of the matrix c. m must be at least 0. ! unchanged on exit. ! ! n - integer. ! on entry, n specifies the number of columns of the matrix ! op( b ) and the number of columns of the matrix c. n must be ! at least 0. ! unchanged on exit. ! ! k - integer. ! on entry, k specifies the number of columns of the matrix ! op( a ) and the number of rows of the matrix op( b ). k must ! be at least 0. ! unchanged on exit. ! ! alpha - real . ! on entry, alpha specifies the scalar alpha. ! unchanged on exit. ! ! a - real array of dimension ( lda, ka ), where ka is ! k when transa = 'n' or 'n', and is m otherwise. ! before entry with transa = 'n' or 'n', the leading m by k ! part of the array a must contain the matrix a, otherwise ! the leading k by m part of the array a must contain the ! matrix a. ! unchanged on exit. ! ! lda - integer. ! on entry, lda specifies the first dimension of a as declared ! in the calling (sub) program. when transa = 'n' or 'n' then ! lda must be at least max( 1, m ), otherwise lda must be at ! least max( 1, k ). ! unchanged on exit. ! ! b - real array of dimension ( ldb, kb ), where kb is ! n when transb = 'n' or 'n', and is k otherwise. ! before entry with transb = 'n' or 'n', the leading k by n ! part of the array b must contain the matrix b, otherwise ! the leading n by k part of the array b must contain the ! matrix b. ! unchanged on exit. ! ! ldb - integer. ! on entry, ldb specifies the first dimension of b as declared ! in the calling (sub) program. when transb = 'n' or 'n' then ! ldb must be at least max( 1, k ), otherwise ldb must be at ! least max( 1, n ). ! unchanged on exit. ! ! beta - real . ! on entry, beta specifies the scalar beta. when beta is ! supplied as 0.0 then c need not be set on input. ! unchanged on exit. ! ! c - real array of dimension ( ldc, n ). ! before entry, the leading m by n part of the array c must ! contain the matrix c, except when beta is 0.0, in which ! case c need not be set on entry. ! on exit, the array c is overwritten by the m by n matrix ! ( alpha*op( a )*op( b ) + beta*c ). ! ! ldc - integer. ! on entry, ldc specifies the first dimension of c as declared ! in the calling (sub) program. ldc must be at least ! max( 1, m ). ! unchanged on exit. ! implicit none ! character transa, transb integer m, n, k, lda, ldb, ldc real alpha, beta ! .. array arguments .. real a( lda, * ), b( ldb, * ), c( ldc, * ) ! .. ! .. external functions .. logical lsame external lsame ! .. external subroutines .. external xerbla ! .. intrinsic functions .. intrinsic max ! .. local scalars .. logical nota, notb integer i, info, j, l, ncola, nrowa, nrowb real temp ! ! set nota and notb as true if a and b respectively are not ! transposed and set nrowa, ncola and nrowb as the number of rows ! and columns of a and the number of rows of b respectively. ! nota = lsame( transa, 'N' ) notb = lsame( transb, 'N' ) if ( nota ) then nrowa = m ncola = k else nrowa = k ncola = m END IF if ( notb ) then nrowb = k else nrowb = n END IF ! ! test the input parameters. ! info = 0 if ( ( .not.nota ).and. & ( .not.lsame( transa, 'C' ) ).and. & ( .not.lsame( transa, 'T' ) ) ) then info = 1 else if ( ( .not.notb ).and. & ( .not.lsame( transb, 'C' ) ).and. & ( .not.lsame( transb, 'T' ) ) ) then info = 2 else if ( m <0 ) then info = 3 else if ( n <0 ) then info = 4 else if ( k <0 ) then info = 5 else if ( lda 0 ) then kx = 1 else kx = 1 - ( lenx - 1 ) * incx END IF if ( incy > 0 ) then ky = 1 else ky = 1 - ( leny - 1 ) * incy END IF ! ! Start the operations. in this version the elements of a are ! accessed sequentially with one pass through a. ! ! First form y := beta*y. ! if ( beta /= 1.0 ) then if ( incy == 1 ) then if ( beta == 0.0 ) then do i = 1, leny y(i) = 0.0 end do else do i = 1, leny y(i) = beta * y(i) end do END IF else iy = ky if ( beta == 0.0 ) then do i = 1, leny y(iy) = 0.0 iy = iy + incy end do else do i = 1, leny y(iy) = beta * y(iy) iy = iy + incy end do END IF END IF END IF if ( alpha == 0.0 ) then return END IF if ( lsame ( trans, 'N' ) ) then ! ! Form y := alpha * a * x + y. ! jx = kx if ( incy == 1 ) then do j = 1, n if ( x(jx) /= 0.0 ) then temp = alpha * x(jx) do i = 1, m y(i) = y(i) + temp * a(i,j) end do END IF jx = jx + incx end do else do j = 1, n if ( x(jx) /= 0.0 ) then temp = alpha * x(jx) iy = ky do i = 1, m y(iy) = y(iy) + temp * a(i,j) iy = iy + incy end do END IF jx = jx + incx end do END IF else ! ! Form y := alpha * a' * x + y. ! jy = ky if ( incx == 1 ) then do j = 1, n temp = 0.0 do i = 1, m temp = temp + a(i,j) * x(i) end do y(jy) = y(jy) + alpha * temp jy = jy + incy end do else do j = 1, n temp = 0.0 ix = kx do i = 1, m temp = temp + a(i,j) * x(ix) ix = ix + incx end do y(jy) = y(jy) + alpha * temp jy = jy + incy end do END IF END IF return end subroutine sger ( m, n, alpha, x, incx, y, incy, a, lda ) ! !******************************************************************************* ! !! SGER performs the rank 1 operation A := A + alpha * x*y'. ! ! ! Discussion: ! ! ALPHA is a scalar, ! X is an M element vector, ! Y is an N element vector, ! A is an M by N matrix. ! ! Author: ! ! Jack Dongarra, Argonne National Lab. ! Jeremy du Croz, NAG Central Office. ! Sven Hammarling, NAG Central Office. ! Richard Hanson, Sandia National Labs. ! ! Parameters: ! ! Input, integer M, the number of rows in A. M must be at least 0. ! ! n - integer. ! on entry, n specifies the number of columns of the matrix a. ! n must be at least 0. ! unchanged on exit. ! ! alpha - real . ! on entry, alpha specifies the scalar alpha. ! unchanged on exit. ! ! x - real array of dimension at least ! ( 1 + ( m - 1 ) * abs( incx ) ). ! before entry, the incremented array x must contain the m ! element vector x. ! unchanged on exit. ! ! incx - integer. ! on entry, incx specifies the increment for the elements of ! x. incx must not be 0. ! unchanged on exit. ! ! y - real array of dimension at least ! ( 1 + ( n - 1 ) * abs( incy ) ). ! before entry, the incremented array y must contain the n ! element vector y. ! unchanged on exit. ! ! incy - integer. ! on entry, incy specifies the increment for the elements of ! y. incy must not be 0. ! unchanged on exit. ! ! a - real array of dimension ( lda, n ). ! before entry, the leading m by n part of the array a must ! contain the matrix of coefficients. on exit, a is ! overwritten by the updated matrix. ! ! lda - integer. ! on entry, lda specifies the first dimension of a as declared ! in the calling (sub) program. lda must be at least ! max ( 1, m ). ! unchanged on exit. ! implicit none ! real alpha integer incx, incy, lda, m, n ! .. array arguments .. real a( lda, * ), x( * ), y( * ) real temp integer i, info, ix, j, jy, kx ! .. external subroutines .. external xerbla ! ! Test the input parameters. ! info = 0 if ( m < 0 ) then info = 1 else if ( n < 0 ) then info = 2 else if ( incx == 0 ) then info = 5 else if ( incy == 0 ) then info = 7 else if ( lda < max ( 1, m ) ) then info = 9 END IF if ( info /= 0 ) then call xerbla ( 'sger ', info ) return END IF ! ! Quick returns. ! if ( m == 0 .or. n== 0 .or. alpha == 0.0 ) then return END IF ! ! Start the operations. ! ! In this version the elements of a are ! accessed sequentially with one pass through a. ! if ( incy > 0 ) then jy = 1 else jy = 1 - ( n - 1 ) * incy END IF if ( incx == 1 ) then do j = 1, n if ( y(jy) /= 0.0 ) then temp = alpha * y(jy) do i = 1, m a(i,j) = a(i,j) + x(i) * temp end do END IF jy = jy + incy end do else if ( incx > 0 ) then kx = 1 else kx = 1 - ( m - 1 ) * incx END IF do j = 1, n if ( y(jy) /= 0.0 ) then temp = alpha * y(jy) ix = kx do i = 1, m a(i,j) = a(i,j) + x(ix) * temp ix = ix + incx end do END IF jy = jy + incy end do END IF return end function snrm2 ( n, x, incx ) ! !******************************************************************************* ! !! SNRM2 computes the Euclidean norm of a vector. ! ! ! Discussion: ! ! The original SNRM2 algorithm is accurate but written in a bizarre, ! unreadable and obsolete format. This version goes for clarity. ! ! Modified: ! ! 01 June 2000 ! ! Reference: ! ! Lawson, Hanson, Kincaid, Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real X(*), the vector whose norm is to be computed. ! ! Input, integer INCX, the increment between successive entries of X. ! ! Output, real SNRM2, the Euclidean norm of X. ! implicit none ! integer i integer incx integer ix integer n real snrm2 real stemp real x(*) real xmax ! if ( n <= 0 ) then snrm2 = 0.0E+00 else xmax = maxval ( abs ( x(1:1+(n-1)*incx:incx) ) ) if ( xmax == 0.0E+00 ) then snrm2 = 0.0E+00 else if ( incx >= 0 ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 END IF stemp = 0.0E+00 do i = 1, n stemp = stemp + ( x(ix) / xmax )**2 ix = ix + incx end do snrm2 = xmax * sqrt ( stemp ) END IF END IF return end subroutine srot ( n, x, incx, y, incy, c, s ) ! !******************************************************************************* ! !! SROT applies a plane rotation. ! ! ! Modified: ! ! 08 April 1999 ! ! Reference: ! ! Lawson, Hanson, Kincaid, Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vectors. ! ! Input/output, real X(*), one of the vectors to be rotated. ! ! Input, integer INCX, the increment between successive entries of X. ! ! Input/output, real Y(*), one of the vectors to be rotated. ! ! Input, integer INCY, the increment between successive elements of Y. ! ! Input, real C, S, parameters (presumably the cosine and sine of ! some angle) that define a plane rotation. ! implicit none ! real c integer i integer incx integer incy integer ix integer iy integer n real s real stemp real x(*) real y(*) ! if ( n <= 0 ) then else if ( incx == 1 .and. incy == 1 ) then do i = 1, n stemp = c * x(i) + s * y(i) y(i) = c * y(i) - s * x(i) x(i) = stemp end do else if ( incx >= 0 ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 END IF if ( incy >= 0 ) then iy = 1 else iy = ( - n + 1 ) * incy + 1 END IF do i = 1, n stemp = c * x(ix) + s * y(iy) y(iy) = c * y(iy) - s * x(ix) x(ix) = stemp ix = ix + incx iy = iy + incy end do END IF return end subroutine srotg ( sa, sb, c, s ) ! !******************************************************************************* ! !! SROTG constructs a Givens plane rotation. ! ! ! Modified: ! ! 08 April 1999 ! ! Reference: ! ! Lawson, Hanson, Kincaid, Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input/output, real SA, SB, ... ! ! Output, real C, S, ... ! implicit none ! real c real r real roe real s real sa real sb real scale real z ! if ( abs ( sa ) > abs ( sb ) ) then roe = sa else roe = sb END IF scale = abs ( sa ) + abs ( sb ) if ( scale == 0.0E+00 ) then c = 1.0E+00 s = 0.0E+00 r = 0.0E+00 else r = scale * sqrt ( ( sa / scale )**2 + ( sb / scale )**2 ) r = sign ( 1.0E+00, roe ) * r c = sa / r s = sb / r END IF if ( abs ( c ) > 0.0E+00 .and. abs ( c ) <= s ) then z = 1.0E+00 / c else z = s END IF sa = r sb = z return end subroutine ssbmv ( uplo, n, k, alpha, a, lda, x, incx, beta, y, incy ) ! !******************************************************************************* ! !! SSBMV performs the matrix-vector operation y := alpha * A * x + beta*y, ! ! where alpha and beta are scalars, x and y are n element vectors and ! a is an n by n symmetric band matrix, with k super-diagonals. ! ! Author: ! ! Jack Dongarra, Argonne National Lab. ! Jeremy du Croz, NAG Central Office. ! Sven Hammarling, NAG Central Office. ! Richard Hanson, Sandia National Labs. ! ! Parameters: ! ! uplo - character. ! on entry, uplo specifies whether the upper or lower ! triangular part of the band matrix a is being supplied as ! follows: ! ! uplo = 'U' or 'U' the upper triangular part of a is ! being supplied. ! ! uplo = 'L' or 'L' the lower triangular part of a is ! being supplied. ! ! unchanged on exit. ! ! n - integer. ! on entry, n specifies the order of the matrix a. ! n must be at least 0. ! unchanged on exit. ! ! k - integer. ! on entry, k specifies the number of super-diagonals of the ! matrix a. k must satisfy 0 <= k. ! unchanged on exit. ! ! alpha - real . ! on entry, alpha specifies the scalar alpha. ! unchanged on exit. ! ! a - real array of dimension ( lda, n ). ! before entry with uplo = 'U' or 'U', the leading ( k + 1 ) ! by n part of the array a must contain the upper triangular ! band part of the symmetric matrix, supplied column by ! column, with the leading diagonal of the matrix in row ! ( k + 1 ) of the array, the first super-diagonal starting at ! position 2 in row k, and so on. the top left k by k triangle ! of the array a is not referenced. ! the following program segment will transfer the upper ! triangular part of a symmetric band matrix from conventional ! full matrix storage to band storage: ! ! do j = 1, n ! m = k + 1 - j ! do i = max ( 1, j - k ), j ! a( m + i,j) = matrix(i,j) ! end do ! end do ! ! before entry with uplo = 'L' or 'L', the leading ( k + 1 ) ! by n part of the array a must contain the lower triangular ! band part of the symmetric matrix, supplied column by ! column, with the leading diagonal of the matrix in row 1 of ! the array, the first sub-diagonal starting at position 1 in ! row 2, and so on. the bottom right k by k triangle of the ! array a is not referenced. ! the following program segment will transfer the lower ! triangular part of a symmetric band matrix from conventional ! full matrix storage to band storage: ! ! do j = 1, n ! m = 1 - j ! do i = j, min ( n, j + k ) ! a( m + i,j) = matrix(i,j) ! end do ! end do ! ! unchanged on exit. ! ! lda - integer. ! on entry, lda specifies the first dimension of a as declared ! in the calling (sub) program. lda must be at least ! ( k + 1 ). ! unchanged on exit. ! ! x - real array of dimension at least ! ( 1 + ( n - 1 ) * abs( incx ) ). ! before entry, the incremented array x must contain the ! vector x. ! unchanged on exit. ! ! incx - integer. ! on entry, incx specifies the increment for the elements of ! x. incx must not be 0. ! unchanged on exit. ! ! beta - real . ! on entry, beta specifies the scalar beta. ! unchanged on exit. ! ! y - real array of dimension at least ! ( 1 + ( n - 1 ) * abs( incy ) ). ! before entry, the incremented array y must contain the ! vector y. on exit, y is overwritten by the updated vector y. ! ! incy - integer. ! on entry, incy specifies the increment for the elements of ! y. incy must not be 0. ! unchanged on exit. ! implicit none ! real alpha, beta integer incx, incy, k, lda, n character uplo ! .. array arguments .. real a( lda, * ), x( * ), y( * ) real temp1, temp2 integer i, info, ix, iy, j, jx, jy, kplus1, kx, ky, l ! .. external functions .. logical lsame external lsame ! .. external subroutines .. external xerbla ! ! test the input parameters. ! info = 0 if ( .not.lsame ( uplo, 'U' ).and. & .not.lsame ( uplo, 'L' ) ) then info = 1 else if ( n < 0 ) then info = 2 else if ( k < 0 ) then info = 3 else if ( lda < ( k + 1 ) ) then info = 6 else if ( incx == 0 ) then info = 8 else if ( incy == 0 ) then info = 11 END IF if ( info /= 0 ) then call xerbla ( 'ssbmv ', info ) return END IF ! ! Quick returns. ! if ( ( n == 0 ).or.( ( alpha== 0.0 ).and.( beta== 1.0 ) ) ) then return END IF ! ! Set up the start points in x and y. ! if ( incx>0 ) then kx = 1 else kx = 1 - ( n - 1 ) * incx END IF if ( incy>0 ) then ky = 1 else ky = 1 - ( n - 1 ) * incy END IF ! ! start the operations. in this version the elements of the array a ! are accessed sequentially with one pass through a. ! ! first form y := beta*y. ! if ( beta /= 1.0 ) then if ( incy == 1 ) then if ( beta == 0.0 ) then do i = 1, n y(i) = 0.0 end do else do i = 1, n y(i) = beta*y(i) end do END IF else iy = ky if ( beta == 0.0 ) then do i = 1, n y(iy) = 0.0 iy = iy + incy end do else do i = 1, n y(iy) = beta*y(iy) iy = iy + incy end do END IF END IF END IF if ( alpha == 0.0 ) then return END IF if ( lsame ( uplo, 'U' ) ) then ! ! form y when upper triangle of a is stored. ! kplus1 = k + 1 if ( ( incx == 1 ).and.( incy== 1 ) ) then do j = 1, n temp1 = alpha * x(j) temp2 = 0.0 l = kplus1 - j do i = max ( 1, j - k ), j - 1 y(i) = y(i) + temp1 * a( l + i,j) temp2 = temp2 + a( l + i,j) * x(i) end do y(j) = y(j) + temp1 * a( kplus1,j) + alpha * temp2 end do else jx = kx jy = ky do j = 1, n temp1 = alpha * x(jx) temp2 = 0.0 ix = kx iy = ky l = kplus1 - j do i = max ( 1, j - k ), j - 1 y(iy) = y(iy) + temp1 * a( l + i,j) temp2 = temp2 + a( l + i,j) * x(ix) ix = ix + incx iy = iy + incy end do y(jy) = y(jy) + temp1 * a( kplus1,j) + alpha * temp2 jx = jx + incx jy = jy + incy if ( j>k ) then kx = kx + incx ky = ky + incy END IF end do END IF else ! ! form y when lower triangle of a is stored. ! if ( ( incx == 1 ).and.( incy== 1 ) ) then do j = 1, n temp1 = alpha * x(j) temp2 = 0.0 y(j) = y(j) + temp1 * a( 1,j) l = 1 - j do i = j + 1, min ( n, j + k ) y(i) = y(i) + temp1 * a( l + i,j) temp2 = temp2 + a( l + i,j) * x(i) end do y(j) = y(j) + alpha * temp2 end do else jx = kx jy = ky do j = 1, n temp1 = alpha * x(jx) temp2 = 0.0 y(jy) = y(jy) + temp1 * a( 1,j) l = 1 - j ix = jx iy = jy do i = j + 1, min ( n, j + k ) ix = ix + incx iy = iy + incy y(iy) = y(iy) + temp1 * a( l + i,j) temp2 = temp2 + a( l + i,j) * x(ix) end do y(jy) = y(jy) + alpha * temp2 jx = jx + incx jy = jy + incy end do END IF END IF return end subroutine sscal ( n, sa, x, incx ) ! !******************************************************************************* ! !! SSCAL scales a vector by a constant. ! ! ! Modified: ! ! 08 April 1999 ! ! Reference: ! ! Lawson, Hanson, Kincaid, Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real SA, the multiplier. ! ! Input/output, real X(*), the vector to be scaled. ! ! Input, integer INCX, the increment between successive entries of X. ! implicit none ! integer i integer incx integer ix integer m integer n real sa real x(*) ! if ( n <= 0 ) then else if ( incx == 1 ) then m = mod ( n, 5 ) x(1:m) = sa * x(1:m) do i = m+1, n, 5 x(i) = sa * x(i) x(i+1) = sa * x(i+1) x(i+2) = sa * x(i+2) x(i+3) = sa * x(i+3) x(i+4) = sa * x(i+4) end do else if ( incx >= 0 ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 END IF do i = 1, n x(ix) = sa * x(ix) ix = ix + incx end do END IF return end subroutine sspmv ( uplo, n, alpha, ap, x, incx, beta, y, incy ) ! !******************************************************************************* ! !! SSPMV performs the matrix-vector operation y := alpha * A * x + beta*y, ! ! where alpha and beta are scalars, x and y are n element vectors and ! a is an n by n symmetric matrix, supplied in packed form. ! ! Author: ! ! Jack Dongarra, Argonne National Lab. ! Jeremy du Croz, NAG Central Office. ! Sven Hammarling, NAG Central Office. ! Richard Hanson, Sandia National Labs. ! ! Parameters: ! ! uplo - character. ! on entry, uplo specifies whether the upper or lower ! triangular part of the matrix a is supplied in the packed ! array ap as follows: ! ! uplo = 'U' or 'U' the upper triangular part of a is ! supplied in ap. ! ! uplo = 'L' or 'L' the lower triangular part of a is ! supplied in ap. ! ! unchanged on exit. ! ! n - integer. ! on entry, n specifies the order of the matrix a. ! n must be at least 0. ! unchanged on exit. ! ! alpha - real . ! on entry, alpha specifies the scalar alpha. ! unchanged on exit. ! ! ap - real array of dimension at least ! ( ( n*( n + 1 ) )/2 ). ! before entry with uplo = 'U' or 'U', the array ap must ! contain the upper triangular part of the symmetric matrix ! packed sequentially, column by column, so that ap( 1 ) ! contains a( 1, 1 ), ap( 2 ) and ap( 3 ) contain a( 1, 2 ) ! and a( 2, 2 ) respectively, and so on. ! before entry with uplo = 'L' or 'L', the array ap must ! contain the lower triangular part of the symmetric matrix ! packed sequentially, column by column, so that ap( 1 ) ! contains a( 1, 1 ), ap( 2 ) and ap( 3 ) contain a( 2, 1 ) ! and a( 3, 1 ) respectively, and so on. ! unchanged on exit. ! ! x - real array of dimension at least ! ( 1 + ( n - 1 ) * abs( incx ) ). ! before entry, the incremented array x must contain the n ! element vector x. ! unchanged on exit. ! ! incx - integer. ! on entry, incx specifies the increment for the elements of ! x. incx must not be 0. ! unchanged on exit. ! ! beta - real . ! on entry, beta specifies the scalar beta. when beta is ! supplied as zero then y need not be set on input. ! unchanged on exit. ! ! y - real array of dimension at least ! ( 1 + ( n - 1 ) * abs( incy ) ). ! before entry, the incremented array y must contain the n ! element vector y. on exit, y is overwritten by the updated ! vector y. ! ! incy - integer. ! on entry, incy specifies the increment for the elements of ! y. incy must not be 0. ! unchanged on exit. ! implicit none ! real alpha, beta integer incx, incy, n character uplo ! .. array arguments .. real ap( * ), x( * ), y( * ) ! .. ! ! .. local scalars .. real temp1, temp2 integer i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! .. external functions .. logical lsame external lsame ! .. external subroutines .. external xerbla ! ! test the input parameters. ! info = 0 if ( .not.lsame ( uplo, 'U' ).and..not.lsame( uplo, 'L' )) then info = 1 else if ( n < 0 ) then info = 2 else if ( incx == 0 ) then info = 6 else if ( incy == 0 ) then info = 9 END IF if ( info /= 0 ) then call xerbla ( 'sspmv ', info ) return END IF ! ! Quick returns. ! if ( n == 0 .or. ( ( alpha== 0.0 ).and.( beta== 1.0 ) ) ) then return END IF ! ! Set up the start points in X and Y. ! if ( incx > 0 ) then kx = 1 else kx = 1 - ( n - 1 ) * incx END IF if ( incy > 0 ) then ky = 1 else ky = 1 - ( n - 1 ) * incy END IF ! ! Start the operations. in this version the elements of the array ap ! are accessed sequentially with one pass through ap. ! ! First form y := beta*y. ! if ( beta /= 1.0 ) then if ( incy == 1 ) then if ( beta == 0.0 ) then do i = 1, n y(i) = 0.0 end do else do i = 1, n y(i) = beta * y(i) end do END IF else iy = ky if ( beta == 0.0 ) then do i = 1, n y(iy) = 0.0 iy = iy + incy end do else do i = 1, n y(iy) = beta * y(iy) iy = iy + incy end do END IF END IF END IF if ( alpha == 0.0 ) then return END IF kk = 1 if ( lsame ( uplo, 'U' ) ) then ! ! form y when ap contains the upper triangle. ! if ( ( incx == 1 ).and.( incy== 1 ) ) then do j = 1, n temp1 = alpha * x(j) temp2 = 0.0 k = kk do i = 1, j - 1 y(i) = y(i) + temp1 * ap(k) temp2 = temp2 + ap(k) * x(i) k = k + 1 end do y(j) = y(j) + temp1 * ap( kk + j - 1 ) + alpha * temp2 kk = kk + j end do else jx = kx jy = ky do j = 1, n temp1 = alpha * x(jx) temp2 = 0.0 ix = kx iy = ky do k = kk, kk + j - 2 y(iy) = y(iy) + temp1 * ap(k) temp2 = temp2 + ap(k) * x(ix) ix = ix + incx iy = iy + incy end do y(jy) = y(jy) + temp1 * ap( kk + j - 1 ) + alpha * temp2 jx = jx + incx jy = jy + incy kk = kk + j end do END IF else ! ! form y when ap contains the lower triangle. ! if ( ( incx == 1 ).and.( incy== 1 ) ) then do j = 1, n temp1 = alpha * x(j) temp2 = 0.0 y(j) = y(j) + temp1 * ap(kk) k = kk + 1 do i = j + 1, n y(i) = y(i) + temp1 * ap(k) temp2 = temp2 + ap(k) * x(i) k = k + 1 end do y(j) = y(j) + alpha * temp2 kk = kk + ( n - j + 1 ) end do else jx = kx jy = ky do j = 1, n temp1 = alpha * x(jx) temp2 = 0.0 y(jy) = y(jy) + temp1 * ap(kk) ix = jx iy = jy do k = kk + 1, kk + n - j ix = ix + incx iy = iy + incy y(iy) = y(iy) + temp1 * ap(k) temp2 = temp2 + ap(k) * x(ix) end do y(jy) = y(jy) + alpha * temp2 jx = jx + incx jy = jy + incy kk = kk + ( n - j + 1 ) end do END IF END IF return end subroutine sspr ( uplo, n, alpha, x, incx, ap ) ! !******************************************************************************* ! !! SSPR performs the symmetric rank 1 operation A := A + alpha * x*x'. ! ! ! Discussion: ! ! ALPHA is a real scalar, X is an N element vector and A is an ! N by N symmetric matrix, supplied in packed form. ! ! Author: ! ! Jack Dongarra, Argonne National Lab. ! Jeremy du Croz, NAG Central Office. ! Sven Hammarling, NAG Central Office. ! Richard Hanson, Sandia National Labs. ! ! Parameters: ! ! uplo - character. ! on entry, uplo specifies whether the upper or lower ! triangular part of the matrix a is supplied in the packed ! array ap as follows: ! ! uplo = 'U' or 'U' the upper triangular part of a is ! supplied in ap. ! ! uplo = 'L' or 'L' the lower triangular part of a is ! supplied in ap. ! ! unchanged on exit. ! ! n - integer. ! on entry, n specifies the order of the matrix a. ! n must be at least 0. ! unchanged on exit. ! ! alpha - real . ! on entry, alpha specifies the scalar alpha. ! unchanged on exit. ! ! x - real array of dimension at least ! ( 1 + ( n - 1 ) * abs( incx ) ). ! before entry, the incremented array x must contain the n ! element vector x. ! unchanged on exit. ! ! incx - integer. ! on entry, incx specifies the increment for the elements of ! x. incx must not be 0. ! unchanged on exit. ! ! ap - real array of dimension at least ! ( ( n*( n + 1 ) )/2 ). ! before entry with uplo = 'U' or 'U', the array ap must ! contain the upper triangular part of the symmetric matrix ! packed sequentially, column by column, so that ap( 1 ) ! contains a( 1, 1 ), ap( 2 ) and ap( 3 ) contain a( 1, 2 ) ! and a( 2, 2 ) respectively, and so on. on exit, the array ! ap is overwritten by the upper triangular part of the ! updated matrix. ! before entry with uplo = 'L' or 'L', the array ap must ! contain the lower triangular part of the symmetric matrix ! packed sequentially, column by column, so that ap( 1 ) ! contains a( 1, 1 ), ap( 2 ) and ap( 3 ) contain a( 2, 1 ) ! and a( 3, 1 ) respectively, and so on. on exit, the array ! ap is overwritten by the lower triangular part of the ! updated matrix. ! ! implicit none ! real alpha integer incx, n character uplo ! .. array arguments .. real ap( * ), x( * ) ! .. ! ! .. local scalars .. real temp integer i, info, ix, j, jx, k, kk, kx ! .. external functions .. logical lsame external lsame ! .. external subroutines .. external xerbla ! ! test the input parameters. ! info = 0 if ( .not.lsame ( uplo, 'U' ).and..not.lsame( uplo, 'L' ) ) then info = 1 else if ( n < 0 ) then info = 2 else if ( incx == 0 ) then info = 5 END IF if ( info /= 0 ) then call xerbla ( 'sspr ', info ) return END IF ! ! Quick return if possible. ! if ( ( n == 0 ).or.( alpha== 0.0 ) ) then return END IF ! ! Set the start point in x if the increment is not unity. ! if ( incx <= 0 ) then kx = 1 - ( n - 1 ) * incx else if ( incx /= 1 ) then kx = 1 END IF ! ! Start the operations. in this version the elements of the array ap ! are accessed sequentially with one pass through ap. ! kk = 1 if ( lsame ( uplo, 'U' ) ) then ! ! Form A when upper triangle is stored in ap. ! if ( incx == 1 ) then do j = 1, n if ( x(j) /= 0.0 ) then temp = alpha * x(j) k = kk do i = 1, j ap(k) = ap( k ) + x(i) * temp k = k + 1 end do END IF kk = kk + j end do else jx = kx do j = 1, n if ( x(jx) /= 0.0 ) then temp = alpha * x(jx) ix = kx do k = kk, kk + j - 1 ap(k) = ap( k ) + x(ix) * temp ix = ix + incx end do END IF jx = jx + incx kk = kk + j end do END IF else ! ! Form a when lower triangle is stored in ap. ! if ( incx == 1 ) then do j = 1, n if ( x(j) /= 0.0 ) then temp = alpha * x(j) k = kk do i = j, n ap(k) = ap( k ) + x(i) * temp k = k + 1 end do END IF kk = kk + n - j + 1 end do else jx = kx do j = 1, n if ( x(jx) /= 0.0 ) then temp = alpha * x(jx) ix = jx do k = kk, kk + n - j ap(k) = ap( k ) + x(ix) * temp ix = ix + incx end do END IF jx = jx + incx kk = kk + n - j + 1 end do END IF END IF return end subroutine sspr2 ( uplo, n, alpha, x, incx, y, incy, ap ) ! !******************************************************************************* ! !! SSPR2 performs the symmetric rank 2 operation A := A + alpha * x*y' + alpha * y*x', ! ! where alpha is a scalar, x and y are n element vectors and a is an ! n by n symmetric matrix, supplied in packed form. ! ! ! Author: ! ! Jack Dongarra, Argonne National Lab. ! Jeremy du Croz, NAG Central Office. ! Sven Hammarling, NAG Central Office. ! Richard Hanson, Sandia National Labs. ! ! Parameters: ! ! uplo - character. ! on entry, uplo specifies whether the upper or lower ! triangular part of the matrix a is supplied in the packed ! array ap as follows: ! ! uplo = 'U' or 'U' the upper triangular part of a is ! supplied in ap. ! ! uplo = 'L' or 'L' the lower triangular part of a is ! supplied in ap. ! ! unchanged on exit. ! ! n - integer. ! on entry, n specifies the order of the matrix a. ! n must be at least 0. ! unchanged on exit. ! ! alpha - real . ! on entry, alpha specifies the scalar alpha. ! unchanged on exit. ! ! x - real array of dimension at least ! ( 1 + ( n - 1 ) * abs( incx ) ). ! before entry, the incremented array x must contain the n ! element vector x. ! unchanged on exit. ! ! incx - integer. ! on entry, incx specifies the increment for the elements of ! x. incx must not be 0. ! unchanged on exit. ! ! y - real array of dimension at least ! ( 1 + ( n - 1 ) * abs( incy ) ). ! before entry, the incremented array y must contain the n ! element vector y. ! unchanged on exit. ! ! incy - integer. ! on entry, incy specifies the increment for the elements of ! y. incy must not be 0. ! unchanged on exit. ! ! ap - real array of dimension at least ! ( ( n*( n + 1 ) )/2 ). ! before entry with uplo = 'U' or 'U', the array ap must ! contain the upper triangular part of the symmetric matrix ! packed sequentially, column by column, so that ap( 1 ) ! contains a( 1, 1 ), ap( 2 ) and ap( 3 ) contain a( 1, 2 ) ! and a( 2, 2 ) respectively, and so on. on exit, the array ! ap is overwritten by the upper triangular part of the ! updated matrix. ! before entry with uplo = 'L' or 'L', the array ap must ! contain the lower triangular part of the symmetric matrix ! packed sequentially, column by column, so that ap( 1 ) ! contains a( 1, 1 ), ap( 2 ) and ap( 3 ) contain a( 2, 1 ) ! and a( 3, 1 ) respectively, and so on. on exit, the array ! ap is overwritten by the lower triangular part of the ! updated matrix. ! implicit none ! real alpha integer incx, incy, n character uplo ! .. array arguments .. real ap( * ), x( * ), y( * ) real temp1, temp2 integer i, info, ix, iy, j, jx, jy, k, kk, kx, ky ! .. external functions .. logical lsame external lsame ! .. external subroutines .. external xerbla ! ! Test the input parameters. ! info = 0 if ( .not.lsame ( uplo, 'U' ).and. & .not.lsame ( uplo, 'L' ) ) then info = 1 else if ( n < 0 ) then info = 2 else if ( incx == 0 ) then info = 5 else if ( incy == 0 ) then info = 7 END IF if ( info /= 0 ) then call xerbla ( 'sspr2 ', info ) return END IF ! ! Quick return if possible. ! if ( ( n == 0 ).or.( alpha== 0.0 ) ) then return END IF ! ! Set up the start points in x and y if the increments are not both ! unity. ! if ( ( incx /= 1 ).or.( incy/=1 ) ) then if ( incx>0 ) then kx = 1 else kx = 1 - ( n - 1 ) * incx END IF if ( incy>0 ) then ky = 1 else ky = 1 - ( n - 1 ) * incy END IF jx = kx jy = ky END IF ! ! Start the operations. in this version the elements of the array ap ! are accessed sequentially with one pass through ap. ! kk = 1 if ( lsame ( uplo, 'U' ) ) then ! ! Form a when upper triangle is stored in ap. ! if ( ( incx == 1 ).and.( incy== 1 ) ) then do j = 1, n if ( ( x(j) /= 0.0 ).or.( y(j)/=0.0 ) ) then temp1 = alpha * y(j) temp2 = alpha * x(j) k = kk do i = 1, j ap(k) = ap( k ) + x(i) * temp1 + y(i) * temp2 k = k + 1 end do END IF kk = kk + j end do else do j = 1, n if ( ( x(jx) /= 0.0 ).or.( y(jy)/=0.0 ) ) then temp1 = alpha * y(jy) temp2 = alpha * x(jx) ix = kx iy = ky do k = kk, kk + j - 1 ap(k) = ap( k ) + x(ix) * temp1 + y(iy) * temp2 ix = ix + incx iy = iy + incy end do END IF jx = jx + incx jy = jy + incy kk = kk + j end do END IF else ! ! Form a when lower triangle is stored in ap. ! if ( ( incx == 1 ).and.( incy== 1 ) ) then do j = 1, n if ( ( x(j) /= 0.0 ).or.( y(j)/= 0.0 ) ) then temp1 = alpha * y(j) temp2 = alpha * x(j) k = kk do i = j, n ap(k) = ap( k ) + x(i) * temp1 + y(i) * temp2 k = k + 1 end do END IF kk = kk + n - j + 1 end do else do j = 1, n if ( ( x(jx) /= 0.0 ).or.( y(jy)/= 0.0 ) ) then temp1 = alpha * y(jy) temp2 = alpha * x(jx) ix = jx iy = jy do k = kk, kk + n - j ap(k) = ap( k ) + x(ix) * temp1 + y(iy) * temp2 ix = ix + incx iy = iy + incy end do END IF jx = jx + incx jy = jy + incy kk = kk + n - j + 1 end do END IF END IF return end subroutine sswap ( n, x, incx, y, incy ) ! !******************************************************************************* ! !! SSWAP interchanges two vectors. ! ! ! Modified: ! ! 08 April 1999 ! ! Reference: ! ! Lawson, Hanson, Kincaid, Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vectors. ! ! Input/output, real X(*), one of the vectors to swap. ! ! Input, integer INCX, the increment between successive entries of X. ! ! Input/output, real Y(*), one of the vectors to swap. ! ! Input, integer INCY, the increment between successive elements of Y. ! implicit none ! integer i integer incx integer incy integer ix integer iy integer m integer n real temp real x(*) real y(*) ! if ( n <= 0 ) then else if ( incx == 1 .and. incy == 1 ) then m = mod ( n, 3 ) do i = 1, m temp = x(i) x(i) = y(i) y(i) = temp end do do i = m+1, n, 3 temp = x(i) x(i) = y(i) y(i) = temp temp = x(i+1) x(i+1) = y(i+1) y(i+1) = temp temp = x(i+2) x(i+2) = y(i+2) y(i+2) = temp end do else if ( incx >= 0 ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 END IF if ( incy >= 0 ) then iy = 1 else iy = ( - n + 1 ) * incy + 1 END IF do i = 1, n temp = x(ix) x(ix) = y(iy) y(iy) = temp ix = ix + incx iy = iy + incy end do END IF return end subroutine ssymm ( side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc ) ! !******************************************************************************* ! !! SSYMM performs one of the matrix-matrix operations ! ! C := alpha*A*B + beta*C, ! ! or ! ! C := alpha*B*A + beta*C, ! ! where alpha and beta are scalars, A is a symmetric matrix and B and ! C are M by N matrices. ! ! ! Author: ! ! Jack Dongarra, Argonne National Laboratory. ! Iain Duff, AERE Harwell. ! Jeremy du Croz, Numerical Algorithms Group LTD. ! Sven Hammarling, Numerical Algorithms Group LTD. ! ! Parameters: ! ! side - character. ! on entry, side specifies whether the symmetric matrix a ! appears on the left or right in the operation as follows: ! ! side = 'l' or 'L' c := alpha*a*b + beta*c, ! ! side = 'r' or 'R' c := alpha*b*a + beta*c, ! ! unchanged on exit. ! ! uplo - character. ! on entry, uplo specifies whether the upper or lower ! triangular part of the symmetric matrix a is to be ! referenced as follows: ! ! uplo = 'u' or 'U' only the upper triangular part of the ! symmetric matrix is to be referenced. ! ! uplo = 'l' or 'L' only the lower triangular part of the ! symmetric matrix is to be referenced. ! ! unchanged on exit. ! ! m - integer. ! on entry, m specifies the number of rows of the matrix c. ! m must be at least 0. ! unchanged on exit. ! ! n - integer. ! on entry, n specifies the number of columns of the matrix c. ! n must be at least 0. ! unchanged on exit. ! ! alpha - real . ! on entry, alpha specifies the scalar alpha. ! unchanged on exit. ! ! a - real array of dimension ( lda, ka ), where ka is ! m when side = 'l' or 'L' and is n otherwise. ! before entry with side = 'l' or 'L', the m by m part of ! the array a must contain the symmetric matrix, such that ! when uplo = 'u' or 'U', the leading m by m upper triangular ! part of the array a must contain the upper triangular part ! of the symmetric matrix and the strictly lower triangular ! part of a is not referenced, and when uplo = 'l' or 'L', ! the leading m by m lower triangular part of the array a ! must contain the lower triangular part of the symmetric ! matrix and the strictly upper triangular part of a is not ! referenced. ! before entry with side = 'r' or 'R', the n by n part of ! the array a must contain the symmetric matrix, such that ! when uplo = 'u' or 'U', the leading n by n upper triangular ! part of the array a must contain the upper triangular part ! of the symmetric matrix and the strictly lower triangular ! part of a is not referenced, and when uplo = 'l' or 'L', ! the leading n by n lower triangular part of the array a ! must contain the lower triangular part of the symmetric ! matrix and the strictly upper triangular part of a is not ! referenced. ! unchanged on exit. ! ! lda - integer. ! on entry, lda specifies the first dimension of a as declared ! in the calling (sub) program. when side = 'l' or 'L' then ! lda must be at least max( 1, m ), otherwise lda must be at ! least max( 1, n ). ! unchanged on exit. ! ! b - real array of dimension ( ldb, n ). ! before entry, the leading m by n part of the array b must ! contain the matrix b. ! unchanged on exit. ! ! ldb - integer. ! on entry, ldb specifies the first dimension of b as declared ! in the calling (sub) program. ldb must be at least ! max( 1, m ). ! unchanged on exit. ! ! beta - real . ! on entry, beta specifies the scalar beta. when beta is ! supplied as 0.0 then c need not be set on input. ! unchanged on exit. ! ! c - real array of dimension ( ldc, n ). ! before entry, the leading m by n part of the array c must ! contain the matrix c, except when beta is 0.0, in which ! case c need not be set on entry. ! on exit, the array c is overwritten by the m by n updated ! matrix. ! ! ldc - integer. ! on entry, ldc specifies the first dimension of c as declared ! in the calling (sub) program. ldc must be at least ! max( 1, m ). ! unchanged on exit. ! implicit none ! character side, uplo integer m, n, lda, ldb, ldc real alpha, beta ! .. array arguments .. real a( lda, * ), b( ldb, * ), c( ldc, * ) ! .. ! ! .. external functions .. logical lsame external lsame ! .. external subroutines .. external xerbla ! .. local scalars .. logical upper integer i, info, j, k, nrowa real temp1, temp2 ! ! Set nrowa as the number of rows of a. ! if ( lsame( side, 'L' ) ) then nrowa = m else nrowa = n END IF upper = lsame( uplo, 'U' ) ! ! Test the input parameters. ! info = 0 if ( ( .not.lsame( side, 'L' ) ).and. & ( .not.lsame( side, 'R' ) ) ) then info = 1 else if ( ( .not.upper ).and. & ( .not.lsame( uplo, 'L' ) ) ) then info = 2 else if ( m <0 ) then info = 3 else if ( n <0 ) then info = 4 else if ( lda0 ) then kx = 1 else kx = 1 - ( n - 1 ) * incx END IF if ( incy>0 ) then ky = 1 else ky = 1 - ( n - 1 ) * incy END IF ! ! Start the operations. in this version the elements of a are ! accessed sequentially with one pass through the triangular part ! of a. ! ! first form y := beta*y. ! if ( beta /= 1.0 ) then if ( incy == 1 ) then if ( beta == 0.0 ) then do i = 1, n y(i) = 0.0 end do else do i = 1, n y(i) = beta*y(i) end do END IF else iy = ky if ( beta == 0.0 ) then do i = 1, n y(iy) = 0.0 iy = iy + incy end do else do i = 1, n y(iy) = beta*y(iy) iy = iy + incy end do END IF END IF END IF if ( alpha == 0.0 ) then return END IF if ( lsame ( uplo, 'U' ) ) then ! ! Form y when a is stored in upper triangle. ! if ( ( incx == 1 ).and.( incy== 1 ) ) then do j = 1, n temp1 = alpha * x(j) temp2 = 0.0 do i = 1, j - 1 y(i) = y(i) + temp1 * a(i,j) temp2 = temp2 + a(i,j) * x(i) end do y(j) = y(j) + temp1 * a(j,j) + alpha * temp2 end do else jx = kx jy = ky do j = 1, n temp1 = alpha * x(jx) temp2 = 0.0 ix = kx iy = ky do i = 1, j - 1 y(iy) = y(iy) + temp1 * a(i,j) temp2 = temp2 + a(i,j) * x(ix) ix = ix + incx iy = iy + incy end do y(jy) = y(jy) + temp1 * a(j,j) + alpha * temp2 jx = jx + incx jy = jy + incy end do END IF else ! ! Form y when a is stored in lower triangle. ! if ( ( incx == 1 ).and.( incy== 1 ) ) then do j = 1, n temp1 = alpha * x(j) temp2 = 0.0 y(j) = y(j) + temp1 * a(j,j) do i = j + 1, n y(i) = y(i) + temp1 * a(i,j) temp2 = temp2 + a(i,j) * x(i) end do y(j) = y(j) + alpha * temp2 end do else jx = kx jy = ky do j = 1, n temp1 = alpha * x(jx) temp2 = 0.0 y(jy) = y(jy) + temp1 * a(j,j) ix = jx iy = jy do i = j + 1, n ix = ix + incx iy = iy + incy y(iy) = y(iy) + temp1 * a(i,j) temp2 = temp2 + a(i,j) * x(ix) end do y(jy) = y(jy) + alpha * temp2 jx = jx + incx jy = jy + incy end do END IF END IF return end subroutine ssyr ( uplo, n, alpha, x, incx, a, lda ) ! !******************************************************************************* ! !! SSYR performs the symmetric rank 1 operation A := A + alpha * x*x', ! ! where alpha is a real scalar, x is an n element vector and a is an ! n by n symmetric matrix. ! ! ! Author: ! ! Jack Dongarra, Argonne National Lab. ! Jeremy du Croz, NAG Central Office. ! Sven Hammarling, NAG Central Office. ! Richard Hanson, Sandia National Labs. ! ! Parameters: ! ! uplo - character. ! on entry, uplo specifies whether the upper or lower ! triangular part of the array a is to be referenced as ! follows: ! ! uplo = 'U' or 'U' only the upper triangular part of a ! is to be referenced. ! ! uplo = 'L' or 'L' only the lower triangular part of a ! is to be referenced. ! ! unchanged on exit. ! ! n - integer. ! on entry, n specifies the order of the matrix a. ! n must be at least 0. ! unchanged on exit. ! ! alpha - real . ! on entry, alpha specifies the scalar alpha. ! unchanged on exit. ! ! x - real array of dimension at least ! ( 1 + ( n - 1 ) * abs( incx ) ). ! before entry, the incremented array x must contain the n ! element vector x. ! unchanged on exit. ! ! incx - integer. ! on entry, incx specifies the increment for the elements of ! x. incx must not be 0. ! unchanged on exit. ! ! a - real array of dimension ( lda, n ). ! before entry with uplo = 'U' or 'U', the leading n by n ! upper triangular part of the array a must contain the upper ! triangular part of the symmetric matrix and the strictly ! lower triangular part of a is not referenced. on exit, the ! upper triangular part of the array a is overwritten by the ! upper triangular part of the updated matrix. ! before entry with uplo = 'L' or 'L', the leading n by n ! lower triangular part of the array a must contain the lower ! triangular part of the symmetric matrix and the strictly ! upper triangular part of a is not referenced. on exit, the ! lower triangular part of the array a is overwritten by the ! lower triangular part of the updated matrix. ! ! lda - integer. ! on entry, lda specifies the first dimension of a as declared ! in the calling (sub) program. lda must be at least ! max ( 1, n ). ! unchanged on exit. ! implicit none ! real alpha integer incx, lda, n character uplo ! .. array arguments .. real a( lda, * ), x( * ) ! .. ! ! .. parameters .. ! .. local scalars .. real temp integer i, info, ix, j, jx, kx ! .. external functions .. logical lsame external lsame ! .. external subroutines .. external xerbla ! ! test the input parameters. ! info = 0 if ( .not.lsame ( uplo, 'U' ).and. & .not.lsame ( uplo, 'L' ) ) then info = 1 else if ( n < 0 ) then info = 2 else if ( incx == 0 ) then info = 5 else if ( lda < max ( 1, n ) ) then info = 7 END IF if ( info /= 0 ) then call xerbla ( 'ssyr ', info ) return END IF ! ! Quick return if possible. ! if ( ( n == 0 ).or.( alpha== 0.0 ) ) then return END IF ! ! Set the start point in x if the increment is not unity. ! if ( incx <= 0 ) then kx = 1 - ( n - 1 ) * incx else if ( incx /= 1 ) then kx = 1 END IF ! ! Start the operations. in this version the elements of a are ! accessed sequentially with one pass through the triangular part ! of a. ! if ( lsame ( uplo, 'U' ) ) then ! ! Form a when a is stored in upper triangle. ! if ( incx == 1 ) then do j = 1, n if ( x(j) /= 0.0 ) then temp = alpha * x(j) do i = 1, j a(i,j) = a(i,j) + x(i) * temp end do END IF end do else jx = kx do j = 1, n if ( x(jx) /= 0.0 ) then temp = alpha * x(jx) ix = kx do i = 1, j a(i,j) = a(i,j) + x(ix) * temp ix = ix + incx end do END IF jx = jx + incx end do END IF else ! ! Form a when a is stored in lower triangle. ! if ( incx == 1 ) then do j = 1, n if ( x(j) /= 0.0 ) then temp = alpha * x(j) do i = j, n a(i,j) = a(i,j) + x(i) * temp end do END IF end do else jx = kx do j = 1, n if ( x(jx) /= 0.0 ) then temp = alpha * x(jx) ix = jx do i = j, n a(i,j) = a(i,j) + x(ix) * temp ix = ix + incx end do END IF jx = jx + incx end do END IF END IF return end subroutine ssyr2 ( uplo, n, alpha, x, incx, y, incy, a, lda ) ! !******************************************************************************* ! !! SSYR2 performs A := A + alpha * x*y' + alpha * y*x', ! ! where alpha is a scalar, x and y are n element vectors and a is an n ! by n symmetric matrix. ! ! ! Author: ! ! Jack Dongarra, Argonne National Lab. ! Jeremy du Croz, NAG Central Office. ! Sven Hammarling, NAG Central Office. ! Richard Hanson, Sandia National Labs. ! ! Parameters: ! ! uplo - character. ! on entry, uplo specifies whether the upper or lower ! triangular part of the array a is to be referenced as ! follows: ! ! uplo = 'U' or 'U' only the upper triangular part of a ! is to be referenced. ! ! uplo = 'L' or 'L' only the lower triangular part of a ! is to be referenced. ! ! unchanged on exit. ! ! n - integer. ! on entry, n specifies the order of the matrix a. ! n must be at least 0. ! unchanged on exit. ! ! alpha - real . ! on entry, alpha specifies the scalar alpha. ! unchanged on exit. ! ! x - real array of dimension at least ! ( 1 + ( n - 1 ) * abs( incx ) ). ! before entry, the incremented array x must contain the n ! element vector x. ! unchanged on exit. ! ! incx - integer. ! on entry, incx specifies the increment for the elements of ! x. incx must not be 0. ! unchanged on exit. ! ! y - real array of dimension at least ! ( 1 + ( n - 1 ) * abs( incy ) ). ! before entry, the incremented array y must contain the n ! element vector y. ! unchanged on exit. ! ! incy - integer. ! on entry, incy specifies the increment for the elements of ! y. incy must not be 0. ! unchanged on exit. ! ! a - real array of dimension ( lda, n ). ! before entry with uplo = 'U' or 'U', the leading n by n ! upper triangular part of the array a must contain the upper ! triangular part of the symmetric matrix and the strictly ! lower triangular part of a is not referenced. on exit, the ! upper triangular part of the array a is overwritten by the ! upper triangular part of the updated matrix. ! before entry with uplo = 'L' or 'L', the leading n by n ! lower triangular part of the array a must contain the lower ! triangular part of the symmetric matrix and the strictly ! upper triangular part of a is not referenced. on exit, the ! lower triangular part of the array a is overwritten by the ! lower triangular part of the updated matrix. ! ! lda - integer. ! on entry, lda specifies the first dimension of a as declared ! in the calling (sub) program. lda must be at least ! max ( 1, n ). ! unchanged on exit. ! implicit none ! real alpha integer incx, incy, lda, n character uplo ! .. array arguments .. real a( lda, * ), x( * ), y( * ) ! .. parameters .. ! .. local scalars .. real temp1, temp2 integer i, info, ix, iy, j, jx, jy, kx, ky ! .. external functions .. logical lsame external lsame ! .. external subroutines .. external xerbla ! ! test the input parameters. ! info = 0 if ( .not.lsame ( uplo, 'U' ).and. & .not.lsame ( uplo, 'L' ) ) then info = 1 else if ( n < 0 ) then info = 2 else if ( incx == 0 ) then info = 5 else if ( incy == 0 ) then info = 7 else if ( lda < max ( 1, n ) ) then info = 9 END IF if ( info /= 0 ) then call xerbla ( 'ssyr2 ', info ) return END IF ! ! Quick return if possible. ! if ( ( n == 0 ).or.( alpha== 0.0 ) ) then return END IF ! ! Set up the start points in x and y if the increments are not both ! unity. ! if ( ( incx /= 1 ).or.( incy/=1 ) ) then if ( incx>0 ) then kx = 1 else kx = 1 - ( n - 1 ) * incx END IF if ( incy>0 ) then ky = 1 else ky = 1 - ( n - 1 ) * incy END IF jx = kx jy = ky END IF ! ! Start the operations. in this version the elements of a are ! accessed sequentially with one pass through the triangular part ! of a. ! if ( lsame ( uplo, 'U' ) ) then ! ! Form a when a is stored in the upper triangle. ! if ( ( incx == 1 ).and.( incy== 1 ) ) then do j = 1, n if ( ( x(j) /= 0.0 ).or.( y(j)/= 0.0 ) ) then temp1 = alpha * y(j) temp2 = alpha * x(j) do i = 1, j a(i,j) = a(i,j) + x(i) * temp1 + y(i) * temp2 end do END IF end do else do j = 1, n if ( ( x(jx) /= 0.0 ).or.( y(jy)/= 0.0 ) ) then temp1 = alpha * y(jy) temp2 = alpha * x(jx) ix = kx iy = ky do i = 1, j a(i,j) = a(i,j) + x(ix) * temp1 + y(iy) * temp2 ix = ix + incx iy = iy + incy end do END IF jx = jx + incx jy = jy + incy end do END IF else ! ! Form a when a is stored in the lower triangle. ! if ( ( incx == 1 ).and.( incy== 1 ) ) then do j = 1, n if ( ( x(j) /= 0.0 ).or.( y(j)/= 0.0 ) ) then temp1 = alpha * y(j) temp2 = alpha * x(j) do i = j, n a(i,j) = a(i,j) + x(i) * temp1 + y(i) * temp2 end do END IF end do else do j = 1, n if ( ( x(jx) /= 0.0 ).or.( y(jy)/= 0.0 ) ) then temp1 = alpha * y(jy) temp2 = alpha * x(jx) ix = jx iy = jy do i = j, n a(i,j) = a(i,j) + x(ix) * temp1 + y(iy) * temp2 ix = ix + incx iy = iy + incy end do END IF jx = jx + incx jy = jy + incy end do END IF END IF return end subroutine ssyr2k ( uplo, trans, n, k, alpha, a, lda, b, ldb, beta, c, ldc ) ! !******************************************************************************* ! !! SSYR2K performs one of the symmetric rank 2k operations ! ! c := alpha*a*b' + alpha*b*a' + beta*c, ! ! or ! ! c := alpha*a'*b + alpha*b'*a + beta*c, ! ! where alpha and beta are scalars, c is an n by n symmetric matrix ! and a and b are n by k matrices in the first case and k by n ! matrices in the second case. ! ! ! Author: ! ! Jack Dongarra, Argonne National Laboratory. ! Iain Duff, AERE Harwell. ! Jeremy du Croz, Numerical Algorithms Group LTD. ! Sven Hammarling, Numerical Algorithms Group LTD. ! ! Parameters: ! ! uplo - character. ! on entry, uplo specifies whether the upper or lower ! triangular part of the array c is to be referenced as ! follows: ! ! uplo = 'u' or 'U' only the upper triangular part of c ! is to be referenced. ! ! uplo = 'l' or 'L' only the lower triangular part of c ! is to be referenced. ! ! unchanged on exit. ! ! trans - character. ! on entry, trans specifies the operation to be performed as ! follows: ! ! trans = 'n' or 'n' c := alpha*a*b' + alpha*b*a' + ! beta*c. ! ! trans = 't' or 't' c := alpha*a'*b + alpha*b'*a + ! beta*c. ! ! trans = 'c' or 'C' c := alpha*a'*b + alpha*b'*a + ! beta*c. ! ! unchanged on exit. ! ! n - integer. ! on entry, n specifies the order of the matrix c. n must be ! at least 0. ! unchanged on exit. ! ! k - integer. ! on entry with trans = 'n' or 'n', k specifies the number ! of columns of the matrices a and b, and on entry with ! trans = 't' or 't' or 'c' or 'C', k specifies the number ! of rows of the matrices a and b. k must be at least 0. ! unchanged on exit. ! ! alpha - real . ! on entry, alpha specifies the scalar alpha. ! unchanged on exit. ! ! a - real array of dimension ( lda, ka ), where ka is ! k when trans = 'n' or 'n', and is n otherwise. ! before entry with trans = 'n' or 'n', the leading n by k ! part of the array a must contain the matrix a, otherwise ! the leading k by n part of the array a must contain the ! matrix a. ! unchanged on exit. ! ! lda - integer. ! on entry, lda specifies the first dimension of a as declared ! in the calling (sub) program. when trans = 'n' or 'n' ! then lda must be at least max( 1, n ), otherwise lda must ! be at least max( 1, k ). ! unchanged on exit. ! ! b - real array of dimension ( ldb, kb ), where kb is ! k when trans = 'n' or 'n', and is n otherwise. ! before entry with trans = 'n' or 'n', the leading n by k ! part of the array b must contain the matrix b, otherwise ! the leading k by n part of the array b must contain the ! matrix b. ! unchanged on exit. ! ! ldb - integer. ! on entry, ldb specifies the first dimension of b as declared ! in the calling (sub) program. when trans = 'n' or 'n' ! then ldb must be at least max( 1, n ), otherwise ldb must ! be at least max( 1, k ). ! unchanged on exit. ! ! beta - real . ! on entry, beta specifies the scalar beta. ! unchanged on exit. ! ! c - real array of dimension ( ldc, n ). ! before entry with uplo = 'u' or 'U', the leading n by n ! upper triangular part of the array c must contain the upper ! triangular part of the symmetric matrix and the strictly ! lower triangular part of c is not referenced. on exit, the ! upper triangular part of the array c is overwritten by the ! upper triangular part of the updated matrix. ! before entry with uplo = 'l' or 'L', the leading n by n ! lower triangular part of the array c must contain the lower ! triangular part of the symmetric matrix and the strictly ! upper triangular part of c is not referenced. on exit, the ! lower triangular part of the array c is overwritten by the ! lower triangular part of the updated matrix. ! ! ldc - integer. ! on entry, ldc specifies the first dimension of c as declared ! in the calling (sub) program. ldc must be at least ! max( 1, n ). ! unchanged on exit. ! implicit none ! character uplo, trans integer n, k, lda, ldb, ldc real alpha, beta ! .. array arguments .. real a( lda, * ), b( ldb, * ), c( ldc, * ) ! .. ! ! .. external functions .. logical lsame external lsame ! .. external subroutines .. external xerbla ! .. local scalars .. logical upper integer i, info, j, l, nrowa real temp1, temp2 ! ! test the input parameters. ! if ( lsame( trans, 'N' ) ) then nrowa = n else nrowa = k END IF upper = lsame( uplo, 'U' ) info = 0 if ( ( .not.upper ).and. & ( .not.lsame( uplo , 'L' ) ) ) then info = 1 else if ( ( .not.lsame( trans, 'N' ) ).and. & ( .not.lsame( trans, 'T' ) ).and. & ( .not.lsame( trans, 'C' ) ) ) then info = 2 else if ( n <0 ) then info = 3 else if ( k <0 ) then info = 4 else if ( ldak ) then kx = kx + incx END IF end do END IF else if ( incx == 1 ) then do j = n, 1, -1 if ( x(j) /= 0.0 ) then temp = x(j) l = 1 - j do i = min ( n, j + k ), j + 1, -1 x(i) = x(i) + temp * a( l + i,j) end do if ( nounit ) then x(j) = x(j) * a( 1,j) END IF END IF end do else kx = kx + ( n - 1 ) * incx jx = kx do j = n, 1, -1 if ( x(jx) /= 0.0 ) then temp = x(jx) ix = kx l = 1 - j do i = min ( n, j + k ), j + 1, -1 x(ix) = x(ix) + temp * a( l + i,j) ix = ix - incx end do if ( nounit ) then x(jx) = x(jx) * a(1,j) END IF END IF jx = jx - incx if ( ( n - j ) >= k ) then kx = kx - incx END IF end do END IF END IF else ! ! Form x := a' * x. ! if ( lsame ( uplo, 'U' ) ) then kplus1 = k + 1 if ( incx == 1 ) then do j = n, 1, -1 temp = x(j) l = kplus1 - j if ( nounit ) then temp = temp * a( kplus1,j) END IF do i = j - 1, max ( 1, j - k ), -1 temp = temp + a( l + i,j) * x(i) end do x(j) = temp end do else kx = kx + ( n - 1 ) * incx jx = kx do j = n, 1, -1 temp = x(jx) kx = kx - incx ix = kx l = kplus1 - j if ( nounit ) then temp = temp * a( kplus1,j) END IF do i = j - 1, max ( 1, j - k ), -1 temp = temp + a( l + i,j) * x(ix) ix = ix - incx end do x(jx) = temp jx = jx - incx end do END IF else if ( incx == 1 ) then do j = 1, n temp = x(j) l = 1 - j if ( nounit ) then temp = temp * a( 1,j) END IF do i = j + 1, min ( n, j + k ) temp = temp + a( l + i,j) * x(i) end do x(j) = temp end do else jx = kx do j = 1, n temp = x(jx) kx = kx + incx ix = kx l = 1 - j if ( nounit ) then temp = temp * a( 1,j) END IF do i = j + 1, min ( n, j + k ) temp = temp + a( l + i,j) * x(ix) ix = ix + incx end do x(jx) = temp jx = jx + incx end do END IF END IF END IF return end subroutine stbsv ( uplo, trans, diag, n, k, a, lda, x, incx ) ! !******************************************************************************* ! !! STBSV solves A * x = b or A'*x = b, ! ! where b and x are n element vectors and a is an n by n unit, or ! non-unit, upper or lower triangular band matrix, with ( k + 1 ) ! diagonals. ! ! No test for singularity or near-singularity is included in this ! routine. Such tests must be performed before calling this routine. ! ! ! Author: ! ! Jack Dongarra, Argonne National Lab. ! Jeremy du Croz, NAG Central Office. ! Sven Hammarling, NAG Central Office. ! Richard Hanson, Sandia National Labs. ! ! Parameters: ! ! uplo - character. ! on entry, uplo specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! uplo = 'U' or 'U' a is an upper triangular matrix. ! ! uplo = 'L' or 'L' a is a lower triangular matrix. ! ! unchanged on exit. ! ! trans - character. ! on entry, trans specifies the equations to be solved as ! follows: ! ! trans = 'N' or 'N' a * x = b. ! ! trans = 'T' or 'T' a' * x = b. ! ! trans = 'C' or 'C' a' * x = b. ! ! unchanged on exit. ! ! diag - character. ! on entry, diag specifies whether or not a is unit ! triangular as follows: ! ! diag = 'U' or 'U' a is assumed to be unit triangular. ! ! diag = 'N' or 'N' a is not assumed to be unit ! triangular. ! ! unchanged on exit. ! ! n - integer. ! on entry, n specifies the order of the matrix a. ! n must be at least 0. ! unchanged on exit. ! ! k - integer. ! on entry with uplo = 'U' or 'U', k specifies the number of ! super-diagonals of the matrix a. ! on entry with uplo = 'L' or 'L', k specifies the number of ! sub-diagonals of the matrix a. ! k must satisfy 0 <= k. ! unchanged on exit. ! ! a - real array of dimension ( lda, n ). ! before entry with uplo = 'U' or 'U', the leading ( k + 1 ) ! by n part of the array a must contain the upper triangular ! band part of the matrix of coefficients, supplied column by ! column, with the leading diagonal of the matrix in row ! ( k + 1 ) of the array, the first super-diagonal starting at ! position 2 in row k, and so on. the top left k by k triangle ! of the array a is not referenced. ! the following program segment will transfer an upper ! triangular band matrix from conventional full matrix storage ! to band storage: ! ! do j = 1, n ! m = k + 1 - j ! do i = max ( 1, j - k ), j ! a( m + i,j) = matrix(i,j) ! end do ! end do ! ! before entry with uplo = 'L' or 'L', the leading ( k + 1 ) ! by n part of the array a must contain the lower triangular ! band part of the matrix of coefficients, supplied column by ! column, with the leading diagonal of the matrix in row 1 of ! the array, the first sub-diagonal starting at position 1 in ! row 2, and so on. the bottom right k by k triangle of the ! array a is not referenced. ! the following program segment will transfer a lower ! triangular band matrix from conventional full matrix storage ! to band storage: ! ! do j = 1, n ! m = 1 - j ! do i = j, min ( n, j + k ) ! a( m + i,j) = matrix(i,j) ! end do ! end do ! ! note that when diag = 'U' or 'U' the elements of the array a ! corresponding to the diagonal elements of the matrix are not ! referenced, but are assumed to be unity. ! unchanged on exit. ! ! lda - integer. ! on entry, lda specifies the first dimension of a as declared ! in the calling (sub) program. lda must be at least ! ( k + 1 ). ! unchanged on exit. ! ! x - real array of dimension at least ! ( 1 + ( n - 1 ) * abs( incx ) ). ! before entry, the incremented array x must contain the n ! element right-hand side vector b. on exit, x is overwritten ! with the solution vector x. ! ! incx - integer. ! on entry, incx specifies the increment for the elements of ! x. incx must not be 0. ! unchanged on exit. ! implicit none ! integer incx, k, lda, n character diag, trans, uplo ! .. array arguments .. real a( lda, * ), x( * ) ! .. ! ! .. parameters .. ! .. local scalars .. real temp integer i, info, ix, j, jx, kplus1, kx, l logical nounit ! .. external functions .. logical lsame external lsame ! .. external subroutines .. external xerbla ! ! test the input parameters. ! info = 0 if ( .not.lsame ( uplo , 'U' ).and. & .not.lsame ( uplo , 'L' ) ) then info = 1 else if ( .not.lsame ( trans, 'N' ).and. & .not.lsame ( trans, 'T' ).and. & .not.lsame ( trans, 'C' ) ) then info = 2 else if ( .not.lsame ( diag , 'U' ).and. & .not.lsame ( diag , 'N' ) ) then info = 3 else if ( n < 0 ) then info = 4 else if ( k < 0 ) then info = 5 else if ( lda < ( k + 1 ) ) then info = 7 else if ( incx == 0 ) then info = 9 END IF if ( info /= 0 ) then call xerbla ( 'stbsv ', info ) return END IF ! ! Quick return if possible. ! if ( n == 0 ) then return END IF nounit = lsame ( diag, 'N' ) ! ! Set up the start point in x if the increment is not unity. this ! will be ( n - 1 ) * incx too small for descending loops. ! if ( incx <= 0 ) then kx = 1 - ( n - 1 ) * incx else if ( incx /= 1 ) then kx = 1 END IF ! ! Start the operations. in this version the elements of a are ! accessed by sequentially with one pass through a. ! if ( lsame ( trans, 'N' ) ) then ! ! Form x := inv( a ) * x. ! if ( lsame ( uplo, 'U' ) ) then kplus1 = k + 1 if ( incx == 1 ) then do j = n, 1, -1 if ( x(j) /= 0.0 ) then l = kplus1 - j if ( nounit ) then x(j) = x(j) / a(kplus1,j) END IF temp = x(j) do i = j - 1, max ( 1, j - k ), -1 x(i) = x(i) - temp * a(l+i,j) end do END IF end do else kx = kx + ( n - 1 ) * incx jx = kx do j = n, 1, -1 kx = kx - incx if ( x(jx) /= 0.0 ) then ix = kx l = kplus1 - j if ( nounit ) then x(jx) = x(jx) / a(kplus1,j) END IF temp = x(jx) do i = j - 1, max ( 1, j - k ), -1 x(ix) = x(ix) - temp * a(l+i,j) ix = ix - incx end do END IF jx = jx - incx end do END IF else if ( incx == 1 ) then do j = 1, n if ( x(j) /= 0.0 ) then l = 1 - j if ( nounit ) then x(j) = x(j) / a(1,j) END IF temp = x(j) do i = j + 1, min ( n, j + k ) x(i) = x(i) - temp * a(l+i,j) end do END IF end do else jx = kx do j = 1, n kx = kx + incx if ( x(jx) /= 0.0 ) then ix = kx l = 1 - j if ( nounit ) then x(jx) = x(jx) / a( 1,j) END IF temp = x(jx) do i = j + 1, min ( n, j + k ) x(ix) = x(ix) - temp * a( l + i,j) ix = ix + incx end do END IF jx = jx + incx end do END IF END IF else ! ! Form x := inv( a') * x. ! if ( lsame ( uplo, 'U' ) ) then kplus1 = k + 1 if ( incx == 1 ) then do j = 1, n temp = x(j) l = kplus1 - j do i = max ( 1, j - k ), j - 1 temp = temp - a( l + i,j) * x(i) end do if ( nounit ) then temp = temp/a( kplus1,j) END IF x(j) = temp end do else jx = kx do j = 1, n temp = x(jx) ix = kx l = kplus1 - j do i = max ( 1, j - k ), j - 1 temp = temp - a( l + i,j) * x(ix) ix = ix + incx end do if ( nounit ) then temp = temp/a( kplus1,j) END IF x(jx) = temp jx = jx + incx if ( j>k ) then kx = kx + incx END IF end do END IF else if ( incx == 1 ) then do j = n, 1, -1 temp = x(j) l = 1 - j do i = min ( n, j + k ), j + 1, -1 temp = temp - a( l + i,j) * x(i) end do if ( nounit ) then temp = temp/a( 1,j) END IF x(j) = temp end do else kx = kx + ( n - 1 ) * incx jx = kx do j = n, 1, -1 temp = x(jx) ix = kx l = 1 - j do i = min ( n, j + k ), j + 1, -1 temp = temp - a( l + i,j) * x(ix) ix = ix - incx end do if ( nounit ) then temp = temp/a( 1,j) END IF x(jx) = temp jx = jx - incx if ( ( n - j ) >= k ) then kx = kx - incx END IF end do END IF END IF END IF return end subroutine stpmv ( uplo, trans, diag, n, ap, x, incx ) ! !******************************************************************************* ! !! STPMV performs x := A * x or x := A'*x, ! ! where x is an n element vector and a is an n by n unit, or non-unit, ! upper or lower triangular matrix, supplied in packed form. ! ! ! Author: ! ! Jack Dongarra, Argonne National Lab. ! Jeremy du Croz, NAG Central Office. ! Sven Hammarling, NAG Central Office. ! Richard Hanson, Sandia National Labs. ! ! Parameters: ! ! uplo - character. ! on entry, uplo specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! uplo = 'U' or 'U' a is an upper triangular matrix. ! ! uplo = 'L' or 'L' a is a lower triangular matrix. ! ! unchanged on exit. ! ! trans - character. ! on entry, trans specifies the operation to be performed as ! follows: ! ! trans = 'N' or 'N' x := a * x. ! ! trans = 'T' or 'T' x := a' * x. ! ! trans = 'C' or 'C' x := a' * x. ! ! unchanged on exit. ! ! diag - character. ! on entry, diag specifies whether or not a is unit ! triangular as follows: ! ! diag = 'U' or 'U' a is assumed to be unit triangular. ! ! diag = 'N' or 'N' a is not assumed to be unit ! triangular. ! ! unchanged on exit. ! ! n - integer. ! on entry, n specifies the order of the matrix a. ! n must be at least 0. ! unchanged on exit. ! ! ap - real array of dimension at least ! ( ( n*( n + 1 ) )/2 ). ! before entry with uplo = 'U' or 'U', the array ap must ! contain the upper triangular matrix packed sequentially, ! column by column, so that ap( 1 ) contains a( 1, 1 ), ! ap( 2 ) and ap( 3 ) contain a( 1, 2 ) and a( 2, 2 ) ! respectively, and so on. ! before entry with uplo = 'L' or 'L', the array ap must ! contain the lower triangular matrix packed sequentially, ! column by column, so that ap( 1 ) contains a( 1, 1 ), ! ap( 2 ) and ap( 3 ) contain a( 2, 1 ) and a( 3, 1 ) ! respectively, and so on. ! note that when diag = 'U' or 'U', the diagonal elements of ! a are not referenced, but are assumed to be unity. ! unchanged on exit. ! ! x - real array of dimension at least ! ( 1 + ( n - 1 ) * abs( incx ) ). ! before entry, the incremented array x must contain the n ! element vector x. on exit, x is overwritten with the ! tranformed vector x. ! ! incx - integer. ! on entry, incx specifies the increment for the elements of ! x. incx must not be 0. ! unchanged on exit. ! implicit none ! integer incx, n character diag, trans, uplo ! .. array arguments .. real ap( * ), x( * ) ! .. ! ! .. parameters .. ! .. local scalars .. real temp integer i, info, ix, j, jx, k, kk, kx logical nounit ! .. external functions .. logical lsame external lsame ! .. external subroutines .. external xerbla ! ! test the input parameters. ! info = 0 if ( .not.lsame ( uplo , 'U' ).and. & .not.lsame ( uplo , 'L' ) ) then info = 1 else if ( .not.lsame ( trans, 'N' ).and. & .not.lsame ( trans, 'T' ).and. & .not.lsame ( trans, 'C' ) ) then info = 2 else if ( .not.lsame ( diag , 'U' ).and. & .not.lsame ( diag , 'N' ) ) then info = 3 else if ( n < 0 ) then info = 4 else if ( incx == 0 ) then info = 7 END IF if ( info /= 0 ) then call xerbla ( 'stpmv ', info ) return END IF ! ! Quick return if possible. ! if ( n == 0 ) then return END IF nounit = lsame ( diag, 'N' ) ! ! Set up the start point in x if the increment is not unity. this ! will be ( n - 1 ) * incx too small for descending loops. ! if ( incx <= 0 ) then kx = 1 - ( n - 1 ) * incx else if ( incx /= 1 ) then kx = 1 END IF ! ! Start the operations. in this version the elements of ap are ! accessed sequentially with one pass through ap. ! if ( lsame ( trans, 'N' ) ) then ! ! Form x:= a * x. ! if ( lsame ( uplo, 'U' ) ) then kk = 1 if ( incx == 1 ) then do j = 1, n if ( x(j) /= 0.0 ) then temp = x(j) k = kk do i = 1, j - 1 x(i) = x(i) + temp * ap(k) k = k + 1 end do if ( nounit ) then x(j) = x(j) * ap( kk + j - 1 ) END IF END IF kk = kk + j end do else jx = kx do j = 1, n if ( x(jx) /= 0.0 ) then temp = x(jx) ix = kx do k = kk, kk + j - 2 x(ix) = x(ix) + temp * ap(k) ix = ix + incx end do if ( nounit ) then x(jx) = x(jx) * ap( kk + j - 1 ) END IF END IF jx = jx + incx kk = kk + j end do END IF else kk = ( n*( n + 1 ) )/2 if ( incx == 1 ) then do j = n, 1, -1 if ( x(j) /= 0.0 ) then temp = x(j) k = kk do i = n, j + 1, -1 x(i) = x(i) + temp * ap(k) k = k - 1 end do if ( nounit ) then x(j) = x(j) * ap( kk - n + j ) END IF END IF kk = kk - ( n - j + 1 ) end do else kx = kx + ( n - 1 ) * incx jx = kx do j = n, 1, -1 if ( x(jx) /= 0.0 ) then temp = x(jx) ix = kx do k = kk, kk - ( n - ( j + 1 ) ), -1 x(ix) = x(ix) + temp * ap(k) ix = ix - incx end do if ( nounit ) then x(jx) = x(jx) * ap( kk - n + j ) END IF END IF jx = jx - incx kk = kk - ( n - j + 1 ) end do END IF END IF else ! ! Form x := a' * x. ! if ( lsame ( uplo, 'U' ) ) then kk = ( n*( n + 1 ) )/2 if ( incx == 1 ) then do j = n, 1, -1 temp = x(j) if ( nounit ) then temp = temp * ap(kk) END IF k = kk - 1 do i = j - 1, 1, -1 temp = temp + ap(k) * x(i) k = k - 1 end do x(j) = temp kk = kk - j end do else jx = kx + ( n - 1 ) * incx do j = n, 1, -1 temp = x(jx) ix = jx if ( nounit ) then temp = temp * ap(kk) END IF do k = kk - 1, kk - j + 1, -1 ix = ix - incx temp = temp + ap(k) * x(ix) end do x(jx) = temp jx = jx - incx kk = kk - j end do END IF else kk = 1 if ( incx == 1 ) then do j = 1, n temp = x(j) if ( nounit ) then temp = temp * ap(kk) END IF k = kk + 1 do i = j + 1, n temp = temp + ap(k) * x(i) k = k + 1 end do x(j) = temp kk = kk + ( n - j + 1 ) end do else jx = kx do j = 1, n temp = x(jx) ix = jx if ( nounit ) then temp = temp * ap(kk) END IF do k = kk + 1, kk + n - j ix = ix + incx temp = temp + ap(k) * x(ix) end do x(jx) = temp jx = jx + incx kk = kk + ( n - j + 1 ) end do END IF END IF END IF return end subroutine stpsv ( uplo, trans, diag, n, ap, x, incx ) ! !******************************************************************************* ! !! STPSV solves A * x = b or A'*x = b, ! ! where b and x are n element vectors and a is an n by n unit, or ! non-unit, upper or lower triangular matrix, supplied in packed form. ! ! No test for singularity or near-singularity is included in this ! routine. Such tests must be performed before calling this routine. ! ! Author: ! ! Jack Dongarra, Argonne National Lab. ! Jeremy du Croz, NAG Central Office. ! Sven Hammarling, NAG Central Office. ! Richard Hanson, Sandia National Labs. ! ! Parameters: ! ! uplo - character. ! on entry, uplo specifies whether the matrix is an upper or ! lower triangular matrix as follows: ! ! uplo = 'U' or 'U' a is an upper triangular matrix. ! ! uplo = 'L' or 'L' a is a lower triangular matrix. ! ! unchanged on exit. ! ! trans - character. ! on entry, trans specifies the equations to be solved as ! follows: ! ! trans = 'N' or 'N' a * x = b. ! ! trans = 'T' or 'T' a' * x = b. ! ! trans = 'C' or 'C' a' * x = b. ! ! unchanged on exit. ! ! diag - character. ! on entry, diag specifies whether or not a is unit ! triangular as follows: ! ! diag = 'U' or 'U' a is assumed to be unit triangular. ! ! diag = 'N' or 'N' a is not assumed to be unit ! triangular. ! ! unchanged on exit. ! ! n - integer. ! on entry, n specifies the order of the matrix a. ! n must be at least 0. ! unchanged on exit. ! ! ap - real array of dimension at least ! ( ( n*( n + 1 ) )/2 ). ! before entry with uplo = 'U' or 'U', the array ap must ! contain the upper triangular matrix packed sequentially, ! column by column, so that ap( 1 ) contains a( 1, 1 ), ! ap( 2 ) and ap( 3 ) contain a( 1, 2 ) and a( 2, 2 ) ! respectively, and so on. ! before entry with uplo = 'L' or 'L', the array ap must ! contain the lower triangular matrix packed sequentially, ! column by column, so that ap( 1 ) contains a( 1, 1 ), ! ap( 2 ) and ap( 3 ) contain a( 2, 1 ) and a( 3, 1 ) ! respectively, and so on. ! note that when diag = 'U' or 'U', the diagonal elements of ! a are not referenced, but are assumed to be unity. ! unchanged on exit. ! ! x - real array of dimension at least ! ( 1 + ( n - 1 ) * abs( incx ) ). ! before entry, the incremented array x must contain the n ! element right-hand side vector b. on exit, x is overwritten ! with the solution vector x. ! ! incx - integer. ! on entry, incx specifies the increment for the elements of ! x. incx must not be 0. ! unchanged on exit. ! implicit none ! integer incx, n character diag, trans, uplo ! .. array arguments .. real ap( * ), x( * ) ! .. ! ! .. parameters .. ! .. local scalars .. real temp integer i, info, ix, j, jx, k, kk, kx logical nounit ! .. external functions .. logical lsame external lsame ! .. external subroutines .. external xerbla ! ! test the input parameters. ! info = 0 if ( .not.lsame ( uplo , 'U' ).and. & .not.lsame ( uplo , 'L' ) ) then info = 1 else if ( .not.lsame ( trans, 'N' ).and. & .not.lsame ( trans, 'T' ).and. & .not.lsame ( trans, 'C' ) ) then info = 2 else if ( .not.lsame ( diag , 'U' ).and. & .not.lsame ( diag , 'N' ) ) then info = 3 else if ( n < 0 ) then info = 4 else if ( incx == 0 ) then info = 7 END IF if ( info /= 0 ) then call xerbla ( 'stpsv ', info ) return END IF ! ! Quick return if possible. ! if ( n == 0 ) then return END IF nounit = lsame ( diag, 'N' ) ! ! Set up the start point in x if the increment is not unity. this ! will be ( n - 1 ) * incx too small for descending loops. ! if ( incx <= 0 ) then kx = 1 - ( n - 1 ) * incx else if ( incx /= 1 ) then kx = 1 END IF ! ! Start the operations. in this version the elements of ap are ! accessed sequentially with one pass through ap. ! if ( lsame ( trans, 'N' ) ) then ! ! Form x := inv( a ) * x. ! if ( lsame ( uplo, 'U' ) ) then kk = ( n*( n + 1 ) )/2 if ( incx == 1 ) then do j = n, 1, -1 if ( x(j) /= 0.0 ) then if ( nounit ) then x(j) = x(j)/ap(kk) END IF temp = x(j) k = kk - 1 do i = j - 1, 1, -1 x(i) = x(i) - temp * ap(k) k = k - 1 end do END IF kk = kk - j end do else jx = kx + ( n - 1 ) * incx do j = n, 1, -1 if ( x(jx) /= 0.0 ) then if ( nounit ) then x(jx) = x(jx) / ap(kk) END IF temp = x(jx) ix = jx do k = kk - 1, kk - j + 1, -1 ix = ix - incx x(ix) = x(ix) - temp * ap(k) end do END IF jx = jx - incx kk = kk - j end do END IF else kk = 1 if ( incx == 1 ) then do j = 1, n if ( x(j) /= 0.0 ) then if ( nounit ) then x(j) = x(j) / ap(kk) END IF temp = x(j) k = kk + 1 do i = j + 1, n x(i) = x(i) - temp * ap(k) k = k + 1 end do END IF kk = kk + ( n - j + 1 ) end do else jx = kx do j = 1, n if ( x(jx) /= 0.0 ) then if ( nounit ) then x(jx) = x(jx) / ap(kk) END IF temp = x(jx) ix = jx do k = kk + 1, kk + n - j ix = ix + incx x(ix) = x(ix) - temp * ap(k) end do END IF jx = jx + incx kk = kk + ( n - j + 1 ) end do END IF END IF else ! ! Form x := inv( a' ) * x. ! if ( lsame ( uplo, 'U' ) ) then kk = 1 if ( incx == 1 ) then do j = 1, n temp = x(j) k = kk do i = 1, j - 1 temp = temp - ap(k) * x(i) k = k + 1 end do if ( nounit ) then temp = temp / ap( kk + j - 1 ) END IF x(j) = temp kk = kk + j end do else jx = kx do j = 1, n temp = x(jx) ix = kx do k = kk, kk + j - 2 temp = temp - ap(k) * x(ix) ix = ix + incx end do if ( nounit ) then temp = temp/ap( kk + j - 1 ) END IF x(jx) = temp jx = jx + incx kk = kk + j end do END IF else kk = ( n*( n + 1 ) )/2 if ( incx == 1 ) then do j = n, 1, -1 temp = x(j) k = kk do i = n, j + 1, -1 temp = temp - ap(k) * x(i) k = k - 1 end do if ( nounit ) then temp = temp / ap( kk - n + j ) END IF x(j) = temp kk = kk - ( n - j + 1 ) end do else kx = kx + ( n - 1 ) * incx jx = kx do j = n, 1, -1 temp = x(jx) ix = kx do k = kk, kk - ( n - ( j + 1 ) ), -1 temp = temp - ap(k) * x(ix) ix = ix - incx end do if ( nounit ) then temp = temp / ap( kk - n + j ) END IF x(jx) = temp jx = jx - incx kk = kk - ( n - j + 1 ) end do END IF END IF END IF return end subroutine strmm ( side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb ) ! !******************************************************************************* ! !! STRMM performs one of the matrix-matrix operations ! ! b := alpha*op( a )*b, or b := alpha*b*op( a ), ! ! where alpha is a scalar, b is an m by n matrix, a is a unit, or ! non-unit, upper or lower triangular matrix and op( a ) is one of ! ! op( a ) = a or op( a ) = a'. ! ! ! Author: ! ! Jack Dongarra, Argonne National Laboratory. ! Iain Duff, AERE Harwell. ! Jeremy du Croz, Numerical Algorithms Group LTD. ! Sven Hammarling, Numerical Algorithms Group LTD. ! ! Parameters: ! ! side - character. ! on entry, side specifies whether op( a ) multiplies b from ! the left or right as follows: ! ! side = 'l' or 'L' b := alpha*op( a )*b. ! ! side = 'r' or 'R' b := alpha*b*op( a ). ! ! unchanged on exit. ! ! uplo - character. ! on entry, uplo specifies whether the matrix a is an upper or ! lower triangular matrix as follows: ! ! uplo = 'u' or 'U' a is an upper triangular matrix. ! ! uplo = 'l' or 'L' a is a lower triangular matrix. ! ! unchanged on exit. ! ! transa - character. ! on entry, transa specifies the form of op( a ) to be used in ! the matrix multiplication as follows: ! ! transa = 'n' or 'n' op( a ) = a. ! ! transa = 't' or 't' op( a ) = a'. ! ! transa = 'c' or 'C' op( a ) = a'. ! ! unchanged on exit. ! ! diag - character. ! on entry, diag specifies whether or not a is unit triangular ! as follows: ! ! diag = 'u' or 'U' a is assumed to be unit triangular. ! ! diag = 'n' or 'n' a is not assumed to be unit ! triangular. ! ! unchanged on exit. ! ! m - integer. ! on entry, m specifies the number of rows of b. m must be at ! least 0. ! unchanged on exit. ! ! n - integer. ! on entry, n specifies the number of columns of b. n must be ! at least 0. ! unchanged on exit. ! ! alpha - real . ! on entry, alpha specifies the scalar alpha. when alpha is ! 0.0 then a is not referenced and b need not be set before ! entry. ! unchanged on exit. ! ! a - real array of dimension ( lda, k ), where k is m ! when side = 'l' or 'L' and is n when side = 'r' or 'R'. ! before entry with uplo = 'u' or 'U', the leading k by k ! upper triangular part of the array a must contain the upper ! triangular matrix and the strictly lower triangular part of ! a is not referenced. ! before entry with uplo = 'l' or 'L', the leading k by k ! lower triangular part of the array a must contain the lower ! triangular matrix and the strictly upper triangular part of ! a is not referenced. ! note that when diag = 'u' or 'U', the diagonal elements of ! a are not referenced either, but are assumed to be unity. ! unchanged on exit. ! ! lda - integer. ! on entry, lda specifies the first dimension of a as declared ! in the calling (sub) program. when side = 'l' or 'L' then ! lda must be at least max( 1, m ), when side = 'r' or 'R' ! then lda must be at least max( 1, n ). ! unchanged on exit. ! ! b - real array of dimension ( ldb, n ). ! before entry, the leading m by n part of the array b must ! contain the matrix b, and on exit is overwritten by the ! transformed matrix. ! ! ldb - integer. ! on entry, ldb specifies the first dimension of b as declared ! in the calling (sub) program. ldb must be at least ! max( 1, m ). ! unchanged on exit. ! implicit none ! character side, uplo, transa, diag integer m, n, lda, ldb real alpha ! .. array arguments .. real a( lda, * ), b( ldb, * ) ! .. ! ! .. external functions .. logical lsame external lsame ! .. external subroutines .. external xerbla ! .. local scalars .. logical lside, nounit, upper integer i, info, j, k, nrowa real temp ! ! test the input parameters. ! lside = lsame( side , 'L' ) if ( lside ) then nrowa = m else nrowa = n END IF nounit = lsame( diag , 'N' ) upper = lsame( uplo , 'U' ) info = 0 if ( ( .not.lside ).and. & ( .not.lsame( side , 'R' ) ) ) then info = 1 else if ( ( .not.upper ).and. & ( .not.lsame( uplo , 'L' ) ) ) then info = 2 else if ( ( .not.lsame( transa, 'N' ) ).and. & ( .not.lsame( transa, 'T' ) ).and. & ( .not.lsame( transa, 'C' ) ) ) then info = 3 else if ( ( .not.lsame( diag , 'U' ) ).and. & ( .not.lsame( diag , 'N' ) ) ) then info = 4 else if ( m <0 ) then info = 5 else if ( n <0 ) then info = 6 else if ( lda