#! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh 'd1mach.f' <<'END_OF_FILE' X X double precision function d1mach( i ) X* X* -- lapack auxiliary routine -- X* argonne national lab, courant institute, and n.a.g. ltd. X* april 1, 1989 X* X* .. scalar arguments .. X integer i X* .. X* X* purpose X* ======= X* X* d1mach determines double precision machine constants by a call X* to the double precision version of machar. X* X* (see w. j. cody, "machar: a subroutine to dynamically determine X* machine parameters," toms 14, december, 1988. ) X* X* arguments X* ========= X* X* i - integer X* on entry, i is the index to one of the machine constants, X* as follows: X* X* d1mach(1) = b**(emin-1), the smallest positive magnitude X* X* d1mach(2) = b**emax*(1 - b**(-t)), the largest magnitude X* X* d1mach(3) = b**(-t), the smallest relative spacing X* X* d1mach(4) = b**(1-t), the largest relative spacing X* X* d1mach(5) = log10(b) X* X* .. local scalars .. X logical dejavu X integer ibdig, iexp, iradix, iround, machep, maxexp, X $ minexp, negeps, nguard X double precision eps, epsneg, xmax, xmin X* .. X* .. local arrays .. X double precision dmach( 5 ) X* .. X* .. external subroutines .. X external dmachr X* .. X* .. intrinsic functions .. X intrinsic dble, log10 X* .. X* .. save statement .. X save X* .. X* .. data statements .. X data dejavu / .false. / X* .. X* .. executable statements .. X* X if( .not.dejavu ) then X call dmachr( iradix, ibdig, iround, nguard, machep, negeps, X $ iexp, minexp, maxexp, eps, epsneg, xmin, xmax ) X dmach( 1 ) = xmin X dmach( 2 ) = xmax X dmach( 3 ) = eps X dmach( 4 ) = dble( iradix )*eps X dmach( 5 ) = log10( dble( iradix ) ) X dejavu = .true. X end if X* X if( i.lt.1 .or. i.gt.5 ) then X write( *, fmt = 9999 )i X 9999 format( ' d1mach - i out of bounds', i10 ) X stop X else X d1mach = dmach( i ) X end if X* X return X* X* end of d1mach X* X end END_OF_FILE if test 2192 -ne `wc -c <'d1mach.f'`; then echo shar: \"'d1mach.f'\" unpacked with wrong size! fi # end of 'd1mach.f' fi if test -f 'daxpy.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'daxpy.f'\" else echo shar: Extracting \"'daxpy.f'\" \(1556 characters\) sed "s/^X//" >'daxpy.f' <<'END_OF_FILE' X SUBROUTINE DAXPY( N, DA, DX, INCX, DY, INCY ) X* X* constant times a vector plus a vector. X* uses unrolled loops for increments equal to one. X* jack dongarra, linpack, 3/11/78. X* X* .. Scalar Arguments .. X INTEGER INCX, INCY, N X DOUBLE PRECISION DA X* .. X* .. Array Arguments .. X DOUBLE PRECISION DX( 1 ), DY( 1 ) X* .. X* .. Local Scalars .. X INTEGER I, IX, IY, M, MP1 X* .. X* .. Intrinsic Functions .. X INTRINSIC MOD X* .. X* .. Executable Statements .. X* X IF( N.LE.0 ) X $ RETURN X IF( DA.EQ.0.0D0 ) X $ RETURN X IF( INCX.EQ.1 .AND. INCY.EQ.1 ) X $ GO TO 20 X* X* code for unequal increments or equal increments X* not equal to 1 X* X IX = 1 X IY = 1 X IF( INCX.LT.0 ) X $ IX = ( -N+1 )*INCX + 1 X IF( INCY.LT.0 ) X $ IY = ( -N+1 )*INCY + 1 X DO 10 I = 1, N X DY( IY ) = DY( IY ) + DA*DX( IX ) X IX = IX + INCX X IY = IY + INCY X 10 CONTINUE X RETURN X* X* code for both increments equal to 1 X* X* X* clean-up loop X* X 20 M = MOD( N, 4 ) X IF( M.EQ.0 ) X $ GO TO 40 X DO 30 I = 1, M X DY( I ) = DY( I ) + DA*DX( I ) X 30 CONTINUE X IF( N.LT.4 ) X $ RETURN X 40 MP1 = M + 1 X DO 50 I = MP1, N, 4 X DY( I ) = DY( I ) + DA*DX( I ) X DY( I+1 ) = DY( I+1 ) + DA*DX( I+1 ) X DY( I+2 ) = DY( I+2 ) + DA*DX( I+2 ) X DY( I+3 ) = DY( I+3 ) + DA*DX( I+3 ) X 50 CONTINUE X RETURN X END END_OF_FILE if test 1556 -ne `wc -c <'daxpy.f'`; then echo shar: \"'daxpy.f'\" unpacked with wrong size! fi # end of 'daxpy.f' fi if test -f 'dchk21.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dchk21.f'\" else echo shar: Extracting \"'dchk21.f'\" \(32890 characters\) sed "s/^X//" >'dchk21.f' <<'END_OF_FILE' X SUBROUTINE DCHK21( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, X $ NOUNIT, A, LDA, H, T1, T2, U, LDU, Z, UZ, WR1, X $ WI1, WR3, WI3, EVECTL, EVECTR, EVECTY, EVECTX, X $ WORK, NWORK, IWORK, LWORK, RESULT, INFO ) X* X* -- LAPACK test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X* X***************************** X INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK X DOUBLE PRECISION THRESH X* .. X* X* .. Array Arguments .. X* X LOGICAL DOTYPE( * ), LWORK( * ) X INTEGER ISEED( 4 ), IWORK( * ), NN( * ) X DOUBLE PRECISION A( LDA, * ), EVECTL( LDU, * ), X $ EVECTR( LDU, * ), EVECTX( LDU, * ), X $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 12 ), X $ T1( LDA, * ), T2( LDA, * ), U( LDU, * ), X $ UZ( LDU, * ), WI1( * ), WI3( * ), WORK( * ), X $ WR1( * ), WR3( * ), Z( LDU, * ) X* .. X* X*----------------------------------------------------------------------- X* X* Purpose X* ======= X* X* DCHK21 checks the nonsymmetric eigenvalue problem routines. X* X* DGEHD3 factors A as U H U' , where ' means transpose, X* H is hessenberg, and U is an orthogonal matrix. X* X* DHSEQR factors H as Z T Z' , where Z is orthogonal and X* T is "quasi-triangular", and the eigenvalue vector W. X* X* DTREVC computes the left and right eigenvector matrices X* L and R for T. X* X* DHSEIN computes the left and right eigenvector matrices X* Y and X for H, using inverse iteration. X* X* When DCHK21 is called, a number of matrix "sizes" ("n's") and a X* number of matrix "types" are specified. For each size ("n") X* and each type of matrix, one matrix will be generated and used X* to test the nonsymmetric eigenroutines. For each matrix, 12 X* tests will be performed: X* X* X* (1) | A - U H U' | / ( |A| n ulp ) X* X* (2) | I - UU' | / ( n ulp ) X* X* (3) | H - Z T Z' | / ( |H| n ulp ) X* X* (4) | I - ZZ' | / ( n ulp ) X* X* (5) | A - UZ H (UZ)' | / ( |A| n ulp ) X* X* (6) | I - UZ (UZ)' | / ( n ulp ) X* X* (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp ) X* X* (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp ) X* X* (9) | TR - RW | / ( |T| |R| ulp ) X* X* (10) | LT - WL | / ( |T| |L| ulp ) X* X* (11) | HX - XW | / ( |H| |X| ulp ) X* X* (12) | YH - WY | / ( |H| |Y| ulp ) X* X* The "sizes" are specified by an array NN(1:NSIZES); the value of X* each element NN(j) specifies one size. X* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); X* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. X* Currently, the list of possible types is: X* X* (1) The zero matrix. X* (2) The identity matrix. X* (3) A (transposed) Jordan block, with 1's on the diagonal. X* X* (4) A diagonal matrix with evenly spaced entries X* 1, ..., ULP and random signs. X* (ULP = (first number larger than 1) - 1 ) X* (5) A diagonal matrix with geometrically spaced entries X* 1, ..., ULP and random signs. X* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP X* and random signs. X* X* (7) Same as (4), but multiplied by SQRT( overflow threshold ) X* (8) Same as (4), but multiplied by SQRT( underflow threshold ) X* X* (9) A matrix of the form U' T U, where U is orthogonal and X* T has evenly spaced entries 1, ..., ULP with random signs X* on the diagonal and random O(1) entries in the upper X* triangle. X* X* (10) A matrix of the form U' T U, where U is orthogonal and X* T has geometrically spaced entries 1, ..., ULP with random X* signs on the diagonal and random O(1) entries in the upper X* triangle. X* X* (11) A matrix of the form U' T U, where U is orthogonal and X* T has "clustered" entries 1, ULP,..., ULP with random X* signs on the diagonal and random O(1) entries in the upper X* triangle. X* X* (12) A matrix of the form U' T U, where U is orthogonal and X* T has real or complex conjugate paired eigenvalues randomly X* chosen from ( ULP, 1 ) and random O(1) entries in the upper X* triangle. X* X* (13) A matrix of the form X' T X, where X has condition X* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP X* with random signs on the diagonal and random O(1) entries X* in the upper triangle. X* X* (14) A matrix of the form X' T X, where X has condition X* SQRT( ULP ) and T has geometrically spaced entries X* 1, ..., ULP with random signs on the diagonal and random X* O(1) entries in the upper triangle. X* X* (15) A matrix of the form X' T X, where X has condition X* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP X* with random signs on the diagonal and random O(1) entries X* in the upper triangle. X* X* (16) A matrix of the form X' T X, where X has condition X* SQRT( ULP ) and T has real or complex conjugate paired X* eigenvalues randomly chosen from ( ULP, 1 ) and random X* O(1) entries in the upper triangle. X* X* (17) Same as (16), but multiplied by SQRT( overflow threshold ) X* (18) Same as (16), but multiplied by SQRT( underflow threshold ) X* X* (19) Nonsymmetric matrix with random entries chosen from (-1,1). X* (20) Same as (19), but multiplied by SQRT( overflow threshold ) X* (21) Same as (19), but multiplied by SQRT( underflow threshold ) X* X* X* Arguments X* ========== X* X* NSIZES - INTEGER X* The number of sizes of matrices to use. If it is zero, X* DCHK21 does nothing. It must be at least zero. X* Not modified. X* X* NN - INTEGER array of dimension ( NSIZES ) X* An array containing the sizes to be used for the matrices. X* Zero values will be skipped. The values must be at least X* zero. X* Not modified. X* X* NTYPES - INTEGER X* The number of elements in DOTYPE. If it is zero, DCHK21 X* does nothing. It must be at least zero. If it is MAXTYP+1 X* and NSIZES is 1, then an additional type, MAXTYP+1 is X* defined, which is to use whatever matrix is in A. This X* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and X* DOTYPE(MAXTYP+1) is .TRUE. . X* Not modified. X* X* DOTYPE - LOGICAL array of dimension ( NTYPES ) X* If DOTYPE(j) is .TRUE., then for each size in NN a X* matrix of that size and of type j will be generated. X* If NTYPES is smaller than the maximum number of types X* defined (PARAMETER MAXTYP), then types NTYPES+1 through X* MAXTYP will not be generated. If NTYPES is larger X* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) X* will be ignored. X* Not modified. X* X* THRESH - DOUBLE PRECISION X* A test will count as "failed" if the "error", computed as X* described above, exceeds THRESH. Note that the error X* is scaled to be O(1), so THRESH should be a reasonably X* small multiple of 1, e.g., 10 or 100. In particular, X* it should not depend on the precision (single vs. double) X* or the size of the matrix. It must be at least zero. X* Not modified. X* X* ISEED - INTEGER array of dimension ( 4 ) X* On entry ISEED specifies the seed of the random number X* generator. The array elements should be between 0 and 4095; X* if not they will be reduced mod 4096. Also, ISEED(4) must X* be odd. The random number generator uses a linear X* congruential sequence limited to small integers, and so X* should produce machine independent random numbers. The X* values of ISEED are changed on exit, and can be used in the X* next call to DCHK21 to continue the same random number X* sequence. X* Modified. X* X* NOUNIT - INTEGER X* The FORTRAN unit number for printing out error messages X* (e.g., if a routine returns INFO not equal to 0.) X* Not modified. X* X* A - DOUBLE PRECISION array of dimension ( LDA , max(NN) ) X* Used to hold the matrix whose eigenvalues are to be X* computed. On exit, A contains the last matrix actually X* used. X* Modified. X* X* LDA - INTEGER X* The leading dimension of A, H, T1, and T2. It must be at X* least 1 and at least max( NN ). X* Not modified. X* X* H - DOUBLE PRECISION array of dimension( LDA , max(NN) ) X* The upper hessenberg matrix computed by DGEHD3. On exit, X* H contains the Hessenberg form of the matrix in A. X* Modified. X* X* T1 - DOUBLE PRECISION array of dimension( LDA , max(NN) ) X* The Schur (="quasi-triangular") matrix computed by DHSEQR X* if Z is computed. On exit, T1 contains the Schur form of X* the matrix in A. X* Modified. X* X* T2 - DOUBLE PRECISION array of dimension( LDA , max(NN) ) X* The Schur matrix computed by DHSEQR when Z is not computed. X* This should be identical to T1. X* Modified. X* X* LDU - INTEGER X* The leading dimension of U, V, Z, and UZ. It must be at X* least 1 and at least max( NN ). X* Not modified. X* X* U - DOUBLE PRECISION array of dimension ( LDU, max(NN) ). X* The orthogonal matrix computed by DGEHD3. X* Modified. X* X* Z - DOUBLE PRECISION array of dimension ( LDU, max(NN) ). X* The orthogonal matrix computed by DHSEQR. X* Modified. X* X* UZ - DOUBLE PRECISION array of dimension ( LDU, max(NN) ). X* The product of U times Z. X* Modified. X* X* WR1, WI1 - DOUBLE PRECISION arrays of dimension ( max(NN) ). X* The real and imaginary parts of the eigenvalues of A, X* as computed when Z is computed. X* On exit, WR1 + WI1*i are the eigenvalues of the matrix in A. X* Modified. X* X* WR3, WI3 - DOUBLE PRECISION arrays of dimension ( max(NN) ). X* Like WR1, WI1, these arrays contain the eigenvalues of A, X* but those computed when DHSEQR only computes the X* eigenvalues, i.e., not the Schur vectors and no more of the X* Schur form than is necessary for computing the X* eigenvalues. X* Modified. X* X* EVECTL - DOUBLE PRECISION array of dimension ( LDU, max(NN) ). X* The (upper triangular) left eigenvector matrix for the X* matrix in T1. For complex conjugate pairs, the real part X* is stored in one row and the imaginary part in the next. X* Modified. X* X* EVEZTR - DOUBLE PRECISION array of dimension ( LDU, max(NN) ). X* The (upper triangular) right eigenvector matrix for the X* matrix in T1. For complex conjugate pairs, the real part X* is stored in one column and the imaginary part in the next. X* Modified. X* X* EVECTY - DOUBLE PRECISION array of dimension ( LDU, max(NN) ). X* The left eigenvector matrix for the X* matrix in H. For complex conjugate pairs, the real part X* is stored in one row and the imaginary part in the next. X* Modified. X* X* EVECTX - DOUBLE PRECISION array of dimension ( LDU, max(NN) ). X* The right eigenvector matrix for the X* matrix in H. For complex conjugate pairs, the real part X* is stored in one column and the imaginary part in the next. X* Modified. X* X* WORK - DOUBLE PRECISION array of dimension ( NWORK ) X* Workspace. X* Modified. X* X* NWORK - INTEGER X* The number of entries in WORK. This must be at least X* NN(j) * MAX( 3*NBLOCK+NSHIFT+2 , 2*NBLOCK+2*NSHIFT+2 , X* 2*NN(j) ). X* In this formula, "NBLOCK" is the blocksize and "NSHIFT" is X* the number of simultaneous shifts; both are returned by X* "ENVIR"; NBLOCK will be constrained to be between 1 and X* NN(j), while NSHIFT will be constrained to be between 2 and X* NN(j). X* Not modified. X* X* IWORK - INTEGER array of dimension ( max(NN) ) (scratch) X* Workspace. X* Modified. X* X* LWORK - LOGICAL array of dimension ( max(NN) ) (scratch) X* Workspace. Could be equivalenced to IWORK. X* Modified. X* X* RESULT - DOUBLE PRECISION array of dimension ( 12 ) (OUTPUT) X* The values computed by the twelve tests described above. X* The values are currently limited to 1/ulp, to avoid X* overflow. X* Modified. X* X* INFO - INTEGER X* If 0, then everything ran OK. X* -1: NSIZES < 0 X* -2: Some NN(j) < 0 X* -3: NTYPES < 0 X* -6: THRESH < 0 X* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ). X* -14: LDU < 1 or LDU < NMAX. X* -26: NWORK too small. X* If DLATMR, SLATMS, or SLATME returns an error code, the X* absolute value of it is returned. X* If 1, then DHSEQR could not find all the shifts. X* If 2, then the EISPACK code (for small blocks) failed. X* If >2, then 30*N iterations were not enough to find an X* eigenvalue or to decompose the problem. X* Modified. X* X* X* X*----------------------------------------------------------------------- X* X* Some Local Variables and Parameters: X* ---- ----- --------- --- ---------- X* X* ZERO, ONE Real 0 and 1. X* MAXTYP The number of types defined. X* MTEST The number of tests defined: care must be taken X* that (1) the size of RESULT, (2) the number of X* tests actually performed, and (3) MTEST agree. X* NBLOCK, NSHIFT Blocksize and number of shifts as returned by X* ENVIR. X* NMAX Largest value in NN. X* NMATS The number of matrices generated so far. X* NERRS The number of tests which have exceeded THRESH X* so far (computed by DLAFTS). X* COND, CONDS, X* IMODE Values to be passed to the matrix generators. X* ANORM Norm of A; passed to matrix generators. X* X* OVFL, UNFL Overflow and underflow thresholds. X* ULP, ULPINV Finest relative precision and its inverse. X* RTOVFL, RTUNFL, X* RTULP, RTULPI Square roots of the previous 4 values. X* X* The following four arrays decode JTYPE: X* KTYPE(j) The general type (1-10) for type "j". X* KMODE(j) The MODE value to be passed to the matrix X* generator for type "j". X* KMAGN(j) The order of magnitude ( O(1), X* O(overflow^(1/2) ), O(underflow^(1/2) ) X* KCONDS(j) Selectw whether CONDS is to be 1 or X* 1/sqrt(ulp). (0 means irrelevant.) X* X*----------------------------------------------------------------------- X* X* X* .. Parameters .. X* X DOUBLE PRECISION ZERO, ONE X PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) X INTEGER MAXTYP X PARAMETER ( MAXTYP = 21 ) X* .. X* X* .. Local Scalars .. X* X LOGICAL BADNN X INTEGER IINFO, IMODE, IN, ITYPE, J, JCOL, JSIZE, X $ JTYPE, MTYPES, N, N1, NBLOCK, NCWORK, NERRS, X $ NMATS, NMAX, NSHIFT, NTEST, NTESTT X DOUBLE PRECISION ANINV, ANORM, COND, CONDS, OVFL, RTOVFL, RTULP, X $ RTULPI, RTUNFL, TEMP1, TEMP2, ULP, ULPINV, UNFL X* .. X* X* .. Local Arrays .. X* X CHARACTER ADUMMA( 1 ) X INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ), X $ KMAGN( MAXTYP ), KMODE( MAXTYP ), X $ KTYPE( MAXTYP ) X DOUBLE PRECISION DUMMA( 6 ) X* .. X* X* .. External Functions .. X* X DOUBLE PRECISION DLAMCH X EXTERNAL DLAMCH X* .. X* X* .. External Subroutines .. X* X EXTERNAL ENVIR, DGEHD3, DGEMM, DGET21, DGET22, DHSEIN, X $ DHSEQR, DLABAD, DLACPY, DLAFTS, DLASUM, DLATME, X $ DLATMR, DLATMS, DLAZRO, DTREVC, XERBLA X* .. X* X* .. Intrinsic Functions .. X* X INTRINSIC ABS, DBLE, MAX, MIN, SQRT X* .. X* X* .. Data statements .. X* X* X* X* X DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 / X DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2, X $ 3, 1, 2, 3 / X DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3, X $ 1, 5, 5, 5, 4, 3, 1 / X DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 / X* .. X* X* X*----------------------------------------------------------------------- X* .. Executable Statements .. X* X* X* Check for errors X* X* X* X NTESTT = 0 X INFO = 0 X* X* Important constants X* X CALL ENVIR( 'B', NBLOCK ) X CALL ENVIR( 'S', NSHIFT ) X* X BADNN = .FALSE. X NMAX = 0 X DO 10 J = 1, NSIZES X NMAX = MAX( NMAX, NN( J ) ) X IF( NN( J ).LT.0 ) X $ BADNN = .TRUE. X 10 CONTINUE X* X NBLOCK = MAX( 1, MIN( NMAX, NBLOCK ) ) X NSHIFT = MAX( 2, MIN( NMAX, NSHIFT ) ) X* X* X* Check for errors X* X* X IF( NSIZES.LT.0 ) THEN X INFO = -1 X ELSE IF( BADNN ) THEN X INFO = -2 X ELSE IF( NTYPES.LT.0 ) THEN X INFO = -3 X ELSE IF( THRESH.LT.ZERO ) THEN X INFO = -6 X ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN X INFO = -9 X ELSE IF( LDU.LE.1 .OR. LDU.LT.NMAX ) THEN X INFO = -14 X ELSE IF( NMAX*MAX( 3*NBLOCK+NSHIFT+2, 2*NBLOCK+2*NSHIFT+2 ).GT. X $ NWORK ) THEN X INFO = -26 X END IF X* X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DCHK21', -INFO ) X RETURN X END IF X* X* Quick return if nothing to do X* X IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 ) X $ RETURN X* X* More Important constants X* X* X UNFL = DLAMCH( 'Safe minimum' ) X OVFL = DLAMCH( 'Overflow' ) X CALL DLABAD( UNFL, OVFL ) X ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) X ULPINV = ONE / ULP X RTUNFL = SQRT( UNFL ) X RTOVFL = SQRT( OVFL ) X RTULP = SQRT( ULP ) X RTULPI = ONE / RTULP X* X*----------------------------------------------------------------------- X* X* Loop over sizes, types X* X NERRS = 0 X NMATS = 0 X* X DO 180 JSIZE = 1, NSIZES X N = NN( JSIZE ) X N1 = MAX( 1, N ) X NCWORK = NWORK / N1 X ANINV = ONE / DBLE( N1 ) X* X* X* X IF( NSIZES.NE.1 ) THEN X MTYPES = MIN( MAXTYP, NTYPES ) X ELSE X MTYPES = MIN( MAXTYP+1, NTYPES ) X END IF X* X DO 170 JTYPE = 1, MTYPES X IF( .NOT.DOTYPE( JTYPE ) ) X $ GO TO 170 X NMATS = NMATS + 1 X NTEST = 0 X* X* Save ISEED in case of an error. X* X DO 20 J = 1, 4 X IOLDSD( J ) = ISEED( J ) X 20 CONTINUE X* X* Initialize RESULT X* X DO 30 J = 1, 12 X RESULT( J ) = ZERO X 30 CONTINUE X* X*----------------------------------------------------------------------- X* X* X* Compute "A" X* X* Control parameters: X* X* KMAGN KCONDS KMODE KTYPE X* =1 O(1) 1 clustered 1 zero X* =2 large large clustered 2 identity X* =3 small exponential Jordan X* =4 arithmetic diagonal, (w/ eigenvalues) X* =5 random log symmetric, w/ eigenvalues X* =6 random general, w/ eigenvalues X* =7 random diagonal X* =8 random symmetric X* =9 random general X* =10 random triangular X* X* X* X IF( MTYPES.GT.MAXTYP ) X $ GO TO 100 X* X ITYPE = KTYPE( JTYPE ) X IMODE = KMODE( JTYPE ) X* X* Compute norm X* X GO TO ( 40, 50, 60 )KMAGN( JTYPE ) X* X 40 CONTINUE X ANORM = ONE X GO TO 70 X* X 50 CONTINUE X ANORM = ( RTOVFL*ULP )*ANINV X GO TO 70 X* X 60 CONTINUE X ANORM = RTUNFL*N*ULPINV X GO TO 70 X* X 70 CONTINUE X* X CALL DLAZRO( LDA, N, ZERO, ZERO, A, LDA ) X IINFO = 0 X COND = ULPINV X* X* Special Matrices -- Identity & Jordan block X* X* Zero X* X IF( ITYPE.EQ.1 ) THEN X IINFO = 0 X* X* Identity X* X ELSE IF( ITYPE.EQ.2 ) THEN X* X DO 80 JCOL = 1, N X A( JCOL, JCOL ) = ANORM X 80 CONTINUE X* X* Jordan Block X* X ELSE IF( ITYPE.EQ.3 ) THEN X* X DO 90 JCOL = 1, N X A( JCOL, JCOL ) = ANORM X IF( JCOL.GT.1 ) X $ A( JCOL, JCOL-1 ) = ONE X 90 CONTINUE X* X* X* Diagonal Matrix, [Eigen]values Specified X* X ELSE IF( ITYPE.EQ.4 ) THEN X* X CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, X $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ), X $ IINFO ) X* X* X* Symmetric, eigenvalues specified X* X* X ELSE IF( ITYPE.EQ.5 ) THEN X* X CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND, X $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ), X $ IINFO ) X* X* X* General, eigenvalues specified X* X* X ELSE IF( ITYPE.EQ.6 ) THEN X* X IF( KCONDS( JTYPE ).EQ.1 ) THEN X CONDS = ONE X ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN X CONDS = RTULPI X ELSE X CONDS = ZERO X END IF X ADUMMA( 1 ) = ' ' X CALL DLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE, X $ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4, X $ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ), X $ IINFO ) X* X* X* Diagonal, random eigenvalues X* X* X ELSE IF( ITYPE.EQ.7 ) THEN X* X CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, X $ 'T', 'N', WORK( N+1 ), 1, ONE, X $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0, X $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) X* X* X* Symmetric, random eigenvalues X* X ELSE IF( ITYPE.EQ.8 ) THEN X* X CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE, X $ 'T', 'N', WORK( N+1 ), 1, ONE, X $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, X $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) X* X* X* General, random eigenvalues X* X* X ELSE IF( ITYPE.EQ.9 ) THEN X* X CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE, X $ 'T', 'N', WORK( N+1 ), 1, ONE, X $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N, X $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) X* X* X* Triangular, random eigenvalues X* X* X ELSE IF( ITYPE.EQ.10 ) THEN X* X CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE, X $ 'T', 'N', WORK( N+1 ), 1, ONE, X $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0, X $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO ) X* X ELSE X IINFO = 1 X END IF X* X IF( IINFO.NE.0 ) THEN X WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE, X $ IOLDSD X INFO = ABS( IINFO ) X RETURN X END IF X* X 100 CONTINUE X* X*----------------------------------------------------------------------- X* X* X* Call DGEHD3 to compute H and U, do tests. X* X* X CALL DLACPY( ' ', N, N, A, LDA, H, LDA ) X* X NTEST = 1 X CALL DGEHD3( 'Q', N, H, LDA, U, LDU, WORK, WORK( N+1 ), N1, X $ NCWORK-1, IINFO ) X IF( IINFO.NE.0 ) THEN X RESULT( 1 ) = ULPINV X WRITE( NOUNIT, FMT = 9999 )'DGEHD3', IINFO, N, JTYPE, X $ IOLDSD X INFO = ABS( IINFO ) X GO TO 160 X END IF X NTEST = 2 X* X* X CALL DGET21( 1, N, A, LDA, H, LDA, U, LDU, DUMMA, WORK, X $ RESULT( 1 ) ) X* X*----------------------------------------------------------------------- X* X* X* Call DHSEQR to compute T1, T2, and Z, do tests. X* X* X* Compute T1 and UZ X* X CALL DLACPY( ' ', N, N, H, LDA, T2, LDA ) X NTEST = 3 X RESULT( 3 ) = ULPINV X* X CALL DHSEQR( 'E', N, T2, LDA, UZ, LDU, WR3, WI3, WORK, X $ NWORK, IINFO ) X IF( IINFO.NE.0 ) THEN X WRITE( NOUNIT, FMT = 9999 )'DHSEQR(E)', IINFO, N, JTYPE, X $ IOLDSD X IF( IINFO.LE.N+2 ) THEN X INFO = ABS( IINFO ) X GO TO 160 X END IF X END IF X* X CALL DLACPY( ' ', N, N, H, LDA, T2, LDA ) X* X CALL DHSEQR( 'S', N, T2, LDA, UZ, LDU, WR1, WI1, WORK, X $ NWORK, IINFO ) X IF( IINFO.NE.0 .AND. IINFO.LE.N+2 ) THEN X WRITE( NOUNIT, FMT = 9999 )'DHSEQR(S)', IINFO, N, JTYPE, X $ IOLDSD X INFO = ABS( IINFO ) X GO TO 160 X END IF X* X CALL DLACPY( ' ', N, N, H, LDA, T1, LDA ) X CALL DLACPY( ' ', N, N, U, LDU, UZ, LDA ) X* X CALL DHSEQR( 'V', N, T1, LDA, UZ, LDU, WR1, WI1, WORK, X $ NWORK, IINFO ) X IF( IINFO.NE.0 .AND. IINFO.LE.N+2 ) THEN X WRITE( NOUNIT, FMT = 9999 )'DHSEQR(V)', IINFO, N, JTYPE, X $ IOLDSD X INFO = ABS( IINFO ) X GO TO 160 X END IF X* X* Compute Z = U' UZ X* X CALL DGEMM( 'C', 'N', N, N, N, ONE, U, LDU, UZ, LDU, ZERO, X $ Z, LDU ) X NTEST = 8 X* X* X* Do Tests 3 and 4 X* X* X CALL DGET21( 1, N, H, LDA, T1, LDA, Z, LDU, DUMMA, WORK, X $ RESULT( 3 ) ) X* X* X* X* Do Tests 5 & 6 X* X* X CALL DGET21( 1, N, A, LDA, T1, LDA, UZ, LDU, DUMMA, WORK, X $ RESULT( 5 ) ) X* X* X* Do Test 7 X* X CALL DGET21( 2, N, T2, LDA, T1, LDA, DUMMA, LDU, DUMMA, X $ WORK, RESULT( 7 ) ) X* X* X* Do Test 8 X* X TEMP1 = ZERO X TEMP2 = ZERO X* X DO 110 J = 1, N X TEMP1 = MAX( TEMP1, ABS( WR1( J ) )+ABS( WI1( J ) ), X $ ABS( WR3( J ) )+ABS( WI3( J ) ) ) X TEMP2 = MAX( TEMP2, ABS( WR1( J )-WR3( J ) )+ X $ ABS( WR1( J )-WR3( J ) ) ) X 110 CONTINUE X* X RESULT( 8 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) X* X* X*----------------------------------------------------------------------- X* X* Compute the Left and Right Eigenvectors of T X* X* X* Compute the Right eigenvector Matrix: X* X* X NTEST = 9 X RESULT( 9 ) = ULPINV X DO 120 J = 1, N X LWORK( J ) = .TRUE. X 120 CONTINUE X CALL DTREVC( 'R', LWORK, N, T1, LDA, EVECTR, LDU, DUMMA, X $ LDU, N, IN, WORK, IINFO ) X IF( IINFO.NE.0 ) THEN X WRITE( NOUNIT, FMT = 9999 )'DTREVC(R)', IINFO, N, JTYPE, X $ IOLDSD X INFO = ABS( IINFO ) X GO TO 160 X END IF X* X* X* Test 9: | TR - RW | / ( |T| |R| ulp ) X* X CALL DGET22( 'N', 'N', 'N', N, T1, LDA, EVECTR, LDU, WR1, X $ WI1, WORK, DUMMA( 1 ) ) X RESULT( 9 ) = DUMMA( 1 ) X IF( DUMMA( 2 ).GT.THRESH ) THEN X WRITE( NOUNIT, FMT = 9998 )'Right', 'DTREVC', X $ DUMMA( 2 ), N, JTYPE, IOLDSD X END IF X* X* X* X* Compute the Left eigenvector Matrix: X* X* X NTEST = 10 X RESULT( 10 ) = ULPINV X DO 130 J = 1, N X LWORK( J ) = .TRUE. X 130 CONTINUE X CALL DTREVC( 'L', LWORK, N, T1, LDA, DUMMA, LDU, EVECTL, X $ LDU, N, IN, WORK, IINFO ) X IF( IINFO.NE.0 ) THEN X WRITE( NOUNIT, FMT = 9999 )'DTREVC(L)', IINFO, N, JTYPE, X $ IOLDSD X INFO = ABS( IINFO ) X GO TO 160 X END IF X* X* X* Test 10: | LT - WL | / ( |T| |L| ulp ) X* X CALL DGET22( 'Trans', 'N', 'Conj', N, T1, LDA, EVECTL, LDU, X $ WR1, WI1, WORK, DUMMA( 3 ) ) X RESULT( 10 ) = DUMMA( 3 ) X IF( DUMMA( 4 ).GT.THRESH ) THEN X WRITE( NOUNIT, FMT = 9998 )'Left', 'DTREVC', DUMMA( 4 ), X $ N, JTYPE, IOLDSD X END IF X* X*----------------------------------------------------------------------- X* X* X* Call DHSEIN for Right eigenvectors of H, do test 11 X* X NTEST = 11 X RESULT( 11 ) = ULPINV X DO 140 J = 1, N X LWORK( J ) = .TRUE. X 140 CONTINUE X* X CALL DHSEIN( 'R', LWORK, 'N', 'N', N, H, LDA, WR3, WI3, X $ EVECTX, LDU, DUMMA, LDU, N1, IN, WORK, IINFO ) X IF( IINFO.NE.0 ) THEN X WRITE( NOUNIT, FMT = 9999 )'DHSEIN(R)', IINFO, N, JTYPE, X $ IOLDSD X INFO = ABS( IINFO ) X IF( IINFO.LT.0 ) X $ GO TO 160 X ELSE X* X* Test 11: | HX - XW | / ( |H| |X| ulp ) X* X* (from inverse iteration) X* X CALL DGET22( 'N', 'N', 'N', N, H, LDA, EVECTX, LDU, WR3, X $ WI3, WORK, DUMMA( 1 ) ) X IF( DUMMA( 1 ).LT.ULPINV ) X $ RESULT( 11 ) = DUMMA( 1 )*ANINV X IF( DUMMA( 2 ).GT.THRESH ) THEN X WRITE( NOUNIT, FMT = 9998 )'Right', 'DHSEIN', X $ DUMMA( 2 ), N, JTYPE, IOLDSD X END IF X END IF X* X* X* Call DHSEIN for Left eigenvectors of H, do test 12 X* X NTEST = 12 X RESULT( 12 ) = ULPINV X DO 150 J = 1, N X LWORK( J ) = .TRUE. X 150 CONTINUE X* X CALL DHSEIN( 'L', LWORK, 'N', 'N', N, H, LDA, WR3, WI3, X $ DUMMA, LDU, EVECTY, LDU, N1, IN, WORK, IINFO ) X IF( IINFO.NE.0 ) THEN X WRITE( NOUNIT, FMT = 9999 )'DHSEIN(L)', IINFO, N, JTYPE, X $ IOLDSD X INFO = ABS( IINFO ) X IF( IINFO.LT.0 ) X $ GO TO 160 X ELSE X* X* Test 12: | YH - WY | / ( |H| |Y| ulp ) X* X* (from inverse iteration) X* X CALL DGET22( 'C', 'N', 'C', N, H, LDA, EVECTY, LDU, WR3, X $ WI3, WORK, DUMMA( 3 ) ) X IF( DUMMA( 3 ).LT.ULPINV ) X $ RESULT( 12 ) = DUMMA( 3 )*ANINV X IF( DUMMA( 4 ).GT.THRESH ) THEN X WRITE( NOUNIT, FMT = 9998 )'Left', 'DHSEIN', X $ DUMMA( 4 ), N, JTYPE, IOLDSD X END IF X END IF X* X* X*----------------------------------------------------------------------- X* X* End of Loop -- Check for RESULT(j) > THRESH X* X 160 CONTINUE X* X NTESTT = NTESTT + NTEST X CALL DLAFTS( 'DHS', N, N, JTYPE, NTEST, RESULT, IOLDSD, X $ THRESH, NOUNIT, NERRS ) X* X 170 CONTINUE X 180 CONTINUE X* X* Summary X* X CALL DLASUM( 'DHS', NOUNIT, NERRS, NTESTT ) X* X* X*----------------------------------------------------------------------- X* X* X 9999 FORMAT( ' DCHK21: ', A, ' returned INFO=', I6, '.', / 9X, 'N=', X $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' ) X 9998 FORMAT( ' DCHK21: ', A, ' Eigenvectors from ', A, ' incorrectly ', X $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X, X $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, X $ ')' ) X* X RETURN X* X* End of DCHK21 X* X END END_OF_FILE if test 32890 -ne `wc -c <'dchk21.f'`; then echo shar: \"'dchk21.f'\" unpacked with wrong size! fi # end of 'dchk21.f' fi if test -f 'dcopy.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dcopy.f'\" else echo shar: Extracting \"'dcopy.f'\" \(1490 characters\) sed "s/^X//" >'dcopy.f' <<'END_OF_FILE' X SUBROUTINE DCOPY( N, DX, INCX, DY, INCY ) X* X* copies a vector, x, to a vector, y. X* uses unrolled loops for increments equal to one. X* jack dongarra, linpack, 3/11/78. X* X* .. Scalar Arguments .. X INTEGER INCX, INCY, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION DX( 1 ), DY( 1 ) X* .. X* .. Local Scalars .. X INTEGER I, IX, IY, M, MP1 X* .. X* .. Intrinsic Functions .. X INTRINSIC MOD X* .. X* .. Executable Statements .. X* X IF( N.LE.0 ) X $ RETURN X IF( INCX.EQ.1 .AND. INCY.EQ.1 ) X $ GO TO 20 X* X* code for unequal increments or equal increments X* not equal to 1 X* X IX = 1 X IY = 1 X IF( INCX.LT.0 ) X $ IX = ( -N+1 )*INCX + 1 X IF( INCY.LT.0 ) X $ IY = ( -N+1 )*INCY + 1 X DO 10 I = 1, N X DY( IY ) = DX( IX ) X IX = IX + INCX X IY = IY + INCY X 10 CONTINUE X RETURN X* X* code for both increments equal to 1 X* X* X* clean-up loop X* X 20 M = MOD( N, 7 ) X IF( M.EQ.0 ) X $ GO TO 40 X DO 30 I = 1, M X DY( I ) = DX( I ) X 30 CONTINUE X IF( N.LT.7 ) X $ RETURN X 40 MP1 = M + 1 X DO 50 I = MP1, N, 7 X DY( I ) = DX( I ) X DY( I+1 ) = DX( I+1 ) X DY( I+2 ) = DX( I+2 ) X DY( I+3 ) = DX( I+3 ) X DY( I+4 ) = DX( I+4 ) X DY( I+5 ) = DX( I+5 ) X DY( I+6 ) = DX( I+6 ) X 50 CONTINUE X RETURN X END END_OF_FILE if test 1490 -ne `wc -c <'dcopy.f'`; then echo shar: \"'dcopy.f'\" unpacked with wrong size! fi # end of 'dcopy.f' fi if test -f 'ddot.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'ddot.f'\" else echo shar: Extracting \"'ddot.f'\" \(1663 characters\) sed "s/^X//" >'ddot.f' <<'END_OF_FILE' X DOUBLE PRECISION FUNCTION DDOT( N, DX, INCX, DY, INCY ) X* X* forms the dot product of two vectors. X* uses unrolled loops for increments equal to one. X* jack dongarra, linpack, 3/11/78. X* X* .. Scalar Arguments .. X INTEGER INCX, INCY, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION DX( 1 ), DY( 1 ) X* .. X* .. Local Scalars .. X INTEGER I, IX, IY, M, MP1 X DOUBLE PRECISION DTEMP X* .. X* .. Intrinsic Functions .. X INTRINSIC MOD X* .. X* .. Executable Statements .. X* X DDOT = 0.0D0 X DTEMP = 0.0D0 X IF( N.LE.0 ) X $ RETURN X IF( INCX.EQ.1 .AND. INCY.EQ.1 ) X $ GO TO 20 X* X* code for unequal increments or equal increments X* not equal to 1 X* X IX = 1 X IY = 1 X IF( INCX.LT.0 ) X $ IX = ( -N+1 )*INCX + 1 X IF( INCY.LT.0 ) X $ IY = ( -N+1 )*INCY + 1 X DO 10 I = 1, N X DTEMP = DTEMP + DX( IX )*DY( IY ) X IX = IX + INCX X IY = IY + INCY X 10 CONTINUE X DDOT = DTEMP X RETURN X* X* code for both increments equal to 1 X* X* X* clean-up loop X* X 20 M = MOD( N, 5 ) X IF( M.EQ.0 ) X $ GO TO 40 X DO 30 I = 1, M X DTEMP = DTEMP + DX( I )*DY( I ) X 30 CONTINUE X IF( N.LT.5 ) X $ GO TO 60 X 40 MP1 = M + 1 X DO 50 I = MP1, N, 5 X DTEMP = DTEMP + DX( I )*DY( I ) + DX( I+1 )*DY( I+1 ) + X $ DX( I+2 )*DY( I+2 ) + DX( I+3 )*DY( I+3 ) + X $ DX( I+4 )*DY( I+4 ) X 50 CONTINUE X 60 DDOT = DTEMP X RETURN X END END_OF_FILE if test 1663 -ne `wc -c <'ddot.f'`; then echo shar: \"'ddot.f'\" unpacked with wrong size! fi # end of 'ddot.f' fi if test -f 'depslon.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'depslon.f'\" else echo shar: Extracting \"'depslon.f'\" \(1334 characters\) sed "s/^X//" >'depslon.f' <<'END_OF_FILE' X double precision function epslon (x) X double precision x c c estimate unit roundoff in quantities of size x. c X double precision a,b,c,eps c c this program should function properly on all systems c satisfying the following two assumptions, c 1. the base used in representing floating point c numbers is not a power of three. c 2. the quantity a in statement 10 is represented to c the accuracy used in floating point variables c that are stored in memory. c the statement number 10 and the go to 10 are intended to c force optimizing compilers to generate code satisfying c assumption 2. c under these assumptions, it should be true that, c a is not exactly equal to four-thirds, c b has a zero for its last bit or digit, c c is not exactly equal to one, c eps measures the separation of 1.0 from c the next larger floating point number. c the developers of eispack would appreciate being informed c about any systems where these assumptions do not hold. c c this version dated 4/6/83. c X a = 4.0d0/3.0d0 X 10 b = a - 1.0d0 X c = b + b + b X eps = dabs(c-1.0d0) X if (eps .eq. 0.0d0) go to 10 X epslon = eps*dabs(x) X return X end END_OF_FILE if test 1334 -ne `wc -c <'depslon.f'`; then echo shar: \"'depslon.f'\" unpacked with wrong size! fi # end of 'depslon.f' fi if test -f 'dgehd3.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dgehd3.f'\" else echo shar: Extracting \"'dgehd3.f'\" \(10674 characters\) sed "s/^X//" >'dgehd3.f' <<'END_OF_FILE' X SUBROUTINE DGEHD3( JOB, N, A, LDA, U, LDU, S, WORK, LDWORK, NWORK, X $ INFO ) X* X* -- LAPACK routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER JOB X INTEGER INFO, LDA, LDU, LDWORK, N, NWORK X* .. X* X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), X $ WORK( LDWORK, * ) X* .. X* X* Purpose X* ======= X* X* This subroutine reduces an N-by-N real general matrix A to X* upper Hessenberg form, and returns the orthogonal transforma- X* tion matrix if desired. X* X* A will be decomposed as U H U', where U is orthogonal, H is X* upper Hessenberg, and U' denotes the transpose of U. X* X* Arguments X* ========= X* X* JOB - CHARACTER*1 X* JOB specifies the computation to be done by DGEHD3. X* JOB = 'H': return the upper Hessenberg matrix H only. X* JOB = 'Q': return both the upper Hessenberg matrix H X* and the orthogonal matrix U. X* Not modified. X* X* N - INTEGER X* N specifies the order of the matrix A. X* N must be at least zero. X* Not modified. X* X* A - DOUBLE PRECISION array, dimension (LDA,N) X* On entry, A specifies the array which contains the matrix X* being reduced. X* On exit, the array A is overwritten by its Hessenberg form. X* X* LDA - INTEGER X* LDA specifies the first dimension of A as X* declared in the calling (sub)program. LDA must be at X* least max(1, N). X* Not modified. X* X* U - DOUBLE PRECISION array, dimension (LDU,N) X* If JOB='Q', then on exit, the N-by-N matrix U will contain X* the orthogonal matrix U used to reduce A to Hessenberg form. X* If JOB = 'H', U is not referenced. X* X* LDU - INTEGER X* LDU specifies the first dimensiion of U as declared in X* the calling (sub)program. LDU must be at least max(1, N). X* If JOB = 'H', U is not referenced. X* Not modified. X* X* S - DOUBLE PRECISION array, dimension (N). X* Workspace. If JOB = 'H', S is not referenced. X* X* WORK - DOUBLE PRECISION array, dimension (LDWORK,NWORK) X* Workspace. X* X* LDWORK - INTEGER X* LDWORK specifies the first dimension of WORK as X* declared in the calling (sub)program. LDWORK must be at X* least max(1, N). X* Not modified. X* X* NWORK - INTEGER X* NWORK specifies the number of columns in WORK. X* NWORK must be at least 4, and should be at least 3*NB+1, X* where NB is the blocksize as returned by the routine ENVIR. X* Not modified. X* X* INFO - INTEGER X* On exit, INFO is set to X* 0 normal return. X* -k if input argument number k is illegal. X* X* Internal parameters which may be modified by the user X* ===================================================== X* X* NB - INTEGER X* NB specifies the block size. It is normally gotten X* by a call to the subroutine ENVIR. X* Not modified. X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE X PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) X* .. X* X* .. Local Scalars .. X INTEGER I, IFST, IJOB, ILST, IRES, J, JIFST, JK, JS, X $ JS1, KB, LS, LS3, M, NB, NBL, NN, NNB X DOUBLE PRECISION DELTA, TAU X* .. X* X* .. External Functions .. X LOGICAL LSAME X DOUBLE PRECISION DDOT X EXTERNAL LSAME, DDOT X* .. X* X* .. External Subroutines .. X EXTERNAL ENVIR, DAXPY, DGEMM, DGEMV, DLARFG, DLAZRO, X $ DORGC3, DSCAL, XERBLA X* .. X* X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN, MOD X* .. X* X* .. Executable Statements .. X* X* See "Block Reduction of Matrices to condensed Forms for X* Eigenvalue Computation" by J. Dongarra, S. Hammarling and X* D. Sorensen, LAPACK Working Note #2, and "On a Block X* Implementation of the Hessenberg Multishift QR Iteration" X* by Z. Bai and J. Demmel, LAPACK Working Note #8 for a X* detailed description of the algorithm. X* X* Decode and Test the input parameters X* X IF( LSAME( JOB, 'H' ) ) THEN X IJOB = 1 X ELSE IF( LSAME( JOB, 'Q' ) ) THEN X IJOB = 2 X ELSE X IJOB = -1 X END IF X* X INFO = 0 X IF( IJOB.EQ.-1 ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( LDA.LT.MAX( 1, N ) ) THEN X INFO = -4 X ELSE IF( LDWORK.LT.MAX( 1, N ) ) THEN X INFO = -8 X END IF X IF( IJOB.EQ.2 ) THEN X IF( LDU.LT.MAX( 1, N ) ) X $ INFO = -6 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DGEHD3', -INFO ) X RETURN X END IF X* X* Initialize U, if desired. X* X IF( IJOB.EQ.2 ) THEN X CALL DLAZRO( N, N, ZERO, ZERO, U, LDU ) X END IF X* X* Quick return if possible. X* X IF( N.LE.2 ) X $ GO TO 130 X* X* Get block sizes. X* X CALL ENVIR( 'BLOCK', NB ) X NBL = MIN( NB, N-2, ( NWORK-1 ) / 3 ) X* X* Determine the number of blocks: NNB X* X IRES = MOD( N-2, NBL ) X NNB = ( N-2 ) / NBL X NN = NNB X IF( IRES.NE.0 ) X $ NNB = NNB + 1 X* X* Outer loop in block updating X* X DO 100 KB = 1, NNB X* X* Determine the first column index IFST and the X* last column index ILST of the KBth block. X* X IFST = ( KB-1 )*NBL + 1 X ILST = IFST + NBL - 1 X IF( KB.EQ.NN+1 ) X $ ILST = N - 2 X LS = ILST - IFST + 1 X LS3 = 3*LS + 1 X* X* Initialize working array WORK. Note that in the working X* array WORK: WORK(*,1:LS) store V; WORK(*,LS+1:2*LS) X* store W and WORK(*,1+2*LS:3*LS) store U as described in X* the above papers. On each block, matrix A will be X* updated as X* A = A - U*V' - W*U' X* X DO 40 J = 1, LS X DO 10 I = IFST, N X WORK( I, J ) = ZERO X 10 CONTINUE X DO 20 I = 1, N X WORK( I, J+LS ) = ZERO X 20 CONTINUE X DO 30 I = IFST, N X WORK( I, J+2*LS ) = ZERO X 30 CONTINUE X 40 CONTINUE X* X* Inner loop in each block X* X DO 90 JK = IFST, ILST X* X* form the JKth column. X* X JIFST = JK - IFST + 1 + 2*LS X DO 50 I = JK + 1, N X WORK( I, JIFST ) = A( I, JK ) X 50 CONTINUE X* X DO 70 J = IFST, JK - 1 X DO 60 I = JK + 1, N X WORK( I, JIFST ) = WORK( I, JIFST ) - X $ WORK( JK, J-IFST+1 )* X $ WORK( I, J-IFST+1+2*LS ) - X $ WORK( JK, J-IFST+1+2*LS )* X $ WORK( I, J-IFST+1+LS ) X 60 CONTINUE X 70 CONTINUE X* X* Compute Householder transformation for column JK: X* X CALL DLARFG( N-JK, WORK( JK+1, JIFST ), WORK( JK+2, JIFST ), X $ 1, TAU ) X WORK( JK+1, JIFST ) = ONE X* X IF( IJOB.EQ.2 ) THEN X DO 80 I = JK + 1, N X U( I, JK ) = WORK( I, JIFST ) X 80 CONTINUE X S( JK ) = TAU X END IF X* X* Aggregate the transformation vectors in inner loop. X* X* A'*uj - V*U'*uj - U*W'*uj --> vj X* X JS = JK - IFST X JS1 = JS + 1 X CALL DGEMV( 'T', N-JK, JS, ONE, WORK( JK+1, 1+LS ), LDWORK, X $ WORK( JK+1, JIFST ), 1, ZERO, WORK( 1, LS3 ), X $ 1 ) X* X CALL DGEMV( 'N', N-IFST, JS, ONE, WORK( IFST+1, 1+2*LS ), X $ LDWORK, WORK( 1, LS3 ), 1, ZERO, X $ WORK( IFST+1, JS1 ), 1 ) X* X CALL DGEMV( 'T', N-JK, JS, ONE, WORK( JK+1, 1+2*LS ), X $ LDWORK, WORK( JK+1, JIFST ), 1, ZERO, X $ WORK( 1, LS3 ), 1 ) X* X CALL DGEMV( 'N', N-IFST+1, JS, ONE, WORK( IFST, 1 ), LDWORK, X $ WORK( 1, LS3 ), 1, ONE, WORK( IFST, JS1 ), 1 ) X* X CALL DGEMV( 'T', N-JK, N-IFST+1, ONE, A( JK+1, IFST ), LDA, X $ WORK( JK+1, JIFST ), 1, -ONE, WORK( IFST, JS1 ), X $ 1 ) X* X* A*uj - U*V'*uj - W*U'*uj --> wj X* X CALL DGEMV( 'N', N, JS, ONE, WORK( 1, LS+1 ), LDWORK, X $ WORK( 1, LS3 ), 1, ZERO, WORK( 1, JS1+LS ), 1 ) X* X CALL DGEMV( 'T', N-JK, JS, ONE, WORK( JK+1, 1 ), LDWORK, X $ WORK( JK+1, JIFST ), 1, ZERO, WORK( 1, LS3 ), X $ 1 ) X* X CALL DGEMV( 'N', N-IFST, JS, ONE, WORK( IFST+1, 1+2*LS ), X $ LDWORK, WORK( 1, LS3 ), 1, ONE, X $ WORK( IFST+1, JS1+LS ), 1 ) X* X CALL DGEMV( 'N', N, N-JK, ONE, A( 1, JK+1 ), LDA, X $ WORK( JK+1, JIFST ), 1, -ONE, WORK( 1, JS1+LS ), X $ 1 ) X* X DELTA = DDOT( N-JK, WORK( JK+1, JS1+LS ), 1, X $ WORK( JK+1, JIFST ), 1 ) X CALL DAXPY( N-JK, -TAU*DELTA, WORK( JK+1, JIFST ), 1, X $ WORK( JK+1, JS1 ), 1 ) X* X CALL DSCAL( N-IFST+1, TAU, WORK( IFST, JS1 ), 1 ) X CALL DSCAL( N, TAU, WORK( 1, JS1+LS ), 1 ) X* X 90 CONTINUE X* X* The end of inner JK loop X* X* Row block updating: X* A = A(IFST+1:N,IFST:N) - U*V' X* X CALL DGEMM( 'N', 'T', N-IFST, N-IFST+1, LS, -ONE, X $ WORK( IFST+1, 1+2*LS ), LDWORK, WORK( IFST, 1 ), X $ LDWORK, ONE, A( IFST+1, IFST ), LDA ) X* X* Column block updating: X* A = A(1:N,IFST+1:N) - W*U' X* X CALL DGEMM( 'N', 'T', N, N-IFST, LS, -ONE, WORK( 1, 1+LS ), X $ LDWORK, WORK( IFST+1, 1+2*LS ), LDWORK, ONE, X $ A( 1, IFST+1 ), LDA ) X* X 100 CONTINUE X* X* Clean up X* X DO 120 J = 1, N - 2 X DO 110 I = J + 2, N X A( I, J ) = ZERO X 110 CONTINUE X 120 CONTINUE X* X* Form orthogonal transformation if desired. X* X 130 CONTINUE X IF( IJOB.EQ.2 ) THEN X M = MAX( N-2, 0 ) X CALL DORGC3( N, M, U, LDU, S, WORK, INFO ) X END IF X* X RETURN X* X* End of DGEHD3 X* X END END_OF_FILE if test 10674 -ne `wc -c <'dgehd3.f'`; then echo shar: \"'dgehd3.f'\" unpacked with wrong size! fi # end of 'dgehd3.f' fi if test -f 'dgemm.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dgemm.f'\" else echo shar: Extracting \"'dgemm.f'\" \(9851 characters\) sed "s/^X//" >'dgemm.f' <<'END_OF_FILE' X SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, X $ BETA, C, LDC ) X* .. Scalar Arguments .. X CHARACTER*1 TRANSA, TRANSB X INTEGER M, N, K, LDA, LDB, LDC X DOUBLE PRECISION ALPHA, BETA X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) X* .. X* X* Purpose X* ======= X* X* DGEMM performs one of the matrix-matrix operations X* X* C := alpha*op( A )*op( B ) + beta*C, X* X* where op( X ) is one of X* X* op( X ) = X or op( X ) = X', X* X* alpha and beta are scalars, and A, B and C are matrices, with op( A ) X* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. X* X* Parameters X* ========== X* X* TRANSA - CHARACTER*1. X* On entry, TRANSA specifies the form of op( A ) to be used in X* the matrix multiplication as follows: X* X* TRANSA = 'N' or 'n', op( A ) = A. X* X* TRANSA = 'T' or 't', op( A ) = A'. X* X* TRANSA = 'C' or 'c', op( A ) = A'. X* X* Unchanged on exit. X* X* TRANSB - CHARACTER*1. X* On entry, TRANSB specifies the form of op( B ) to be used in X* the matrix multiplication as follows: X* X* TRANSB = 'N' or 'n', op( B ) = B. X* X* TRANSB = 'T' or 't', op( B ) = B'. X* X* TRANSB = 'C' or 'c', op( B ) = B'. X* X* Unchanged on exit. X* X* M - INTEGER. X* On entry, M specifies the number of rows of the matrix X* op( A ) and of the matrix C. M must be at least zero. X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the number of columns of the matrix X* op( B ) and the number of columns of the matrix C. N must be X* at least zero. X* Unchanged on exit. X* X* K - INTEGER. X* On entry, K specifies the number of columns of the matrix X* op( A ) and the number of rows of the matrix op( B ). K must X* be at least zero. X* Unchanged on exit. X* X* ALPHA - DOUBLE PRECISION. X* On entry, ALPHA specifies the scalar alpha. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is X* k when TRANSA = 'N' or 'n', and is m otherwise. X* Before entry with TRANSA = 'N' or 'n', the leading m by k X* part of the array A must contain the matrix A, otherwise X* the leading k by m part of the array A must contain the X* matrix A. X* Unchanged on exit. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. When TRANSA = 'N' or 'n' then X* LDA must be at least max( 1, m ), otherwise LDA must be at X* least max( 1, k ). X* Unchanged on exit. X* X* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is X* n when TRANSB = 'N' or 'n', and is k otherwise. X* Before entry with TRANSB = 'N' or 'n', the leading k by n X* part of the array B must contain the matrix B, otherwise X* the leading n by k part of the array B must contain the X* matrix B. X* Unchanged on exit. X* X* LDB - INTEGER. X* On entry, LDB specifies the first dimension of B as declared X* in the calling (sub) program. When TRANSB = 'N' or 'n' then X* LDB must be at least max( 1, k ), otherwise LDB must be at X* least max( 1, n ). X* Unchanged on exit. X* X* BETA - DOUBLE PRECISION. X* On entry, BETA specifies the scalar beta. When BETA is X* supplied as zero then C need not be set on input. X* Unchanged on exit. X* X* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). X* Before entry, the leading m by n part of the array C must X* contain the matrix C, except when beta is zero, in which X* case C need not be set on entry. X* On exit, the array C is overwritten by the m by n matrix X* ( alpha*op( A )*op( B ) + beta*C ). X* X* LDC - INTEGER. X* On entry, LDC specifies the first dimension of C as declared X* in the calling (sub) program. LDC must be at least X* max( 1, m ). X* Unchanged on exit. X* X* X* Level 3 Blas routine. X* X* -- Written on 8-February-1989. X* Jack Dongarra, Argonne National Laboratory. X* Iain Duff, AERE Harwell. X* Jeremy Du Croz, Numerical Algorithms Group Ltd. X* Sven Hammarling, Numerical Algorithms Group Ltd. X* X* X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. Local Scalars .. X LOGICAL NOTA, NOTB X INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB X DOUBLE PRECISION TEMP X* .. Parameters .. X DOUBLE PRECISION ONE , ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Executable Statements .. X* X* Set NOTA and NOTB as true if A and B respectively are not X* transposed and set NROWA, NCOLA and NROWB as the number of rows X* and columns of A and the number of rows of B respectively. X* X NOTA = LSAME( TRANSA, 'N' ) X NOTB = LSAME( TRANSB, 'N' ) X IF( NOTA )THEN X NROWA = M X NCOLA = K X ELSE X NROWA = K X NCOLA = M X END IF X IF( NOTB )THEN X NROWB = K X ELSE X NROWB = N X END IF X* X* Test the input parameters. X* X INFO = 0 X IF( ( .NOT.NOTA ).AND. X $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. X $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN X INFO = 1 X ELSE IF( ( .NOT.NOTB ).AND. X $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. X $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN X INFO = 2 X ELSE IF( M .LT.0 )THEN X INFO = 3 X ELSE IF( N .LT.0 )THEN X INFO = 4 X ELSE IF( K .LT.0 )THEN X INFO = 5 X ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN X INFO = 8 X ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN X INFO = 10 X ELSE IF( LDC.LT.MAX( 1, M ) )THEN X INFO = 13 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DGEMM ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. X $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) X $ RETURN X* X* And if alpha.eq.zero. X* X IF( ALPHA.EQ.ZERO )THEN X IF( BETA.EQ.ZERO )THEN X DO 20, J = 1, N X DO 10, I = 1, M X C( I, J ) = ZERO X 10 CONTINUE X 20 CONTINUE X ELSE X DO 40, J = 1, N X DO 30, I = 1, M X C( I, J ) = BETA*C( I, J ) X 30 CONTINUE X 40 CONTINUE X END IF X RETURN X END IF X* X* Start the operations. X* X IF( NOTB )THEN X IF( NOTA )THEN X* X* Form C := alpha*A*B + beta*C. X* X DO 90, J = 1, N X IF( BETA.EQ.ZERO )THEN X DO 50, I = 1, M X C( I, J ) = ZERO X 50 CONTINUE X ELSE IF( BETA.NE.ONE )THEN X DO 60, I = 1, M X C( I, J ) = BETA*C( I, J ) X 60 CONTINUE X END IF X DO 80, L = 1, K X IF( B( L, J ).NE.ZERO )THEN X TEMP = ALPHA*B( L, J ) X DO 70, I = 1, M X C( I, J ) = C( I, J ) + TEMP*A( I, L ) X 70 CONTINUE X END IF X 80 CONTINUE X 90 CONTINUE X ELSE X* X* Form C := alpha*A'*B + beta*C X* X DO 120, J = 1, N X DO 110, I = 1, M X TEMP = ZERO X DO 100, L = 1, K X TEMP = TEMP + A( L, I )*B( L, J ) X 100 CONTINUE X IF( BETA.EQ.ZERO )THEN X C( I, J ) = ALPHA*TEMP X ELSE X C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) X END IF X 110 CONTINUE X 120 CONTINUE X END IF X ELSE X IF( NOTA )THEN X* X* Form C := alpha*A*B' + beta*C X* X DO 170, J = 1, N X IF( BETA.EQ.ZERO )THEN X DO 130, I = 1, M X C( I, J ) = ZERO X 130 CONTINUE X ELSE IF( BETA.NE.ONE )THEN X DO 140, I = 1, M X C( I, J ) = BETA*C( I, J ) X 140 CONTINUE X END IF X DO 160, L = 1, K X IF( B( J, L ).NE.ZERO )THEN X TEMP = ALPHA*B( J, L ) X DO 150, I = 1, M X C( I, J ) = C( I, J ) + TEMP*A( I, L ) X 150 CONTINUE X END IF X 160 CONTINUE X 170 CONTINUE X ELSE X* X* Form C := alpha*A'*B' + beta*C X* X DO 200, J = 1, N X DO 190, I = 1, M X TEMP = ZERO X DO 180, L = 1, K X TEMP = TEMP + A( L, I )*B( J, L ) X 180 CONTINUE X IF( BETA.EQ.ZERO )THEN X C( I, J ) = ALPHA*TEMP X ELSE X C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) X END IF X 190 CONTINUE X 200 CONTINUE X END IF X END IF X* X RETURN X* X* End of DGEMM . X* X END END_OF_FILE if test 9851 -ne `wc -c <'dgemm.f'`; then echo shar: \"'dgemm.f'\" unpacked with wrong size! fi # end of 'dgemm.f' fi if test -f 'dgemv.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dgemv.f'\" else echo shar: Extracting \"'dgemv.f'\" \(7481 characters\) sed "s/^X//" >'dgemv.f' <<'END_OF_FILE' X SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, X $ BETA, Y, INCY ) X* .. Scalar Arguments .. X DOUBLE PRECISION ALPHA, BETA X INTEGER INCX, INCY, LDA, M, N X CHARACTER*1 TRANS X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) X* .. X* X* Purpose X* ======= X* X* DGEMV performs one of the matrix-vector operations X* X* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, X* X* where alpha and beta are scalars, x and y are vectors and A is an X* m by n matrix. X* X* Parameters X* ========== X* X* TRANS - CHARACTER*1. X* On entry, TRANS specifies the operation to be performed as X* follows: X* X* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. X* X* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. X* X* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. X* X* Unchanged on exit. X* X* M - INTEGER. X* On entry, M specifies the number of rows of the matrix A. X* M must be at least zero. X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the number of columns of the matrix A. X* N must be at least zero. X* Unchanged on exit. X* X* ALPHA - DOUBLE PRECISION. X* On entry, ALPHA specifies the scalar alpha. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). X* Before entry, the leading m by n part of the array A must X* contain the matrix of coefficients. X* Unchanged on exit. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least X* max( 1, m ). X* Unchanged on exit. X* X* X - DOUBLE PRECISION array of DIMENSION at least X* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' X* and at least X* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. X* Before entry, the incremented array X must contain the X* vector x. X* Unchanged on exit. X* X* INCX - INTEGER. X* On entry, INCX specifies the increment for the elements of X* X. INCX must not be zero. X* Unchanged on exit. X* X* BETA - DOUBLE PRECISION. X* On entry, BETA specifies the scalar beta. When BETA is X* supplied as zero then Y need not be set on input. X* Unchanged on exit. X* X* Y - DOUBLE PRECISION array of DIMENSION at least X* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' X* and at least X* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. X* Before entry with BETA non-zero, the incremented array Y X* must contain the vector y. On exit, Y is overwritten by the X* updated vector y. X* X* INCY - INTEGER. X* On entry, INCY specifies the increment for the elements of X* Y. INCY must not be zero. X* Unchanged on exit. X* X* X* Level 2 Blas routine. X* X* -- Written on 22-October-1986. X* Jack Dongarra, Argonne National Lab. X* Jeremy Du Croz, Nag Central Office. X* Sven Hammarling, Nag Central Office. X* Richard Hanson, Sandia National Labs. X* X* X* .. Parameters .. X DOUBLE PRECISION ONE , ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. Local Scalars .. X DOUBLE PRECISION TEMP X INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF ( .NOT.LSAME( TRANS, 'N' ).AND. X $ .NOT.LSAME( TRANS, 'T' ).AND. X $ .NOT.LSAME( TRANS, 'C' ) )THEN X INFO = 1 X ELSE IF( M.LT.0 )THEN X INFO = 2 X ELSE IF( N.LT.0 )THEN X INFO = 3 X ELSE IF( LDA.LT.MAX( 1, M ) )THEN X INFO = 6 X ELSE IF( INCX.EQ.0 )THEN X INFO = 8 X ELSE IF( INCY.EQ.0 )THEN X INFO = 11 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DGEMV ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. X $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) X $ RETURN X* X* Set LENX and LENY, the lengths of the vectors x and y, and set X* up the start points in X and Y. X* X IF( LSAME( TRANS, 'N' ) )THEN X LENX = N X LENY = M X ELSE X LENX = M X LENY = N X END IF X IF( INCX.GT.0 )THEN X KX = 1 X ELSE X KX = 1 - ( LENX - 1 )*INCX X END IF X IF( INCY.GT.0 )THEN X KY = 1 X ELSE X KY = 1 - ( LENY - 1 )*INCY X END IF X* X* Start the operations. In this version the elements of A are X* accessed sequentially with one pass through A. X* X* First form y := beta*y. X* X IF( BETA.NE.ONE )THEN X IF( INCY.EQ.1 )THEN X IF( BETA.EQ.ZERO )THEN X DO 10, I = 1, LENY X Y( I ) = ZERO X 10 CONTINUE X ELSE X DO 20, I = 1, LENY X Y( I ) = BETA*Y( I ) X 20 CONTINUE X END IF X ELSE X IY = KY X IF( BETA.EQ.ZERO )THEN X DO 30, I = 1, LENY X Y( IY ) = ZERO X IY = IY + INCY X 30 CONTINUE X ELSE X DO 40, I = 1, LENY X Y( IY ) = BETA*Y( IY ) X IY = IY + INCY X 40 CONTINUE X END IF X END IF X END IF X IF( ALPHA.EQ.ZERO ) X $ RETURN X IF( LSAME( TRANS, 'N' ) )THEN X* X* Form y := alpha*A*x + y. X* X JX = KX X IF( INCY.EQ.1 )THEN X DO 60, J = 1, N X IF( X( JX ).NE.ZERO )THEN X TEMP = ALPHA*X( JX ) X DO 50, I = 1, M X Y( I ) = Y( I ) + TEMP*A( I, J ) X 50 CONTINUE X END IF X JX = JX + INCX X 60 CONTINUE X ELSE X DO 80, J = 1, N X IF( X( JX ).NE.ZERO )THEN X TEMP = ALPHA*X( JX ) X IY = KY X DO 70, I = 1, M X Y( IY ) = Y( IY ) + TEMP*A( I, J ) X IY = IY + INCY X 70 CONTINUE X END IF X JX = JX + INCX X 80 CONTINUE X END IF X ELSE X* X* Form y := alpha*A'*x + y. X* X JY = KY X IF( INCX.EQ.1 )THEN X DO 100, J = 1, N X TEMP = ZERO X DO 90, I = 1, M X TEMP = TEMP + A( I, J )*X( I ) X 90 CONTINUE X Y( JY ) = Y( JY ) + ALPHA*TEMP X JY = JY + INCY X 100 CONTINUE X ELSE X DO 120, J = 1, N X TEMP = ZERO X IX = KX X DO 110, I = 1, M X TEMP = TEMP + A( I, J )*X( IX ) X IX = IX + INCX X 110 CONTINUE X Y( JY ) = Y( JY ) + ALPHA*TEMP X JY = JY + INCY X 120 CONTINUE X END IF X END IF X* X RETURN X* X* End of DGEMV . X* X END END_OF_FILE if test 7481 -ne `wc -c <'dgemv.f'`; then echo shar: \"'dgemv.f'\" unpacked with wrong size! fi # end of 'dgemv.f' fi if test -f 'dger.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dger.f'\" else echo shar: Extracting \"'dger.f'\" \(4366 characters\) sed "s/^X//" >'dger.f' <<'END_OF_FILE' X SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) X* .. Scalar Arguments .. X DOUBLE PRECISION ALPHA X INTEGER INCX, INCY, LDA, M, N X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) X* .. X* X* Purpose X* ======= X* X* DGER performs the rank 1 operation X* X* A := alpha*x*y' + A, X* X* where alpha is a scalar, x is an m element vector, y is an n element X* vector and A is an m by n matrix. X* X* Parameters X* ========== X* X* M - INTEGER. X* On entry, M specifies the number of rows of the matrix A. X* M must be at least zero. X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the number of columns of the matrix A. X* N must be at least zero. X* Unchanged on exit. X* X* ALPHA - DOUBLE PRECISION. X* On entry, ALPHA specifies the scalar alpha. X* Unchanged on exit. X* X* X - DOUBLE PRECISION array of dimension at least X* ( 1 + ( m - 1 )*abs( INCX ) ). X* Before entry, the incremented array X must contain the m X* element vector x. X* Unchanged on exit. X* X* INCX - INTEGER. X* On entry, INCX specifies the increment for the elements of X* X. INCX must not be zero. X* Unchanged on exit. X* X* Y - DOUBLE PRECISION array of dimension at least X* ( 1 + ( n - 1 )*abs( INCY ) ). X* Before entry, the incremented array Y must contain the n X* element vector y. X* Unchanged on exit. X* X* INCY - INTEGER. X* On entry, INCY specifies the increment for the elements of X* Y. INCY must not be zero. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). X* Before entry, the leading m by n part of the array A must X* contain the matrix of coefficients. On exit, A is X* overwritten by the updated matrix. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least X* max( 1, m ). X* Unchanged on exit. X* X* X* Level 2 Blas routine. X* X* -- Written on 22-October-1986. X* Jack Dongarra, Argonne National Lab. X* Jeremy Du Croz, Nag Central Office. X* Sven Hammarling, Nag Central Office. X* Richard Hanson, Sandia National Labs. X* X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D+0 ) X* .. Local Scalars .. X DOUBLE PRECISION TEMP X INTEGER I, INFO, IX, J, JY, KX X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF ( M.LT.0 )THEN X INFO = 1 X ELSE IF( N.LT.0 )THEN X INFO = 2 X ELSE IF( INCX.EQ.0 )THEN X INFO = 5 X ELSE IF( INCY.EQ.0 )THEN X INFO = 7 X ELSE IF( LDA.LT.MAX( 1, M ) )THEN X INFO = 9 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DGER ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) X $ RETURN X* X* Start the operations. In this version the elements of A are X* accessed sequentially with one pass through A. X* X IF( INCY.GT.0 )THEN X JY = 1 X ELSE X JY = 1 - ( N - 1 )*INCY X END IF X IF( INCX.EQ.1 )THEN X DO 20, J = 1, N X IF( Y( JY ).NE.ZERO )THEN X TEMP = ALPHA*Y( JY ) X DO 10, I = 1, M X A( I, J ) = A( I, J ) + X( I )*TEMP X 10 CONTINUE X END IF X JY = JY + INCY X 20 CONTINUE X ELSE X IF( INCX.GT.0 )THEN X KX = 1 X ELSE X KX = 1 - ( M - 1 )*INCX X END IF X DO 40, J = 1, N X IF( Y( JY ).NE.ZERO )THEN X TEMP = ALPHA*Y( JY ) X IX = KX X DO 30, I = 1, M X A( I, J ) = A( I, J ) + X( IX )*TEMP X IX = IX + INCX X 30 CONTINUE X END IF X JY = JY + INCY X 40 CONTINUE X END IF X* X RETURN X* X* End of DGER . X* X END END_OF_FILE if test 4366 -ne `wc -c <'dger.f'`; then echo shar: \"'dger.f'\" unpacked with wrong size! fi # end of 'dger.f' fi if test -f 'dget21.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dget21.f'\" else echo shar: Extracting \"'dget21.f'\" \(8295 characters\) sed "s/^X//" >'dget21.f' <<'END_OF_FILE' X SUBROUTINE DGET21( ITYPE, N, A, LDA, B, LDB, U, LDU, TAU, WORK, X $ RESULT ) X* X* -- LAPACK test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X* X INTEGER ITYPE, LDA, LDB, LDU, N X* .. X* X* .. Array Arguments .. X* X DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RESULT( * ), X $ TAU( * ), U( LDU, * ), WORK( * ) X* .. X* X*----------------------------------------------------------------------- X* X* Purpose X* ======= X* X* DGET21 generally checks a decomposition of the form X* X* A = U B U' X* X* where ' means transpose and U is orthogonal. If ITYPE=1, X* then U is represented as a dense matrix, otherwise the X* U is expressed as a product of Householder transformations, X* whose vectors are stored in the array "U" and whose scaling X* constants are in "TAU". X* X* Specifically, if ITYPE=1 or 3, then: X* X* RESULT(1) = | A - U B U' | / ( |A| n ulp ) X* X* If ITYPE=2, then: X* X* RESULT(1) = | A - B | / ( |A| n ulp ) X* X* If ITYPE=4, then: X* X* RESULT(1) = | I - BU' | / ( n ulp ) X* X* If ITYPE=1, then a second check is performed: X* X* RESULT(2) = | I - UU' | / ( n ulp ) X* X* otherwise, RESULT(2) is not modified. X* X* X* For ITYPE > 1, the transformation U is expressed as a product X* U = H(1)...H(n-2), where H(j) = I - tau(j) v(j) v(j)' X* and each vector v(j) has its first j elements 0, the (j+1)st X* assumed to be 1, and the remaining n-1-j elements stored in X* U(n-1-j:n,j). X* X* Arguments X* ========== X* X* ITYPE - INTEGER X* Specifies the type of tests to be performed. X* 1: U expressed as a dense orthogonal matrix: X* RESULT(1) = | A - U B U' | / ( |A| n ulp ) *and* X* RESULT(2) = | I - UU' | / ( n ulp ) X* X* 2: RESULT(1) = | A - B | / ( |A| n ulp ) X* X* 3: U expressed as a product of Housholder transformations: X* RESULT(1) = | A - U B U' | / ( |A| n ulp ) X* X* 4: U expressed as a product of Housholder transformations: X* RESULT(1) = | I - BU' | / ( n ulp ) X* X* N - INTEGER X* The size of the matrix. If it is zero, DGET21 does nothing. X* It must be at least zero. X* Not modified. X* X* A - DOUBLE PRECISION array of dimension ( LDA , N ) X* The original (unfactored) matrix. X* Not referenced if ITYPE=4. X* Not modified. X* X* LDA - INTEGER X* The leading dimension of A. It must be at least 1 X* and at least N. X* Not modified. X* X* B - DOUBLE PRECISION array of dimension ( LDB , N ) X* The factored matrix. X* Not modified. X* X* LDB - INTEGER X* The leading dimension of B. It must be at least 1 X* and at least N. X* Not modified. X* X* U - DOUBLE PRECISION array of dimension ( LDU, N ). X* The orthogonal matrix in the decomposition. If ITYPE=1, X* then it is just the matrix, otherwise the lower triangle X* contains the Householder vectors used to describe U. X* Not referenced if ITYPE=2 X* Not modified. X* X* LDU - INTEGER X* The leading dimension of U. LDU must be at least N and X* at least 1. X* Not modified. X* X* TAU - DOUBLE PRECISION array of dimension ( N ) X* If ITYPE > 2, then TAU(j) is the scalar factor of X* v(j) v(j)' in the Householder transformation H(j) of X* the product U = H(1)...H(n-2) X* If ITYPE <= 2, then TAU is not referenced. X* Not modified. X* X* WORK - DOUBLE PRECISION array of dimension ( 2*N**2 ) X* Workspace. X* Modified. X* X* RESULT - DOUBLE PRECISION array of dimension ( 2 ) X* The values computed by the two tests described above. The X* values are currently limited to 1/ulp, to avoid overflow. X* Errors are flagged by RESULT(1)=10/ulp. X* RESULT(1) is always modified. RESULT(2) is modified only X* if ITYPE=1. X* Modified. X* X*----------------------------------------------------------------------- X* X* X* .. Parameters .. X* X DOUBLE PRECISION ZERO, ONE, TEN X PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 ) X* .. X* X* .. Local Scalars .. X* X INTEGER IINFO, JCOL, JDIAG, JROW X DOUBLE PRECISION ANORM, ULP, UNFL, WNORM X* .. X* X* .. External Functions .. X* X DOUBLE PRECISION DLAMCH, DLANGE X EXTERNAL DLAMCH, DLANGE X* .. X* X* .. External Subroutines .. X* X EXTERNAL DGEMM, DLACPY, DORMC2 X* .. X* X* .. Intrinsic Functions .. X* X INTRINSIC DBLE, MAX, MIN X* .. X* X* X*----------------------------------------------------------------------- X* .. Executable Statements .. X* X RESULT( 1 ) = ZERO X IF( ITYPE.EQ.1 ) X $ RESULT( 2 ) = ZERO X IF( N.LE.0 ) X $ RETURN X* X* Constants X* X UNFL = DLAMCH( 'Safe minimum' ) X ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) X* X* Some Error Checks X* X IF( ITYPE.LT.1 .OR. ITYPE.GT.4 ) THEN X RESULT( 1 ) = TEN / ULP X RETURN X END IF X* X*----------------------------------------------------------------------- X* X* X* Do Test 1 X* X* Norm of A: X* X IF( ITYPE.EQ.4 ) THEN X ANORM = ONE X ELSE X ANORM = MAX( DLANGE( '1', N, N, A, LDA, WORK ), UNFL ) X END IF X* X* Norm of A - UBU' X* X IF( ITYPE.EQ.1 ) THEN X CALL DLACPY( ' ', N, N, A, LDA, WORK, N ) X CALL DGEMM( 'N', 'N', N, N, N, ONE, U, LDU, B, LDB, ZERO, X $ WORK( N**2+1 ), N ) X* X CALL DGEMM( 'N', 'C', N, N, N, -ONE, WORK( N**2+1 ), N, U, LDU, X $ ONE, WORK, N ) X* X ELSE X CALL DLACPY( ' ', N, N, B, LDB, WORK, N ) X* X IF( ITYPE.GE.3 .AND. N.GE.2 ) THEN X CALL DORMC2( 'R', 'T', N, N-1, N-1, U( 2, 1 ), LDU, TAU, X $ WORK( N+1 ), N, WORK( N**2+1 ), IINFO ) X IF( IINFO.NE.0 ) THEN X RESULT( 1 ) = TEN / ULP X RETURN X END IF X* X IF( ITYPE.EQ.3 ) THEN X CALL DORMC2( 'L', 'N', N-1, N, N-1, U( 2, 1 ), LDU, TAU, X $ WORK( 2 ), N, WORK( N**2+1 ), IINFO ) X IF( IINFO.NE.0 ) THEN X RESULT( 1 ) = TEN / ULP X RETURN X END IF X END IF X END IF X* X IF( ITYPE.LT.4 ) THEN X DO 20 JCOL = 1, N X DO 10 JROW = 1, N X WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) ) X $ - A( JROW, JCOL ) X 10 CONTINUE X 20 CONTINUE X ELSE X DO 30 JDIAG = 1, N X WORK( ( N+1 )*( JDIAG-1 )+1 ) = WORK( ( N+1 )* X $ ( JDIAG-1 )+1 ) - ONE X 30 CONTINUE X END IF X END IF X* X WNORM = DLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) ) X* X IF( ANORM.GT.WNORM ) THEN X RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP ) X ELSE X IF( ANORM.LT.ONE ) THEN X RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP ) X ELSE X RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP ) X END IF X END IF X* X* . . . . . . . . . . . . . . X* X* Do Test 2 X* X* Compute UU' - I X* X IF( ITYPE.EQ.1 ) THEN X CALL DGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK, X $ N ) X* X DO 40 JDIAG = 1, N X WORK( ( N+1 )*( JDIAG-1 )+1 ) = WORK( ( N+1 )*( JDIAG-1 )+ X $ 1 ) - ONE X 40 CONTINUE X* X RESULT( 2 ) = MIN( DLANGE( '1', N, N, WORK, N, X $ WORK( N**2+1 ) ), DBLE( N ) ) / ( N*ULP ) X END IF X* X*----------------------------------------------------------------------- X* X* X RETURN X* X* End of DGET21 X* X END END_OF_FILE if test 8295 -ne `wc -c <'dget21.f'`; then echo shar: \"'dget21.f'\" unpacked with wrong size! fi # end of 'dget21.f' fi if test -f 'dget22.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dget22.f'\" else echo shar: Extracting \"'dget22.f'\" \(10597 characters\) sed "s/^X//" >'dget22.f' <<'END_OF_FILE' X SUBROUTINE DGET22( TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, WR, X $ WI, WORK, RESULT ) X* X* -- LAPACK test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X* X CHARACTER TRANSA, TRANSE, TRANSW X INTEGER LDA, LDE, N X* .. X* X* .. Array Arguments .. X* X DOUBLE PRECISION A( LDA, * ), E( LDE, * ), RESULT( 2 ), WI( * ), X $ WORK( N, * ), WR( * ) X* .. X* X*----------------------------------------------------------------------- X* X* Purpose X* ======= X* X* DGET22 does an eigenvector check. X* X* The basic test is: X* X* RESULT(1) = | A E - E W | / ( |A| |E| ulp ) X* X* using the 1-norm. It also checks the normalization: X* X* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp ) X* j X* X* where E(j) is the j-th eigenvector, and m-norm is the X* max-norm of a vector. If an eigenvector is complex, as X* determined from WI(j) nonzero, then the max-norm of the X* vector ( er + i*ei ) is the maximum of X* |er(1)| + |ei(1)|, ... , |er(n)| + |ei(n)| X* X* W is a block diagonal matrix, with a 1x1 block for each X* real eigenvalue and a 2x2 block for each complex conjugate X* pair. If eigenvalues j and j+1 are a complex conjugate pair, X* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the X* 2 x 2 block corresponding to the pair will be: X* X* ( wr wi ) X* ( -wi wr ) X* X* Such a block multiplying an n x 2 matrix ( ur ui ) on the X* right will be the same as multiplying ur + i*ui by wr + i*wi. X* X* To handle various schemes for storage of left eigenvectors, X* there are options to use (a) A-transpose instead of A, X* (b) E-transpose instead of E, and/or (c) W-transpose instead X* of W. X* X* X* Arguments X* ========== X* X* X* TRANSA - CHARACTER*1 X* If TRANSA='T' or 'C', A-transpose will be used everywhere X* instead of A. If TRANSA='N', A (not transposed) will be X* used. X* Not modified. X* X* TRANSE - CHARACTER*1 X* If TRANSE='T' or 'C', E-transpose will be used everywhere X* instead of E, and the eigenvectors will be in rows of E. X* If TRANSE='N', E (not transposed) will be used, and the X* eigenvectors will be in columns of E. X* Not modified. X* X* TRANSW - CHARACTER*1 X* If TRANSW='T' or 'C', W-transpose will be used everywhere X* instead of W; this corresponds to using -WI(j) instead of X* WI(j) everywhere. If TRANSW='N', W (not transposed) will X* be used. X* Not modified. X* X* N - INTEGER X* The size of the matrix. If it is zero, DGET22 does nothing. X* It must be at least zero. X* Not modified. X* X* A - DOUBLE PRECISION array of dimension ( LDA , N ) X* The matrix whose eigenvectors are in E. X* Not modified. X* X* LDA - INTEGER X* The leading dimension of A. It must be at least 1 X* and at least N. X* Not modified. X* X* E - DOUBLE PRECISION array of dimension ( LDE , N ) X* The matrix of eigenvectors. X* Not modified. X* X* LDE - INTEGER X* The leading dimension of E. It must be at least 1 X* and at least N. X* Not modified. X* X* WR, WI - DOUBLE PRECISION arrays of dimension ( N ). X* The real and imaginary parts of the eigenvalues of A. X* Purely real eigenvalues are indicated by WI(j) = exactly 0. X* Complex conjugate pairs are indicated by WR(j)=WR(j+1) and X* WI(j) = - WI(j+1) non-zero; the real part is assumed to be X* stored in the j-th row/column and the imaginary part in X* the (j+1)-th row/column. These are the only possibilities X* forseen, and strange results may occur if something else X* is supplied. X* Not modified. X* X* WORK - DOUBLE PRECISION array of dimension ( N, N+1 ) X* Workspace. X* Modified. X* X* RESULT - DOUBLE PRECISION array of dimension ( 2 ) X* The value computed by the test described above. X* Modified. X* X*----------------------------------------------------------------------- X* X* X* .. Parameters .. X* X DOUBLE PRECISION ZERO, ONE X PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) X* .. X* X* .. Local Scalars .. X* X CHARACTER NORMA, NORME X INTEGER IECOL, IEROW, INCE, IPAIR, ITRNSE, J, JCOL, X $ JVEC X DOUBLE PRECISION ANORM, ENORM, ENRMAX, ENRMIN, ERRNRM, TEMP1, X $ ULP, UNFL X* .. X* X* .. Local Arrays .. X* X DOUBLE PRECISION WMAT( 2, 2 ) X* .. X* X* .. External Functions .. X* X LOGICAL LSAME X DOUBLE PRECISION DLAMCH, DLANGE X EXTERNAL LSAME, DLAMCH, DLANGE X* .. X* X* .. External Subroutines .. X* X EXTERNAL DAXPY, DGEMM, DLAZRO X* .. X* X* .. Intrinsic Functions .. X* X INTRINSIC ABS, DBLE, MAX, MIN X* .. X* X* X*----------------------------------------------------------------------- X* .. Executable Statements .. X* X* Initialize RESULT (in case N=0) X* X RESULT( 1 ) = ZERO X RESULT( 2 ) = ZERO X IF( N.LE.0 ) X $ RETURN X* X* 1) Constants X* X UNFL = DLAMCH( 'Safe minimum' ) X ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) X* X ITRNSE = 0 X INCE = 1 X NORMA = 'O' X NORME = 'O' X* X IF( LSAME( TRANSA, 'T' ) .OR. LSAME( TRANSA, 'C' ) ) THEN X NORMA = 'I' X END IF X IF( LSAME( TRANSE, 'T' ) .OR. LSAME( TRANSE, 'C' ) ) THEN X NORME = 'I' X ITRNSE = 1 X INCE = LDE X END IF X* X*----------------------------------------------------------------------- X* X* Check Normalization of E X* X ENRMIN = ONE / ULP X ENRMAX = ZERO X IF( ITRNSE.EQ.0 ) THEN X* X* . . . . . . . . . . . . . . X* X* Eigenvectors are column vectors. X* X IPAIR = 0 X DO 30 JVEC = 1, N X TEMP1 = ZERO X IF( IPAIR.EQ.0 .AND. JVEC.LT.N .AND. WI( JVEC ).NE.ZERO ) X $ IPAIR = 1 X IF( IPAIR.EQ.1 ) THEN X* X* Complex Eigenvector X* X DO 10 J = 1, N X TEMP1 = MAX( TEMP1, ABS( E( J, JVEC ) )+ X $ ABS( E( J, JVEC+1 ) ) ) X 10 CONTINUE X ENRMIN = MIN( ENRMIN, TEMP1 ) X ENRMAX = MAX( ENRMAX, TEMP1 ) X IPAIR = 2 X ELSE IF( IPAIR.EQ.2 ) THEN X IPAIR = 0 X ELSE X* X* Real Eigenvector X* X DO 20 J = 1, N X TEMP1 = MAX( TEMP1, ABS( E( J, JVEC ) ) ) X 20 CONTINUE X ENRMIN = MIN( ENRMIN, TEMP1 ) X ENRMAX = MAX( ENRMAX, TEMP1 ) X IPAIR = 0 X END IF X 30 CONTINUE X* X* . . . . . . . . . . . . . . X* X* Eigenvectors are row vectors. X* X ELSE X DO 40 JVEC = 1, N X WORK( JVEC, 1 ) = ZERO X 40 CONTINUE X* X DO 60 J = 1, N X IPAIR = 0 X DO 50 JVEC = 1, N X IF( IPAIR.EQ.0 .AND. JVEC.LT.N .AND. WI( JVEC ).NE.ZERO ) X $ IPAIR = 1 X IF( IPAIR.EQ.1 ) THEN X WORK( JVEC, 1 ) = MAX( WORK( JVEC, 1 ), X $ ABS( E( J, JVEC ) )+ X $ ABS( E( J, JVEC+1 ) ) ) X WORK( JVEC+1, 1 ) = WORK( JVEC, 1 ) X ELSE IF( IPAIR.EQ.2 ) THEN X IPAIR = 0 X ELSE X WORK( JVEC, 1 ) = MAX( WORK( JVEC, 1 ), X $ ABS( E( J, JVEC ) ) ) X IPAIR = 0 X END IF X 50 CONTINUE X 60 CONTINUE X* X DO 70 JVEC = 1, N X ENRMIN = MIN( ENRMIN, WORK( JVEC, 1 ) ) X ENRMAX = MAX( ENRMAX, WORK( JVEC, 1 ) ) X 70 CONTINUE X END IF X* X* X* X*----------------------------------------------------------------------- X* X* X* X* Norm of A: X* X ANORM = MAX( DLANGE( NORMA, N, N, A, LDA, WORK ), UNFL ) X* X* Norm of E: X* X ENORM = MAX( DLANGE( NORME, N, N, E, LDE, WORK ), ULP ) X* X* . . . . . . . . . . . . . .. X* X* Norm of Error: X* X* X* Error = AE - EW X* X CALL DLAZRO( N, N, ZERO, ZERO, WORK, N ) X* X IPAIR = 0 X IEROW = 1 X IECOL = 1 X* X DO 80 JCOL = 1, N X IF( ITRNSE.EQ.1 ) THEN X IEROW = JCOL X ELSE X IECOL = JCOL X END IF X* X IF( IPAIR.EQ.0 .AND. WI( JCOL ).NE.ZERO ) X $ IPAIR = 1 X* X IF( IPAIR.EQ.1 ) THEN X WMAT( 1, 1 ) = WR( JCOL ) X WMAT( 2, 1 ) = -WI( JCOL ) X WMAT( 1, 2 ) = WI( JCOL ) X WMAT( 2, 2 ) = WR( JCOL ) X CALL DGEMM( TRANSE, TRANSW, N, 2, 2, ONE, E( IEROW, IECOL ), X $ LDE, WMAT, 2, ZERO, WORK( 1, JCOL ), N ) X IPAIR = 2 X ELSE IF( IPAIR.EQ.2 ) THEN X IPAIR = 0 X* X ELSE X CALL DAXPY( N, WR( JCOL ), E( IEROW, IECOL ), INCE, X $ WORK( 1, JCOL ), 1 ) X IPAIR = 0 X END IF X* X 80 CONTINUE X* X CALL DGEMM( TRANSA, TRANSE, N, N, N, ONE, A, LDA, E, LDE, -ONE, X $ WORK, N ) X* X* X* X ERRNRM = DLANGE( 'One', N, N, WORK, N, WORK( 1, N+1 ) ) / ENORM X* X* . . . . . . . . . . . . . .. X* X* X* Compute RESULT(1) (avoiding under/overflow) X* X* X IF( ANORM.GT.ERRNRM ) THEN X RESULT( 1 ) = ( ERRNRM / ANORM ) / ULP X ELSE X IF( ANORM.LT.ONE ) THEN X RESULT( 1 ) = ( MIN( ERRNRM, ANORM ) / ANORM ) / ULP X ELSE X RESULT( 1 ) = MIN( ERRNRM / ANORM, ONE ) / ULP X END IF X END IF X* X* Compute RESULT(2) : the normalization error in E. X* X RESULT( 2 ) = MAX( ABS( ENRMAX-ONE ), ABS( ENRMIN-ONE ) ) / X $ ( DBLE( N )*ULP ) X* X*----------------------------------------------------------------------- X* X* X RETURN X* X* End of DGET22 X* X END END_OF_FILE if test 10597 -ne `wc -c <'dget22.f'`; then echo shar: \"'dget22.f'\" unpacked with wrong size! fi # end of 'dget22.f' fi if test -f 'dhqr2.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dhqr2.f'\" else echo shar: Extracting \"'dhqr2.f'\" \(14620 characters\) sed "s/^X//" >'dhqr2.f' <<'END_OF_FILE' X subroutine hqr2(nm,n,low,igh,h,wr,wi,z,ierr) CVD$G noconcur c X integer i,j,k,l,m,n,en,ii,jj,ll,mm,na,nm,nn, X x igh,itn,its,low,mp2,enm2,ierr X double precision h(nm,n),wr(n),wi(n),z(nm,n) X double precision p,q,r,s,t,w,x,y,ra,sa,vi,vr,zz,norm,tst1,tst2 X logical notlas c c this subroutine is a translation of the algol procedure hqr2, c num. math. 16, 181-204(1970) by peters and wilkinson. c handbook for auto. comp., vol.ii-linear algebra, 372-395(1971). c c this subroutine finds the eigenvalues and eigenvectors c of a real upper hessenberg matrix by the qr method. the c eigenvectors of a real general matrix can also be found c if elmhes and eltran or orthes and ortran have c been used to reduce this general matrix to hessenberg form c and to accumulate the similarity transformations. c c on input c c nm must be set to the row dimension of two-dimensional c array parameters as declared in the calling program c dimension statement. c c n is the order of the matrix. c c low and igh are integers determined by the balancing c subroutine balanc. if balanc has not been used, c set low=1, igh=n. c c h contains the upper hessenberg matrix. c c z contains the transformation matrix produced by eltran c after the reduction by elmhes, or by ortran after the c reduction by orthes, if performed. if the eigenvectors c of the hessenberg matrix are desired, z must contain the c identity matrix. c c on output c c h has been destroyed. c c wr and wi contain the real and imaginary parts, c respectively, of the eigenvalues. the eigenvalues c are unordered except that complex conjugate pairs c of values appear consecutively with the eigenvalue c having the positive imaginary part first. if an c error exit is made, the eigenvalues should be correct c for indices ierr+1,...,n. c c z contains the real and imaginary parts of the eigenvectors. c if the i-th eigenvalue is real, the i-th column of z c contains its eigenvector. if the i-th eigenvalue is complex c with positive imaginary part, the i-th and (i+1)-th c columns of z contain the real and imaginary parts of its c eigenvector. the eigenvectors are unnormalized. if an c error exit is made, none of the eigenvectors has been found. c c ierr is set to c zero for normal return, c j if the limit of 30*n iterations is exhausted c while the j-th eigenvalue is being sought. c c calls cdiv for complex division. c c questions and comments should be directed to burton s. garbow, c mathematics and computer science div, argonne national laboratory c c this version dated august 1983. c c ------------------------------------------------------------------ c X ierr = 0 X norm = 0.0d0 X k = 1 c .......... store roots isolated by balanc c and compute matrix norm .......... X do 50 i = 1, n c X do 40 j = k, n X 40 norm = norm + dabs(h(i,j)) c X k = i X if (i .ge. low .and. i .le. igh) go to 50 X wr(i) = h(i,i) X wi(i) = 0.0d0 X 50 continue c X en = igh X t = 0.0d0 X itn = 30*n c .......... search for next eigenvalues .......... X 60 if (en .lt. low) go to 340 X its = 0 X na = en - 1 X enm2 = na - 1 c .......... look for single small sub-diagonal element c for l=en step -1 until low do -- .......... X 70 do 80 ll = low, en X l = en + low - ll X if (l .eq. low) go to 100 X s = dabs(h(l-1,l-1)) + dabs(h(l,l)) X if (s .eq. 0.0d0) s = norm X tst1 = s X tst2 = tst1 + dabs(h(l,l-1)) X if (tst2 .eq. tst1) go to 100 X 80 continue c .......... form shift .......... X 100 x = h(en,en) X if (l .eq. en) go to 270 X y = h(na,na) X w = h(en,na) * h(na,en) X if (l .eq. na) go to 280 X if (itn .eq. 0) go to 1000 X if (its .ne. 10 .and. its .ne. 20) go to 130 c .......... form exceptional shift .......... X t = t + x c X do 120 i = low, en X 120 h(i,i) = h(i,i) - x c X s = dabs(h(en,na)) + dabs(h(na,enm2)) X x = 0.75d0 * s X y = x X w = -0.4375d0 * s * s X 130 its = its + 1 X itn = itn - 1 c .......... look for two consecutive small c sub-diagonal elements. c for m=en-2 step -1 until l do -- .......... X do 140 mm = l, enm2 X m = enm2 + l - mm X zz = h(m,m) X r = x - zz X s = y - zz X p = (r * s - w) / h(m+1,m) + h(m,m+1) X q = h(m+1,m+1) - zz - r - s X r = h(m+2,m+1) X s = dabs(p) + dabs(q) + dabs(r) X p = p / s X q = q / s X r = r / s X if (m .eq. l) go to 150 X tst1 = dabs(p)*(dabs(h(m-1,m-1)) + dabs(zz) + dabs(h(m+1,m+1))) X tst2 = tst1 + dabs(h(m,m-1))*(dabs(q) + dabs(r)) X if (tst2 .eq. tst1) go to 150 X 140 continue c X 150 mp2 = m + 2 c X do 160 i = mp2, en X h(i,i-2) = 0.0d0 X if (i .eq. mp2) go to 160 X h(i,i-3) = 0.0d0 X 160 continue c .......... double qr step involving rows l to en and c columns m to en .......... X do 260 k = m, na X notlas = k .ne. na X if (k .eq. m) go to 170 X p = h(k,k-1) X q = h(k+1,k-1) X r = 0.0d0 X if (notlas) r = h(k+2,k-1) X x = dabs(p) + dabs(q) + dabs(r) X if (x .eq. 0.0d0) go to 260 X p = p / x X q = q / x X r = r / x X 170 s = dsign(dsqrt(p*p+q*q+r*r),p) X if (k .eq. m) go to 180 X h(k,k-1) = -s * x X go to 190 X 180 if (l .ne. m) h(k,k-1) = -h(k,k-1) X 190 p = p + s X x = p / s X y = q / s X zz = r / s X q = q / p X r = r / p X if (notlas) go to 225 c .......... row modification .......... X do 200 j = k, n X p = h(k,j) + q * h(k+1,j) X h(k,j) = h(k,j) - p * x X h(k+1,j) = h(k+1,j) - p * y X 200 continue c X j = min0(en,k+3) c .......... column modification .......... X do 210 i = 1, j X p = x * h(i,k) + y * h(i,k+1) X h(i,k) = h(i,k) - p X h(i,k+1) = h(i,k+1) - p * q X 210 continue c .......... accumulate transformations .......... X do 220 i = low, igh X p = x * z(i,k) + y * z(i,k+1) X z(i,k) = z(i,k) - p X z(i,k+1) = z(i,k+1) - p * q X 220 continue X go to 255 X 225 continue c .......... row modification .......... X do 230 j = k, n X p = h(k,j) + q * h(k+1,j) + r * h(k+2,j) X h(k,j) = h(k,j) - p * x X h(k+1,j) = h(k+1,j) - p * y X h(k+2,j) = h(k+2,j) - p * zz X 230 continue c X j = min0(en,k+3) c .......... column modification .......... X do 240 i = 1, j X p = x * h(i,k) + y * h(i,k+1) + zz * h(i,k+2) X h(i,k) = h(i,k) - p X h(i,k+1) = h(i,k+1) - p * q X h(i,k+2) = h(i,k+2) - p * r X 240 continue c .......... accumulate transformations .......... X do 250 i = low, igh X p = x * z(i,k) + y * z(i,k+1) + zz * z(i,k+2) X z(i,k) = z(i,k) - p X z(i,k+1) = z(i,k+1) - p * q X z(i,k+2) = z(i,k+2) - p * r X 250 continue X 255 continue c X 260 continue c X go to 70 c .......... one root found .......... X 270 h(en,en) = x + t X wr(en) = h(en,en) X wi(en) = 0.0d0 X en = na X go to 60 c .......... two roots found .......... X 280 p = (y - x) / 2.0d0 X q = p * p + w X zz = dsqrt(dabs(q)) X h(en,en) = x + t X x = h(en,en) X h(na,na) = y + t X if (q .lt. 0.0d0) go to 320 c .......... real pair .......... X zz = p + dsign(zz,p) X wr(na) = x + zz X wr(en) = wr(na) X if (zz .ne. 0.0d0) wr(en) = x - w / zz X wi(na) = 0.0d0 X wi(en) = 0.0d0 X x = h(en,na) X s = dabs(x) + dabs(zz) X p = x / s X q = zz / s X r = dsqrt(p*p+q*q) X p = p / r X q = q / r c .......... row modification .......... X do 290 j = na, n X zz = h(na,j) X h(na,j) = q * zz + p * h(en,j) X h(en,j) = q * h(en,j) - p * zz X 290 continue c .......... column modification .......... X do 300 i = 1, en X zz = h(i,na) X h(i,na) = q * zz + p * h(i,en) X h(i,en) = q * h(i,en) - p * zz X 300 continue c .......... accumulate transformations .......... X do 310 i = low, igh X zz = z(i,na) X z(i,na) = q * zz + p * z(i,en) X z(i,en) = q * z(i,en) - p * zz X 310 continue c X go to 330 c .......... complex pair .......... X 320 wr(na) = x + p X wr(en) = x + p X wi(na) = zz X wi(en) = -zz X 330 en = enm2 X go to 60 c .......... all roots found. backsubstitute to find c vectors of upper triangular form .......... X 340 if (norm .eq. 0.0d0) go to 1001 c .......... for en=n step -1 until 1 do -- .......... X do 800 nn = 1, n X en = n + 1 - nn X p = wr(en) X q = wi(en) X na = en - 1 X if (q) 710, 600, 800 c .......... real vector .......... X 600 m = en X h(en,en) = 1.0d0 X if (na .eq. 0) go to 800 c .......... for i=en-1 step -1 until 1 do -- .......... X do 700 ii = 1, na X i = en - ii X w = h(i,i) - p X r = 0.0d0 c X do 610 j = m, en X 610 r = r + h(i,j) * h(j,en) c X if (wi(i) .ge. 0.0d0) go to 630 X zz = w X s = r X go to 700 X 630 m = i X if (wi(i) .ne. 0.0d0) go to 640 X t = w X if (t .ne. 0.0d0) go to 635 X tst1 = norm X t = tst1 X 632 t = 0.01d0 * t X tst2 = norm + t X if (tst2 .gt. tst1) go to 632 X 635 h(i,en) = -r / t X go to 680 c .......... solve real equations .......... X 640 x = h(i,i+1) X y = h(i+1,i) X q = (wr(i) - p) * (wr(i) - p) + wi(i) * wi(i) X t = (x * s - zz * r) / q X h(i,en) = t X if (dabs(x) .le. dabs(zz)) go to 650 X h(i+1,en) = (-r - w * t) / x X go to 680 X 650 h(i+1,en) = (-s - y * t) / zz c c .......... overflow control .......... X 680 t = dabs(h(i,en)) X if (t .eq. 0.0d0) go to 700 X tst1 = t X tst2 = tst1 + 1.0d0/tst1 X if (tst2 .gt. tst1) go to 700 X do 690 j = i, en X h(j,en) = h(j,en)/t X 690 continue c X 700 continue c .......... end real vector .......... X go to 800 c .......... complex vector .......... X 710 m = na c .......... last vector component chosen imaginary so that c eigenvector matrix is triangular .......... X if (dabs(h(en,na)) .le. dabs(h(na,en))) go to 720 X h(na,na) = q / h(en,na) X h(na,en) = -(h(en,en) - p) / h(en,na) X go to 730 X 720 call cdiv(0.0d0,-h(na,en),h(na,na)-p,q,h(na,na),h(na,en)) X 730 h(en,na) = 0.0d0 X h(en,en) = 1.0d0 X enm2 = na - 1 X if (enm2 .eq. 0) go to 800 c .......... for i=en-2 step -1 until 1 do -- .......... X do 795 ii = 1, enm2 X i = na - ii X w = h(i,i) - p X ra = 0.0d0 X sa = 0.0d0 c X do 760 j = m, en X ra = ra + h(i,j) * h(j,na) X sa = sa + h(i,j) * h(j,en) X 760 continue c X if (wi(i) .ge. 0.0d0) go to 770 X zz = w X r = ra X s = sa X go to 795 X 770 m = i X if (wi(i) .ne. 0.0d0) go to 780 X call cdiv(-ra,-sa,w,q,h(i,na),h(i,en)) X go to 790 c .......... solve complex equations .......... X 780 x = h(i,i+1) X y = h(i+1,i) X vr = (wr(i) - p) * (wr(i) - p) + wi(i) * wi(i) - q * q X vi = (wr(i) - p) * 2.0d0 * q X if (vr .ne. 0.0d0 .or. vi .ne. 0.0d0) go to 784 X tst1 = norm * (dabs(w) + dabs(q) + dabs(x) X x + dabs(y) + dabs(zz)) X vr = tst1 X 783 vr = 0.01d0 * vr X tst2 = tst1 + vr X if (tst2 .gt. tst1) go to 783 X 784 call cdiv(x*r-zz*ra+q*sa,x*s-zz*sa-q*ra,vr,vi, X x h(i,na),h(i,en)) X if (dabs(x) .le. dabs(zz) + dabs(q)) go to 785 X h(i+1,na) = (-ra - w * h(i,na) + q * h(i,en)) / x X h(i+1,en) = (-sa - w * h(i,en) - q * h(i,na)) / x X go to 790 X 785 call cdiv(-r-y*h(i,na),-s-y*h(i,en),zz,q, X x h(i+1,na),h(i+1,en)) c c .......... overflow control .......... X 790 t = dmax1(dabs(h(i,na)), dabs(h(i,en))) X if (t .eq. 0.0d0) go to 795 X tst1 = t X tst2 = tst1 + 1.0d0/tst1 X if (tst2 .gt. tst1) go to 795 X do 792 j = i, en X h(j,na) = h(j,na)/t X h(j,en) = h(j,en)/t X 792 continue c X 795 continue c .......... end complex vector .......... X 800 continue c .......... end back substitution. c vectors of isolated roots .......... X do 840 i = 1, n X if (i .ge. low .and. i .le. igh) go to 840 c X do 820 j = i, n X 820 z(i,j) = h(i,j) c X 840 continue c .......... multiply by transformation matrix to give c vectors of original full matrix. c for j=n step -1 until low do -- .......... X do 880 jj = low, n X j = n + low - jj X m = min0(j,igh) c X do 880 i = low, igh X zz = 0.0d0 c X do 860 k = low, m X 860 zz = zz + z(i,k) * h(k,j) c X z(i,j) = zz X 880 continue c X go to 1001 c .......... set error -- all eigenvalues have not c converged after 30*n iterations .......... X 1000 ierr = en X 1001 return X end c X subroutine cdiv(ar,ai,br,bi,cr,ci) X double precision ar,ai,br,bi,cr,ci c c complex division, (cr,ci) = (ar,ai)/(br,bi) c X double precision s,ars,ais,brs,bis X s = dabs(br) + dabs(bi) X ars = ar/s X ais = ai/s X brs = br/s X bis = bi/s X s = brs**2 + bis**2 X cr = (ars*brs + ais*bis)/s X ci = (ais*brs - ars*bis)/s X return X end X END_OF_FILE if test 14620 -ne `wc -c <'dhqr2.f'`; then echo shar: \"'dhqr2.f'\" unpacked with wrong size! fi # end of 'dhqr2.f' fi if test -f 'dhsein.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dhsein.f'\" else echo shar: Extracting \"'dhsein.f'\" \(16332 characters\) sed "s/^X//" >'dhsein.f' <<'END_OF_FILE' X SUBROUTINE DHSEIN( JOB, SELECT, SOURCE, VECTOR, N, H, LDH, WR, WI, X $ RE, LDRE, LE, LDLE, MM, M, WORK, INFO ) X* X* -- LAPACK routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER JOB, SOURCE, VECTOR X INTEGER INFO, LDH, LDLE, LDRE, M, MM, N X* .. X* X* .. Array Arguments .. X LOGICAL SELECT( * ) X DOUBLE PRECISION H( LDH, * ), LE( LDLE, * ), RE( LDLE, * ), X $ WI( * ), WORK( * ), WR( * ) X* .. X* X* Purpose X* ======= X* X* This subroutine uses inverse iteration to find specified right X* and/or left eigenvectors of a real upper Hessenberg matrix. X* X* Arguments X* ========= X* X* JOB - CHARACTER*1 X* JOB specifies the computation to be performed by DHSEIN: X* as follows: X* If JOB = 'R', compute right eigenvectors only. X* If JOB = 'L', compute left eigenvectors only. X* If JOB = 'B', compute both right and left eigenvectors. X* Not modified. X* X* SELECT - LOGICAL array, dimension (N). X* SELECT specifies the eigenvectors to be computed. To get X* the eigenvector corresponding to the j-th eigenvalue, set X* SELECT(j) to .TRUE. To get the eigenvectors corresponding X* to a complex conjugate pair of eigenvalues, set the element X* of SELECT corresponding to the first eigenvalue of the pair X* to .TRUE. and the second to .FALSE. (Currently, the value X* of the first element of the pair determines whether the X* pair of eigenvectors is computed.) X* X* On exit, SELECT may have been altered. If the elements of X* SELECT corresponding to a complex conjugate pair of X* eigenvalues were both initially set to .TRUE., the program X* resets the second of the two elements to .FALSE. X* X* X* SOURCE - CHARACTER*1 X* SOURCE specifies the source of eigenvalues supplied in X* WR and WI. X* If SOURCE = 'Q', the eigenvalues were found using DHSEQR; X* thus, if H has zero or negligible sub-diagonal X* entries, and so is block-triangular, then X* the j-th eigenvalue can be assumed to be an X* eigenvalue of the block containing the j-th X* row/column. This property allows DHSEIN to X* perform inverse iteration on just one diagonal X* block. X* If SOURCE = 'N', no assumptions are made on the X* correspondence between eigenvalues and diagonal X* blocks. In this case, DHSEIN must always X* perform inverse iteration using the whole X* matrix H. X* Not modified. X* X* VECTOR - CHARACTER*1 X* VECTOR specifies the source of the initial vectors in X* inverse iteration. X* If VECTOR = 'N', the user does not supply any initial X* vector for the inverse iteration. X* If VECTOR = 'U', the user supplies the initial vectors X* in the array RE and/or LE. The starting vector X* for computing a particular eigenvector will be X* taken from the same place that the eigenvector X* will be stored in. X* Not modified. X* X* N - INTEGER X* The order of the matrix H. X* N must be at least zero. X* Not modified. X* X* H - DOUBLE PRECISION array, dimension (LDH,N). X* H contains the matrix whose eigenvectors are to be computed. X* H must be a real upper Hessenberg matrix. X* Not modified. X* X* LDH - INTEGER. X* The first dimension of H as declared in the calling X* (sub)program. LDH must be at least max(1, N). X* Not modified. X* X* WR,WI - DOUBLE PRECISION arrays, dimension (N). X* On entry, WR and WI contain the real and imaginary parts, X* respectively, of the eigenvalues of H. The N eigenvalues X* may appear in any order, except that a complex conjugate X* pair of eigenvalues must appear consecutively with the X* eigenvalue having the positive imaginary part first. X* Inverse iteration will be performed with each real X* WR(j) for which SELECT(j)=.TRUE. and each complex conjugate X* pair WR(j) +/- i*WI(j) = WR(j+1) -/+ i*WI(j+1) for which X* SELECT(j)=.TRUE. X* X* On exit, WR may have been altered since close eigenvalues X* are perturbed slightly in searching for independent eigen- X* vectors. WI will not be altered. X* X* RE - DOUBLE PRECISION array, dimension (LDRE,MM) X* If VECTOR='U', then on entry RE must contain starting X* vectors for the inverse iteration for the right X* eigenvectors. The starting vector for computing a X* particular eigenvector must be in the same column(s) that X* the eigenvector will be stored in. X* X* The *right* eigenvectors specified by SELECT will be stored X* one after another in the columns of RE, in the same *order* X* (but not necessarily the same position) as their X* eigenvalues. An eigenvector corresponding to a SELECTed X* *real* eigenvalue will take up one column. An eigenvector X* pair corresponding to a SELECTed *complex conjugate pair* X* of eigenvalues will take up two columns: the first column X* will hold the real part, the second will hold the imaginary X* part of the eigenvector corresponding to the eigenvalue X* with *positive* imaginary part. X* X* The eigenvectors will be normalized so that the component X* of largest magnitude is 1; here, the magnitude of a complex X* number x + iy is considered to be |x| + |y|. Eigenvectors X* which do not pass an "acceptance test", i.e., for which the X* inverse iteration does not converge, will be set to zero. X* X* If JOB = 'R' or 'B', RE will be modified. X* If JOB = 'L', RE will not be referenced. X* X* LDRE - INTEGER X* LDRE specifies the leading dimension of RE as declared in X* the calling (sub)program. LDRE must be at least max(1, N). X* If JOB = 'L', LDRE is not referenced. X* Not modified. X* X* LE - DOUBLE PRECISION array, dimension (LDLE,MM) X* If VECTOR='U', then on entry LE must contain starting X* vectors for the inverse iteration for the left eigenvectors. X* The starting vector for computing a particular eigenvector X* must be in the same column(s) that the eigenvector will be X* stored in. X* X* The conjugate transposes of the *left* eigenvectors X* specified by SELECT will be stored one after another in the X* columns of LE, in the same *order* (but not necessarily the X* same position) as their eigenvalues. An eigenvector X* corresponding to a SELECTed *real* eigenvalue will take up X* one column. An eigenvector pair corresponding to a X* SELECTed *complex conjugate pair* of eigenvalues will take X* up two columns: the first column will hold the real part, X* the second will hold the imaginary part of the conjugate X* transpose of the left eigenvector corresponding to the X* eigenvalue with *positive* imaginary part. X* X* The eigenvectors will be normalized so that the component X* of largest magnitude is 1; here, the magnitude of a complex X* number x + iy is considered to be |x| + |y|. Eigenvectors X* which do not pass an "acceptance test", i.e., for which the X* inverse iteration does not converge, will be set to zero. X* X* If JOB = 'L' or 'B', LE will be modified. X* If JOB = 'R', LE will not be referenced. X* X* X* LDLE - INTEGER X* LDLE specifies the leading dimension of LE as declared in X* the calling (sub)program. LDLE must be at least max(1, N). X* If JOB = 'R', LDLE is not referenced. X* Not modified. X* X* MM - INTEGER X* The number of columns in LE and/or RE. Note that X* two columns are required to store the eigenvector X* corresponding to a complex eigenvalue. X* Not modified. X* X* M - INTEGER X* On exit, M is the number of columns in LE and/or RE actually X* used to store the eigenvectors. X* X* WORK - DOUBLE PRECISION array, dimension ( (N+2)**2 + N ). X* WORK is a (N+2)**2 + N workarray. X* X* INFO - INTEGER X* On exit, INFO is set to X* 0 for normal return, X* -k if input argument number k is illegal. X* N+1 if more than MM columns of RE and/or LE are X* necessary to store the SELECTed eigenvectors. X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE X PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) X* .. X* X* .. Local Scalars .. X INTEGER I, IJOB, IP, IP1, ISOURC, IVECTO, K, LK, LK1, X $ S, UK, UK1 X DOUBLE PRECISION BIGNUM, EPS3, ILAMBD, NORM, NORMF, NORML, X $ NORMR, OVFL, RLAMBD, SMLNUM, ULP, UNFL X* .. X* X* .. External Functions .. X LOGICAL LSAME X DOUBLE PRECISION DLAMCH, DLANHS X EXTERNAL LSAME, DLAMCH, DLANHS X* .. X* X* .. External Subroutines .. X EXTERNAL DLAEIN, XERBLA X* .. X* X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX X* .. X* X* .. Executable Statements .. X* X* Deconde and Test the input parameter X* X IF( LSAME( JOB, 'R' ) ) THEN X IJOB = 1 X ELSE IF( LSAME( JOB, 'L' ) ) THEN X IJOB = 2 X ELSE IF( LSAME( JOB, 'B' ) ) THEN X IJOB = 3 X ELSE X IJOB = -1 X END IF X* X IF( LSAME( SOURCE, 'Q' ) ) THEN X ISOURC = 1 X ELSE IF( LSAME( SOURCE, 'N' ) ) THEN X ISOURC = 2 X ELSE X ISOURC = -1 X END IF X* X IF( LSAME( VECTOR, 'N' ) ) THEN X IVECTO = 1 X ELSE IF( LSAME( VECTOR, 'U' ) ) THEN X IVECTO = 2 X ELSE X IVECTO = -1 X END IF X* X INFO = 0 X IF( IJOB.EQ.-1 ) THEN X INFO = -1 X ELSE IF( ISOURC.EQ.-1 ) THEN X INFO = -3 X ELSE IF( IVECTO.EQ.-1 ) THEN X INFO = -4 X ELSE IF( N.LT.0 ) THEN X INFO = -5 X ELSE IF( LDH.LT.MAX( 1, N ) ) THEN X INFO = -7 X END IF X IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN X IF( LDRE.LT.MAX( 1, N ) ) X $ INFO = -11 X END IF X IF( IJOB.EQ.2 .OR. IJOB.EQ.3 ) THEN X IF( LDLE.LT.MAX( 1, N ) ) X $ INFO = -13 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DHSEIN', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.EQ.0 ) X $ RETURN X* X* Set constants to control overflow. X* X UNFL = DLAMCH( 'Safe minimum' ) X OVFL = DLAMCH( 'Overflow' ) X ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) X SMLNUM = MAX( UNFL*( N/ULP ), N/( ULP*OVFL ) ) X BIGNUM = ( ONE-ULP ) / SMLNUM X* X* Compute inf-norm of matrix H. X* X NORMF = DLANHS( 'I', N, H, LDH, WORK ) X* X* ip = 0, real eigenvalue, X* 1, first of conjugate complex pair, X* -1, second of conjugate complex pair. X* X UK = 0 X LK = 1 X IP = 0 X S = 1 X* X DO 170 K = 1, N X IF( IP.EQ.-1 ) X $ GO TO 160 X IF( WI( K ).EQ.ZERO ) X $ GO TO 10 X IP = 1 X IF( SELECT( K ) .AND. SELECT( K+1 ) ) X $ SELECT( K+1 ) = .FALSE. X 10 CONTINUE X IF( .NOT.SELECT( K ) ) X $ GO TO 160 X IF( IP.EQ.0 .AND. S.GT.MM ) X $ GO TO 180 X IF( IP.NE.0 .AND. S+1.GT.MM ) X $ GO TO 180 X* X* If the affiliation of eigenvalue is known, split checking X* X IF( ISOURC.EQ.1 ) THEN X* X IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN X* X* Split checking for right eigenvector. The inverse X* iteration works on H(1:UK,1:UK) X* X IF( UK.GE.K ) X $ GO TO 50 X DO 20 UK1 = K, N X IF( UK1.EQ.N ) X $ GO TO 40 X IF( H( UK1+1, UK1 ).EQ.ZERO ) X $ GO TO 30 X 20 CONTINUE X* X 30 CONTINUE X UK = UK1 X NORMR = DLANHS( 'I', UK, H, LDH, WORK ) X GO TO 50 X 40 CONTINUE X UK = N X NORMR = NORMF X END IF X* X* Split checking for left eigenvector. The inverse X* iteration works on H(LK:N,LK:N). X* X 50 CONTINUE X IF( IJOB.EQ.2 .OR. IJOB.EQ.3 ) THEN X DO 60 LK1 = K, LK, -1 X IF( LK1.EQ.LK ) X $ GO TO 70 X IF( H( LK1, LK1-1 ).EQ.ZERO ) X $ GO TO 70 X 60 CONTINUE X* X 70 CONTINUE X IF( LK1.EQ.1 ) THEN X LK = LK1 X NORML = NORMF X GO TO 80 X END IF X* X IF( LK1.EQ.LK ) THEN X LK = LK1 X GO TO 80 X ELSE X LK = LK1 X NORML = DLANHS( 'I', N-LK+1, H( LK, LK ), LDH, WORK ) X END IF X END IF X* X 80 CONTINUE X IF( IJOB.EQ.1 ) THEN X NORM = NORMR X ELSE IF( IJOB.EQ.2 ) THEN X NORM = NORML X ELSE IF( IJOB.EQ.3 ) THEN X NORM = MAX( NORMR, NORML ) X END IF X* X ELSE X* X* If the affiliation of eigenvalue is not known, the X* inverse iteration works on full matrix H. X* X UK = N X LK = 1 X NORM = NORMF X END IF X* X IF( NORM.EQ.ZERO ) THEN X IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN X DO 90 I = 1, N X RE( I, S ) = ZERO X 90 CONTINUE X RE( K, S ) = ONE X END IF X IF( IJOB.EQ.2 .OR. IJOB.EQ.3 ) THEN X DO 100 I = 1, N X LE( I, S ) = ZERO X 100 CONTINUE X LE( K, S ) = ONE X END IF X GO TO 150 X END IF X* X* EPS3 replaces zero pivot in decomposition X* and close roots are modified by EPS3. X* X EPS3 = NORM*ULP X* X RLAMBD = WR( K ) X ILAMBD = WI( K ) X IF( K.EQ.1 ) X $ GO TO 140 X GO TO 120 X* X* Perturb eigenvalue if it is close to any previous X* eigenvalue. X* X 110 CONTINUE X RLAMBD = RLAMBD + EPS3 X 120 CONTINUE X DO 130 I = LK - 1, UK, -1 X IF( SELECT( I ) .AND. ABS( WR( I )-RLAMBD ).LT.EPS3 .AND. X $ ABS( WI( I )-ILAMBD ).LT.EPS3 )GO TO 110 X 130 CONTINUE X* X WR( K ) = RLAMBD X* X* Perturb conjugate eigenvalue to match. X* X IP1 = K + IP X WR( IP1 ) = RLAMBD X* X* Call DLAEIN to find the selected right and/or right X* eigenvector. The computed eigenvectors are stored in X* S-th column (and (S+1)-th colums if complex eigenvalues). X* X 140 CONTINUE X CALL DLAEIN( IJOB, IVECTO, N, H, LDH, RLAMBD, ILAMBD, UK, LK, X $ RE( 1, S ), LDRE, LE( 1, S ), LDLE, WORK( N+1 ), X $ N+2, WORK, EPS3, SMLNUM, BIGNUM, INFO ) X* X 150 CONTINUE X IF( IP.EQ.0 ) X $ S = S + 1 X IF( IP.NE.0 ) X $ S = S + 2 X 160 CONTINUE X IF( IP.EQ.-1 ) X $ IP = 0 X IF( IP.EQ.1 ) X $ IP = -1 X* X 170 CONTINUE X* X GO TO 190 X* X* Set error -- underestimate of eigenvector space required. X* X 180 CONTINUE X IF( INFO.EQ.0 ) X $ INFO = N + 1 X 190 CONTINUE X M = S - 1 X* X RETURN X* X* End of DHSEIN X* X END END_OF_FILE if test 16332 -ne `wc -c <'dhsein.f'`; then echo shar: \"'dhsein.f'\" unpacked with wrong size! fi # end of 'dhsein.f' fi if test -f 'dhseqr.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dhseqr.f'\" else echo shar: Extracting \"'dhseqr.f'\" \(25062 characters\) sed "s/^X//" >'dhseqr.f' <<'END_OF_FILE' X SUBROUTINE DHSEQR( JOB, N, H, LDH, Z, LDZ, WR, WI, WORK, LWORK, X $ INFO ) X* X* -- LAPACK routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER JOB X INTEGER INFO, LDH, LDZ, LWORK, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ), X $ Z( LDZ, * ) X* .. X* X* Purpose X* ======= X* X* This subroutine computes the Schur decomposition of a real X* upper Hessenberg matrix using the block multishift QR method X* (Z. Bai and J. Demmel, "On a Block Implementation of Hessenberg X* Multishift QR Iteration", _International_Journal_of_High_Speed_ X* _Computing_, vol. 1, no. 1, 1989, p. 97--112.) X* X* A real N x N upper Hessenberg matrix H is Schur decomposed as: X* X* H = Z*T*Z' X* X* where Z' denotes the transpose of Z, Z is a (real) orthogonal X* matrix, and T is in standardized Schur canonical form. "Schur X* canonical form" means that T is block upper-triangular with 1 x X* 1 and/or 2 x 2 blocks on the diagonal such that the 2 x 2 X* blocks have complex eigenvalues (this form is also called X* "quasi-triangular".) "Standardized" means that, if there are X* any 2 x 2 blocks on the diagonal, each is of the form: X* X* ( a c ) so that its eigenvalues are: X* ( -b a ) a +- sqrt(b*c)*i X* X* Depending on the value of the argument "JOB", DHSEQR will X* compute either (a) only enough of the Schur form to determine X* the eigenvalues, or (b) the entire matrix T, or (c) the X* matrices T and Z, or (d) the matrix T and X*Z, where X is a X* user-specified N x N matrix. (See also the description of the X* argument "Z".) In the last case, the matrix X will usually be X* the orthogonal matrix used to reduce a dense matrix to the X* Hessenberg matrix H, i.e., A = X*H*X', so that X*Z will be the X* Schur vector matrix for A. X* X* The number of shifts ("NS"), the blocksize ("NB"), and "MAXB" (see X* below) are obtained by a call to ENVIR. The workspace needed by X* the block multishift method depends on NS and NB; if the amount of X* workspace supplied is insufficient, the standard method from X* EISPACK (HQR/HQR2, here called DLAHQR) will be used instead. X* X* Also, if a block which has deflated is smaller than MAXB, DLAHQR X* will be used to compute its Schur decomposition. X* X* X* Arguments X* ========= X* X* JOB - CHARACTER*1 X* This specifies what DHSEQR will calculate: X* If JOB = 'E', compute eigenvalues only. X* If JOB = 'S', compute eigenvalues and T. X* If JOB = 'I', compute eigenvalues, T, and the Schur X* vectors (Z). X* If JOB = 'V', compute eigenvalues, T, and the Schur X* vectors (Z) premultiplied by the initial X* contents of the argument array Z (called X* "X" in the previous discussion.) X* Not modified. X* X* N - INTEGER X* N specifies the order of the matrix H. It must be at least X* zero. X* Not modified. X* X* H - DOUBLE PRECISION array, dimension (LDH,N) X* On entry, H contains the upper Hessenberg matrix H. X* If JOB is 'S', 'I', or 'V', then on exit this will contain X* the Schur matrix T. In any case, H will be modified. X* Modified. X* X* LDH - INTEGER X* LDH specifies the first dimension of H as X* declared in the calling (sub)program. LDH must be at X* least max(1, N). X* Not modified. X* X* WR,WI - DOUBLE PRECISION arrays, dimension (N) X* On exit, WR and WI contain the real and imaginary parts, X* respectively, of the computed eigenvalues. The eigenvalues X* will not be in any particular order, except that complex X* conjugate pairs of eigen-values will appear consecutively X* with the eigenvalue having the positive imaginary part X* first. X* X* Z - DOUBLE PRECISION array, dimension (LDZ,N) X* On entry: X* If JOB is 'V', then on entry Z is assumed to contain the X* matrix "X" described above, which will premultiply the X* matrix "Z" used to reduce H to Schur form. X* If JOB is not 'V', the initial contents of Z are ignored. X* X* If JOB is 'E' or 'S', Z is not referenced at all. X* If JOB is 'I', Z will be overwritten with the orthogonal X* matrix "Z" used to reduce H to Schur form. X* If JOB is 'V', the matrix in Z will be postmultiplied by X* the orthogonal matrix "Z", and the product will be X* returned. X* Not referenced if JOB='E' or 'S'. X* Modified if JOB='I' or 'V'. X* X* LDZ - INTEGER X* If JOB is 'I' or 'V', then LDZ specifies the leading X* dimension of Z as declared in the calling (sub)program, X* which must be at least max(1, N). X* If JOB is 'E' or 'S', LDZ is not referenced. X* Not modified. X* X* WORK - DOUBLE PRECISION array, dimension (LWORK) X* Workspace. X* Modified. X* X* LWORK - INTEGER X* LWORK specifies the number of words in WORK. The block X* multishift algorithm requires: X* MAX( K*(K+N) , MAXB*(MAXB+N) , N*MAX(2*NB+1,NB+NS+1) ) X* words; if LWORK is less than this, then the EISPACK X* algorithm (here called DLAHQR) will be used and INFO will X* be set to -10. X* Not modified. X* X* INFO - INTEGER X* INFO will be set to X* 0 if normal return. X* -K if input argument number K is illegal. X* If INFO=-10, then H, WR, WI, and Z will have been X* computed as specified by JOB. If INFO has some X* other negative value, no calculations will have X* been done. X* r*N + j If the calculation of H, WR, WI, and Z has failed. X* The eigenvalues in the WR and WI arrays should be X* correct for indices j+1,...,N. The value of "r" X* indicates the nature of the failure: X* r=0 The block multishift method failed to find all X* eigenvalues in 30*N iterations. X* r=1 The call to DLAHQR to find the shifts failed. X* r=2 The call to DLAHQR to process a subblock of H X* failed. X* r=3 DLAHQR was called because LWORK was too small, X* and DLAHQR failed to find all eigenvalues. X* X* X* Internal Parameters which may be modified by the user. X* ==================================================== X* X* NS - INTEGER X* This is set by a call to ENVIR. NS specifies the number X* of shifts used in each multishift QR iteration. NS should X* usually be much smaller than the order of matrix, say X* about n/20 to n/10. The variable actually used in the X* code is called "K", whose value is the same as NS, except X* restricted to be in the range 2 to N, and not greater than X* MAXB. (The restriction K <= MAXB is because DLAHQR will be X* called on a K x K submatrix to get the K shifts; if the X* block is K x K or less, then the shifts will be the X* eigenvalues.) X* Not modified. X* X* NB - INTEGER X* This is set by a call to ENVIR. NB specifies the blocksize X* used in the block "bulge chasing". NB should usually be X* much smaller than the order of matrix, say about n/20 to X* n/10. The variable actually used in the code is called X* "P", whose value is the same as NB, except restricted to be X* in the range 1 to N-2 (or 1, if N is less than 3). X* Not modified. X* X* MAXB - INTEGER X* This is set by a call to ENVIR. If a deflated block is X* MAXB x MAXB or smaller, it will be processed by DLAHQR. X* It must be at least 2, since the recognition and X* processing of 2x2 blocks corresponding to complex X* pairs of eigenvalues is done by DLAHQR. X* X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE, TWO X PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) X DOUBLE PRECISION DATA X PARAMETER ( DATA = 1.5D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, IAS, IERR, IFST, II, IJOB, ILST, ITEN, ITS, X $ IWK, J, JJ, JSH, K, KB, KEFF, KP, LEN, MAXB, X $ N0, NB, NJ, NS, P X DOUBLE PRECISION DIST, NORM, OVFL, SMALL, SMLNUM, SS, TAU, ULP, X $ UNFL X* .. X* .. External Functions .. X LOGICAL LSAME X INTEGER IDAMAX X DOUBLE PRECISION DLAMCH, DLANHS X EXTERNAL LSAME, IDAMAX, DLAMCH, DLANHS X* .. X* .. External Subroutines .. X EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLACPY, DLAHQR, X $ DLAHRD, DLARF, DLARFG, DLAZRO, DORML2, DSCAL, X $ ENVIR, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, MIN X* .. X* .. Executable Statements .. X* X* See "On a Block Implementation of the Hessenberg Multishift X* QR iteration" by Z. Bai and J. Demmel, LAPACK Working Note X* #8 for a detailed description of the algorithm. X* X* Decode and Test the input parameters X* X IF( LSAME( JOB, 'E' ) ) THEN X IJOB = 1 X ELSE IF( LSAME( JOB, 'S' ) ) THEN X IJOB = 2 X ELSE IF( LSAME( JOB, 'I' ) ) THEN X IJOB = 3 X ELSE IF( LSAME( JOB, 'V' ) ) THEN X IJOB = 4 X ELSE X IJOB = -1 X END IF X* X* Check for errors. X* X INFO = 0 X IF( IJOB.EQ.-1 ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( LDH.LT.MAX( 1, N ) ) THEN X INFO = -4 X END IF X IF( IJOB.GE.3 ) THEN X IF( LDZ.LT.MAX( 1, N ) ) X $ INFO = -6 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DHSEQR', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.EQ.0 ) X $ RETURN X* X* If the size of input matrix is smaller than MAXB, X* to call modified EISPACK DLAHQR immediately. X* X CALL ENVIR( 'EISPACK', MAXB ) X MAXB = MAX( MAXB, 2 ) X IF( N.LE.MAXB ) THEN X CALL DLAHQR( JOB, N, H, LDH, WR, WI, Z, LDZ, INFO ) X RETURN X END IF X* X* Determine the number of shifts and the blocksize. X* X CALL ENVIR( 'BLOCK', NB ) X CALL ENVIR( 'SHIFT', NS ) X K = MIN( MAXB, MAX( 2, NS ), N ) X P = MIN( MAX( NB, 1 ), MAX( 1, N-2 ) ) X* X* Check whether there is enough workspace. X* if not, use DLAHQR (modified EISPACK code.) X* X IF( LWORK.LT.MAX( K*( K+2 ), MAXB*( MAXB+N ), X $ ( K+P+1 )**2+N*MAX( 2*P+1, K+P+1 ) ) ) THEN X CALL DLAHQR( JOB, N, H, LDH, WR, WI, Z, LDZ, IERR ) X IF( IERR.EQ.0 ) THEN X INFO = -10 X ELSE X INFO = 3*N + IERR X END IF X RETURN X END IF X* X* Initialize Z, if necessary X* X IF( IJOB.EQ.3 ) THEN X CALL DLAZRO( N, N, ZERO, ONE, Z, LDZ ) X END IF X* X* Compute the 1-norm of the input Hessenberg matrix. X* X NORM = DLANHS( '1', N, H, LDH, WORK ) X IF( NORM.EQ.ZERO ) THEN X DO 10 I = 1, N X WR( I ) = ZERO X WI( I ) = ZERO X 10 CONTINUE X RETURN X END IF X* X* Set machine related contants. X* The code is organized so that if NORM <= sqrt(OVFL), X* overflow should not occur. X* X UNFL = DLAMCH( 'Safe minimum' ) X OVFL = DLAMCH( 'Overflow' ) X ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) X SMLNUM = MAX( UNFL*( N/ULP ), N/( ULP*OVFL ) ) X SMALL = MAX( SMLNUM, MIN( ( NORM*SMLNUM )*NORM, ULP*NORM ) ) X* X* Begin the main loop X* X* We do one step of the QR on the last unreduced (i.e., strictly X* non-zero on the subdiagonal) block that has not already been X* Schur decomposed. In other words, at each iteration, we X* consider the matrix to have the block form: X* X* ( H1 F12 F13 ) X* ( 0 H2 F23 ) X* ( 0 0 H3 ) X* X* where H3 is the part already in standardized Schur form (which X* may be 0 x 0), H2 is the unreduced Hessenberg block which will X* be operated on by this iteration, and H1 is the rest (which may X* also be 0 x 0) -- it will be (not necessarily unreduced) X* Hessenberg. F12, F13, and F23 are dense matrices. X* X* Important variables are: X* K -- The number of shifts (at least 2). X* P -- The blocksize, used in the bulge chasing. X* J -- The first row/column of the unreduced Hessenberg block (H2) X* N0 - The last row/column of the unreduced Hessenberg block (H2) X* NJ - The number of rows/columns in H2. Note that NJ > K X* whenever a block multishift iteration is done. (See the X* description of MAXB, above.) X* X* Thus, H2 is NJ x NJ, and the diagonal blocks are: X* X* H1 = H( 1:J-1 , 1:J-1 ) which is (J-1) x (J-1) X* H2 = H( J:N0 , J:N0 ) which is NJ x NJ X* H3 = H( N0+1:N , N0+1:N ) which is (N-N0) x (N-N0) X* X* Whenever H2 gets to be MAXB x MAXB or smaller, we use DLAHQR to X* finish the reduction to Schur form. DLAHQR also insures that X* 2x2 diagonal blocks with complex eigenvalues are put in X* standardized form. X* Also, if the submatrix: H(1:N0,1:N0) = ( H1 F12 ) X* ( 0 H2 ) X* is MAXB x MAXB or smaller, it will be processed by DLAHQR. X* X* X N0 = N X ITS = 0 X* X* X DO 120 ITEN = 30*N, 1, -1 X* X* If the matrix remaining to be processed ( H(1:N0,1:N0) ) is X* larger than MAXB x MAXB, find the last unreduced block. If X* the matrix remaining is MAXB x MAXB or smaller, leave the X* entire remaining part of the matrix: it will be processed X* by DLAHQR. X* X* This step defines J and NJ. X* X IF( N0.GT.MAXB ) THEN X DO 20 J = N0, 2, -1 X SS = ABS( H( J-1, J-1 ) ) + ABS( H( J, J ) ) X IF( SS.EQ.ZERO ) X $ SS = NORM X IF( ABS( H( J, J-1 ) ).LE.MAX( ULP*SS, SMALL ) ) X $ GO TO 30 X 20 CONTINUE X J = 1 X 30 CONTINUE X IF( J.GT.1 ) X $ H( J, J-1 ) = ZERO X NJ = N0 - J + 1 X ELSE X J = 1 X NJ = N0 X END IF X* X* If "H2" is larger than MAXB x MAXB, use the block X* multishift method. X* X IF( NJ.GT.MAXB ) THEN X* X* Find the eigenvalues of the K x K trailing matrix X* of H2 (H2 = H(J:N0,J:N0) ) -- they will be used X* as the K shifts. X* X* WORK(1:K) -- real part of shifts. X* WORK(K+1:2*K) -- imaginary part of shifts. X* WORK(IAS:IAS-1+K**2) = X* WORK(2*K+1:K**2+2*K) -- trailing K x K submatrix, which is X* fed to DLAHQR, to compute the shifts. X* WORK(IWK:*) = X* WORK(K**2+2*K+1:*) -- scratch. X* X ITS = ITS + 1 X* X* Form exceptional k-shifts X* X IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN X DO 40 II = 1, K X WORK( II ) = DATA*( ABS( H( N0-K+II, N0-K+II-1 ) )+ X $ ABS( H( N0-K+II, N0-K+II ) ) ) X WORK( II+K ) = ZERO X 40 CONTINUE X GO TO 50 X END IF X* X IAS = 2*K + 1 X IWK = IAS + K**2 X CALL DLACPY( 'F', K, K, H( N0-K+1, N0-K+1 ), LDH, X $ WORK( IAS ), K ) X CALL DLAHQR( 'E', K, WORK( IAS ), K, WORK( 1 ), WORK( K+1 ), X $ WORK( IWK ), K, IERR ) X IF( IERR.NE.ZERO ) THEN X INFO = N + N0 X GO TO 130 X END IF X* X* Determine the first column of X* (Aj - shfK)...(Aj - shf2)(Aj - shf1), X* where Aj = H(j:n0,j:n0). X* WR is used as workspace to store the (column) vector, X* and later the Householder vector. X* X 50 CONTINUE X DO 60 II = 2, K + 1 X WR( II ) = ZERO X 60 CONTINUE X WR( 1 ) = ONE X LEN = 1 X* X* Loop over shifts. If the shift is complex, do the X* shift and its complex conjugate (which is assumed X* to be the next shift) at the same time, and skip X* the next iteration. X* LEN is the length of the vector so far, i.e., number X* of shifts+1. Since complex eigenvalue pairs are X* always stored with positive imaginary part first, X* "IF ( LEN.LE.JSH )" has the same effect as X* "IF ( WORK(K+JSH).GE.ZERO )", but this code will work X* even if that is not true. However, the code will break X* if a complex eigenvalue is not immediately followed by X* its conjugate. X* X* If an intermediate product (vector) or the final X* product is zero, set it to (1,0,...) and continue. X* Note that if the final product is zero (and thus X* set to (1,0,...)), the resulting Householder X* transformation will be the identity. X* X DO 80 JSH = 1, K X IF( LEN.LE.JSH ) THEN X IF( WORK( K+JSH ).EQ.ZERO ) THEN X CALL DGEMV( 'N', LEN+1, LEN, ONE, H( J, J ), LDH, X $ WR, 1, ZERO, WI, 1 ) X CALL DAXPY( LEN+1, -WORK( JSH ), WR, 1, WI, 1 ) X CALL DCOPY( LEN+1, WI, 1, WR, 1 ) X LEN = LEN + 1 X ELSE X WI( LEN+2 ) = ZERO X DIST = WORK( JSH )*WORK( JSH ) + X $ WORK( K+JSH )*WORK( K+JSH ) X CALL DGEMV( 'N', LEN+1, LEN, ONE, H( J, J ), LDH, X $ WR, 1, ZERO, WI, 1 ) X CALL DGEMV( 'N', LEN+2, LEN+1, ONE, H( J, J ), LDH, X $ WI, 1, DIST, WR, 1 ) X CALL DAXPY( LEN+2, -TWO*WORK( JSH ), WI, 1, WR, 1 ) X LEN = LEN + 2 X END IF X* X* SS = DNRM2( LEN, WR, 1 ) X II = IDAMAX( LEN, WR, 1 ) X SS = ABS( WR( II ) ) X IF( SS.EQ.ZERO ) THEN X DO 70 II = 2, K + 1 X WR( II ) = ZERO X 70 CONTINUE X WR( 1 ) = ONE X ELSE X SS = ONE / SS X CALL DSCAL( LEN, SS, WR, 1 ) X END IF X END IF X 80 CONTINUE X* X* X* Determine the Householder transformation. X* X CALL DLARFG( LEN, WR( 1 ), WR( 2 ), 1, TAU ) X WR( 1 ) = ONE X* X* Pre- and Post-multiply H2 (= H(J:N0,J:N0) ) by Householder X* transformation (I - TAU WR WR' ) producing a K x K "bulge" X* X CALL DLARF( 'R', MIN( K+2, NJ ), K+1, WR, 1, TAU, H( J, J ), X $ LDH, WORK ) X CALL DLARF( 'L', K+1, NJ, WR, 1, TAU, H( J, J ), LDH, WORK ) X* X* Update F12 and F23 ( H(1:J-1,J:N0) and H(J:N0,N0+1:N) ) X* if Schur form is desired. X* X IF( IJOB.NE.1 ) THEN X IF( J.GT.1 ) X $ CALL DLARF( 'R', J-1, K+1, WR, 1, TAU, H( 1, J ), LDH, X $ WORK ) X IF( N0.LT.N ) X $ CALL DLARF( 'L', K+1, N-N0, WR, 1, TAU, H( J, N0+1 ), X $ LDH, WORK ) X* X* Update Z if Z (or XZ) is desired. X* X IF( IJOB.GE.3 ) THEN X CALL DLARF( 'R', N, K+1, WR, 1, TAU, Z( 1, J ), LDZ, X $ WORK ) X END IF X END IF X* X* Chase K-by-K bulge of H(J:N0,J:N0) down block by block to X* return it to upper Hessenberg form. X* X DO 90 KB = 1, ( NJ-3 ) / P + 1 X* X IFST = ( KB-1 )*P + J X ILST = MIN( IFST+P-1, N0-2 ) X KEFF = MIN( K, N0-IFST-1 ) X* X* "Chase" the bulge P columns/rows, only operating on H2. X* X* KEFF is the size of the bulge before chasing. X* DLAHRD will chase stuff rows/columns IFST:ILST X* to rows/columns ILST+1:2*ILST-IFST+1, except that X* what goes beyone row/column N0 goes away. X* IFST is the first column index in KBth block, X* ILST is the last column index. X* KP+1 is the number of the rows that are updated in KBth X* block bulge chasing. X* WORK(1:IWK-1) contains the orthogonal transformations X* U from the bulge chasing. X* X KP = MIN( P+KEFF, N0-IFST ) X IWK = ( KP+1 )**2 + 1 X CALL DLAHRD( NJ, KEFF, IFST-J+1, ILST-J+1, H( J, J ), X $ LDH, WORK, KP+1, WR, WORK( IWK ), NJ, IERR ) X* X* If Schur form is desired, update F12 and F23. X* X IF( IJOB.GT.1 ) THEN X LEN = ILST - IFST + 1 X* X* Postmultiply F12 by U (F12 = H(1:J-1,IFST:IFST+KP) ) X* X IF( J.GT.1 ) THEN X CALL DORML2( 'R', 'L', 'N', J-1, KP+1, LEN, 1, X $ WORK, KP+1, WR, H( 1, IFST ), LDH, X $ WORK( IWK ), IERR ) X END IF X* X* Premultiply F23 by U' ( F23 = H(IFST:IFST+KP,N0+1:N) ) X* X IF( N0.LT.N ) THEN X CALL DORML2( 'L', 'L', 'T', KP+1, N-N0, LEN, 1, X $ WORK, KP+1, WR, H( IFST, N0+1 ), LDH, X $ WORK( IWK ), IERR ) X END IF X* X* Accumulate orthogonal transformation in Z, if desired. X* X IF( IJOB.GE.3 ) THEN X CALL DORML2( 'R', 'L', 'N', N, KP+1, LEN, 1, WORK, X $ KP+1, WR, Z( 1, IFST ), LDZ, X $ WORK( IWK ), IERR ) X END IF X* X END IF X* X 90 CONTINUE X* X* Clean up -- zero out H2 below the sub-diagonal, so it will X* be exactly Hessenberg. X* X DO 110 JJ = J, N0 X DO 100 II = JJ + 2, MIN( JJ+K+1, N0 ) X H( II, JJ ) = ZERO X 100 CONTINUE X 110 CONTINUE X* X ELSE X* X* "H2" (or the entire remaining matrix) is MAXB x MAXB X* or smaller -- use DLAHQR to Schur decompose, and X* get NJ eigenvalues and eigenvectors (vectors in U). X* X ITS = 0 X IWK = NJ**2 + 1 X CALL DLAHQR( 'I', NJ, H( J, J ), LDH, WR( J ), WI( J ), X $ WORK, NJ, IERR ) X IF( IERR.NE.0 ) THEN X INFO = 2*N + N0 X GO TO 130 X END IF X* X* If Schur form desired. X* X IF( IJOB.NE.1 ) THEN X* X* Postmultiply F12 (i.e., H(1:J-1,J:N0) ) by U X* X IF( J.GT.1 ) THEN X CALL DGEMM( 'N', 'N', J-1, NJ, NJ, ONE, H( 1, J ), X $ LDH, WORK, NJ, ZERO, WORK( IWK ), J-1 ) X CALL DLACPY( 'F', J-1, NJ, WORK( IWK ), J-1, X $ H( 1, J ), LDH ) X END IF X* X* Premultiply F23 (i.e., H(J:N0,N0+1:N) ) by U' X* X IF( N0.LT.N ) THEN X CALL DGEMM( 'T', 'N', NJ, N-N0, NJ, ONE, WORK, NJ, X $ H( J, N0+1 ), LDH, ZERO, WORK( IWK ), NJ ) X CALL DLACPY( 'F', NJ, N-N0, WORK( IWK ), NJ, X $ H( J, N0+1 ), LDH ) X END IF X* X* Accumulate orthogonal transformation, if desired. X* X IF( IJOB.GE.3 ) THEN X CALL DGEMM( 'N', 'N', N, NJ, NJ, ONE, Z( 1, J ), LDZ, X $ WORK, NJ, ZERO, WORK( IWK ), N ) X CALL DLACPY( 'F', N, NJ, WORK( IWK ), N, Z( 1, J ), X $ LDZ ) X END IF X* X END IF X* X N0 = N0 - NJ X IF( N0.LE.0 ) X $ GO TO 130 X END IF X 120 CONTINUE X* X* Drop Through -- Not converged. Error condition. X* (but converged for N0+1:N) X* X INFO = N0 X* X* Exit (error & otherwise) X* X 130 CONTINUE X* X RETURN X* X* End of DHSEQR X* X END END_OF_FILE if test 25062 -ne `wc -c <'dhseqr.f'`; then echo shar: \"'dhseqr.f'\" unpacked with wrong size! fi # end of 'dhseqr.f' fi if test -f 'dlabad.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlabad.f'\" else echo shar: Extracting \"'dlabad.f'\" \(1482 characters\) sed "s/^X//" >'dlabad.f' <<'END_OF_FILE' X SUBROUTINE DLABAD( SMALL, LARGE ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X DOUBLE PRECISION LARGE, SMALL X* .. X* X* Purpose X* ======= X* X* DLABAD takes as input the values computed by DLAMCH for underflow X* and overflow, and returns the square root of each of these values X* if it seems we are on a Cray. X* X* Arguments X* ========= X* X* SMALL (input) DOUBLE PRECISION X* On entry, the underflow threshold as computed by DLAMCH. X* On exit, the square root of the input value if it seems we X* are on a Cray, otherwise unchanged. X* X* LARGE (input) DOUBLE PRECISION X* On entry, the overflow threshold as computed by DLAMCH. X* On exit, the square root of the input value if it seems we X* are on a Cray, otherwise unchanged. X* X* ===================================================================== X* X* .. Intrinsic Functions .. X INTRINSIC LOG10, SQRT X* .. X* .. Executable Statements .. X* X* If it looks like we're on a Cray, take the square root of X* SMALL and LARGE to avoid overflow and underflow problems. X* X IF( LOG10( LARGE ).GT.2000.D0 ) THEN X SMALL = SQRT( SMALL ) X LARGE = SQRT( LARGE ) X END IF X* X RETURN X* X* End of DLABAD X* X END END_OF_FILE if test 1482 -ne `wc -c <'dlabad.f'`; then echo shar: \"'dlabad.f'\" unpacked with wrong size! fi # end of 'dlabad.f' fi if test -f 'dlacpy.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlacpy.f'\" else echo shar: Extracting \"'dlacpy.f'\" \(2385 characters\) sed "s/^X//" >'dlacpy.f' <<'END_OF_FILE' X SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) X* X* -- LAPACK auxiliary routine X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER UPLO X INTEGER LDA, LDB, M, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), B( LDB, * ) X* .. X* X* Purpose X* ======= X* X* DLACPY copies all or part of a two-dimensional matrix A to another X* matrix B. X* X* Arguments X* ========= X* X* UPLO (input) CHARACTER*1 X* Specifies the part of the matrix A to be copied to B. X* = 'U': Upper triangular part X* = 'L': Lower triangular part X* Otherwise: All of the matrix A X* X* M (input) INTEGER X* The number of rows of the matrix A. X* X* N (input) INTEGER X* The number of columns of the matrix A. X* X* A (input) DOUBLE PRECISION array, dimension (LDA,N) X* The M x N matrix A. If UPLO = 'U', only the upper trapezium X* is accessed; if UPLO = 'L', only the lower trapezium is X* accessed. X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,M). X* X* B (output) DOUBLE PRECISION array, dimension (LDB,N) X* On exit, B = A in the locations specified by UPLO. X* X* LDB (input) INTEGER X* The leading dimension of the array B. LDB >= max(1,M). X* X* ===================================================================== X* X* .. Local Scalars .. X INTEGER I, J X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. Intrinsic Functions .. X INTRINSIC MIN X* .. X* .. Executable Statements .. X* X IF( LSAME( UPLO, 'U' ) ) THEN X DO 20 J = 1, N X DO 10 I = 1, MIN( J, M ) X B( I, J ) = A( I, J ) X 10 CONTINUE X 20 CONTINUE X ELSE IF( LSAME( UPLO, 'L' ) ) THEN X DO 40 J = 1, N X DO 30 I = J, M X B( I, J ) = A( I, J ) X 30 CONTINUE X 40 CONTINUE X ELSE X DO 60 J = 1, N X DO 50 I = 1, M X B( I, J ) = A( I, J ) X 50 CONTINUE X 60 CONTINUE X END IF X RETURN X* X* End of DLACPY X* X END END_OF_FILE if test 2385 -ne `wc -c <'dlacpy.f'`; then echo shar: \"'dlacpy.f'\" unpacked with wrong size! fi # end of 'dlacpy.f' fi if test -f 'dlaein.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlaein.f'\" else echo shar: Extracting \"'dlaein.f'\" \(29193 characters\) sed "s/^X//" >'dlaein.f' <<'END_OF_FILE' X SUBROUTINE DLAEIN( IJOB, IVECTO, N, H, LDH, RLAMBD, ILAMBD, UK, X $ LK, RE, LDRE, LE, LDLE, WORK, LDWORK, RWORK, X $ EPS3, SMLNUM, BIGNUM, INFO ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X INTEGER IJOB, INFO, IVECTO, LDH, LDLE, LDRE, LDWORK, X $ LK, N, UK X DOUBLE PRECISION BIGNUM, EPS3, ILAMBD, RLAMBD, SMLNUM X* .. X* X* .. Array Arguments .. X DOUBLE PRECISION H( LDH, * ), LE( LDLE, * ), RE( LDLE, * ), X $ RWORK( * ), WORK( LDWORK, * ) X* .. X* X* Purpose X* ======= X* X* This subroutine uses inverse iteration to find a specified right X* and/or left eigenvector of a real upper Hessenberg matrix. X* X* Arguments X* ========= X* X* IJOB - INTEGER X* IJOB specifies the computation to be performed by DLAEIN: X* as follows: X* If IJOB = 1, compute right eigenvectors only. X* If IJOB = 2, compute left eigenvectors only. X* If IJOB = 3, compute both right and left eigenvectors. X* Not modified. X* X* VECTOR - INTEGER X* IVECTO specifies the source of the initial vectors in X* inverse iteration. X* If IVECTO = 1, the user does not supply any initial X* vector for the inverse iteration. X* If IVECTO = 2, the user supplies the initial vectors X* in the array RE and/or LE. X* Not modified. X* X* N - INTEGER X* The order of the matrix H. X* N must be at least zero. X* Not modified. X* X* H - DOUBLE PRECISION array, dimension (LDH,N). X* H contains the matrix whose eigenvectors are to be computed. X* H must be a real upper Hessenberg matrix. X* Not modified. X* X* LDH - INTEGER. X* The first dimension of H as declared in the calling X* (sub)program. LDH must be at least max(1, N). X* Not modified. X* X* RLAMBD - DOUBLE PRECISION X* ILAMBD - DOUBLE PRECISION X* On entry, RLAMBD and ILAMBD are the real and imaginary X* parts, respectively, of the eigenvalues of H, whose X* corresponding right and/or left eigenvector is to be X* computed. X* Not modified. X* X* UK - INTEGER X* On entry, UK specifies the Hessenberg matrix X* H(1:UK, 1:UK) to be used in inverse iteration to find X* right eigenvector. If it is not known where to split X* the diagonal block, set UK = N. X* Not modified. X* X* LK - INTEGER X* On entry, LK specifies the Hessenberg matrix X* H(LK:N, LK:N) to be used in inverse iteration to find X* left eigenvector. If it is not known where to split X* the diagonal block, set LK = 1. X* Not modified. X* X* RE - DOUBLE PRECISION array, dimension (LDRE,2) X* If IVECTOR=2, then on entry RE must contain starting X* vectors for the inverse iteration for the right X* eigenvectors. X* X* The real part of *right* eigenvectors be stored in the first X* first column, and the *positive* imaginary part (if it X* exists) will be stored in the second column. X* X* The eigenvector will be normalized so that the component X* of largest magnitude is 1; here, the magnitude of a complex X* number x + iy is considered to be |x| + |y|. Eigenvector X* which do not pass an "acceptance test", i.e., for which the X* inverse iteration does not converge, will be set to zero. X* X* If IJOB = 1 or 3 , RE will be modified. X* If IJOB = 2, RE will not be referenced. X* X* LDRE - INTEGER X* LDRE specifies the leading dimension of RE as declared in X* the calling (sub)program. LDRE must be at least max(1, N). X* If IJOB = 2, LDRE is not referenced. X* Not modified. X* X* LE - DOUBLE PRECISION array, dimension (LDLE,2) X* If IVECTOR=2, then on entry LE must contain starting X* vectors for the inverse iteration for the right X* eigenvectors. X* X* The real part of *left* eigenvectors be stored in the first X* first column, and the *positive* imaginary part (if exits) X* will be stored in the second column. X* X* The eigenvector will be normalized so that the component X* of largest magnitude is 1; here, the magnitude of a complex X* number x + iy is considered to be |x| + |y|. Eigenvector X* which do not pass an "acceptance test", i.e., for which the X* inverse iteration does not converge, will be set to zero. X* X* If IJOB = 2 or 3, LE will be modified. X* If IJOB = 2, LE will not be referenced. X* X* LDLE - INTEGER X* LDLE specifies the leading dimension of LE as declared in X* the calling (sub)program. LDLE must be at least max(1, N). X* If IJOB = 2, LDLE is not referenced. X* Not modified. X* X* WORK - DOUBLE PRECISION array, dimension (LDWORK,N+2). X* WORK is a N+2 by N+2 workspace. X* WORK holds the triangularized form of the upper Hessenberg X* matrix. During the computation of complex eigenvectors, X* the real part of the triangular factor of (H - w) is stored X* in the upper triangle and the imaginary part is stored in X* the lower triangle starting at WORK(3,1). X* X* LDWORK - INTEGER X* The first dimension of WORK as declared in the calling X* (sub)program. LDWORK must be at least N+2. X* Not modified. X* X* RWORK - DOUBLE PRECISION array, dimension (N) X* Workspace. X* X* EPS3 - DOUBLE PRECISION X* The small number used in triangular decomposition and X* set initial vector. EPS3 = macheps*norm(H) X* X* SMLNUM - DOUBLE PRECISION X* BIGNUM - DOUBLE PRECISION X* Machine related number to control overflow. X* X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE, ONE1 X PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, ONE1 = 1.0D-1 ) X* .. X* X* .. Local Scalars .. X INTEGER I, IERR, ITS, J, MP X DOUBLE PRECISION GROWTO, LKROOT, NORM, NORMIN, NORMV, REC, X $ SCALE, UKROOT, VCRIT, VMAX, W, W1, W2, X, Y X* .. X* X* .. External Functions .. X DOUBLE PRECISION DLAPY2, DNRM2 X EXTERNAL DLAPY2, DNRM2 X* .. X* X* .. External Subroutines .. X EXTERNAL DLATRS, XERBLA X* .. X* X* .. Intrinsic Functions .. X INTRINSIC ABS, DBLE, MAX, SQRT X* .. X* X* .. Executable Statements .. X* X* Test the input parameter X* X INFO = 0 X IF( IJOB.LE.0 .OR. IJOB.GE.4 ) THEN X INFO = -1 X ELSE IF( IVECTO.LE.0 .OR. IVECTO.GE.3 ) THEN X INFO = -2 X ELSE IF( N.LT.0 ) THEN X INFO = -3 X ELSE IF( LDH.LT.MAX( 1, N ) ) THEN X INFO = -5 X ELSE IF( UK.LT.0 .OR. UK.GT.N ) THEN X INFO = -8 X ELSE IF( LK.LT.0 .OR. LK.GT.N ) THEN X INFO = -9 X ELSE IF( LDWORK.LT.MAX( 1, N+2 ) ) THEN X INFO = -15 X END IF X IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN X IF( LDRE.LT.MAX( 1, N ) ) X $ INFO = -11 X END IF X IF( IJOB.EQ.2 .OR. IJOB.EQ.3 ) THEN X IF( LDLE.LT.MAX( 1, N ) ) X $ INFO = -13 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DLAEIN', -INFO ) X RETURN X END IF X* X* Computer the selected right eigenvector X* X IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN X* X* GROWTO is the criterion for the growth. X* X UKROOT = SQRT( DBLE( UK ) ) X GROWTO = ONE1 / UKROOT X NORMIN = MAX( ONE, EPS3*UKROOT )*SMLNUM X* X* Form upper Hessenberg: WORK = H(1:UK,1:UK) - RLAMBD*I. X* X MP = 1 X DO 20 I = 1, UK X DO 10 J = MP, UK X WORK( I, J ) = H( I, J ) X 10 CONTINUE X WORK( I, I ) = WORK( I, I ) - RLAMBD X MP = I X 20 CONTINUE X* X IF( ILAMBD.NE.ZERO ) X $ GO TO 130 X* X* Real eigenvalue. LU-Triangular decomposition with X* partial pivoting of WORK, replacing zero pivots by EPS3. X* The upper triangular part of WORK stores the factor U. X* X IF( UK.EQ.1 ) X $ GO TO 60 X* X DO 50 I = 2, UK X MP = I - 1 X IF( ABS( WORK( MP, MP ) ).LT.ABS( WORK( I, MP ) ) ) THEN X* X* Interchange if necessary. X* X DO 30 J = MP, UK X Y = WORK( I, J ) X WORK( I, J ) = WORK( MP, J ) X WORK( MP, J ) = Y X 30 CONTINUE X END IF X IF( WORK( MP, MP ).EQ.ZERO ) X $ WORK( MP, MP ) = EPS3 X X = WORK( I, MP ) / WORK( MP, MP ) X IF( X.EQ.ZERO ) X $ GO TO 50 X DO 40 J = I, UK X WORK( I, J ) = WORK( I, J ) - X*WORK( MP, J ) X 40 CONTINUE X 50 CONTINUE X* X 60 CONTINUE X IF( WORK( UK, UK ).EQ.ZERO ) X $ WORK( UK, UK ) = EPS3 X* X* Compute each row norm of offdiagonal part of WORK to X* control overflow in triangular sovler. X* X DO 80 I = 1, UK - 1 X RWORK( I ) = ZERO X DO 70 J = I + 1, UK X RWORK( I ) = RWORK( I ) + ABS( WORK( I, J ) ) X 70 CONTINUE X 80 CONTINUE X RWORK( UK ) = ZERO X* X* Set the initial vector X* All initial vectors have 2-norm eps3*sqrt(uk) X* X IF( IVECTO.EQ.1 ) THEN X DO 90 I = 1, LK - 1 X WORK( I, N+1 ) = ZERO X 90 CONTINUE X DO 100 I = LK, UK X WORK( I, N+1 ) = EPS3 X 100 CONTINUE X ELSE X NORM = DNRM2( UK, RE( 1, 1 ), 1 ) X REC = ( EPS3*UKROOT ) / MAX( NORM, NORMIN ) X DO 110 I = 1, UK X WORK( I, N+1 ) = RE( I, 1 )*REC X 110 CONTINUE X END IF X* X ITS = 0 X* X* Solve triangular system: WORK*x = scale*b X* X 120 CONTINUE X CALL DLATRS( 'U', 'N', 'Y', UK, WORK, LDWORK, WORK( 1, N+1 ), X $ SCALE, RWORK, IERR ) X* X GO TO 290 X* X* Complex eigenvalue. LU-Triangular decomposition with X* partial pivoting of WORK. Store imaginary part of U X* in the lower triangle starting at WORK(3,1). X* Note that the imaginary part of the (i,j)-element (j>i) X* of the factor U is stored at the (j+2,i) position. X* X 130 CONTINUE X WORK( 3, 1 ) = -ILAMBD X DO 140 I = 4, UK + 2 X WORK( I, 1 ) = ZERO X 140 CONTINUE X* X DO 170 I = 2, UK X MP = I - 1 X W = WORK( I, MP ) X X = WORK( MP, MP )**2 + WORK( I+1, MP )**2 X IF( X.LT.W*W ) THEN X* X* Interchange and elimination X* X X = WORK( MP, MP ) / W X Y = WORK( I+1, MP ) / W X WORK( MP, MP ) = W X WORK( I+1, MP ) = ZERO X DO 150 J = I, UK X W = WORK( I, J ) X WORK( I, J ) = WORK( MP, J ) - X*W X WORK( MP, J ) = W X WORK( J+2, I ) = WORK( J+2, MP ) - Y*W X WORK( J+2, MP ) = ZERO X 150 CONTINUE X WORK( I+2, MP ) = -ILAMBD X WORK( I, I ) = WORK( I, I ) - Y*ILAMBD X WORK( I+2, I ) = WORK( I+2, I ) + X*ILAMBD X ELSE X* X* Elimination X* X IF( X.EQ.ZERO ) THEN X WORK( MP, MP ) = EPS3 X WORK( I+1, MP ) = ZERO X X = EPS3*EPS3 X END IF X W = W / X X X = WORK( MP, MP )*W X Y = -WORK( I+1, MP )*W X DO 160 J = I, UK X WORK( I, J ) = WORK( I, J ) - X*WORK( MP, J ) + X $ Y*WORK( J+2, MP ) X WORK( J+2, I ) = -X*WORK( J+2, MP ) - Y*WORK( MP, J ) X 160 CONTINUE X WORK( I+2, I ) = WORK( I+2, I ) - ILAMBD X END IF X 170 CONTINUE X* X IF( WORK( UK, UK ).EQ.ZERO .AND. WORK( UK+2, UK ).EQ.ZERO ) X $ WORK( UK, UK ) = EPS3 X* X* Compute each row norm of strictly upper triangular matrix X* to control overflow in triangular solver. X* X DO 190 I = 1, UK - 1 X RWORK( I ) = ZERO X DO 180 J = I + 1, UK X RWORK( I ) = RWORK( I ) + ABS( WORK( I, J ) ) + X $ ABS( WORK( J+2, I ) ) X 180 CONTINUE X 190 CONTINUE X RWORK( UK ) = ZERO X* X* Set initial vector X* X IF( IVECTO.EQ.1 ) THEN X DO 200 I = 1, LK - 1 X WORK( I, N+1 ) = ZERO X WORK( I, N+2 ) = ZERO X 200 CONTINUE X DO 210 I = LK, UK X WORK( I, N+1 ) = EPS3 X WORK( I, N+2 ) = ZERO X 210 CONTINUE X ELSE X NORM = DLAPY2( DNRM2( UK, RE( 1, 1 ), 1 ), X $ DNRM2( UK, RE( 1, 2 ), 1 ) ) X REC = ( EPS3*UKROOT ) / MAX( NORM, NORMIN ) X DO 220 I = 1, UK X WORK( I, N+1 ) = RE( I, 1 )*REC X WORK( I, N+2 ) = RE( I, 2 )*REC X 220 CONTINUE X END IF X* X ITS = 0 X* X* Backward substitution for solving complex triangular X* system in real arithmetic. X* (WORKr + i*WORKi)*(xr + i*xi) = scale*(br + i*bi) X* X 230 CONTINUE X SCALE = ONE X VMAX = ONE X VCRIT = BIGNUM X DO 280 I = UK, 1, -1 X* X IF( RWORK( I ).GT.VCRIT ) THEN X REC = ONE / VMAX X DO 240 J = 1, UK X WORK( J, N+1 ) = WORK( J, N+1 )*REC X WORK( J, N+2 ) = WORK( J, N+2 )*REC X 240 CONTINUE X SCALE = SCALE*REC X VMAX = ONE X VCRIT = BIGNUM X END IF X* X X = WORK( I, N+1 ) X Y = WORK( I, N+2 ) X DO 250 J = I + 1, UK X X = X - WORK( I, J )*WORK( J, N+1 ) + X $ WORK( J+2, I )*WORK( J, N+2 ) X Y = Y - WORK( I, J )*WORK( J, N+2 ) - X $ WORK( J+2, I )*WORK( J, N+1 ) X 250 CONTINUE X* X W = ABS( WORK( I, I ) ) + ABS( WORK( I+2, I ) ) X IF( W.GT.SMLNUM ) THEN X IF( W.LT.ONE ) THEN X W1 = ABS( X ) + ABS( Y ) X IF( W1.GT.W*BIGNUM ) THEN X REC = ONE / W1 X DO 260 J = 1, UK X WORK( J, N+1 ) = WORK( J, N+1 )*REC X WORK( J, N+2 ) = WORK( J, N+2 )*REC X 260 CONTINUE X X = WORK( I, N+1 ) X Y = WORK( I, N+2 ) X SCALE = SCALE*REC X VMAX = VMAX*REC X END IF X END IF X* X* Complex division (X + iY)/(WORK(I,I)+iWORK(I+2,I)) X* X IF( ABS( WORK( I+2, I ) ).LT.ABS( WORK( I, I ) ) ) THEN X W1 = WORK( I+2, I ) / WORK( I, I ) X W2 = WORK( I, I ) + WORK( I+2, I )*W1 X WORK( I, N+1 ) = ( X+Y*W1 ) / W2 X WORK( I, N+2 ) = ( Y-X*W1 ) / W2 X ELSE X W1 = WORK( I, I ) / WORK( I+2, I ) X W2 = WORK( I+2, I ) + WORK( I, I )*W1 X WORK( I, N+1 ) = ( Y+X*W1 ) / W2 X WORK( I, N+2 ) = ( -X+Y*W1 ) / W2 X END IF X VMAX = MAX( ABS( WORK( I, N+1 ) )+ABS( WORK( I, N+2 ) ), X $ VMAX ) X VCRIT = BIGNUM / VMAX X ELSE X DO 270 J = 1, UK X WORK( J, N+1 ) = ZERO X WORK( J, N+2 ) = ZERO X 270 CONTINUE X WORK( I, N+1 ) = ONE X WORK( I, N+2 ) = ONE X SCALE = ZERO X VMAX = ONE X VCRIT = BIGNUM X END IF X* X 280 CONTINUE X* X* Acceptance test for real or complex eigenvector. X* X 290 CONTINUE X ITS = ITS + 1 X* X NORM = ZERO X IF( ILAMBD.EQ.ZERO ) THEN X DO 300 I = 1, UK X NORM = NORM + ABS( WORK( I, N+1 ) ) X 300 CONTINUE X ELSE X DO 310 I = 1, UK X NORM = NORM + ABS( WORK( I, N+1 ) ) + X $ ABS( WORK( I, N+2 ) ) X 310 CONTINUE X END IF X IF( NORM.LT.GROWTO*SCALE ) X $ GO TO 360 X* X* Accept vector - normalization. X* X NORMV = ZERO X IF( ILAMBD.EQ.ZERO ) THEN X DO 320 I = 1, UK X NORMV = MAX( NORMV, ABS( WORK( I, N+1 ) ) ) X 320 CONTINUE X NORMV = ONE / NORMV X DO 330 I = 1, UK X RE( I, 1 ) = WORK( I, N+1 )*NORMV X 330 CONTINUE X ELSE X DO 340 I = 1, UK X NORMV = MAX( NORMV, ABS( WORK( I, N+1 ) )+ X $ ABS( WORK( I, N+2 ) ) ) X 340 CONTINUE X NORMV = ONE / NORMV X DO 350 I = 1, UK X RE( I, 1 ) = WORK( I, N+1 )*NORMV X RE( I, 2 ) = WORK( I, N+2 )*NORMV X 350 CONTINUE X END IF X* X IF( UK.EQ.N ) X $ GO TO 420 X J = UK + 1 X GO TO 390 X* X* Choosing a new starting vector. X* X 360 CONTINUE X IF( ITS.GE.UK ) X $ GO TO 380 X Y = EPS3 / ( UKROOT+ONE ) X WORK( 1, N+1 ) = EPS3 X* X DO 370 I = 2, UK X WORK( I, N+1 ) = Y X 370 CONTINUE X* X J = UK - ITS + 1 X WORK( J, N+1 ) = WORK( J, N+1 ) - EPS3*UKROOT X IF( ILAMBD.EQ.ZERO ) X $ GO TO 120 X GO TO 230 X* X* Set error -- unaccepted eigenvector. X* X 380 CONTINUE X J = 1 X* X* Set remaining vector components to zero. X* X 390 CONTINUE X DO 400 I = J, N X RE( I, 1 ) = ZERO X 400 CONTINUE X IF( ILAMBD.NE.ZERO ) THEN X DO 410 I = J, N X RE( I, 2 ) = ZERO X 410 CONTINUE X END IF X* X END IF X* X* Compute selected left eigenvector. X* X 420 CONTINUE X IF( IJOB.EQ.2 .OR. IJOB.EQ.3 ) THEN X* X* GROWTO is the criterion for the growth. X* X LKROOT = SQRT( DBLE( N-LK+1 ) ) X GROWTO = ONE1 / LKROOT X NORMIN = MAX( ONE, EPS3*LKROOT )*SMLNUM X* X* Form upper Hessenberg: X* WORK(LK:N,LK:N) = H(LK:N,LK:N) - RLAMBD*I. X* X MP = LK X DO 440 I = LK, N X DO 430 J = MP, N X WORK( I, J ) = H( I, J ) X 430 CONTINUE X WORK( I, I ) = WORK( I, I ) - RLAMBD X MP = I X 440 CONTINUE X* X IF( ILAMBD.NE.ZERO ) X $ GO TO 550 X* X* Real eigenvalue. UL-Triangular decomposition with X* partial pivoting of WORK, replacing zero pivots by EPS3. X* Note that the lower triangular L is stored at the X* upper triangular part of working array WORK. X* X IF( LK.EQ.N ) X $ GO TO 480 X* X DO 470 J = N, LK + 1, -1 X IF( ABS( WORK( J, J ) ).LT.ABS( WORK( J, J-1 ) ) ) THEN X* X* Interchange if necessary X* X DO 450 I = LK, J X Y = WORK( I, J ) X WORK( I, J ) = WORK( I, J-1 ) X WORK( I, J-1 ) = Y X 450 CONTINUE X END IF X IF( WORK( J, J ).EQ.ZERO ) X $ WORK( J, J ) = EPS3 X X = WORK( J, J-1 ) / WORK( J, J ) X IF( X.EQ.ZERO ) X $ GO TO 470 X DO 460 I = LK, J X WORK( I, J-1 ) = WORK( I, J-1 ) - X*WORK( I, J ) X 460 CONTINUE X 470 CONTINUE X* X 480 CONTINUE X IF( WORK( LK, LK ).EQ.ZERO ) X $ WORK( LK, LK ) = EPS3 X* X* Compute each column norm of offdiagonal part of WORK to X* control overflow in triangular solve. X* X RWORK( LK ) = ZERO X DO 500 J = LK + 1, N X RWORK( J ) = ZERO X DO 490 I = LK, J - 1 X RWORK( J ) = RWORK( J ) + ABS( WORK( I, J ) ) X 490 CONTINUE X 500 CONTINUE X* X* Set the initial vector X* X IF( IVECTO.EQ.1 ) THEN X DO 510 I = LK, UK X WORK( I, N+1 ) = EPS3 X 510 CONTINUE X DO 520 I = UK + 1, N X WORK( I, N+1 ) = ZERO X 520 CONTINUE X ELSE X NORM = DNRM2( N-LK+1, LE( LK, 1 ), 1 ) X REC = ( EPS3*LKROOT ) / MAX( NORM, NORMIN ) X DO 530 I = LK, N X WORK( I, N+1 ) = LE( I, 1 )*REC X 530 CONTINUE X END IF X* X ITS = 0 X* X* Solve triangular system: WORK'*x = scale*le(:,s) X* X 540 CONTINUE X CALL DLATRS( 'U', 'T', 'Y', N-LK+1, WORK( LK, LK ), LDWORK, X $ WORK( LK, N+1 ), SCALE, RWORK( LK ), IERR ) X* X GO TO 710 X* X* Complex eigenvalue. UL-Triangular decomposition with X* partial pivoting of WORK. Store imaginary parts of U X* in the lower triangule starting at WORK(3,1). X* Note that the imaginary part of the (i,j) element (j>i) X* of the factor U is stored at (j+2,i) position of WORK. X* X 550 CONTINUE X WORK( N+2, N ) = -ILAMBD X DO 560 J = LK, N - 1 X WORK( N+2, J ) = ZERO X 560 CONTINUE X* X DO 590 J = N, LK + 1, -1 X W = WORK( J, J-1 ) X X = WORK( J, J )**2 + WORK( J+2, J )**2 X IF( X.LT.W*W ) THEN X* X* Interchange and elimination X* X X = WORK( J, J ) / W X Y = WORK( J+2, J ) / W X WORK( J, J ) = W X WORK( J+2, J ) = ZERO X DO 570 I = LK, J - 1 X W = WORK( I, J-1 ) X WORK( I, J-1 ) = WORK( I, J ) - X*W X WORK( I, J ) = W X WORK( J+1, I ) = WORK( J+2, I ) - Y*W X WORK( J+2, I ) = ZERO X 570 CONTINUE X WORK( J+2, J-1 ) = -ILAMBD X WORK( J-1, J-1 ) = WORK( J-1, J-1 ) - Y*ILAMBD X WORK( J+1, J-1 ) = WORK( J+1, J-1 ) + X*ILAMBD X ELSE X* X* Elimination X* X IF( X.EQ.ZERO ) THEN X WORK( J, J ) = EPS3 X WORK( J+2, J ) = ZERO X X = EPS3*2 X END IF X W = W / X X X = WORK( J, J )*W X Y = -WORK( J+2, J )*W X DO 580 I = LK, J X WORK( I, J-1 ) = WORK( I, J-1 ) - X*WORK( I, J ) + X $ Y*WORK( J+2, I ) X WORK( J+1, I ) = -X*WORK( J+2, I ) - Y*WORK( I, J ) X 580 CONTINUE X WORK( J+1, J-1 ) = WORK( J+1, J-1 ) - ILAMBD X END IF X 590 CONTINUE X* X IF( WORK( LK, LK ).EQ.ZERO .AND. WORK( LK+2, LK ).EQ.ZERO ) X $ WORK( LK, LK ) = EPS3 X* X* Set initial vector. X* X IF( IVECTO.EQ.1 ) THEN X DO 600 I = LK, UK X WORK( I, N+1 ) = EPS3 X WORK( I, N+2 ) = ZERO X 600 CONTINUE X DO 610 I = UK + 1, N X WORK( I, N+1 ) = ZERO X WORK( I, N+2 ) = ZERO X 610 CONTINUE X ELSE X NORM = DLAPY2( DNRM2( N-LK+1, LE( LK, 1 ), 1 ), X $ DNRM2( N-LK+1, LE( LK, 2 ), 1 ) ) X REC = ( EPS3*LKROOT ) / MAX( NORM, NORMIN ) X DO 620 I = LK, N X WORK( I, N+1 ) = LE( I, 1 )*REC X WORK( I, N+2 ) = LE( I, 2 )*REC X 620 CONTINUE X END IF X* X ITS = 0 X* X* Compute 1-norm of each column of strictly upper X* triangular part to control overflow in triangular solver. X* X RWORK( LK ) = ZERO X DO 640 J = LK + 1, N X RWORK( J ) = ZERO X DO 630 I = LK, J - 1 X RWORK( J ) = RWORK( J ) + ABS( WORK( I, J ) ) + X $ ABS( WORK( J+2, I ) ) X 630 CONTINUE X 640 CONTINUE X* X* Forward substitution for solving triangular system. X* (WORKr + i*WORKi)'*(xr + i*xi) = scale*(br + i*bi) X* in real arithmetic. X* X 650 CONTINUE X SCALE = ONE X VMAX = ONE X VCRIT = BIGNUM X DO 700 I = LK, N X* X IF( RWORK( I ).GT.VCRIT ) THEN X REC = ONE / VMAX X DO 660 J = LK, N X WORK( J, N+1 ) = WORK( J, N+1 )*REC X WORK( J, N+2 ) = WORK( J, N+2 )*REC X 660 CONTINUE X SCALE = SCALE*REC X VMAX = ONE X VCRIT = BIGNUM X END IF X* X X = WORK( I, N+1 ) X Y = WORK( I, N+2 ) X DO 670 J = LK, I - 1 X X = X - WORK( J, I )*WORK( J, N+1 ) - X $ WORK( I+2, J )*WORK( J, N+2 ) X Y = Y - WORK( J, I )*WORK( J, N+2 ) + X $ WORK( I+2, J )*WORK( J, N+1 ) X 670 CONTINUE X* X W = ABS( WORK( I, I ) ) + ABS( WORK( I+2, I ) ) X IF( W.GT.SMLNUM ) THEN X* X IF( W.LT.ONE ) THEN X W1 = ABS( X ) + ABS( Y ) X IF( W1.GT.W*BIGNUM ) THEN X REC = ONE / W1 X DO 680 J = LK, N X WORK( J, N+1 ) = WORK( J, N+1 )*REC X WORK( J, N+2 ) = WORK( J, N+2 )*REC X 680 CONTINUE X X = WORK( I, N+1 ) X Y = WORK( I, N+2 ) X SCALE = SCALE*REC X VMAX = VMAX*REC X END IF X END IF X* X* Complex division (X + i*Y)/(WORK(I,I)-i*WORK(I+2,I)) X* X IF( ABS( WORK( I+2, I ) ).LT.ABS( WORK( I, I ) ) ) THEN X W1 = -WORK( I+2, I ) / WORK( I, I ) X W2 = WORK( I, I ) - WORK( I+2, I )*W1 X WORK( I, N+1 ) = ( X+Y*W1 ) / W2 X WORK( I, N+2 ) = ( Y-X*W1 ) / W2 X ELSE X W1 = -WORK( I, I ) / WORK( I+2, I ) X W2 = -WORK( I+2, I ) + WORK( I, I )*W1 X WORK( I, N+1 ) = ( Y+X*W1 ) / W2 X WORK( I, N+2 ) = ( -X+Y*W1 ) / W2 X END IF X* X VMAX = MAX( ABS( WORK( I, N+1 ) )+ABS( WORK( I, N+2 ) ), X $ VMAX ) X VCRIT = BIGNUM / VMAX X ELSE X DO 690 J = LK, N X WORK( J, N+1 ) = ZERO X WORK( J, N+2 ) = ZERO X 690 CONTINUE X WORK( I, N+1 ) = ONE X WORK( I, N+2 ) = ONE X SCALE = ZERO X VMAX = ONE X VCRIT = BIGNUM X END IF X* X 700 CONTINUE X* X* Acceptance test for real or complex eigenvector X* X 710 CONTINUE X ITS = ITS + 1 X* X NORM = ZERO X IF( ILAMBD.EQ.ZERO ) THEN X DO 720 I = LK, N X NORM = NORM + ABS( WORK( I, N+1 ) ) X 720 CONTINUE X ELSE X DO 730 I = LK, N X NORM = NORM + ABS( WORK( I, N+1 ) ) + X $ ABS( WORK( I, N+2 ) ) X 730 CONTINUE X END IF X IF( NORM.LT.GROWTO*SCALE ) X $ GO TO 780 X* X* Accept vector - normalization. X* X NORMV = ZERO X IF( ILAMBD.EQ.ZERO ) THEN X DO 740 I = LK, N X NORMV = MAX( NORMV, ABS( WORK( I, N+1 ) ) ) X 740 CONTINUE X NORMV = ONE / NORMV X DO 750 I = LK, N X LE( I, 1 ) = WORK( I, N+1 )*NORMV X 750 CONTINUE X ELSE X DO 760 I = LK, N X NORMV = MAX( NORMV, ABS( WORK( I, N+1 ) )+ X $ ABS( WORK( I, N+2 ) ) ) X 760 CONTINUE X NORMV = ONE / NORMV X DO 770 I = LK, N X LE( I, 1 ) = WORK( I, N+1 )*NORMV X LE( I, 2 ) = WORK( I, N+2 )*NORMV X 770 CONTINUE X END IF X* X IF( LK.EQ.1 ) X $ GO TO 840 X J = LK - 1 X GO TO 810 X* X* Choosing a new starting vector. X* X 780 CONTINUE X IF( ITS.GE.N-LK+1 ) X $ GO TO 800 X Y = EPS3 / ( LKROOT+ONE ) X WORK( LK, N+1 ) = EPS3 X* X DO 790 I = LK + 1, N X WORK( I, N+1 ) = Y X 790 CONTINUE X* X J = N - ITS + 1 X WORK( J, N+1 ) = WORK( J, N+1 ) - EPS3*LKROOT X IF( ILAMBD.EQ.ZERO ) X $ GO TO 540 X GO TO 650 X* X* Set error -- unaccepted eigenvector. X* X 800 CONTINUE X J = N X* X* Set remaining vector components to zero. X* X 810 CONTINUE X DO 820 I = 1, J X LE( I, 1 ) = ZERO X 820 CONTINUE X IF( ILAMBD.NE.ZERO ) THEN X DO 830 I = 1, J X LE( I, 2 ) = ZERO X 830 CONTINUE X END IF X* X END IF X* X 840 CONTINUE X* X RETURN X* X* End of DLAEIN X* X END END_OF_FILE if test 29193 -ne `wc -c <'dlaein.f'`; then echo shar: \"'dlaein.f'\" unpacked with wrong size! fi # end of 'dlaein.f' fi if test -f 'dlafts.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlafts.f'\" else echo shar: Extracting \"'dlafts.f'\" \(5466 characters\) sed "s/^X//" >'dlafts.f' <<'END_OF_FILE' X SUBROUTINE DLAFTS( TYPE, M, N, IMAT, NTESTS, RESULT, ISEED, X $ THRESH, IOUNIT, IE ) X* X* -- LAPACK auxiliary test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER*3 TYPE X INTEGER IE, IMAT, IOUNIT, M, N, NTESTS X DOUBLE PRECISION THRESH X* .. X* .. Array Arguments .. X INTEGER ISEED( 4 ) X DOUBLE PRECISION RESULT( * ) X* X integer ifirst X save ifirst X* .. X* X* Purpose X* ======= X* X* DLAFTS tests the result vector against the threshold value to X* see which tests for this matrix type failed to pass the threshold. X* Output is to the file given by unit IOUNIT. X* X* Arguments X* ========= X* X* TYPE - CHARACTER*3 X* On entry, TYPE specifies the matrix type to be used in the X* printed messages. X* Not modified. X* X* N - INTEGER X* On entry, N specifies the order of the test matrix. X* Not modified. X* X* IMAT - INTEGER X* On entry, IMAT specifies the type of the test matrix. X* A listing of the different types is printed by DLAHD2 X* to the output file if a test fails to pass the threshold. X* Not modified. X* X* NTESTS - INTEGER X* On entry, NTESTS is the number of tests performed on the X* subroutines in the path given by TYPE. X* Not modified. X* X* RESULT - DOUBLE PRECISION array of dimension( NTESTS ) X* On entry, RESULT contains the test ratios from the tests X* performed in the calling program. X* Not modified. X* X* ISEED - INTEGER array of dimension( 4 ) X* Contains the random seed that generated the matrix used X* for the tests whose ratios are in RESULT. X* Not modified. X* X* THRESH - DOUBLE PRECISION X* On entry, THRESH specifies the acceptable threshold of the X* test ratios. If RESULT( K ) > THRESH, then the K-th test X* did not pass the threshold and a message will be printed. X* Not modified. X* X* IOUNIT - INTEGER X* On entry, IOUNIT specifies the unit number of the file X* to which the messages are printed. X* Not modified. X* X* IE - INTEGER X* On entry, IE contains the number of tests which have X* failed to pass the threshold so far. X* Updated on exit if any of the ratios in RESULT also fail. X* X* .. Local Scalars .. X INTEGER K X* .. X* .. External Subroutines .. X EXTERNAL DLAHD2 X* .. X* .. Executable Statements .. X* X IF( M.EQ.N ) THEN X* X* Output for square matrices: X* X DO 10 K = 1, NTESTS X IF( RESULT( K ).GE.THRESH ) THEN X* X* If this is the first test to fail, call DLAHD2 X* to print a header to the data file. X* X IF( IE.EQ.0 .and. ifirst .eq. 0) then X ifirst=1 X CALL DLAHD2( IOUNIT, TYPE ) X endif X* X IE = IE + 1 X*** WRITE( IOUNIT, 15 )' Matrix of order', N, X*** $ ', type ', IMAT, X*** $ ', test ', K, X*** $ ', ratio = ', RESULT( K ) X*** 15 FORMAT( A16, I5, 2( A8, I2 ), A11, G13.6 ) X IF( RESULT( K ).LT.10000.0D0 ) THEN X WRITE( IOUNIT, FMT = 9999 )N, IMAT, ISEED, K, X $ RESULT( K ) X 9999 FORMAT( ' Matrix order=', I5, ', type=', I2, X $ ', seed=', 4( I4, ',' ), ' result ', I2, ' is', X $ 0P, F8.2 ) X ELSE X WRITE( IOUNIT, FMT = 9998 )N, IMAT, ISEED, K, X $ RESULT( K ) X 9998 FORMAT( ' Matrix order=', I5, ', type=', I2, X $ ', seed=', 4( I4, ',' ), ' result ', I2, ' is', X $ 1P, D10.3 ) X END IF X END IF X 10 CONTINUE X ELSE X* X* Output for rectangular matrices X* X DO 20 K = 1, NTESTS X IF( RESULT( K ).GE.THRESH ) THEN X* X* If this is the first test to fail, call DLAHD2 X* to print a header to the data file. X* X IF( IE.EQ.0 ) X $ CALL DLAHD2( IOUNIT, TYPE ) X IE = IE + 1 X*** WRITE( IOUNIT, FMT = 9997 )' Matrix of size', M, ' x', X*** $ N, ', type ', IMAT, ', test ', K, ', ratio = ', X*** $ RESULT( K ) X*** 9997 FORMAT( A10, I5, A2, I5, A7, I2, A8, I2, A11, G13.6 ) X IF( RESULT( K ).LT.10000.0D0 ) THEN X WRITE( IOUNIT, FMT = 9997 )M, N, IMAT, ISEED, K, X $ RESULT( K ) X 9997 FORMAT( 1X, I5, ' x', I5, ' matrix, type=', I2, ', s', X $ 'eed=', 3( I4, ',' ), I4, ': result ', I2, X $ ' is', 0P, F8.2 ) X ELSE X WRITE( IOUNIT, FMT = 9996 )M, N, IMAT, ISEED, K, X $ RESULT( K ) X 9996 FORMAT( 1X, I5, ' x', I5, ' matrix, type=', I2, ', s', X $ 'eed=', 3( I4, ',' ), I4, ': result ', I2, X $ ' is', 1P, D10.3 ) X END IF X END IF X 20 CONTINUE X* X END IF X RETURN X* X* End of DLAFTS X* X END END_OF_FILE if test 5466 -ne `wc -c <'dlafts.f'`; then echo shar: \"'dlafts.f'\" unpacked with wrong size! fi # end of 'dlafts.f' fi if test -f 'dlahd2.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlahd2.f'\" else echo shar: Extracting \"'dlahd2.f'\" \(11630 characters\) sed "s/^X//" >'dlahd2.f' <<'END_OF_FILE' X SUBROUTINE DLAHD2( IOUNIT, PATH ) X* X* -- LAPACK auxiliary test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER*3 PATH X INTEGER IOUNIT X* .. X* X* Purpose X* ======= X* X* DLAHD2 prints header information for the different test paths. X* X* Arguments X* ========= X* X* IOUNIT (input) INTEGER. X* On entry, IOUNIT specifies the unit number to which the X* header information should be printed. X* X* PATH (input) CHARACTER*3. X* On entry, PATH contains the name of the path for which the X* header information is to be printed. Current paths are X* X* SHS, CHS: Non-symmetric eigenproblem. X* SST, CST: Symmetric eigenproblem. X* SBD, CBD: Singular Value Decomposition (SVD) X* X* These paths also are supplied in double precision (replace X* leading S by D and leading C by Z in path names). X* X*----------------------------------------------------------------------- X* X* .. Local Scalars .. X INTEGER ITYPE, J X* .. X* .. External Functions .. X LOGICAL LSAMEN X EXTERNAL LSAMEN X* .. X* X*----------------------------------------------------------------------- X* .. Executable Statements .. X* X* X* X IF( IOUNIT.LE.0 ) X $ RETURN X* X* X* First line describing this path X* X* X IF( LSAMEN( 3, PATH, 'SHS' ) .OR. LSAMEN( 3, PATH, 'DHS' ) ) THEN X ITYPE = 1 X WRITE( IOUNIT, FMT = 9999 )PATH X* X ELSE IF( LSAMEN( 3, PATH, 'CHS' ) .OR. LSAMEN( 3, PATH, 'ZHS' ) ) X $ THEN X ITYPE = 2 X WRITE( IOUNIT, FMT = 9998 )PATH X* X ELSE IF( LSAMEN( 3, PATH, 'SST' ) .OR. LSAMEN( 3, PATH, 'DST' ) ) X $ THEN X ITYPE = 3 X WRITE( IOUNIT, FMT = 9997 )PATH X* X ELSE IF( LSAMEN( 3, PATH, 'CST' ) .OR. LSAMEN( 3, PATH, 'ZST' ) ) X $ THEN X ITYPE = 4 X WRITE( IOUNIT, FMT = 9996 )PATH X* X ELSE IF( LSAMEN( 3, PATH, 'SBD' ) .OR. LSAMEN( 3, PATH, 'DBD' ) ) X $ THEN X ITYPE = 5 X WRITE( IOUNIT, FMT = 9995 )PATH X* X ELSE IF( LSAMEN( 3, PATH, 'CBD' ) .OR. LSAMEN( 3, PATH, 'ZBD' ) ) X $ THEN X ITYPE = 6 X WRITE( IOUNIT, FMT = 9994 )PATH X ELSE X RETURN X END IF X* X* X* . . . . . . . . . . . . . .. X* X* X* Matrix types X* X* X* X* Real Non-symmetric Eigenvalue Problem: X* X* X IF( ITYPE.EQ.1 ) THEN X* X WRITE( IOUNIT, FMT = 9993 ) X WRITE( IOUNIT, FMT = 9992 ) X WRITE( IOUNIT, FMT = 9991 )'pairs ', 'pairs ', 'prs.', 'prs.' X WRITE( IOUNIT, FMT = 9990 ) X* X* Tests performed X* X WRITE( IOUNIT, FMT = 9989 )'orthogonal', '''=transpose', X $ ( '''', J = 1, 6 ) X* X* X* Complex Non-symmetric Eigenvalue Problem: X* X* X ELSE IF( ITYPE.EQ.2 ) THEN X WRITE( IOUNIT, FMT = 9993 ) X WRITE( IOUNIT, FMT = 9992 ) X WRITE( IOUNIT, FMT = 9991 )'e.vals', 'e.vals', 'e.vs', 'e.vs' X WRITE( IOUNIT, FMT = 9990 ) X* X* Tests performed X* X WRITE( IOUNIT, FMT = 9989 )'unitary', '*=conj.transp.', X $ ( '*', J = 1, 6 ) X* X* X* Real Symmetric Eigenvalue Problem: X* X* X ELSE IF( ITYPE.EQ.3 ) THEN X WRITE( IOUNIT, FMT = 9988 ) X WRITE( IOUNIT, FMT = 9987 ) X WRITE( IOUNIT, FMT = 9986 )'Symmetric' X* X* Tests performed X* X WRITE( IOUNIT, FMT = 9985 )'orthogonal', '''=transpose', X $ ( '''', J = 1, 6 ) X* X* X* Complex Hermitian Eigenvalue Problem: X* X* X ELSE IF( ITYPE.EQ.4 ) THEN X WRITE( IOUNIT, FMT = 9988 ) X WRITE( IOUNIT, FMT = 9987 ) X WRITE( IOUNIT, FMT = 9986 )'Hermitian' X* X* Tests performed X* X WRITE( IOUNIT, FMT = 9985 )'unitary', '*=conj.transp.', X $ ( '*', J = 1, 6 ) X* X* X* Real Singular Value Decomposition: X* X* X ELSE IF( ITYPE.EQ.5 ) THEN X WRITE( IOUNIT, FMT = 9984 ) X WRITE( IOUNIT, FMT = 9983 ) X WRITE( IOUNIT, FMT = 9982 ) X* X* Tests performed X* X WRITE( IOUNIT, FMT = 9981 )'orthogonal', '''=transpose', X $ ( '''', J = 1, 6 ) X* X* X* Complex Singular Value Decomposition: X* X* X ELSE IF( ITYPE.EQ.6 ) THEN X WRITE( IOUNIT, FMT = 9984 ) X WRITE( IOUNIT, FMT = 9983 ) X WRITE( IOUNIT, FMT = 9982 ) X* X* Tests performed X* X WRITE( IOUNIT, FMT = 9981 )'unitary', '*=conj.transp.', X $ ( '*', J = 1, 6 ) X* X* X END IF X* X* . . . . . . . . . . . . . .. X* X* X* X RETURN X* X* X* X* X 9999 FORMAT( / 1X, A3, ' -- Real Non-symmetric eigenvalue problem' ) X 9998 FORMAT( / 1X, A3, ' -- Complex Non-symmetric eigenvalue problem' ) X 9997 FORMAT( / 1X, A3, ' -- Real Symmetric eigenvalue problem' ) X 9996 FORMAT( / 1X, A3, ' -- Complex Hermetian eigenvalue problem' ) X 9995 FORMAT( / 1X, A3, ' -- Real Singular Value Decomposition' ) X 9994 FORMAT( / 1X, A3, ' -- Complex Singular Value Decomposition' ) X* X* X* X 9993 FORMAT( ' Matrix types (see xCHK21 for details): ' ) X* X 9992 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ', X $ ' ', ' 5=Diagonal: geometr. spaced entries.', X $ / ' 2=Identity matrix. ', ' 6=Diagona', X $ 'l: clustered entries.', / ' 3=Transposed Jordan block. ', X $ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ', X $ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s', X $ 'mall, evenly spaced.' ) X 9991 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev', X $ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e', X $ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ', X $ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond', X $ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp', X $ 'lex ', A6, / ' 12=Well-cond., random complex ', A6, ' ', X $ ' 17=Ill-cond., large rand. complx ', A4, / ' 13=Ill-condi', X $ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.', X $ ' complx ', A4 ) X 9990 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ', X $ 'with small random entries.', / ' 20=Matrix with large ran', X $ 'dom entries. ' ) X* X* 1 1 1 1 1 2 2 2 2 2 3 3 3 3 3 4 4 4 4 4 5 5 5 5 5 6 6 6 6 6 7 7 X*2 4 6 8 0 2 4 6 8 0 2 4 6 8 0 2 4 6 8 0 2 4 6 8 0 2 4 6 8 0 2 4 6 8 0 2 X 9989 FORMAT( / ' Tests performed: ', '(H is Hessenberg, T is Schur,', X $ ' U and Z are ', A, ',', / 20X, A, ', W is a diagonal matr', X $ 'ix of eigenvalues,', / 20X, 'L and R are the left and rig', X $ 'ht eigenvector matrices)', / ' 1 = | A - U H U', A1, ' |', X $ ' / ( |A| n ulp ) ', ' 2 = | I - U U', A1, ' | / ', X $ '( n ulp )', / ' 3 = | H - Z T Z', A1, ' | / ( |H| n ulp ', X $ ') ', ' 4 = | I - Z Z', A1, ' | / ( n ulp )', X $ / ' 5 = | A - UZ T (UZ)', A1, ' | / ( |A| n ulp ) ', X $ ' 6 = | I - UZ (UZ)', A1, ' | / ( n ulp )', / ' 7 = | T(', X $ 'e.vects.) - T(no e.vects.) | / ( |T| ulp )', / ' 8 = | W', X $ '(e.vects.) - W(no e.vects.) | / ( |W| ulp )', / ' 9 = | ', X $ 'TR - RW | / ( |T| |R| ulp ) ', ' 10 = | LT - WL | / (', X $ ' |T| |L| ulp )', / ' 11= |HX - XW| / (|H| |X| ulp) (inv.', X $ 'it)', ' 12= |YH - WY| / (|H| |Y| ulp) (inv.it)' ) X* X* Symmetric/Hermetian eigenproblem X* X 9988 FORMAT( ' Matrix types (see xCHK22 for details): ' ) X* X 9987 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ', X $ ' ', ' 5=Diagonal: clustered entries.', / ' 2=', X $ 'Identity matrix. ', ' 6=Diagonal: lar', X $ 'ge, evenly spaced.', / ' 3=Diagonal: evenly spaced entri', X $ 'es. ', ' 7=Diagonal: small, evenly spaced.', / ' 4=D', X $ 'iagonal: geometr. spaced entries.' ) X 9986 FORMAT( ' Dense ', A, ' Matrices:', / ' 8=Evenly spaced eigen', X $ 'vals. ', ' 12=Small, evenly spaced eigenvals.', X $ / ' 9=Geometrically spaced eigenvals. ', ' 13=Matrix ', X $ 'with random O(1) entries.', / ' 10=Clustered eigenvalues.', X $ ' ', ' 14=Matrix with large random entries.', X $ / ' 11=Large, evenly spaced eigenvals. ', ' 15=Matrix ', X $ 'with small random entries.' ) X* X 9985 FORMAT( / ' Tests performed: ', '(S is Tridiag, D is diagonal,', X $ ' U and Z are ', A, ',', / 20X, A, ', W is a diagonal matr', X $ 'ix of eigenvalues)', / ' 1= | A - U S U', A1, ' | / ( |A', X $ '| n ulp ) ', ' 2= | I - U U', A1, ' | / ( n ulp )', X $ / ' 3= | S - Z D Z', A1, ' | / ( |S| n ulp ) ', ' 4=', X $ ' | I - Z Z', A1, ' | / ( n ulp )', X $ / ' 5= | A - UZ D (UZ)', A1, ' | / ( |A| n ulp ) ', ' 6=', X $ ' | I - UZ (UZ)', A1, ' | / ( n ulp )', / ' 7= |D(with Z)', X $ ' - D(w/o Z)| / (|D| ulp) ', ' 8= | D(PWK) - D(QR) | / (|', X $ 'D| ulp)', / ' 9= Sturm sequence test on W ', X $ ' 10= | Z(inv it.) - Z(QR) | / (|Z| ulp)' ) X* X* Singular Value Decomposition X* X 9984 FORMAT( ' Matrix types (see xCHK22 for details): ' ) X* X 9983 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ', X $ ' 5=Diagonal: clustered entries.', / ' 2=', X $ 'Identity matrix. 6=Diagonal: lar', X $ 'ge, evenly spaced.', / ' 3=Diagonal: evenly spaced entri', X $ 'es. 7=Diagonal: small, evenly spaced.', / ' 4=D', X $ 'iagonal: geometr. spaced entries.' ) X 9982 FORMAT( ' Dense General Matrices:', / ' 8=Evenly spaced singu', X $ 'lar values. 12=Small, evenly spaced sing.vals.', X $ / ' 9=Geometrically spaced singular vals. 13=Matrix ', X $ 'with random O(1) entries.', / ' 10=Clustered singular val', X $ 'ues. 14=Matrix with large random entries.', X $ / ' 11=Large, evenly spaced sing.vals. 15=Matrix ', X $ 'with small random entries.', / ' 16=Random Bidiagonal (No', X $ 't all tests.)' ) X* X 9981 FORMAT( / ' Tests performed: (B is Bidiag, S is diagonal,', X $ ' Q, P, U, and V are ', A, ',', / 20X, A, ', b, c, and d a', X $ 're (random) general', / 20X, 'm x k matrices, r=max(m,n),', X $ ' s=min(m,n), t=max(m,k))', / ' 1= | A - Q B P | / ( |A| ', X $ 'r ulp ) 2= | b - Q c | / ( |b| t ulp )', / ' 3= ', X $ '| I - Q', A1, 'Q | / ( m ulp ) 4= | I - P P', X $ A1, ' | / ( n ulp )', / ' 5= | B - U S V | / ( |B| s ulp ', X $ ') 6= | c - U d | / (|c| max(s,k) ulp)', / ' 7= |', X $ ' I - U', A1, 'U | / ( s ulp ) 8= | I - V V', X $ A1, ' | / ( s ulp )', / ' 9= | A - (QU) S (VP) | / ( |A| ', X $ 'r ulp ) 10= | b - (QU) d | / ( |b| t ulp )', / ' 11= | I', X $ ' - (QU)', A1, '(QU) | / ( m ulp ) 12= | I - (VP) (', X $ 'VP)', A1, ' | / ( n ulp )', / ' 13= | S(w/ U,V) - S(w/o U', X $ ',V) | / (|S(w/ U,V)| ulp) 14= Sturm sequence test.' ) X* X* X* End of DLAHD2 X* X END END_OF_FILE if test 11630 -ne `wc -c <'dlahd2.f'`; then echo shar: \"'dlahd2.f'\" unpacked with wrong size! fi # end of 'dlahd2.f' fi if test -f 'dlahqr.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlahqr.f'\" else echo shar: Extracting \"'dlahqr.f'\" \(14239 characters\) sed "s/^X//" >'dlahqr.f' <<'END_OF_FILE' X SUBROUTINE DLAHQR( JOB, N, H, LDH, WR, WI, Z, LDZ, INFO ) X* X* -- LAPACK routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER JOB X INTEGER INFO, LDH, LDZ, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * ) X* .. X* X* Purpose X* ======= X* X* This subroutine finds the Schur factorization: H = Z T Z' X* of a real upper Hessenberg matrix H by the QR method, where T X* is a matrix in Schur canonical form, Z is orthogonal, and Z' X* denotes the transpose of Z. DLAHQR can either return just X* the eigenvalues, or the eigenvalues and T, or the eigenvalues, X* T, and Z, or the eigenvalues, T, and Z premultiplied by a X* matrix. This routine is basically the EISPACK routines X* HQR and HQR2. X* X* Arguments X* ========= X* X* JOB - CHARACTER*1 X* JOB specifies what DLAHQR is to compute: X* If JOB='E', compute the eigenvalues only. X* If JOB='S', compute the eigenvalues and the Schur form. X* If JOB='I', compute the eigenvalues, Schur form and X* Z (the Schur vectors). X* If JOB='V', compute the eigenvalues, Schur form and X* Z (the Schur vectors) premultiplied by X* the matrix that was in the array "Z" upon X* entry to DLAHQR. X* Not modified. X* X* N - INTEGER X* The order of the matrix H. X* Not modified. X* X* H - DOUBLE PRECISION array, dimension (LDH,N) X* On entry, H contains the upper Hessenberg matrix. X* On exit, H will contain the Schur form if JOB is 'S', 'I', X* or 'V'. X* Modified. X* X* LDH - INTEGER X* The first dimension of H as declared in the calling X* (sub)program. LDH must be at least max(1, N). X* Not modified. X* X* WR,WI - DOUBLE PRECISION arrays, dimension (N) X* On exit, WR and WI will contain the real and imaginary X* parts, respectively, of the eigenvalues. The eigenvalues X* are unordered except that complex conjugate pairs of values X* appear consecutively with the eigenvalue having the X* positive imaginary part first. If an error exit is made, X* the eigenvalues should be correct for indices X* info+1,...,n. X* X* Z - DOUBLE PRECISION array, dimension (LDZ,N) X* On entry: X* If JOB is 'V', then on entry Z is assumed to contain a X* matrix which will premultiply the matrix "Z" used to X* reduce H to Schur form. X* If JOB is not 'V', the initial contents of Z are ignored. X* X* If JOB is 'E' or 'S', Z is not referenced at all. X* If JOB is 'I', Z will be overwritten with the orthogonal X* matrix "Z" used to reduce H to Schur form. X* If JOB is 'V', the matrix in Z will be postmultiplied by X* the orthogonal matrix "Z", and the product will be X* returned. X* Not referenced if JOB='E' or 'S'. X* Modified if JOB='I' or 'V'. X* X* LDZ - INTEGER X* The first dimension of Z as declared in the calling X* (sub)program. LDZ must be at least max(1, N). If JOB='E' X* or 'S', LDZ is not referenced. X* Not modified. X* X* INFO - INTEGER X* On exit, INFO is set to X* 0 normal return. X* -k if input argument number k is illegal. X* j if the limit of 30*n iterations is exhausted X* while the j-th eigenvalue is being sought. X* The eigenvalues in W should be correct for X* the indices j+1,j+2,...,N X* X* .. Parameters .. X DOUBLE PRECISION ZERO, HALF, ONE X PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) X DOUBLE PRECISION TWO, FOUR X PARAMETER ( TWO = 2.0D+0, FOUR = 4.0D+0 ) X DOUBLE PRECISION DAT1, DAT2 X PARAMETER ( DAT1 = 0.75D+0, DAT2 = -0.4375D+0 ) X* .. X* .. Local Scalars .. X INTEGER EN, ENM2, I, ICOLN, IJOB, IROW1, ITN, ITS, J, X $ K, L, M, MP3, NA X DOUBLE PRECISION NORM, OVFL, P, Q, R, S, SMALL, SMLNUM, T, TST1, X $ TST2, ULP, UNFL, W, X, Y, ZZ X* .. X* .. External Functions .. X LOGICAL LSAME X DOUBLE PRECISION DLAMCH, DLANHS X EXTERNAL LSAME, DLAMCH, DLANHS X* .. X* .. External Subroutines .. X EXTERNAL DLAZRO, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, MIN, SIGN, SQRT X* .. X* .. Executable Statements .. X* X* Decode and Test the input parameters X* X IF( LSAME( JOB, 'E' ) ) THEN X IJOB = 1 X ELSE IF( LSAME( JOB, 'S' ) ) THEN X IJOB = 2 X ELSE IF( LSAME( JOB, 'I' ) ) THEN X IJOB = 3 X ELSE IF( LSAME( JOB, 'V' ) ) THEN X IJOB = 4 X ELSE X IJOB = -1 X END IF X* X INFO = 0 X IF( IJOB.EQ.-1 ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( LDH.LT.MAX( 1, N ) ) THEN X INFO = -4 X END IF X IF( IJOB.EQ.3 .OR. IJOB.EQ.4 ) THEN X IF( LDZ.LT.MAX( 1, N ) ) X $ INFO = -8 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DLAHQR', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.EQ.0 ) X $ RETURN X* X IF( IJOB.EQ.3 ) THEN X CALL DLAZRO( N, N, ZERO, ONE, Z, LDZ ) X END IF X* X NORM = DLANHS( '1', N, H, LDH, WR ) X IF( NORM.EQ.ZERO ) THEN X DO 10 I = 1, N X WR( I ) = ZERO X WI( I ) = ZERO X 10 CONTINUE X RETURN X END IF X* X* Set constants for stopping criterion. The code is organized X* so that as far as NORM <= sqrt(OVFL), it would never blow up. X* X UNFL = DLAMCH( 'Safe minimum' ) X OVFL = DLAMCH( 'Overflow' ) X ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) X SMLNUM = MAX( UNFL*( N/ULP ), N/( ULP*OVFL ) ) X SMALL = MAX( SMLNUM, MIN( ( NORM*SMLNUM )*NORM, ULP*NORM ) ) X* X K = 1 X EN = N X ITN = 30*N X* X* Search for next eigenvalues. X* X 20 CONTINUE X IF( EN.LT.1 ) X $ GO TO 270 X ITS = 0 X NA = EN - 1 X ENM2 = NA - 1 X* X* Look for single small sub-diagonal element. We need to test X* whether the small sub-diagonal element is less than SMALL X* because of gradual underflow otherwise stopping convergence. X* X 30 CONTINUE X DO 40 L = EN, 2, -1 X S = ABS( H( L-1, L-1 ) ) + ABS( H( L, L ) ) X IF( S.EQ.ZERO ) X $ S = NORM X IF( ABS( H( L, L-1 ) ).LE.MAX( ULP*S, SMALL ) ) X $ GO TO 50 X 40 CONTINUE X L = 1 X* X 50 CONTINUE X IF( L.GT.1 ) X $ H( L, L-1 ) = ZERO X IF( L.EQ.EN ) X $ GO TO 210 X IF( L.EQ.NA ) X $ GO TO 220 X IF( ITN.EQ.0 ) X $ GO TO 260 X* X* Form shift. Note that under the assumption of X* NORM <= sqrt(OVFL), the following W cannot overflow. X* X X = H( EN, EN ) X Y = H( NA, NA ) X W = H( EN, NA )*H( NA, EN ) X* X IF( ITS.NE.10 .AND. ITS.NE.20 ) X $ GO TO 60 X* X* Form exceptional shift. X* X S = ABS( H( EN, NA ) ) + ABS( H( NA, ENM2 ) ) X X = DAT1*S X Y = X X W = DAT2*S*S X* X 60 CONTINUE X ITS = ITS + 1 X ITN = ITN - 1 X* X* Look for two consecutive small sub-diagonal elements. X* Note that under the assumption of NORM <= sqrt(OVFL), X* the following P cannot overflow, because X* (R*S - W) / H(M+1,M) <= NORM**2 / H(M+1,M). X* If NORM**2 / H(M+1,M) > OVFL, then X* H(M+1,M) < NORM**2/OVFL, X* but would here already set H(M+1,M) to 0. Moreover, X* TST1, TST2 <= NORM**2 <= OVFL. X* X DO 70 M = ENM2, L, -1 X ZZ = H( M, M ) X R = X - ZZ X S = Y - ZZ X P = ( R*S-W ) / H( M+1, M ) + H( M, M+1 ) X Q = H( M+1, M+1 ) - ZZ - R - S X R = H( M+2, M+1 ) X S = ABS( P ) + ABS( Q ) + ABS( R ) X P = P / S X Q = Q / S X R = R / S X IF( M.EQ.L ) X $ GO TO 80 X TST1 = ABS( P )*( ABS( H( M-1, M-1 ) )+ABS( ZZ )+ X $ ABS( H( M+1, M+1 ) ) ) X TST2 = ABS( H( M, M-1 ) )*( ABS( Q )+ABS( R ) ) X IF( TST2.LE.MAX( ULP*TST1, SMALL ) ) X $ GO TO 80 X 70 CONTINUE X* X* Double shift QR step involving rows L to EN and columns M to EN. X* Update the whole matrix if the Schur form is desired. X* X 80 CONTINUE X IF( IJOB.EQ.1 ) THEN X IROW1 = L X ICOLN = EN X ELSE X IROW1 = 1 X ICOLN = N X END IF X* X DO 150 K = M, NA - 1 X* X* Chasing 2 by 2 bulge X* X IF( K.EQ.M ) X $ GO TO 90 X P = H( K, K-1 ) X Q = H( K+1, K-1 ) X R = H( K+2, K-1 ) X X = ABS( P ) + ABS( Q ) + ABS( R ) X IF( X.EQ.ZERO ) X $ GO TO 150 X P = P / X X Q = Q / X X R = R / X X 90 CONTINUE X S = SIGN( SQRT( P*P+Q*Q+R*R ), P ) X IF( K.EQ.M ) X $ GO TO 100 X H( K, K-1 ) = -S*X X GO TO 110 X 100 CONTINUE X IF( L.NE.M ) X $ H( K, K-1 ) = -H( K, K-1 ) X 110 CONTINUE X P = P + S X X = P / S X Y = Q / S X ZZ = R / S X Q = Q / P X R = R / P X* X* Row modification. X* X DO 120 J = K, ICOLN X P = H( K, J ) + Q*H( K+1, J ) X P = P + R*H( K+2, J ) X H( K+2, J ) = H( K+2, J ) - P*ZZ X H( K+1, J ) = H( K+1, J ) - P*Y X H( K, J ) = H( K, J ) - P*X X 120 CONTINUE X* X* Column modification. X* X DO 130 I = IROW1, MIN( EN, K+3 ) X P = X*H( I, K ) + Y*H( I, K+1 ) X P = P + ZZ*H( I, K+2 ) X H( I, K+2 ) = H( I, K+2 ) - P*R X H( I, K+1 ) = H( I, K+1 ) - P*Q X H( I, K ) = H( I, K ) - P X 130 CONTINUE X* X* Accumulate transformations, if desired. X* X IF( IJOB.GE.3 ) THEN X DO 140 I = 1, N X P = X*Z( I, K ) + Y*Z( I, K+1 ) X P = P + ZZ*Z( I, K+2 ) X Z( I, K+2 ) = Z( I, K+2 ) - P*R X Z( I, K+1 ) = Z( I, K+1 ) - P*Q X Z( I, K ) = Z( I, K ) - P X 140 CONTINUE X END IF X* X 150 CONTINUE X* X* Chasing the 1 by 1 bulge at H(EN,EN-2) position. X* X P = H( NA, ENM2 ) X Q = H( EN, ENM2 ) X X = ABS( P ) + ABS( Q ) X IF( X.EQ.ZERO ) X $ GO TO 190 X P = P / X X Q = Q / X X S = SIGN( SQRT( P*P+Q*Q ), P ) X H( NA, ENM2 ) = -S*X X P = P + S X X = P / S X Y = Q / S X Q = Q / P X* X* Row modification. X* X DO 160 J = NA, ICOLN X P = H( NA, J ) + Q*H( EN, J ) X H( EN, J ) = H( EN, J ) - P*Y X H( NA, J ) = H( NA, J ) - P*X X 160 CONTINUE X* X* Column modification. X* X DO 170 I = IROW1, EN X P = X*H( I, NA ) + Y*H( I, EN ) X H( I, EN ) = H( I, EN ) - P*Q X H( I, NA ) = H( I, NA ) - P X 170 CONTINUE X* X* Accumulate transformations, if desired. X* X IF( IJOB.GE.3 ) THEN X DO 180 I = 1, N X P = X*Z( I, NA ) + Y*Z( I, EN ) X Z( I, EN ) = Z( I, EN ) - P*Q X Z( I, NA ) = Z( I, NA ) - P X 180 CONTINUE X END IF X* X* clean up X* X 190 CONTINUE X H( M+2, M ) = ZERO X MP3 = M + 3 X DO 200 I = MP3, EN X H( I, I-2 ) = ZERO X H( I, I-3 ) = ZERO X 200 CONTINUE X* X GO TO 30 X* X* One root found. X* X 210 CONTINUE X WR( EN ) = H( EN, EN ) X WI( EN ) = ZERO X EN = NA X GO TO 20 X* X* Two roots found, Standardization if necessary. X* X 220 CONTINUE X S = MAX( ABS( H( NA, NA ) ), ABS( H( NA, EN ) ), X $ ABS( H( EN, NA ) ), ABS( H( EN, EN ) ) ) X IF( S.EQ.ZERO ) THEN X WR( NA ) = ZERO X WI( NA ) = ZERO X WR( EN ) = ZERO X WI( EN ) = ZERO X EN = ENM2 X GO TO 20 X END IF X* X ZZ = ( H( NA, NA )/S-H( EN, EN )/S ) / TWO X W = ZZ*ZZ + ( H( EN, NA )/S )*( H( NA, EN )/S ) X IF( W.GE.ZERO ) THEN X* X* For two real eigenvalues, triangularize 2 by 2 block. X* X T = ( ZZ+SIGN( SQRT( W ), ZZ ) ) / ( H( EN, NA )/S ) X P = SIGN( ONE/SQRT( ONE+T*T ), T ) X Q = T*P X* X ELSE X* X* For complex conjugate eigenvalues, equalize the diagonal X* elements. X* X R = ( H( NA, EN )/S ) + ( H( EN, NA )/S ) X T = SQRT( R*R+FOUR*ZZ*ZZ ) X Q = SQRT( HALF*( ONE+ABS( R )/T ) ) X P = SIGN( ZZ/( Q*T ), -R*ZZ ) X END IF X* X IF( IJOB.EQ.1 ) THEN X ICOLN = EN X IROW1 = NA X ELSE X ICOLN = N X IROW1 = 1 X END IF X* X* Column modification. X* X DO 230 J = NA, ICOLN X ZZ = H( NA, J ) / S X T = H( EN, J ) / S X H( NA, J ) = S*( Q*ZZ+P*T ) X H( EN, J ) = S*( -P*ZZ+Q*T ) X 230 CONTINUE X* X* Row modification. X* X DO 240 I = IROW1, EN X ZZ = H( I, NA ) / S X T = H( I, EN ) / S X H( I, NA ) = S*( Q*ZZ+P*T ) X H( I, EN ) = S*( -P*ZZ+Q*T ) X 240 CONTINUE X* X* Accumulate transformations, if desired. X* X IF( IJOB.GE.3 ) THEN X DO 250 I = 1, N X ZZ = Z( I, NA ) X Z( I, NA ) = Q*ZZ + P*Z( I, EN ) X Z( I, EN ) = -P*ZZ + Q*Z( I, EN ) X 250 CONTINUE X END IF X* X* Set eigenvalues X* X IF( W.GE.ZERO ) THEN X H( EN, NA ) = ZERO X WR( NA ) = H( NA, NA ) X WR( EN ) = H( EN, EN ) X WI( NA ) = ZERO X WI( EN ) = ZERO X ELSE X WR( NA ) = H( NA, NA ) X WR( EN ) = H( NA, NA ) X H( EN, EN ) = H( NA, NA ) X WI( NA ) = SQRT( ABS( H( EN, NA ) ) )* X $ SQRT( ABS( H( NA, EN ) ) ) X WI( EN ) = -WI( NA ) X END IF X* X EN = ENM2 X GO TO 20 X* X 260 CONTINUE X INFO = EN X 270 CONTINUE X* X RETURN X* X* End of DLAHQR X* X END END_OF_FILE if test 14239 -ne `wc -c <'dlahqr.f'`; then echo shar: \"'dlahqr.f'\" unpacked with wrong size! fi # end of 'dlahqr.f' fi if test -f 'dlahrd.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlahrd.f'\" else echo shar: Extracting \"'dlahrd.f'\" \(13697 characters\) sed "s/^X//" >'dlahrd.f' <<'END_OF_FILE' X SUBROUTINE DLAHRD( N, K, IFST, ILST, A, LDA, U, LDU, S, WORK, X $ LDWORK, INFO ) X* X* -- LAPACK routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X INTEGER IFST, ILST, INFO, K, LDA, LDU, LDWORK, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ), X $ WORK( LDWORK, * ) X* .. X* X* Purpose X* ======= X* X* This subroutine chases a K-by-K bulge on an upper Hessenberg X* matrix one block down from the block with the first column X* index IFST and the last column index ILST. This amounts to X* doing a reduction to Hessenberg form just on columns IFST X* through ILST, except that we exploit the fact that A has a X* special form: for columns IFST through N-2, entries X* max(IFST+K+2,j+2) through N are zero. This means that only K+1 X* subdiagonals are ever made non-zero, and the Householder X* vectors have at most K+1 non-zero entries. An example X* input matrix for K=2, N=8, and IFST=1: X* X* X X X X X X X X X* X X X X X X X X X* * X X X X X X X X* * * X X X X X X X* X X X X X X* X X X X X* X X X X* X X X* X* here, "*" identifies entries belonging to the "bulge" and "X" X* identifies the other non-zero entries. If ILST is 4, then the X* output matrix will have the structure: X* X* X X X X X X X X X* X X X X X X X X X* . X X X X X X X X* . . X X X X X X X* . . X X X X X X* . . X X X X X* . * X X X X* * * X X X* X* where "." identifies entries that were non-zero during the X* calculation but are zero at the end. X* X* This routine is intended to be called from DHSEQR, which will X* first apply a Householder transformation that will create the X* bulge starting in column 1, then call this routine with IFST=1 X* and ILST=p to move the bulge to column p+1, then call this X* routine again with IFST=p+1 and ILST=2p, etc., until the bulge X* runs off the end. X* X* The reduction is done in a "blocked" fashion, that is, A is not X* updated once for each Householder transformation and each side, X* but rather only after all the transformations have been X* computed. If we define H(j) = I - t(j) u(j) u(j)' to be the X* j-th Householder transformation being applied to A, and X* A(j) = H(j)...H(1) A H(1)...H(j), then X* X* A(j) = A - U(j) V(j)' - W(j) U(j)' X* X* where U(j), V(j), W(j) are n x j matrices whose k-th columns X* are u(k), v(k) = t(k)[A(k)' u(k) - t(k) w(k)'u(k) u(k)] , X* and w(k) = t(k) A(k) u(k) . X* X* X* Arguments X* ========= X* X* N - INTEGER X* On entry, N specifies the order of matrix A, X* N must be at least zero. X* Not modified. X* X* K - INTEGER X* On entry, K specifies the size of the bulge. X* Not modified. X* X* IFST - INTEGER X* On entry, IFST is the first column to be reduced to X* Hessenberg form. It must be at least 1 and not greater X* than N. X* Not modified. X* X* ILST - INTEGER X* On entry, ILST is the last column to be reduced to X* Hessenberg form. It must be at least IFST and not greater X* than N. X* Not modified. X* X* A - DOUBLE PRECISION array, dimension (LDA,N) X* On entry, A specifies the array which contains the matrix X* to be reduced. On exit, A will contain the resulting X* matrix, which will be in Hessenberg form in columns IFST X* through ILST, and will have the bulge starting in column X* ILST+1 (if ILST is less than N-2 ) X* X* LDA - INTEGER X* On entry, LDA specifies the first dimension of A as X* declared in the calling (sub)program. LDA must be at X* least max(1, N). X* Not modified. X* X* U - DOUBLE PRECISION array, dimension (LDU,ILST-IFST+1) X* On exit, the strictly lower triangle of U will contain the X* Householder vectors for the transformations applied to A. X* It will thus be ready to be passed to DORGC3. X* Modified. X* X* LDU - INTEGER X* On entry, LDU specifies the first dimension of U as X* declared in the calling (sub)program. LDU must be at X* least min( ILST-IFST + K + 2, N+1 - IFST ). X* Not modified. X* X* S - DOUBLE PRECISION array, dimension(ILST-IFST+1) X* On exit, S contains the scaling factors for Householder X* transformations. X* X* WORK - DOUBLE PRECISION array, dimension (LDWORK,2*(ILST-IFST+1)+1) X* Workspace. The first p (i.e., ILST-IFST+1) columns are X* used to store V, the second p are used for W, and the last X* column is used for a vector temporary. X* X* LDWORK - INTEGER X* On entry, LDWORK specifies the first dimension of WORK as X* declared in the calling (sub)program. LDWORK must be at X* least max(1, N). X* Not modified. X* X* INFO - INTEGER X* On exit, INFO is set to X* 0 a normal return. X* -k input argument number k is illegal. X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE X PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER IEXTRA, J, JS, KQ, LDUMIN, LDVMIN, LDWMIN, X $ LENUJ, LENUU, LENVJ, LENWJ, P X DOUBLE PRECISION DELTA X* .. X* .. External Functions .. X DOUBLE PRECISION DDOT X EXTERNAL DDOT X* .. X* .. External Subroutines .. X EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLARF, DLARFG, X $ DLAZRO, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX, MIN X* .. X* .. Executable Statements .. X* X* See "On a Block Implementation of the Hessenberg Multishift X* QR Iteration" by Z. Bai and J. Demmel, LAPACK Working Note X* #8 for a detailed description of the algorithm. X* X* Determine the blocksize P and the maximum column lengths of X* U and WORK. X* X* X* The (column) vectors u(j), v(j), and w(j) each have the X* following sparsity structure: X* X* Vector: first last length of X* non-zero row: non-zero row: non-zero portion: X* u(j) j+1 min(j+k+1,n) min(k+1,n-j) X* v(j) j n n+1-j X* w(j) 1 min(j+k+2,n) min(j+k+2,n) X* X* The matrices U(j), V(j), and W(j) each have one non-zero block, X* which runs from column IFST to j, and rows: X* X* Matrix: first last length of X* non-zero row: non-zero row: non-zero portion: X* U(j) IFST+1 min(j+k+1,n) min(j+k+1,n)-IFST X* V(j) IFST n n+1-IFST X* W(j) 1 min(j+k+2,n) min(j+k+2,n) X* X* The upper-left entry of these non-zero blocks are stored in X* the FORTRAN arrays as follows: X* X* Matrix entry: is stored in X* FORTRAN array element: X* U(IFST+1,IFST) U(2,1) (1st row is zero) X* V(IFST,IFST) WORK(1,1) X* W(1,IFST) WORK(1,P+1) X* X* X* Determine the blocksize P X* X P = ILST - IFST + 1 X IEXTRA = 2*P + 1 X LDUMIN = MIN( N-IFST, K+P ) + 1 X LDVMIN = N + 1 - IFST X LDWMIN = MIN( ILST+K+2, N ) X* X* Test the input parameters X* X INFO = 0 X IF( N.LT.0 ) THEN X INFO = -1 X ELSE IF( IFST.LE.0 .OR. IFST.GT.N ) THEN X INFO = -3 X ELSE IF( ILST.LT.IFST .OR. ILST.GT.N ) THEN X INFO = -4 X ELSE IF( LDA.LT.MAX( 1, N ) ) THEN X INFO = -6 X ELSE IF( LDU.LT.LDUMIN ) THEN X INFO = -8 X ELSE IF( LDWORK.LT.MAX( LDVMIN, LDWMIN ) ) THEN X INFO = -11 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DLAHRD', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( K.LE.0 .OR. N.LE.2 ) X $ RETURN X* X* Unblocked BLAS 2 Version, blocksize = 1 X* X IF( P.EQ.1 ) THEN X* X KQ = MIN( K+IFST+1, N ) X LENUJ = KQ - IFST X CALL DCOPY( LENUJ, A( IFST+1, IFST ), 1, U( 2, 1 ), 1 ) X* X* Compute Householder transformation H(j). X* X CALL DLARFG( LENUJ, U( 2, 1 ), U( 3, 1 ), 1, S( 1 ) ) X U( 2, 1 ) = ONE X* X* Update X* X CALL DLARF( 'L', LENUJ, LDVMIN, U( 2, 1 ), 1, S( 1 ), X $ A( IFST+1, IFST ), LDA, WORK ) X LENWJ = MIN( K+IFST+2, N ) X CALL DLARF( 'R', LENWJ, LENUJ, U( 2, 1 ), 1, S( 1 ), X $ A( 1, IFST+1 ), LDA, WORK ) X* X* Blocked BLAS 3 Version, blocksize > 1 X* X ELSE X* X* Initialize. X* X CALL DLAZRO( LDUMIN, P, ZERO, ZERO, U, LDU ) X CALL DLAZRO( LDVMIN, P, ZERO, ZERO, WORK( 1, 1 ), LDWORK ) X CALL DLAZRO( LDWMIN, P, ZERO, ZERO, WORK( 1, P+1 ), LDWORK ) X* X DO 10 J = IFST, ILST X* X* Compute Lengths and Indices X* X* LENUU -- Number of non-zero rows in matrix U(j) X* LENUJ, X* LENVJ -- Number of non-zero rows in vectors u(j), v(j) X* LENWJ -- Number of non-zero rows in w(j) and W(j) X* KQ -- Last non-zero in vector u(j). X* X JS = J - IFST + 1 X KQ = MIN( K+J+1, N ) X LENUJ = KQ - J X LENUU = KQ - IFST X LENVJ = N + 1 - J X LENWJ = MIN( K+J+2, N ) X* X* Form the Jth column of X* A(j-1) = A - U(j-1) V(j-1)' - W(j-1) U(j-1)' X* X CALL DCOPY( LENUJ, A( J+1, J ), 1, U( JS+1, JS ), 1 ) X IF( JS.GT.1 ) THEN X CALL DGEMV( 'N', LENUJ, JS-1, -ONE, U( JS+1, 1 ), LDU, X $ WORK( JS, 1 ), LDWORK, ONE, U( JS+1, JS ), X $ 1 ) X CALL DGEMV( 'N', LENUJ, JS-1, -ONE, WORK( J+1, P+1 ), X $ LDWORK, U( JS, 1 ), LDU, ONE, U( JS+1, JS ), X $ 1 ) X END IF X* X* Compute Householder transformation H(j). X* X CALL DLARFG( LENUJ, U( JS+1, JS ), U( JS+2, JS ), 1, X $ S( JS ) ) X U( JS+1, JS ) = ONE X* X* Aggregate the transformation vectors in inner loop. X* Compute the j-th column of V and W: X* X* X IF( J.EQ.IFST ) THEN X* X* A'*uj --> vj X* X CALL DGEMV( 'T', LENUJ, LENVJ, S( JS ), A( J+1, IFST ), X $ LDA, U( JS+1, JS ), 1, ZERO, WORK( JS, JS ), X $ 1 ) X* X* A*uj --> wj X* X CALL DGEMV( 'N', LENWJ, LENUJ, S( JS ), A( 1, J+1 ), LDA, X $ U( JS+1, JS ), 1, ZERO, WORK( 1, JS+P ), 1 ) X* X ELSE X* X* A'*uj - V*U'*uj - U*W'*uj --> vj X* X CALL DGEMV( 'T', LENUJ, JS-1, ONE, WORK( J+1, P+1 ), X $ LDWORK, U( JS+1, JS ), 1, ZERO, X $ WORK( 1, IEXTRA ), 1 ) X* X CALL DGEMV( 'N', KQ-J+1, JS-1, S( JS ), U( JS, 1 ), LDU, X $ WORK( 1, IEXTRA ), 1, ZERO, WORK( JS, JS ), X $ 1 ) X* X CALL DGEMV( 'T', LENUJ, JS-1, ONE, U( JS+1, 1 ), LDU, X $ U( JS+1, JS ), 1, ZERO, WORK( 1, IEXTRA ), X $ 1 ) X* X CALL DGEMV( 'N', LENVJ, JS-1, S( JS ), WORK( JS, 1 ), X $ LDWORK, WORK( 1, IEXTRA ), 1, ONE, X $ WORK( JS, JS ), 1 ) X* X CALL DGEMV( 'T', LENUJ, LENVJ, S( JS ), A( J+1, J ), LDA, X $ U( JS+1, JS ), 1, -ONE, WORK( JS, JS ), 1 ) X* X* A*uj - U*V'*uj - W*U'*uj --> wj X* X CALL DGEMV( 'N', KQ, JS-1, S( JS ), WORK( 1, P+1 ), X $ LDWORK, WORK( 1, IEXTRA ), 1, ZERO, X $ WORK( 1, JS+P ), 1 ) X* X CALL DGEMV( 'T', LENUJ, JS-1, ONE, WORK( JS+1, 1 ), X $ LDWORK, U( JS+1, JS ), 1, ZERO, X $ WORK( 1, IEXTRA ), 1 ) X* X CALL DGEMV( 'N', LENUU, JS-1, S( JS ), U( 2, 1 ), LDU, X $ WORK( 1, IEXTRA ), 1, ONE, X $ WORK( IFST+1, JS+P ), 1 ) X* X CALL DGEMV( 'N', LENWJ, LENUJ, S( JS ), A( 1, J+1 ), LDA, X $ U( JS+1, JS ), 1, -ONE, WORK( 1, JS+P ), 1 ) X* X END IF X* X DELTA = DDOT( LENUJ, WORK( J+1, JS+P ), 1, U( JS+1, JS ), X $ 1 ) X CALL DAXPY( LENUJ, -S( JS )*DELTA, U( JS+1, JS ), 1, X $ WORK( JS+1, JS ), 1 ) X* X 10 CONTINUE X* X* Row block updating: A = A - U*V' X* X CALL DGEMM( 'N', 'T', LENUU, LDVMIN, P, -ONE, U( 2, 1 ), LDU, X $ WORK( 1, 1 ), LDWORK, ONE, A( IFST+1, IFST ), LDA ) X* X* Column block updating: A = A - W*U' X* X CALL DGEMM( 'N', 'T', LENWJ, LENUU, P, -ONE, WORK( 1, P+1 ), X $ LDWORK, U( 2, 1 ), LDU, ONE, A( 1, IFST+1 ), LDA ) X* X* X END IF X* X RETURN X* X* End of DLAHRD X* X END END_OF_FILE if test 13697 -ne `wc -c <'dlahrd.f'`; then echo shar: \"'dlahrd.f'\" unpacked with wrong size! fi # end of 'dlahrd.f' fi if test -f 'dlaln2.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlaln2.f'\" else echo shar: Extracting \"'dlaln2.f'\" \(23035 characters\) sed "s/^X//" >'dlaln2.f' <<'END_OF_FILE' X SUBROUTINE DLALN2( ITRANS, NA, NW, SMIN, A, LDA, B, LDB, WR, WI, X $ X, LDX, SCALE, XNORM, INFO ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X* X INTEGER INFO, ITRANS, LDA, LDB, LDX, NA, NW X DOUBLE PRECISION SCALE, SMIN, WI, WR, XNORM X* .. X* X* .. Array Arguments .. X* X DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ) X* .. X* X*----------------------------------------------------------------------- X* X* Purpose X* ======= X* X* DLALN2 solves a system of the form (A - w) X = s B X* with possible scaling ("s") and perturbation of A. X* X* A is an NA x NA real matrix, w is a real or complex value, and X* X and B are NA x 1 matrices -- real if w is real, complex if w X* is complex. NA may be 1 or 2. X* X* If w is complex, X and B are represented as NA x 2 matrices, X* the first column of each being the real part and the second X* being the imaginary part. X* X* "s" is a scaling factor (.LE. 1), computed by DLALN2, which is X* so chosen that X can be computed without overflow. X* X* If both singular values of (A - w) are less than SMIN, X* SMIN*identity will be used instead of (A - w). If only one X* singular value is less than SMIN, one element of (A - w) will X* be perturbed enough to make the smallest singular value roughly X* SMIN. If both singular values are at least SMIN, (A - w) will X* not be perturbed. In any case, the perturbation will be at X* most some small multiple of max( SMIN, ulp*norm(A - w) ). The X* singular values are computed by infinity-norm approximations, X* and thus will only be correct to a factor of 2 or so. X* X* X* Note: all quantities are assumed to be smaller than overflow X* by a reasonable factor. (See BIGNUM.) X* X* X* Arguments X* ========== X* X* ITRANS - INTEGER X* If zero, then A will be used. If 1, then A-transpose will X* be used. Only 0 and 1 are legal. X* Not modified. X* X* NA - INTEGER X* The size of the matrix A. It may (only) be 1 or 2. X* Not modified. X* X* NW - INTEGER X* 1 if "w" is real, 2 if "w" is complex. It may only be 1 X* or 2. X* Not modified. X* X* SMIN - DOUBLE PRECISION X* The desired lower bound on the singular values of A. This X* should be a safe distance away from underflow or overflow, X* say, between (underflow/machine precision) and (machine X* precision * overflow ). (See BIGNUM and ULP.) X* Not modified. X* X* A - DOUBLE PRECISION array, dimension ( LDA , NA ) X* The NA x NA matrix A. X* Not modified. X* X* LDA - INTEGER X* The leading dimension of A. It must be at least NA. X* Not modified. X* X* B - DOUBLE PRECISION array, dimension ( LDB , NW ) X* The NA x NW matrix B (right-hand side). If NW=2 ("w" is X* complex), column 1 contains the real part of B and column 2 X* contains the imaginary part. X* Not modified. X* X* LDB - INTEGER X* The leading dimension of B. It must be at least NA. X* Not modified. X* X* WR - DOUBLE PRECISION X* The real part of the scalar "w". X* Not modified. X* X* WI - DOUBLE PRECISION X* The imaginary part of the scalar "w". Not used if NW=1. X* Not modified. X* X* X - DOUBLE PRECISION array, dimension ( LDX , NW ) X* The NA x NW matrix X (unknowns), as computed by DLALN2. X* If NW=2 ("w" is complex), on exit, column 1 will contain X* the real part of X and column 2 will contain the imaginary X* part. X* Modified. X* X* LDX - INTEGER X* The leading dimension of X. It must be at least NA. X* Not modified. X* X* SCALE - DOUBLE PRECISION X* The scale factor that B must be multiplied by to insure X* that overflow does not occur when computing X. Thus, X* (A - w)X will be SCALE*B, not B (ignoring perturbation X* of A.) It will be at most 1. X* Modified. X* X* XNORM - DOUBLE PRECISION X* The infinity-norm of X, when X is regarded as an NA x NW X* real matrix. X* Modified. X* X* INFO - INTEGER X* An error flag. It will be set to zero if no error occurs, X* a negative number if an argument is in error, or a positive X* number if A - w had to be perturbed. X* The possible values are: X* 0 -- No error occurred, and (A - w) did not have to be X* perturbed. X* 1 -- Only one singular value of (A - w) was less than SMIN. X* (NA=2 only.) X* 2 -- Both singular values of (A - w) were less than SMIN X* (NA=2) or (A - w) < SMIN (NA=1). X* -1 -- ITRANS was not 0 or 1. X* -2 -- NA was not 1 or 2. X* -3 -- NW was not 1 or 2. X* -4 -- SMIN was zero or greater than ulp*overflow. X* -6 -- LDA was < NA X* -8 -- LDB was < NA X* -12-- LDX was < NA X* X* X*----------------------------------------------------------------------- X* X* Some Local Variables X* ==== ===== ========= X* X* In the following, "D" is A - w (A-transpose - w if ITRANS=1) X* or some perturbed version thereof. X* X* BIGNUM -- ULP*(machine overflow) X* BNORM -- the infinity-norm of B. X* DET -- the determinant of the real part of D, scaled by X* SABSI. X* DETA -- the absolute value of the determinant of D (not nec. X* ABS(DET) ) scaled by SABSI. This is the usual X* absolute value, even when D is complex. X* DETI -- the imaginary part of the determinant of D, scaled X* by SABSI. X* DETISG -- DETI / DETA X* DETMIN -- the smallest value of DETA for which D will not be X* perturbed. X* DETR -- the real part of the determinant of D, scaled by X* SABSI. X* DETRSG -- DETR / DETA X* DNORM -- the norm of D -- if NA=2, then scaled by SABSI. X* EHAT -- the (scalar) perturbation of D. X* GROW -- 1/( estimated norm of D-inverse ) X* SABS -- the absolute value of the largest element of D X* (if D is complex, then the "absolute value" means X* | real part | + | imaginary part | ) X* SABSI -- 1/SABS X* SIHAT -- the imaginary part of the largest element of D, X* scaled by SABSI. X* SRHAT -- the real part of the largest element of D, scaled X* by SABSI. X* ULP -- the relative machine precision. In particular, X* neither (1+ULP)*x nor x + ULP*x should ever equal x, X* unless x is zero. X* WIABS -- | WI | X* WISCAL -- WI scaled by SABSI. X* X* X* The following five "vectors" contain entries corresponding X* to the entries of A (or D). The entries in the vectors are X* in the order (1,1), (2,1), (1,2), (2,2) . If ITRANS=1, then X* the transpose of A is used in setting these vectors. X* X* DRABS -- the abolute values of the entries of D. If D is X* complex, "absolute value" means |real| + |imaginary|, X* and DRABS(5:6) contain |real| of DRORIG(1) and (4). X* DRORIG -- the real part of D (not scaled) X* DRSCAL -- DRORIG, scaled by its largest element. X* IROW, ICOL -- the row and column numbers in the *inverse* X* of D where the elements of DRSCAL will go. X* X* TMPMAT -- intermediate result matrix. X* X* X*----------------------------------------------------------------------- X* X* .. Parameters .. X* X DOUBLE PRECISION ZERO, ONE X PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) X DOUBLE PRECISION TWO, HALF X PARAMETER ( TWO = 2.0D0, HALF = ONE/TWO ) X* .. X* X* .. Local Scalars .. X* X INTEGER I, IMAX, J X DOUBLE PRECISION BIGNUM, BNORM, DET, DETA, DETI, DETISG, DETMIN, X $ DETR, DETRSG, DNORM, DSI, DSR, EHAT, GROW, X $ SABS, SABSI, SIHAT, SRHAT, TEMP1, TEMP2, ULP, X $ WIABS, WISCAL X* .. X* X* .. Local Arrays .. X* X* X INTEGER ICOL( 4 ), IROW( 4 ) X DOUBLE PRECISION DRABS( 6 ), DRORIG( 4 ), DRSCAL( 4 ), X $ TMPMAT( 2, 2 ) X* .. X* X* .. External Functions .. X* X DOUBLE PRECISION DLAMCH, DLAPY2 X EXTERNAL DLAMCH, DLAPY2 X* .. X* X* .. External Subroutines .. X* X EXTERNAL XERBLA X* .. X* X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, SIGN X* .. X* .. Data statements .. X* X DATA ICOL / 2, 1, 2, 1 / X DATA IROW / 2, 2, 1, 1 / X* .. X* X* X*----------------------------------------------------------------------- X* X* .. Executable Statements .. X* X* Compute BIGNUM, ULP X* X ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) X BIGNUM = ULP*DLAMCH( 'Overflow' ) X* X* Check for errors X* X INFO = 0 X IF( ITRANS.LT.0 .OR. ITRANS.GT.1 ) THEN X INFO = -1 X ELSE IF( NA.LT.1 .OR. NA.GT.2 ) THEN X INFO = -2 X ELSE IF( NW.LT.1 .OR. NW.GT.2 ) THEN X INFO = -3 X ELSE IF( SMIN.LE.ZERO .OR. SMIN.GE.BIGNUM ) THEN X INFO = -4 X ELSE IF( LDA.LT.NA ) THEN X INFO = -6 X ELSE IF( LDB.LT.NA ) THEN X INFO = -8 X ELSE IF( LDX.LT.NA ) THEN X INFO = -12 X END IF X* X IF( INFO.LT.0 ) THEN X CALL XERBLA( 'DLALN2', -INFO ) X RETURN X END IF X* X* Standard Initializations X* X SCALE = ONE X* X* X*....................................................................... X* X* X* NA = 1 -- A is 1 x 1, i.e., scalar X* X* X IF( NA.EQ.2 ) X $ GO TO 10 X* X IF( NW.EQ.1 ) THEN X* X* NW = 1 -- w is real X* X* D = A - w X* X DSR = A( 1, 1 ) - WR X DNORM = ABS( DSR ) X* X* If | D | < SMIN, use D = SMIN X* X IF( DNORM.LT.SMIN ) THEN X DSR = SMIN X DNORM = SMIN X INFO = 2 X END IF X* X* Check scaling for X = B / D X* X BNORM = ABS( B( 1, 1 ) ) X IF( DNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN X IF( BNORM.GT.BIGNUM*DNORM ) X $ SCALE = ONE / BNORM X END IF X* X* Compute X X* X X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / DSR X XNORM = ABS( X( 1, 1 ) ) X RETURN X ELSE X* X* NW = 2 -- w is complex X* X* D = A - w X* X DSR = A( 1, 1 ) - WR X DSI = -WI X DNORM = ABS( DSR ) + ABS( DSI ) X* X* If | D | < SMIN, use D = SMIN X* X IF( DNORM.LT.SMIN ) THEN X DSR = SMIN X DSI = ZERO X DNORM = SMIN X INFO = 2 X END IF X* X* Check scaling for X = B / D X* X BNORM = ABS( B( 1, 1 ) ) + ABS( B( 1, 2 ) ) X IF( DNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN X IF( BNORM.GT.BIGNUM*DNORM ) X $ SCALE = ONE / BNORM X END IF X* X* Compute X X* X IF( ABS( DSR ).GE.ABS( DSI ) ) THEN X TEMP1 = DSI / DSR X TEMP2 = SCALE / ( DSR+TEMP1*DSI ) X X( 1, 1 ) = TEMP2*( B( 1, 1 )+TEMP1*B( 1, 2 ) ) X X( 1, 2 ) = TEMP2*( B( 1, 2 )-TEMP1*B( 1, 1 ) ) X ELSE X TEMP1 = DSR / DSI X TEMP2 = SCALE / ( TEMP1*DSR+DSI ) X X( 1, 1 ) = TEMP2*( TEMP1*B( 1, 1 )+B( 1, 2 ) ) X X( 1, 2 ) = TEMP2*( TEMP1*B( 1, 2 )-B( 1, 1 ) ) X END IF X XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 1 ) ) X RETURN X END IF X* X*....................................................................... X* X* X* NA = 2 -- I.e., A is 2x2. X* X* X 10 CONTINUE X* X* D = A - w (or A-transpose - w) X* X DRORIG( 1 ) = A( 1, 1 ) - WR X DRORIG( 4 ) = A( 2, 2 ) - WR X* X IF( ITRANS.EQ.0 ) THEN X DRORIG( 2 ) = A( 2, 1 ) X DRORIG( 3 ) = A( 1, 2 ) X ELSE X DRORIG( 2 ) = A( 1, 2 ) X DRORIG( 3 ) = A( 2, 1 ) X END IF X* X IF( NW.EQ.1 ) THEN X* X* . . . . . . . . . . . . . .. X* X* X* NW = 1 -- w is real X* X* X BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 2, 1 ) ) ) X* X* Find the largest entry in D = A - w X* X SABS = ZERO X IMAX = 0 X* X DO 20 J = 1, 4 X DRABS( J ) = ABS( DRORIG( J ) ) X IF( DRABS( J ).GT.SABS ) THEN X SABS = DRABS( J ) X IMAX = J X END IF X 20 CONTINUE X* X* If the largest entry of D is < SMIN, X* then the larger singular value is < 2*SMIN, X* so we will use SMIN*identity instead of A - w. X* X IF( SABS.LT.SMIN ) THEN X* X* Check Scaling for X = B / SMIN X* X IF( SMIN.LT.ONE .AND. BNORM.GT.ONE ) THEN X IF( BNORM.GT.BIGNUM*SMIN ) X $ SCALE = ONE / BNORM X END IF X TEMP1 = SCALE / SMIN X X( 1, 1 ) = TEMP1*B( 1, 1 ) X X( 2, 1 ) = TEMP1*B( 2, 1 ) X XNORM = TEMP1*BNORM X INFO = 2 X RETURN X END IF X* X* Otherwise, check smaller singular value X* X* X* D^ = D / (largest element) X* X SABSI = ONE / SABS X* X DO 30 J = 1, 4 X DRSCAL( J ) = SABSI*DRORIG( J ) X 30 CONTINUE X* X* || D^ ||_1 (which is between 1 and 2) X* X DNORM = SABSI*MAX( DRABS( 1 )+DRABS( 2 ), X $ DRABS( 3 )+DRABS( 4 ) ) X* X* det(D) / (largest element of D) X* X* (which is ||D^|| times the smaller X* singular value of D) X* X* X DET = DRSCAL( 1 )*DRORIG( 4 ) - DRSCAL( 2 )*DRORIG( 3 ) X DETA = ABS( DET ) X* X DETMIN = DNORM*SMIN X IF( DETMIN.LE.DETA ) THEN X* X* X* Smallest singular value > SMIN, so just invert A - w X* X* X GROW = DETA / DNORM X IF( GROW.LT.ONE .AND. BNORM.GT.ONE ) THEN X IF( BNORM.GT.BIGNUM*GROW ) X $ SCALE = ONE / BNORM X END IF X TEMP1 = SCALE / DET X X( 1, 1 ) = TEMP1*( DRSCAL( 4 )*B( 1, 1 )-DRSCAL( 3 )* X $ B( 2, 1 ) ) X X( 2, 1 ) = TEMP1*( DRSCAL( 1 )*B( 2, 1 )-DRSCAL( 2 )* X $ B( 1, 1 ) ) X XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) ) X INFO = 0 X RETURN X END IF X* X* X* Smallest singular value < SMIN, so X* perturb element diagonally opposite largest element. X* X* We want DETA to be at least DETMIN, but we must also X* perturb the element by at least ULP times that element, X* which may make DETA much larger than DETMIN. X* X* TEMP1: is amount that DETA is changed by. X* EHAT: is the amount that the perturbed element is to X* be perturbed by, in the scaled matrix (D^). X* X TEMP1 = MAX( TWO*ULP*DRABS( 5-IMAX ), DETMIN-DETA ) X EHAT = SIGN( TEMP1, DET ) / DRORIG( IMAX ) X DETA = DETA + TEMP1 X DET = SIGN( DETA, DET ) X DRSCAL( 2 ) = -DRSCAL( 2 ) X DRSCAL( 3 ) = -DRSCAL( 3 ) X DRSCAL( 5-IMAX ) = DRSCAL( 5-IMAX ) + EHAT X* X* "GROW" is 1/( a bound on D inverse ) -- here we use X* a rather crude bound on D inverse: 2/SMIN. X* X GROW = HALF*SMIN X IF( GROW.LT.ONE .AND. BNORM.GT.ONE ) THEN X IF( BNORM.GT.BIGNUM*GROW ) X $ SCALE = ONE / BNORM X END IF X TEMP1 = SCALE / DET X X( 1, 1 ) = TEMP1*( DRSCAL( 4 )*B( 1, 1 )+DRSCAL( 3 )* X $ B( 2, 1 ) ) X X( 2, 1 ) = TEMP1*( DRSCAL( 1 )*B( 2, 1 )+DRSCAL( 2 )* X $ B( 1, 1 ) ) X XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) ) X INFO = 1 X RETURN X ELSE X* X* . . . . . . . . . . . . . .. X* X* X* NW = 2 -- w is complex X* X* X BNORM = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ), X $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) ) X* X* Find the largest entry in the matrix D = A - w. X* X* X WIABS = ABS( WI ) X* X DRABS( 1 ) = ABS( DRORIG( 1 ) ) + WIABS X DRABS( 2 ) = ABS( DRORIG( 2 ) ) X DRABS( 3 ) = ABS( DRORIG( 3 ) ) X DRABS( 4 ) = ABS( DRORIG( 4 ) ) + WIABS X* X SABS = ZERO X IMAX = 0 X* X DO 40 J = 1, 4 X IF( DRABS( J ).GT.SABS ) THEN X SABS = DRABS( J ) X IMAX = J X END IF X 40 CONTINUE X* X* If the largest entry of the matrix is < SMIN, X* then the larger singular value is < 2*SMIN, X* so we will use SMIN*identity instead of A - w. X* X IF( SABS.LT.SMIN ) THEN X* X* Check Scaling for X = B / SMIN X* X IF( SMIN.LT.ONE .AND. BNORM.GT.ONE ) THEN X IF( BNORM.GT.BIGNUM*SMIN ) X $ SCALE = ONE / BNORM X END IF X TEMP1 = SCALE / SMIN X X( 1, 1 ) = TEMP1*B( 1, 1 ) X X( 2, 1 ) = TEMP1*B( 2, 1 ) X X( 1, 2 ) = TEMP1*B( 1, 2 ) X X( 2, 2 ) = TEMP1*B( 2, 2 ) X XNORM = TEMP1*BNORM X INFO = 2 X RETURN X END IF X* X* Otherwise, check smaller singular value X* X* D^ = D / (largest element) X* X SABSI = ONE / SABS X* X WISCAL = SABSI*WI X* X DO 50 J = 1, 4 X DRSCAL( J ) = SABSI*DRORIG( J ) X 50 CONTINUE X* X* X* || D^ ||_1 (which is between 1 and 2) X* X DNORM = SABSI*MAX( DRABS( 1 )+DRABS( 2 ), X $ DRABS( 3 )+DRABS( 4 ) ) X* X* det( Re(D) ) / (largest element of D) X* X DET = DRSCAL( 1 )*DRORIG( 4 ) - DRSCAL( 2 )*DRORIG( 3 ) X* X* Real and Imaginary parts of det(D)/(largest entry) X* Also absolute value & (complex) sign X* X DETR = DET - WI*WISCAL X DETI = -WISCAL*( DRORIG( 1 )+DRORIG( 4 ) ) X DETA = DLAPY2( DETR, DETI ) X* X IF( DETA.GT.ZERO ) THEN X TEMP1 = ONE / DETA X DETRSG = TEMP1*DETR X DETISG = TEMP1*DETI X ELSE X DETRSG = ONE X DETISG = ZERO X END IF X DETMIN = SMIN*DNORM X IF( DETMIN.LE.DETA ) THEN X* X* The smaller singular value is > SMIN -- use X* present determinant, compute GROW. X* X INFO = 0 X GROW = DETA / DNORM X ELSE X* X* The smaller singular value is < SMIN, compute X* perturbation, new determinant, and GROW. X* Note that the perturbation is added to a diagonal X* entry, but subtracted from an off-diagonal entry, X* of the original matrix. X* X* As before, the perturbation is chosen to make the X* abs. value of the determinant of the perturbed X* matrix at least DETMIN, and also large enough so X* that element + perturbation won't become = element X* (to machine precision.) X* X* Here, SRHAT + i SIHAT is the value of the largest X* element in D^, i.e., scaled by |SRHAT| + |SIHAT|. X* EHAT contains all the other (real) factors. X* X INFO = 1 X TEMP1 = MAX( TWO*ULP*DRABS( 5-IMAX ), DETMIN-DETA ) X SRHAT = DRSCAL( IMAX ) X IF( IMAX.EQ.1 .OR. IMAX.EQ.4 ) THEN X SIHAT = -WISCAL X TEMP2 = WI*WISCAL + DRSCAL( IMAX )*DRORIG( IMAX ) X ELSE X SIHAT = ZERO X TEMP2 = +DRSCAL( IMAX )*DRORIG( IMAX ) X END IF X EHAT = TEMP1 / TEMP2 X DETA = DETA + TEMP1 X GROW = HALF*SMIN X END IF X* X* X* Compute X with no perturbation except for the X* determinant. X* X* The formula is: X* X* ( D^Q - i WISCAL ) ( DETRSG - i DETISG ) X* X = --------------------------------------- SCALE*B X* DETA X* X* where "D^Q" is D^ with the diagonal elements swapped and X* the off-diagonals negated. X* X* Note that multiplication by a complex number is X* the same as multiplying on the right by the appropriate X* 2 x 2 matrix. X* X* X* Compute SCALE X* X IF( GROW.LT.ONE .AND. BNORM.GT.ONE ) THEN X IF( BNORM.GT.BIGNUM*GROW ) X $ SCALE = ONE / BNORM X END IF X TEMP1 = SCALE / DETA X* X* Multiply by sign(det(D)) on the right X* X DO 60 J = 1, 2 X TMPMAT( J, 1 ) = DETRSG*B( J, 1 ) + DETISG*B( J, 2 ) X TMPMAT( J, 2 ) = -DETISG*B( J, 1 ) + DETRSG*B( J, 2 ) X 60 CONTINUE X* X* Multiply by D^Q on the left X* X DO 70 J = 1, 2 X X( 1, J ) = DRSCAL( 4 )*TMPMAT( 1, J ) - X $ DRSCAL( 3 )*TMPMAT( 2, J ) X X( 2, J ) = DRSCAL( 1 )*TMPMAT( 2, J ) - X $ DRSCAL( 2 )*TMPMAT( 1, J ) X 70 CONTINUE X* X* Subtract off TMPMAT*i*WI and scale by TEMP1 X* X DO 80 J = 1, 2 X X( J, 1 ) = TEMP1*( X( J, 1 )+WISCAL*TMPMAT( J, 2 ) ) X X( J, 2 ) = TEMP1*( X( J, 2 )-WISCAL*TMPMAT( J, 1 ) ) X 80 CONTINUE X* X* X* Add in perturbation, if necessary, to D inverse. X* X* The perturbation is: X* X* ( unperturbed det(D^) ) 1 X* ( 1 - -------------------------- ) -------------------- X* ( det(D^) after perturbation ) largest element of D X* X* *added* (always) to the appropriate element of X* the inverse of D^ as computed above. (Note that that X* inverse has a perturbed value of DETA.) X* X* X IF( INFO.NE.0 ) THEN X TEMP2 = TEMP1*EHAT X I = IROW( 5-IMAX ) X J = ICOL( 5-IMAX ) X X( I, 1 ) = X( I, 1 ) + TEMP2* X $ ( SRHAT*B( J, 1 )+SIHAT*B( J, 2 ) ) X X( I, 2 ) = X( I, 2 ) + TEMP2* X $ ( -SIHAT*B( J, 1 )+SRHAT*B( J, 2 ) ) X END IF X* X XNORM = MAX( ABS( X( 1, 1 )+X( 1, 2 ) ), X $ ABS( X( 2, 1 )+X( 2, 2 ) ) ) X RETURN X END IF X* X*....................................................................... X* X* End of DLALN2 X* X END END_OF_FILE if test 23035 -ne `wc -c <'dlaln2.f'`; then echo shar: \"'dlaln2.f'\" unpacked with wrong size! fi # end of 'dlaln2.f' fi if test -f 'dlamch.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlamch.f'\" else echo shar: Extracting \"'dlamch.f'\" \(22400 characters\) sed "s/^X//" >'dlamch.f' <<'END_OF_FILE' X DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* November 10, 1990 X* X* .. Scalar Arguments .. X CHARACTER CMACH X* .. X* X* Purpose X* ======= X* X* DLAMCH determines double precision machine parameters. X* X*----------------------------------------------------------------------- X* X* The value returned by DLAMCH is determined by the parameter CMACH as X* follows: X* X* CMACH = 'E' or 'e', DLAMCH := eps X* CMACH = 'S' or 's , DLAMCH := sfmin X* CMACH = 'B' or 'b', DLAMCH := base X* CMACH = 'P' or 'p', DLAMCH := eps*base X* CMACH = 'N' or 'n', DLAMCH := t X* CMACH = 'R' or 'r', DLAMCH := rnd X* CMACH = 'M' or 'm', DLAMCH := emin X* CMACH = 'U' or 'u', DLAMCH := rmin X* CMACH = 'L' or 'l', DLAMCH := emax X* CMACH = 'O' or 'o', DLAMCH := rmax X* X* where X* X* eps = relative machine precision X* sfmin = safe minimum, such that 1/sfmin does not overflow X* base = base of the machine X* prec = eps*base X* t = number of (base) digits in the mantissa X* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise X* emin = minimum exponent before (gradual) underflow X* rmin = underflow threshold - base**(emin-1) X* emax = largest exponent before overflow X* rmax = overflow threshold - (base**emax)*(1-eps) X* X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X LOGICAL FIRST, LRND X INTEGER BETA, IMAX, IMIN, IT X DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, X $ RND, SFMIN, SMALL, T X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. Save statement .. X SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, X $ EMAX, RMAX, PREC X* .. X* .. External Subroutines .. X EXTERNAL DLAMC2 X* .. X* .. Data statements .. X DATA FIRST / .TRUE. / X* .. X* .. Executable Statements .. X* X IF( FIRST ) THEN X FIRST = .FALSE. X CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) X BASE = BETA X T = IT X IF( LRND ) THEN X RND = ONE X EPS = ( BASE**( 1-IT ) ) / 2 X ELSE X RND = ZERO X EPS = BASE**( 1-IT ) X END IF X PREC = EPS*BASE X EMIN = IMIN X EMAX = IMAX X SFMIN = RMIN X SMALL = ONE / RMAX X IF( SMALL.GE.SFMIN ) THEN X* X* Use SMALL plus a bit, to avoid the possibility of rounding X* causing overflow when computing 1/sfmin. X* X SFMIN = SMALL*( ONE+EPS ) X END IF X END IF X* X IF( LSAME( CMACH, 'E' ) ) THEN X RMACH = EPS X ELSE IF( LSAME( CMACH, 'S' ) ) THEN X RMACH = SFMIN X ELSE IF( LSAME( CMACH, 'B' ) ) THEN X RMACH = BASE X ELSE IF( LSAME( CMACH, 'P' ) ) THEN X RMACH = PREC X ELSE IF( LSAME( CMACH, 'N' ) ) THEN X RMACH = T X ELSE IF( LSAME( CMACH, 'R' ) ) THEN X RMACH = RND X ELSE IF( LSAME( CMACH, 'M' ) ) THEN X RMACH = EMIN X ELSE IF( LSAME( CMACH, 'U' ) ) THEN X RMACH = RMIN X ELSE IF( LSAME( CMACH, 'L' ) ) THEN X RMACH = EMAX X ELSE IF( LSAME( CMACH, 'O' ) ) THEN X RMACH = RMAX X END IF X* X DLAMCH = RMACH X RETURN X* X* End of DLAMCH X* X END X* X************************************************************************ X* X SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) X* X* DLAMC1 returns the machine parameters given by: X* X* BETA - INTEGER. X* The base of the machine. X* X* T - INTEGER. X* The number of ( BETA ) digits in the mantissa. X* X* RND - LOGICAL. X* Whether proper rounding ( RND = .TRUE. ) or chopping X* ( RND = .FALSE. ) occurs in addition. This may not be a X* reliable guide to the way in which the machine performs X* its arithmetic. X* X* IEEE1 - LOGICAL. X* Whether rounding appears to be done in the IEEE 'round X* to nearest' style. X* X* The routine is based on the routine ENVRON by Malcolm and X* incorporates suggestions by Gentleman and Marovich. See X* X* Malcolm M. A. (1972) Algorithms to reveal properties of X* floating-point arithmetic. Comms. of the ACM, 15, 949-951. X* X* Gentleman W. M. and Marovich S. B. (1974) More on algorithms X* that reveal properties of floating point arithmetic units. X* Comms. of the ACM, 17, 276-277. X* X* X* .. Scalar Arguments .. X LOGICAL IEEE1, RND X INTEGER BETA, T X* .. X* .. Local Scalars .. X LOGICAL FIRST, LIEEE1, LRND X INTEGER LBETA, LT X DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 X* .. X* .. External Functions .. X DOUBLE PRECISION DLAMC3 X EXTERNAL DLAMC3 X* .. X* .. Save statement .. X SAVE FIRST, LIEEE1, LBETA, LRND, LT X* .. X* .. Data statements .. X* X DATA FIRST / .TRUE. / X* .. X* .. Executable Statements .. X* X IF( FIRST ) THEN X FIRST = .FALSE. X ONE = 1 X* X* LBETA, LIEEE1, LT and LRND are the local values of BETA, X* IEEE1, T and RND. X* X* Throughout this routine we use the function DLAMC3 to ensure X* that relevant values are stored and not held in registers, or X* are not affected by optimizers. X* X* Compute a = 2.0**m with the smallest positive integer m such X* that X* X* fl( a + 1.0 ) = a. X* X A = 1 X C = 1 X* X*+ WHILE( C.EQ.ONE )LOOP X 10 CONTINUE X IF( C.EQ.ONE ) THEN X A = 2*A X C = DLAMC3( A, ONE ) X C = DLAMC3( C, -A ) X GO TO 10 X END IF X*+ END WHILE X* X* Now compute b = 2.0**m with the smallest positive integer m X* such that X* X* fl( a + b ) .gt. a. X* X B = 1 X C = DLAMC3( A, B ) X* X*+ WHILE( C.EQ.A )LOOP X 20 CONTINUE X IF( C.EQ.A ) THEN X B = 2*B X C = DLAMC3( A, B ) X GO TO 20 X END IF X*+ END WHILE X* X* Now compute the base. a and c are neighbouring floating point X* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so X* their difference is beta. Adding 0.25 to c is to ensure that it X* is truncated to beta and not ( beta - 1 ). X* X QTR = ONE / 4 X SAVEC = C X C = DLAMC3( C, -A ) X LBETA = C + QTR X* X* Now determine whether rounding or chopping occurs, by adding a X* bit less than beta/2 and a bit more than beta/2 to a. X* X B = LBETA X F = DLAMC3( B/2, -B/100 ) X C = DLAMC3( F, A ) X IF( C.EQ.A ) THEN X LRND = .TRUE. X ELSE X LRND = .FALSE. X END IF X F = DLAMC3( B/2, B/100 ) X C = DLAMC3( F, A ) X IF( ( LRND ) .AND. ( C.EQ.A ) ) X $ LRND = .FALSE. X* X* Try and decide whether rounding is done in the IEEE 'round to X* nearest' style. B/2 is half a unit in the last place of the two X* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit X* zero, and SAVEC is odd. Thus adding B/2 to A should not change X* A, but adding B/2 to SAVEC should change SAVEC. X* X T1 = DLAMC3( B/2, A ) X T2 = DLAMC3( B/2, SAVEC ) X LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND X* X* Now find the mantissa, t. It should be the integer part of X* log to the base beta of a, however it is safer to determine t X* by powering. So we find t as the smallest positive integer for X* which X* X* fl( beta**t + 1.0 ) = 1.0. X* X LT = 0 X A = 1 X C = 1 X* X*+ WHILE( C.EQ.ONE )LOOP X 30 CONTINUE X IF( C.EQ.ONE ) THEN X LT = LT + 1 X A = A*LBETA X C = DLAMC3( A, ONE ) X C = DLAMC3( C, -A ) X GO TO 30 X END IF X*+ END WHILE X* X END IF X* X BETA = LBETA X T = LT X RND = LRND X IEEE1 = LIEEE1 X RETURN X* X* End of DLAMC1 X* X END X* X************************************************************************ X* X SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) X* X* DLAMC2 returns the machine parameters given by: X* X* BETA - INTEGER. X* The base of the machine. X* X* T - INTEGER. X* The number of ( BETA ) digits in the mantissa. X* X* RND - LOGICAL. X* Whether proper rounding ( RND = .TRUE. ) or chopping X* ( RND = .FALSE. ) occurs in addition. This may not be a X* reliable guide to the way in which the machine performs X* its arithmetic. X* X* EPS - DOUBLE PRECISION. X* The smallest positive number such that X* X* fl( 1.0 - EPS ) .LT. 1.0, X* X* where fl denotes the computed value. X* X* EMIN - INTEGER. X* The minimum exponent before (gradual) underflow occurs. X* X* RMIN - DOUBLE PRECISION. X* The smallest normalized number for the machine given by X* BASE**( EMIN - 1 ), where BASE is the floating point X* value of BETA. X* X* EMAX - INTEGER. X* The maximum exponent before overflow occurs. X* X* RMAX - DOUBLE PRECISION. X* The largest positive number for the machine given by X* BASE**EMAX * ( 1 - EPS ), where BASE is the floating X* point value of BETA. X* X* X* The computation of EPS is based on a routine, PARANOIA by X* W. Kahan of the University of California at Berkeley. X* X* X* .. Scalar Arguments .. X LOGICAL RND X INTEGER BETA, EMAX, EMIN, T X DOUBLE PRECISION EPS, RMAX, RMIN X* .. X* .. Local Scalars .. X LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND X INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, X $ NGNMIN, NGPMIN X DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, X $ SIXTH, SMALL, THIRD, TWO, ZERO X* .. X* .. External Functions .. X DOUBLE PRECISION DLAMC3 X EXTERNAL DLAMC3 X* .. X* .. External Subroutines .. X EXTERNAL DLAMC1, DLAMC4, DLAMC5 X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, MIN X* .. X* .. Save statement .. X SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, X $ LRMIN, LT X* .. X* .. Data statements .. X DATA FIRST / .TRUE. / , IWARN / .FALSE. / X* .. X* .. Executable Statements .. X* X IF( FIRST ) THEN X FIRST = .FALSE. X ZERO = 0 X ONE = 1 X TWO = 2 X* X* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of X* BETA, T, RND, EPS, EMIN and RMIN. X* X* Throughout this routine we use the function DLAMC3 to ensure X* that relevant values are stored and not held in registers, or X* are not affected by optimizers. X* X* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. X* X CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) X* X* Start to find EPS. X* X B = LBETA X A = B**( -LT ) X LEPS = A X* X* Try some tricks to see whether or not this is the correct EPS. X* X B = TWO / 3 X HALF = ONE / 2 X SIXTH = DLAMC3( B, -HALF ) X THIRD = DLAMC3( SIXTH, SIXTH ) X B = DLAMC3( THIRD, -HALF ) X B = DLAMC3( B, SIXTH ) X B = ABS( B ) X IF( B.LT.LEPS ) X $ B = LEPS X* X LEPS = 1 X* X*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP X 10 CONTINUE X IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN X LEPS = B X C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) X C = DLAMC3( HALF, -C ) X B = DLAMC3( HALF, C ) X C = DLAMC3( HALF, -B ) X B = DLAMC3( HALF, C ) X GO TO 10 X END IF X*+ END WHILE X* X IF( A.LT.LEPS ) X $ LEPS = A X* X* Computation of EPS complete. X* X* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). X* Keep dividing A by BETA until (gradual) underflow occurs. This X* is detected when we cannot recover the previous A. X* X RBASE = ONE / LBETA X SMALL = ONE X DO 20 I = 1, 3 X SMALL = DLAMC3( SMALL*RBASE, ZERO ) X 20 CONTINUE X A = DLAMC3( ONE, SMALL ) X CALL DLAMC4( NGPMIN, ONE, LBETA ) X CALL DLAMC4( NGNMIN, -ONE, LBETA ) X CALL DLAMC4( GPMIN, A, LBETA ) X CALL DLAMC4( GNMIN, -A, LBETA ) X IEEE = .FALSE. X* X IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN X IF( NGPMIN.EQ.GPMIN ) THEN X LEMIN = NGPMIN X* ( Non twos-complement machines, no gradual underflow; X* e.g., VAX ) X ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN X LEMIN = NGPMIN - 1 + LT X IEEE = .TRUE. X* ( Non twos-complement machines, with gradual underflow; X* e.g., IEEE standard followers ) X ELSE X LEMIN = MIN( NGPMIN, GPMIN ) X* ( A guess; no known machine ) X IWARN = .TRUE. X END IF X* X ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN X IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN X LEMIN = MAX( NGPMIN, NGNMIN ) X* ( Twos-complement machines, no gradual underflow; X* e.g., CYBER 205 ) X ELSE X LEMIN = MIN( NGPMIN, NGNMIN ) X* ( A guess; no known machine ) X IWARN = .TRUE. X END IF X* X ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. X $ ( GPMIN.EQ.GNMIN ) ) THEN X IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN X LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT X* ( Twos-complement machines with gradual underflow; X* no known machine ) X ELSE X LEMIN = MIN( NGPMIN, NGNMIN ) X* ( A guess; no known machine ) X IWARN = .TRUE. X END IF X* X ELSE X LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) X* ( A guess; no known machine ) X IWARN = .TRUE. X END IF X*** X* Comment out this if block if EMIN is ok X IF( IWARN ) THEN X FIRST = .TRUE. X WRITE( 6, FMT = 9999 )LEMIN X END IF X*** X* X* Assume IEEE arithmetic if we found denormalised numbers above, X* or if arithmetic seems to round in the IEEE style, determined X* in routine DLAMC1. A true IEEE machine should have both things X* true; however, faulty machines may have one or the other. X* X IEEE = IEEE .OR. LIEEE1 X* X* Compute RMIN by successive division by BETA. We could compute X* RMIN as BASE**( EMIN - 1 ), but some machines underflow during X* this computation. X* X LRMIN = 1 X DO 30 I = 1, 1 - LEMIN X LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) X 30 CONTINUE X* X* Finally, call DLAMC5 to compute EMAX and RMAX. X* X CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) X END IF X* X BETA = LBETA X T = LT X RND = LRND X EPS = LEPS X EMIN = LEMIN X RMIN = LRMIN X EMAX = LEMAX X RMAX = LRMAX X* X RETURN X* X 9999 FORMAT( //' WARNING. The value EMIN may be incorrect:-', X $ ' EMIN = ', I8, / X $ ' If, after inspection, the value EMIN looks', X $ ' acceptable please comment out ', X $ /' the IF block as marked within the code of routine', X $ ' DLAMC2,', /' otherwise supply EMIN explicitly.', / ) X* X* End of DLAMC2 X* X END X* X************************************************************************ X* X DOUBLE PRECISION FUNCTION DLAMC3( A, B ) X* .. Scalar Arguments .. X DOUBLE PRECISION A, B X* .. X* .. Executable Statements .. X* X* DLAMC3 is intended to force A and B to be stored prior to doing X* the addition of A and B. For use in situations where optimizers X* might hold one of these in a register. X* X* X DLAMC3 = A + B X* X RETURN X* X* End of DLAMC3 X* X END X* X************************************************************************ X* X SUBROUTINE DLAMC4( EMIN, START, BASE ) X* X* Service routine for DLAMC2. X* X* X* .. Scalar Arguments .. X INTEGER BASE, EMIN X DOUBLE PRECISION START X* .. X* .. Local Scalars .. X INTEGER I X DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO X* .. X* .. External Functions .. X DOUBLE PRECISION DLAMC3 X EXTERNAL DLAMC3 X* .. X* .. Executable Statements .. X* X A = START X ONE = 1 X RBASE = ONE / BASE X ZERO = 0 X EMIN = 1 X B1 = DLAMC3( A*RBASE, ZERO ) X C1 = A X C2 = A X D1 = A X D2 = A X*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. X* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP X 10 CONTINUE X IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. X $ ( D2.EQ.A ) ) THEN X EMIN = EMIN - 1 X A = B1 X B1 = DLAMC3( A/BASE, ZERO ) X C1 = DLAMC3( B1*BASE, ZERO ) X D1 = ZERO X DO 20 I = 1, BASE X D1 = D1 + B1 X 20 CONTINUE X B2 = DLAMC3( A*RBASE, ZERO ) X C2 = DLAMC3( B2/RBASE, ZERO ) X D2 = ZERO X DO 30 I = 1, BASE X D2 = D2 + B2 X 30 CONTINUE X GO TO 10 X END IF X*+ END WHILE X* X RETURN X* X* End of DLAMC4 X* X END X* X************************************************************************ X* X SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) X* X* Given BETA, the base of floating-point arithmetic, P, the X* number of base BETA digits in the mantissa of a floating-point X* value, EMIN, the minimum exponent, and IEEE, a logical X* flag saying whether or not the arithmetic system is thought X* to comply with the IEEE standard, this routine attempts to X* compute RMAX, the largest machine floating-point number, X* without overflow. The routine assumes that EMAX + abs(EMIN) X* sum approximately to a power of 2. It will fail on machines X* where this assumption does not hold, for example the Cyber 205 X* (EMIN = -28625, EMAX = 28718). It will also fail if the value X* supplied for EMIN is too large (i.e. too close to zero), X* probably with overflow. X* X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE X PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) X* .. X* .. Scalar Arguments .. X LOGICAL IEEE X INTEGER BETA, EMAX, EMIN, P X DOUBLE PRECISION RMAX X* .. X* .. Local Scalars .. X INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP X DOUBLE PRECISION OLDY, RECBAS, Y, Z X* .. X* .. External Functions .. X DOUBLE PRECISION DLAMC3 X EXTERNAL DLAMC3 X* .. X* .. Intrinsic Functions .. X INTRINSIC MOD X* .. X* .. Executable Statements .. X* X* First compute LEXP and UEXP, two powers of 2 that bound X* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum X* approximately to the bound that is closest to abs(EMIN). X* (EMAX is the exponent of the required number RMAX). X* X LEXP = 1 X EXBITS = 1 X 10 CONTINUE X TRY = LEXP*2 X IF( TRY.LE.( -EMIN ) ) THEN X LEXP = TRY X EXBITS = EXBITS + 1 X GO TO 10 X END IF X IF( LEXP.EQ.-EMIN ) THEN X UEXP = LEXP X ELSE X UEXP = TRY X EXBITS = EXBITS + 1 X END IF X* X* Now -LEXP is less than or equal to EMIN, and -UEXP is greater X* than or equal to EMIN. EXBITS is the number of bits needed to X* store the exponent. X* X IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN X EXPSUM = 2*LEXP X ELSE X EXPSUM = 2*UEXP X END IF X* X* EXPSUM is the exponent range, approximately equal to X* EMAX - EMIN + 1 . X* X EMAX = EXPSUM + EMIN - 1 X NBITS = 1 + EXBITS + P X* X* NBITS is the total number of bits needed to store a X* floating-point number. X* X IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN X* X* Either there are an odd number of bits used to store a X* floating-point number, which is unlikely, or some bits are X* not used in the representation of numbers, which is possible, X* (e.g. Cray machines) or the mantissa has an implicit bit, X* (e.g. IEEE machines, Dec Vax machines), which is perhaps the X* most likely. We have to assume the last alternative. X* If this is true, then we need to reduce EMAX by one because X* there must be some way of representing zero in an implicit-bit X* system. On machines like Cray, we are reducing EMAX by one X* unnecessarily. X* X EMAX = EMAX - 1 X END IF X* X IF( IEEE ) THEN X* X* Assume we are on an IEEE machine which reserves one exponent X* for infinity and NaN. X* X EMAX = EMAX - 1 X END IF X* X* Now create RMAX, the largest machine number, which should X* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . X* X* First compute 1.0 - BETA**(-P), being careful that the X* result is less than 1.0 . X* X RECBAS = ONE / BETA X Z = ONE X Y = ZERO X DO 20 I = 1, P X Z = Z*RECBAS X IF( Y.LT.ONE ) X $ OLDY = Y X Y = DLAMC3( Y, Z ) X 20 CONTINUE X IF( Y.GE.ONE ) X $ Y = OLDY X* X* Now multiply by BETA**EMAX to get RMAX. X* X DO 30 I = 1, EMAX X Y = DLAMC3( Y*BETA, ZERO ) X 30 CONTINUE X* X RMAX = Y X RETURN X* X* End of DLAMC5 X* X END END_OF_FILE if test 22400 -ne `wc -c <'dlamch.f'`; then echo shar: \"'dlamch.f'\" unpacked with wrong size! fi # end of 'dlamch.f' fi if test -f 'dlangb.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlangb.f'\" else echo shar: Extracting \"'dlangb.f'\" \(5811 characters\) sed "s/^X//" >'dlangb.f' <<'END_OF_FILE' X DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, A, LDA, WORK ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER NORM X INTEGER KL, KU, LDA, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DLANGB returns the value of the one norm, or the Frobenius norm, or X* the infinity norm, or the element of largest absolute value of an X* n by n band matrix A, with kl sub-diagonals and ku super-diagonals. X* X* Description X* =========== X* X* DLANGB returns the value X* X* DLANGB = ( max( abs( a( i, j ) ) ) , NORM = 'M' or 'm' X* ( X* ( norm1( A ) , NORM = '1', 'O' or 'o' X* ( X* ( normI( A ) , NORM = 'I' or 'i' X* ( X* ( normF( A ) , NORM = 'F', 'f', 'E' or 'e' X* X* where norm1 denotes the one norm of a matrix (maximum column sum), X* normI denotes the infinity norm of a matrix (maximum row sum) and X* normF denotes the Frobenius norm of a matrix (square root of sum of X* squares). Note that max( abs( a( i, j ) ) ) is not a matrix norm. X* X* Arguments X* ========= X* X* NORM - CHARACTER*1 X* X* On entry, NORM specifies the value to be returned in DLANGB X* as described above. X* X* Not modified. X* X* N - INTEGER X* X* On entry, N specifies the order of the matrix A. N must be X* at least zero. When N = 0 then DLANGB is set to zero and X* an immediate return is effected. X* X* X* KL - INTEGER X* X* On entry, KL specifies the number of sub-diagonals of the X* matrix A. KL must be at least zero. X* X* Not modified. X* X* KU - INTEGER X* X* On entry, KU specifies the number of super-diagonals of the X* matrix A. KU must be at least zero. X* X* Not modified. X* X* A - DOUBLE PRECISION array, dimension( LDA, N ) X* X* Before entry, the leading ( kl + ku + 1 ) by n part of the X* array A must contain the matrix of coefficients, supplied X* column by column, with the leading diagonal of the matrix in X* row ( ku + 1 ) of the array, the first super-diagonal X* starting at position 2 in row ku, the first sub-diagonal X* starting at position 1 in row ( ku + 2 ), and so on. X* Elements in the array that do not correspond to elements in X* the band matrix (such as the top left ku by ku triangle) are X* not referenced. The following program segment will transfer X* a band matrix from full matrix storage to band storage: X* X* DO 20, J = 1, N X* K = KU + 1 - J X* DO 10, I = MAX( 1, J - KU ), MIN( N, J + KL ) X* A( K + I, J ) = matrix( I, J ) X* 10 CONTINUE X* 20 CONTINUE X* X* Not modified. X* X* LDA - INTEGER X* X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least X* ( KL + KU + 1 ). X* X* Not modified. X* X* WORK - DOUBLE PRECISION array, dimension( LWORK ), where LWORK X* must be at least N when NORM = 'I' or 'i'. X* X* When NORM = 'I' or 'i' then WORK is used as internal X* workspace, otherwise WORK is not referenced. X* X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, J, K, L X DOUBLE PRECISION SCALE, SUM, VALUE X* .. X* .. External Subroutines .. X EXTERNAL DLASSQ X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, MIN, SQRT X* .. X* .. Executable Statements .. X* X IF( N.EQ.0 ) THEN X VALUE = ZERO X ELSE IF( LSAME( NORM, 'M' ) ) THEN X* X* Find max( abs( a( i, j ) ) ). X* X VALUE = ZERO X DO 20 J = 1, N X DO 10 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) X VALUE = MAX( VALUE, ABS( A( I, J ) ) ) X 10 CONTINUE X 20 CONTINUE X ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN X* X* Find norm1( A ). X* X VALUE = ZERO X DO 40 J = 1, N X SUM = ZERO X DO 30 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 ) X SUM = SUM + ABS( A( I, J ) ) X 30 CONTINUE X VALUE = MAX( VALUE, SUM ) X 40 CONTINUE X ELSE IF( LSAME( NORM, 'I' ) ) THEN X* X* Find normI( A ). X* X DO 50 I = 1, N X WORK( I ) = ZERO X 50 CONTINUE X DO 70 J = 1, N X K = KU + 1 - J X DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL ) X WORK( I ) = WORK( I ) + ABS( A( K+I, J ) ) X 60 CONTINUE X 70 CONTINUE X VALUE = ZERO X DO 80 I = 1, N X VALUE = MAX( VALUE, WORK( I ) ) X 80 CONTINUE X ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN X* X* Find normF( A ). X* X SCALE = ZERO X SUM = ONE X DO 90 J = 1, N X L = MAX( 1, J-KU ) X K = KU + 1 - J + L X CALL DLASSQ( MIN( N, J+KL )-L+1, A( K, J ), 1, SCALE, SUM ) X 90 CONTINUE X VALUE = SCALE*SQRT( SUM ) X END IF X* X DLANGB = VALUE X RETURN X* X* End of DLANGB X* X END END_OF_FILE if test 5811 -ne `wc -c <'dlangb.f'`; then echo shar: \"'dlangb.f'\" unpacked with wrong size! fi # end of 'dlangb.f' fi if test -f 'dlange.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlange.f'\" else echo shar: Extracting \"'dlange.f'\" \(4577 characters\) sed "s/^X//" >'dlange.f' <<'END_OF_FILE' X DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER NORM X INTEGER LDA, M, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DLANGE returns the value of the one norm, or the Frobenius norm, or X* the infinity norm, or the element of largest absolute value of a X* real matrix A. X* X* Description X* =========== X* X* DLANGE returns the value X* X* DLANGE = ( max( abs( a( i, j ) ) ) , NORM = 'M' or 'm' X* ( X* ( norm1( A ) , NORM = '1', 'O' or 'o' X* ( X* ( normI( A ) , NORM = 'I' or 'i' X* ( X* ( normF( A ) , NORM = 'F', 'f', 'E' or 'e' X* X* where norm1 denotes the one norm of a matrix (maximum column sum), X* normI denotes the infinity norm of a matrix (maximum row sum) and X* normF denotes the Frobenius norm of a matrix (square root of sum of X* squares). Note that max( abs( a( i, j ) ) ) is not a matrix norm. X* X* Parameters X* ========== X* X* NORM - CHARACTER*1 X* X* On entry, NORM specifies the value to be returned in DLANGE X* as described above. X* X* Not modified. X* X* M - INTEGER X* X* On entry, M specifies the number of rows of the matrix A. X* M must be at least zero. When M = 0 then DLANGE is set to X* zero and an immediate return is effected. X* X* Not modified. X* X* N - INTEGER X* X* On entry, N specifies the number of columns of the matrix A. X* N must be at least zero. When N = 0 then DLANGE is set to X* zero and an immediate return is effected. X* X* Not modified. X* X* A - DOUBLE PRECISION array, dimension( LDA, N ) X* X* Before entry, A must contain the m by n matrix for which X* DLANGE is required. X* X* Not modified. X* X* LDA - INTEGER X* X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least M. X* X* Not modified. X* X* WORK - DOUBLE PRECISION array, dimension( LWORK ), where LWORK X* must be at least M when NORM = 'I' or 'i'. X* X* When NORM = 'I' or 'i' then WORK is used as internal X* workspace, otherwise WORK is not referenced. X* X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, J X DOUBLE PRECISION SCALE, SUM, VALUE X* .. X* .. External Subroutines .. X EXTERNAL DLASSQ X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, MIN, SQRT X* .. X* .. Executable Statements .. X* X IF( MIN( M, N ).EQ.0 ) THEN X VALUE = ZERO X ELSE IF( LSAME( NORM, 'M' ) ) THEN X* X* Find max( abs( a( i, j ) ) ). X* X VALUE = ZERO X DO 20 J = 1, N X DO 10 I = 1, M X VALUE = MAX( VALUE, ABS( A( I, J ) ) ) X 10 CONTINUE X 20 CONTINUE X ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN X* X* Find norm1( A ). X* X VALUE = ZERO X DO 40 J = 1, N X SUM = ZERO X DO 30 I = 1, M X SUM = SUM + ABS( A( I, J ) ) X 30 CONTINUE X VALUE = MAX( VALUE, SUM ) X 40 CONTINUE X ELSE IF( LSAME( NORM, 'I' ) ) THEN X* X* Find normI( A ). X* X DO 50 I = 1, M X WORK( I ) = ZERO X 50 CONTINUE X DO 70 J = 1, N X DO 60 I = 1, M X WORK( I ) = WORK( I ) + ABS( A( I, J ) ) X 60 CONTINUE X 70 CONTINUE X VALUE = ZERO X DO 80 I = 1, M X VALUE = MAX( VALUE, WORK( I ) ) X 80 CONTINUE X ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN X* X* Find normF( A ). X* X SCALE = ZERO X SUM = ONE X DO 90 J = 1, N X CALL DLASSQ( M, A( 1, J ), 1, SCALE, SUM ) X 90 CONTINUE X VALUE = SCALE*SQRT( SUM ) X END IF X* X DLANGE = VALUE X RETURN X* X* End of DLANGE X* X END END_OF_FILE if test 4577 -ne `wc -c <'dlange.f'`; then echo shar: \"'dlange.f'\" unpacked with wrong size! fi # end of 'dlange.f' fi if test -f 'dlanhs.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlanhs.f'\" else echo shar: Extracting \"'dlanhs.f'\" \(4512 characters\) sed "s/^X//" >'dlanhs.f' <<'END_OF_FILE' X DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER NORM X INTEGER LDA, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DLANHS returns the value of the one norm, or the Frobenius norm, or X* the infinity norm, or the element of largest absolute value of a X* Hessenberg matrix A. X* X* Description X* =========== X* X* DLANHS returns the value X* X* DLANHS = ( max( abs( a( i, j ) ) ) , NORM = 'M' or 'm' X* ( X* ( norm1( A ) , NORM = '1', 'O' or 'o' X* ( X* ( normI( A ) , NORM = 'I' or 'i' X* ( X* ( normF( A ) , NORM = 'F', 'f', 'E' or 'e' X* X* where norm1 denotes the one norm of a matrix (maximum column sum), X* normI denotes the infinity norm of a matrix (maximum row sum) and X* normF denotes the Frobenius norm of a matrix (square root of sum of X* squares). Note that max( abs( a( i, j ) ) ) is not a matrix norm. X* X* Parameters X* ========== X* X* NORM - CHARACTER*1 X* X* On entry, NORM specifies the value to be returned in DLANHS X* as described above. X* X* Not modified. X* X* N - INTEGER X* X* On entry, N specifies the order of the matrix A. N must be X* at least zero. When N = 0 then DLANHS is set to zero and X* an immediate return is effected. X* X* Not modified. X* X* A - DOUBLE PRECISION array, dimension( LDA, N ) X* X* Before entry, n by n upper Hessenberg part of the array A X* must contain the n by n upper Hessenberg matrix for which X* DLANHS is required, and the part of A below the first X* sub-diagonal is not referenced. X* X* Not modified. X* X* LDA - INTEGER X* X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least N. X* X* Not modified. X* X* WORK - DOUBLE PRECISION array, dimension( LWORK ), where LWORK X* must be at least N when NORM = 'I' or 'i'. X* X* When NORM = 'I' or 'i' then WORK is used as internal X* workspace, otherwise WORK is not referenced. X* X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, J X DOUBLE PRECISION SCALE, SUM, VALUE X* .. X* .. External Subroutines .. X EXTERNAL DLASSQ X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, MIN, SQRT X* .. X* .. Executable Statements .. X* X IF( N.EQ.0 ) THEN X VALUE = ZERO X ELSE IF( LSAME( NORM, 'M' ) ) THEN X* X* Find max( abs( a( i, j ) ) ). X* X VALUE = ZERO X DO 20 J = 1, N X DO 10 I = 1, MIN( N, J+1 ) X VALUE = MAX( VALUE, ABS( A( I, J ) ) ) X 10 CONTINUE X 20 CONTINUE X ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN X* X* Find norm1( A ). X* X VALUE = ZERO X DO 40 J = 1, N X SUM = ZERO X DO 30 I = 1, MIN( N, J+1 ) X SUM = SUM + ABS( A( I, J ) ) X 30 CONTINUE X VALUE = MAX( VALUE, SUM ) X 40 CONTINUE X ELSE IF( LSAME( NORM, 'I' ) ) THEN X* X* Find normI( A ). X* X DO 50 I = 1, N X WORK( I ) = ZERO X 50 CONTINUE X DO 70 J = 1, N X DO 60 I = 1, MIN( N, J+1 ) X WORK( I ) = WORK( I ) + ABS( A( I, J ) ) X 60 CONTINUE X 70 CONTINUE X VALUE = ZERO X DO 80 I = 1, N X VALUE = MAX( VALUE, WORK( I ) ) X 80 CONTINUE X ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN X* X* Find normF( A ). X* X SCALE = ZERO X SUM = ONE X DO 90 J = 1, N X CALL DLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM ) X 90 CONTINUE X VALUE = SCALE*SQRT( SUM ) X END IF X* X DLANHS = VALUE X RETURN X* X* End of DLANHS X* X END END_OF_FILE if test 4512 -ne `wc -c <'dlanhs.f'`; then echo shar: \"'dlanhs.f'\" unpacked with wrong size! fi # end of 'dlanhs.f' fi if test -f 'dlansb.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlansb.f'\" else echo shar: Extracting \"'dlansb.f'\" \(8026 characters\) sed "s/^X//" >'dlansb.f' <<'END_OF_FILE' X DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, A, LDA, WORK ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER NORM, UPLO X INTEGER K, LDA, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DLANSB returns the value of the one norm, or the Frobenius norm, or X* the infinity norm, or the element of largest absolute value of an X* n by n symmetric band matrix A, with k super-diagonals. X* X* Description X* =========== X* X* DLANSB returns the value X* X* DLANSB = ( max( abs( a( i, j ) ) ) , NORM = 'M' or 'm' X* ( X* ( norm1( A ) , NORM = '1', 'O' or 'o' X* ( X* ( normI( A ) , NORM = 'I' or 'i' X* ( X* ( normF( A ) , NORM = 'F', 'f', 'E' or 'e' X* X* where norm1 denotes the one norm of a matrix (maximum column sum), X* normI denotes the infinity norm of a matrix (maximum row sum) and X* normF denotes the Frobenius norm of a matrix (square root of sum of X* squares). Note that max( abs( a( i, j ) ) ) is not a matrix norm. X* X* Parameters X* ========== X* X* NORM - CHARACTER*1 X* X* On entry, NORM specifies the value to be returned in DLANSB X* as described above. X* X* Not modified. X* X* UPLO - CHARACTER*1 X* X* On entry, UPLO specifies whether the upper or lower X* triangular part of the band matrix A is being supplied. X* X* UPLO = 'U' or 'u' The upper triangular part of A is X* being supplied. X* X* UPLO = 'L' or 'l' The lower triangular part of A is X* being supplied. X* X* Not modified. X* X* N - INTEGER X* X* On entry, N specifies the order of the matrix A. N must be X* at least zero. When N = 0 then DLANSB is set to zero and X* an immediate return is effected. X* X* Not modified. X* X* K - INTEGER X* X* On entry, K specifies the number of super-diagonals of the X* matrix A. K must be at least zero. X* X* Not modified. X* X* A - DOUBLE PRECISION array, dimension( LDA, N ) X* X* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) X* by n part of the array A must contain the upper triangular X* band part of the symmetric matrix, supplied column by X* column, with the leading diagonal of the matrix in row X* ( k + 1 ) of the array, the first super-diagonal starting at X* position 2 in row k, and so on. The top left k by k triangle X* of the array A is not referenced. The following program X* segment will transfer the upper triangular part of a X* symmetric band matrix from conventional full matrix storage X* to band storage: X* X* DO 20, J = 1, N X* M = K + 1 - J X* DO 10, I = MAX( 1, J - K ), J X* A( M + I, J ) = matrix( I, J ) X* 10 CONTINUE X* 20 CONTINUE X* X* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) X* by n part of the array A must contain the lower triangular X* band part of the symmetric matrix, supplied column by X* column, with the leading diagonal of the matrix in row 1 of X* the array, the first sub-diagonal starting at position 1 in X* row 2, and so on. The bottom right k by k triangle of the X* array A is not referenced. The following program segment X* will transfer the lower triangular part of a symmetric band X* matrix from conventional full matrix storage to band X* storage: X* X* DO 20, J = 1, N X* M = 1 - J X* DO 10, I = J, MIN( N, J + K ) X* A( M + I, J ) = matrix( I, J ) X* 10 CONTINUE X* 20 CONTINUE X* X* Not modified. X* X* LDA - INTEGER X* X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least X* ( K + 1 ). X* X* Not modified. X* X* WORK - DOUBLE PRECISION array, dimension( LWORK ), where LWORK X* must be at least N when NORM = '1' or 'O' or 'o' or 'I' or X* 'i'. X* X* When NORM = 'I' or 'i' or '1' or 'O' or 'o' then WORK is X* used as internal workspace, otherwise WORK is not X* referenced. X* X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, J, L X DOUBLE PRECISION ABSA, SCALE, SUM, VALUE X* .. X* .. External Subroutines .. X EXTERNAL DLASSQ X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, MIN, SQRT X* .. X* .. Executable Statements .. X* X IF( N.EQ.0 ) THEN X VALUE = ZERO X ELSE IF( LSAME( NORM, 'M' ) ) THEN X* X* Find max( abs( a( i, j ) ) ). X* X VALUE = ZERO X IF( LSAME( UPLO, 'U' ) ) THEN X DO 20 J = 1, N X DO 10 I = MAX( K+2-J, 1 ), K + 1 X VALUE = MAX( VALUE, ABS( A( I, J ) ) ) X 10 CONTINUE X 20 CONTINUE X ELSE X DO 40 J = 1, N X DO 30 I = 1, MIN( N+1-J, K+1 ) X VALUE = MAX( VALUE, ABS( A( I, J ) ) ) X 30 CONTINUE X 40 CONTINUE X END IF X ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. X $ ( NORM.EQ.'1' ) ) THEN X* X* Find normI( A ) ( = norm1( A ), since A is symmetric). X* X VALUE = ZERO X IF( LSAME( UPLO, 'U' ) ) THEN X DO 60 J = 1, N X SUM = ZERO X L = K + 1 - J X DO 50 I = MAX( 1, J-K ), J - 1 X ABSA = ABS( A( L+I, J ) ) X SUM = SUM + ABSA X WORK( I ) = WORK( I ) + ABSA X 50 CONTINUE X WORK( J ) = SUM + ABS( A( K+1, J ) ) X 60 CONTINUE X DO 70 I = 1, N X VALUE = MAX( VALUE, WORK( I ) ) X 70 CONTINUE X ELSE X DO 80 I = 1, N X WORK( I ) = ZERO X 80 CONTINUE X DO 100 J = 1, N X SUM = WORK( J ) + ABS( A( 1, J ) ) X L = 1 - J X DO 90 I = J + 1, MIN( N, J+K ) X ABSA = ABS( A( L+I, J ) ) X SUM = SUM + ABSA X WORK( I ) = WORK( I ) + ABSA X 90 CONTINUE X VALUE = MAX( VALUE, SUM ) X 100 CONTINUE X END IF X ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN X* X* Find normF( A ). X* X SCALE = ZERO X SUM = ONE X IF( K.GT.0 ) THEN X IF( LSAME( UPLO, 'U' ) ) THEN X DO 110 J = 2, N X CALL DLASSQ( MIN( J-1, K ), A( MAX( K+2-J, 1 ), J ), X $ 1, SCALE, SUM ) X 110 CONTINUE X L = K + 1 X ELSE X DO 120 J = 1, N - 1 X CALL DLASSQ( MIN( N-J, K ), A( 2, J ), 1, SCALE, SUM ) X 120 CONTINUE X L = 1 X END IF X SUM = 2*SUM X ELSE X L = 1 X END IF X CALL DLASSQ( N, A( L, 1 ), LDA, SCALE, SUM ) X VALUE = SCALE*SQRT( SUM ) X END IF X* X DLANSB = VALUE X RETURN X* X* End of DLANSB X* X END END_OF_FILE if test 8026 -ne `wc -c <'dlansb.f'`; then echo shar: \"'dlansb.f'\" unpacked with wrong size! fi # end of 'dlansb.f' fi if test -f 'dlansp.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlansp.f'\" else echo shar: Extracting \"'dlansp.f'\" \(6929 characters\) sed "s/^X//" >'dlansp.f' <<'END_OF_FILE' X DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER NORM, UPLO X INTEGER N X* .. X* .. Array Arguments .. X DOUBLE PRECISION AP( * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DLANSP returns the value of the one norm, or the Frobenius norm, or X* the infinity norm, or the element of largest absolute value of a X* real symmetric matrix A, supplied in packed form. X* X* Description X* =========== X* X* DLANSP returns the value X* X* DLANSP = ( max( abs( a( i, j ) ) ) , NORM = 'M' or 'm' X* ( X* ( norm1( A ) , NORM = '1', 'O' or 'o' X* ( X* ( normI( A ) , NORM = 'I' or 'i' X* ( X* ( normF( A ) , NORM = 'F', 'f', 'E' or 'e' X* X* where norm1 denotes the one norm of a matrix (maximum column sum), X* normI denotes the infinity norm of a matrix (maximum row sum) and X* normF denotes the Frobenius norm of a matrix (square root of sum of X* squares). Note that max( abs( a( i, j ) ) ) is not a matrix norm. X* X* Parameters X* ========== X* X* NORM - CHARACTER*1 X* X* On entry, NORM specifies the value to be returned in DLANSP X* as described above. X* X* Not modified. X* X* UPLO - CHARACTER*1 X* X* On entry, UPLO specifies whether the upper or lower X* triangular part of the symmetric matrix A is supplied in the X* packed array AP as follows: X* X* UPLO = 'U' or 'u' The upper triangular part of A is X* supplied in AP. X* X* UPLO = 'L' or 'l' The lower triangular part of A is X* supplied in AP. X* X* Not modified. X* X* N - INTEGER X* X* On entry, N specifies the order of the matrix A. N must be X* at least zero. When N = 0 then DLANSP is set to zero and X* an immediate return is effected. X* X* Not modified. X* X* AP - DOUBLE PRECISION array, dimension( N*(N+1)/2 ) X* X* Before entry, with UPLO = 'U' or 'u', the array AP must X* contain the upper triangular part of the n by n symmetric X* matrix packed sequentially, column by column, so that X* AP( 1 ) contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain X* a( 1, 2 ) and a( 2, 2 ) respectively, and so on. X* Before entry, with UPLO = 'L' or 'l', the array AP must X* contain the lower triangular part of the n by n symmetric X* matrix packed sequentially, column by column, so that X* AP( 1 ) contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain X* a( 2, 1 ) and a( 3, 1 ) respectively, and so on. X* X* Not modified. X* X* WORK - DOUBLE PRECISION array, dimension( LWORK ), where LWORK X* must be at least N when NORM = '1' or 'O' or 'o' or 'I' or X* 'i'. X* X* When NORM = '1' or 'O' or 'o' or 'I' or 'i' then WORK is X* used as internal workspace, otherwise WORK is not X* referenced. X* X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, J, K X DOUBLE PRECISION ABSA, SCALE, SUM, VALUE X* .. X* .. External Subroutines .. X EXTERNAL DLASSQ X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, SQRT X* .. X* .. Executable Statements .. X* X IF( N.EQ.0 ) THEN X VALUE = ZERO X ELSE IF( LSAME( NORM, 'M' ) ) THEN X* X* Find max( abs( a( i, j ) ) ). X* X VALUE = ZERO X IF( LSAME( UPLO, 'U' ) ) THEN X K = 1 X DO 20 J = 1, N X DO 10 I = K, K + J - 1 X VALUE = MAX( VALUE, ABS( AP( I ) ) ) X 10 CONTINUE X K = K + J X 20 CONTINUE X ELSE X K = 1 X DO 40 J = 1, N X DO 30 I = K, K + N - J X VALUE = MAX( VALUE, ABS( AP( I ) ) ) X 30 CONTINUE X K = K + N - J + 1 X 40 CONTINUE X END IF X ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. X $ ( NORM.EQ.'1' ) ) THEN X* X* Find normI( A ) ( = norm1( A ), since A is symmetric). X* X VALUE = ZERO X K = 1 X IF( LSAME( UPLO, 'U' ) ) THEN X DO 60 J = 1, N X SUM = ZERO X DO 50 I = 1, J - 1 X ABSA = ABS( AP( K ) ) X SUM = SUM + ABSA X WORK( I ) = WORK( I ) + ABSA X K = K + 1 X 50 CONTINUE X WORK( J ) = SUM + ABS( AP( K ) ) X K = K + 1 X 60 CONTINUE X DO 70 I = 1, N X VALUE = MAX( VALUE, WORK( I ) ) X 70 CONTINUE X ELSE X DO 80 I = 1, N X WORK( I ) = ZERO X 80 CONTINUE X DO 100 J = 1, N X SUM = WORK( J ) + ABS( AP( K ) ) X K = K + 1 X DO 90 I = J + 1, N X ABSA = ABS( AP( K ) ) X SUM = SUM + ABSA X WORK( I ) = WORK( I ) + ABSA X K = K + 1 X 90 CONTINUE X VALUE = MAX( VALUE, SUM ) X 100 CONTINUE X END IF X ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN X* X* Find normF( A ). X* X SCALE = ZERO X SUM = ONE X K = 2 X IF( LSAME( UPLO, 'U' ) ) THEN X DO 110 J = 2, N X CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM ) X K = K + J X 110 CONTINUE X ELSE X DO 120 J = 1, N - 1 X CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM ) X K = K + N - J + 1 X 120 CONTINUE X END IF X SUM = 2*SUM X K = 1 X DO 130 I = 1, N X IF( AP( K ).NE.ZERO ) THEN X ABSA = ABS( AP( K ) ) X IF( SCALE.LT.ABSA ) THEN X SUM = ONE + SUM*( SCALE/ABSA )**2 X SCALE = ABSA X ELSE X SUM = SUM + ( ABSA/SCALE )**2 X END IF X END IF X IF( LSAME( UPLO, 'U' ) ) THEN X K = K + I + 1 X ELSE X K = K + N - I + 1 X END IF X 130 CONTINUE X VALUE = SCALE*SQRT( SUM ) X END IF X* X DLANSP = VALUE X RETURN X* X* End of DLANSP X* X END END_OF_FILE if test 6929 -ne `wc -c <'dlansp.f'`; then echo shar: \"'dlansp.f'\" unpacked with wrong size! fi # end of 'dlansp.f' fi if test -f 'dlansy.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlansy.f'\" else echo shar: Extracting \"'dlansy.f'\" \(6308 characters\) sed "s/^X//" >'dlansy.f' <<'END_OF_FILE' X DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER NORM, UPLO X INTEGER LDA, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DLANSY returns the value of the one norm, or the Frobenius norm, or X* the infinity norm, or the element of largest absolute value of a X* real symmetric matrix A. X* X* Description X* =========== X* X* DLANSY returns the value X* X* DLANSY = ( max( abs( a( i, j ) ) ) , NORM = 'M' or 'm' X* ( X* ( norm1( A ) , NORM = '1', 'O' or 'o' X* ( X* ( normI( A ) , NORM = 'I' or 'i' X* ( X* ( normF( A ) , NORM = 'F', 'f', 'E' or 'e' X* X* where norm1 denotes the one norm of a matrix (maximum column sum), X* normI denotes the infinity norm of a matrix (maximum row sum) and X* normF denotes the Frobenius norm of a matrix (square root of sum of X* squares). Note that max( abs( a( i, j ) ) ) is not a matrix norm. X* X* Parameters X* ========== X* X* NORM - CHARACTER*1 X* X* On entry, NORM specifies the value to be returned in DLANSY X* as described above. X* X* Not modified. X* X* UPLO - CHARACTER*1 X* X* On entry, UPLO specifies whether the upper or lower X* triangular part of the symmetric matrix A is to be X* referenced as follows: X* X* UPLO = 'U' or 'u' Only the upper triangular part of the X* symmetric matrix is to be referenced. X* X* UPLO = 'L' or 'l' Only the lower triangular part of the X* symmetric matrix is to be referenced. X* X* Not modified. X* X* N - INTEGER X* X* On entry, N specifies the order of the matrix A. N must be X* at least zero. When N = 0 then DLANSY is set to zero and X* an immediate return is effected. X* X* Not modified. X* X* A - DOUBLE PRECISION array, dimension( LDA, N ) X* X* Before entry, A must contain the n by n symmetric matrix for X* which DLANSY is required, such that when UPLO = 'U' or 'u' X* the n by n upper triangular part of the array A must contain X* the upper triangular part of the symmetric matrix and the X* strictly lower triangular part of A is not referenced, and X* when UPLO = 'L' or 'l' the n by n lower triangular part of X* the array A must contain the lower triangular part of the X* symmetric matrix and the strictly upper triangular part of A X* is not referenced X* X* Not modified. X* X* LDA - INTEGER X* X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least N. X* X* Not modified. X* X* WORK - DOUBLE PRECISION array, dimension( LWORK ), where LWORK X* must be at least N when NORM = '1' or 'O' or 'o' or 'I' or X* 'i'. X* X* When NORM = '1' or 'O' or 'o' or 'I' or 'i' then WORK is X* used as internal workspace, otherwise WORK is not X* referenced. X* X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, J X DOUBLE PRECISION ABSA, SCALE, SUM, VALUE X* .. X* .. External Subroutines .. X EXTERNAL DLASSQ X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, SQRT X* .. X* .. Executable Statements .. X* X IF( N.EQ.0 ) THEN X VALUE = ZERO X ELSE IF( LSAME( NORM, 'M' ) ) THEN X* X* Find max( abs( a( i, j ) ) ). X* X VALUE = ZERO X IF( LSAME( UPLO, 'U' ) ) THEN X DO 20 J = 1, N X DO 10 I = 1, J X VALUE = MAX( VALUE, ABS( A( I, J ) ) ) X 10 CONTINUE X 20 CONTINUE X ELSE X DO 40 J = 1, N X DO 30 I = J, N X VALUE = MAX( VALUE, ABS( A( I, J ) ) ) X 30 CONTINUE X 40 CONTINUE X END IF X ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. X $ ( NORM.EQ.'1' ) ) THEN X* X* Find normI( A ) ( = norm1( A ), since A is symmetric). X* X VALUE = ZERO X IF( LSAME( UPLO, 'U' ) ) THEN X DO 60 J = 1, N X SUM = ZERO X DO 50 I = 1, J - 1 X ABSA = ABS( A( I, J ) ) X SUM = SUM + ABSA X WORK( I ) = WORK( I ) + ABSA X 50 CONTINUE X WORK( J ) = SUM + ABS( A( J, J ) ) X 60 CONTINUE X DO 70 I = 1, N X VALUE = MAX( VALUE, WORK( I ) ) X 70 CONTINUE X ELSE X DO 80 I = 1, N X WORK( I ) = ZERO X 80 CONTINUE X DO 100 J = 1, N X SUM = WORK( J ) + ABS( A( J, J ) ) X DO 90 I = J + 1, N X ABSA = ABS( A( I, J ) ) X SUM = SUM + ABSA X WORK( I ) = WORK( I ) + ABSA X 90 CONTINUE X VALUE = MAX( VALUE, SUM ) X 100 CONTINUE X END IF X ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN X* X* Find normF( A ). X* X SCALE = ZERO X SUM = ONE X IF( LSAME( UPLO, 'U' ) ) THEN X DO 110 J = 2, N X CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) X 110 CONTINUE X ELSE X DO 120 J = 1, N - 1 X CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) X 120 CONTINUE X END IF X SUM = 2*SUM X CALL DLASSQ( N, A, LDA+1, SCALE, SUM ) X VALUE = SCALE*SQRT( SUM ) X END IF X* X DLANSY = VALUE X RETURN X* X* End of DLANSY X* X END END_OF_FILE if test 6308 -ne `wc -c <'dlansy.f'`; then echo shar: \"'dlansy.f'\" unpacked with wrong size! fi # end of 'dlansy.f' fi if test -f 'dlapy2.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlapy2.f'\" else echo shar: Extracting \"'dlapy2.f'\" \(1322 characters\) sed "s/^X//" >'dlapy2.f' <<'END_OF_FILE' X DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* May 24, 1990 X* X* .. Scalar Arguments .. X DOUBLE PRECISION X, Y X* .. X* X* Purpose X* ======= X* X* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause X* unnecessary overflow. X* X* Arguments X* ========= X* X* X (input) DOUBLE PRECISION X* Y (input) DOUBLE PRECISION X* X and Y specify the values x and y. X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE X PARAMETER ( ZERO = 0.0D0, ONE = 1.0D+0 ) X* .. X* .. Local Scalars .. X DOUBLE PRECISION XABS, YABS X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS, SQRT X* .. X* .. Executable Statements .. X* X XABS = ABS( X ) X YABS = ABS( Y ) X IF( XABS.GE.YABS ) THEN X IF( YABS.GT.ZERO ) THEN X DLAPY2 = XABS*SQRT( ONE+( YABS/XABS )**2 ) X ELSE X DLAPY2 = XABS X END IF X ELSE X IF( XABS.GT.ZERO ) THEN X DLAPY2 = YABS*SQRT( ONE+( XABS/YABS )**2 ) X ELSE X DLAPY2 = YABS X END IF X END IF X RETURN X* X* End of DLAPY2 X* X END END_OF_FILE if test 1322 -ne `wc -c <'dlapy2.f'`; then echo shar: \"'dlapy2.f'\" unpacked with wrong size! fi # end of 'dlapy2.f' fi if test -f 'dlaran.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlaran.f'\" else echo shar: Extracting \"'dlaran.f'\" \(3035 characters\) sed "s/^X//" >'dlaran.f' <<'END_OF_FILE' X DOUBLE PRECISION FUNCTION DLARAN( ISEED ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Array Arguments .. X INTEGER ISEED( 4 ) X* .. X* X* Purpose X* ======= X* X* ISEED generates and returns random numbers uniformly distributed X* between 0. and 1. A linear congruential sequence is used. X* X* This code is machine independent provided 12 bit integers can be X* added and multiplied to produce 24 bit answers. Note that ISEED(4) X* must be odd. X* X* Arguments X* ========= X* X* ISEED (input/output) INTEGER array, dimension (4) X* On entry, the seed of the random number generator. The array X* elements should be between 0 and 4095; if not they will be X* reduced mod 4096. Also, ISEED(4) must be odd. The random X* number generator uses a linear congruential sequence limited X* to small integers, and so should produce machine independent X* random numbers. X* On exit, ISEED is changed so that the next call will generate X* a different number. X* X* X* .. Parameters .. X INTEGER M1 X PARAMETER ( M1 = 502 ) X INTEGER M2 X PARAMETER ( M2 = 1521 ) X INTEGER M3 X PARAMETER ( M3 = 4071 ) X INTEGER M4 X PARAMETER ( M4 = 2107 ) X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D0 ) X DOUBLE PRECISION T12 X PARAMETER ( T12 = 4096.0D0 ) X* .. X* .. Local Scalars .. X INTEGER I1, I2, I3, I4 X DOUBLE PRECISION R X* .. X* .. Intrinsic Functions .. X INTRINSIC DBLE, MOD X* .. X* .. Executable Statements .. X* X* The following is just multiplication of two 48-bit X* fixed-point numbers, each of which is represented by 4 12-bit X* pieces. The constant, "M", is represented by M1 throught M4, X* M1 being the high-order part, and the variable ISEED is X* represented by ISEED(1) through ISEED(4), ISEED(1) being the X* high-order part. The binary point can be thought of as X* lying between M1 and M2, and between ISEED(1) and ISEED(2). X* X* The code is thus ISEED = MOD( M * ISEED , 4096 ) X* X I1 = ISEED( 1 )*M4 + ISEED( 2 )*M3 + ISEED( 3 )*M2 + ISEED( 4 )*M1 X I2 = ISEED( 2 )*M4 + ISEED( 3 )*M3 + ISEED( 4 )*M2 X I3 = ISEED( 3 )*M4 + ISEED( 4 )*M3 X I4 = ISEED( 4 )*M4 X ISEED( 4 ) = MOD( I4, 4096 ) X I3 = I3 + I4 / 4096 X ISEED( 3 ) = MOD( I3, 4096 ) X I2 = I2 + I3 / 4096 X ISEED( 2 ) = MOD( I2, 4096 ) X ISEED( 1 ) = MOD( I1+I2/4096, 4096 ) X* X* Compute DLARAN = ISEED / 4096.0 X* X R = ONE / T12 X DLARAN = R*( DBLE( ISEED( 1 ) )+R* X $ ( DBLE( ISEED( 2 ) )+R*( DBLE( ISEED( 3 ) )+R* X $ ( DBLE( ISEED( 4 ) ) ) ) ) ) X RETURN X* X* End of DLARAN X* X END END_OF_FILE if test 3035 -ne `wc -c <'dlaran.f'`; then echo shar: \"'dlaran.f'\" unpacked with wrong size! fi # end of 'dlaran.f' fi if test -f 'dlarf.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlarf.f'\" else echo shar: Extracting \"'dlarf.f'\" \(3110 characters\) sed "s/^X//" >'dlarf.f' <<'END_OF_FILE' X SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER SIDE X INTEGER INCV, LDC, M, N X DOUBLE PRECISION TAU X* .. X* .. Array Arguments .. X DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DLARF applies a real elementary reflector H to a real m by n matrix X* C, from either the left or the right. H is represented in the form X* X* H = I - tau * v * v' X* X* where tau is a real scalar and v is a real vector. X* X* If tau = 0, then H is taken to be the unit matrix. X* X* Arguments X* ========= X* X* SIDE (input) CHARACTER*1 X* = 'L': form H * C X* = 'R': form C * H X* X* M (input) INTEGER X* The number of rows of the matrix C. X* X* N (input) INTEGER X* The number of columns of the matrix C. X* X* V (input) DOUBLE PRECISION array, dimension X* (1 + (M-1)*abs(INCV)) if SIDE = 'L' X* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' X* The vector v in the representation of H. V is not used if X* TAU = 0. X* X* INCV (input) INTEGER X* The increment between elements of v. INCV <> 0. X* X* TAU (input) DOUBLE PRECISION X* The value tau in the representation of H. X* X* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) X* On entry, the m by n matrix C. X* On exit, C is overwritten by the matrix H * C if SIDE = 'L', X* or C * H if SIDE = 'R'. X* X* LDC (input) INTEGER X* The leading dimension of the array C. LDA >= M. X* X* WORK (workspace) DOUBLE PRECISION array, dimension X* (N) if SIDE = 'L' X* or (M) if SIDE = 'R' X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. External Subroutines .. X EXTERNAL DGEMV, DGER X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. Executable Statements .. X* X IF( LSAME( SIDE, 'L' ) ) THEN X* X* Form H * C X* X IF( TAU.NE.ZERO ) THEN X* X* w := C' * v X* X CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO, X $ WORK, 1 ) X* X* C := C - v * w' X* X CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) X END IF X ELSE X* X* Form C * H X* X IF( TAU.NE.ZERO ) THEN X* X* w := C * v X* X CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, X $ ZERO, WORK, 1 ) X* X* C := C - w * v' X* X CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) X END IF X END IF X RETURN X* X* End of DLARF X* X END END_OF_FILE if test 3110 -ne `wc -c <'dlarf.f'`; then echo shar: \"'dlarf.f'\" unpacked with wrong size! fi # end of 'dlarf.f' fi if test -f 'dlarfg.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlarfg.f'\" else echo shar: Extracting \"'dlarfg.f'\" \(2520 characters\) sed "s/^X//" >'dlarfg.f' <<'END_OF_FILE' X SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X INTEGER INCX, N X DOUBLE PRECISION ALPHA, TAU X* .. X* .. Array Arguments .. X DOUBLE PRECISION X( * ) X* .. X* X* Purpose X* ======= X* X* DLARFG generates a real elementary reflector H of order n, such X* that X* X* H * ( alpha ) = ( beta ), H' * H = I. X* ( x ) ( 0 ) X* X* where alpha and beta are scalars, and x is an (n-1)-element real X* vector. H is represented in the form X* X* H = I - tau * ( 1 ) * ( 1 v' ) , X* ( v ) X* X* where tau is a real scalar and v is a real (n-1)-element X* vector. X* X* If the elements of x are all zero, then tau = 0 and H is taken to be X* the unit matrix. X* X* Arguments X* ========= X* X* N (input) INTEGER X* The order of the elementary reflector. X* X* ALPHA (input/output) DOUBLE PRECISION X* On entry, the value alpha. X* On exit, it is overwritten with the value beta. X* X* X (input/output) DOUBLE PRECISION array, dimension X* (1+(N-2)*abs(INCX)) X* On entry, the vector x. X* On exit, it is overwritten with the vector v. X* X* INCX (input) INTEGER X* The increment between elements of X. INCX <> 0. X* X* TAU (output) DOUBLE PRECISION X* The value tau. X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X DOUBLE PRECISION BETA, XNORM X* .. X* .. External Functions .. X DOUBLE PRECISION DLAPY2, DNRM2 X EXTERNAL DLAPY2, DNRM2 X* .. X* .. Intrinsic Functions .. X INTRINSIC SIGN X* .. X* .. External Subroutines .. X EXTERNAL DSCAL X* .. X* .. Executable Statements .. X* X XNORM = DNRM2( N-1, X, INCX ) X IF( XNORM.EQ.ZERO ) THEN X* X* H = I X* X TAU = ZERO X ELSE X* X* general case X* X BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) X TAU = ( BETA-ALPHA ) / BETA X CALL DSCAL( N-1, ONE/( ALPHA-BETA ), X, INCX ) X ALPHA = BETA X END IF X* X RETURN X* X* End of DLARFG X* X END END_OF_FILE if test 2520 -ne `wc -c <'dlarfg.f'`; then echo shar: \"'dlarfg.f'\" unpacked with wrong size! fi # end of 'dlarfg.f' fi if test -f 'dlarfy.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlarfy.f'\" else echo shar: Extracting \"'dlarfy.f'\" \(3052 characters\) sed "s/^X//" >'dlarfy.f' <<'END_OF_FILE' X SUBROUTINE DLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) X* X* -- LAPACK auxiliary test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER UPLO X INTEGER INCV, LDC, N X DOUBLE PRECISION TAU X* .. X* .. Array Arguments .. X DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DLARFY applies an elementary reflector, or Householder matrix, H, X* to an n x n symmetric matrix C, from both the left and the right. X* X* H is represented in the form X* X* H = I - tau * v * v' X* X* where tau is a scalar and v is a vector. X* X* If tau is zero, then H is taken to be the unit matrix. X* X* Arguments X* ========= X* X* UPLO - CHARACTER*1 X* On entry, UPLO specifies whether the upper or lower X* triangular part of the symmetric matrix C is stored: X* UPLO = 'U' or 'u' Upper triangle of C is stored X* UPLO = 'L' or 'l' Lower triangle of C is stored X* Not modified. X* X* N - INTEGER X* On entry, N specifies the number of rows and columns of the X* matrix C. N must be at least zero. X* Not modified. X* X* V - DOUBLE PRECISION array of dimension at least X* ( 1 + (N-1)*abs(INCV) ) X* On entry, V must contain the vector v. X* Not modified. X* X* INCV - INTEGER X* On entry, INCV specifies the increment for the elements of X* V. INCV must not be zero. X* Not modified. X* X* TAU - DOUBLE PRECISION X* On entry, TAU specifies the value tau. X* Not modified. X* X* C - DOUBLE PRECISION array of dimension( LDC, N ) X* On entry, C must contain the matrix C. X* On exit, it is overwritten by H * C (or C * H). X* X* LDC - INTEGER X* On entry, LDC specifies the first dimension of the array C. X* LDC must be at least max( 1, N ). X* Not modified. X* X* WORK - DOUBLE PRECISION array of dimension( N ) X* Used as workspace. X* X* X* .. Parameters .. X DOUBLE PRECISION ONE, ZERO, HALF X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, HALF = 0.5D+0 ) X* .. X* .. Local Scalars .. X DOUBLE PRECISION ALPHA X* .. X* .. External Subroutines .. X EXTERNAL DAXPY, DSYMV, DSYR2 X* .. X* .. External Functions .. X DOUBLE PRECISION DDOT X EXTERNAL DDOT X* .. X* .. Executable Statements .. X* X IF( TAU.EQ.ZERO ) X $ RETURN X* X* Form w:= C * v X* X CALL DSYMV( UPLO, N, ONE, C, LDC, V, INCV, ZERO, WORK, 1 ) X* X ALPHA = -HALF*TAU*DDOT( N, WORK, 1, V, INCV ) X CALL DAXPY( N, ALPHA, V, INCV, WORK, 1 ) X* X* C := C - v * w' - w * v' X* X CALL DSYR2( UPLO, N, -TAU, V, INCV, WORK, 1, C, LDC ) X* X RETURN X* X* End of DLARFY X* X END END_OF_FILE if test 3052 -ne `wc -c <'dlarfy.f'`; then echo shar: \"'dlarfy.f'\" unpacked with wrong size! fi # end of 'dlarfy.f' fi if test -f 'dlarnd.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlarnd.f'\" else echo shar: Extracting \"'dlarnd.f'\" \(2545 characters\) sed "s/^X//" >'dlarnd.f' <<'END_OF_FILE' X DOUBLE PRECISION FUNCTION DLARND( IDIST, ISEED ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X INTEGER IDIST X* .. X* .. Array Arguments .. X INTEGER ISEED( 4 ) X* .. X* X* Purpose X* ======= X* X* DLARND returns a random number from the distribution determined by X* IDIST. It uses DLARAN to get random numbers in (0,1). If IDIST=3 X* and DLARAN returns 0, DLARND will also return 0. X* X* Arguments X* ========= X* X* IDIST (input) INTEGER X* Specifies the type of distribution to be used to generate the X* random matrix: X* = 1: UNIFORM( 0, 1 ) X* = 2: UNIFORM( -1, 1 ) X* = 3: NORMAL ( 0, 1 ) X* X* ISEED (input) INTEGER array, dimension( 4 ) X* Specifies the seed of the random number generator. The array X* elements should be between 0 and 4095; if not they will be X* reduced mod 4096. Also, ISEED(4) must be odd. X* X* Further Details X* ======= ======= X* X* The random number generator uses a linear congruential sequence X* limited to small integers, and so should produce machine independent X* random numbers. The values of ISEED are changed on exit, and can be X* used in the next call to DLARND to continue the same random number X* sequence. X* X* X* .. Parameters .. X DOUBLE PRECISION PI X PARAMETER ( PI = 3.14159265358979311599796D+00 ) X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D0 ) X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D0 ) X DOUBLE PRECISION TWO X PARAMETER ( TWO = 2.0D0 ) X* .. X* .. Local Scalars .. X DOUBLE PRECISION RAN1, RAN2 X* .. X* .. External Functions .. X DOUBLE PRECISION DLARAN X EXTERNAL DLARAN X* .. X* .. Intrinsic Functions .. X INTRINSIC COS, LOG, SQRT X* .. X* .. Executable Statements .. X* X RAN1 = DLARAN( ISEED ) X IF( IDIST.EQ.1 ) THEN X DLARND = RAN1 X ELSE IF( IDIST.EQ.2 ) THEN X DLARND = TWO*RAN1 - ONE X ELSE IF( IDIST.EQ.3 ) THEN X* X RAN2 = DLARAN( ISEED ) X IF( RAN1.NE.ZERO .AND. RAN2.NE.ZERO ) THEN X DLARND = SQRT( -TWO*LOG( RAN1 ) )*COS( TWO*PI*RAN2 ) X ELSE X DLARND = ZERO X END IF X* X END IF X RETURN X* X* End of DLARND X* X END END_OF_FILE if test 2545 -ne `wc -c <'dlarnd.f'`; then echo shar: \"'dlarnd.f'\" unpacked with wrong size! fi # end of 'dlarnd.f' fi if test -f 'dlaror.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlaror.f'\" else echo shar: Extracting \"'dlaror.f'\" \(8370 characters\) sed "s/^X//" >'dlaror.f' <<'END_OF_FILE' X SUBROUTINE DLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) X* X* -- LAPACK auxiliary test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER INIT, SIDE X INTEGER INFO, LDA, M, N X* .. X* .. Array Arguments .. X INTEGER ISEED( 4 ) X DOUBLE PRECISION A( LDA, * ), X( * ) X* .. X* X* Purpose X* ======= X* X* DLAROR pre- or post-multiplies an M by N matrix A by a random X* orthogonal matrix U, overwriting A. A may optionally be X* initialized to the identity matrix before multiplying by U. X* U is generated using the method of G.W. Stewart X* ( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ). X* X* (BLAS-2 version) X* X* Arguments X* ========= X* X* SIDE - CHARACTER*1 X* SIDE specifies whether A is multiplied on the left or right X* by U. X* SIDE = 'L' Multiply A on the left (premultiply) by U X* SIDE = 'R' Multiply A on the right (postmultiply) by U' X* SIDE = 'C' or 'T' Multiply A on the left by U and the right X* by U' (Here, U' means U-transpose.) X* Not modified. X* X* INIT - CHARACTER*1 X* INIT specifies whether or not A should be initialized to X* the identity matrix. X* INIT = 'I' Initialize A to (a section of) the X* identity matrix before applying U. X* INIT = 'N' No initialization. Apply U to the X* input matrix A. X* X* INIT = 'I' may be used to generate square or rectangular X* orthogonal matrices: X* For square matrices, M=N, and SIDE many be either 'L' or X* 'R'; the rows will be orthogonal to each other, as will the X* columns. X* For rectangular matrices where M < N, SIDE = 'R' will X* produce a dense matrix whose rows will be orthogonal and X* whose columns will not, while SIDE = 'L' will produce a X* matrix whose rows will be orthogonal, and whose first M X* columns will be orthogonal, the remaining columns being X* zero. X* For matrices where M > N, just use the previous X* explaination, interchanging 'L' and 'R' and "rows" and X* "columns". X* X* Not modified. X* X* M - INTEGER X* Number of rows of A. Not modified. X* X* N - INTEGER X* Number of columns of A. Not modified. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, N ) X* Input array. Overwritten by U A ( if SIDE = 'L' ) X* or by A U ( if SIDE = 'R' ) X* or by U A U' ( if SIDE = 'C' or 'T') on exit. X* X* LDA - INTEGER X* Leading dimension of A. Must be at least MAX ( 1, M ). X* Not modified. X* X* ISEED - INTEGER array of dimension ( 4 ) X* On entry ISEED specifies the seed of the random number X* generator. The array elements should be between 0 and 4095; X* if not they will be reduced mod 4096. Also, ISEED(4) must X* be odd. The random number generator uses a linear X* congruential sequence limited to small integers, and so X* should produce machine independent random numbers. The X* values of ISEED are changed on exit, and can be used in the X* next call to DLAROR to continue the same random number X* sequence. X* Modified. X* X* X - DOUBLE PRECISION array of DIMENSION ( 3*MAX( M, N ) ) X* Workspace. Of length: X* 2*M + N if SIDE = 'L', X* 2*N + M if SIDE = 'R', X* 3*N if SIDE = 'C' or 'T'. X* Modified. X* X* INFO - INTEGER X* An error flag. It is set to: X* 0 if no error. X* 1 if the random numbers generated by DLARND are bad. X* -1 if SIDE is not L, R, C, or T. X* -3 if M is negative. X* -4 if N is negative or if SIDE is C or T and N is not equal X* to M. X* -6 if LDA is less than M. X* X*----------------------------------------------------------------------- X* X* .. Parameters .. X* X DOUBLE PRECISION ZERO, ONE, TOOSML X PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, X $ TOOSML = 1.0D-20 ) X* .. X* X* .. Local Scalars .. X* X INTEGER IROW, ITYPE, IXFRM, J, JCOL, KBEG, NXFRM X DOUBLE PRECISION FACTOR, XNORM, XNORMS X* .. X* X* .. External Functions .. X* X LOGICAL LSAME X DOUBLE PRECISION DLARND, DNRM2 X EXTERNAL LSAME, DLARND, DNRM2 X* .. X* X* .. External Subroutines .. X* X EXTERNAL DGEMV, DGER, DLAZRO, DSCAL, XERBLA X* .. X* X* .. Intrinsic Functions .. X* X INTRINSIC ABS, SIGN X* .. X* X*----------------------------------------------------------------------- X* X* .. Executable Statements .. X* X IF( N.EQ.0 .OR. M.EQ.0 ) X $ RETURN X* X ITYPE = 0 X IF( LSAME( SIDE, 'L' ) ) THEN X ITYPE = 1 X ELSE IF( LSAME( SIDE, 'R' ) ) THEN X ITYPE = 2 X ELSE IF( LSAME( SIDE, 'C' ) .OR. LSAME( SIDE, 'T' ) ) THEN X ITYPE = 3 X END IF X* X* Check for argument errors. X* X INFO = 0 X IF( ITYPE.EQ.0 ) THEN X INFO = -1 X ELSE IF( M.LT.0 ) THEN X INFO = -3 X ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.3 .AND. N.NE.M ) ) THEN X INFO = -4 X ELSE IF( LDA.LT.M ) THEN X INFO = -6 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DLAROR', -INFO ) X RETURN X END IF X* X* X* X IF( ITYPE.EQ.1 ) THEN X NXFRM = M X ELSE X NXFRM = N X END IF X* X* Initialize A to the identity matrix if desired X* X IF( LSAME( INIT, 'I' ) ) X $ CALL DLAZRO( M, N, ZERO, ONE, A, LDA ) X* X* If no rotation possible, multiply by random +/-1 X* X*....................................................................... X* X* X* 2) Compute Rotation by computing Householder X* Transformations H(2), H(3), ..., H(nhouse) X* X* X DO 10 J = 1, NXFRM X X( J ) = ZERO X 10 CONTINUE X* X* X DO 30 IXFRM = 2, NXFRM X KBEG = NXFRM - IXFRM + 1 X* X* Generate independent normal( 0, 1 ) random numbers X* X DO 20 J = KBEG, NXFRM X X( J ) = DLARND( 3, ISEED ) X 20 CONTINUE X* X* Generate a Householder transformation from the random vector X X* X XNORM = DNRM2( IXFRM, X( KBEG ), 1 ) X XNORMS = SIGN( XNORM, X( KBEG ) ) X X( KBEG+NXFRM ) = SIGN( ONE, -X( KBEG ) ) X FACTOR = XNORMS*( XNORMS+X( KBEG ) ) X IF( ABS( FACTOR ).LT.TOOSML ) THEN X INFO = 1 X CALL XERBLA( 'DLAROR', -INFO ) X RETURN X ELSE X FACTOR = ONE / FACTOR X END IF X X( KBEG ) = X( KBEG ) + XNORMS X* X* Apply Householder transformation to A X* X IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 ) THEN X* X* Apply H(k) from the left. X* X CALL DGEMV( 'T', IXFRM, N, ONE, A( KBEG, 1 ), LDA, X $ X( KBEG ), 1, ZERO, X( 2*NXFRM+1 ), 1 ) X CALL DGER( IXFRM, N, -FACTOR, X( KBEG ), 1, X( 2*NXFRM+1 ), X $ 1, A( KBEG, 1 ), LDA ) X* X END IF X* X IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN X* X* Apply H(k) from the right. X* X CALL DGEMV( 'N', M, IXFRM, ONE, A( 1, KBEG ), LDA, X $ X( KBEG ), 1, ZERO, X( 2*NXFRM+1 ), 1 ) X CALL DGER( M, IXFRM, -FACTOR, X( 2*NXFRM+1 ), 1, X( KBEG ), X $ 1, A( 1, KBEG ), LDA ) X* X END IF X 30 CONTINUE X* X X( 2*NXFRM ) = SIGN( ONE, DLARND( 3, ISEED ) ) X* X*....................................................................... X* X* Scale the matrix A by D. X* X IF( ITYPE.EQ.1 .OR. ITYPE.EQ.3 ) THEN X DO 40 IROW = 1, M X CALL DSCAL( N, X( NXFRM+IROW ), A( IROW, 1 ), LDA ) X 40 CONTINUE X END IF X* X IF( ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN X DO 50 JCOL = 1, N X CALL DSCAL( M, X( NXFRM+JCOL ), A( 1, JCOL ), 1 ) X 50 CONTINUE X END IF X RETURN X* X* End of DLAROR X* X END END_OF_FILE if test 8370 -ne `wc -c <'dlaror.f'`; then echo shar: \"'dlaror.f'\" unpacked with wrong size! fi # end of 'dlaror.f' fi if test -f 'dlarot.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlarot.f'\" else echo shar: Extracting \"'dlarot.f'\" \(9667 characters\) sed "s/^X//" >'dlarot.f' <<'END_OF_FILE' X SUBROUTINE DLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, X $ XRIGHT ) X* X* -- LAPACK auxiliary test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X LOGICAL LLEFT, LRIGHT, LROWS X INTEGER LDA, NL X DOUBLE PRECISION C, S, XLEFT, XRIGHT X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( * ) X* .. X* X* Purpose X* ======= X* X* DLAROT applies a (Givens) rotation to two adjacent rows or X* columns, where one element of the first and/or last column/row X* may be a separate variable. This is specifically indended X* for use on matrices stored in some format other than GE, so X* that elements of the matrix may be used or modified for which X* no array element is provided. X* X* One example is a symmetric matrix in SB format (bandwidth=4), for X* which UPLO='L': Two adjacent rows will have the format: X* X* row j: * * * * * . . . . X* row j+1: * * * * * . . . . X* X* '*' indicates elements for which storage is provided, X* '.' indicates elements for which no storage is provided, but X* are not necessarily zero; their values are determined by X* symmetry. ' ' indicates elements which are necessarily zero, X* and have no storage provided. X* X* Those columns which have two '*'s can be handled by DROT. X* Those columns which have no '*'s can be ignored, since as long X* as the Givens rotations are carefully applied to preserve X* symmetry, their values are determined. X* Those columns which have one '*' have to be handled separately, X* by using separate variables "p" and "q": X* X* row j: * * * * * p . . . X* row j+1: q * * * * * . . . . X* X* The element p would have to be set correctly, then that column X* is rotated, setting p to its new value. The next call to X* DLAROT would rotate columns j and j+1, using p, and restore X* symmetry. The element q would start out being zero, and be X* made non-zero by the rotation. Later, rotations would presumably X* be chosen to zero q out. X* X* X* Typical Calling Sequences: rotating the i-th and (i+1)-st rows. X* ------- ------- --------- X* X* General dense matrix: X* X* CALL DLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, X* A(i,1),LDA, DUMMY, DUMMY) X* X* General banded matrix in GB format: X* X* j = MAX(1, i-KL ) X* NL = MIN( N, i+KU+1 ) + 1-j X* CALL DLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, X* A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) X* X* [ note that i+1-j is just MIN(i,KL+1) ] X* X* Symmetric banded matrix in SY format, bandwidth K, X* lower triangle only: X* X* j = MAX(1, i-K ) X* NL = MIN( K+1, i ) + 1 X* CALL DLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, X* A(i,j), LDA, XLEFT, XRIGHT ) X* X* Same, but upper triangle only: X* X* NL = MIN( K+1, N-i ) + 1 X* CALL DLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, X* A(i,i), LDA, XLEFT, XRIGHT ) X* X* Symmetric banded matrix in SB format, bandwidth K, X* lower triangle only: X* X* [ same as for SY, except:] X* . . . . X* A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) X* X* [ note that i+1-j is just MIN(i,K+1) ] X* X* Same, but upper triangle only: X* . . . X* A(K+1,i), LDA-1, XLEFT, XRIGHT ) X* X* X* Rotating columns is just the transpose of rotating rows, except X* for GB and SB: (rotating columns i and i+1) X* X* GB: X* j = MAX(1, i-KU ) X* NL = MIN( N, i+KL+1 ) + 1-j X* CALL DLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, X* A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) X* X* [note that KU+j+1-i is just MAX(1,KU+2-i)] X* X* SB: (upper triangle) X* X* . . . . . . X* A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) X* X* SB: (lower triangle) X* X* . . . . . . X* A(1,i),LDA-1, XTOP, XBOTTM ) X* X* X* X* Arguments X* ========= X* X* LROWS - LOGICAL X* If .TRUE., then DLAROT will rotate two rows. If .FALSE., X* then it will rotate two columns. X* Not modified. X* X* LLEFT - LOGICAL X* If .TRUE., then XLEFT will be used instead of the X* corresponding element of A for the first element in the X* second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) X* If .FALSE., then the corresponding element of A will be X* used. X* Not modified. X* X* LRIGHT - LOGICAL X* If .TRUE., then XRIGHT will be used instead of the X* corresponding element of A for the last element in the X* first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If X* .FALSE., then the corresponding element of A will be used. X* Not modified. X* X* NL - INTEGER X* The length of the rows (if LROWS=.TRUE.) or columns (if X* LROWS=.FALSE.) to be rotated. If XLEFT and/or XRIGHT are X* used, the columns/rows they are in should be included in X* NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at X* least 2. The number of rows/columns to be rotated X* exclusive of those involving XLEFT and/or XRIGHT may X* not be negative, i.e., NL minus how many of LLEFT and X* LRIGHT are .TRUE. must be at least zero; if not, XERBLA X* will be called. X* Not modified. X* X* C, S - DOUBLE PRECISION X* Specify the Givens rotation to be applied. If LROWS is X* true, then the matrix ( c s ) X* (-s c ) is applied from the left; X* if false, then the transpose thereof is applied from the X* right. For a Givens rotation, C**2 + S**2 should be 1, X* but this is not checked. X* Not modified. X* X* A - DOUBLE PRECISION array. X* The array containing the rows/columns to be rotated. The X* first element of A should be the upper left element to X* be rotated. X* Read and modified. X* X* LDA - INTEGER X* The "effective" leading dimension of A. If A contains X* a matrix stored in GE or SY format, then this is just X* the leading dimension of A as dimensioned in the calling X* routine. If A contains a matrix stored in band (GB or SB) X* format, then this should be *one less* than the leading X* dimension used in the calling routine. Thus, if X* A were dimensioned A(LDA,*) in DLAROT, then A(1,j) would X* be the j-th element in the first of the two rows X* to be rotated, and A(2,j) would be the j-th in the second, X* regardless of how the array may be stored in the calling X* routine. [A cannot, however, actually be dimensioned thus, X* since for band format, the row number may exceed LDA, which X* is not legal FORTRAN.] X* If LROWS=.TRUE., then LDA must be at least 1, otherwise X* it must be at least NL minus the number of .TRUE. values X* in XLEFT and XRIGHT. X* Not modified. X* X* XLEFT - DOUBLE PRECISION X* If LLEFT is .TRUE., then XLEFT will be used and modified X* instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) X* (if LROWS=.FALSE.). X* Read and modified. X* X* XRIGHT - DOUBLE PRECISION X* If LRIGHT is .TRUE., then XRIGHT will be used and modified X* instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) X* (if LROWS=.FALSE.). X* Read and modified. X* X* X*----------------------------------------------------------------------- X* X* X* .. Local Scalars .. X* X INTEGER IINC, INEXT, IX, IY, IYT, NT X* .. X* X* .. Local Arrays .. X* X DOUBLE PRECISION XT( 2 ), YT( 2 ) X* .. X* X* .. External Subroutines .. X* X EXTERNAL DROT, XERBLA X* .. X* X*----------------------------------------------------------------------- X* X* .. Executable Statements .. X* X* X* Set up indices, arrays for ends X* X* X IF( LROWS ) THEN X IINC = LDA X INEXT = 1 X ELSE X IINC = 1 X INEXT = LDA X END IF X* X IF( LLEFT ) THEN X NT = 1 X IX = 1 + IINC X IY = 2 + LDA X XT( 1 ) = A( 1 ) X YT( 1 ) = XLEFT X ELSE X NT = 0 X IX = 1 X IY = 1 + INEXT X END IF X* X IF( LRIGHT ) THEN X IYT = 1 + INEXT + ( NL-1 )*IINC X NT = NT + 1 X XT( NT ) = XRIGHT X YT( NT ) = A( IYT ) X END IF X* X* Check for errors X* X IF( NL.LT.NT ) THEN X CALL XERBLA( 'DLAROT', 4 ) X RETURN X END IF X IF( LDA.LE.0 .OR. ( .NOT.LROWS .AND. LDA.LT.NL-NT ) ) THEN X CALL XERBLA( 'DLAROT', 8 ) X RETURN X END IF X* X* Rotate X* X CALL DROT( NL-NT, A( IX ), IINC, A( IY ), IINC, C, S ) X CALL DROT( NT, XT, 1, YT, 1, C, S ) X* X* Stuff values back into XLEFT, XRIGHT, etc. X* X IF( LLEFT ) THEN X A( 1 ) = XT( 1 ) X XLEFT = YT( 1 ) X END IF X* X IF( LRIGHT ) THEN X XRIGHT = XT( NT ) X A( IYT ) = YT( NT ) X END IF X* X RETURN X* X* End of DLAROT X* X END END_OF_FILE if test 9667 -ne `wc -c <'dlarot.f'`; then echo shar: \"'dlarot.f'\" unpacked with wrong size! fi # end of 'dlarot.f' fi if test -f 'dlartg.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlartg.f'\" else echo shar: Extracting \"'dlartg.f'\" \(2369 characters\) sed "s/^X//" >'dlartg.f' <<'END_OF_FILE' X SUBROUTINE DLARTG( F, G, CS, SN, R ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X DOUBLE PRECISION CS, F, G, R, SN X* .. X* X* Purpose X* ======= X* X* Generate a plane rotation so that X* X* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. X* [ -SN CS ] [ G ] [ 0 ] X* X* This is a faster version of the BLAS1 routine DROTG, except for X* the following differences: X* F and G are unchanged on return. X* If G=0, then CS=1 and SN=0. X* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any X* floating point operations (saves work in DBDSQR when X* there are zeros on the diagonal). X* X* Arguments X* ========= X* X* F - DOUBLE PRECISION X* On input, the first component of vector to be rotated. X* Unchanged on output. X* X* G - DOUBLE PRECISION X* On input, the second component of vector to be rotated. X* Unchanged on output. X* X* CS - DOUBLE PRECISION X* On output, the cosine of the rotation. X* X* SN - DOUBLE PRECISION X* On output, the sine of the rotation. X* X* R - DOUBLE PRECISION X* On output, the nonzero component of the rotated vector. X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D0 ) X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D0 ) X* .. X* X* .. Local Scalars .. X DOUBLE PRECISION T, TT X* .. X* X* .. Intrinsic Functions .. X INTRINSIC ABS, SQRT X* .. X* X* .. Executable Statements .. X* X IF( F.EQ.ZERO ) THEN X IF( G.EQ.ZERO ) THEN X CS = ONE X SN = ZERO X R = ZERO X ELSE X CS = ZERO X SN = ONE X R = G X END IF X ELSE X IF( ABS( F ).GT.ABS( G ) ) THEN X T = G / F X TT = SQRT( ONE+T*T ) X CS = ONE / TT X SN = T*CS X R = F*TT X ELSE X T = F / G X TT = SQRT( ONE+T*T ) X SN = ONE / TT X CS = T*SN X R = G*TT X END IF X END IF X RETURN X* X* End of DLARTG X* X END END_OF_FILE if test 2369 -ne `wc -c <'dlartg.f'`; then echo shar: \"'dlartg.f'\" unpacked with wrong size! fi # end of 'dlartg.f' fi if test -f 'dlassq.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlassq.f'\" else echo shar: Extracting \"'dlassq.f'\" \(2835 characters\) sed "s/^X//" >'dlassq.f' <<'END_OF_FILE' X SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X INTEGER INCX, N X DOUBLE PRECISION SCALE, SUMSQ X* .. X* .. Array Arguments .. X DOUBLE PRECISION X( * ) X* .. X* X* Purpose X* ======= X* X* DLASSQ returns the values scl and smsq such that X* X* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, X* X* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is X* assumed to be non-negative and scl returns the value X* X* scl = max( scale, abs( x( i ) ) ). X* X* scale and sumsq must be supplied in SCALE and SUMSQ and X* scl and smsq are overwritten on SCALE and SUMSQ respectively. X* X* The routine makes only one pass through the vector x. X* X* Arguments X* ========= X* X* N - INTEGER X* On entry, N is the number of elements to be used from the X* vector X. X* Not modified. X* X* X - DOUBLE PRECISION X* On entry, X contains the vector for which a scaled sum of X* squares is computed. X* x( i ) = X( 1 + ( i - 1 )*INCX ), i = 1, n X* Not modified. X* X* INCX - INTEGER X* On entry, INCX is the increment for the vector X. INCX X* should be a positive integer. X* Not modified. X* X* SCALE - DOUBLE PRECISION X* On entry, SCALE contains the value scale in the equation X* above. On exit, SCALE is overwritten with scl , the X* scaling factor for the sum of squares. X* X* SUMSQ - DOUBLE PRECISION X* On entry, SUMSQ contains the value sumsq in the equation X* above. On exit, SUMSQ is overwritten with smsq , the X* basic sum of squares from which scl has been factored out. X* X* X* -- Written on 22-October-1982. X* Sven Hammarling, Nag Central Office. X* X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER IX X DOUBLE PRECISION ABSXI X* .. X* .. Intrinsic Functions .. X INTRINSIC ABS X* .. X* .. Executable Statements .. X* X IF( N.GT.0 ) THEN X DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX X IF( X( IX ).NE.ZERO ) THEN X ABSXI = ABS( X( IX ) ) X IF( SCALE.LT.ABSXI ) THEN X SUMSQ = 1 + SUMSQ*( SCALE/ABSXI )**2 X SCALE = ABSXI X ELSE X SUMSQ = SUMSQ + ( ABSXI/SCALE )**2 X END IF X END IF X 10 CONTINUE X END IF X RETURN X* X* End of DLASSQ X* X END END_OF_FILE if test 2835 -ne `wc -c <'dlassq.f'`; then echo shar: \"'dlassq.f'\" unpacked with wrong size! fi # end of 'dlassq.f' fi if test -f 'dlasum.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlasum.f'\" else echo shar: Extracting \"'dlasum.f'\" \(1036 characters\) sed "s/^X//" >'dlasum.f' <<'END_OF_FILE' X SUBROUTINE DLASUM( TYPE, IOUNIT, IE, NRUN ) X* X* -- LAPACK auxiliary test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER*3 TYPE X INTEGER IE, IOUNIT, NRUN X* .. X* X* Purpose X* ======= X* X* DLASUM prints a summary of the results from one of the -CHK- X* routines. Since DLASUM contains write statements in lower X* case, it should not be TAMPR-ed with. X* X* .. Executable Statements .. X* X IF( IE.GT.0 ) THEN X WRITE( IOUNIT, FMT = 9999 )TYPE, ': ', IE, ' out of ', NRUN, X $ ' tests failed to pass the threshold' X ELSE X WRITE( IOUNIT, FMT = 9998 )'All tests for ', TYPE, X $ ' passed the threshold (', NRUN, ' tests run)' X END IF X 9999 FORMAT( 1X, A3, A2, I4, A8, I4, A35 ) X 9998 FORMAT( / 1X, A14, A3, A23, I4, A11 ) X RETURN X* X* End of DLASUM X* X END END_OF_FILE if test 1036 -ne `wc -c <'dlasum.f'`; then echo shar: \"'dlasum.f'\" unpacked with wrong size! fi # end of 'dlasum.f' fi if test -f 'dlatm1.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlatm1.f'\" else echo shar: Extracting \"'dlatm1.f'\" \(7256 characters\) sed "s/^X//" >'dlatm1.f' <<'END_OF_FILE' X SUBROUTINE DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) X* X* -- LAPACK auxiliary test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X* X INTEGER IDIST, INFO, IRSIGN, MODE, N X DOUBLE PRECISION COND X* .. X* X* .. Array Arguments .. X* X INTEGER ISEED( 4 ) X DOUBLE PRECISION D( * ) X* .. X* X* Purpose X* ======= X* X* DLATM1 computes the entries of D(1..N) as specified by X* MODE, COND and IRSIGN. IDIST and ISEED determine the generation X* of random numbers. DLATM1 is called by SLATMR to generate X* random test matrices for LAPACK programs. X* X* Arguments X* ========= X* X* MODE - INTEGER X* On entry describes how D is to be computed: X* MODE = 0 means do not change D. X* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND X* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND X* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) X* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) X* MODE = 5 sets D to random numbers in the range X* ( 1/COND , 1 ) such that their logarithms X* are uniformly distributed. X* MODE = 6 set D to random numbers from same distribution X* as the rest of the matrix. X* MODE < 0 has the same meaning as ABS(MODE), except that X* the order of the elements of D is reversed. X* Thus if MODE is positive, D has entries ranging from X* 1 to 1/COND, if negative, from 1/COND to 1, X* Not modified. X* X* COND - DOUBLE PRECISION X* On entry, used as described under MODE above. X* If used, it must be >= 1. Not modified. X* X* IRSIGN - INTEGER X* On entry, if MODE neither -6, 0 nor 6, determines sign of X* entries of D X* 0 => leave entries of D unchanged X* 1 => multiply each entry of D by 1 or -1 with probability .5 X* X* IDIST - CHARACTER*1 X* On entry, DIST specifies the type of distribution to be used X* to generate a random matrix . X* 1 => UNIFORM( 0, 1 ) X* 2 => UNIFORM( -1, 1 ) X* 3 => NORMAL( 0, 1 ) X* Not modified. X* X* ISEED - INTEGER array of dimension ( 4 ) X* On entry ISEED specifies the seed of the random number X* generator. The random number generator uses a X* linear congruential sequence limited to small X* integers, and so should produce machine independent X* random numbers. The values of ISEED are changed on X* exit, and can be used in the next call to DLATM1 X* to continue the same random number sequence. X* Changed on exit. X* X* D - DOUBLE PRECISION array of dimension ( MIN( M , N ) ) X* Array to be computed according to MODE, COND and IRSIGN. X* May be changed on exit if MODE is nonzero. X* X* N - INTEGER X* Number of entries of D. Not modified. X* X* INFO - INTEGER X* 0 => normal termination X* -1 => if MODE not in range -6 to 6 X* -2 => if MODE neither -6, 0 nor 6, and X* IRSIGN neither 0 nor 1 X* -3 => if MODE neither -6, 0 nor 6 and COND less than 1 X* -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3 X* -7 => if N negative X* X*----------------------------------------------------------------------- X* X* .. Parameters .. X* X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D0 ) X DOUBLE PRECISION HALF X PARAMETER ( HALF = 0.5D0 ) X* .. X* X* .. Local Scalars .. X* X INTEGER I X DOUBLE PRECISION ALPHA, TEMP X* .. X* X* .. External Functions .. X* X DOUBLE PRECISION DLARAN, DLARND X EXTERNAL DLARAN, DLARND X* .. X* X* .. External Subroutines .. X* X EXTERNAL XERBLA X* .. X* X* .. Intrinsic Functions .. X* X INTRINSIC ABS, DBLE, EXP, LOG X* .. X* X* .. Executable Statements .. X* X* Decode and Test the input parameters. X* Initialize flags & seed. X* X INFO = 0 X* X* Quick return if possible X* X IF( N.EQ.0 ) X $ RETURN X* X* Set INFO if an error X* X IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN X INFO = -1 X ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. X $ ( IRSIGN.NE.0 .AND. IRSIGN.NE.1 ) ) THEN X INFO = -2 X ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. X $ COND.LT.ONE ) THEN X INFO = -3 X ELSE IF( ( MODE.EQ.6 .OR. MODE.EQ.-6 ) .AND. X $ ( IDIST.LT.1 .OR. IDIST.GT.3 ) ) THEN X INFO = -4 X ELSE IF( N.LT.0 ) THEN X INFO = -7 X END IF X* X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DLATM1', -INFO ) X RETURN X END IF X* X*....................................................................... X* X* Compute D according to COND and MODE X* X IF( MODE.NE.0 ) THEN X GO TO ( 10, 30, 50, 70, 90, 110 )ABS( MODE ) X* X* One large D value: X* X 10 CONTINUE X DO 20 I = 1, N X D( I ) = ONE / COND X 20 CONTINUE X D( 1 ) = ONE X GO TO 130 X* X* One small D value: X* X 30 CONTINUE X DO 40 I = 1, N X D( I ) = ONE X 40 CONTINUE X D( N ) = ONE / COND X GO TO 130 X* X* Exponentially distributed D values: X* X 50 CONTINUE X D( 1 ) = ONE X IF( N.GT.1 ) THEN X ALPHA = COND**( -ONE / DBLE( N-1 ) ) X DO 60 I = 2, N X D( I ) = ALPHA**( I-1 ) X 60 CONTINUE X END IF X GO TO 130 X* X* Arithmetically distributed D values: X* X 70 CONTINUE X D( 1 ) = ONE X IF( N.GT.1 ) THEN X TEMP = ONE / COND X ALPHA = ( ONE-TEMP ) / DBLE( N-1 ) X DO 80 I = 2, N X D( I ) = DBLE( N-I )*ALPHA + TEMP X 80 CONTINUE X END IF X GO TO 130 X* X* Randomly distributed D values on ( 1/COND , 1): X* X 90 CONTINUE X ALPHA = LOG( ONE / COND ) X DO 100 I = 1, N X D( I ) = EXP( ALPHA*DLARAN( ISEED ) ) X 100 CONTINUE X GO TO 130 X* X* Randomly distributed D values from DIST X* X 110 CONTINUE X DO 120 I = 1, N X D( I ) = DLARND( IDIST, ISEED ) X 120 CONTINUE X* X 130 CONTINUE X* X* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign X* random signs to D X* X IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. X $ IRSIGN.EQ.1 ) THEN X DO 140 I = 1, N X IF( DLARAN( ISEED ).GT.HALF ) X $ D( I ) = -D( I ) X 140 CONTINUE X END IF X* X* Reverse if MODE < 0 X* X IF( MODE.LT.0 ) THEN X DO 150 I = 1, N / 2 X TEMP = D( I ) X D( I ) = D( N+1-I ) X D( N+1-I ) = TEMP X 150 CONTINUE X END IF X* X END IF X* X RETURN X* X* End of DLATM1 X* X END END_OF_FILE if test 7256 -ne `wc -c <'dlatm1.f'`; then echo shar: \"'dlatm1.f'\" unpacked with wrong size! fi # end of 'dlatm1.f' fi if test -f 'dlatm2.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlatm2.f'\" else echo shar: Extracting \"'dlatm2.f'\" \(7266 characters\) sed "s/^X//" >'dlatm2.f' <<'END_OF_FILE' X DOUBLE PRECISION FUNCTION DLATM2( M, N, I, J, KL, KU, IDIST, X $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) X* X* -- LAPACK auxiliary test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X* X INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N X DOUBLE PRECISION SPARSE X* .. X* X* .. Array Arguments .. X* X INTEGER ISEED( 4 ), IWORK( * ) X DOUBLE PRECISION D( * ), DL( * ), DR( * ) X* .. X* X* Purpose X* ======= X* X* DLATM2 returns the (I,J) entry of a random matrix of dimension X* (M, N) described by the other paramters. It is called by the X* DLATMR routine in order to build random test matrices. No error X* checking on parameters is done, because this routine is called in X* a tight loop by DLATMR which has already checked the parameters. X* X* Use of DLATM2 differs from SLATM3 in the order in which the random X* number generator is called to fill in random matrix entries. X* With DLATM2, the generator is called to fill in the pivoted matrix X* columnwise. With DLATM3, the generator is called to fill in the X* matrix columnwise, after which it is pivoted. Thus, DLATM3 can X* be used to construct random matrices which differ only in their X* order of rows and/or columns. DLATM2 is used to construct band X* matrices while avoiding calling the random number generator for X* entries outside the band (and therefore generating random numbers X* X* The matrix whose (I,J) entry is returned is constructed as X* follows (this routine only computes one entry): X* X* If I is outside (1..M) or J is outside (1..N), return zero X* (this is convenient for generating matrices in band format). X* X* Generate a matrix A with random entries of distribution IDIST. X* X* Set the diagonal to D. X* X* Grade the matrix, if desired, from the left (by DL) and/or X* from the right (by DR or DL) as specified by IGRADE. X* X* Permute, if desired, the rows and/or columns as specified by X* IPVTNG and IWORK. X* X* Band the matrix to have lower bandwidth KL and upper X* bandwidth KU. X* X* Set random entries to zero as specified by SPARSE. X* X* Arguments X* ========= X* X* M - INTEGER X* Number of rows of matrix. Not modified. X* X* N - INTEGER X* Number of columns of matrix. Not modified. X* X* I - INTEGER X* Row of entry to be returned. Not modified. X* X* J - INTEGER X* Column of entry to be returned. Not modified. X* X* KL - INTEGER X* Lower bandwidth. Not modified. X* X* KU - INTEGER X* Upper bandwidth. Not modified. X* X* IDIST - INTEGER X* On entry, IDIST specifies the type of distribution to be X* used to generate a random matrix . X* 1 => UNIFORM( 0, 1 ) X* 2 => UNIFORM( -1, 1 ) X* 3 => NORMAL( 0, 1 ) X* Not modified. X* X* ISEED - INTEGER array of dimension ( 4 ) X* Seed for random number generator. X* Changed on exit. X* X* D - DOUBLE PRECISION array of dimension ( MIN( I , J ) ) X* Diagonal entries of matrix. Not modified. X* X* IGRADE - INTEGER X* Specifies grading of matrix as follows: X* 0 => no grading X* 1 => matrix premultiplied by diag( DL ) X* 2 => matrix postmultiplied by diag( DR ) X* 3 => matrix premultiplied by diag( DL ) and X* postmultiplied by diag( DR ) X* 4 => matrix premultiplied by diag( DL ) and X* postmultiplied by inv( diag( DL ) ) X* 5 => matrix premultiplied by diag( DL ) and X* postmultiplied by diag( DL ) X* Not modified. X* X* DL - DOUBLE PRECISION array ( I or J, as appropriate ) X* Left scale factors for grading matrix. Not modified. X* X* DR - DOUBLE PRECISION array ( I or J, as appropriate ) X* Right scale factors for grading matrix. Not modified. X* X* IPVTNG - INTEGER X* On entry specifies pivoting permutations as follows: X* 0 => none. X* 1 => row pivoting. X* 2 => column pivoting. X* 3 => full pivoting, i.e., on both sides. X* Not modified. X* X* IWORK - INTEGER array ( I or J, as appropriate ) X* This array specifies the permutation used. The X* row (or column) in position K was originally in X* position IWORK( K ). X* This differs from IWORK for DLATM3. Not modified. X* X* SPARSE - DOUBLE PRECISION between 0. and 1. X* On entry specifies the sparsity of the matrix X* if sparse matix is to be generated. X* SPARSE should lie between 0 and 1. X* A uniform ( 0, 1 ) random number x is generated and X* compared to SPARSE; if x is larger the matrix entry X* is unchanged and if x is smaller the entry is set X* to zero. Thus on the average a fraction SPARSE of the X* entries will be set to zero. X* Not modified. X* X*----------------------------------------------------------------------- X* X* .. Parameters .. X* X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D0 ) X* .. X* X* .. Local Scalars .. X* X INTEGER ISUB, JSUB X DOUBLE PRECISION TEMP X* .. X* X* .. External Functions .. X* X DOUBLE PRECISION DLARAN, DLARND X EXTERNAL DLARAN, DLARND X* .. X* X*----------------------------------------------------------------------- X* X* .. Executable Statements .. X* X* X* Check for I and J in range X* X IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN X DLATM2 = ZERO X RETURN X END IF X* X* Check for banding X* X IF( J.GT.I+KU .OR. J.LT.I-KL ) THEN X DLATM2 = ZERO X RETURN X END IF X* X* Check for sparsity X* X IF( SPARSE.GT.ZERO ) THEN X IF( DLARAN( ISEED ).LT.SPARSE ) THEN X DLATM2 = ZERO X RETURN X END IF X END IF X* X* Compute subscripts depending on IPVTNG X* X IF( IPVTNG.EQ.0 ) THEN X ISUB = I X JSUB = J X ELSE IF( IPVTNG.EQ.1 ) THEN X ISUB = IWORK( I ) X JSUB = J X ELSE IF( IPVTNG.EQ.2 ) THEN X ISUB = I X JSUB = IWORK( J ) X ELSE IF( IPVTNG.EQ.3 ) THEN X ISUB = IWORK( I ) X JSUB = IWORK( J ) X END IF X* X* Compute entry and grade it according to IGRADE X* X IF( ISUB.EQ.JSUB ) THEN X TEMP = D( ISUB ) X ELSE X TEMP = DLARND( IDIST, ISEED ) X END IF X IF( IGRADE.EQ.1 ) THEN X TEMP = TEMP*DL( ISUB ) X ELSE IF( IGRADE.EQ.2 ) THEN X TEMP = TEMP*DR( JSUB ) X ELSE IF( IGRADE.EQ.3 ) THEN X TEMP = TEMP*DL( ISUB )*DR( JSUB ) X ELSE IF( IGRADE.EQ.4 .AND. ISUB.NE.JSUB ) THEN X TEMP = TEMP*DL( ISUB ) / DL( JSUB ) X ELSE IF( IGRADE.EQ.5 ) THEN X TEMP = TEMP*DL( ISUB )*DL( JSUB ) X END IF X DLATM2 = TEMP X RETURN X* X* End of DLATM2 X* X END END_OF_FILE if test 7266 -ne `wc -c <'dlatm2.f'`; then echo shar: \"'dlatm2.f'\" unpacked with wrong size! fi # end of 'dlatm2.f' fi if test -f 'dlatm3.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlatm3.f'\" else echo shar: Extracting \"'dlatm3.f'\" \(7712 characters\) sed "s/^X//" >'dlatm3.f' <<'END_OF_FILE' X DOUBLE PRECISION FUNCTION DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, X $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, X $ SPARSE ) X* X* -- LAPACK auxiliary test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X* X INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL, X $ KU, M, N X DOUBLE PRECISION SPARSE X* .. X* X* .. Array Arguments .. X* X INTEGER ISEED( 4 ), IWORK( * ) X DOUBLE PRECISION D( * ), DL( * ), DR( * ) X* .. X* X* Purpose X* ======= X* X* DLATM3 returns the (ISUB,JSUB) entry of a random matrix of X* dimension (M, N) described by the other paramters. (ISUB,JSUB) X* is the final position of the (I,J) entry after pivoting X* according to IPVTNG and IWORK. DLATM3 is called by the X* DLATMR routine in order to build random test matrices. No error X* checking on parameters is done, because this routine is called in X* a tight loop by DLATMR which has already checked the parameters. X* X* Use of DLATM3 differs from SLATM2 in the order in which the random X* number generator is called to fill in random matrix entries. X* With DLATM2, the generator is called to fill in the pivoted matrix X* columnwise. With DLATM3, the generator is called to fill in the X* matrix columnwise, after which it is pivoted. Thus, DLATM3 can X* be used to construct random matrices which differ only in their X* order of rows and/or columns. DLATM2 is used to construct band X* matrices while avoiding calling the random number generator for X* entries outside the band (and therefore generating random numbers X* in different orders for different pivot orders). X* X* The matrix whose (ISUB,JSUB) entry is returned is constructed as X* follows (this routine only computes one entry): X* X* If ISUB is outside (1..M) or JSUB is outside (1..N), return zero X* (this is convenient for generating matrices in band format). X* X* Generate a matrix A with random entries of distribution IDIST. X* X* Set the diagonal to D. X* X* Grade the matrix, if desired, from the left (by DL) and/or X* from the right (by DR or DL) as specified by IGRADE. X* X* Permute, if desired, the rows and/or columns as specified by X* IPVTNG and IWORK. X* X* Band the matrix to have lower bandwidth KL and upper X* bandwidth KU. X* X* Set random entries to zero as specified by SPARSE. X* X* Arguments X* ========= X* X* M - INTEGER X* Number of rows of matrix. Not modified. X* X* N - INTEGER X* Number of columns of matrix. Not modified. X* X* I - INTEGER X* Row of unpivoted entry to be returned. Not modified. X* X* J - INTEGER X* Column of unpivoted entry to be returned. Not modified. X* X* ISUB - INTEGER X* Row of pivoted entry to be returned. Changed on exit. X* X* JSUB - INTEGER X* Column of pivoted entry to be returned. Changed on exit. X* X* KL - INTEGER X* Lower bandwidth. Not modified. X* X* KU - INTEGER X* Upper bandwidth. Not modified. X* X* IDIST - INTEGER X* On entry, IDIST specifies the type of distribution to be X* used to generate a random matrix . X* 1 => UNIFORM( 0, 1 ) X* 2 => UNIFORM( -1, 1 ) X* 3 => NORMAL( 0, 1 ) X* Not modified. X* X* ISEED - INTEGER array of dimension ( 4 ) X* Seed for random number generator. X* Changed on exit. X* X* D - DOUBLE PRECISION array of dimension ( MIN( I , J ) ) X* Diagonal entries of matrix. Not modified. X* X* IGRADE - INTEGER X* Specifies grading of matrix as follows: X* 0 => no grading X* 1 => matrix premultiplied by diag( DL ) X* 2 => matrix postmultiplied by diag( DR ) X* 3 => matrix premultiplied by diag( DL ) and X* postmultiplied by diag( DR ) X* 4 => matrix premultiplied by diag( DL ) and X* postmultiplied by inv( diag( DL ) ) X* 5 => matrix premultiplied by diag( DL ) and X* postmultiplied by diag( DL ) X* Not modified. X* X* DL - DOUBLE PRECISION array ( I or J, as appropriate ) X* Left scale factors for grading matrix. Not modified. X* X* DR - DOUBLE PRECISION array ( I or J, as appropriate ) X* Right scale factors for grading matrix. Not modified. X* X* IPVTNG - INTEGER X* On entry specifies pivoting permutations as follows: X* 0 => none. X* 1 => row pivoting. X* 2 => column pivoting. X* 3 => full pivoting, i.e., on both sides. X* Not modified. X* X* IWORK - INTEGER array ( I or J, as appropriate ) X* This array specifies the permutation used. The X* row (or column) originally in position K is in X* position IWORK( K ) after pivoting. X* This differs from IWORK for DLATM2. Not modified. X* X* SPARSE - DOUBLE PRECISION between 0. and 1. X* On entry specifies the sparsity of the matrix X* if sparse matix is to be generated. X* SPARSE should lie between 0 and 1. X* A uniform ( 0, 1 ) random number x is generated and X* compared to SPARSE; if x is larger the matrix entry X* is unchanged and if x is smaller the entry is set X* to zero. Thus on the average a fraction SPARSE of the X* entries will be set to zero. X* Not modified. X* X*----------------------------------------------------------------------- X* X* .. Parameters .. X* X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D0 ) X* .. X* X* .. Local Scalars .. X* X DOUBLE PRECISION TEMP X* .. X* X* .. External Functions .. X* X DOUBLE PRECISION DLARAN, DLARND X EXTERNAL DLARAN, DLARND X* .. X* X*----------------------------------------------------------------------- X* X* .. Executable Statements .. X* X* X* Check for I and J in range X* X IF( I.LT.1 .OR. I.GT.M .OR. J.LT.1 .OR. J.GT.N ) THEN X ISUB = I X JSUB = J X DLATM3 = ZERO X RETURN X END IF X* X* Compute subscripts depending on IPVTNG X* X IF( IPVTNG.EQ.0 ) THEN X ISUB = I X JSUB = J X ELSE IF( IPVTNG.EQ.1 ) THEN X ISUB = IWORK( I ) X JSUB = J X ELSE IF( IPVTNG.EQ.2 ) THEN X ISUB = I X JSUB = IWORK( J ) X ELSE IF( IPVTNG.EQ.3 ) THEN X ISUB = IWORK( I ) X JSUB = IWORK( J ) X END IF X* X* Check for banding X* X IF( JSUB.GT.ISUB+KU .OR. JSUB.LT.ISUB-KL ) THEN X DLATM3 = ZERO X RETURN X END IF X* X* Check for sparsity X* X IF( SPARSE.GT.ZERO ) THEN X IF( DLARAN( ISEED ).LT.SPARSE ) THEN X DLATM3 = ZERO X RETURN X END IF X END IF X* X* Compute entry and grade it according to IGRADE X* X IF( I.EQ.J ) THEN X TEMP = D( I ) X ELSE X TEMP = DLARND( IDIST, ISEED ) X END IF X IF( IGRADE.EQ.1 ) THEN X TEMP = TEMP*DL( I ) X ELSE IF( IGRADE.EQ.2 ) THEN X TEMP = TEMP*DR( J ) X ELSE IF( IGRADE.EQ.3 ) THEN X TEMP = TEMP*DL( I )*DR( J ) X ELSE IF( IGRADE.EQ.4 .AND. I.NE.J ) THEN X TEMP = TEMP*DL( I ) / DL( J ) X ELSE IF( IGRADE.EQ.5 ) THEN X TEMP = TEMP*DL( I )*DL( J ) X END IF X DLATM3 = TEMP X RETURN X* X* End of DLATM3 X* X END END_OF_FILE if test 7712 -ne `wc -c <'dlatm3.f'`; then echo shar: \"'dlatm3.f'\" unpacked with wrong size! fi # end of 'dlatm3.f' fi if test -f 'dlatme.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlatme.f'\" else echo shar: Extracting \"'dlatme.f'\" \(20985 characters\) sed "s/^X//" >'dlatme.f' <<'END_OF_FILE' X SUBROUTINE DLATME( N, DIST, ISEED, D, MODE, COND, DMAX, EI, RSIGN, X $ UPPER, SIM, DS, MODES, CONDS, KL, KU, ANORM, A, X $ LDA, WORK, INFO ) X* X* -- LAPACK test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X* X CHARACTER DIST, RSIGN, SIM, UPPER X INTEGER INFO, KL, KU, LDA, MODE, MODES, N X DOUBLE PRECISION ANORM, COND, CONDS, DMAX X* .. X* X* .. Array Arguments .. X* X CHARACTER EI( * ) X INTEGER ISEED( 4 ) X DOUBLE PRECISION A( LDA, * ), D( * ), DS( * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DLATME generates random non-symmetric square matrices with X* specified eigenvalues for testing LAPACK programs. X* X* DLATME operates by applying the following sequence of X* operations: X* X* 1. Set the diagonal to D, where D may be input or X* computed according to MODE, COND, DMAX, and RSIGN X* as described below. X* X* 2. If complex conjugate pairs are desired (MODE=0 and EI(1)='R', X* or MODE=5), certain pairs of adjacent elements of D are X* interpreted as the real and complex parts of a complex X* conjugate pair; A thus becomes block diagonal, with 1x1 X* and 2x2 blocks. X* X* 3. If UPPER='T', the upper triangle of A is set to random values X* out of distribution DIST. X* X* 4. If SIM='T', A is multiplied on the left by a random matrix X* X, whose singular values are specified by DS, MODES, and X* CONDS, and on the right by X inverse. X* X* 5. If KL < N-1, the lower bandwidth is reduced to KL using X* Householder transformations. If KU < N-1, the upper X* bandwidth is reduced to KU. X* X* 6. If ANORM is not negative, the matrix is scaled to have X* maximum-element-norm ANORM. X* X* (Note: since the matrix cannot be reduced beyond Hessenberg form, X* no packing options are available.) X* X* Arguments X* ========= X* X* N - INTEGER X* The number of columns (or rows) of A. Not modified. X* X* DIST - CHARACTER*1 X* On entry, DIST specifies the type of distribution to be used X* to generate the random eigen-/singular values, and for the X* upper triangle (see UPPER). X* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) X* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) X* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) X* Not modified. X* X* ISEED - INTEGER array of dimension ( 4 ) X* On entry ISEED specifies the seed of the random number X* generator. They should lie between 0 and 4095 inclusive, X* and ISEED(4) should be odd. The random number generator X* uses a linear congruential sequence limited to small X* integers, and so should produce machine independent X* random numbers. The values of ISEED are changed on X* exit, and can be used in the next call to DLATME X* to continue the same random number sequence. X* Changed on exit. X* X* D - DOUBLE PRECISION array of dimension ( N ) X* This array is used to specify the eigenvalues of A. If X* MODE=0, then D is assumed to contain the eigenvalues (but X* see the description of EI), otherwise they will be X* computed according to MODE, COND, DMAX, and RSIGN and X* placed in D. X* Modified if MODE is nonzero. X* X* MODE - INTEGER X* On entry this describes how the eigenvalues are to X* be specified: X* MODE = 0 means use D (with EI) as input X* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND X* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND X* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) X* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) X* MODE = 5 sets D to random numbers in the range X* ( 1/COND , 1 ) such that their logarithms X* are uniformly distributed. Each odd-even pair X* of elements will be either used as two real X* eigenvalues or as the real and imaginary part X* of a complex conjugate pair of eigenvalues; X* the choice of which is done is random, with X* 50-50 probability, for each pair. X* MODE = 6 set D to random numbers from same distribution X* as the rest of the matrix. X* MODE < 0 has the same meaning as ABS(MODE), except that X* the order of the elements of D is reversed. X* Thus if MODE is between 1 and 4, D has entries ranging X* from 1 to 1/COND, if between -1 and -4, D has entries X* ranging from 1/COND to 1, X* Not modified. X* X* COND - DOUBLE PRECISION X* On entry, this is used as described under MODE above. X* If used, it must be >= 1. Not modified. X* X* DMAX - DOUBLE PRECISION X* If MODE is neither -6, 0 nor 6, the contents of D, as X* computed according to MODE and COND, will be scaled by X* DMAX / max(abs(D(i))). Note that DMAX need not be X* positive: if DMAX is negative (or zero), D will be X* scaled by a negative number (or zero). X* Not modified. X* X* EI - CHARACTER*1 array of dimension ( N ) X* If MODE is 0, and EI(1) is not ' ' (space character), X* this array specifies which elements of D (on input) are X* real eigenvalues and which are the real and imaginary parts X* of a complex conjugate pair of eigenvalues. The elements X* of EI may then only have the values 'R' and 'I'. If X* EI(j)='R' and EI(j+1)='I', then the j-th eigenvalue is X* CMPLX( D(j) , D(j+1) ), and the (j+1)-th is the complex X* conjugate thereof. If EI(j)=EI(j+1)='R', then the j-th X* eigenvalue is D(j) (i.e., real). EI(1) may not be 'I', X* nor may two adjacent elements of EI both have the value 'I'. X* If MODE is not 0, then EI is ignored. If MODE is 0 and X* EI(1)=' ', then the eigenvalues will all be real. X* Not modified. X* X* RSIGN - CHARACTER*1 X* If MODE is not 0, 6, or -6, and RSIGN='T', then the X* elements of D, as computed according to MODE and COND, will X* be multiplied by a random sign (+1 or -1). If RSIGN='F', X* they will not be. RSIGN may only have the values 'T' or X* 'F'. X* Not modified. X* X* UPPER - CHARACTER*1 X* If UPPER='T', then the elements of A above the diagonal X* (and above the 2x2 diagonal blocks, if A has complex X* eigenvalues) will be set to random numbers out of DIST. X* If UPPER='F', they will not. UPPER may only have the X* values 'T' or 'F'. X* Not modified. X* X* SIM - CHARACTER*1 X* If SIM='T', then A will be operated on by a "similarity X* transform", i.e., multiplied on the left by a matrix X and X* on the right by X inverse. X = U S V, where U and V are X* random unitary matrices and S is a (diagonal) matrix of X* singular values specified by DS, MODES, and CONDS. If X* SIM='F', then A will not be transformed. X* Not modified. X* X* DS - DOUBLE PRECISION array of dimension ( N ) X* This array is used to specify the singular values of X, X* in the same way that D specifies the eigenvalues of A. X* If MODE=0, the DS contains the singular values, which X* may not be zero. X* Modified if MODE is nonzero. X* X* MODES - INTEGER X* CONDS - DOUBLE PRECISION X* Same as MODE and COND, but for specifying the diagonal X* of S. MODES=-6 and +6 are not allowed (since they would X* result in randomly ill-conditioned eigenvalues.) X* X* KL - INTEGER positive X* This specifies the lower bandwidth of the matrix. KL=1 X* specifies upper Hessenberg form. If KL is at least N-1, X* then A will have full lower bandwidth. KL must be at X* least 1. X* Not modified. X* X* KU - INTEGER positive X* This specifies the upper bandwidth of the matrix. KU=1 X* specifies lower Hessenberg form. If KU is at least N-1, X* then A will have full upper bandwidth; if KU and KL X* are both at least N-1, then A will be dense. Only one of X* KU and KL may be less than N-1. KU must be at least 1. X* Not modified. X* X* ANORM - DOUBLE PRECISION X* If ANORM is not negative, then A will be scaled by a non- X* negative real number to make the maximum-element-norm of A X* to be ANORM. X* Not modified. X* X* A - DOUBLE PRECISION array of dimension ( LDA, N ) X* On exit A is the desired test matrix. X* Modified. X* X* LDA - INTEGER X* LDA specifies the first dimension of A as declared in the X* calling program. LDA must be at least N. X* Not modified. X* X* WORK - DOUBLE PRECISION array ( 3*N ) X* Workspace. X* Modified. X* X* INFO - INTEGER X* Error code. On exit, INFO will be set to one of the X* following values: X* 0 => normal return X* -1 => N negative X* -2 => DIST illegal string X* -5 => MODE not in range -6 to 6 X* -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 X* -8 => EI(1) is not ' ' or 'R', EI(j) is not 'R' or 'I', or X* two adjacent elements of EI are 'I'. X* -9 => RSIGN is not 'T' or 'F' X* -10 => UPPER is not 'T' or 'F' X* -11 => SIM is not 'T' or 'F' X* -12 => MODES=0 and DS has a zero singular value. X* -13 => MODES is not in the range -5 to 5. X* -14 => MODES is nonzero and CONDS is less than 1. X* -15 => KL is less than 1. X* -16 => KU is less than 1, or KL and KU are both less than X* N-1. X* -19 => LDA is less than N. X* 1 => Error return from DLATM1 (computing D) X* 2 => Cannot scale to DMAX (max. eigenvalue is 0) X* 3 => Error return from DLATM1 (computing DS) X* 4 => Error return from DLAROR X* 5 => Zero singular value from DLATM1. X* X*----------------------------------------------------------------------- X* X* .. Parameters .. X* X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D0 ) X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D0 ) X DOUBLE PRECISION HALF X PARAMETER ( HALF = 1.0D0 / 2.0D0 ) X* .. X* X* .. Local Scalars .. X* X LOGICAL BADEI, BADS, USEEI X INTEGER I, IC, ICOLS, IDIST, IINFO, IR, IROWS, IRSIGN, X $ ISIM, IUPPER, J, JC, JCR, JR X DOUBLE PRECISION ALPHA, TAU, TEMP, XNORMS X* .. X* X* .. Local Arrays .. X* X DOUBLE PRECISION TEMPA( 1 ) X* .. X* X* .. External Functions .. X* X LOGICAL LSAME X DOUBLE PRECISION DLANGE, DLARAN, DLARND X EXTERNAL LSAME, DLANGE, DLARAN, DLARND X* .. X* X* .. External Subroutines .. X* X EXTERNAL DCOPY, DGEMV, DGER, DLARFG, DLAROR, DLATM1, X $ DLAZRO, DSCAL, XERBLA X* .. X* X* .. Intrinsic Functions .. X* X INTRINSIC ABS, MAX, MOD X* .. X* X*----------------------------------------------------------------------- X* X* .. Executable Statements .. X* X* X* 1) Decode and Test the input parameters. X* Initialize flags & seed. X* X* X INFO = 0 X* X* Quick return if possible X* X IF( N.EQ.0 ) X $ RETURN X* X* Decode DIST X* X IF( LSAME( DIST, 'U' ) ) THEN X IDIST = 1 X ELSE IF( LSAME( DIST, 'S' ) ) THEN X IDIST = 2 X ELSE IF( LSAME( DIST, 'N' ) ) THEN X IDIST = 3 X ELSE X IDIST = -1 X END IF X* X* Check EI X* X USEEI = .TRUE. X BADEI = .FALSE. X IF( LSAME( EI( 1 ), ' ' ) .OR. MODE.NE.0 ) THEN X USEEI = .FALSE. X ELSE X IF( LSAME( EI( 1 ), 'R' ) ) THEN X DO 10 J = 2, N X IF( LSAME( EI( J ), 'I' ) ) THEN X IF( LSAME( EI( J-1 ), 'I' ) ) X $ BADEI = .TRUE. X ELSE X IF( .NOT.LSAME( EI( J ), 'R' ) ) X $ BADEI = .TRUE. X END IF X 10 CONTINUE X ELSE X BADEI = .TRUE. X END IF X END IF X* X* Decode RSIGN X* X IF( LSAME( RSIGN, 'T' ) ) THEN X IRSIGN = 1 X ELSE IF( LSAME( RSIGN, 'F' ) ) THEN X IRSIGN = 0 X ELSE X IRSIGN = -1 X END IF X* X* Decode UPPER X* X IF( LSAME( UPPER, 'T' ) ) THEN X IUPPER = 1 X ELSE IF( LSAME( UPPER, 'F' ) ) THEN X IUPPER = 0 X ELSE X IUPPER = -1 X END IF X* X* Decode SIM X* X IF( LSAME( SIM, 'T' ) ) THEN X ISIM = 1 X ELSE IF( LSAME( SIM, 'F' ) ) THEN X ISIM = 0 X ELSE X ISIM = -1 X END IF X* X* Check DS, if MODES=0 and ISIM=1 X* X BADS = .FALSE. X IF( MODES.EQ.0 .AND. ISIM.EQ.1 ) THEN X DO 20 J = 1, N X IF( DS( J ).EQ.ZERO ) X $ BADS = .TRUE. X 20 CONTINUE X END IF X* X* Set INFO if an error X* X IF( N.LT.0 ) THEN X INFO = -1 X ELSE IF( IDIST.EQ.-1 ) THEN X INFO = -2 X ELSE IF( ABS( MODE ).GT.6 ) THEN X INFO = -5 X ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE ) X $ THEN X INFO = -6 X ELSE IF( BADEI ) THEN X INFO = -8 X ELSE IF( IRSIGN.EQ.-1 ) THEN X INFO = -9 X ELSE IF( IUPPER.EQ.-1 ) THEN X INFO = -10 X ELSE IF( ISIM.EQ.-1 ) THEN X INFO = -11 X ELSE IF( BADS ) THEN X INFO = -12 X ELSE IF( ISIM.EQ.1 .AND. ABS( MODES ).GT.5 ) THEN X INFO = -13 X ELSE IF( ISIM.EQ.1 .AND. MODES.NE.0 .AND. CONDS.LT.ONE ) THEN X INFO = -14 X ELSE IF( KL.LT.1 ) THEN X INFO = -15 X ELSE IF( KU.LT.1 .OR. ( KU.LT.N-1 .AND. KL.LT.N-1 ) ) THEN X INFO = -16 X ELSE IF( LDA.LT.MAX( 1, N ) ) THEN X INFO = -19 X END IF X* X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DLATME', -INFO ) X RETURN X END IF X* X* Initialize random number generator X* X DO 30 I = 1, 4 X ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 ) X 30 CONTINUE X* X IF( MOD( ISEED( 4 ), 2 ).NE.1 ) X $ ISEED( 4 ) = ISEED( 4 ) + 1 X* X*....................................................................... X* X* X* 2) Set up diagonal of A X* X* X* Compute D according to COND and MODE X* X CALL DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, IINFO ) X IF( IINFO.NE.0 ) THEN X INFO = 1 X RETURN X END IF X IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN X* X* Scale by DMAX X* X TEMP = ABS( D( 1 ) ) X DO 40 I = 2, N X TEMP = MAX( TEMP, ABS( D( I ) ) ) X 40 CONTINUE X* X IF( TEMP.GT.ZERO ) THEN X ALPHA = DMAX / TEMP X ELSE IF( DMAX.NE.ZERO ) THEN X INFO = 2 X RETURN X ELSE X ALPHA = ZERO X END IF X* X CALL DSCAL( N, ALPHA, D, 1 ) X* X END IF X* X CALL DLAZRO( N, N, ZERO, ZERO, A, LDA ) X CALL DCOPY( N, D, 1, A, LDA+1 ) X* X* X* Set up complex conjugate pairs X* X* X IF( MODE.EQ.0 ) THEN X IF( USEEI ) THEN X DO 50 J = 2, N X IF( LSAME( EI( J ), 'I' ) ) THEN X A( J-1, J ) = A( J, J ) X A( J, J-1 ) = -A( J, J ) X A( J, J ) = A( J-1, J-1 ) X END IF X 50 CONTINUE X END IF X* X ELSE IF( ABS( MODE ).EQ.5 ) THEN X DO 60 J = 2, N, 2 X IF( DLARAN( ISEED ).GT.HALF ) THEN X A( J-1, J ) = A( J, J ) X A( J, J-1 ) = -A( J, J ) X A( J, J ) = A( J-1, J-1 ) X END IF X 60 CONTINUE X END IF X* X* X*....................................................................... X* X* X* 3) If UPPER='T', set upper triangle of A to random numbers. X* (but don't modify the corners of 2x2 blocks.) X* X* X IF( IUPPER.NE.0 ) THEN X DO 80 JC = 2, N X DO 70 JR = 1, JC - 2 X A( JR, JC ) = DLARND( IDIST, ISEED ) X 70 CONTINUE X IF( A( JC-1, JC ).EQ.ZERO ) X $ A( JC-1, JC ) = DLARND( IDIST, ISEED ) X 80 CONTINUE X END IF X* X* X*....................................................................... X* X* X* 4) If SIM='T', apply similarity transformation. X* X* -1 X* Transform is X A X , where X = U S V, thus X* X* it is U S V A V' (1/S) U' X* X* X IF( ISIM.NE.0 ) THEN X* X* Compute S (singular values of the eigenvector matrix) X* according to CONDS and MODES X* X CALL DLATM1( MODES, CONDS, 0, 0, ISEED, DS, N, IINFO ) X IF( IINFO.NE.0 ) THEN X INFO = 3 X RETURN X END IF X* X* Multiply by V and V' X* X CALL DLAROR( 'C', 'N', N, N, A, LDA, ISEED, WORK, IINFO ) X IF( IINFO.NE.0 ) THEN X INFO = 4 X RETURN X END IF X* X* Multiply by S and (1/S) X* X DO 90 J = 1, N X CALL DSCAL( N, DS( J ), A( J, 1 ), LDA ) X IF( DS( J ).NE.ZERO ) THEN X CALL DSCAL( N, ONE / DS( J ), A( 1, J ), 1 ) X ELSE X INFO = 5 X RETURN X END IF X 90 CONTINUE X* X* Multiply by U and U' X* X CALL DLAROR( 'C', 'N', N, N, A, LDA, ISEED, WORK, IINFO ) X IF( IINFO.NE.0 ) THEN X INFO = 4 X RETURN X END IF X END IF X* X* X* X*....................................................................... X* X* X* 5) Reduce the bandwidth. X* X* X IF( KL.LT.N-1 ) THEN X* X* Reduce bandwidth -- kill column X* X DO 100 JCR = KL + 1, N - 1 X IC = JCR - KL X IROWS = N + 1 - JCR X ICOLS = N + KL - JCR X* X CALL DCOPY( IROWS, A( JCR, IC ), 1, WORK, 1 ) X XNORMS = WORK( 1 ) X CALL DLARFG( IROWS, XNORMS, WORK( 2 ), 1, TAU ) X WORK( 1 ) = ONE X* X CALL DGEMV( 'T', IROWS, ICOLS, ONE, A( JCR, IC+1 ), LDA, X $ WORK, 1, ZERO, WORK( IROWS+1 ), 1 ) X CALL DGER( IROWS, ICOLS, -TAU, WORK, 1, WORK( IROWS+1 ), 1, X $ A( JCR, IC+1 ), LDA ) X* X CALL DGEMV( 'N', N, IROWS, ONE, A( 1, JCR ), LDA, WORK, 1, X $ ZERO, WORK( IROWS+1 ), 1 ) X CALL DGER( N, IROWS, -TAU, WORK( IROWS+1 ), 1, WORK, 1, X $ A( 1, JCR ), LDA ) X* X A( JCR, IC ) = XNORMS X CALL DLAZRO( IROWS-1, 1, ZERO, ZERO, A( JCR+1, IC ), LDA ) X 100 CONTINUE X ELSE IF( KU.LT.N-1 ) THEN X* X* Reduce upper bandwidth -- kill a row at a time. X* X DO 110 JCR = KU + 1, N - 1 X IR = JCR - KU X IROWS = N + KU - JCR X ICOLS = N + 1 - JCR X* X CALL DCOPY( ICOLS, A( IR, JCR ), LDA, WORK, 1 ) X XNORMS = WORK( 1 ) X CALL DLARFG( ICOLS, XNORMS, WORK( 2 ), 1, TAU ) X WORK( 1 ) = ONE X* X CALL DGEMV( 'N', IROWS, ICOLS, ONE, A( IR+1, JCR ), LDA, X $ WORK, 1, ZERO, WORK( ICOLS+1 ), 1 ) X CALL DGER( IROWS, ICOLS, -TAU, WORK( ICOLS+1 ), 1, WORK, 1, X $ A( IR+1, JCR ), LDA ) X* X CALL DGEMV( 'C', ICOLS, N, ONE, A( JCR, 1 ), LDA, WORK, 1, X $ ZERO, WORK( ICOLS+1 ), 1 ) X CALL DGER( ICOLS, N, -TAU, WORK, 1, WORK( ICOLS+1 ), 1, X $ A( JCR, 1 ), LDA ) X* X A( IR, JCR ) = XNORMS X CALL DLAZRO( 1, ICOLS-1, ZERO, ZERO, A( IR, JCR+1 ), LDA ) X 110 CONTINUE X END IF X* X* X* X*....................................................................... X* X* Scale the matrix to have norm ANORM X* X IF( ANORM.GE.ZERO ) THEN X TEMP = DLANGE( 'M', N, N, A, LDA, TEMPA ) X IF( TEMP.GT.ZERO ) THEN X ALPHA = ANORM / TEMP X DO 120 J = 1, N X CALL DSCAL( N, ALPHA, A( 1, J ), 1 ) X 120 CONTINUE X END IF X END IF X* X*....................................................................... X* X RETURN X* X*....................................................................... X* X* End of DLATME X* X END END_OF_FILE if test 20985 -ne `wc -c <'dlatme.f'`; then echo shar: \"'dlatme.f'\" unpacked with wrong size! fi # end of 'dlatme.f' fi if test -f 'dlatmr.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlatmr.f'\" else echo shar: Extracting \"'dlatmr.f'\" \(40668 characters\) sed "s/^X//" >'dlatmr.f' <<'END_OF_FILE' X SUBROUTINE DLATMR( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, X $ RSIGN, GRADE, DL, MODEL, CONDL, DR, MODER, X $ CONDR, PIVTNG, IPIVOT, KL, KU, SPARSE, ANORM, X $ PACK, A, LDA, IWORK, INFO ) X* X* -- LAPACK test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X* X CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM X INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N X DOUBLE PRECISION ANORM, COND, CONDL, CONDR, DMAX, SPARSE X* .. X* X* .. Array Arguments .. X* X INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * ) X DOUBLE PRECISION A( LDA, * ), D( * ), DL( * ), DR( * ) X* .. X* X* Purpose X* ======= X* X* DLATMR generates random matrices of various types for testing X* LAPACK programs. X* X* DLATMR operates by applying the following sequence of X* operations: X* X* Generate a matrix A with random entries of distribution DIST X* which is symmetric if SYM='S', and nonsymmetric X* if SYM='N'. X* X* Set the diagonal to D, where D may be input or X* computed according to MODE, COND, DMAX and RSIGN X* as described below. X* X* Grade the matrix, if desired, from the left and/or right X* as specified by GRADE. The inputs DL, MODEL, CONDL, DR, X* MODER and CONDR also determine the grading as described X* below. X* X* Permute, if desired, the rows and/or columns as specified by X* PIVTNG and IPIVOT. X* X* Set random entries to zero, if desired, to get a random sparse X* matrix as specified by SPARSE. X* X* Make A a band matrix, if desired, by zeroing out the matrix X* outside a band of lower bandwidth KL and upper bandwidth KU. X* X* Scale A, if desired, to have maximum entry ANORM. X* X* Pack the matrix if desired. Options specified by PACK are: X* no packing X* zero out upper half (if symmetric) X* zero out lower half (if symmetric) X* store the upper half columnwise (if symmetric or X* square upper triangular) X* store the lower half columnwise (if symmetric or X* square lower triangular) X* same as upper half rowwise if symmetric X* store the lower triangle in banded format (if symmetric) X* store the upper triangle in banded format (if symmetric) X* store the entire matrix in banded format X* X* Note: If two calls to DLATMR differ only in the PACK parameter, X* they will generate mathematically equivalent matrices. X* X* If two calls to DLATMR both have full bandwidth (KL = M-1 X* and KU = N-1), and differ only in the PIVTNG and PACK X* parameters, then the matrices generated will differ only X* in the order of the rows and/or columns, and otherwise X* contain the same data. This consistency cannot be and X* is not maintained with less than full bandwidth. X* X* Arguments X* ========= X* X* M - INTEGER X* Number of rows of A. Not modified. X* X* N - INTEGER X* Number of columns of A. Not modified. X* X* DIST - CHARACTER*1 X* On entry, DIST specifies the type of distribution to be used X* to generate a random matrix . X* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) X* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) X* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) X* Not modified. X* X* ISEED - INTEGER array of dimension ( 4 ) X* On entry ISEED specifies the seed of the random number X* generator. They should lie between 0 and 4095 inclusive, X* and ISEED(4) should be odd. The random number generator X* uses a linear congruential sequence limited to small X* integers, and so should produce machine independent X* random numbers. The values of ISEED are changed on X* exit, and can be used in the next call to DLATMR X* to continue the same random number sequence. X* Changed on exit. X* X* SYM - CHARACTER*1 X* If SYM='S' or 'H', generated matrix is symmetric. X* If SYM='N', generated matrix is nonsymmetric. X* Not modified. X* X* D - DOUBLE PRECISION array of dimension ( MIN( M , N ) ) X* On entry this array specifies the diagonal entries X* of the diagonal of A. D may either be specified X* on entry, or set according to MODE and COND as described X* below. May be changed on exit if MODE is nonzero. X* X* MODE - INTEGER X* On entry describes how D is to be used: X* MODE = 0 means use D as input X* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND X* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND X* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) X* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) X* MODE = 5 sets D to random numbers in the range X* ( 1/COND , 1 ) such that their logarithms X* are uniformly distributed. X* MODE = 6 set D to random numbers from same distribution X* as the rest of the matrix. X* MODE < 0 has the same meaning as ABS(MODE), except that X* the order of the elements of D is reversed. X* Thus if MODE is positive, D has entries ranging from X* 1 to 1/COND, if negative, from 1/COND to 1, X* Not modified. X* X* COND - DOUBLE PRECISION X* On entry, used as described under MODE above. X* If used, it must be >= 1. Not modified. X* X* DMAX - DOUBLE PRECISION X* If MODE neither -6, 0 nor 6, the diagonal is scaled by X* DMAX / max(abs(D(i))), so that maximum absolute entry X* of diagonal is abs(DMAX). If DMAX is negative (or zero), X* diagonal will be scaled by a negative number (or zero). X* X* RSIGN - CHARACTER*1 X* If MODE neither -6, 0 nor 6, specifies sign of diagonal X* as follows: X* 'T' => diagonal entries are multiplied by 1 or -1 X* with probability .5 X* 'F' => diagonal unchanged X* Not modified. X* X* GRADE - CHARACTER*1 X* Specifies grading of matrix as follows: X* 'N' => no grading X* 'L' => matrix premultiplied by diag( DL ) X* (only if matrix nonsymmetric) X* 'R' => matrix postmultiplied by diag( DR ) X* (only if matrix nonsymmetric) X* 'B' => matrix premultiplied by diag( DL ) and X* postmultiplied by diag( DR ) X* (only if matrix nonsymmetric) X* 'S' or 'H' => matrix premultiplied by diag( DL ) and X* postmultiplied by diag( DL ) X* ('S' for symmetric, or 'H' for Hermitian) X* 'E' => matrix premultiplied by diag( DL ) and X* postmultiplied by inv( diag( DL ) ) X* ( 'E' for eigenvalue invariance) X* (only if matrix nonsymmetric) X* Note: if GRADE='E', then M must equal N. X* Not modified. X* X* DL - DOUBLE PRECISION array of dimension ( M ) X* If MODEL=0, then on entry this array specifies the diagonal X* entries of a diagonal matrix used as described under GRADE X* above. If MODEL is not zero, then DL will be set according X* to MODEL and CONDL, analogous to the way D is set according X* to MODE and COND (except there is no DMAX parameter for DL). X* If GRADE='E', then DL cannot have zero entries. X* Not referenced if GRADE = 'N' or 'R'. Changed on exit. X* X* MODEL - INTEGER X* This specifies how the diagonal array DL is to be computed, X* just as MODE specifies how D is to be computed. X* Not modified. X* X* CONDL - DOUBLE PRECISION scalar. X* When MODEL is not zero, this specifies the condition number X* of the computed DL. Not modified. X* X* DR - DOUBLE PRECISION array of dimension ( N ) X* If MODER=0, then on entry this array specifies the diagonal X* entries of a diagonal matrix used as described under GRADE X* above. If MODER is not zero, then DR will be set according X* to MODER and CONDR, analogous to the way D is set according X* to MODE and COND (except there is no DMAX parameter for DR). X* Not referenced if GRADE = 'N', 'L', 'H', 'S' or 'E'. X* Changed on exit. X* X* MODER - INTEGER X* This specifies how the diagonal array DR is to be computed, X* just as MODE specifies how D is to be computed. X* Not modified. X* X* CONDR - DOUBLE PRECISION scalar. X* When MODER is not zero, this specifies the condition number X* of the computed DR. Not modified. X* X* PIVTNG - CHARACTER*1 X* On entry specifies pivoting permutations as follows: X* 'N' or ' ' => none. X* 'L' => left or row pivoting (matrix must be nonsymmetric). X* 'R' => right or column pivoting (matrix must be X* nonsymmetric). X* 'B' or 'F' => both or full pivoting, i.e., on both sides. X* In this case, M must equal N X* X* If two calls to DLATMR both have full bandwidth (KL = M-1 X* and KU = N-1), and differ only in the PIVTNG and PACK X* parameters, then the matrices generated will differ only X* in the order of the rows and/or columns, and otherwise X* contain the same data. This consistency cannot be X* maintained with less than full bandwidth. X* X* IPIVOT - INTEGER array ( N or M, as appropriate ) X* This array specifies the permutation used. After the X* basic matrix is generated, the rows, columns, or both X* are permuted. If, say, row pivoting is selected, DLATMR X* starts with the *last* row and interchanges the M-th and X* IPIVOT(M)-th rows, then moves to the next-to-last row, X* interchanging the (M-1)-th and the IPIVOT(M-1)-th rows, X* and so on. In terms of "2-cycles", the permutation is X* (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M)) X* where the rightmost cycle is applied first. This is the X* *inverse* of the effect of pivoting in LINPACK. The idea X* is that factoring (with pivoting) an identity matrix X* which has been inverse-pivoted in this way should X* result in a pivot vector identical to IPIVOT. X* Not referenced if PIVTNG = 'N'. Not modified. X* X* SPARSE - DOUBLE PRECISION between 0. and 1. X* On entry specifies the sparsity of the matrix if a sparse X* matrix is to be generated. SPARSE should lie between X* 0 and 1. To generate a sparse matrix, for each matrix entry X* a uniform ( 0, 1 ) random number x is generated and X* compared to SPARSE; if x is larger the matrix entry X* is unchanged and if x is smaller the entry is set X* to zero. Thus on the average a fraction SPARSE of the X* entries will be set to zero. X* Not modified. X* X* KL - INTEGER nonnegative X* On entry specifies the lower bandwidth of the matrix. For X* example, KL=0 implies upper triangular, KL=1 implies upper X* Hessenberg, and KL at least M-1 implies the matrix is not X* banded. Must equal KU if matrix is symmetric. X* Not modified. X* X* KU - INTEGER nonnegative X* On entry specifies the upper bandwidth of the matrix. For X* example, KU=0 implies lower triangular, KU=1 implies lower X* Hessenberg, and KU at least N-1 implies the matrix is not X* banded. Must equal KL if matrix is symmetric. X* Not modified. X* X* ANORM - DOUBLE PRECISION X* On entry specifies maximum entry of output matrix X* (output matrix will by multiplied by a constant so that X* its largest absolute entry equal ANORM) X* if ANORM is nonnegative. If ANORM is negative no scaling X* is done. Not modified. X* X* PACK - CHARACTER*1 X* On entry specifies packing of matrix as follows: X* 'N' => no packing X* 'U' => zero out all subdiagonal entries (if symmetric) X* 'L' => zero out all superdiagonal entries (if symmetric) X* 'C' => store the upper triangle columnwise X* (only if matrix symmetric or square upper triangular) X* 'R' => store the lower triangle columnwise X* (only if matrix symmetric or square lower triangular) X* (same as upper half rowwise if symmetric) X* 'B' => store the lower triangle in band storage scheme X* (only if matrix symmetric) X* 'Q' => store the upper triangle in band storage scheme X* (only if matrix symmetric) X* 'Z' => store the entire matrix in band storage scheme X* (pivoting can be provided for by using this X* option to store A in the trailing rows of X* the allocated storage) X* X* Using these options, the various LAPACK packed and banded X* storage schemes can be obtained: X* GB - use 'Z' X* PB, SB or TB - use 'B' or 'Q' X* PP, SP or TP - use 'C' or 'R' X* X* If two calls to DLATMR differ only in the PACK parameter, X* they will generate mathematically equivalent matrices. X* Not modified. X* X* A - DOUBLE PRECISION array of dimension ( LDA, N ) X* On exit A is the desired test matrix. Only those X* entries of A which are significant on output X* will be referenced (even if A is in packed or band X* storage format). The 'unoccupied corners' of A in X* band format will be zeroed out. X* X* LDA - INTEGER X* on entry LDA specifies the first dimension of A as X* declared in the calling program. X* If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ). X* If PACK='C' or 'R', LDA must be at least 1. X* If PACK='B', or 'Q', LDA must be MIN ( KU+1, N ) X* If PACK='Z', LDA must be at least KUU+KLL+1, where X* KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, N-1 ) X* Not modified. X* X* IWORK - INTEGER array ( N or M as appropriate ) X* Workspace. Not referenced if PIVTNG = 'N'. Changed on exit. X* X* INFO - INTEGER X* Error parameter on exit: X* 0 => normal return X* -1 => M negative or unequal to N and SYM='S' or 'H' X* -2 => N negative X* -3 => DIST illegal string X* -5 => SYM illegal string X* -7 => MODE not in range -6 to 6 X* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 X* -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string X* -11 => GRADE illegal string, or GRADE='E' and X* M not equal to N, or GRADE='L', 'R', 'B' or 'E' and X* SYM = 'S' or 'H' X* -12 => GRADE = 'E' and DL contains zero X* -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H', X* 'S' or 'E' X* -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E', X* and MODEL neither -6, 0 nor 6 X* -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B' X* -17 => CONDR less than 1.0, GRADE='R' or 'B', and X* MODER neither -6, 0 nor 6 X* -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and X* M not equal to N, or PIVTNG='L' or 'R' and SYM='S' X* or 'H' X* -19 => IPIVOT contains out of range number and X* PIVTNG not equal to 'N' X* -20 => KL negative X* -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL X* -22 => SPARSE not in range 0. to 1. X* -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q' X* and SYM='N', or PACK='C' and SYM='N' and either KL X* not equal to 0 or N not equal to M, or PACK='R' and X* SYM='N', and either KU not equal to 0 or N not equal X* to M X* -26 => LDA too small X* 1 => Error return from DLATM1 (computing D) X* 2 => Cannot scale diagonal to DMAX (max. entry is 0) X* 3 => Error return from DLATM1 (computing DL) X* 4 => Error return from DLATM1 (computing DR) X* 5 => ANORM is positive, but matrix constructed prior to X* attempting to scale it to have norm ANORM, is zero X* X*----------------------------------------------------------------------- X* X* .. Parameters .. X* X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D0 ) X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D0 ) X* .. X* X* .. Local Scalars .. X* X LOGICAL BADPVT, DZERO, FULBND X INTEGER I, IDIST, IGRADE, IISUB, IPACK, IPVTNG, IRSIGN, X $ ISUB, ISYM, J, JJSUB, JSUB, K, KLL, KUU, MNMIN, X $ MNSUB, MXSUB, NPVTS X DOUBLE PRECISION ALPHA, ONORM, TEMP X* .. X* X* .. Local Arrays .. X* X DOUBLE PRECISION TEMPA( 1 ) X* .. X* X* .. External Functions .. X* X LOGICAL LSAME X DOUBLE PRECISION DLANGB, DLANGE, DLANSB, DLANSP, DLANSY, DLATM2, X $ DLATM3 X EXTERNAL LSAME, DLANGB, DLANGE, DLANSB, DLANSP, DLANSY, X $ DLATM2, DLATM3 X* .. X* X* .. External Subroutines .. X* X EXTERNAL DLATM1, DSCAL, XERBLA X* .. X* X* .. Intrinsic Functions .. X* X INTRINSIC ABS, MAX, MIN, MOD X* .. X* X*----------------------------------------------------------------------- X* X* .. Executable Statements .. X* X* X* 1) Decode and Test the input parameters. X* Initialize flags & seed. X* X* X INFO = 0 X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.EQ.0 ) X $ RETURN X* X* Decode DIST X* X IF( LSAME( DIST, 'U' ) ) THEN X IDIST = 1 X ELSE IF( LSAME( DIST, 'S' ) ) THEN X IDIST = 2 X ELSE IF( LSAME( DIST, 'N' ) ) THEN X IDIST = 3 X ELSE X IDIST = -1 X END IF X* X* Decode SYM X IF( LSAME( SYM, 'S' ) ) THEN X ISYM = 0 X ELSE IF( LSAME( SYM, 'N' ) ) THEN X ISYM = 1 X ELSE IF( LSAME( SYM, 'H' ) ) THEN X ISYM = 0 X ELSE X ISYM = -1 X END IF X* X* Decode RSIGN X* X IF( LSAME( RSIGN, 'F' ) ) THEN X IRSIGN = 0 X ELSE IF( LSAME( RSIGN, 'T' ) ) THEN X IRSIGN = 1 X ELSE X IRSIGN = -1 X END IF X* X* Decode PIVTNG X* X IF( LSAME( PIVTNG, 'N' ) ) THEN X IPVTNG = 0 X ELSE IF( LSAME( PIVTNG, ' ' ) ) THEN X IPVTNG = 0 X ELSE IF( LSAME( PIVTNG, 'L' ) ) THEN X IPVTNG = 1 X NPVTS = M X ELSE IF( LSAME( PIVTNG, 'R' ) ) THEN X IPVTNG = 2 X NPVTS = N X ELSE IF( LSAME( PIVTNG, 'B' ) ) THEN X IPVTNG = 3 X NPVTS = MIN( N, M ) X ELSE IF( LSAME( PIVTNG, 'F' ) ) THEN X IPVTNG = 3 X NPVTS = MIN( N, M ) X ELSE X IPVTNG = -1 X END IF X* X* Decode GRADE X* X IF( LSAME( GRADE, 'N' ) ) THEN X IGRADE = 0 X ELSE IF( LSAME( GRADE, 'L' ) ) THEN X IGRADE = 1 X ELSE IF( LSAME( GRADE, 'R' ) ) THEN X IGRADE = 2 X ELSE IF( LSAME( GRADE, 'B' ) ) THEN X IGRADE = 3 X ELSE IF( LSAME( GRADE, 'E' ) ) THEN X IGRADE = 4 X ELSE IF( LSAME( GRADE, 'H' ) .OR. LSAME( GRADE, 'S' ) ) THEN X IGRADE = 5 X ELSE X IGRADE = -1 X END IF X* X* Decode PACK X* X IF( LSAME( PACK, 'N' ) ) THEN X IPACK = 0 X ELSE IF( LSAME( PACK, 'U' ) ) THEN X IPACK = 1 X ELSE IF( LSAME( PACK, 'L' ) ) THEN X IPACK = 2 X ELSE IF( LSAME( PACK, 'C' ) ) THEN X IPACK = 3 X ELSE IF( LSAME( PACK, 'R' ) ) THEN X IPACK = 4 X ELSE IF( LSAME( PACK, 'B' ) ) THEN X IPACK = 5 X ELSE IF( LSAME( PACK, 'Q' ) ) THEN X IPACK = 6 X ELSE IF( LSAME( PACK, 'Z' ) ) THEN X IPACK = 7 X ELSE X IPACK = -1 X END IF X* X* Set certain internal parameters X* X MNMIN = MIN( M, N ) X KLL = MIN( KL, M-1 ) X KUU = MIN( KU, N-1 ) X* X* If inv(DL) is used, check to see if DL has a zero entry. X* X DZERO = .FALSE. X IF( IGRADE.EQ.4 .AND. MODEL.EQ.0 ) THEN X DO 10 I = 1, M X IF( DL( I ).EQ.ZERO ) X $ DZERO = .TRUE. X 10 CONTINUE X END IF X* X* Check values in IPIVOT X* X BADPVT = .FALSE. X IF( IPVTNG.GT.0 ) THEN X DO 20 J = 1, NPVTS X IF( IPIVOT( J ).LE.0 .OR. IPIVOT( J ).GT.NPVTS ) X $ BADPVT = .TRUE. X 20 CONTINUE X END IF X* X* Set INFO if an error X* X IF( M.LT.0 ) THEN X INFO = -1 X ELSE IF( M.NE.N .AND. ISYM.EQ.0 ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( IDIST.EQ.-1 ) THEN X INFO = -3 X ELSE IF( ISYM.EQ.-1 ) THEN X INFO = -5 X ELSE IF( MODE.LT.-6 .OR. MODE.GT.6 ) THEN X INFO = -7 X ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. X $ COND.LT.ONE ) THEN X INFO = -8 X ELSE IF( ( MODE.NE.-6 .AND. MODE.NE.0 .AND. MODE.NE.6 ) .AND. X $ IRSIGN.EQ.-1 ) THEN X INFO = -10 X ELSE IF( IGRADE.EQ.-1 .OR. ( IGRADE.EQ.4 .AND. M.NE.N ) .OR. X $ ( ( IGRADE.GE.1 .AND. IGRADE.LE.4 ) .AND. ISYM.EQ.0 ) ) X $ THEN X INFO = -11 X ELSE IF( IGRADE.EQ.4 .AND. DZERO ) THEN X INFO = -12 X ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. X $ IGRADE.EQ.5 ) .AND. ( MODEL.LT.-6 .OR. MODEL.GT.6 ) ) X $ THEN X INFO = -13 X ELSE IF( ( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. X $ IGRADE.EQ.5 ) .AND. ( MODEL.NE.-6 .AND. MODEL.NE.0 .AND. X $ MODEL.NE.6 ) .AND. CONDL.LT.ONE ) THEN X INFO = -14 X ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND. X $ ( MODER.LT.-6 .OR. MODER.GT.6 ) ) THEN X INFO = -16 X ELSE IF( ( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) .AND. X $ ( MODER.NE.-6 .AND. MODER.NE.0 .AND. MODER.NE.6 ) .AND. X $ CONDR.LT.ONE ) THEN X INFO = -17 X ELSE IF( IPVTNG.EQ.-1 .OR. ( IPVTNG.EQ.3 .AND. M.NE.N ) .OR. X $ ( ( IPVTNG.EQ.1 .OR. IPVTNG.EQ.2 ) .AND. ISYM.EQ.0 ) ) X $ THEN X INFO = -18 X ELSE IF( IPVTNG.NE.0 .AND. BADPVT ) THEN X INFO = -19 X ELSE IF( KL.LT.0 ) THEN X INFO = -20 X ELSE IF( KU.LT.0 .OR. ( ISYM.EQ.0 .AND. KL.NE.KU ) ) THEN X INFO = -21 X ELSE IF( SPARSE.LT.ZERO .OR. SPARSE.GT.ONE ) THEN X INFO = -22 X ELSE IF( IPACK.EQ.-1 .OR. ( ( IPACK.EQ.1 .OR. IPACK.EQ.2 .OR. X $ IPACK.EQ.5 .OR. IPACK.EQ.6 ) .AND. ISYM.EQ.1 ) .OR. X $ ( IPACK.EQ.3 .AND. ISYM.EQ.1 .AND. ( KL.NE.0 .OR. M.NE. X $ N ) ) .OR. ( IPACK.EQ.4 .AND. ISYM.EQ.1 .AND. ( KU.NE. X $ 0 .OR. M.NE.N ) ) ) THEN X INFO = -24 X ELSE IF( ( ( IPACK.EQ.0 .OR. IPACK.EQ.1 .OR. IPACK.EQ.2 ) .AND. X $ LDA.LT.MAX( 1, M ) ) .OR. ( ( IPACK.EQ.3 .OR. IPACK.EQ. X $ 4 ) .AND. LDA.LT.1 ) .OR. ( ( IPACK.EQ.5 .OR. IPACK.EQ. X $ 6 ) .AND. LDA.LT.KUU+1 ) .OR. X $ ( IPACK.EQ.7 .AND. LDA.LT.KLL+KUU+1 ) ) THEN X INFO = -26 X END IF X* X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DLATMR', -INFO ) X RETURN X END IF X* X* Decide if we can pivot consistently X* X FULBND = .FALSE. X IF( KUU.EQ.N-1 .AND. KLL.EQ.M-1 ) X $ FULBND = .TRUE. X* X* Initialize random number generator X* X DO 30 I = 1, 4 X ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 ) X 30 CONTINUE X* X ISEED( 4 ) = 2*( ISEED( 4 ) / 2 ) + 1 X* X*....................................................................... X* X* X* 2) Set up D, DL, and DR, if indicated. X* X* X* Compute D according to COND and MODE X* X CALL DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, INFO ) X IF( INFO.NE.0 ) THEN X INFO = 1 X RETURN X END IF X IF( MODE.NE.0 .AND. MODE.NE.-6 .AND. MODE.NE.6 ) THEN X* X* Scale by DMAX X* X TEMP = ABS( D( 1 ) ) X DO 40 I = 2, MNMIN X TEMP = MAX( TEMP, ABS( D( I ) ) ) X 40 CONTINUE X IF( TEMP.EQ.ZERO .AND. DMAX.NE.ZERO ) THEN X INFO = 2 X RETURN X END IF X IF( TEMP.NE.ZERO ) THEN X ALPHA = DMAX / TEMP X ELSE X ALPHA = ONE X END IF X DO 50 I = 1, MNMIN X D( I ) = ALPHA*D( I ) X 50 CONTINUE X* X END IF X* X* Compute DL if grading set X* X IF( IGRADE.EQ.1 .OR. IGRADE.EQ.3 .OR. IGRADE.EQ.4 .OR. IGRADE.EQ. X $ 5 ) THEN X CALL DLATM1( MODEL, CONDL, 0, IDIST, ISEED, DL, M, INFO ) X IF( INFO.NE.0 ) THEN X INFO = 3 X RETURN X END IF X END IF X* X* Compute DR if grading set X* X* X IF( IGRADE.EQ.2 .OR. IGRADE.EQ.3 ) THEN X CALL DLATM1( MODER, CONDR, 0, IDIST, ISEED, DR, N, INFO ) X IF( INFO.NE.0 ) THEN X INFO = 4 X RETURN X END IF X END IF X* X*....................................................................... X* X* X* 3) Generate IWORK if pivoting X* X IF( IPVTNG.GT.0 ) THEN X DO 60 I = 1, NPVTS X IWORK( I ) = I X 60 CONTINUE X IF( FULBND ) THEN X DO 70 I = 1, NPVTS X K = IPIVOT( I ) X J = IWORK( I ) X IWORK( I ) = IWORK( K ) X IWORK( K ) = J X 70 CONTINUE X ELSE X DO 80 I = NPVTS, 1, -1 X K = IPIVOT( I ) X J = IWORK( I ) X IWORK( I ) = IWORK( K ) X IWORK( K ) = J X 80 CONTINUE X END IF X END IF X* X*....................................................................... X* X* X* 4) Generate matrices for each kind of PACKing X* Always sweep matrix columnwise (if symmetric, upper X* half only) so that matrix generated does not depend X* on PACK X* X IF( FULBND ) THEN X* X* Use DLATM3 so matrices generated with differing PIVOTing only X* differ only in the order of their rows and/or columns. X* X IF( IPACK.EQ.0 ) THEN X IF( ISYM.EQ.0 ) THEN X DO 100 J = 1, N X DO 90 I = 1, J X TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, X $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, X $ IWORK, SPARSE ) X A( ISUB, JSUB ) = TEMP X A( JSUB, ISUB ) = TEMP X 90 CONTINUE X 100 CONTINUE X ELSE IF( ISYM.EQ.1 ) THEN X DO 120 J = 1, N X DO 110 I = 1, M X TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, X $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, X $ IWORK, SPARSE ) X A( ISUB, JSUB ) = TEMP X 110 CONTINUE X 120 CONTINUE X END IF X* X ELSE IF( IPACK.EQ.1 ) THEN X DO 140 J = 1, N X DO 130 I = 1, J X TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, X $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, X $ SPARSE ) X MNSUB = MIN( ISUB, JSUB ) X MXSUB = MAX( ISUB, JSUB ) X A( MNSUB, MXSUB ) = TEMP X IF( MNSUB.NE.MXSUB ) X $ A( MXSUB, MNSUB ) = ZERO X 130 CONTINUE X 140 CONTINUE X* X ELSE IF( IPACK.EQ.2 ) THEN X DO 160 J = 1, N X DO 150 I = 1, J X TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, X $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, X $ SPARSE ) X MNSUB = MIN( ISUB, JSUB ) X MXSUB = MAX( ISUB, JSUB ) X A( MXSUB, MNSUB ) = TEMP X IF( MNSUB.NE.MXSUB ) X $ A( MNSUB, MXSUB ) = ZERO X 150 CONTINUE X 160 CONTINUE X* X ELSE IF( IPACK.EQ.3 ) THEN X DO 180 J = 1, N X DO 170 I = 1, J X TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, X $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, X $ SPARSE ) X* X* Compute K = location of (ISUB,JSUB) entry in packed X* array X* X MNSUB = MIN( ISUB, JSUB ) X MXSUB = MAX( ISUB, JSUB ) X K = MXSUB*( MXSUB-1 ) / 2 + MNSUB X* X* Convert K to (IISUB,JJSUB) location X* X JJSUB = ( K-1 ) / LDA + 1 X IISUB = K - LDA*( JJSUB-1 ) X* X A( IISUB, JJSUB ) = TEMP X 170 CONTINUE X 180 CONTINUE X* X ELSE IF( IPACK.EQ.4 ) THEN X DO 200 J = 1, N X DO 190 I = 1, J X TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, X $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, X $ SPARSE ) X* X* Compute K = location of (I,J) entry in packed array X* X MNSUB = MIN( ISUB, JSUB ) X MXSUB = MAX( ISUB, JSUB ) X IF( MNSUB.EQ.1 ) THEN X K = MXSUB X ELSE X K = N*( N+1 ) / 2 - ( N-MNSUB+1 )*( N-MNSUB+2 ) / X $ 2 + MXSUB - MNSUB + 1 X END IF X* X* Convert K to (IISUB,JJSUB) location X* X JJSUB = ( K-1 ) / LDA + 1 X IISUB = K - LDA*( JJSUB-1 ) X* X A( IISUB, JJSUB ) = TEMP X 190 CONTINUE X 200 CONTINUE X* X ELSE IF( IPACK.EQ.5 ) THEN X DO 220 J = 1, N X DO 210 I = J - KUU, J X IF( I.LT.1 ) THEN X A( J-I+1, I+N ) = ZERO X ELSE X TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, X $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, X $ IWORK, SPARSE ) X MNSUB = MIN( ISUB, JSUB ) X MXSUB = MAX( ISUB, JSUB ) X A( MXSUB-MNSUB+1, MNSUB ) = TEMP X END IF X 210 CONTINUE X 220 CONTINUE X* X ELSE IF( IPACK.EQ.6 ) THEN X DO 240 J = 1, N X DO 230 I = J - KUU, J X TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, X $ ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, X $ SPARSE ) X MNSUB = MIN( ISUB, JSUB ) X MXSUB = MAX( ISUB, JSUB ) X A( MNSUB-MXSUB+KUU+1, MXSUB ) = TEMP X 230 CONTINUE X 240 CONTINUE X* X ELSE IF( IPACK.EQ.7 ) THEN X IF( ISYM.EQ.0 ) THEN X DO 260 J = 1, N X DO 250 I = J - KUU, J X TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, X $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, X $ IWORK, SPARSE ) X MNSUB = MIN( ISUB, JSUB ) X MXSUB = MAX( ISUB, JSUB ) X A( MNSUB-MXSUB+KUU+1, MXSUB ) = TEMP X IF( I.LT.1 ) X $ A( J-I+1+KUU, I+N ) = ZERO X IF( I.GE.1 .AND. MNSUB.NE.MXSUB ) X $ A( MXSUB-MNSUB+1+KUU, MNSUB ) = TEMP X 250 CONTINUE X 260 CONTINUE X ELSE IF( ISYM.EQ.1 ) THEN X DO 280 J = 1, N X DO 270 I = J - KUU, J + KLL X TEMP = DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, X $ IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, X $ IWORK, SPARSE ) X A( ISUB-JSUB+KUU+1, JSUB ) = TEMP X 270 CONTINUE X 280 CONTINUE X END IF X* X END IF X* X ELSE X* X* Use DLATM2 X* X IF( IPACK.EQ.0 ) THEN X IF( ISYM.EQ.0 ) THEN X DO 300 J = 1, N X DO 290 I = 1, J X A( I, J ) = DLATM2( M, N, I, J, KL, KU, IDIST, X $ ISEED, D, IGRADE, DL, DR, IPVTNG, X $ IWORK, SPARSE ) X A( J, I ) = A( I, J ) X 290 CONTINUE X 300 CONTINUE X ELSE IF( ISYM.EQ.1 ) THEN X DO 320 J = 1, N X DO 310 I = 1, M X A( I, J ) = DLATM2( M, N, I, J, KL, KU, IDIST, X $ ISEED, D, IGRADE, DL, DR, IPVTNG, X $ IWORK, SPARSE ) X 310 CONTINUE X 320 CONTINUE X END IF X* X ELSE IF( IPACK.EQ.1 ) THEN X DO 340 J = 1, N X DO 330 I = 1, J X A( I, J ) = DLATM2( M, N, I, J, KL, KU, IDIST, ISEED, X $ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) X IF( I.NE.J ) X $ A( J, I ) = ZERO X 330 CONTINUE X 340 CONTINUE X* X ELSE IF( IPACK.EQ.2 ) THEN X DO 360 J = 1, N X DO 350 I = 1, J X A( J, I ) = DLATM2( M, N, I, J, KL, KU, IDIST, ISEED, X $ D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) X IF( I.NE.J ) X $ A( I, J ) = ZERO X 350 CONTINUE X 360 CONTINUE X* X ELSE IF( IPACK.EQ.3 ) THEN X ISUB = 0 X JSUB = 1 X DO 380 J = 1, N X DO 370 I = 1, J X ISUB = ISUB + 1 X IF( ISUB.GT.LDA ) THEN X ISUB = 1 X JSUB = JSUB + 1 X END IF X A( ISUB, JSUB ) = DLATM2( M, N, I, J, KL, KU, IDIST, X $ ISEED, D, IGRADE, DL, DR, IPVTNG, X $ IWORK, SPARSE ) X 370 CONTINUE X 380 CONTINUE X* X ELSE IF( IPACK.EQ.4 ) THEN X IF( ISYM.EQ.0 ) THEN X DO 400 J = 1, N X DO 390 I = 1, J X* X* Compute K = location of (I,J) entry in packed array X* X IF( I.EQ.1 ) THEN X K = J X ELSE X K = N*( N+1 ) / 2 - ( N-I+1 )*( N-I+2 ) / 2 + X $ J - I + 1 X END IF X* X* Convert K to (ISUB,JSUB) location X* X JSUB = ( K-1 ) / LDA + 1 X ISUB = K - LDA*( JSUB-1 ) X* X A( ISUB, JSUB ) = DLATM2( M, N, I, J, KL, KU, X $ IDIST, ISEED, D, IGRADE, DL, DR, X $ IPVTNG, IWORK, SPARSE ) X 390 CONTINUE X 400 CONTINUE X ELSE X ISUB = 0 X JSUB = 1 X DO 420 J = 1, N X DO 410 I = J, M X ISUB = ISUB + 1 X IF( ISUB.GT.LDA ) THEN X ISUB = 1 X JSUB = JSUB + 1 X END IF X A( ISUB, JSUB ) = DLATM2( M, N, I, J, KL, KU, X $ IDIST, ISEED, D, IGRADE, DL, DR, X $ IPVTNG, IWORK, SPARSE ) X 410 CONTINUE X 420 CONTINUE X END IF X* X ELSE IF( IPACK.EQ.5 ) THEN X DO 440 J = 1, N X DO 430 I = J - KUU, J X IF( I.LT.1 ) THEN X A( J-I+1, I+N ) = ZERO X ELSE X A( J-I+1, I ) = DLATM2( M, N, I, J, KL, KU, IDIST, X $ ISEED, D, IGRADE, DL, DR, IPVTNG, X $ IWORK, SPARSE ) X END IF X 430 CONTINUE X 440 CONTINUE X* X ELSE IF( IPACK.EQ.6 ) THEN X DO 460 J = 1, N X DO 450 I = J - KUU, J X A( I-J+KUU+1, J ) = DLATM2( M, N, I, J, KL, KU, IDIST, X $ ISEED, D, IGRADE, DL, DR, IPVTNG, X $ IWORK, SPARSE ) X 450 CONTINUE X 460 CONTINUE X* X ELSE IF( IPACK.EQ.7 ) THEN X IF( ISYM.EQ.0 ) THEN X DO 480 J = 1, N X DO 470 I = J - KUU, J X A( I-J+KUU+1, J ) = DLATM2( M, N, I, J, KL, KU, X $ IDIST, ISEED, D, IGRADE, DL, X $ DR, IPVTNG, IWORK, SPARSE ) X IF( I.LT.1 ) X $ A( J-I+1+KUU, I+N ) = ZERO X IF( I.GE.1 .AND. I.NE.J ) X $ A( J-I+1+KUU, I ) = A( I-J+KUU+1, J ) X 470 CONTINUE X 480 CONTINUE X ELSE IF( ISYM.EQ.1 ) THEN X DO 500 J = 1, N X DO 490 I = J - KUU, J + KLL X A( I-J+KUU+1, J ) = DLATM2( M, N, I, J, KL, KU, X $ IDIST, ISEED, D, IGRADE, DL, X $ DR, IPVTNG, IWORK, SPARSE ) X 490 CONTINUE X 500 CONTINUE X END IF X* X END IF X* X END IF X* X*....................................................................... X* X* 5) Scaling the norm X* X IF( IPACK.EQ.0 ) THEN X ONORM = DLANGE( 'M', M, N, A, LDA, TEMPA ) X ELSE IF( IPACK.EQ.1 ) THEN X ONORM = DLANSY( 'M', 'U', N, A, LDA, TEMPA ) X ELSE IF( IPACK.EQ.2 ) THEN X ONORM = DLANSY( 'M', 'L', N, A, LDA, TEMPA ) X ELSE IF( IPACK.EQ.3 ) THEN X ONORM = DLANSP( 'M', 'U', N, A, TEMPA ) X ELSE IF( IPACK.EQ.4 ) THEN X ONORM = DLANSP( 'M', 'L', N, A, TEMPA ) X ELSE IF( IPACK.EQ.5 ) THEN X ONORM = DLANSB( 'M', 'L', N, KLL, A, LDA, TEMPA ) X ELSE IF( IPACK.EQ.6 ) THEN X ONORM = DLANSB( 'M', 'U', N, KUU, A, LDA, TEMPA ) X ELSE IF( IPACK.EQ.7 ) THEN X ONORM = DLANGB( 'M', N, KLL, KUU, A, LDA, TEMPA ) X END IF X* X IF( ANORM.GE.ZERO ) THEN X* X IF( ANORM.GT.ZERO .AND. ONORM.EQ.ZERO ) THEN X* X* Desired scaling impossible X* X INFO = 5 X RETURN X* X ELSE IF( ( ANORM.GT.ONE .AND. ONORM.LT.ONE ) .OR. X $ ( ANORM.LT.ONE .AND. ONORM.GT.ONE ) ) THEN X* X* Scale carefully to avoid over / underflow X* X IF( IPACK.LE.2 ) THEN X DO 510 J = 1, N X CALL DSCAL( M, ONE / ONORM, A( 1, J ), 1 ) X CALL DSCAL( M, ANORM, A( 1, J ), 1 ) X 510 CONTINUE X* X ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN X CALL DSCAL( N*( N+1 ) / 2, ONE / ONORM, A, 1 ) X CALL DSCAL( N*( N+1 ) / 2, ANORM, A, 1 ) X* X ELSE IF( IPACK.GE.5 ) THEN X DO 520 J = 1, N X CALL DSCAL( KLL+KUU+1, ONE / ONORM, A( 1, J ), 1 ) X CALL DSCAL( KLL+KUU+1, ANORM, A( 1, J ), 1 ) X 520 CONTINUE X* X END IF X* X ELSE X* X* Scale straightforwardly X* X IF( IPACK.LE.2 ) THEN X DO 530 J = 1, N X CALL DSCAL( M, ANORM / ONORM, A( 1, J ), 1 ) X 530 CONTINUE X* X ELSE IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN X CALL DSCAL( N*( N+1 ) / 2, ANORM / ONORM, A, 1 ) X* X ELSE IF( IPACK.GE.5 ) THEN X DO 540 J = 1, N X CALL DSCAL( KLL+KUU+1, ANORM / ONORM, A( 1, J ), 1 ) X 540 CONTINUE X END IF X* X END IF X* X END IF X* X*....................................................................... X* X* End of DLATMR X* X END END_OF_FILE if test 40668 -ne `wc -c <'dlatmr.f'`; then echo shar: \"'dlatmr.f'\" unpacked with wrong size! fi # end of 'dlatmr.f' fi if test -f 'dlatms.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlatms.f'\" else echo shar: Extracting \"'dlatms.f'\" \(46676 characters\) sed "s/^X//" >'dlatms.f' <<'END_OF_FILE' X SUBROUTINE DLATMS( M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, X $ KL, KU, PACK, A, LDA, WORK, INFO ) X* X* -- LAPACK test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X* X CHARACTER DIST, PACK, SYM X INTEGER INFO, KL, KU, LDA, M, MODE, N X DOUBLE PRECISION COND, DMAX X* .. X* X* .. Array Arguments .. X* X INTEGER ISEED( 4 ) X DOUBLE PRECISION A( LDA, * ), D( * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DLATMS generates random matrices with specified singular values X* (or symmetric/hermitian with specified eigenvalues) X* for testing LAPACK programs. X* X* DLATMS operates by applying the following sequence of X* operations: X* X* Set the diagonal to D, where D may be input or X* computed according to MODE, COND, DMAX, and SYM X* as described below. X* X* Generate a matrix with the appropriate band structure, by one X* of two methods: X* X* Method A: X* Generate a dense M x N matrix by multiplying D on the left X* and the right by random unitary matrices, then: X* X* Reduce the bandwidth according to KL and KU, using X* Householder transformations. X* X* Method B: X* Convert the bandwidth-0 (i.e., diagonal) matrix to a X* bandwidth-1 matrix using Givens rotations, "chasing" X* out-of-band elements back, much as in QR; then X* convert the bandwidth-1 to a bandwidth-2 matrix, etc. X* Note that for reasonably small bandwidths (relative to X* M and N) this requires less storage, as a dense matrix X* is not generated. Also, for symmetric matrices, only X* one triangle is generated. X* X* Method A is chosen if the bandwidth is a large fraction of the X* order of the matrix, and LDA is at least M (so a dense X* matrix can be stored.) Method B is chosen if the bandwidth X* is small (< 1/2 N for symmetric, < .3 N+M for X* non-symmetric), or LDA is less than M and not less than the X* bandwidth. X* X* Pack the matrix if desired. Options specified by PACK are: X* no packing X* zero out upper half (if symmetric) X* zero out lower half (if symmetric) X* store the upper half columnwise (if symmetric or upper X* triangular) X* store the lower half columnwise (if symmetric or lower X* triangular) X* store the lower triangle in banded format (if symmetric X* or lower triangular) X* store the upper triangle in banded format (if symmetric X* or upper triangular) X* store the entire matrix in banded format X* If Method B is chosen, and band format is specified, then the X* matrix will be generated in the band format, so no repacking X* will be necessary. X* X* X* Arguments X* ========= X* X* M - INTEGER X* The number of rows of A. Not modified. X* X* N - INTEGER X* The number of columns of A. Not modified. X* X* DIST - CHARACTER*1 X* On entry, DIST specifies the type of distribution to be used X* to generate the random eigen-/singular values. X* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) X* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) X* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) X* Not modified. X* X* ISEED - INTEGER array of dimension ( 4 ) X* On entry ISEED specifies the seed of the random number X* generator. They should lie between 0 and 4095 inclusive, X* and ISEED(4) should be odd. The random number generator X* uses a linear congruential sequence limited to small X* integers, and so should produce machine independent X* random numbers. The values of ISEED are changed on X* exit, and can be used in the next call to DLATMS X* to continue the same random number sequence. X* Changed on exit. X* X* SYM - CHARACTER*1 X* If SYM='S' or 'H', the generated matrix is symmetric, with X* eigenvalues specified by D, COND, MODE, and DMAX; they X* may be positive, negative, or zero. X* If SYM='P', the generated matrix is symmetric, with X* eigenvalues (= singular values) specified by D, COND, X* MODE, and DMAX; they will not be negative. X* If SYM='N', the generated matrix is nonsymmetric, with X* singular values specified by D, COND, MODE, and DMAX; X* they will not be negative. X* Not modified. X* X* D - DOUBLE PRECISION array of dimension ( MIN( M , N ) ) X* This array is used to specify the singular values or X* eigenvalues of A (see SYM, above.) If MODE=0, then D is X* assumed to contain the singular/eigenvalues, otherwise X* they will be computed according to MODE, COND, and DMAX, X* and placed in D. X* Modified if MODE is nonzero. X* X* MODE - INTEGER X* On entry this describes how the singular/eigenvalues are to X* be specified: X* MODE = 0 means use D as input X* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND X* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND X* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) X* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) X* MODE = 5 sets D to random numbers in the range X* ( 1/COND , 1 ) such that their logarithms X* are uniformly distributed. X* MODE = 6 set D to random numbers from same distribution X* as the rest of the matrix. X* MODE < 0 has the same meaning as ABS(MODE), except that X* the order of the elements of D is reversed. X* Thus if MODE is positive, D has entries ranging from X* 1 to 1/COND, if negative, from 1/COND to 1, X* If SYM='S' or 'H', and MODE is neither 0, 6, nor -6, then X* the elements of D will also be multiplied by a random X* sign (i.e., +1 or -1.) X* Not modified. X* X* COND - DOUBLE PRECISION X* On entry, this is used as described under MODE above. X* If used, it must be >= 1. Not modified. X* X* DMAX - DOUBLE PRECISION X* If MODE is neither -6, 0 nor 6, the contents of D, as X* computed according to MODE and COND, will be scaled by X* DMAX / max(abs(D(i))); thus, the maximum absolute eigen- or X* singular value (which is to say the norm) will be abs(DMAX). X* Note that DMAX need not be positive: if DMAX is negative X* (or zero), D will be scaled by a negative number (or zero). X* Not modified. X* X* KL - INTEGER nonnegative X* This specifies the lower bandwidth of the matrix. For X* example, KL=0 implies upper triangular, KL=1 implies upper X* Hessenberg, and KL being at least M-1 means that the matrix X* has full lower bandwidth. KL must equal KU if the matrix X* is symmetric. X* Not modified. X* X* KU - INTEGER nonnegative X* This specifies the upper bandwidth of the matrix. For X* example, KU=0 implies lower triangular, KU=1 implies lower X* Hessenberg, and KU being at least N-1 means that the matrix X* has full upper bandwidth. KL must equal KU if the matrix X* is symmetric. X* Not modified. X* X* PACK - CHARACTER*1 X* This specifies packing of matrix as follows: X* 'N' => no packing X* 'U' => zero out all subdiagonal entries (if symmetric) X* 'L' => zero out all superdiagonal entries (if symmetric) X* 'C' => store the upper triangle columnwise X* (only if the matrix is symmetric or upper triangular) X* 'R' => store the lower triangle columnwise X* (only if the matrix is symmetric or lower triangular) X* 'B' => store the lower triangle in band storage scheme X* (only if matrix symmetric or lower triangular) X* 'Q' => store the upper triangle in band storage scheme X* (only if matrix symmetric or upper triangular) X* 'Z' => store the entire matrix in band storage scheme X* (pivoting can be provided for by using this X* option to store A in the trailing rows of X* the allocated storage) X* X* Using these options, the various LAPACK packed and banded X* storage schemes can be obtained: X* GB - use 'Z' X* PB, SB or TB - use 'B' or 'Q' X* PP, SP or TP - use 'C' or 'R' X* X* If two calls to DLATMS differ only in the PACK parameter, X* they will generate mathematically equivalent matrices. X* Not modified. X* X* A - DOUBLE PRECISION array of dimension ( LDA, N ) X* On exit A is the desired test matrix. A is first generated X* in full (unpacked) form, and then packed, if so specified X* by PACK. Thus, the first M elements of the first N X* columns will always be modified. If PACK specifies a X* packed or banded storage scheme, all LDA elements of the X* first N columns will be modified; the elements of the X* array which do not correspond to elements of the generated X* matrix are set to zero. X* Modified. X* X* LDA - INTEGER X* LDA specifies the first dimension of A as declared in the X* calling program. If PACK='N', 'U', 'L', 'C', or 'R', then X* LDA must be at least M. If PACK='B' or 'Q', then LDA must X* be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)). X* If PACK='Z', LDA must be large enough to hold the packed X* array: MIN( KU, N-1) + MIN( KL, M-1) + 1. X* Not modified. X* X* WORK - DOUBLE PRECISION array ( 3*MAX( N , M ) ) X* Workspace. X* Modified. X* X* INFO - INTEGER X* Error code. On exit, INFO will be set to one of the X* following values: X* 0 => normal return X* -1 => M negative or unequal to N and SYM='S', 'H', or 'P' X* -2 => N negative X* -3 => DIST illegal string X* -5 => SYM illegal string X* -7 => MODE not in range -6 to 6 X* -8 => COND less than 1.0, and MODE neither -6, 0 nor 6 X* -10 => KL negative X* -11 => KU negative, or SYM='S' or 'H' and KU not equal to KL X* -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N'; X* or PACK='C' or 'Q' and SYM='N' and KL is not zero; X* or PACK='R' or 'B' and SYM='N' and KU is not zero; X* or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not X* N. X* -14 => LDA is less than M, or PACK='Z' and LDA is less than X* MIN(KU,N-1) + MIN(KL,M-1) + 1. X* 1 => Error return from DLATM1 X* 2 => Cannot scale to DMAX (max. sing. value is 0) X* 3 => Error return from DLAROR X* X*----------------------------------------------------------------------- X* X* .. Parameters .. X* X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D0 ) X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D0 ) X DOUBLE PRECISION TWOPI X PARAMETER ( TWOPI = 6.28318530717958623199592D+00 ) X* .. X* X* .. Local Scalars .. X* X LOGICAL GIVENS, ILEXTR, ILTEMP, TOPDWN X INTEGER I, IC, ICLRWS, ICOL, ICOLS, ICR, IDIST, IENDCH, X $ IINFO, IL, ILDA, IOFFG, IOFFST, IPACK, IPACKG, X $ IR, IR1, IR2, IROW, IROWS, IRSIGN, IRWCLS, X $ ISKEW, ISYM, ISYMPK, J, JC, JCH, JCR, JKL, JKU, X $ JR, JRC, K, LLB, MINLDA, MNMIN, MR, NC, UUB X DOUBLE PRECISION ALPHA, ANGLE, C, DUMMY, EXTRA, S, TAU, TEMP, X $ XNORMS X* .. X* X* .. External Functions .. X* X LOGICAL LSAME X DOUBLE PRECISION DLARND X EXTERNAL LSAME, DLARND X* .. X* X* .. External Subroutines .. X* X EXTERNAL DCOPY, DGEMV, DGER, DLARFG, DLAROR, DLAROT, X $ DLARTG, DLATM1, DLAZRO, DSCAL, XERBLA X* .. X* X* .. Intrinsic Functions .. X* X INTRINSIC ABS, COS, DBLE, MAX, MIN, MOD, SIN X* .. X* X*----------------------------------------------------------------------- X* X* .. Executable Statements .. X* X* X* 1) Decode and Test the input parameters. X* Initialize flags & seed. X* X* X INFO = 0 X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.EQ.0 ) X $ RETURN X* X* Decode DIST X* X IF( LSAME( DIST, 'U' ) ) THEN X IDIST = 1 X ELSE IF( LSAME( DIST, 'S' ) ) THEN X IDIST = 2 X ELSE IF( LSAME( DIST, 'N' ) ) THEN X IDIST = 3 X ELSE X IDIST = -1 X END IF X* X* Decode SYM X* X IF( LSAME( SYM, 'N' ) ) THEN X ISYM = 1 X IRSIGN = 0 X ELSE IF( LSAME( SYM, 'P' ) ) THEN X ISYM = 2 X IRSIGN = 0 X ELSE IF( LSAME( SYM, 'S' ) ) THEN X ISYM = 2 X IRSIGN = 1 X ELSE IF( LSAME( SYM, 'H' ) ) THEN X ISYM = 2 X IRSIGN = 1 X ELSE X ISYM = -1 X END IF X* X* Decode PACK X* X ISYMPK = 0 X IF( LSAME( PACK, 'N' ) ) THEN X IPACK = 0 X ELSE IF( LSAME( PACK, 'U' ) ) THEN X IPACK = 1 X ISYMPK = 1 X ELSE IF( LSAME( PACK, 'L' ) ) THEN X IPACK = 2 X ISYMPK = 1 X ELSE IF( LSAME( PACK, 'C' ) ) THEN X IPACK = 3 X ISYMPK = 2 X ELSE IF( LSAME( PACK, 'R' ) ) THEN X IPACK = 4 X ISYMPK = 3 X ELSE IF( LSAME( PACK, 'B' ) ) THEN X IPACK = 5 X ISYMPK = 3 X ELSE IF( LSAME( PACK, 'Q' ) ) THEN X IPACK = 6 X ISYMPK = 2 X ELSE IF( LSAME( PACK, 'Z' ) ) THEN X IPACK = 7 X ELSE X IPACK = -1 X END IF X* X* Set certain internal parameters X* X MNMIN = MIN( M, N ) X LLB = MIN( KL, M-1 ) X UUB = MIN( KU, N-1 ) X MR = MIN( M, N+LLB ) X NC = MIN( N, M+UUB ) X* X IF( IPACK.EQ.5 .OR. IPACK.EQ.6 ) THEN X MINLDA = UUB + 1 X ELSE IF( IPACK.EQ.7 ) THEN X MINLDA = LLB + UUB + 1 X ELSE X MINLDA = M X END IF X* X* Use Givens rotation method if bandwidth small enough, X* or if LDA is too small to store the matrix unpacked. X* X GIVENS = .FALSE. X IF( ISYM.EQ.1 ) THEN X IF( DBLE( LLB+UUB ).LT.0.3D0*DBLE( MAX( 1, MR+NC ) ) ) X $ GIVENS = .TRUE. X ELSE X IF( 2*LLB.LT.M ) X $ GIVENS = .TRUE. X END IF X IF( LDA.LT.M .AND. LDA.GE.MINLDA ) X $ GIVENS = .TRUE. X* X* Set INFO if an error X* X IF( M.LT.0 ) THEN X INFO = -1 X ELSE IF( M.NE.N .AND. ISYM.NE.1 ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -2 X ELSE IF( IDIST.EQ.-1 ) THEN X INFO = -3 X ELSE IF( ISYM.EQ.-1 ) THEN X INFO = -5 X ELSE IF( ABS( MODE ).GT.6 ) THEN X INFO = -7 X ELSE IF( ( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) .AND. COND.LT.ONE ) X $ THEN X INFO = -8 X ELSE IF( KL.LT.0 ) THEN X INFO = -10 X ELSE IF( KU.LT.0 .OR. ( ISYM.NE.1 .AND. KL.NE.KU ) ) THEN X INFO = -11 X ELSE IF( IPACK.EQ.-1 .OR. ( ISYMPK.EQ.1 .AND. ISYM.EQ.1 ) .OR. X $ ( ISYMPK.EQ.2 .AND. ISYM.EQ.1 .AND. KL.GT.0 ) .OR. X $ ( ISYMPK.EQ.3 .AND. ISYM.EQ.1 .AND. KU.GT.0 ) .OR. X $ ( ISYMPK.NE.0 .AND. M.NE.N ) ) THEN X INFO = -12 X ELSE IF( LDA.LT.MAX( 1, MINLDA ) ) THEN X INFO = -14 X END IF X* X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DLATMS', -INFO ) X RETURN X END IF X* X* Initialize random number generator X* X DO 10 I = 1, 4 X ISEED( I ) = MOD( ABS( ISEED( I ) ), 4096 ) X 10 CONTINUE X* X IF( MOD( ISEED( 4 ), 2 ).NE.1 ) X $ ISEED( 4 ) = ISEED( 4 ) + 1 X* X*....................................................................... X* X* X* 2) Set up D if indicated. X* X* X* Compute D according to COND and MODE X* X CALL DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, MNMIN, IINFO ) X IF( IINFO.NE.0 ) THEN X INFO = 1 X RETURN X END IF X* X* Choose Top-Down if D is (apparently) increasing, X* Bottom-Up if D is (apparently) decreasing. X* X IF( ABS( D( 1 ) ).LE.ABS( D( MNMIN ) ) ) THEN X TOPDWN = .TRUE. X ELSE X TOPDWN = .FALSE. X END IF X* X IF( MODE.NE.0 .AND. ABS( MODE ).NE.6 ) THEN X* X* Scale by DMAX X* X TEMP = ABS( D( 1 ) ) X DO 20 I = 2, MNMIN X TEMP = MAX( TEMP, ABS( D( I ) ) ) X 20 CONTINUE X* X IF( TEMP.GT.ZERO ) THEN X ALPHA = DMAX / TEMP X ELSE X INFO = 2 X RETURN X END IF X* X CALL DSCAL( MNMIN, ALPHA, D, 1 ) X* X END IF X* X* X*....................................................................... X* X* X* 3) Generate Banded Matrix using Givens rotations. X* Also the special case of UUB=LLB=0 X* X* X* Compute Addressing constants to cover all X* storage formats. Whether GE, SY, GB, or SB, X* upper or lower triangle or both, X* the (i,j)-th element is in X* A( i - ISKEW*j + IOFFST, j ) X* X* X IF( IPACK.GT.4 ) THEN X ILDA = LDA - 1 X ISKEW = 1 X IF( IPACK.GT.5 ) THEN X IOFFST = UUB + 1 X ELSE X IOFFST = 1 X END IF X ELSE X ILDA = LDA X ISKEW = 0 X IOFFST = 0 X END IF X* X* IPACKG is the format that the matrix is generated in. X* If this is different from IPACK, then the matrix X* must be repacked at the end. It also signals X* how to compute the norm, for scaling. X* X IPACKG = 0 X CALL DLAZRO( LDA, N, ZERO, ZERO, A, LDA ) X* X* X* Diagonal Matrix -- We are done, unless it X* is to be stored SP/PP/TP (PACK='R' or 'C') X* X* X IF( LLB.EQ.0 .AND. UUB.EQ.0 ) THEN X CALL DCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFST, 1 ), ILDA+1 ) X IF( IPACK.LE.2 .OR. IPACK.GE.5 ) X $ IPACKG = IPACK X* X* Check whether to use Givens rotations, X* Householder transformations, or nothing. X* X ELSE IF( GIVENS ) THEN X* (ELSE IF matches IF ( LLB .EQ. 0 ..... ) X* X* X IF( ISYM.EQ.1 ) THEN X* X* - - - - - - - - - - - - - -- X* X* Non-symmetric -- A = U D V X* X* X* X IF( IPACK.GT.4 ) THEN X IPACKG = IPACK X ELSE X IPACKG = 0 X END IF X* X CALL DCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFST, 1 ), ILDA+1 ) X* X IF( TOPDWN ) THEN X JKL = 0 X DO 50 JKU = 1, UUB X* X* Transform from bandwidth JKL, JKU-1 to JKL, JKU X* X* Last row actually rotated is M X* Last column actually rotated is MIN( M+JKU, N ) X* X DO 40 JR = 1, MIN( M+JKU, N ) + JKL - 1 X EXTRA = ZERO X ANGLE = TWOPI*DLARND( 1, ISEED ) X C = COS( ANGLE ) X S = SIN( ANGLE ) X ICOL = MAX( 1, JR-JKL ) X IF( JR.LT.M ) THEN X IL = MIN( N, JR+JKU ) + 1 - ICOL X CALL DLAROT( .TRUE., JR.GT.JKL, .FALSE., IL, C, X $ S, A( JR-ISKEW*ICOL+IOFFST, ICOL ), X $ ILDA, EXTRA, DUMMY ) X END IF X* X* Chase "EXTRA" back up X* X IR = JR X IC = ICOL X DO 30 JCH = JR - JKL, 1, -JKL - JKU X IF( IR.LT.M ) THEN X CALL DLARTG( A( IR+1-ISKEW*( IC+1 )+IOFFST, X $ IC+1 ), EXTRA, C, S, DUMMY ) X END IF X IROW = MAX( 1, JCH-JKU ) X IL = IR + 2 - IROW X TEMP = ZERO X ILTEMP = JCH.GT.JKU X CALL DLAROT( .FALSE., ILTEMP, .TRUE., IL, C, -S, X $ A( IROW-ISKEW*IC+IOFFST, IC ), X $ ILDA, TEMP, EXTRA ) X IF( ILTEMP ) THEN X CALL DLARTG( A( IROW+1-ISKEW*( IC+1 )+IOFFST, X $ IC+1 ), TEMP, C, S, DUMMY ) X ICOL = MAX( 1, JCH-JKU-JKL ) X IL = IC + 2 - ICOL X EXTRA = ZERO X CALL DLAROT( .TRUE., JCH.GT.JKU+JKL, .TRUE., X $ IL, C, -S, A( IROW-ISKEW*ICOL+ X $ IOFFST, ICOL ), ILDA, EXTRA, X $ TEMP ) X IC = ICOL X IR = IROW X END IF X 30 CONTINUE X 40 CONTINUE X 50 CONTINUE X* X* X JKU = UUB X DO 80 JKL = 1, LLB X* X* Transform from bandwidth JKL-1, JKU to JKL, JKU X* X DO 70 JC = 1, MIN( N+JKL, M ) + JKU - 1 X EXTRA = ZERO X ANGLE = TWOPI*DLARND( 1, ISEED ) X C = COS( ANGLE ) X S = SIN( ANGLE ) X IROW = MAX( 1, JC-JKU ) X IF( JC.LT.N ) THEN X IL = MIN( M, JC+JKL ) + 1 - IROW X CALL DLAROT( .FALSE., JC.GT.JKU, .FALSE., IL, C, X $ S, A( IROW-ISKEW*JC+IOFFST, JC ), X $ ILDA, EXTRA, DUMMY ) X END IF X* X* Chase "EXTRA" back up X* X IC = JC X IR = IROW X DO 60 JCH = JC - JKU, 1, -JKL - JKU X IF( IC.LT.N ) THEN X CALL DLARTG( A( IR+1-ISKEW*( IC+1 )+IOFFST, X $ IC+1 ), EXTRA, C, S, DUMMY ) X END IF X ICOL = MAX( 1, JCH-JKL ) X IL = IC + 2 - ICOL X TEMP = ZERO X ILTEMP = JCH.GT.JKL X CALL DLAROT( .TRUE., ILTEMP, .TRUE., IL, C, -S, X $ A( IR-ISKEW*ICOL+IOFFST, ICOL ), X $ ILDA, TEMP, EXTRA ) X IF( ILTEMP ) THEN X CALL DLARTG( A( IR+1-ISKEW*( ICOL+1 )+IOFFST, X $ ICOL+1 ), TEMP, C, S, DUMMY ) X IROW = MAX( 1, JCH-JKL-JKU ) X IL = IR + 2 - IROW X EXTRA = ZERO X CALL DLAROT( .FALSE., JCH.GT.JKL+JKU, .TRUE., X $ IL, C, -S, A( IROW-ISKEW*ICOL+ X $ IOFFST, ICOL ), ILDA, EXTRA, X $ TEMP ) X IC = ICOL X IR = IROW X END IF X 60 CONTINUE X 70 CONTINUE X 80 CONTINUE X* X* X ELSE X* (ELSE matches IF ( TOPDWN ) ) X* . . . . . . . . . . . . . .. X* X* Bottom-Up -- Start at the bottom right. X* X* X JKL = 0 X DO 110 JKU = 1, UUB X* X* Transform from bandwidth JKL, JKU-1 to JKL, JKU X* X* First row actually rotated is M X* First column actually rotated is MIN( M+JKU, N ) X* X IENDCH = MIN( M, N+JKL ) - 1 X DO 100 JC = MIN( M+JKU, N ) - 1, 1 - JKL, -1 X EXTRA = ZERO X ANGLE = TWOPI*DLARND( 1, ISEED ) X C = COS( ANGLE ) X S = SIN( ANGLE ) X IROW = MAX( 1, JC-JKU+1 ) X IF( JC.GT.0 ) THEN X IL = MIN( M, JC+JKL+1 ) + 1 - IROW X CALL DLAROT( .FALSE., .FALSE., JC+JKL.LT.M, IL, X $ C, S, A( IROW-ISKEW*JC+IOFFST, X $ JC ), ILDA, DUMMY, EXTRA ) X END IF X* X* Chase "EXTRA" back down X* X IC = JC X DO 90 JCH = JC + JKL, IENDCH, JKL + JKU X ILEXTR = IC.GT.0 X IF( ILEXTR ) THEN X CALL DLARTG( A( JCH-ISKEW*IC+IOFFST, IC ), X $ EXTRA, C, S, DUMMY ) X END IF X IC = MAX( 1, IC ) X ICOL = MIN( N-1, JCH+JKU ) X ILTEMP = JCH + JKU.LT.N X TEMP = ZERO X CALL DLAROT( .TRUE., ILEXTR, ILTEMP, ICOL+2-IC, X $ C, S, A( JCH-ISKEW*IC+IOFFST, IC ), X $ ILDA, EXTRA, TEMP ) X IF( ILTEMP ) THEN X CALL DLARTG( A( JCH-ISKEW*ICOL+IOFFST, X $ ICOL ), TEMP, C, S, DUMMY ) X IL = MIN( IENDCH, JCH+JKL+JKU ) + 2 - JCH X EXTRA = ZERO X CALL DLAROT( .FALSE., .TRUE., X $ JCH+JKL+JKU.LE.IENDCH, IL, C, S, X $ A( JCH-ISKEW*ICOL+IOFFST, X $ ICOL ), ILDA, TEMP, EXTRA ) X IC = ICOL X END IF X 90 CONTINUE X 100 CONTINUE X 110 CONTINUE X* X* X JKU = UUB X DO 140 JKL = 1, LLB X* X* Transform from bandwidth JKL-1, JKU to JKL, JKU X* X* X* First row actually rotated is MIN( N+JKL, M ) X* First column actually rotated is N X* X IENDCH = MIN( N, M+JKU ) - 1 X DO 130 JR = MIN( N+JKL, M ) - 1, 1 - JKU, -1 X EXTRA = ZERO X ANGLE = TWOPI*DLARND( 1, ISEED ) X C = COS( ANGLE ) X S = SIN( ANGLE ) X ICOL = MAX( 1, JR-JKL+1 ) X IF( JR.GT.0 ) THEN X IL = MIN( N, JR+JKU+1 ) + 1 - ICOL X CALL DLAROT( .TRUE., .FALSE., JR+JKU.LT.N, IL, X $ C, S, A( JR-ISKEW*ICOL+IOFFST, X $ ICOL ), ILDA, DUMMY, EXTRA ) X END IF X* X* Chase "EXTRA" back down X* X IR = JR X DO 120 JCH = JR + JKU, IENDCH, JKL + JKU X ILEXTR = IR.GT.0 X IF( ILEXTR ) THEN X CALL DLARTG( A( IR-ISKEW*JCH+IOFFST, JCH ), X $ EXTRA, C, S, DUMMY ) X END IF X IR = MAX( 1, IR ) X IROW = MIN( M-1, JCH+JKL ) X ILTEMP = JCH + JKL.LT.M X TEMP = ZERO X CALL DLAROT( .FALSE., ILEXTR, ILTEMP, IROW+2-IR, X $ C, S, A( IR-ISKEW*JCH+IOFFST, X $ JCH ), ILDA, EXTRA, TEMP ) X IF( ILTEMP ) THEN X CALL DLARTG( A( IROW-ISKEW*JCH+IOFFST, JCH ), X $ TEMP, C, S, DUMMY ) X IL = MIN( IENDCH, JCH+JKL+JKU ) + 2 - JCH X EXTRA = ZERO X CALL DLAROT( .TRUE., .TRUE., X $ JCH+JKL+JKU.LE.IENDCH, IL, C, S, X $ A( IROW-ISKEW*JCH+IOFFST, JCH ), X $ ILDA, TEMP, EXTRA ) X IR = IROW X END IF X 120 CONTINUE X 130 CONTINUE X 140 CONTINUE X* X* X* X END IF X* (END IF matches IF ( TOPDWN ) ) X ELSE X* (ELSE matches IF ( ISYM.EQ.1 ) ) X* X* - - - - - - - - - - - - - -- X* X* Symmetric -- A = U D U' X* X* IPACKG is the format generated (treating X* SP as SY), IOFFG is the value of IOFFST X* used when generating (note case when X* IPACK=7 and bottom-up!) X* X IPACKG = IPACK X IOFFG = IOFFST X* X IF( TOPDWN ) THEN X* X* . . . . . . . X* X* Top-Down -- Generate Upper triangle only X* X* X IF( IPACK.GE.5 ) THEN X IPACKG = 6 X IOFFG = UUB + 1 X ELSE X IPACKG = 1 X END IF X CALL DCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFG, 1 ), ILDA+1 ) X* X DO 170 K = 1, UUB X DO 160 JC = 1, N - 1 X IROW = MAX( 1, JC-K ) X IL = MIN( JC+1, K+2 ) X EXTRA = ZERO X TEMP = A( JC-ISKEW*( JC+1 )+IOFFG, JC+1 ) X ANGLE = TWOPI*DLARND( 1, ISEED ) X C = COS( ANGLE ) X S = SIN( ANGLE ) X CALL DLAROT( .FALSE., JC.GT.K, .TRUE., IL, C, S, X $ A( IROW-ISKEW*JC+IOFFG, JC ), ILDA, X $ EXTRA, TEMP ) X CALL DLAROT( .TRUE., .TRUE., .FALSE., X $ MIN( K, N-JC )+1, C, S, X $ A( ( 1-ISKEW )*JC+IOFFG, JC ), ILDA, X $ TEMP, DUMMY ) X* X* Chase EXTRA back up the matrix X* X ICOL = JC X DO 150 JCH = JC - K, 1, -K X CALL DLARTG( A( JCH+1-ISKEW*( ICOL+1 )+IOFFG, X $ ICOL+1 ), EXTRA, C, S, DUMMY ) X TEMP = A( JCH-ISKEW*( JCH+1 )+IOFFG, JCH+1 ) X CALL DLAROT( .TRUE., .TRUE., .TRUE., K+2, C, -S, X $ A( ( 1-ISKEW )*JCH+IOFFG, JCH ), X $ ILDA, TEMP, EXTRA ) X IROW = MAX( 1, JCH-K ) X IL = MIN( JCH+1, K+2 ) X EXTRA = ZERO X CALL DLAROT( .FALSE., JCH.GT.K, .TRUE., IL, C, X $ -S, A( IROW-ISKEW*JCH+IOFFG, JCH ), X $ ILDA, EXTRA, TEMP ) X ICOL = JCH X 150 CONTINUE X 160 CONTINUE X 170 CONTINUE X* X* If we need lower triangle, copy from upper. X* Note that the order of copying is chosen X* to work for 'q' -> 'b' X* X IF( IPACK.NE.IPACKG .AND. IPACK.NE.3 ) THEN X DO 190 JC = 1, N X IROW = IOFFST - ISKEW*JC X DO 180 JR = JC, MIN( N, JC+UUB ) X A( JR+IROW, JC ) = A( JC-ISKEW*JR+IOFFG, JR ) X 180 CONTINUE X 190 CONTINUE X IF( IPACK.EQ.5 ) THEN X DO 210 JC = N - UUB + 1, N X DO 200 JR = N + 2 - JC, UUB + 1 X A( JR, JC ) = ZERO X 200 CONTINUE X 210 CONTINUE X END IF X IF( IPACKG.EQ.6 ) THEN X IPACKG = IPACK X ELSE X IPACKG = 0 X END IF X END IF X ELSE X* (ELSE matches IF ( TOPDWN ) ) X* X* . . . . . . . X* X* Bottom-Up -- Generate Lower triangle only X* X* X IF( IPACK.GE.5 ) THEN X IPACKG = 5 X IF( IPACK.EQ.6 ) X $ IOFFG = 1 X ELSE X IPACKG = 2 X END IF X CALL DCOPY( MNMIN, D, 1, A( 1-ISKEW+IOFFG, 1 ), ILDA+1 ) X* X DO 240 K = 1, UUB X DO 230 JC = N - 1, 1, -1 X IL = MIN( N+1-JC, K+2 ) X EXTRA = ZERO X TEMP = A( 1+( 1-ISKEW )*JC+IOFFG, JC ) X ANGLE = TWOPI*DLARND( 1, ISEED ) X C = COS( ANGLE ) X S = -SIN( ANGLE ) X CALL DLAROT( .FALSE., .TRUE., N-JC.GT.K, IL, C, S, X $ A( ( 1-ISKEW )*JC+IOFFG, JC ), ILDA, X $ TEMP, EXTRA ) X ICOL = MAX( 1, JC-K+1 ) X CALL DLAROT( .TRUE., .FALSE., .TRUE., JC+2-ICOL, C, X $ S, A( JC-ISKEW*ICOL+IOFFG, ICOL ), X $ ILDA, DUMMY, TEMP ) X* X* Chase EXTRA back down the matrix X* X ICOL = JC X DO 220 JCH = JC + K, N - 1, K X CALL DLARTG( A( JCH-ISKEW*ICOL+IOFFG, ICOL ), X $ EXTRA, C, S, DUMMY ) X TEMP = A( 1+( 1-ISKEW )*JCH+IOFFG, JCH ) X CALL DLAROT( .TRUE., .TRUE., .TRUE., K+2, C, S, X $ A( JCH-ISKEW*ICOL+IOFFG, ICOL ), X $ ILDA, EXTRA, TEMP ) X IL = MIN( N+1-JCH, K+2 ) X EXTRA = ZERO X CALL DLAROT( .FALSE., .TRUE., N-JCH.GT.K, IL, C, X $ S, A( ( 1-ISKEW )*JCH+IOFFG, JCH ), X $ ILDA, TEMP, EXTRA ) X ICOL = JCH X 220 CONTINUE X 230 CONTINUE X 240 CONTINUE X* X* If we need upper triangle, copy from lower. X* Note that the order of copying is chosen X* to work for 'b' -> 'q' X* X IF( IPACK.NE.IPACKG .AND. IPACK.NE.4 ) THEN X DO 260 JC = N, 1, -1 X IROW = IOFFST - ISKEW*JC X DO 250 JR = JC, MAX( 1, JC-UUB ), -1 X A( JR+IROW, JC ) = A( JC-ISKEW*JR+IOFFG, JR ) X 250 CONTINUE X 260 CONTINUE X IF( IPACK.EQ.6 ) THEN X DO 280 JC = 1, UUB X DO 270 JR = 1, UUB + 1 - JC X A( JR, JC ) = ZERO X 270 CONTINUE X 280 CONTINUE X END IF X IF( IPACKG.EQ.5 ) THEN X IPACKG = IPACK X ELSE X IPACKG = 0 X END IF X END IF X END IF X* (END IF matches IF ( TOPDWN ) ) X END IF X* (END IF matches IF ( ISYM.EQ.1 ) ) X ELSE X* (ELSE matches ELSE IF ( GIVENS ) ) X* X*....................................................................... X* X* X* 4) Generate Banded Matrix by first X* Rotating by random Unitary matrices, X* then reducing the bandwidth using Householder X* transformations. X* X* Note: we should get here only if LDA .ge. N! X* X* X* - - - - - - - - - - - - - -- X CALL DCOPY( MNMIN, D, 1, A, LDA+1 ) X IF( ISYM.EQ.1 ) THEN X* . . . . . . . X* X* Non-symmetric -- A = U D V X* X* X CALL DLAROR( 'Left', 'No init', MR, NC, A, LDA, ISEED, WORK, X $ IINFO ) X IF( IINFO.NE.0 ) THEN X INFO = 3 X RETURN X END IF X CALL DLAROR( 'Right', 'No init', MR, NC, A, LDA, ISEED, X $ WORK, IINFO ) X IF( IINFO.NE.0 ) THEN X INFO = 3 X RETURN X END IF X* X* Reduce the bandwidth: X* X* special case if LLB = 0: kill row, then column X* X IF( LLB.EQ.0 ) THEN X DO 290 JRC = 1, MAX( MR, NC ) - 1 X IF( JRC.GT.UUB .AND. JRC.LE.MIN( MR+UUB, NC-1 ) ) THEN X IR = JRC - UUB X IROWS = MR + UUB - JRC X ICOLS = NC + 1 - JRC X* X CALL DCOPY( ICOLS, A( IR, JRC ), LDA, WORK, 1 ) X XNORMS = WORK( 1 ) X CALL DLARFG( ICOLS, XNORMS, WORK( 2 ), 1, TAU ) X WORK( 1 ) = ONE X* X CALL DGEMV( 'N', IROWS, ICOLS, ONE, A( IR+1, JRC ), X $ LDA, WORK, 1, ZERO, WORK( ICOLS+1 ), X $ 1 ) X CALL DGER( IROWS, ICOLS, -TAU, WORK( ICOLS+1 ), 1, X $ WORK, 1, A( IR+1, JRC ), LDA ) X* X A( IR, JRC ) = XNORMS X CALL DLAZRO( 1, ICOLS-1, ZERO, ZERO, X $ A( IR, JRC+1 ), LDA ) X END IF X* X IF( JRC.LE.MIN( MR-1, NC ) ) THEN X IROWS = MR + 1 - JRC X ICOLS = NC - JRC X CALL DCOPY( IROWS, A( JRC, JRC ), 1, WORK, 1 ) X XNORMS = WORK( 1 ) X CALL DLARFG( IROWS, XNORMS, WORK( 2 ), 1, TAU ) X WORK( 1 ) = ONE X* X CALL DGEMV( 'T', IROWS, ICOLS, ONE, X $ A( JRC, JRC+1 ), LDA, WORK, 1, ZERO, X $ WORK( IROWS+1 ), 1 ) X CALL DGER( IROWS, ICOLS, -TAU, WORK, 1, X $ WORK( IROWS+1 ), 1, A( JRC, JRC+1 ), X $ LDA ) X* X A( JRC, JRC ) = XNORMS X CALL DLAZRO( IROWS-1, 1, ZERO, ZERO, X $ A( JRC+1, JRC ), LDA ) X END IF X 290 CONTINUE X ELSE X* X* Reduce bandwidth -- Usual case: kill column, then row. X* X DO 300 JCR = MIN( LLB, UUB ) + 1, MAX( MR, NC ) - 1 X IF( JCR.GT.LLB .AND. JCR.LE.MIN( MR-1, NC+LLB ) ) THEN X IC = JCR - LLB X IROWS = MR + 1 - JCR X ICOLS = NC + LLB - JCR X* X CALL DCOPY( IROWS, A( JCR, IC ), 1, WORK, 1 ) X XNORMS = WORK( 1 ) X CALL DLARFG( IROWS, XNORMS, WORK( 2 ), 1, TAU ) X WORK( 1 ) = ONE X* X CALL DGEMV( 'T', IROWS, ICOLS, ONE, A( JCR, IC+1 ), X $ LDA, WORK, 1, ZERO, WORK( IROWS+1 ), X $ 1 ) X CALL DGER( IROWS, ICOLS, -TAU, WORK, 1, X $ WORK( IROWS+1 ), 1, A( JCR, IC+1 ), X $ LDA ) X* X A( JCR, IC ) = XNORMS X CALL DLAZRO( IROWS-1, 1, ZERO, ZERO, X $ A( JCR+1, IC ), LDA ) X END IF X* X IF( JCR.GT.UUB .AND. JCR.LE.MIN( MR+UUB, NC-1 ) ) THEN X IR = JCR - UUB X IROWS = MR + UUB - JCR X ICOLS = NC + 1 - JCR X* X CALL DCOPY( ICOLS, A( IR, JCR ), LDA, WORK, 1 ) X XNORMS = WORK( 1 ) X CALL DLARFG( ICOLS, XNORMS, WORK( 2 ), 1, TAU ) X WORK( 1 ) = ONE X* X CALL DGEMV( 'N', IROWS, ICOLS, ONE, A( IR+1, JCR ), X $ LDA, WORK, 1, ZERO, WORK( ICOLS+1 ), X $ 1 ) X CALL DGER( IROWS, ICOLS, -TAU, WORK( ICOLS+1 ), 1, X $ WORK, 1, A( IR+1, JCR ), LDA ) X* X A( IR, JCR ) = XNORMS X CALL DLAZRO( 1, ICOLS-1, ZERO, ZERO, X $ A( IR, JCR+1 ), LDA ) X END IF X 300 CONTINUE X END IF X ELSE X* . . . . . . . X* X* Symmetric -- A = U D U' X* X* X CALL DLAROR( 'Conjugate', 'No init', M, M, A, LDA, ISEED, X $ WORK, IINFO ) X IF( IINFO.NE.0 ) THEN X INFO = 3 X RETURN X END IF X* X* Reduce bandwidth -- Kill column, then row. X* X DO 310 JCR = LLB + 1, M - 1 X ICR = JCR - LLB X IRWCLS = M + 1 - JCR X ICLRWS = M + LLB - JCR X* X CALL DCOPY( IRWCLS, A( JCR, ICR ), 1, WORK, 1 ) X XNORMS = WORK( 1 ) X CALL DLARFG( IRWCLS, XNORMS, WORK( 2 ), 1, TAU ) X WORK( 1 ) = ONE X* X CALL DGEMV( 'T', IRWCLS, ICLRWS, ONE, A( JCR, ICR+1 ), X $ LDA, WORK, 1, ZERO, WORK( IRWCLS+1 ), 1 ) X CALL DGER( IRWCLS, ICLRWS, -TAU, WORK, 1, X $ WORK( IRWCLS+1 ), 1, A( JCR, ICR+1 ), LDA ) X* X CALL DGEMV( 'N', ICLRWS, IRWCLS, ONE, A( ICR+1, JCR ), X $ LDA, WORK, 1, ZERO, WORK( IRWCLS+1 ), 1 ) X CALL DGER( ICLRWS, IRWCLS, -TAU, WORK( IRWCLS+1 ), 1, X $ WORK, 1, A( ICR+1, JCR ), LDA ) X* X A( JCR, ICR ) = XNORMS X CALL DLAZRO( IRWCLS-1, 1, ZERO, ZERO, A( JCR+1, ICR ), X $ LDA ) X A( ICR, JCR ) = XNORMS X CALL DLAZRO( 1, IRWCLS-1, ZERO, ZERO, A( ICR, JCR+1 ), X $ LDA ) X* X 310 CONTINUE X* X* Enforce Symmetry X* X DO 330 JC = 2, M X DO 320 JR = 1, JC - 1 X A( JC, JR ) = A( JR, JC ) X 320 CONTINUE X 330 CONTINUE X* . . . . . . . X END IF X* - - - - - - - - - - - - - - X END IF X* ( END IF matches ELSE IF ( GIVENS ) ) X* X*....................................................................... X* X* 5) Pack the matrix X* X* X* 'U' -- Upper triangular, not packed X* X IF( IPACK.NE.IPACKG ) THEN X IF( IPACK.EQ.1 ) THEN X DO 350 J = 1, M X DO 340 I = J + 1, M X A( I, J ) = ZERO X 340 CONTINUE X 350 CONTINUE X* X* 'L' -- Lower triangular, not packed X* X ELSE IF( IPACK.EQ.2 ) THEN X DO 370 J = 2, M X DO 360 I = 1, J - 1 X A( I, J ) = ZERO X 360 CONTINUE X 370 CONTINUE X* X* 'C' -- Upper triangle packed Columnwise. X* X ELSE IF( IPACK.EQ.3 ) THEN X ICOL = 1 X IROW = 0 X DO 390 J = 1, M X DO 380 I = 1, J X IROW = IROW + 1 X IF( IROW.GT.LDA ) THEN X IROW = 1 X ICOL = ICOL + 1 X END IF X A( IROW, ICOL ) = A( I, J ) X 380 CONTINUE X 390 CONTINUE X* X* 'R' -- Lower triangle packed Columnwise. X* X ELSE IF( IPACK.EQ.4 ) THEN X ICOL = 1 X IROW = 0 X DO 410 J = 1, M X DO 400 I = J, M X IROW = IROW + 1 X IF( IROW.GT.LDA ) THEN X IROW = 1 X ICOL = ICOL + 1 X END IF X A( IROW, ICOL ) = A( I, J ) X 400 CONTINUE X 410 CONTINUE X* X* 'B' -- The lower triangle is packed as a band matrix. X* 'Q' -- The upper triangle is packed as a band matrix. X* 'Z' -- The whole matrix is packed as a band matrix. X* X ELSE IF( IPACK.GE.5 ) THEN X IF( IPACK.EQ.5 ) X $ UUB = 0 X IF( IPACK.EQ.6 ) X $ LLB = 0 X* X DO 430 J = 1, UUB X DO 420 I = MIN( J+LLB, M ), 1, -1 X A( I-J+UUB+1, J ) = A( I, J ) X 420 CONTINUE X 430 CONTINUE X* X DO 450 J = UUB + 2, N X DO 440 I = J - UUB, MIN( J+LLB, M ) X A( I-J+UUB+1, J ) = A( I, J ) X 440 CONTINUE X 450 CONTINUE X END IF X* X* X* If packed, zero out extraneous elements. X* X* Symmetric/Triangular Packed -- X* zero out everything after A(IROW,ICOL) X* X IF( IPACK.EQ.3 .OR. IPACK.EQ.4 ) THEN X DO 470 JC = ICOL, M X DO 460 JR = IROW + 1, LDA X A( JR, JC ) = ZERO X 460 CONTINUE X IROW = 0 X 470 CONTINUE X* X* Packed Band -- X* 1st row is now in A( UUB+2-j, j), zero above it X* m-th row is now in A( M+UUB-j,j), zero below it X* last non-zero diagonal is now in A( UUB+LLB+1,j ), zero X* below it, too. X* X ELSE IF( IPACK.GE.5 ) THEN X IR1 = UUB + LLB + 2 X IR2 = UUB + M + 2 X DO 500 JC = 1, N X DO 480 JR = 1, UUB + 1 - JC X A( JR, JC ) = ZERO X 480 CONTINUE X DO 490 JR = MIN( IR1, IR2-JC ), LDA X A( JR, JC ) = ZERO X 490 CONTINUE X 500 CONTINUE X END IF X END IF X* ( END IF matches IF ( IPACK .NE. IPACKG ) ) X* X* X*....................................................................... X* X RETURN X* X*....................................................................... X* X* End of DLATMS X* X END END_OF_FILE if test 46676 -ne `wc -c <'dlatms.f'`; then echo shar: \"'dlatms.f'\" unpacked with wrong size! fi # end of 'dlatms.f' fi if test -f 'dlatrs.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlatrs.f'\" else echo shar: Extracting \"'dlatrs.f'\" \(15305 characters\) sed "s/^X//" >'dlatrs.f' <<'END_OF_FILE' X SUBROUTINE DLATRS( UPLO, TRANS, RCNRM, N, T, LDT, X, SCALE, CNORM, X $ INFO ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER RCNRM, TRANS, UPLO X INTEGER INFO, LDT, N X DOUBLE PRECISION SCALE X* .. X* X* .. Array Arguments .. X DOUBLE PRECISION CNORM( * ), T( LDT, * ), X( * ) X* .. X* X* Purpose X* ======= X* X* Solve the (triangular) system: X* X* T x = scale*b X* or X* T' x = scale*b X* X* where T is an upper or lower triangular matrix, T' denotes X* the transpose of T, and "scale" is a scale factor, X* 1 or less, chosen so that x will be less than the overflow X* threshhold. A rough bound on x is computed: if that is less X* than overflow, DTRSV is called, otherwise, specific code is X* used to perform the same function which checks for possible X* overflow or divide-by-zero at every operation. The tests X* are chosen so that neither overflow nor divide-by-zero will X* ever happen if the absolute sum of all elements of T and b X* can be computed without overflow. X* X* X* Discussion X* ---------- X* X* For simplicity, we only describe the method for T upper X* triangular. X* X* For solving T x = b: X* --- ------- ------- X* X* a "columnwise" scheme is used, i.e., if d[1],...,d[j] are the X* diagonal elements, b[1:j-1] denotes the first j-1 elements of X* b, and C[j] is the j-th column *without* the diagonal element, X* then the method is: X* X* For j=n,...,1 X* x[j] = b[j]/d[j] X* b[1:j-1] = b[1:j-1] - x[j]*C[j] X* X* We have a bound on the max-norm of "b(j+1)", the j+1-st iterate X* of b (j=0,...,n-1): X* X* ( C[n-j] e[n-j]') X* b(j+1) = b(j) - x[n-j]*C[n-j] = ( I - ------------- ) b(j) X* ( d[n-j] ) X* X* where e[j] is the row vector with all zeros except for X* the j-th entry, which is 1. X* X* |b(j+1)| <= | I - C[n-j] e[n-j]' | |b(j)| X* X* = ( 1 + |C[n-j]|/|d[n-j]| ) |b(j)| X* X* <= |b(0)| prod ( 1 + |C[k]|/|d[k]| ) X* k>=n-j X* X* where the norms are all max-norms. The bound on x[j] is then: X* X* |x[j]| <= |b(n-j)| / |d[j]| X* X* |b(0)| X* <= ------ prod ( 1 + |C[k]|/|d[k]| ) X* |d[j]| k>j X* X* Therefor, we may use DTRSV without fear of overflow if X* X* 1 |d[1]| n ( |d[k]| ) X* - = ------ prod ( --------------- ) X* G |b(0)| k=2 ( |d[k]| + |C[k]| ) X* X* is larger than max( underflow , 1/overflow ), and all the X* |d[k]| are, too. Note that we compute 1/G, and not G, because X* 1/G will just (harmlessly) underflow if G would overflow. X* X* The bounds on b(j) and x[j] also allow us to determine when a X* step in the columnwise method can be performed without fear of X* overflow. If either bound will be greater than overflow, both X* the (updated) b and x as computed so far are scaled so that X* the max-norm of that x is 1, and "scale" is updated; the X* method then continues. If a diagonal element is 0 (or very X* close to it), scale is set to zero, b and x are set to zero, X* and then x[j] is set to 1. X* X* X* For solving T' x = b: X* --- ------- -------- X* X* a "rowwise" scheme is used, i.e.: X* X* For j=1,...,n X* x[j] = ( b[j] - x[1:j-1].C[j] ) / d[j] X* X* noting that C[j] is the j-th *row* of T', and T' is lower X* triangular. X* X* X* We have the bound on x[j]: X* X* |b[j]| + |C[j]| X* |x[j]| <= --------------- max( 1, |x[1]|, ..., |x[j-1]| ) X* |d[j]| X* X* |b[k]| + |C[k]| X* <= prod max( 1, --------------- ) X* k<=j |d[k]| X* X* where |C[k]| is the *1-norm* of column k of T. We therefor test X* X* 1 n |d[k]| X* - = prod min ( 1, --------------- ) X* G k=1 |b[k]| + |C[k]| X* X* X* X* X* X* Arguments X* ========= X* X* UPLO - CHARACTER*1 X* UPLO specifies whether the matrix T is upper or lower X* triangular: X* If UPLO = 'U', T is upper triangular. X* If UPLO = 'L', T is lower triangular. X* Not modified. X* X* TRANS - CHARACTER*1 X* The transpose option: X* If TRANS = 'N', solve Tx = b X* If TRANS = 'T' or 'C', solve T'x = b X* Not modified. X* X* RCNRM - CHARACTER*1 X* Specifies whether CNORM has be set or not. X* If RCNRM = 'Y', CNORM already contains the column norms. X* If RCNRM = 'N', DLATRS must compute the appropriate X* column norms and store them in CNORM. X* Not modified. X* X* N - INTEGER X* The order of matrix T. N must be at least zero. X* Not modified. X* X* T - DOUBLE PRECISION array, dimension (LDT,N) X* The upper or lower triangular matrix. X* Not modified. X* X* LDT - INTEGER X* The first dimension of T as declared in the calling X* (sub)program. LDT must be at least max(1, N). X* Not modified. X* X* X - DOUBLE PRECISION array, dimension (N) X* On entry, X contains the right-side of the triangular X* system. X* On exit, X is overwritten by the solution. X* Modified. X* X* SCALE - DOUBLE PRECISION X* On exit, SCALE is the scaling factor used in the X* triangular solver. X* Modified. X* X* CNORM - DOUBLE PRECISION array, dimension (N) X* On entry, if RCNRM = 'Y', then for j=1,..,N, CNORM(j) X* contains the norm of the off-diagonal part of the j-th X* column of T. If TRANS='C', then it must be (at least) X* the 1-norm; if TRANS='N', it must be (at least) the max-norm X* of the (off-diagonal part of the) column. If RCNRM='N', X* then CNORM(j) will be set to the 1-norm of the off-diagonal X* part of the j-th column. X* Modified if RCNRM='N'. X* X* INFO - INTEGER X* On exit, INFO is set to X* 0 for normal return. X* -k if input argument number k is illegal. X* Modified. X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE X PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) X* .. X* X* .. Local Scalars .. X INTEGER I, IFIRST, IINC, ILAST, IOFFST, ITRANS, IUPLO, X $ J, K, NRM X DOUBLE PRECISION BIGNUM, BJ, BMAX, GROW, OVFL, REC, SMLNUM, TJJ, X $ ULP, UNFL, XJ, XMAX X* .. X* X* .. External Functions .. X LOGICAL LSAME X DOUBLE PRECISION DDOT, DLAMCH X EXTERNAL LSAME, DDOT, DLAMCH X* .. X* X* .. External Subroutines .. X EXTERNAL DAXPY, DLABAD, DSCAL, DTRSV, XERBLA X* .. X* X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX X* .. X* X* X* .. Executable Statements .. X* X* Decode and Test the input parameters X* X IF( LSAME( UPLO, 'U' ) ) THEN X IUPLO = 1 X ELSE IF( LSAME( UPLO, 'L' ) ) THEN X IUPLO = 2 X ELSE X IUPLO = -1 X END IF X* X IF( LSAME( TRANS, 'N' ) ) THEN X ITRANS = 1 X ELSE IF( LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) ) THEN X ITRANS = 2 X ELSE X ITRANS = -1 X END IF X* X IF( LSAME( RCNRM, 'Y' ) ) THEN X NRM = 1 X ELSE IF( LSAME( RCNRM, 'N' ) ) THEN X NRM = 2 X ELSE X NRM = -1 X END IF X* X INFO = 0 X IF( IUPLO.EQ.-1 ) THEN X INFO = -1 X ELSE IF( ITRANS.EQ.-1 ) THEN X INFO = -2 X ELSE IF( NRM.EQ.-1 ) THEN X INFO = -3 X ELSE IF( N.LT.0 ) THEN X INFO = -4 X ELSE IF( LDT.LT.MAX( 1, N ) ) THEN X INFO = -6 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DLATRS', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.EQ.0 ) X $ RETURN X* X* Determine machine dependent parameters to control overflow. X* X UNFL = DLAMCH( 'Safe minimum' ) X OVFL = DLAMCH( 'Overflow' ) X CALL DLABAD( UNFL, OVFL ) X ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) X SMLNUM = MAX( UNFL*( N/ULP ), N/( ULP*OVFL ) ) X BIGNUM = ( ONE-ULP ) / SMLNUM X SCALE = ONE X* X* Compute the 1-norm of each column, if CNORM is not already set. X* X IF( NRM.EQ.2 ) THEN X IF( IUPLO.EQ.1 ) THEN X CNORM( 1 ) = ZERO X DO 20 J = 2, N X CNORM( J ) = ZERO X DO 10 I = 1, J - 1 X CNORM( J ) = CNORM( J ) + ABS( T( I, J ) ) X 10 CONTINUE X 20 CONTINUE X ELSE X DO 40 J = 1, N - 1 X CNORM( J ) = ZERO X DO 30 I = J + 1, N X CNORM( J ) = CNORM( J ) + ABS( T( I, J ) ) X 30 CONTINUE X 40 CONTINUE X CNORM( N ) = ZERO X END IF X END IF X* X* X* X* Solve the system T*x = b X* X* X* X IF( ITRANS.EQ.1 ) THEN X IF( IUPLO.EQ.1 ) THEN X IFIRST = N X ILAST = 1 X IINC = -1 X IOFFST = 0 X ELSE X IFIRST = 1 X ILAST = N X IINC = 1 X IOFFST = -1 X END IF X* X* Compute GROW = 1/G and |b(0)| (for columnwise method) X* X BMAX = ZERO X DO 50 J = 1, N X BMAX = MAX( BMAX, ABS( X( J ) ) ) X 50 CONTINUE X* X TJJ = ABS( T( ILAST, ILAST ) ) X IF( BMAX.LT.ONE .AND. TJJ.GT.ONE ) THEN X GROW = ONE / MAX( SMLNUM, BMAX/TJJ ) X ELSE X GROW = TJJ / MAX( SMLNUM, BMAX ) X END IF X* X DO 60 J = IFIRST, ILAST - IINC, IINC X IF( GROW.LE.SMLNUM ) X $ GO TO 70 X TJJ = ABS( T( J, J ) ) X IF( TJJ.LT.SMLNUM ) THEN X GROW = ZERO X ELSE X GROW = GROW*( TJJ/( TJJ+CNORM( J ) ) ) X END IF X 60 CONTINUE X 70 CONTINUE X* X IF( GROW.GT.SMLNUM ) THEN X* X* Use DTRSV (the BLAS 2 solver) X* X CALL DTRSV( UPLO, 'N', 'N', N, T, LDT, X, 1 ) X RETURN X* X* BLAS 1 solver X* X ELSE X* X DO 100 J = IFIRST, ILAST, IINC X* X* x(j) = b(j) / t(j,j) X* X TJJ = ABS( T( J, J ) ) X IF( TJJ.GT.SMLNUM ) THEN X XJ = ABS( X( J ) ) X IF( TJJ.LT.ONE ) THEN X IF( XJ.GT.TJJ*BIGNUM ) THEN X REC = ONE / XJ X CALL DSCAL( N, REC, X, 1 ) X XJ = ONE X SCALE = SCALE*REC X BMAX = BMAX*REC X END IF X END IF X X( J ) = X( J ) / T( J, J ) X ELSE X DO 80 K = 1, N X X( K ) = ZERO X 80 CONTINUE X X( J ) = ONE X XJ = ONE X SCALE = ZERO X BMAX = ZERO X END IF X* X* update right-hand side X* b = b - t(:,j)*x(j) X* X IF( XJ.GT.ONE ) THEN X REC = ONE / XJ X IF( CNORM( J ).GT.( BIGNUM-BMAX )*REC ) THEN X CALL DSCAL( N, REC, X, 1 ) X SCALE = SCALE*REC X XJ = XJ*REC X BMAX = ZERO X DO 90 K = J + IINC, ILAST, IINC X BMAX = MAX( BMAX, ABS( X( K ) ) ) X 90 CONTINUE X END IF X END IF X* X IF( IUPLO.EQ.1 ) THEN X CALL DAXPY( J-1, -X( J ), T( 1, J ), 1, X, 1 ) X ELSE X CALL DAXPY( N-J, -X( J ), T( J+1, J ), 1, X( J+1 ), X $ 1 ) X END IF X BMAX = BMAX + XJ*CNORM( J ) X* X 100 CONTINUE X* X RETURN X END IF X* (matches IF (GROW .GT. SMLNUM) ... ELSE ...) X* X* X* Solve system T'*x = b X* X* X ELSE X* (matches IF ( ITRANS .EQ. 1 ) ) X* X* Compute GROW = 1/G (for rowwise method) X* X GROW = ONE X DO 110 J = 1, N X TJJ = ABS( T( J, J ) ) X BJ = ABS( X( J ) ) + CNORM( J ) X IF( TJJ.LT.SMLNUM ) THEN X GROW = ZERO X GO TO 120 X END IF X IF( BJ.GT.TJJ ) X $ GROW = GROW*( TJJ/BJ ) X 110 CONTINUE X* X 120 CONTINUE X* X* X* BLAS 2 solver X* X* X IF( GROW.GT.SMLNUM ) THEN X CALL DTRSV( UPLO, 'C', 'N', N, T, LDT, X, 1 ) X RETURN X ELSE X* X* X* BLAS 1 solver X* X* X IF( IUPLO.EQ.1 ) THEN X IFIRST = 1 X ILAST = N X IINC = 1 X ELSE X IFIRST = N X ILAST = 1 X IINC = -1 X END IF X* X XMAX = ONE X* X DO 140 J = IFIRST, ILAST, IINC X* X* Form s = b(j) - sum t(k,j)*x(k) X* k#j X* X* scaling x and b if necessary. X* X IF( XMAX.GT.ONE ) THEN X BJ = ABS( X( J ) ) X REC = ONE / XMAX X IF( CNORM( J ).GT.( BIGNUM-BJ )*REC ) THEN X CALL DSCAL( N, REC, X, 1 ) X SCALE = SCALE*REC X XMAX = ONE X END IF X END IF X IF( IUPLO.EQ.1 ) THEN X X( J ) = X( J ) - DDOT( J-1, T( 1, J ), 1, X, 1 ) X ELSE X X( J ) = X( J ) - DDOT( N-J, T( J+1, J ), 1, X( J+1 ), X $ 1 ) X END IF X* X* x(j) = b(j) / t(j,j) X* X TJJ = ABS( T( J, J ) ) X IF( TJJ.GT.SMLNUM ) THEN X IF( TJJ.LT.ONE ) THEN X XJ = ABS( X( J ) ) X IF( XJ.GT.TJJ*BIGNUM ) THEN X REC = ONE / XJ X CALL DSCAL( N, REC, X, 1 ) X SCALE = SCALE*REC X XMAX = XMAX*REC X END IF X END IF X X( J ) = X( J ) / T( J, J ) X XMAX = MAX( XMAX, ABS( X( J ) ) ) X ELSE X DO 130 K = 1, N X X( K ) = ZERO X 130 CONTINUE X X( J ) = ONE X SCALE = ZERO X XMAX = ONE X END IF X* X 140 CONTINUE X* X RETURN X END IF X* (matches IF (GROW .GT. SMLNUM) ... ELSE ...) X END IF X* (matches IF ( ITRANS .EQ. 1 ) ... ELSE ...) X* X* X* End of DLATRS X* X END END_OF_FILE if test 15305 -ne `wc -c <'dlatrs.f'`; then echo shar: \"'dlatrs.f'\" unpacked with wrong size! fi # end of 'dlatrs.f' fi if test -f 'dlazro.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dlazro.f'\" else echo shar: Extracting \"'dlazro.f'\" \(1736 characters\) sed "s/^X//" >'dlazro.f' <<'END_OF_FILE' X SUBROUTINE DLAZRO( M, N, ALPHA, BETA, A, LDA ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X INTEGER LDA, M, N X DOUBLE PRECISION ALPHA, BETA X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ) X* .. X* X* Purpose X* ======= X* X* DLAZRO initializes a 2-D array A to BETA on the diagonal and X* ALPHA on the offdiagonals. X* X* Arguments X* ========= X* X* M (input) INTEGER X* The number of rows of the matrix A. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix A. N >= 0. X* X* ALPHA (input) DOUBLE PRECISION X* The constant to which the offdiagonal elements are to be set. X* X* BETA (input) DOUBLE PRECISION X* The constant to which the diagonal elements are to be set. X* X* A (output) DOUBLE PRECISION array, dimension( LDA, N ) X* On exit, the leading m x n submatrix of A is set such that X* A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i <> j X* A(i,i) = BETA, 1 <= i <= min(m,n). X* X* LDA (input) INTEGER X* The leading dimension of the array A. LDA >= max(1,M). X* X* .. Local Scalars .. X INTEGER I, J X* .. X* .. Intrinsic Functions .. X INTRINSIC MIN X* .. X* .. Executable Statements .. X* X DO 20 J = 1, N X DO 10 I = 1, M X A( I, J ) = ALPHA X 10 CONTINUE X 20 CONTINUE X* X DO 30 I = 1, MIN( M, N ) X A( I, I ) = BETA X 30 CONTINUE X* X RETURN X* X* End of DLAZRO X* X END END_OF_FILE if test 1736 -ne `wc -c <'dlazro.f'`; then echo shar: \"'dlazro.f'\" unpacked with wrong size! fi # end of 'dlazro.f' fi if test -f 'dmachr.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dmachr.f'\" else echo shar: Extracting \"'dmachr.f'\" \(11380 characters\) sed "s/^X//" >'dmachr.f' <<'END_OF_FILE' X X subroutine dmachr( ibeta, it, irnd, ngrd, machep, negep, iexp, X $ minexp, maxexp, eps, epsneg, xmin, xmax ) X* X* -- lapack auxiliary routine -- X* argonne national lab, courant institute, and n.a.g. ltd. X* april 1, 1989 X* X* .. scalar arguments .. X integer ibeta, iexp, irnd, it, machep, maxexp, minexp, X $ negep, ngrd X double precision eps, epsneg, xmax, xmin X* .. X* X* purpose X* ======= X* X* smachr computes double precision machine parameters. this is X* the double precision version of machar, contributed by X* w. j. cody, argonne national laboratory. X* X*----------------------------------------------------------------------- X* this fortran 77 subroutine is intended to determine the parameters X* of the floating-point arithmetic system specified below. the X* determination of the first three uses an extension of an algorithm X* due to m. malcolm, cacm 15 (1972), pp. 949-951, incorporating some, X* but not all, of the improvements suggested by m. gentleman and s. X* marovich, cacm 17 (1974), pp. 276-277. an earlier version of this X* program was published in the book software manual for the X* elementary functions by w. j. cody and w. waite, prentice-hall, X* englewood cliffs, nj, 1980. the present version is documented in X* w. j. cody, "machar: a subroutine to dynamically determine machine X* parameters," toms 14, december, 1988. X* X* parameter values reported are as follows: X* X* ibeta - the radix for the floating-point representation X* it - the number of base ibeta digits in the floating-point X* significand X* irnd - 0 if floating-point addition chops X* 1 if floating-point addition rounds, but not in the X* ieee style X* 2 if floating-point addition rounds in the ieee style X* 3 if floating-point addition chops, and there is X* partial underflow X* 4 if floating-point addition rounds, but not in the X* ieee style, and there is partial underflow X* 5 if floating-point addition rounds in the ieee style, X* and there is partial underflow X* ngrd - the number of guard digits for multiplication with X* truncating arithmetic. it is X* 0 if floating-point arithmetic rounds, or if it X* truncates and only it base ibeta digits X* participate in the post-normalization shift of the X* floating-point significand in multiplication; X* 1 if floating-point arithmetic truncates and more X* than it base ibeta digits participate in the X* post-normalization shift of the floating-point X* significand in multiplication. X* machep - the largest negative integer such that X* 1.0+float(ibeta)**machep .ne. 1.0, except that X* machep is bounded below by -(it+3) X* negeps - the largest negative integer such that X* 1.0-float(ibeta)**negeps .ne. 1.0, except that X* negeps is bounded below by -(it+3) X* iexp - the number of bits (decimal places if ibeta = 10) X* reserved for the representation of the exponent X* (including the bias or sign) of a floating-point X* number X* minexp - the largest in magnitude negative integer such that X* float(ibeta)**minexp is positive and normalized X* maxexp - the smallest positive power of beta that overflows X* eps - the smallest positive floating-point number such X* that 1.0+eps .ne. 1.0. in particular, if either X* ibeta = 2 or irnd = 0, eps = float(ibeta)**machep. X* otherwise, eps = (float(ibeta)**machep)/2 X* epsneg - a small positive floating-point number such that X* 1.0-epsneg .ne. 1.0. in particular, if ibeta = 2 X* or irnd = 0, epsneg = float(ibeta)**negeps. X* otherwise, epsneg = (ibeta**negeps)/2. because X* negeps is bounded below by -(it+3), epsneg may not X* be the smallest number that can alter 1.0 by X* subtraction. X* xmin - the smallest non-vanishing normalized floating-point X* power of the radix, i.e., xmin = float(ibeta)**minexp X* xmax - the largest finite floating-point number. in X* particular xmax = (1.0-epsneg)*float(ibeta)**maxexp X* note - on some machines xmax will be only the X* second, or perhaps third, largest number, being X* too small by 1 or 2 units in the last digit of X* the significand. X* X* latest revision - december 4, 1987 X* X* author - w. j. cody X* argonne national laboratory X*----------------------------------------------------------------------- X* X* .. local scalars .. X integer i, itemp, iz, j, k, mx, nxres X double precision a, b, beta, betah, betain, one, t, temp, temp1, X $ tempa, two, y, z, zero X* .. X* .. intrinsic functions .. X intrinsic abs, int, dble X* .. X* .. statement functions .. X double precision conv X* .. X* .. statement function definitions .. X conv( i ) = dble( i ) X* .. X* .. executable statements .. X* X one = conv( 1 ) X two = one + one X zero = one - one X*----------------------------------------------------------------------- X* determine ibeta, beta ala malcolm. X*----------------------------------------------------------------------- X a = one X 10 a = a + a X temp = a + one X temp1 = temp - a X if( temp1-one.eq.zero ) X $ go to 10 X b = one X 20 b = b + b X temp = a + b X itemp = int( temp-a ) X if( itemp.eq.0 ) X $ go to 20 X ibeta = itemp X beta = conv( ibeta ) X*----------------------------------------------------------------------- X* determine it, irnd. X*----------------------------------------------------------------------- X it = 0 X b = one X 30 it = it + 1 X b = b*beta X temp = b + one X temp1 = temp - b X if( temp1-one.eq.zero ) X $ go to 30 X irnd = 0 X betah = beta / two X temp = a + betah X if( temp-a.ne.zero ) X $ irnd = 1 X tempa = a + beta X temp = tempa + betah X if( ( irnd.eq.0 ) .and. ( temp-tempa.ne.zero ) ) X $ irnd = 2 X*----------------------------------------------------------------------- X* determine negep, epsneg. X*----------------------------------------------------------------------- X negep = it + 3 X betain = one / beta X a = one X do 40 i = 1, negep X a = a*betain X 40 continue X b = a X 50 temp = one - a X if( temp-one.ne.zero ) X $ go to 60 X a = a*beta X negep = negep - 1 X go to 50 X 60 negep = -negep X epsneg = a X*----------------------------------------------------------------------- X* determine machep, eps. X*----------------------------------------------------------------------- X machep = -it - 3 X a = b X 70 temp = one + a X if( temp-one.ne.zero ) X $ go to 80 X a = a*beta X machep = machep + 1 X go to 70 X 80 eps = a X*----------------------------------------------------------------------- X* determine ngrd. X*----------------------------------------------------------------------- X ngrd = 0 X temp = one + eps X if( ( irnd.eq.0 ) .and. ( temp*one-one.ne.zero ) ) X $ ngrd = 1 X*----------------------------------------------------------------------- X* determine iexp, minexp, xmin. X* X* loop to determine largest i and k = 2**i such that X* (1/beta) ** (2**(i)) X* does not underflow. X* exit from loop is signaled by an underflow. X*----------------------------------------------------------------------- X i = 0 X k = 1 X z = betain X t = one + eps X nxres = 0 X 90 y = z X z = y*y X*----------------------------------------------------------------------- X* check for underflow here. X*----------------------------------------------------------------------- X a = z*one X temp = z*t X if( ( a+a.eq.zero ) .or. ( abs( z ).ge.y ) ) X $ go to 100 X temp1 = temp*betain X if( temp1*beta.eq.z ) X $ go to 100 X i = i + 1 X k = k + k X go to 90 X 100 if( ibeta.eq.10 ) X $ go to 110 X iexp = i + 1 X mx = k + k X go to 140 X*----------------------------------------------------------------------- X* this segment is for decimal machines only. X*----------------------------------------------------------------------- X 110 iexp = 2 X iz = ibeta X 120 if( k.lt.iz ) X $ go to 130 X iz = iz*ibeta X iexp = iexp + 1 X go to 120 X 130 mx = iz + iz - 1 X*----------------------------------------------------------------------- X* loop to determine minexp, xmin. X* exit from loop is signaled by an underflow. X*----------------------------------------------------------------------- X 140 xmin = y X y = y*betain X*----------------------------------------------------------------------- X* check for underflow here. X*----------------------------------------------------------------------- X a = y*one X temp = y*t X if( ( ( a+a ).eq.zero ) .or. ( abs( y ).ge.xmin ) ) X $ go to 150 X k = k + 1 X temp1 = temp*betain X if( ( temp1*beta.ne.y ) .or. ( temp.eq.y ) ) then X go to 140 X else X nxres = 3 X xmin = y X end if X 150 minexp = -k X*----------------------------------------------------------------------- X* determine maxexp, xmax. X*----------------------------------------------------------------------- X if( ( mx.gt.k+k-3 ) .or. ( ibeta.eq.10 ) ) X $ go to 160 X mx = mx + mx X iexp = iexp + 1 X 160 maxexp = mx + minexp X*----------------------------------------------------------------- X* adjust irnd to reflect partial underflow. X*----------------------------------------------------------------- X irnd = irnd + nxres X*----------------------------------------------------------------- X* adjust for ieee-style machines. X*----------------------------------------------------------------- X if( irnd.ge.2 ) X $ maxexp = maxexp - 2 X*----------------------------------------------------------------- X* adjust for machines with implicit leading bit in binary X* significand, and machines with radix point at extreme X* right of significand. X*----------------------------------------------------------------- X i = maxexp + minexp X if( ( ibeta.eq.2 ) .and. ( i.eq.0 ) ) X $ maxexp = maxexp - 1 X if( i.gt.20 ) X $ maxexp = maxexp - 1 X if( a.ne.y ) X $ maxexp = maxexp - 2 X xmax = one - epsneg X if( xmax*one.ne.xmax ) X $ xmax = one - beta*epsneg X xmax = xmax / ( beta*beta*beta*xmin ) X i = maxexp + minexp + 3 X if( i.le.0 ) X $ go to 180 X do 170 j = 1, i X if( ibeta.eq.2 ) X $ xmax = xmax + xmax X if( ibeta.ne.2 ) X $ xmax = xmax*beta X 170 continue X 180 return X* X* end of dmachr X* X end END_OF_FILE if test 11380 -ne `wc -c <'dmachr.f'`; then echo shar: \"'dmachr.f'\" unpacked with wrong size! fi # end of 'dmachr.f' fi if test -f 'dnrm2.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dnrm2.f'\" else echo shar: Extracting \"'dnrm2.f'\" \(4558 characters\) sed "s/^X//" >'dnrm2.f' <<'END_OF_FILE' X DOUBLE PRECISION FUNCTION DNRM2( N, DX, INCX ) X* .. Scalar Arguments .. X INTEGER INCX, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION DX( 1 ) X* .. X* .. Local Scalars .. X INTEGER I, IX, J, NEXT X DOUBLE PRECISION CUTHI, CUTLO, HITEST, ONE, SUM, XMAX, ZERO X* .. X* .. Intrinsic Functions .. X INTRINSIC DABS, DSQRT, FLOAT X* .. X* .. Data statements .. X* X* euclidean norm of the n-vector stored in dx() with storage X* increment incx . X* if n .le. 0 return with result = 0. X* if n .ge. 1 then incx must be .ge. 1 X* X* c.l.lawson, 1978 jan 08 X* modified to correct problem with negative increment, 8/21/90. X* X* four phase method using two built-in constants that are X* hopefully applicable to all machines. X* cutlo = maximum of dsqrt(u/eps) over all known machines. X* cuthi = minimum of dsqrt(v) over all known machines. X* where X* eps = smallest no. such that eps + 1. .gt. 1. X* u = smallest positive no. (underflow limit) X* v = largest no. (overflow limit) X* X* brief outline of algorithm.. X* X* phase 1 scans zero components. X* move to phase 2 when a component is nonzero and .le. cutlo X* move to phase 3 when a component is .gt. cutlo X* move to phase 4 when a component is .ge. cuthi/m X* where m = n for x() real and m = 2*n for complex. X* X* values for cutlo and cuthi.. X* from the environmental parameters listed in the imsl converter X* document the limiting values are as follows.. X* cutlo, s.p. u/eps = 2**(-102) for honeywell. close seconds are X* univac and dec at 2**(-103) X* thus cutlo = 2**(-51) = 4.44089e-16 X* cuthi, s.p. v = 2**127 for univac, honeywell, and dec. X* thus cuthi = 2**(63.5) = 1.30438e19 X* cutlo, d.p. u/eps = 2**(-67) for honeywell and dec. X* thus cutlo = 2**(-33.5) = 8.23181d-11 X* cuthi, d.p. same as s.p. cuthi = 1.30438d19 X* data cutlo, cuthi / 8.232d-11, 1.304d19 / X* data cutlo, cuthi / 4.441e-16, 1.304e19 / X DATA ZERO, ONE / 0.0D0, 1.0D0 / X DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / X* .. X* .. Executable Statements .. X* X IF( N.GT.0 ) X $ GO TO 10 X DNRM2 = ZERO X GO TO 140 X* X 10 CONTINUE X ASSIGN 30 TO NEXT X SUM = ZERO X I = 1 X IF( INCX.LT.0 ) X $ I = ( -N+1 )*INCX + 1 X IX = 1 X* begin main loop X 20 CONTINUE X GO TO NEXT( 30, 40, 70, 80 ) X 30 CONTINUE X IF( DABS( DX( I ) ).GT.CUTLO ) X $ GO TO 110 X ASSIGN 40 TO NEXT X XMAX = ZERO X* X* phase 1. sum is zero X* X 40 CONTINUE X IF( DX( I ).EQ.ZERO ) X $ GO TO 130 X IF( DABS( DX( I ) ).GT.CUTLO ) X $ GO TO 110 X* X* prepare for phase 2. X ASSIGN 70 TO NEXT X GO TO 60 X* X* prepare for phase 4. X* X 50 CONTINUE X ASSIGN 80 TO NEXT X SUM = ( SUM/DX( I ) ) / DX( I ) X 60 CONTINUE X XMAX = DABS( DX( I ) ) X GO TO 90 X* X* phase 2. sum is small. X* scale to avoid destructive underflow. X* X 70 CONTINUE X IF( DABS( DX( I ) ).GT.CUTLO ) X $ GO TO 100 X* X* common code for phases 2 and 4. X* in phase 4 sum is large. scale to avoid overflow. X* X 80 CONTINUE X IF( DABS( DX( I ) ).LE.XMAX ) X $ GO TO 90 X SUM = ONE + SUM*( XMAX/DX( I ) )**2 X XMAX = DABS( DX( I ) ) X GO TO 130 X* X 90 CONTINUE X SUM = SUM + ( DX( I )/XMAX )**2 X GO TO 130 X* X* X* prepare for phase 3. X* X 100 CONTINUE X SUM = ( SUM*XMAX )*XMAX X* X* X* for real or d.p. set hitest = cuthi/n X* for complex set hitest = cuthi/(2*n) X* X 110 CONTINUE X HITEST = CUTHI / FLOAT( N ) X* X* phase 3. sum is mid-range. no scaling. X* X DO 120 J = IX, N X IF( DABS( DX( I ) ).GE.HITEST ) X $ GO TO 50 X SUM = SUM + DX( I )**2 X I = I + INCX X 120 CONTINUE X DNRM2 = DSQRT( SUM ) X GO TO 140 X* X 130 CONTINUE X IX = IX + 1 X I = I + INCX X IF( IX.LE.N ) X $ GO TO 20 X* X* end of main loop. X* X* compute square root and adjust for scaling. X* X DNRM2 = XMAX*DSQRT( SUM ) X 140 CONTINUE X RETURN X END END_OF_FILE if test 4558 -ne `wc -c <'dnrm2.f'`; then echo shar: \"'dnrm2.f'\" unpacked with wrong size! fi # end of 'dnrm2.f' fi if test -f 'dorgc3.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dorgc3.f'\" else echo shar: Extracting \"'dorgc3.f'\" \(4071 characters\) sed "s/^X//" >'dorgc3.f' <<'END_OF_FILE' X SUBROUTINE DORGC3( N, M, U, LDU, S, WORK, INFO ) X* X* -- LAPACK routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X INTEGER INFO, LDU, M, N X* .. X* X* .. Array Arguments .. X DOUBLE PRECISION S( * ), U( LDU, * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* Generate the N by N orthogonal matrix U which is a product X* of the M Householder transformations whose Householder X* vectors are in the lower triangle of U and whose scale X* factors are in S. The orthogonal matrix U overwrites the X* array U containing the Householder vectors. X* X* U = H(1) ... H(m) X* X* where H(j) = I - S(j) u(j) u(j)', I is the identity, X* u(j) is a vector stored in the j-th column of the array X* U, and ' means transpose. X* X* This is the unblocked (BLAS 2) version. X* X* Arguments X* ========= X* X* N - INTEGER X* N specifies the number of the rows and columns in the X* orthogonal matrix U. N must be at least zero. X* Not modified. X* X* M - INTEGER X* On entry, M specifies the number of Householder X* transformations. The first M columns of the strictly lower X* triangular part of U contain the Householder vectors, X* while the first M elements of S contain the scale factors. X* M must be at least zero. X* Not modified. X* X* U - DOUBLE PRECISION array, dimension(LDU,N) X* On entry, the strictly lower triangular part of U contains X* the Householder vectors. X* On exit, the array U is overwritten by the orthogonal X* matrix defined by the Householder transformation. X* X* LDU - INTEGER X* LDU specifies the first dimension of U as X* declared in the calling (sub)program. LDU must be at least X* max(1, N). X* Not modified. X* X* S - DOUBLE PRECISION array, dimension(M) X* S specifies the scaling factors (sometimes called 'tau') X* for the Householder matrices. X* Not modified. X* X* WORK - DOUBLE PRECISION array, dimension(N) X* Workspace. X* X* INFO - INTEGER X* On return, INFO is set to X* 0 normal return X* -k input argument number k has an illegal value. X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE X PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) X* .. X* X* .. Local Scalars .. X INTEGER I, J X* .. X* X* .. External Subroutines .. X EXTERNAL DGEMV, DGER, XERBLA X* .. X* X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters X* X INFO = 0 X IF( N.LT.0 ) THEN X INFO = -1 X ELSE IF( M.LT.0 ) THEN X INFO = -2 X ELSE IF( LDU.LT.MAX( 1, N ) ) THEN X INFO = -5 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DORGC3', -INFO ) X END IF X* X* Initialization X* X DO 20 J = 2, M X DO 10 I = 1, J - 1 X U( I, J ) = ZERO X 10 CONTINUE X 20 CONTINUE X* X DO 40 J = M + 1, N X DO 30 I = 1, N X U( I, J ) = ZERO X 30 CONTINUE X 40 CONTINUE X* X DO 50 I = 1, N X U( I, I ) = ONE X 50 CONTINUE X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.LT.2 ) X $ RETURN X* X* Update: U = (I - s(j)*u(:,j)*u(:,j)')*U X* X DO 70 J = M, 1, -1 X* X IF( J.LT.N ) THEN X CALL DGEMV( 'T', N-J, N-J, ONE, U( J+1, J+1 ), LDU, X $ U( J+1, J ), 1, ZERO, WORK, 1 ) X CALL DGER( N-J, N-J, -S( J ), U( J+1, J ), 1, WORK, 1, X $ U( J+1, J+1 ), LDU ) X DO 60 I = J + 1, N X U( I, J ) = ZERO X 60 CONTINUE X END IF X* X 70 CONTINUE X* X RETURN X* X* End of DORGC3 X* X END END_OF_FILE if test 4071 -ne `wc -c <'dorgc3.f'`; then echo shar: \"'dorgc3.f'\" unpacked with wrong size! fi # end of 'dorgc3.f' fi if test -f 'dormc2.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dormc2.f'\" else echo shar: Extracting \"'dormc2.f'\" \(6363 characters\) sed "s/^X//" >'dormc2.f' <<'END_OF_FILE' X SUBROUTINE DORMC2( SIDE, TRANS, M, N, K, A, LDA, S, C, LDC, WORK, X $ INFO ) X* X* -- LAPACK routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER SIDE, TRANS X INTEGER INFO, K, LDA, LDC, M, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), C( LDC, * ), S( * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DORMC2 overwrites the general m-by-n matrix C with X* X* Q * C if SIDE = 'L' and TRANS = 'N', or X* X* Q'* C if SIDE = 'L' and TRANS = 'C', or X* X* C * Q if SIDE = 'R' and TRANS = 'N', or X* X* C * Q if SIDE = 'R' and TRANS = 'C', X* X* where Q is a unitary matrix defined as the product of k X* elementary reflectors X* X* H(1) H(2) . . . H(k) X* X* For each i, H(i) has the form X* X* H(i) = I - tau * v * v' X* X* where the vector v has its first i-1 elements zero, its i-th X* element equal to 1, and its remaining elements stored in the X* subdiagonal elements of the i-th column of the array A. X* X* The tau-values are stored in the array S. X* X* This is the unblocked version of the algorithm. X* X* Arguments X* ========= X* X* SIDE - CHARACTER*1 X* on entry, SIDE specifies from which side Q or Q' is applied. X* X* if SIDE = 'L', C := Q * C or Q' * C X* X* if SIDE = 'R', C := C * Q or C * Q' X* X* Not modified. X* X* TRANS - CHARACTER*1 X* on entry, TRANS specifies whether to apply Q or Q'. X* X* if TRANS = 'N', apply Q X* X* if TRANS = 'T', apply Q' X* X* Not modified. X* X* M -INTEGER X* on entry, M specifies the number of rows of the matrix C. X* M must be at least zero. X* Not modified. X* X* N - INTEGER X* On entry, N must specify the number of columns of the X* matrix C. N must be at least zero. X* Not modified. X* X* K - INTEGER X* On entry, K must specify the number of elementary reflectors X* whose product forms the matrix Q. X* K must be greater than zero and X* at least M if SIDE = 'L', and X* at least N if SIDE = 'R' X* Not modified. X* X* A - DOUBLE PRECISION array, dimension( LDA, K ) X* on entry, the strictly lower diagonal elements of A X* must contain the elementary reflectors as returned X* by DGEQRF or DGEQR2. X* modified and restored. X* X* LDA - INTEGER X* on entry, LDA specifies the first dimension of the X* array A as declared in the calling (sub)program. X* LDA must be at least X* max(1,M) if SIDE = 'L', or X* max(1,N) if SIDE = 'R' X* Not modified. X* X* S - DOUBLE PRECISION array, dimension( K ) X* on entry, S must contain the scaling factors for the X* Householder vectors as stored by DGEQR2 or DGEQRF X* Not modified. X* X* C - DOUBLE PRECISION array, dimension( LDC, N ) X* on entry, C must contain the matrix C. X* on exit, C is overwritten by W*C or C*W where W = Q or Q'. X* X* LDC - INTEGER X* On entry, LDC must specify the first dimension of X* the array C as declared in the calling (sub)program. X* LDC must be at least max(1,M). X* Not modified. X* X* WORK - DOUBLE PRECISION array, dimension X* N if SIDE = 'L' X* or M if SIDE = 'R'. X* Used for work space. X* X* INFO - INTEGER X* On exit, a value of 0 indicates a normal return; a negative X* value, say -K, indicates that the K-th argument has an X* illegal value. X* X* .. Parameters .. X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D+0 ) X* .. X* .. Local Scalars .. X INTEGER I, I1, I2, I3, NQ X DOUBLE PRECISION AII X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. External Subroutines .. X EXTERNAL DLARF, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Check arguments X* X INFO = 0 X NQ = 0 X IF( LSAME( SIDE, 'L' ) ) THEN X NQ = M X ELSE IF( LSAME( SIDE, 'R' ) ) THEN X NQ = N X ELSE X INFO = -1 X END IF X IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN X INFO = -2 X ELSE IF( M.LT.0 ) THEN X INFO = -3 X ELSE IF( N.LT.0 ) THEN X INFO = -4 X ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN X INFO = -5 X ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN X INFO = -7 X ELSE IF( LDC.LT.MAX( 1, M ) ) THEN X INFO = -10 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DORMC2', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) X $ RETURN X* X* Application of Q from the left X* X IF( LSAME( SIDE, 'L' ) ) THEN X* X IF( LSAME( TRANS, 'N' ) ) THEN X I1 = K X I2 = 1 X I3 = -1 X ELSE IF( LSAME( TRANS, 'T' ) ) THEN X I1 = 1 X I2 = K X I3 = 1 X END IF X* X DO 10 I = I1, I2, I3 X* X* C(I:M,1:N) := H(I)*C(I:M,1:N) X* X AII = A( I, I ) X A( I, I ) = ONE X CALL DLARF( 'Left', M-I+1, N, A( I, I ), 1, S( I ), X $ C( I, 1 ), LDC, WORK ) X A( I, I ) = AII X 10 CONTINUE X* X ELSE IF( LSAME( SIDE, 'R' ) ) THEN X* X IF( LSAME( TRANS, 'N' ) ) THEN X I1 = 1 X I2 = K X I3 = 1 X ELSE IF( LSAME( TRANS, 'T' ) ) THEN X I1 = K X I2 = 1 X I3 = -1 X END IF X* X DO 20 I = I1, I2, I3 X* X* C(1:M,I:N) := C(1:M,I:N)*H(I) X* X AII = A( I, I ) X A( I, I ) = ONE X CALL DLARF( 'Right', M, N-I+1, A( I, I ), 1, S( I ), X $ C( 1, I ), LDC, WORK ) X A( I, I ) = AII X 20 CONTINUE X* X END IF X RETURN X* X* End of DORMC2 X* X END END_OF_FILE if test 6363 -ne `wc -c <'dormc2.f'`; then echo shar: \"'dormc2.f'\" unpacked with wrong size! fi # end of 'dormc2.f' fi if test -f 'dorml2.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dorml2.f'\" else echo shar: Extracting \"'dorml2.f'\" \(10008 characters\) sed "s/^X//" >'dorml2.f' <<'END_OF_FILE' X SUBROUTINE DORML2( SIDE, UPLO, TRANS, M, N, K, IQ, A, LDA, TAU, C, X $ LDC, WORK, INFO ) X* X* -- LAPACK routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER SIDE, TRANS, UPLO X INTEGER INFO, IQ, K, LDA, LDC, M, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) X* .. X* X* Purpose X* ======= X* X* DORML2 overwrites the general real m by n matrix C with X* X* Q * C if SIDE = 'L' and TRANS = 'N', or X* X* Q'* C if SIDE = 'L' and TRANS = 'T', or X* X* C * Q if SIDE = 'R' and TRANS = 'N', or X* X* C * Q' if SIDE = 'R' and TRANS = 'T', X* X* where Q is a real orthogonal matrix defined as the product of k X* elementary reflectors, of order m if SIDE = 'L', and of order n if X* SIDE = 'R'. X* X* If UPLO = 'L', X* X* Q = H(1) H(2) . . . H(k) X* X* where the elementary reflectors H(i) are defined by vectors stored X* columnwise below the diagonal of the array A. X* X* If UPLO = 'U', X* X* Q = H(k) . . . H(2) H(1) X* X* where the elementary reflectors H(i) are defined by vectors stored X* rowwise above the diagonal of the array A. X* X* Arguments X* ========= X* X* SIDE (input) CHARACTER*1 X* = 'L': apply Q or Q' from the Left X* = 'R': apply Q or Q' from the Right X* X* UPLO (input) CHARACTER*1 X* Specifies how the vectors which define the elementary X* reflectors are stored: X* = 'L': columnwise below the diagonal (Lower trapezium) X* = 'U': rowwise above the diagonal (Upper trapezium) X* X* TRANS (input) CHARACTER*1 X* = 'N': apply Q (No transpose) X* = 'T': apply Q' (Transpose) X* X* M (input) INTEGER X* The number of rows of the matrix C. M >= 0. X* X* N (input) INTEGER X* The number of columns of the matrix C. N >= 0. X* X* K (input) INTEGER X* The number of elementary reflectors whose product defines X* the matrix Q. X* If SIDE = 'L', M >= K >= 0; X* if SIDE = 'R', N >= K >= 0. X* X* IQ (input) INTEGER X* The offset for the storage of the vectors which define X* the elementary reflectors (see A). If SIDE = 'L', the first X* IQ rows of C are unchanged; if SIDE = 'R', the first IQ X* columns are unchanged. X* If SIDE = 'L', M-K >= IQ >= 0; X* if SIDE = 'R', N-K >= IQ >= 0. X* X* A (input) DOUBLE PRECISION array, dimension X* (LDA,K) if UPLO = 'L' X* (LDA,M) if SIDE = 'L' and UPLO = 'U' X* (LDA,N) if SIDE = 'R' and UPLO = 'U' X* If UPLO = 'L', the elements below the IQ-th subdiagonal in X* the first K columns must contain the vectors which define X* the elementary reflectors, stored columnwise; X* if UPLO = 'R', the elements above the IQ-th superdiagonal in X* the first K rows must contain the vectors which define X* the elementary reflectors, stored rowwise. X* The rest of the array is not used. X* X* LDA (input) INTEGER X* The leading dimension of the array A. X* If SIDE = 'L' and UPLO = 'L', LDA >= M; X* if SIDE = 'R' and UPLO = 'L', LDA >= N; X* if UPLO = 'U', LDA >= K. X* X* TAU (input) DOUBLE PRECISION array, dimension (K) X* Further details of the elementary reflectors. X* X* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) X* On entry, the m by n matrix C. X* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. X* X* LDC (input) INTEGER X* The leading dimension of the array C. LDC >= M. X* X* WORK (workspace) DOUBLE PRECISION array, dimension X* (N) if SIDE = 'L', X* (M) if SIDE = 'R'. X* X* INFO (output) INTEGER X* = 0: successful exit X* < 0: if INFO = -i, the i-th argument had an illegal value X* X* ===================================================================== X* X* .. Parameters .. X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D+0 ) X* .. X* .. Local Scalars .. X LOGICAL LEFT, LOWER, NOTRAN, RIGHT, UPPER X INTEGER I, II, NQ X DOUBLE PRECISION AII X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. External Subroutines .. X EXTERNAL DLARF, XERBLA X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input arguments X* X INFO = 0 X LOWER = LSAME( UPLO, 'L' ) X UPPER = LSAME( UPLO, 'U' ) X LEFT = LSAME( SIDE, 'L' ) X RIGHT = LSAME( SIDE, 'R' ) X NOTRAN = LSAME( TRANS, 'N' ) X IF( LEFT ) THEN X NQ = M X ELSE X NQ = N X END IF X IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN X INFO = -1 X ELSE IF( .NOT.LOWER .AND. .NOT.UPPER ) THEN X INFO = -2 X ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN X INFO = -3 X ELSE IF( M.LT.0 ) THEN X INFO = -4 X ELSE IF( N.LT.0 ) THEN X INFO = -5 X ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN X INFO = -6 X ELSE IF( IQ.LT.0 .OR. IQ.GT.NQ-K ) THEN X INFO = -7 X ELSE IF( ( LOWER .AND. LDA.LT.MAX( 1, NQ ) ) .OR. X $ ( UPPER .AND. LDA.LT.MAX( 1, K ) ) ) THEN X INFO = -9 X ELSE IF( LDC.LT.MAX( 1, M ) ) THEN X INFO = -12 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DORML2', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) X $ RETURN X* X IF( LOWER ) THEN X* X* Vectors stored columnwise below the diagonal X* X IF( LEFT ) THEN X* X* Apply Q or Q' from the left X* X IF( NOTRAN ) THEN X* X* Form Q * C X* X DO 10 I = K, 1, -1 X II = I + IQ X* X* Apply H(i) to rows i+iq:m of C from the left X* X AII = A( II, I ) X A( II, I ) = ONE X CALL DLARF( 'Left', M-II+1, N, A( II, I ), 1, X $ TAU( I ), C( II, 1 ), LDC, WORK ) X A( II, I ) = AII X 10 CONTINUE X ELSE X* X* Form Q' * C X* X DO 20 I = 1, K X II = I + IQ X* X* Apply H(i) to rows i+iq:m of C from the left X* X AII = A( II, I ) X A( II, I ) = ONE X CALL DLARF( 'Left', M-II+1, N, A( II, I ), 1, X $ TAU( I ), C( II, 1 ), LDC, WORK ) X A( II, I ) = AII X 20 CONTINUE X END IF X ELSE X* X* Apply Q or Q' from the right X* X IF( NOTRAN ) THEN X* X* Form C * Q X* X DO 30 I = 1, K X II = I + IQ X* X* Apply H(i) to columns i+iq:n of C from the right X* X AII = A( II, I ) X A( II, I ) = ONE X CALL DLARF( 'Right', M, N-II+1, A( II, I ), 1, X $ TAU( I ), C( 1, II ), LDC, WORK ) X A( II, I ) = AII X 30 CONTINUE X ELSE X* X* Form C * Q' X* X DO 40 I = K, 1, -1 X II = I + IQ X* X* Apply H(i) to columns i+iq:n of C from the right X* X AII = A( II, I ) X A( II, I ) = ONE X CALL DLARF( 'Right', M, N-II+1, A( II, I ), 1, X $ TAU( I ), C( 1, II ), LDC, WORK ) X A( II, I ) = AII X 40 CONTINUE X END IF X END IF X ELSE X* X* Vectors stored rowwise above the diagonal X* X IF( LEFT ) THEN X* X* Apply Q or Q' from the left X* X IF( NOTRAN ) THEN X* X* Form Q * C X* X DO 50 I = 1, K X II = I + IQ X* X* Apply H(i) to rows i+iq:m of C from the left X* X AII = A( I, II ) X A( I, II ) = ONE X CALL DLARF( 'Left', M-II+1, N, A( I, II ), LDA, X $ TAU( I ), C( II, 1 ), LDC, WORK ) X A( I, II ) = AII X 50 CONTINUE X ELSE X* X* Form Q' * C X* X DO 60 I = K, 1, -1 X II = I + IQ X* X* Apply H(i) to rows i+iq:m of C from the left X* X AII = A( I, II ) X A( I, II ) = ONE X CALL DLARF( 'Left', M-II+1, N, A( I, II ), LDA, X $ TAU( I ), C( II, 1 ), LDC, WORK ) X A( I, II ) = AII X 60 CONTINUE X END IF X ELSE X* X* Apply Q or Q' from the right X* X IF( NOTRAN ) THEN X* X* Form C * Q X* X DO 70 I = K, 1, -1 X II = I + IQ X* X* Apply H(i) to columns i+iq:n of C from the right X* X AII = A( I, II ) X A( I, II ) = ONE X CALL DLARF( 'Right', M, N-II+1, A( I, II ), LDA, X $ TAU( I ), C( 1, II ), LDC, WORK ) X A( I, II ) = AII X 70 CONTINUE X ELSE X* X* Form C * Q' X* X DO 80 I = 1, K X II = I + IQ X* X* Apply H(i) to columns i+iq:n of C from the right X* X AII = A( I, II ) X A( I, II ) = ONE X CALL DLARF( 'Right', M, N-II+1, A( I, II ), LDA, X $ TAU( I ), C( 1, II ), LDC, WORK ) X A( I, II ) = AII X 80 CONTINUE X END IF X END IF X END IF X RETURN X* X* End of DORML2 X* X END END_OF_FILE if test 10008 -ne `wc -c <'dorml2.f'`; then echo shar: \"'dorml2.f'\" unpacked with wrong size! fi # end of 'dorml2.f' fi if test -f 'drandom.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'drandom.f'\" else echo shar: Extracting \"'drandom.f'\" \(590 characters\) sed "s/^X//" >'drandom.f' <<'END_OF_FILE' c------------------------------------------------------------------- X double precision function random() CVD$G noconcur X c----------------------------------------------------- c Routine returns a pseudo-random number between 0-1. c----------------------------------------------------- X integer m, i, md, seed X double precision fmd X**** X integer sseed X common/sseed/sseed X**** X X data m/25173/,i/13849/,md/65536/,fmd/65536.d0/,seed/17/ X X save seed X X seed = mod(m*seed+i,md) X random = seed/fmd X**** X sseed=seed X**** X return X end END_OF_FILE if test 590 -ne `wc -c <'drandom.f'`; then echo shar: \"'drandom.f'\" unpacked with wrong size! fi # end of 'drandom.f' fi if test -f 'drot.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'drot.f'\" else echo shar: Extracting \"'drot.f'\" \(1174 characters\) sed "s/^X//" >'drot.f' <<'END_OF_FILE' X SUBROUTINE DROT( N, DX, INCX, DY, INCY, C, S ) X* X* applies a plane rotation. X* jack dongarra, linpack, 3/11/78. X* X* .. Scalar Arguments .. X INTEGER INCX, INCY, N X DOUBLE PRECISION C, S X* .. X* .. Array Arguments .. X DOUBLE PRECISION DX( 1 ), DY( 1 ) X* .. X* .. Local Scalars .. X INTEGER I, IX, IY X DOUBLE PRECISION DTEMP X* .. X* .. Executable Statements .. X* X IF( N.LE.0 ) X $ RETURN X IF( INCX.EQ.1 .AND. INCY.EQ.1 ) X $ GO TO 20 X* X* code for unequal increments or equal increments X* not equal to 1 X* X IX = 1 X IY = 1 X IF( INCX.LT.0 ) X $ IX = ( -N+1 )*INCX + 1 X IF( INCY.LT.0 ) X $ IY = ( -N+1 )*INCY + 1 X DO 10 I = 1, N X DTEMP = C*DX( IX ) + S*DY( IY ) X DY( IY ) = C*DY( IY ) - S*DX( IX ) X DX( IX ) = DTEMP X IX = IX + INCX X IY = IY + INCY X 10 CONTINUE X RETURN X* X* code for both increments equal to 1 X* X 20 DO 30 I = 1, N X DTEMP = C*DX( I ) + S*DY( I ) X DY( I ) = C*DY( I ) - S*DX( I ) X DX( I ) = DTEMP X 30 CONTINUE X RETURN X END END_OF_FILE if test 1174 -ne `wc -c <'drot.f'`; then echo shar: \"'drot.f'\" unpacked with wrong size! fi # end of 'drot.f' fi if test -f 'dscal.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dscal.f'\" else echo shar: Extracting \"'dscal.f'\" \(1395 characters\) sed "s/^X//" >'dscal.f' <<'END_OF_FILE' X SUBROUTINE DSCAL( N, DA, DX, INCX ) X* X* scales a vector by a constant. X* uses unrolled loops for increment equal to one. X* jack dongarra, linpack, 3/11/78. X* modified to correct problem with negative increment, 8/21/90. X* X* .. Scalar Arguments .. X INTEGER INCX, N X DOUBLE PRECISION DA X* .. X* .. Array Arguments .. X DOUBLE PRECISION DX( 1 ) X* .. X* .. Local Scalars .. X INTEGER I, IX, M, MP1 X* .. X* .. Intrinsic Functions .. X INTRINSIC MOD X* .. X* .. Executable Statements .. X* X IF( N.LE.0 ) X $ RETURN X IF( INCX.EQ.1 ) X $ GO TO 20 X* X* code for increment not equal to 1 X* X IX = 1 X IF( INCX.LT.0 ) X $ IX = ( -N+1 )*INCX + 1 X DO 10 I = 1, N X DX( IX ) = DA*DX( IX ) X IX = IX + INCX X 10 CONTINUE X RETURN X* X* code for increment equal to 1 X* X* X* clean-up loop X* X 20 CONTINUE X M = MOD( N, 5 ) X IF( M.EQ.0 ) X $ GO TO 40 X DO 30 I = 1, M X DX( I ) = DA*DX( I ) X 30 CONTINUE X IF( N.LT.5 ) X $ RETURN X 40 CONTINUE X MP1 = M + 1 X DO 50 I = MP1, N, 5 X DX( I ) = DA*DX( I ) X DX( I+1 ) = DA*DX( I+1 ) X DX( I+2 ) = DA*DX( I+2 ) X DX( I+3 ) = DA*DX( I+3 ) X DX( I+4 ) = DA*DX( I+4 ) X 50 CONTINUE X RETURN X END END_OF_FILE if test 1395 -ne `wc -c <'dscal.f'`; then echo shar: \"'dscal.f'\" unpacked with wrong size! fi # end of 'dscal.f' fi if test -f 'dstech.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dstech.f'\" else echo shar: Extracting \"'dstech.f'\" \(5223 characters\) sed "s/^X//" >'dstech.f' <<'END_OF_FILE' X SUBROUTINE DSTECH( N, A, B, EIG, TOL, WORK, INFO ) X* X* -- LAPACK test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X* X INTEGER INFO, N X DOUBLE PRECISION TOL X* .. X* X* .. Array Arguments .. X* X DOUBLE PRECISION A( * ), B( * ), EIG( * ), WORK( * ) X* .. X* X*----------------------------------------------------------------------- X* X* Purpose X* ======= X* X* Let T be the tridiagonal matrix with diagonal entries A(1) ,..., X* A(N) and offdiagonal entries B(1) ,..., B(N-1)). DSTECH checks to X* see if EIG(1) ,..., EIG(N) are indeed accurate eigenvalues of T. X* It does this by expanding each EIG(I) into an interval X* [SVD(I) - EPS, SVD(I) + EPS], merging overlapping intervals if X* any, and using Sturm sequences to count and verify whether each X* resulting interval has the correct number of eigenvalues (using X* DSTECT). Here EPS = TOL*MAZHEPS*MAXEIG, where MACHEPS is the X* machine precision and MAXEIG is the absolute value of the largest X* eigenvalue. If each interval contains the correct number of X* eigenvalues, INFO = 0 is returned, otherwise INFO is the index of X* the first eigenvalue in the first bad interval. X* X* X* Arguments X* ========== X* X* N - INTEGER X* The dimension of the tridiagonal matrix T. X* Not modified. X* X* A - DOUBLE PRECISION array of dimension ( N ) X* The diagonal entries of the tridiagonal matrix T. X* Not modified. X* X* B - DOUBLE PRECISION array of dimension ( N-1 ) X* The offdiagonal entries of the tridiagonal matrix T. X* Not modified. X* X* EIG - DOUBLE PRECISION array of dimension ( N ) X* The purported eigenvalues to be checked. X* Not modified. X* X* TOL - DOUBLE PRECISION X* Error tolerance for checking, a multiple of the X* machine precision. X* Not modified. X* X* WORK - DOUBLE PRECISION array of dimension ( N ) X* Workspace array. X* Modified. X* X* INFO - INTEGER X* 0 if the eigenvalues are all correct (to within X* 1 +- TOL*MAZHEPS*MAXEIG) X* >0 if the interval containing the INFO-th eigenvalue X* contains the incorrect number of eigenvalues. X* X*----------------------------------------------------------------------- X* X* .. Parameters .. X* X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D0 ) X* .. X* X* .. Local Scalars .. X* X INTEGER BPNT, COUNT, I, ISUB, J, NUML, NUMU, TPNT X DOUBLE PRECISION EMIN, EPS, LOWER, MX, TUPPR, UNFLEP, UPPER X* .. X* X* .. External Functions .. X* X DOUBLE PRECISION DLAMCH X EXTERNAL DLAMCH X* .. X* X* .. External Subroutines .. X* X EXTERNAL DSTECT X* .. X* X* .. Intrinsic Functions .. X* X INTRINSIC ABS, MAX X* .. X* X* .. Executable Statements .. X* X* Check input parameters X* X INFO = 0 X IF( N.EQ.0 ) X $ RETURN X IF( N.LT.0 ) THEN X INFO = -1 X RETURN X END IF X IF( TOL.LT.ZERO ) THEN X INFO = -5 X RETURN X END IF X* X* Get machine constants X* X EPS = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) X UNFLEP = DLAMCH( 'Safe minimum' ) / EPS X EPS = TOL*EPS X* X* Compute maximum absolute eigenvalue, error tolerance X* X MX = ABS( EIG( 1 ) ) X DO 10 I = 2, N X MX = MAX( MX, ABS( EIG( I ) ) ) X 10 CONTINUE X EPS = MAX( EPS*MX, UNFLEP ) X* X* X* Sort eigenvalues from EIG into WORK X* X DO 20 I = 1, N X WORK( I ) = EIG( I ) X 20 CONTINUE X DO 40 I = 1, N - 1 X ISUB = 1 X EMIN = WORK( 1 ) X DO 30 J = 2, N + 1 - I X IF( WORK( J ).LT.EMIN ) THEN X ISUB = J X EMIN = WORK( J ) X END IF X 30 CONTINUE X IF( ISUB.NE.N+1-I ) THEN X WORK( ISUB ) = WORK( N+1-I ) X WORK( N+1-I ) = EMIN X END IF X 40 CONTINUE X* X* TPNT points to singular value at right endpoint of interval X* BPNT points to singular value at left endpoint of interval X* X TPNT = 1 X BPNT = 1 X* X* Begin loop over all intervals X* X 50 CONTINUE X UPPER = WORK( TPNT ) + EPS X LOWER = WORK( BPNT ) - EPS X* X* Begin loop merging overlapping intervals X* X 60 CONTINUE X IF( BPNT.EQ.N ) X $ GO TO 70 X TUPPR = WORK( BPNT+1 ) + EPS X IF( TUPPR.LT.LOWER ) X $ GO TO 70 X* X* Merge X* X BPNT = BPNT + 1 X LOWER = WORK( BPNT ) - EPS X GO TO 60 X 70 CONTINUE X* X* Count singular values in interval [ LOWER, UPPER ] X* X CALL DSTECT( N, A, B, LOWER, NUML ) X CALL DSTECT( N, A, B, UPPER, NUMU ) X COUNT = NUMU - NUML X IF( COUNT.NE.BPNT-TPNT+1 ) THEN X* X* Wrong number of singular values in interval X* X INFO = TPNT X GO TO 80 X END IF X TPNT = BPNT + 1 X BPNT = TPNT X IF( TPNT.LE.N ) X $ GO TO 50 X 80 CONTINUE X RETURN X* X* End of DSTECH X* X END END_OF_FILE if test 5223 -ne `wc -c <'dstech.f'`; then echo shar: \"'dstech.f'\" unpacked with wrong size! fi # end of 'dstech.f' fi if test -f 'dstect.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dstect.f'\" else echo shar: Extracting \"'dstect.f'\" \(3714 characters\) sed "s/^X//" >'dstect.f' <<'END_OF_FILE' X SUBROUTINE DSTECT( N, A, B, SHIFT, NUM ) X* X* -- LAPACK test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X* X INTEGER N, NUM X DOUBLE PRECISION SHIFT X* .. X* X* .. Array Arguments .. X* X DOUBLE PRECISION A( * ), B( * ) X* .. X* X*----------------------------------------------------------------------- X* X* Purpose X* ======= X* X* DSTECT counts the number NUM of eigenvalues of a tridiagonal X* matrix T which are less than or equal to SHIFT. T has X* diagonal entries A(1), ... , A(N), and offdiagonal entries X* B(1), ..., B(N-1). X* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal X* Matrix", Report CS41, Computer Science Dept., Stanford X* University, July 21, 1966 X* X* Arguments X* ========== X* X* N - INTEGER X* The dimension of the tridiagonal matrix T. X* Not modified. X* X* A - DOUBLE PRECISION array of dimension ( N ) X* The diagonal entries of the tridiagonal matrix T. X* Not modified. X* X* B - DOUBLE PRECISION array of dimension ( N-1 ) X* The offdiagonal entries of the tridiagonal matrix T. X* Not modified. X* X* SHIFT - DOUBLE PRECISION X* The shift, used as described under Purpose. X* Not modified. X* X* NUM - INTEGER X* The number of eigenvalues of T less than or equal X* to SHIFT. X* Modified. X* X*----------------------------------------------------------------------- X* X* .. Parameters .. X* X DOUBLE PRECISION ZERO, ONE, THREE X PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, THREE = 3.0D0 ) X* .. X* X* .. Local Scalars .. X* X INTEGER I X DOUBLE PRECISION M1, M2, MX, OVFL, SOV, SSHIFT, SSUN, SUN, TMP, X $ TOM, U, UNFL X* .. X* X* .. External Functions .. X* X DOUBLE PRECISION DLAMCH X EXTERNAL DLAMCH X* .. X* X* .. Intrinsic Functions .. X* X INTRINSIC ABS, MAX, SQRT X* .. X* X* .. Executable Statements .. X* X* Get machine constants X* X UNFL = DLAMCH( 'Safe minimum' ) X OVFL = DLAMCH( 'Overflow' ) X* X* Find largest entry X* X MX = ABS( A( 1 ) ) X DO 10 I = 1, N - 1 X MX = MAX( MX, ABS( A( I+1 ) ), ABS( B( I ) ) ) X 10 CONTINUE X* X* Handle easy cases, including zero matrix X* X IF( SHIFT.GE.THREE*MX ) THEN X NUM = N X RETURN X END IF X IF( SHIFT.LT.-THREE*MX ) THEN X NUM = 0 X RETURN X END IF X* X* Compute scale factors as in Kahan's report X* At this point, MX .NE. 0 so we can divide by it X* X SUN = SQRT( UNFL ) X SSUN = SQRT( SUN ) X SOV = SQRT( OVFL ) X TOM = SSUN*SOV X IF( MX.LE.ONE ) THEN X M1 = ONE / MX X M2 = TOM X ELSE X M1 = ONE X M2 = TOM / MX X END IF X* X* Begin counting X* X NUM = 0 X SSHIFT = ( SHIFT*M1 )*M2 X U = ( A( 1 )*M1 )*M2 - SSHIFT X IF( U.LE.SUN ) THEN X IF( U.LE.ZERO ) THEN X NUM = NUM + 1 X IF( U.GT.-SUN ) X $ U = -SUN X ELSE X U = SUN X END IF X END IF X DO 20 I = 2, N X TMP = ( B( I-1 )*M1 )*M2 X U = ( ( A( I )*M1 )*M2-TMP*( TMP / U ) ) - SSHIFT X IF( U.LE.SUN ) THEN X IF( U.LE.ZERO ) THEN X NUM = NUM + 1 X IF( U.GT.-SUN ) X $ U = -SUN X ELSE X U = SUN X END IF X END IF X 20 CONTINUE X RETURN X* X* End of DSTECT X* X END END_OF_FILE if test 3714 -ne `wc -c <'dstect.f'`; then echo shar: \"'dstect.f'\" unpacked with wrong size! fi # end of 'dstect.f' fi if test -f 'dstt21.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dstt21.f'\" else echo shar: Extracting \"'dstt21.f'\" \(5813 characters\) sed "s/^X//" >'dstt21.f' <<'END_OF_FILE' X SUBROUTINE DSTT21( N, KBAND, AD, AE, SD, SE, U, LDU, WORK, X $ RESULT ) X* X* -- LAPACK test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X* X INTEGER KBAND, LDU, N X* .. X* X* .. Array Arguments .. X* X DOUBLE PRECISION AD( * ), AE( * ), RESULT( 2 ), SD( * ), X $ SE( * ), U( LDU, * ), WORK( N, * ) X* .. X* X*----------------------------------------------------------------------- X* X* Purpose X* ======= X* X* DSTT21 checks a decomposition of the form X* X* A = U S U' X* X* where ' means transpose, A is symmetric tridiagonal, U is X* orthogonal, and S is diagonal (if KBAND=0) or symmetric X* tridiagonal (if KBAND=1). Two tests are performed: X* X* RESULT(1) = | A - U S U' | / ( |A| n ulp ) X* X* RESULT(2) = | I - UU' | / ( n ulp ) X* X* Arguments X* ========== X* X* N - INTEGER X* The size of the matrix. If it is zero, DSTT21 does nothing. X* It must be at least zero. X* Not modified. X* X* KBAND - INTEGER X* The bandwidth of the matrix S. It may only be zero or one. X* If zero, then S is diagonal, and SE is not referenced. If X* one, then S is symmetric tri-diagonal. X* Not modified. X* X* AD - DOUBLE PRECISION array of dimension ( N ) X* The diagonal of the original (unfactored) matrix A. A is X* assumed to be symmetric tridiagonal. X* Not modified. X* X* AE - DOUBLE PRECISION array of dimension ( N ) X* The off-diagonal of the original (unfactored) matrix A. A X* is assumed to be symmetric tridiagonal. AE(1) is ignored, X* AE(2) is the (1,2) and (2,1) element, etc. X* Not modified. X* X* SD - DOUBLE PRECISION array of dimension ( N ) X* The diagonal of the (symmetric tri-) diagonal matrix S. X* Not modified. X* X* SE - DOUBLE PRECISION array of dimension ( N ) X* The off-diagonal of the (symmetric tri-) diagonal matrix S. X* Not referenced if KBSND=0. If KBAND=1, then AE(1) is X* ignored, SE(2) is the (1,2) and (2,1) element, etc. X* Not modified. X* X* U - DOUBLE PRECISION array of dimension ( LDU, N ). X* The orthogonal matrix in the decomposition. X* Not modified. X* X* LDU - INTEGER X* The leading dimension of U. LDU must be at least N. X* Not modified. X* X* WORK - DOUBLE PRECISION array of dimension ( N, N+1 ) X* Workspace. X* Modified. X* X* RESULT - DOUBLE PRECISION array of dimension ( 2 ) X* The values computed by the two tests described above. The X* values are currently limited to 1/ulp, to avoid overflow. X* RESULT(1) is always modified. X* Modified. X* X*----------------------------------------------------------------------- X* X* X* .. Parameters .. X* X DOUBLE PRECISION ZERO, ONE X PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) X* .. X* X* .. Local Scalars .. X* X INTEGER J X DOUBLE PRECISION ANORM, TEMP1, TEMP2, ULP, UNFL, WNORM X* .. X* X* .. External Functions .. X* X DOUBLE PRECISION DLAMCH, DLANGE, DLANSY X EXTERNAL DLAMCH, DLANGE, DLANSY X* .. X* X* .. External Subroutines .. X* X EXTERNAL DGEMM, DLAZRO, DSYR, DSYR2 X* .. X* X* .. Intrinsic Functions .. X* X INTRINSIC ABS, DBLE, MAX, MIN X* .. X* X* X*----------------------------------------------------------------------- X* .. Executable Statements .. X* X* X* 1) Constants X* X* X RESULT( 1 ) = ZERO X RESULT( 2 ) = ZERO X IF( N.LE.0 ) X $ RETURN X* X UNFL = DLAMCH( 'Safe minimum' ) X ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) X* X*----------------------------------------------------------------------- X* X* X* Do Test 1 X* X* Copy A & Compute its 1-Norm: X* X CALL DLAZRO( N, N, ZERO, ZERO, WORK, N ) X* X ANORM = ZERO X TEMP1 = ZERO X* X DO 10 J = 1, N - 1 X WORK( J, J ) = AD( J ) X WORK( J+1, J ) = AE( J+1 ) X TEMP2 = ABS( AE( J+1 ) ) X ANORM = MAX( ANORM, ABS( AD( J ) )+TEMP1+TEMP2 ) X TEMP1 = TEMP2 X 10 CONTINUE X* X WORK( N, N ) = AD( N ) X ANORM = MAX( ANORM, ABS( AD( N ) )+TEMP1, UNFL ) X* X* X* Norm of A - USU' X* X* X DO 20 J = 1, N X CALL DSYR( 'L', N, -SD( J ), U( 1, J ), 1, WORK, N ) X 20 CONTINUE X* X IF( N.GT.1 .AND. KBAND.EQ.1 ) THEN X DO 30 J = 2, N X CALL DSYR2( 'L', N, -SE( J ), U( 1, J-1 ), 1, U( 1, J ), 1, X $ WORK, N ) X 30 CONTINUE X END IF X* X* X WNORM = DLANSY( '1', 'L', N, WORK, N, WORK( 1, N+1 ) ) X* X IF( ANORM.GT.WNORM ) THEN X RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP ) X ELSE X IF( ANORM.LT.ONE ) THEN X RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP ) X ELSE X RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP ) X END IF X END IF X* X* . . . . . . . . . . . . . . X* X* Do Test 2 X* X* Compute UU' - I X* X CALL DGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK, X $ N ) X* X DO 40 J = 1, N X WORK( J, J ) = WORK( J, J ) - ONE X 40 CONTINUE X* X RESULT( 2 ) = MIN( DBLE( N ), DLANGE( '1', N, N, WORK, N, WORK( 1, X $ N+1 ) ) ) / ( N*ULP ) X* X*----------------------------------------------------------------------- X* X* X RETURN X* X* End of DSTT21 X* X END END_OF_FILE if test 5813 -ne `wc -c <'dstt21.f'`; then echo shar: \"'dstt21.f'\" unpacked with wrong size! fi # end of 'dstt21.f' fi if test -f 'dsvdch.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dsvdch.f'\" else echo shar: Extracting \"'dsvdch.f'\" \(4835 characters\) sed "s/^X//" >'dsvdch.f' <<'END_OF_FILE' X SUBROUTINE DSVDCH( N, S, E, SVD, TOL, INFO ) X* X* -- LAPACK test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X* X INTEGER INFO, N X DOUBLE PRECISION TOL X* .. X* X* .. Array Arguments .. X* X DOUBLE PRECISION E( * ), S( * ), SVD( * ) X* .. X* X*----------------------------------------------------------------------- X* X* Purpose X* ======= X* X* Let B be the bidiagonal matrix with diagonal entries X* S(1) ,..., S(N) and superdiagonal entries E(1) ,..., E(N-1)). X* DSVDCH checks to see if SVD(1) ,..., SVD(N) are indeed accurate X* singular values of B. It does this by expanding each SVD(I) into X* an interval [SVD(I) * (1-EPS) , SVD(I) * (1+EPS)], merging X* overlapping intervals if any, and using Sturm sequences to count X* and verify whether each resulting interval has the correct number X* of singular values (using DSVDCT). Here EPS=TOL*MAX(N/10,1)*MAZHEPS, X* where MAZHEPS is the machine precision. The routine assumes the X* singular values are sorted, with SVD(1) the largest and SVD(N) X* smallest. If each interval contains the correct number of singular X* values, INFO = 0 is returned, otherwise INFO is the index of the X* first singular value in the first bad interval. X* X* Arguments X* ========== X* X* N (input) INTEGER X* The dimension of the bidiagonal matrix B. X* X* S (input) DOUBLE PRECISION array, dimension (N) X* The diagonal entries of the bidiagonal matrix B. X* X* E (input) DOUBLE PRECISION array, dimension (N-1) X* The superdiagonal entries of the bidiagonal matrix B. X* X* SVD (input) DOUBLE PRECISION array, dimension (N) X* The purported singular values to be checked. X* X* TOL (input) DOUBLE PRECISION X* Error tolerance for checking, a multiplier of the X* machine precision. X* X* INFO (output) INTEGER X* 0 if the singular values are all correct (to within X* 1 +- TOL*MAZHEPS) X* >0 if the interval containing the INFO-th singular value X* contains the incorrect number of singular values. X* X*----------------------------------------------------------------------- X* X* .. Parameters .. X* X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D0 ) X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D0 ) X* .. X* X* .. Local Scalars .. X* X INTEGER BPNT, COUNT, NUML, NUMU, TPNT X DOUBLE PRECISION EPS, LOWER, OVFL, TUPPR, UNFL, UNFLEP, UPPER X* .. X* X* .. External Functions .. X* X DOUBLE PRECISION DLAMCH X EXTERNAL DLAMCH X* .. X* X* .. External Subroutines .. X* X EXTERNAL DSVDCT X* .. X* X* .. Intrinsic Functions .. X INTRINSIC MAX, SQRT X* .. X* .. Executable Statements .. X* X* Get machine constants X* X INFO = 0 X IF( N.LE.0 ) X $ RETURN X UNFL = DLAMCH( 'Safe minimum' ) X OVFL = DLAMCH( 'Overflow' ) X EPS = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) X* X* UNFLEP is chosen so that when and eigenvalue is multiplied by X* the scale factor sqrt(OVFL)*sqrt(sqrt(UNFL))/MX in DSVDCT, X* it exceed sqrt(UNFL), which is the lower limit for DSVDCT X* X UNFLEP = ( SQRT( SQRT( UNFL ) ) / SQRT( OVFL ) )*SVD( 1 ) + X $ UNFL / EPS X* X* The value of EPS works best when TOL equals (or exceeds) 10 X* X EPS = TOL*MAX( N / 10, 1 )*EPS X* X* TPNT points to singular value at right endpoint of interval X* BPNT points to singular value at left endpoint of interval X* X TPNT = 1 X BPNT = 1 X* X* Begin loop over all intervals X* X 10 CONTINUE X UPPER = ( ONE+EPS )*SVD( TPNT ) + UNFLEP X LOWER = ( ONE-EPS )*SVD( BPNT ) - UNFLEP X IF( LOWER.LE.UNFLEP ) X $ LOWER = -UPPER X* X* Begin loop merging overlapping intervals X* X 20 CONTINUE X IF( BPNT.EQ.N ) X $ GO TO 30 X TUPPR = ( ONE+EPS )*SVD( BPNT+1 ) + UNFLEP X IF( TUPPR.LT.LOWER ) X $ GO TO 30 X* X* Merge X* X BPNT = BPNT + 1 X LOWER = ( ONE-EPS )*SVD( BPNT ) - UNFLEP X IF( LOWER.LE.UNFLEP ) X $ LOWER = -UPPER X GO TO 20 X 30 CONTINUE X* X* Count singular values in interval [ LOWER, UPPER ] X* X CALL DSVDCT( N, S, E, LOWER, NUML ) X CALL DSVDCT( N, S, E, UPPER, NUMU ) X COUNT = NUMU - NUML X IF( LOWER.LT.ZERO ) X $ COUNT = COUNT / 2 X IF( COUNT.NE.BPNT-TPNT+1 ) THEN X* X* Wrong number of singular values in interval X* X INFO = TPNT X GO TO 40 X END IF X TPNT = BPNT + 1 X BPNT = TPNT X IF( TPNT.LE.N ) X $ GO TO 10 X 40 CONTINUE X RETURN X* X* End of DSVDCH X* X END END_OF_FILE if test 4835 -ne `wc -c <'dsvdch.f'`; then echo shar: \"'dsvdch.f'\" unpacked with wrong size! fi # end of 'dsvdch.f' fi if test -f 'dsvdct.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dsvdct.f'\" else echo shar: Extracting \"'dsvdct.f'\" \(4737 characters\) sed "s/^X//" >'dsvdct.f' <<'END_OF_FILE' X SUBROUTINE DSVDCT( N, S, E, SHIFT, NUM ) X* X* -- LAPACK test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X* X INTEGER N, NUM X DOUBLE PRECISION SHIFT X* .. X* X* .. Array Arguments .. X* X DOUBLE PRECISION E( * ), S( * ) X* .. X* X*----------------------------------------------------------------------- X* X* Purpose X* ======= X* X* DSVDCT counts the number NUM of eigenvalues of a tridiagonal X* matrix T which are less than or equal to SHIFT. T is formed X* by putting zeros on the diagonal and making the off diagonals X* equal to S(1), E(1), S(2), E(2), ... , E(N-1), S(N). If SHIFT X* is positive, NUM is equal to N plus the number of singular X* values of a bidiagonal matrix B less than or equal to SHIFT. X* Here B has diagonal entries S(1), ..., S(N) and superdiagonal X* entries E(1), ... E(N-1). If SHIFT is negative, NUM is equal X* to the number of singular values of B greater than or equal X* to -SHIFT. X* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal X* Matrix", Report CS41, Computer Science Dept., Stanford University, X* July 21, 1966 X* X* Arguments X* ========== X* X* N - INTEGER (INPUT) X* The dimension of the bidiagonal matrix B. X* Unchanged on exit. X* X* S - DOUBLE PRECISION array of dimension ( N ) (INPUT) X* The diagonal entries of the bidiagonal matrix B. X* Unchanged on exit. X* X* E - DOUBLE PRECISION array of dimension ( N-1 ) (INPUT) X* The superdiagonal entries of the bidiagonal matrix B. X* Unchanged on exit. X* X* SHIFT - DOUBLE PRECISION (INPUT) X* The shift, used as described under Purpose. X* Unchanged on exit. X* X* NUM - INTEGER (OUTPUT) X* The number of eigenvalues of T less than or equal X* to SHIFT. X* X*----------------------------------------------------------------------- X* X* .. Parameters .. X* X DOUBLE PRECISION ONE X PARAMETER ( ONE = 1.0D0 ) X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D0 ) X* .. X* X* .. Local Scalars .. X* X INTEGER I X DOUBLE PRECISION M1, M2, MX, OVFL, SOV, SSHIFT, SSUN, SUN, TMP, X $ TOM, U, UNFL X* .. X* X* .. External Functions .. X* X DOUBLE PRECISION DLAMCH X EXTERNAL DLAMCH X* .. X* X* .. Intrinsic Functions .. X* X INTRINSIC ABS, MAX, SQRT X* .. X* X* .. Executable Statements .. X* X* Get machine constants X* X UNFL = DLAMCH( 'Safe minimum' ) X OVFL = DLAMCH( 'Overflow' ) X* X* Find largest entry X* X MX = ABS( S( 1 ) ) X DO 10 I = 1, N - 1 X MX = MAX( MX, ABS( S( I+1 ) ), ABS( E( I ) ) ) X 10 CONTINUE X* X IF( MX.EQ.ZERO ) THEN X IF( SHIFT.LT.ZERO ) THEN X NUM = 0 X ELSE X NUM = 2*N X END IF X RETURN X END IF X* X* Compute scale factors as in Kahan's report X* X SUN = SQRT( UNFL ) X SSUN = SQRT( SUN ) X SOV = SQRT( OVFL ) X TOM = SSUN*SOV X IF( MX.LE.ONE ) THEN X M1 = ONE / MX X M2 = TOM X ELSE X M1 = ONE X M2 = TOM / MX X END IF X* X* Begin counting X* X U = ONE X NUM = 0 X SSHIFT = ( SHIFT*M1 )*M2 X U = -SSHIFT X IF( U.LE.SUN ) THEN X IF( U.LE.ZERO ) THEN X NUM = NUM + 1 X IF( U.GT.-SUN ) X $ U = -SUN X ELSE X U = SUN X END IF X END IF X TMP = ( S( 1 )*M1 )*M2 X U = -TMP*( TMP / U ) - SSHIFT X IF( U.LE.SUN ) THEN X IF( U.LE.ZERO ) THEN X NUM = NUM + 1 X IF( U.GT.-SUN ) X $ U = -SUN X ELSE X U = SUN X END IF X END IF X DO 20 I = 1, N - 1 X TMP = ( E( I )*M1 )*M2 X U = -TMP*( TMP / U ) - SSHIFT X IF( U.LE.SUN ) THEN X IF( U.LE.ZERO ) THEN X NUM = NUM + 1 X IF( U.GT.-SUN ) X $ U = -SUN X ELSE X U = SUN X END IF X END IF X TMP = ( S( I+1 )*M1 )*M2 X U = -TMP*( TMP / U ) - SSHIFT X IF( U.LE.SUN ) THEN X IF( U.LE.ZERO ) THEN X NUM = NUM + 1 X IF( U.GT.-SUN ) X $ U = -SUN X ELSE X U = SUN X END IF X END IF X 20 CONTINUE X RETURN X* X* End of DSVDCT X* X END END_OF_FILE if test 4737 -ne `wc -c <'dsvdct.f'`; then echo shar: \"'dsvdct.f'\" unpacked with wrong size! fi # end of 'dsvdct.f' fi if test -f 'dsymv.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dsymv.f'\" else echo shar: Extracting \"'dsymv.f'\" \(8072 characters\) sed "s/^X//" >'dsymv.f' <<'END_OF_FILE' X SUBROUTINE DSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX, X $ BETA, Y, INCY ) X* .. Scalar Arguments .. X DOUBLE PRECISION ALPHA, BETA X INTEGER INCX, INCY, LDA, N X CHARACTER*1 UPLO X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) X* .. X* X* Purpose X* ======= X* X* DSYMV performs the matrix-vector operation X* X* y := alpha*A*x + beta*y, X* X* where alpha and beta are scalars, x and y are n element vectors and X* A is an n by n symmetric matrix. X* X* Parameters X* ========== X* X* UPLO - CHARACTER*1. X* On entry, UPLO specifies whether the upper or lower X* triangular part of the array A is to be referenced as X* follows: X* X* UPLO = 'U' or 'u' Only the upper triangular part of A X* is to be referenced. X* X* UPLO = 'L' or 'l' Only the lower triangular part of A X* is to be referenced. X* X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the order of the matrix A. X* N must be at least zero. X* Unchanged on exit. X* X* ALPHA - DOUBLE PRECISION. X* On entry, ALPHA specifies the scalar alpha. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). X* Before entry with UPLO = 'U' or 'u', the leading n by n X* upper triangular part of the array A must contain the upper X* triangular part of the symmetric matrix and the strictly X* lower triangular part of A is not referenced. X* Before entry with UPLO = 'L' or 'l', the leading n by n X* lower triangular part of the array A must contain the lower X* triangular part of the symmetric matrix and the strictly X* upper triangular part of A is not referenced. X* Unchanged on exit. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least X* max( 1, n ). X* Unchanged on exit. X* X* X - DOUBLE PRECISION array of dimension at least X* ( 1 + ( n - 1 )*abs( INCX ) ). X* Before entry, the incremented array X must contain the n X* element vector x. X* Unchanged on exit. X* X* INCX - INTEGER. X* On entry, INCX specifies the increment for the elements of X* X. INCX must not be zero. X* Unchanged on exit. X* X* BETA - DOUBLE PRECISION. X* On entry, BETA specifies the scalar beta. When BETA is X* supplied as zero then Y need not be set on input. X* Unchanged on exit. X* X* Y - DOUBLE PRECISION array of dimension at least X* ( 1 + ( n - 1 )*abs( INCY ) ). X* Before entry, the incremented array Y must contain the n X* element vector y. On exit, Y is overwritten by the updated X* vector y. X* X* INCY - INTEGER. X* On entry, INCY specifies the increment for the elements of X* Y. INCY must not be zero. X* Unchanged on exit. X* X* X* Level 2 Blas routine. X* X* -- Written on 22-October-1986. X* Jack Dongarra, Argonne National Lab. X* Jeremy Du Croz, Nag Central Office. X* Sven Hammarling, Nag Central Office. X* Richard Hanson, Sandia National Labs. X* X* X* .. Parameters .. X DOUBLE PRECISION ONE , ZERO X PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) X* .. Local Scalars .. X DOUBLE PRECISION TEMP1, TEMP2 X INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF ( .NOT.LSAME( UPLO, 'U' ).AND. X $ .NOT.LSAME( UPLO, 'L' ) )THEN X INFO = 1 X ELSE IF( N.LT.0 )THEN X INFO = 2 X ELSE IF( LDA.LT.MAX( 1, N ) )THEN X INFO = 5 X ELSE IF( INCX.EQ.0 )THEN X INFO = 7 X ELSE IF( INCY.EQ.0 )THEN X INFO = 10 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DSYMV ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) X $ RETURN X* X* Set up the start points in X and Y. X* X IF( INCX.GT.0 )THEN X KX = 1 X ELSE X KX = 1 - ( N - 1 )*INCX X END IF X IF( INCY.GT.0 )THEN X KY = 1 X ELSE X KY = 1 - ( N - 1 )*INCY X END IF X* X* Start the operations. In this version the elements of A are X* accessed sequentially with one pass through the triangular part X* of A. X* X* First form y := beta*y. X* X IF( BETA.NE.ONE )THEN X IF( INCY.EQ.1 )THEN X IF( BETA.EQ.ZERO )THEN X DO 10, I = 1, N X Y( I ) = ZERO X 10 CONTINUE X ELSE X DO 20, I = 1, N X Y( I ) = BETA*Y( I ) X 20 CONTINUE X END IF X ELSE X IY = KY X IF( BETA.EQ.ZERO )THEN X DO 30, I = 1, N X Y( IY ) = ZERO X IY = IY + INCY X 30 CONTINUE X ELSE X DO 40, I = 1, N X Y( IY ) = BETA*Y( IY ) X IY = IY + INCY X 40 CONTINUE X END IF X END IF X END IF X IF( ALPHA.EQ.ZERO ) X $ RETURN X IF( LSAME( UPLO, 'U' ) )THEN X* X* Form y when A is stored in upper triangle. X* X IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN X DO 60, J = 1, N X TEMP1 = ALPHA*X( J ) X TEMP2 = ZERO X DO 50, I = 1, J - 1 X Y( I ) = Y( I ) + TEMP1*A( I, J ) X TEMP2 = TEMP2 + A( I, J )*X( I ) X 50 CONTINUE X Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2 X 60 CONTINUE X ELSE X JX = KX X JY = KY X DO 80, J = 1, N X TEMP1 = ALPHA*X( JX ) X TEMP2 = ZERO X IX = KX X IY = KY X DO 70, I = 1, J - 1 X Y( IY ) = Y( IY ) + TEMP1*A( I, J ) X TEMP2 = TEMP2 + A( I, J )*X( IX ) X IX = IX + INCX X IY = IY + INCY X 70 CONTINUE X Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2 X JX = JX + INCX X JY = JY + INCY X 80 CONTINUE X END IF X ELSE X* X* Form y when A is stored in lower triangle. X* X IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN X DO 100, J = 1, N X TEMP1 = ALPHA*X( J ) X TEMP2 = ZERO X Y( J ) = Y( J ) + TEMP1*A( J, J ) X DO 90, I = J + 1, N X Y( I ) = Y( I ) + TEMP1*A( I, J ) X TEMP2 = TEMP2 + A( I, J )*X( I ) X 90 CONTINUE X Y( J ) = Y( J ) + ALPHA*TEMP2 X 100 CONTINUE X ELSE X JX = KX X JY = KY X DO 120, J = 1, N X TEMP1 = ALPHA*X( JX ) X TEMP2 = ZERO X Y( JY ) = Y( JY ) + TEMP1*A( J, J ) X IX = JX X IY = JY X DO 110, I = J + 1, N X IX = IX + INCX X IY = IY + INCY X Y( IY ) = Y( IY ) + TEMP1*A( I, J ) X TEMP2 = TEMP2 + A( I, J )*X( IX ) X 110 CONTINUE X Y( JY ) = Y( JY ) + ALPHA*TEMP2 X JX = JX + INCX X JY = JY + INCY X 120 CONTINUE X END IF X END IF X* X RETURN X* X* End of DSYMV . X* X END END_OF_FILE if test 8072 -ne `wc -c <'dsymv.f'`; then echo shar: \"'dsymv.f'\" unpacked with wrong size! fi # end of 'dsymv.f' fi if test -f 'dsyr.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dsyr.f'\" else echo shar: Extracting \"'dsyr.f'\" \(5964 characters\) sed "s/^X//" >'dsyr.f' <<'END_OF_FILE' X SUBROUTINE DSYR ( UPLO, N, ALPHA, X, INCX, A, LDA ) X* .. Scalar Arguments .. X DOUBLE PRECISION ALPHA X INTEGER INCX, LDA, N X CHARACTER*1 UPLO X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), X( * ) X* .. X* X* Purpose X* ======= X* X* DSYR performs the symmetric rank 1 operation X* X* A := alpha*x*x' + A, X* X* where alpha is a real scalar, x is an n element vector and A is an X* n by n symmetric matrix. X* X* Parameters X* ========== X* X* UPLO - CHARACTER*1. X* On entry, UPLO specifies whether the upper or lower X* triangular part of the array A is to be referenced as X* follows: X* X* UPLO = 'U' or 'u' Only the upper triangular part of A X* is to be referenced. X* X* UPLO = 'L' or 'l' Only the lower triangular part of A X* is to be referenced. X* X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the order of the matrix A. X* N must be at least zero. X* Unchanged on exit. X* X* ALPHA - DOUBLE PRECISION. X* On entry, ALPHA specifies the scalar alpha. X* Unchanged on exit. X* X* X - DOUBLE PRECISION array of dimension at least X* ( 1 + ( n - 1 )*abs( INCX ) ). X* Before entry, the incremented array X must contain the n X* element vector x. X* Unchanged on exit. X* X* INCX - INTEGER. X* On entry, INCX specifies the increment for the elements of X* X. INCX must not be zero. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). X* Before entry with UPLO = 'U' or 'u', the leading n by n X* upper triangular part of the array A must contain the upper X* triangular part of the symmetric matrix and the strictly X* lower triangular part of A is not referenced. On exit, the X* upper triangular part of the array A is overwritten by the X* upper triangular part of the updated matrix. X* Before entry with UPLO = 'L' or 'l', the leading n by n X* lower triangular part of the array A must contain the lower X* triangular part of the symmetric matrix and the strictly X* upper triangular part of A is not referenced. On exit, the X* lower triangular part of the array A is overwritten by the X* lower triangular part of the updated matrix. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least X* max( 1, n ). X* Unchanged on exit. X* X* X* Level 2 Blas routine. X* X* -- Written on 22-October-1986. X* Jack Dongarra, Argonne National Lab. X* Jeremy Du Croz, Nag Central Office. X* Sven Hammarling, Nag Central Office. X* Richard Hanson, Sandia National Labs. X* X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D+0 ) X* .. Local Scalars .. X DOUBLE PRECISION TEMP X INTEGER I, INFO, IX, J, JX, KX X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF ( .NOT.LSAME( UPLO, 'U' ).AND. X $ .NOT.LSAME( UPLO, 'L' ) )THEN X INFO = 1 X ELSE IF( N.LT.0 )THEN X INFO = 2 X ELSE IF( INCX.EQ.0 )THEN X INFO = 5 X ELSE IF( LDA.LT.MAX( 1, N ) )THEN X INFO = 7 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DSYR ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) X $ RETURN X* X* Set the start point in X if the increment is not unity. X* X IF( INCX.LE.0 )THEN X KX = 1 - ( N - 1 )*INCX X ELSE IF( INCX.NE.1 )THEN X KX = 1 X END IF X* X* Start the operations. In this version the elements of A are X* accessed sequentially with one pass through the triangular part X* of A. X* X IF( LSAME( UPLO, 'U' ) )THEN X* X* Form A when A is stored in upper triangle. X* X IF( INCX.EQ.1 )THEN X DO 20, J = 1, N X IF( X( J ).NE.ZERO )THEN X TEMP = ALPHA*X( J ) X DO 10, I = 1, J X A( I, J ) = A( I, J ) + X( I )*TEMP X 10 CONTINUE X END IF X 20 CONTINUE X ELSE X JX = KX X DO 40, J = 1, N X IF( X( JX ).NE.ZERO )THEN X TEMP = ALPHA*X( JX ) X IX = KX X DO 30, I = 1, J X A( I, J ) = A( I, J ) + X( IX )*TEMP X IX = IX + INCX X 30 CONTINUE X END IF X JX = JX + INCX X 40 CONTINUE X END IF X ELSE X* X* Form A when A is stored in lower triangle. X* X IF( INCX.EQ.1 )THEN X DO 60, J = 1, N X IF( X( J ).NE.ZERO )THEN X TEMP = ALPHA*X( J ) X DO 50, I = J, N X A( I, J ) = A( I, J ) + X( I )*TEMP X 50 CONTINUE X END IF X 60 CONTINUE X ELSE X JX = KX X DO 80, J = 1, N X IF( X( JX ).NE.ZERO )THEN X TEMP = ALPHA*X( JX ) X IX = JX X DO 70, I = J, N X A( I, J ) = A( I, J ) + X( IX )*TEMP X IX = IX + INCX X 70 CONTINUE X END IF X JX = JX + INCX X 80 CONTINUE X END IF X END IF X* X RETURN X* X* End of DSYR . X* X END END_OF_FILE if test 5964 -ne `wc -c <'dsyr.f'`; then echo shar: \"'dsyr.f'\" unpacked with wrong size! fi # end of 'dsyr.f' fi if test -f 'dsyr2.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dsyr2.f'\" else echo shar: Extracting \"'dsyr2.f'\" \(7342 characters\) sed "s/^X//" >'dsyr2.f' <<'END_OF_FILE' X SUBROUTINE DSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) X* .. Scalar Arguments .. X DOUBLE PRECISION ALPHA X INTEGER INCX, INCY, LDA, N X CHARACTER*1 UPLO X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) X* .. X* X* Purpose X* ======= X* X* DSYR2 performs the symmetric rank 2 operation X* X* A := alpha*x*y' + alpha*y*x' + A, X* X* where alpha is a scalar, x and y are n element vectors and A is an n X* by n symmetric matrix. X* X* Parameters X* ========== X* X* UPLO - CHARACTER*1. X* On entry, UPLO specifies whether the upper or lower X* triangular part of the array A is to be referenced as X* follows: X* X* UPLO = 'U' or 'u' Only the upper triangular part of A X* is to be referenced. X* X* UPLO = 'L' or 'l' Only the lower triangular part of A X* is to be referenced. X* X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the order of the matrix A. X* N must be at least zero. X* Unchanged on exit. X* X* ALPHA - DOUBLE PRECISION. X* On entry, ALPHA specifies the scalar alpha. X* Unchanged on exit. X* X* X - DOUBLE PRECISION array of dimension at least X* ( 1 + ( n - 1 )*abs( INCX ) ). X* Before entry, the incremented array X must contain the n X* element vector x. X* Unchanged on exit. X* X* INCX - INTEGER. X* On entry, INCX specifies the increment for the elements of X* X. INCX must not be zero. X* Unchanged on exit. X* X* Y - DOUBLE PRECISION array of dimension at least X* ( 1 + ( n - 1 )*abs( INCY ) ). X* Before entry, the incremented array Y must contain the n X* element vector y. X* Unchanged on exit. X* X* INCY - INTEGER. X* On entry, INCY specifies the increment for the elements of X* Y. INCY must not be zero. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). X* Before entry with UPLO = 'U' or 'u', the leading n by n X* upper triangular part of the array A must contain the upper X* triangular part of the symmetric matrix and the strictly X* lower triangular part of A is not referenced. On exit, the X* upper triangular part of the array A is overwritten by the X* upper triangular part of the updated matrix. X* Before entry with UPLO = 'L' or 'l', the leading n by n X* lower triangular part of the array A must contain the lower X* triangular part of the symmetric matrix and the strictly X* upper triangular part of A is not referenced. On exit, the X* lower triangular part of the array A is overwritten by the X* lower triangular part of the updated matrix. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least X* max( 1, n ). X* Unchanged on exit. X* X* X* Level 2 Blas routine. X* X* -- Written on 22-October-1986. X* Jack Dongarra, Argonne National Lab. X* Jeremy Du Croz, Nag Central Office. X* Sven Hammarling, Nag Central Office. X* Richard Hanson, Sandia National Labs. X* X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D+0 ) X* .. Local Scalars .. X DOUBLE PRECISION TEMP1, TEMP2 X INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF ( .NOT.LSAME( UPLO, 'U' ).AND. X $ .NOT.LSAME( UPLO, 'L' ) )THEN X INFO = 1 X ELSE IF( N.LT.0 )THEN X INFO = 2 X ELSE IF( INCX.EQ.0 )THEN X INFO = 5 X ELSE IF( INCY.EQ.0 )THEN X INFO = 7 X ELSE IF( LDA.LT.MAX( 1, N ) )THEN X INFO = 9 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DSYR2 ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) X $ RETURN X* X* Set up the start points in X and Y if the increments are not both X* unity. X* X IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN X IF( INCX.GT.0 )THEN X KX = 1 X ELSE X KX = 1 - ( N - 1 )*INCX X END IF X IF( INCY.GT.0 )THEN X KY = 1 X ELSE X KY = 1 - ( N - 1 )*INCY X END IF X JX = KX X JY = KY X END IF X* X* Start the operations. In this version the elements of A are X* accessed sequentially with one pass through the triangular part X* of A. X* X IF( LSAME( UPLO, 'U' ) )THEN X* X* Form A when A is stored in the upper triangle. X* X IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN X DO 20, J = 1, N X IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN X TEMP1 = ALPHA*Y( J ) X TEMP2 = ALPHA*X( J ) X DO 10, I = 1, J X A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 X 10 CONTINUE X END IF X 20 CONTINUE X ELSE X DO 40, J = 1, N X IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN X TEMP1 = ALPHA*Y( JY ) X TEMP2 = ALPHA*X( JX ) X IX = KX X IY = KY X DO 30, I = 1, J X A( I, J ) = A( I, J ) + X( IX )*TEMP1 X $ + Y( IY )*TEMP2 X IX = IX + INCX X IY = IY + INCY X 30 CONTINUE X END IF X JX = JX + INCX X JY = JY + INCY X 40 CONTINUE X END IF X ELSE X* X* Form A when A is stored in the lower triangle. X* X IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN X DO 60, J = 1, N X IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN X TEMP1 = ALPHA*Y( J ) X TEMP2 = ALPHA*X( J ) X DO 50, I = J, N X A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 X 50 CONTINUE X END IF X 60 CONTINUE X ELSE X DO 80, J = 1, N X IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN X TEMP1 = ALPHA*Y( JY ) X TEMP2 = ALPHA*X( JX ) X IX = JX X IY = JY X DO 70, I = J, N X A( I, J ) = A( I, J ) + X( IX )*TEMP1 X $ + Y( IY )*TEMP2 X IX = IX + INCX X IY = IY + INCY X 70 CONTINUE X END IF X JX = JX + INCX X JY = JY + INCY X 80 CONTINUE X END IF X END IF X* X RETURN X* X* End of DSYR2 . X* X END END_OF_FILE if test 7342 -ne `wc -c <'dsyr2.f'`; then echo shar: \"'dsyr2.f'\" unpacked with wrong size! fi # end of 'dsyr2.f' fi if test -f 'dsyt21.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dsyt21.f'\" else echo shar: Extracting \"'dsyt21.f'\" \(11148 characters\) sed "s/^X//" >'dsyt21.f' <<'END_OF_FILE' X SUBROUTINE DSYT21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V, X $ LDV, TAU, WORK, RESULT ) X* X* -- LAPACK test routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X* X CHARACTER UPLO X INTEGER ITYPE, KBAND, LDA, LDU, LDV, N X* .. X* X* .. Array Arguments .. X* X DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), RESULT( 2 ), X $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * ) X* .. X* X*----------------------------------------------------------------------- X* X* Purpose X* ======= X* X* DSYT21 generally checks a decomposition of the form X* X* A = U S U' X* X* where ' means transpose, A is symmetric, U is orthogonal, and S X* is diagonal (if KBAND=0) or symmetric tridiagonal (if X* KBAND=1). If ITYPE=1, then U is represented as a dense matrix, X* otherwise the U is expressed as a product of Householder X* transformations, whose vectors are stored in the array "V" and X* whose scaling constants are in "TAU"; we shall use the letter X* "V" to refer to the product of Householder transformations X* (which should be equal to U). X* X* Specifically, if ITYPE=1, then: X* X* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* X* RESULT(2) = | I - UU' | / ( n ulp ) X* X* If ITYPE=2, then: X* X* RESULT(1) = | A - V S V' | / ( |A| n ulp ) X* X* If ITYPE=3, then: X* X* RESULT(1) = | I - VU' | / ( n ulp ) X* X* X* For ITYPE > 1, the transformation U is expressed as a product X* V = H(1)...H(n-2), where H(j) = I - tau(j) v(j) v(j)' X* and each vector v(j) has its first j elements 0 and the X* remaining n-j elements stored in V(j+1:n,j). X* X* Arguments X* ========== X* X* ITYPE - INTEGER X* Specifies the type of tests to be performed. X* 1: U expressed as a dense orthogonal matrix: X* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* X* RESULT(2) = | I - UU' | / ( n ulp ) X* X* 2: U expressed as a product V of Housholder transformations: X* RESULT(1) = | A - V S V' | / ( |A| n ulp ) X* X* 3: U expressed both as a dense orthogonal matrix and X* as a product of Housholder transformations: X* RESULT(1) = | I - VU' | / ( n ulp ) X* X* UPLO - CHARACTER X* If UPLO='U', the upper triangle of A will be used and the X* (strictly) lower triangle will not be referenced. If X* UPLO='L', the lower triangle of A will be used and the X* (strictly) upper triangle will not be referenced. X* Not modified. X* X* N - INTEGER (INPUT) X* The size of the matrix. If it is zero, DSYT21 does nothing. X* It must be at least zero. X* Not modified. X* X* KBAND - INTEGER (INPUT) X* The bandwidth of the matrix. It may only be zero or one. X* If zero, then S is diagonal, and E is not referenced. If X* one, then S is symmetric tri-diagonal. X* Not modified. X* X* A - DOUBLE PRECISION array of dimension ( LDA , N ) X* The original (unfactored) matrix. It is assumed to be X* symmetric, and only the upper (UPLO='U') or only the lower X* (UPLO='L') will be referenced. X* Not modified. X* X* LDA - INTEGER. (INPUT) X* The leading dimension of A. It must be at least 1 X* and at least N. X* Not modified. X* X* D - DOUBLE PRECISION array of dimension ( N ) X* The diagonal of the (symmetric tri-) diagonal matrix. X* Not modified. X* X* E - DOUBLE PRECISION array of dimension ( N ) X* The off-diagonal of the (symmetric tri-) diagonal matrix. X* E(1) is ignored, E(2) is the (1,2) and (2,1) element, etc. X* Not referenced if KBAND=0. X* Not modified. X* X* U - DOUBLE PRECISION array of dimension ( LDU, N ). X* If ITYPE=1 or 3, this contains the orthogonal matrix in X* the decomposition, expressed as a dense matrix. If ITYPE=2, X* then it is not referenced. X* Not modified. X* X* LDU - INTEGER X* The leading dimension of U. LDU must be at least N and X* at least 1. X* Not modified. X* X* V - DOUBLE PRECISION array of dimension ( LDV, N ). X* If ITYPE=2 or 3, the lower triangle of this array contains X* the Householder vectors used to describe the orthogonal X* matrix in the decomposition. If ITYPE=1, then it is not X* referenced. X* Not modified. X* X* LDV - INTEGER X* The leading dimension of V. LDV must be at least N and X* at least 1. X* Not modified. X* X* TAU - DOUBLE PRECISION array of dimension ( N ) X* If ITYPE >= 2, then TAU(j) is the scalar factor of X* v(j) v(j)' in the Householder transformation H(j) of X* the product U = H(1)...H(n-2) X* If ITYPE < 2, then TAU is not referenced. X* Not modified. X* X* WORK - DOUBLE PRECISION array of dimension ( 2*N**2 ) X* Workspace. X* Modified. X* X* RESULT - DOUBLE PRECISION array of dimension ( 2 ) X* The values computed by the two tests described above. The X* values are currently limited to 1/ulp, to avoid overflow. X* RESULT(1) is always modified. RESULT(2) is modified only X* if LDU is at least N. X* Modified. X* X*----------------------------------------------------------------------- X* X* X* .. Parameters .. X* X DOUBLE PRECISION ZERO, ONE, TEN X PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 ) X* .. X* X* .. Local Scalars .. X* X CHARACTER CUPLO X INTEGER IINFO, IUPLO, J, JCOL, JROW X DOUBLE PRECISION ANORM, ULP, UNFL, WNORM X* .. X* X* .. External Functions .. X* X LOGICAL LSAME X DOUBLE PRECISION DLAMCH, DLANGE, DLANSY X EXTERNAL LSAME, DLAMCH, DLANGE, DLANSY X* .. X* X* .. External Subroutines .. X* X EXTERNAL DAXPY, DCOPY, DGEMM, DLACPY, DLARFY, DLAZRO, X $ DORMC2, DSYR, DSYR2 X* .. X* X* .. Intrinsic Functions .. X* X INTRINSIC DBLE, MAX, MIN X* .. X* X* X*----------------------------------------------------------------------- X* .. Executable Statements .. X* X* X* 1) Constants X* X* X RESULT( 1 ) = ZERO X IF( ITYPE.EQ.1 ) X $ RESULT( 2 ) = ZERO X IF( N.LE.0 ) X $ RETURN X* X IF( LSAME( UPLO, 'U' ) ) THEN X IUPLO = 2 X CUPLO = 'U' X ELSE X IUPLO = 1 X CUPLO = 'L' X END IF X* X UNFL = DLAMCH( 'Safe minimum' ) X ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) X* X* X* Some Error Checks X* X IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN X RESULT( 1 ) = TEN / ULP X RETURN X END IF X* X*----------------------------------------------------------------------- X* X* X* Do Test 1 X* X* Norm of A: X* X IF( ITYPE.EQ.3 ) THEN X ANORM = ONE X ELSE X ANORM = MAX( DLANSY( '1', CUPLO, N, A, LDA, WORK ), UNFL ) X END IF X* X* X* Compute error matrix: X* X IF( ITYPE.EQ.1 ) THEN X* X* ITYPE=1: error = A - U S U' X* X CALL DLAZRO( N, N, ZERO, ZERO, WORK, N ) X CALL DLACPY( CUPLO, N, N, A, LDA, WORK, N ) X* X DO 10 J = 1, N X CALL DSYR( CUPLO, N, -D( J ), U( 1, J ), 1, WORK, N ) X 10 CONTINUE X* X IF( N.GT.1 .AND. KBAND.EQ.1 ) THEN X DO 20 J = 2, N X CALL DSYR2( CUPLO, N, -E( J ), U( 1, J-1 ), 1, U( 1, J ), X $ 1, WORK, N ) X 20 CONTINUE X END IF X WNORM = DLANSY( '1', CUPLO, N, WORK, N, WORK( N**2+1 ) ) X* X ELSE IF( ITYPE.EQ.2 ) THEN X* X* ITYPE=2: error = V S V' - A X* X CALL DLAZRO( N, N, ZERO, ZERO, WORK, N ) X CALL DCOPY( N, D, 1, WORK, N+1 ) X* X DO 30 J = N - 1, 1, -1 X IF( KBAND.EQ.1 ) THEN X IF( IUPLO.EQ.1 ) THEN X WORK( ( N+1 )*( J-1 )+2 ) = E( J+1 ) X CALL DAXPY( N-J, -TAU( J )*V( J+1, J )*E( J+1 ), X $ V( J+1, J ), 1, WORK( ( N+1 )*( J-1 )+2 ), X $ 1 ) X ELSE X WORK( ( N+1 )*J ) = E( J+1 ) X CALL DAXPY( N-J, -TAU( J )*V( J+1, J )*E( J+1 ), X $ V( J+1, J ), 1, WORK( ( N+1 )*J ), N ) X END IF X END IF X* X CALL DLARFY( CUPLO, N-J, V( J+1, J ), 1, TAU( J ), X $ WORK( ( N+1 )*J+1 ), N, WORK( N**2+1 ) ) X 30 CONTINUE X* X DO 60 JCOL = 1, N X IF( IUPLO.EQ.1 ) THEN X DO 40 JROW = JCOL, N X WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) ) X $ - A( JROW, JCOL ) X 40 CONTINUE X ELSE X DO 50 JROW = 1, JCOL X WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) ) X $ - A( JROW, JCOL ) X 50 CONTINUE X END IF X 60 CONTINUE X WNORM = DLANSY( '1', CUPLO, N, WORK, N, WORK( N**2+1 ) ) X* X* X* ITYPE=3: error = V U' - I X* X* X ELSE IF( ITYPE.EQ.3 ) THEN X IF( N.LT.2 ) X $ RETURN X CALL DLACPY( ' ', N, N, U, LDU, WORK, N ) X CALL DORMC2( 'R', 'T', N, N-1, N-1, V( 2, 1 ), LDU, TAU, X $ WORK( N+1 ), N, WORK( N**2+1 ), IINFO ) X IF( IINFO.NE.0 ) THEN X RESULT( 1 ) = TEN / ULP X RETURN X END IF X* X DO 70 J = 1, N X WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE X 70 CONTINUE X* X WNORM = DLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) ) X END IF X* X IF( ANORM.GT.WNORM ) THEN X RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP ) X ELSE X IF( ANORM.LT.ONE ) THEN X RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP ) X ELSE X RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP ) X END IF X END IF X* X* . . . . . . . . . . . . . . X* X* Do Test 2 X* X* Compute UU' - I X* X IF( ITYPE.EQ.1 ) THEN X CALL DGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK, X $ N ) X* X DO 80 J = 1, N X WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE X 80 CONTINUE X* X RESULT( 2 ) = MIN( DLANGE( '1', N, N, WORK, N, X $ WORK( N**2+1 ) ), DBLE( N ) ) / ( N*ULP ) X END IF X* X*----------------------------------------------------------------------- X* X* X RETURN X* X* End of DSYT21 X* X END END_OF_FILE if test 11148 -ne `wc -c <'dsyt21.f'`; then echo shar: \"'dsyt21.f'\" unpacked with wrong size! fi # end of 'dsyt21.f' fi if test -f 'dtrevc.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dtrevc.f'\" else echo shar: Extracting \"'dtrevc.f'\" \(31995 characters\) sed "s/^X//" >'dtrevc.f' <<'END_OF_FILE' X SUBROUTINE DTREVC( JOB, SELECT, N, T, LDT, RE, LDRE, LE, LDLE, MM, X $ M, RWORK, INFO ) X* X* -- LAPACK routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER JOB X INTEGER INFO, LDLE, LDRE, LDT, M, MM, N X* .. X* X* .. Array Arguments .. X LOGICAL SELECT( * ) X DOUBLE PRECISION LE( LDLE, * ), RE( LDRE, * ), RWORK( * ), X $ T( LDT, * ) X* .. X* X* Purpose X* ======= X* X* Compute selected right and/or left eigenvectors of a X* Schur canonical matrix T. X* X* Arguments X* ========= X* X* JOB - CHARACTER*1 X* JOB specifies the computation to be performed by DTREVC X* as follows: X* If JOB = 'R', compute right eigenvectors only. X* If JOB = 'L', compute left eigenvectors only. X* If JOB = 'B', compute both right and left eigenvectors. X* Not modified. X* X* SELECT - LOGICAL array, dimension (N). X* SELECT specifies the eigenvectors to be computed. To get X* the eigenvector corresponding to the j-th eigenvalue, set X* SELECT(J) to .TRUE. To get the eigenvectors corresponding X* to a complex conjugate pair of eigenvalues, set the element X* of SELECT corresponding to the first eigenvalue of the pair X* to .TRUE. and the second to .FALSE. (Currently, the value X* of the first element of the pair determines whether the X* pair of eigenvectors is computed.) X* X* On exit, SELECT may have been altered. If the elements of X* SELECT corresponding to a complex conjugate pair of X* eigenvalues were both initially set to .TRUE., the program X* resets the second of the two elements to .FALSE. X* X* X* N - INTEGER. X* N specifies the order of matrix T. N must be at least zero. X* Not modified. X* X* T - DOUBLE PRECISION array, dimension (LDT,N). X* T contains the matrix whose eigenvectors are to be computed; X* it must be in Schur canonical form. X* Not modified. X* X* LDT - INTEGER. X* LDT specifies the first dimension of T as declared in X* the calling (sub)program. LDT must be at least max(1, N). X* Not modified. X* X* RE - DOUBLE PRECISION array, dimension (LDRE,MM) X* The *right* eigenvectors specified by SELECT will be stored X* one after another in the columns of RE, in the same *order* X* (but not necessarily the same position) as their X* eigenvalues. An eigenvector corresponding to a SELECTed X* *real* eigenvalue will take up one column. An eigenvector X* pair corresponding to a SELECTed *complex conjugate pair* X* of eigenvalues will take up two columns: the first column X* will hold the real part, the second will hold the imaginary X* part of the eigenvector corresponding to the eigenvalue X* with *positive* imaginary part. X* X* If the j-th eigenvalue is real, then the last n-j elements X* of its right eigenvector are zero. If the j-th and j+1st X* eigenvalues are a complex pair, then the last n-j elements X* of the real part and the last n-j-1 elements of the X* imaginary part of its eigenvector will be zero. Thus, if X* all eigenvectors are selected, RE will be in upper X* triangular form. X* X* The eigenvectors will be normalized so that the component X* of largest magnitude is 1; here, the magnitude of a complex X* number x + iy is considered to be |x| + |y|. X* X* If JOB = 'R' or 'B', RE will be modified. X* If JOB = 'L', RE will not be referenced. X* X* LDRE - INTEGER X* LDRE specifies the leading dimension of RE as declared in X* the calling (sub)program. LDRE must be at least max(1, N). X* If JOB = 'L', LDRE is not referenced. X* Not modified. X* X* LE - DOUBLE PRECISION array, dimension (LDLE,MM) X* The conjugate transposes of the *left* eigenvectors X* specified by SELECT will be stored one after another in the X* columns of LE, in the same *order* (but not necessarily the X* same position) as their eigenvalues. An eigenvector X* corresponding to a SELECTed *real* eigenvalue will take up X* one column. An eigenvector pair corresponding to a X* SELECTed *complex conjugate pair* of eigenvalues will take X* up two columns: the first column will hold the real part, X* the second will hold the imaginary part of the conjugate X* transpose of the left eigenvector corresponding to the X* eigenvalue with *positive* imaginary part. X* X* If the j-th eigenvalue is real, then the first j-1 elements X* of its left eigenvector are zero. If the j-th and j+1st X* eigenvalues are a complex pair, then the first j-1 elements X* of the real part and the first j elements of the imaginary X* part of its left eigenvector will be zero. Thus, if all X* eigenvectors are selected, RE will be in upper triangular X* form. X* X* The eigenvectors will be normalized so that the component X* of largest magnitude is 1; here, the magnitude of a complex X* number x + iy is considered to be |x| + |y|. X* X* If JOB = 'L' or 'B', LE will be modified. X* If JOB = 'R', LE will not be referenced. X* X* X* LDLE - INTEGER X* LDLE specifies the leading dimension of LE as declared in X* the calling (sub)program. LDLE must be at least max(1, N). X* If JOB = 'R', LDLE is not referenced. X* Not modified. X* X* MM - INTEGER X* The number of columns in LE and/or RE. Note that X* two columns are required to store the eigenvector X* corresponding to a complex eigenvalue. X* Not modified. X* X* M - INTEGER X* On exit, M is the number of columns in LE and/or RE actually X* used to store the eigenvectors. X* X* RWORK - DOUBLE PRECISION array, dimension(N) X* Workspace. X* X* INFO - INTEGER X* INFO is set to X* 0 for normal return X* -k if input argument number k is illegal. X* N+1 if more than MM columns of RE or LE are X* necessary to store the selected eigenvectors. X* X* .. Parameters .. X DOUBLE PRECISION ZERO, ONE X PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) X* .. X* X* .. Local Scalars .. X INTEGER I, IERR, IJOB, IP, J, J1, J2, JNEXT, K, KI, S X DOUBLE PRECISION ALPHA, BETA, BIGNUM, EMAX, OVFL, REC, REMAX, X $ SCALE, SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, X $ WI, WR, XNORM X* .. X* X* .. External Functions .. X LOGICAL LSAME X DOUBLE PRECISION DDOT, DLAMCH X EXTERNAL LSAME, DDOT, DLAMCH X* .. X* X* .. External Subroutines .. X EXTERNAL DLALN2, XERBLA X* .. X* X* .. Intrinsic Functions .. X INTRINSIC ABS, MAX, SQRT X* .. X* X* .. Local Arrays .. X DOUBLE PRECISION X( 2, 2 ) X* .. X* .. Executable Statements .. X* X* Decode and Test the input parameters X* X IF( LSAME( JOB, 'R' ) ) THEN X IJOB = 1 X ELSE IF( LSAME( JOB, 'L' ) ) THEN X IJOB = 2 X ELSE IF( LSAME( JOB, 'B' ) ) THEN X IJOB = 3 X ELSE X IJOB = -1 X END IF X* X INFO = 0 X IF( IJOB.EQ.-1 ) THEN X INFO = -1 X ELSE IF( N.LT.0 ) THEN X INFO = -3 X ELSE IF( LDT.LT.MAX( 1, N ) ) THEN X INFO = -5 X END IF X IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN X IF( LDRE.LT.MAX( 1, N ) ) X $ INFO = -7 X END IF X IF( IJOB.EQ.2 .OR. IJOB.EQ.3 ) THEN X IF( LDLE.LT.MAX( 1, N ) ) X $ INFO = -9 X END IF X IF( INFO.NE.0 ) THEN X CALL XERBLA( 'DTREVC', -INFO ) X RETURN X END IF X* X* Quick return if possible X* X IF( N.EQ.0 ) X $ RETURN X* X* Set the contants to control overflow X* X UNFL = DLAMCH( 'Safe minimum' ) X OVFL = DLAMCH( 'Overflow' ) X ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' ) X SMLNUM = MAX( UNFL*( N/ULP ), N/( ULP*OVFL ) ) X BIGNUM = ( ONE-ULP ) / SMLNUM X* X* Compute 1-norm of each column of strictly upper triangular X* part of T to control overflow in triangular solver. X* X RWORK( 1 ) = ZERO X DO 20 J = 2, N X RWORK( J ) = ZERO X DO 10 I = 1, J - 1 X RWORK( J ) = RWORK( J ) + ABS( T( I, J ) ) X 10 CONTINUE X 20 CONTINUE X* X* ip = 0, real eigenvalue, X* 1, first of conjugate complex pair: wr + i*wi X* -1, second of conjugate complex pair: wr - i*wi X* X IP = 0 X S = 1 X* X DO 450 KI = 1, N X IF( IP.EQ.-1 ) X $ GO TO 440 X IF( KI.EQ.N ) X $ GO TO 30 X IF( T( KI+1, KI ).EQ.ZERO ) X $ GO TO 30 X IP = 1 X IF( SELECT( KI ) .AND. SELECT( KI+1 ) ) X $ SELECT( KI+1 ) = .FALSE. X 30 CONTINUE X IF( .NOT.SELECT( KI ) ) X $ GO TO 440 X IF( IP.NE.0 ) X $ S = S + 1 X IF( S.GT.MM ) X $ GO TO 460 X* X* KI is the index of real eigenvalue or the first index X* of conjugate complex pair. X* X WR = T( KI, KI ) X WI = ZERO X IF( IP.NE.0 ) X $ WI = SQRT( ABS( T( KI, KI+1 ) ) )* X $ SQRT( ABS( T( KI+1, KI ) ) ) X SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM ) X* X* Compute the right eigenvector of KIth eigenvalue. X* X IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN X* X* The KIth real eigenvalue. X* X IF( IP.EQ.0 ) THEN X RE( KI, S ) = ONE X IF( KI.EQ.1 ) X $ GO TO 120 X* X* Form right-side. X* X DO 40 K = 1, KI - 1 X RE( K, S ) = -T( K, KI ) X 40 CONTINUE X* X* Solve the upper quasi-triangular system: X* (t(1:ki-1,1:ki-1) - wr)*x = scale*re(*,s). X* X JNEXT = KI - 1 X DO 90 J = KI - 1, 1, -1 X IF( J.GT.JNEXT ) X $ GO TO 90 X J1 = J X J2 = J X JNEXT = J - 1 X IF( J.GT.1 ) THEN X IF( T( J, J-1 ).NE.ZERO ) THEN X J1 = J - 1 X JNEXT = J - 2 X END IF X END IF X* X IF( J1.EQ.J2 ) THEN X* X* Meet 1-by-1 block X* X CALL DLALN2( 0, 1, 1, SMIN, T( J, J ), LDT, X $ RE( J, S ), LDRE, WR, ZERO, X, 2, X $ SCALE, XNORM, IERR ) X* X* Scale X(1,1) to avoid overflow in the X* updating right-hand side. X* X ALPHA = ABS( X( 1, 1 ) ) X IF( ALPHA.GT.ONE ) THEN X IF( RWORK( J ).GT.BIGNUM/ALPHA ) THEN X X( 1, 1 ) = X( 1, 1 ) / ALPHA X SCALE = SCALE / ALPHA X END IF X END IF X* X* Scaling if necessary X* X IF( SCALE.NE.ONE ) THEN X DO 50 K = 1, KI X RE( K, S ) = SCALE*RE( K, S ) X 50 CONTINUE X END IF X RE( J, S ) = X( 1, 1 ) X* X* Update right-side X* X DO 60 K = 1, J - 1 X RE( K, S ) = RE( K, S ) - T( K, J )*RE( J, S ) X 60 CONTINUE X* X ELSE X* X* Meet 2-by-2 block. X* X CALL DLALN2( 0, 2, 1, SMIN, T( J-1, J-1 ), LDT, X $ RE( J-1, S ), LDRE, WR, ZERO, X, 2, X $ SCALE, XNORM, IERR ) X* X* Scale X(1,1) and X(2,1) to avoid X* overflow in the updating right-hand side. X* X ALPHA = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) ) X IF( ALPHA.GT.ONE ) THEN X BETA = MAX( RWORK( J-1 ), RWORK( J ) ) X IF( BETA.GT.BIGNUM/ALPHA ) THEN X X( 1, 1 ) = X( 1, 1 ) / ALPHA X X( 2, 1 ) = X( 2, 1 ) / ALPHA X SCALE = SCALE / ALPHA X END IF X END IF X* X* Scaling if necessary X* X IF( SCALE.NE.ONE ) THEN X DO 70 K = 1, KI X RE( K, S ) = SCALE*RE( K, S ) X 70 CONTINUE X END IF X RE( J-1, S ) = X( 1, 1 ) X RE( J, S ) = X( 2, 1 ) X* X* Update right side. X* X DO 80 K = 1, J - 2 X RE( K, S ) = RE( K, S ) - X $ T( K, J-1 )*RE( J-1, S ) - X $ T( K, J )*RE( J, S ) X 80 CONTINUE X* X END IF X* X 90 CONTINUE X* X* Normalization X* X EMAX = ZERO X DO 100 K = 1, KI X EMAX = MAX( EMAX, ABS( RE( K, S ) ) ) X 100 CONTINUE X* X REMAX = ONE / EMAX X DO 110 K = 1, KI X RE( K, S ) = RE( K, S )*REMAX X 110 CONTINUE X* X* Set the rest part to zero X* X 120 CONTINUE X DO 130 K = KI + 1, N X RE( K, S ) = ZERO X 130 CONTINUE X* X* The KIth conjugate complex eigenvalues. X* X ELSE X* X* Initial solve: X* ((t(ki,ki) t(ki,ki+1) ) - (wr + i* wi))*X = 0. X* ((t(ki+1,ki) t(ki+1,ki+1)) X* X IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN X RE( KI, S-1 ) = ONE X RE( KI+1, S ) = WI / T( KI, KI+1 ) X ELSE X RE( KI, S-1 ) = -WI / T( KI+1, KI ) X RE( KI+1, S ) = ONE X END IF X RE( KI, S ) = ZERO X RE( KI+1, S-1 ) = ZERO X IF( KI.EQ.1 ) X $ GO TO 220 X* X* Form right-side X* X DO 140 K = 1, KI - 1 X RE( K, S-1 ) = -T( K, KI )*RE( KI, S-1 ) X RE( K, S ) = -T( K, KI+1 )*RE( KI+1, S ) X 140 CONTINUE X* X* Solve upper quasi-triangular system: X* (t~ - (wr+i*wi))*x = scale*(re(*,s-1)+i*re(*,s)) X* where t~ = t(1:ki-1,1:ki-1). X* X JNEXT = KI - 1 X DO 190 J = KI - 1, 1, -1 X IF( J.GT.JNEXT ) X $ GO TO 190 X J1 = J X J2 = J X JNEXT = J - 1 X IF( J.GT.1 ) THEN X IF( T( J, J-1 ).NE.ZERO ) THEN X J1 = J - 1 X JNEXT = J - 2 X END IF X END IF X* X IF( J1.EQ.J2 ) THEN X* X* Meet 1-by-1 block X* X CALL DLALN2( 0, 1, 2, SMIN, T( J, J ), LDT, X $ RE( J, S-1 ), LDRE, WR, WI, X, 2, X $ SCALE, XNORM, IERR ) X* X* Scale X(1,1) and X(1,2) to avoid overflow X* in the updating right-hand side. X* X ALPHA = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ) ) X IF( ALPHA.GT.ONE ) THEN X REC = ONE / ALPHA X IF( RWORK( J ).GT.BIGNUM*REC ) THEN X X( 1, 1 ) = X( 1, 1 )*REC X X( 1, 2 ) = X( 1, 2 )*REC X SCALE = SCALE*REC X END IF X END IF X* X* Scaling if necessary X* X IF( SCALE.NE.ONE ) THEN X DO 150 K = 1, KI + 1 X RE( K, S-1 ) = SCALE*RE( K, S-1 ) X RE( K, S ) = SCALE*RE( K, S ) X 150 CONTINUE X END IF X RE( J, S-1 ) = X( 1, 1 ) X RE( J, S ) = X( 1, 2 ) X* X* Update right-side. X* X DO 160 K = 1, J - 1 X RE( K, S-1 ) = RE( K, S-1 ) - X $ T( K, J )*RE( J, S-1 ) X RE( K, S ) = RE( K, S ) - T( K, J )*RE( J, S ) X 160 CONTINUE X* X ELSE X* X* Meet 2-by-2 block X* X CALL DLALN2( 0, 2, 2, SMIN, T( J-1, J-1 ), LDT, X $ RE( J-1, S-1 ), LDRE, WR, WI, X, 2, X $ SCALE, XNORM, IERR ) X* X* Scale X to avoid overflow in the updating X* right-hand side. X* X ALPHA = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ), X $ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ) ) X IF( ALPHA.GT.ONE ) THEN X REC = ONE / ALPHA X BETA = MAX( RWORK( J-1 ), RWORK( J ) ) X IF( BETA.GT.BIGNUM*REC ) THEN X X( 1, 1 ) = X( 1, 1 )*REC X X( 1, 2 ) = X( 1, 2 )*REC X X( 2, 1 ) = X( 2, 1 )*REC X X( 2, 2 ) = X( 2, 2 )*REC X SCALE = SCALE*REC X END IF X END IF X* X* Scaling if necessary X* X IF( SCALE.NE.ONE ) THEN X DO 170 K = 1, KI + 1 X RE( K, S-1 ) = SCALE*RE( K, S-1 ) X RE( K, S ) = SCALE*RE( K, S ) X 170 CONTINUE X END IF X RE( J-1, S-1 ) = X( 1, 1 ) X RE( J-1, S ) = X( 1, 2 ) X RE( J, S-1 ) = X( 2, 1 ) X RE( J, S ) = X( 2, 2 ) X* X* Update right-side. X* X DO 180 K = 1, J - 2 X RE( K, S-1 ) = RE( K, S-1 ) - X $ T( K, J-1 )*RE( J-1, S-1 ) - X $ T( K, J )*RE( J, S-1 ) X RE( K, S ) = RE( K, S ) - X $ T( K, J-1 )*RE( J-1, S ) - X $ T( K, J )*RE( J, S ) X 180 CONTINUE X END IF X* X 190 CONTINUE X* X* Normalization X* X EMAX = ZERO X DO 200 K = 1, KI + 1 X EMAX = MAX( EMAX, ABS( RE( K, S-1 ) )+ X $ ABS( RE( K, S ) ) ) X 200 CONTINUE X* X REMAX = ONE / EMAX X DO 210 K = 1, KI + 1 X RE( K, S-1 ) = RE( K, S-1 )*REMAX X RE( K, S ) = RE( K, S )*REMAX X 210 CONTINUE X* X* Set the rest part of RE to ZERO X* X 220 CONTINUE X DO 230 K = KI + 2, N X RE( K, S-1 ) = ZERO X RE( K, S ) = ZERO X 230 CONTINUE X* X END IF X* X END IF X* X* Computed the selected left eigenvector X* X IF( IJOB.EQ.2 .OR. IJOB.EQ.3 ) THEN X* X* The KIth real eigenvalue. X* X IF( IP.EQ.ZERO ) THEN X LE( KI, S ) = ONE X IF( KI.EQ.N ) X $ GO TO 320 X* X* Form right-hand side X* X DO 240 K = KI + 1, N X LE( K, S ) = -T( KI, K ) X 240 CONTINUE X* X* Solve the quasi- triangular system: X* (t(ki+1:n,ki+1:n) - wr)'*x = le(ki+1:n,s), X* X VMAX = ONE X VCRIT = BIGNUM X* X JNEXT = KI + 1 X DO 290 J = KI + 1, N X IF( J.LT.JNEXT ) X $ GO TO 290 X J1 = J X J2 = J X JNEXT = J + 1 X IF( J.LT.N ) THEN X IF( T( J+1, J ).NE.ZERO ) THEN X J2 = J + 1 X JNEXT = J + 2 X END IF X END IF X* X IF( J1.EQ.J2 ) THEN X* X* Meet 1-by-1 block X* Step 1: X* le(j,s) = le(j,s) - sum t(k,j)*le(k,s) X* k=ki+1,j-1 X* and scale le(k,s) if necessary. X* X IF( RWORK( J ).GT.VCRIT ) THEN X REC = ONE / VMAX X DO 250 K = KI, N X LE( K, S ) = LE( K, S )*REC X 250 CONTINUE X SCALE = SCALE*REC X VMAX = ONE X VCRIT = BIGNUM X END IF X* X LE( J, S ) = LE( J, S ) - X $ DDOT( J-KI-1, T( KI+1, J ), 1, X $ LE( KI+1, S ), 1 ) X* X* Step 2: solve (t(j,j)-wr)'*x = le(j,s) X* X CALL DLALN2( 0, 1, 1, SMIN, T( J, J ), LDT, X $ LE( J, S ), LDLE, WR, ZERO, X, 2, X $ SCALE, XNORM, IERR ) X* X* Scaling if necessary X* X IF( SCALE.NE.ONE ) THEN X DO 260 K = KI, N X LE( K, S ) = SCALE*LE( K, S ) X 260 CONTINUE X END IF X LE( J, S ) = X( 1, 1 ) X VMAX = MAX( ABS( LE( J, S ) ), VMAX ) X VCRIT = BIGNUM / VMAX X* X ELSE X* X* Meet 2-by-2 block X* Step 1: X* le(p,s) = le(p,s) - sum t(k,p)*le(k,s) X* k=ki+1,j-1 X* where p = j,j+1 and scale le(k,s) if necessary. X* X BETA = MAX( RWORK( J ), RWORK( J+1 ) ) X IF( BETA.GT.VCRIT ) THEN X REC = ONE / VMAX X DO 270 K = KI, N X LE( K, S ) = LE( K, S )*REC X 270 CONTINUE X SCALE = SCALE*REC X VMAX = ONE X VCRIT = BIGNUM X END IF X* X LE( J, S ) = LE( J, S ) - X $ DDOT( J-KI-1, T( KI+1, J ), 1, X $ LE( KI+1, S ), 1 ) X* X LE( J+1, S ) = LE( J+1, S ) - X $ DDOT( J-KI-1, T( KI+1, J+1 ), 1, X $ LE( KI+1, S ), 1 ) X* X* Step 2: solve X* (t'(j,j) t(j,j+1) )'* x = (le(j,i) ) X* (t(j+1,j) t'(j+1,j+1)) (le(j+1,i)) X* where t'(k,k) = t(k,k) - wr X* X CALL DLALN2( 1, 2, 1, SMIN, T( J, J ), LDT, X $ LE( J, S ), LDLE, WR, ZERO, X, 2, X $ SCALE, XNORM, IERR ) X* X* Scaling if necessary X* X IF( SCALE.NE.ONE ) THEN X DO 280 K = KI, N X LE( K, S ) = SCALE*LE( K, S ) X 280 CONTINUE X END IF X LE( J, S ) = X( 1, 1 ) X LE( J+1, S ) = X( 2, 1 ) X VMAX = MAX( ABS( LE( J, S ) ), ABS( LE( J+1, S ) ), X $ VMAX ) X VCRIT = BIGNUM / VMAX X* X END IF X 290 CONTINUE X* X* Normalization X* X EMAX = ZERO X DO 300 K = KI, N X EMAX = MAX( EMAX, ABS( LE( K, S ) ) ) X 300 CONTINUE X* X REMAX = ONE / EMAX X DO 310 K = KI, N X LE( K, S ) = LE( K, S )*REMAX X 310 CONTINUE X* X* Set the rest part to zero. X* X 320 CONTINUE X DO 330 K = 1, KI - 1 X LE( K, S ) = ZERO X 330 CONTINUE X* X* The KIth conjugate complex eigenvalues. X* X ELSE X* X* Initial solve: X* ((t(ki,ki) t(ki,ki+1) )' - (wr - i* wi))*X = 0. X* ((t(ki+1,ki) t(ki+1,ki+1)) X* X IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN X LE( KI, S-1 ) = WI / T( KI, KI+1 ) X LE( KI+1, S ) = ONE X ELSE X LE( KI, S-1 ) = ONE X LE( KI+1, S ) = -WI / T( KI+1, KI ) X END IF X LE( KI, S ) = ZERO X LE( KI+1, S-1 ) = ZERO X IF( KI.EQ.N-1 ) X $ GO TO 420 X* X* Form right-side. X* X DO 340 K = KI + 2, N X LE( K, S-1 ) = -T( KI, K )*LE( KI, S-1 ) X LE( K, S ) = -T( KI+1, K )*LE( KI+1, S ) X 340 CONTINUE X* X* Solver complex quasi-triangular system: X* ( t' - (wr-i*wi) )*x = le(*,s-1)+i*le(*,s) X* where t = t(ki+2,n:ki+2,n). X* X VMAX = ONE X VCRIT = BIGNUM X* X JNEXT = KI + 2 X DO 390 J = KI + 2, N X IF( J.LT.JNEXT ) X $ GO TO 390 X J1 = J X J2 = J X JNEXT = J + 1 X IF( J.LT.N ) THEN X IF( T( J+1, J ).NE.ZERO ) THEN X J2 = J + 1 X JNEXT = J + 2 X END IF X END IF X* X IF( J1.EQ.J2 ) THEN X* X* Meet 1-by-1 block X* Step 1: X* le(j,q) = le(j,q) - sum t(k,j)*le(k,q) X* k=ki+2,j-1 X* where q=s-1,s and scale le(k,q) if necessary. X* X IF( RWORK( J ).GT.VCRIT ) THEN X REC = ONE / VMAX X DO 350 K = KI, N X LE( K, S-1 ) = LE( K, S-1 )*REC X LE( K, S ) = LE( K, S )*REC X 350 CONTINUE X SCALE = SCALE*REC X VMAX = ONE X VCRIT = BIGNUM X END IF X* X LE( J, S-1 ) = LE( J, S-1 ) - X $ DDOT( J-KI-2, T( KI+2, J ), 1, X $ LE( KI+2, S-1 ), 1 ) X LE( J, S ) = LE( J, S ) - X $ DDOT( J-KI-2, T( KI+2, J ), 1, X $ LE( KI+2, S ), 1 ) X* X* Step 2: X* (t(j,j)-(wr-i*wi))*(xr+i*xi) X* = le(j,s-1)+i*le(j,s) X* X CALL DLALN2( 0, 1, 2, SMIN, T( J, J ), LDT, X $ LE( J, S-1 ), LDLE, WR, -WI, X, 2, X $ SCALE, XNORM, IERR ) X* X* Scaling if necessary X* X IF( SCALE.NE.ONE ) THEN X DO 360 K = I, N X LE( K, S-1 ) = SCALE*LE( K, S-1 ) X LE( K, S ) = SCALE*LE( K, S ) X 360 CONTINUE X END IF X LE( J, S-1 ) = X( 1, 1 ) X LE( J, S ) = X( 1, 2 ) X VMAX = MAX( ABS( LE( J, S-1 ) ), ABS( LE( J, S ) ), X $ VMAX ) X VCRIT = BIGNUM / VMAX X* X ELSE X* X* Meet 2-by-2 block X* Step 1: X* le(p,q) = le(p,q) - sum t(k,p)*le(k,q) X* k=i+2,j-1 X* where p = j,j+1, q = s-1,s and scale X* le(k,q) if necessary. X* X BETA = MAX( RWORK( J ), RWORK( J+1 ) ) X IF( BETA.GT.VCRIT ) THEN X REC = ONE / VMAX X DO 370 K = KI, N X LE( K, S-1 ) = LE( K, S-1 )*REC X LE( K, S ) = LE( K, S )*REC X 370 CONTINUE X SCALE = SCALE*REC X VMAX = ONE X VCRIT = BIGNUM X END IF X* X LE( J, S-1 ) = LE( J, S-1 ) - X $ DDOT( J-KI-2, T( KI+2, J ), 1, X $ LE( KI+2, S-1 ), 1 ) X* X LE( J, S ) = LE( J, S ) - X $ DDOT( J-KI-2, T( KI+2, J ), 1, X $ LE( KI+2, S ), 1 ) X* X LE( J+1, S-1 ) = LE( J+1, S-1 ) - X $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, X $ LE( KI+2, S-1 ), 1 ) X* X LE( J+1, S ) = LE( J+1, S ) - X $ DDOT( J-KI-2, T( KI+2, J+1 ), 1, X $ LE( KI+2, S ), 1 ) X* X* Step 2: X* A* x = (le(j,s-1) +i*le(j,s) ) X* (le(j+1,s-1)+i*le(j+1,s)) X* where X* A = (t(j,j) t(j,j+1) ) - (wr - i*wi) X* (t(j+1,j) t(j+1,j+1)) X* X CALL DLALN2( 1, 2, 2, SMIN, T( J, J ), LDT, X $ LE( J, S-1 ), LDLE, WR, -WI, X, 2, X $ SCALE, XNORM, IERR ) X* X* Scaling if necessary X* X IF( SCALE.NE.ONE ) THEN X DO 380 K = KI, N X LE( K, S-1 ) = SCALE*LE( K, S-1 ) X LE( K, S ) = SCALE*LE( K, S ) X 380 CONTINUE X END IF X LE( J, S-1 ) = X( 1, 1 ) X LE( J, S ) = X( 1, 2 ) X LE( J+1, S-1 ) = X( 2, 1 ) X LE( J+1, S ) = X( 2, 2 ) X VMAX = MAX( ABS( LE( J, S-1 ) ), ABS( LE( J, S ) ), X $ ABS( LE( J+1, S-1 ) ), ABS( LE( J+1, S ) ), X $ VMAX ) X VCRIT = BIGNUM / VMAX X* X END IF X 390 CONTINUE X* X* Normalization X* X EMAX = ZERO X DO 400 K = KI, N X EMAX = MAX( EMAX, ABS( LE( K, S-1 ) )+ X $ ABS( LE( K, S ) ) ) X 400 CONTINUE X* X REMAX = ONE / EMAX X DO 410 K = KI, N X LE( K, S-1 ) = LE( K, S-1 )*REMAX X LE( K, S ) = LE( K, S )*REMAX X 410 CONTINUE X* X* Set the rest part of LE to ZERO X* X 420 CONTINUE X DO 430 K = 1, KI - 1 X LE( K, S-1 ) = ZERO X LE( K, S ) = ZERO X 430 CONTINUE X* X END IF X* X END IF X* X S = S + 1 X 440 CONTINUE X IF( IP.EQ.-1 ) X $ IP = 0 X IF( IP.EQ.1 ) X $ IP = -1 X* X 450 CONTINUE X* X GO TO 470 X* X 460 CONTINUE X INFO = N + 1 X 470 CONTINUE X M = S - 1 X RETURN X* X* End of DTREVC X* X END END_OF_FILE if test 31995 -ne `wc -c <'dtrevc.f'`; then echo shar: \"'dtrevc.f'\" unpacked with wrong size! fi # end of 'dtrevc.f' fi if test -f 'dtrsv.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'dtrsv.f'\" else echo shar: Extracting \"'dtrsv.f'\" \(9019 characters\) sed "s/^X//" >'dtrsv.f' <<'END_OF_FILE' X SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) X* .. Scalar Arguments .. X INTEGER INCX, LDA, N X CHARACTER*1 DIAG, TRANS, UPLO X* .. Array Arguments .. X DOUBLE PRECISION A( LDA, * ), X( * ) X* .. X* X* Purpose X* ======= X* X* DTRSV solves one of the systems of equations X* X* A*x = b, or A'*x = b, X* X* where b and x are n element vectors and A is an n by n unit, or X* non-unit, upper or lower triangular matrix. X* X* No test for singularity or near-singularity is included in this X* routine. Such tests must be performed before calling this routine. X* X* Parameters X* ========== X* X* UPLO - CHARACTER*1. X* On entry, UPLO specifies whether the matrix is an upper or X* lower triangular matrix as follows: X* X* UPLO = 'U' or 'u' A is an upper triangular matrix. X* X* UPLO = 'L' or 'l' A is a lower triangular matrix. X* X* Unchanged on exit. X* X* TRANS - CHARACTER*1. X* On entry, TRANS specifies the equations to be solved as X* follows: X* X* TRANS = 'N' or 'n' A*x = b. X* X* TRANS = 'T' or 't' A'*x = b. X* X* TRANS = 'C' or 'c' A'*x = b. X* X* Unchanged on exit. X* X* DIAG - CHARACTER*1. X* On entry, DIAG specifies whether or not A is unit X* triangular as follows: X* X* DIAG = 'U' or 'u' A is assumed to be unit triangular. X* X* DIAG = 'N' or 'n' A is not assumed to be unit X* triangular. X* X* Unchanged on exit. X* X* N - INTEGER. X* On entry, N specifies the order of the matrix A. X* N must be at least zero. X* Unchanged on exit. X* X* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). X* Before entry with UPLO = 'U' or 'u', the leading n by n X* upper triangular part of the array A must contain the upper X* triangular matrix and the strictly lower triangular part of X* A is not referenced. X* Before entry with UPLO = 'L' or 'l', the leading n by n X* lower triangular part of the array A must contain the lower X* triangular matrix and the strictly upper triangular part of X* A is not referenced. X* Note that when DIAG = 'U' or 'u', the diagonal elements of X* A are not referenced either, but are assumed to be unity. X* Unchanged on exit. X* X* LDA - INTEGER. X* On entry, LDA specifies the first dimension of A as declared X* in the calling (sub) program. LDA must be at least X* max( 1, n ). X* Unchanged on exit. X* X* X - DOUBLE PRECISION array of dimension at least X* ( 1 + ( n - 1 )*abs( INCX ) ). X* Before entry, the incremented array X must contain the n X* element right-hand side vector b. On exit, X is overwritten X* with the solution vector x. X* X* INCX - INTEGER. X* On entry, INCX specifies the increment for the elements of X* X. INCX must not be zero. X* Unchanged on exit. X* X* X* Level 2 Blas routine. X* X* -- Written on 22-October-1986. X* Jack Dongarra, Argonne National Lab. X* Jeremy Du Croz, Nag Central Office. X* Sven Hammarling, Nag Central Office. X* Richard Hanson, Sandia National Labs. X* X* X* .. Parameters .. X DOUBLE PRECISION ZERO X PARAMETER ( ZERO = 0.0D+0 ) X* .. Local Scalars .. X DOUBLE PRECISION TEMP X INTEGER I, INFO, IX, J, JX, KX X LOGICAL NOUNIT X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. External Subroutines .. X EXTERNAL XERBLA X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Executable Statements .. X* X* Test the input parameters. X* X INFO = 0 X IF ( .NOT.LSAME( UPLO , 'U' ).AND. X $ .NOT.LSAME( UPLO , 'L' ) )THEN X INFO = 1 X ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. X $ .NOT.LSAME( TRANS, 'T' ).AND. X $ .NOT.LSAME( TRANS, 'C' ) )THEN X INFO = 2 X ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. X $ .NOT.LSAME( DIAG , 'N' ) )THEN X INFO = 3 X ELSE IF( N.LT.0 )THEN X INFO = 4 X ELSE IF( LDA.LT.MAX( 1, N ) )THEN X INFO = 6 X ELSE IF( INCX.EQ.0 )THEN X INFO = 8 X END IF X IF( INFO.NE.0 )THEN X CALL XERBLA( 'DTRSV ', INFO ) X RETURN X END IF X* X* Quick return if possible. X* X IF( N.EQ.0 ) X $ RETURN X* X NOUNIT = LSAME( DIAG, 'N' ) X* X* Set up the start point in X if the increment is not unity. This X* will be ( N - 1 )*INCX too small for descending loops. X* X IF( INCX.LE.0 )THEN X KX = 1 - ( N - 1 )*INCX X ELSE IF( INCX.NE.1 )THEN X KX = 1 X END IF X* X* Start the operations. In this version the elements of A are X* accessed sequentially with one pass through A. X* X IF( LSAME( TRANS, 'N' ) )THEN X* X* Form x := inv( A )*x. X* X IF( LSAME( UPLO, 'U' ) )THEN X IF( INCX.EQ.1 )THEN X DO 20, J = N, 1, -1 X IF( X( J ).NE.ZERO )THEN X IF( NOUNIT ) X $ X( J ) = X( J )/A( J, J ) X TEMP = X( J ) X DO 10, I = J - 1, 1, -1 X X( I ) = X( I ) - TEMP*A( I, J ) X 10 CONTINUE X END IF X 20 CONTINUE X ELSE X JX = KX + ( N - 1 )*INCX X DO 40, J = N, 1, -1 X IF( X( JX ).NE.ZERO )THEN X IF( NOUNIT ) X $ X( JX ) = X( JX )/A( J, J ) X TEMP = X( JX ) X IX = JX X DO 30, I = J - 1, 1, -1 X IX = IX - INCX X X( IX ) = X( IX ) - TEMP*A( I, J ) X 30 CONTINUE X END IF X JX = JX - INCX X 40 CONTINUE X END IF X ELSE X IF( INCX.EQ.1 )THEN X DO 60, J = 1, N X IF( X( J ).NE.ZERO )THEN X IF( NOUNIT ) X $ X( J ) = X( J )/A( J, J ) X TEMP = X( J ) X DO 50, I = J + 1, N X X( I ) = X( I ) - TEMP*A( I, J ) X 50 CONTINUE X END IF X 60 CONTINUE X ELSE X JX = KX X DO 80, J = 1, N X IF( X( JX ).NE.ZERO )THEN X IF( NOUNIT ) X $ X( JX ) = X( JX )/A( J, J ) X TEMP = X( JX ) X IX = JX X DO 70, I = J + 1, N X IX = IX + INCX X X( IX ) = X( IX ) - TEMP*A( I, J ) X 70 CONTINUE X END IF X JX = JX + INCX X 80 CONTINUE X END IF X END IF X ELSE X* X* Form x := inv( A' )*x. X* X IF( LSAME( UPLO, 'U' ) )THEN X IF( INCX.EQ.1 )THEN X DO 100, J = 1, N X TEMP = X( J ) X DO 90, I = 1, J - 1 X TEMP = TEMP - A( I, J )*X( I ) X 90 CONTINUE X IF( NOUNIT ) X $ TEMP = TEMP/A( J, J ) X X( J ) = TEMP X 100 CONTINUE X ELSE X JX = KX X DO 120, J = 1, N X TEMP = X( JX ) X IX = KX X DO 110, I = 1, J - 1 X TEMP = TEMP - A( I, J )*X( IX ) X IX = IX + INCX X 110 CONTINUE X IF( NOUNIT ) X $ TEMP = TEMP/A( J, J ) X X( JX ) = TEMP X JX = JX + INCX X 120 CONTINUE X END IF X ELSE X IF( INCX.EQ.1 )THEN X DO 140, J = N, 1, -1 X TEMP = X( J ) X DO 130, I = N, J + 1, -1 X TEMP = TEMP - A( I, J )*X( I ) X 130 CONTINUE X IF( NOUNIT ) X $ TEMP = TEMP/A( J, J ) X X( J ) = TEMP X 140 CONTINUE X ELSE X KX = KX + ( N - 1 )*INCX X JX = KX X DO 160, J = N, 1, -1 X TEMP = X( JX ) X IX = KX X DO 150, I = N, J + 1, -1 X TEMP = TEMP - A( I, J )*X( IX ) X IX = IX - INCX X 150 CONTINUE X IF( NOUNIT ) X $ TEMP = TEMP/A( J, J ) X X( JX ) = TEMP X JX = JX - INCX X 160 CONTINUE X END IF X END IF X END IF X* X RETURN X* X* End of DTRSV . X* X END END_OF_FILE if test 9019 -ne `wc -c <'dtrsv.f'`; then echo shar: \"'dtrsv.f'\" unpacked with wrong size! fi # end of 'dtrsv.f' fi if test -f 'envir.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'envir.f'\" else echo shar: Extracting \"'envir.f'\" \(1716 characters\) sed "s/^X//" >'envir.f' <<'END_OF_FILE' X SUBROUTINE ENVIR( WHAT, NVALUE ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER WHAT X INTEGER NVALUE X* .. X* X* Purpose X* ======= X* X* ENVIR returns certain machine and problem-dependent parameters for X* the local environment. X* X* Arguments X* ========= X* X* WHAT (input) CHARACTER X* A character code for the value to be returned. X* = 'B': blocksize X* = 'P': number of processors X* = 'S': number of shifts to be used in eigenvalue/SVD X* iterations X* = 'E': size of largest deflated block to be processed by X* EISPACK algorithm, instead of multishift. X* X* NVALUE (output) INTEGER X* The value of the parameter specified by WHAT. X* X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. Intrinsic Functions .. X INTRINSIC MAX X* .. X* .. Scalars in Common .. X INTEGER NBLOCK, NPROC, NSHIFT, NEISPK X* .. X* .. Common blocks .. X COMMON / CENVIR / NBLOCK, NPROC, NSHIFT, NEISPK X* .. X* .. Executable Statements .. X* X IF( LSAME( WHAT, 'B' ) ) THEN X NVALUE = NBLOCK X ELSE IF( LSAME( WHAT, 'P' ) ) THEN X NVALUE = NPROC X ELSE IF( LSAME( WHAT, 'S' ) ) THEN X NVALUE = NSHIFT X ELSE IF( LSAME( WHAT, 'E' ) ) THEN X NVALUE = NEISPK X END IF X* X NVALUE = MAX( 1, NVALUE ) X RETURN X* X* End of ENVIR X* X END END_OF_FILE if test 1716 -ne `wc -c <'envir.f'`; then echo shar: \"'envir.f'\" unpacked with wrong size! fi # end of 'envir.f' fi if test -f 'fcaltol.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'fcaltol.f'\" else echo shar: Extracting \"'fcaltol.f'\" \(879 characters\) sed "s/^X//" >'fcaltol.f' <<'END_OF_FILE' X subroutine caltol(lda,ndim,h,tol,snormh) X integer lda,ndim X double precision h(lda,*) X double precision tol,snormh c X integer ii,i,j X double precision temp c X double precision d1mach X external d1mach c X*** X* purpose X* ------- X* computes: + snormh = infinity norm of h (upper-hessenberg). X* + tol = tolerance to be used in stopping criterion. X* an eigenpair producing a residual with norm .lt. tol is X* accepted as an eigenpair of h. X*** c X tol=0.0d0 X snormh=0.0d0 c X ii=1 X do 20 i=1,ndim X temp=0.0d0 X do 10 j=ii,ndim X temp=temp+dabs(h(i,j)) X 10 continue X if (temp.gt.snormh) snormh=temp X ii=i X 20 continue c X tol=snormh*ndim*d1mach(3) X if (snormh.eq.0.0) tol=d1mach(3) c X return X end END_OF_FILE if test 879 -ne `wc -c <'fcaltol.f'`; then echo shar: \"'fcaltol.f'\" unpacked with wrong size! fi # end of 'fcaltol.f' fi if test -f 'fdandc.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'fdandc.f'\" else echo shar: Extracting \"'fdandc.f'\" \(3893 characters\) sed "s/^X//" >'fdandc.f' <<'END_OF_FILE' X subroutine dandc(lda,norg,horg,lam,zr,zi,ind,ipvt,res, X & work,work1,work2,trace) X integer ipvt(*),ind(*) X integer lda,norg,trace X double precision horg(lda,*),lam(lda,*),zr(lda,*),zi(lda,*), X & res(lda+1,*),work((lda+1)**2,*),work1(lda+1,*),work2(lda+1,*) c X double precision temp,dtemp X integer i,j,igh,low,ierr,icnt,ndim,itemp,least,most c X external hqr2,vec,defcnt c X*** X* purpose X* ------- X* This is a simplified version of the divide & conquer (D&C) X* driver routine, where the initial problem can be broken in X* 2 subpbs only. X* X* on input: X* -------- X* X* lda leading dimension of horg as defined in calling program X* X* norg is the dimension of horg X* X* horg contains the original upper-hess matrix. X* X* trace = 1 will cause the code to print info on how individual residuals X* are varying. X* X* on output: X* --------- X* X* horg unchanged X* X* lam contains real parts of eigenvalues as computed by D&C code in the X* first column, and imaginary parts in second column. X* X* zr contains real parts of eigenvectors as computed by D&C code, such X* that zr(:,i) is the real part of the eigenvector corresponding to X* lam(i,1) + sqrt(-1) * lam(i,2) X* X* zi contains imaginary parts of eigenvectors (see zr) X* X* The remaining arrays are needed as work spaces for calls to hqr2, and X* in lower routines for residual computation, Jacobian factorization... X* X* X* Here is the hierarchy of the subroutines: X* ---- -- --- --------- -- --- ----------- X* X* X* dandc X* / \ X* / \ X* hqr2 defcnt X* vec / \ X* / \ X* caltol iterat X* / | | \ X* / | | \ X* resid | | \ X* | | \ X* dlaein | \ X* | \ X* | \ X* scale / \ X* | / \ X* | clufac csol X* xmult | | X* xinv | | X* xmult xmult X* xdiv xdiv X* xinv X*** c X* X* look for smallest component on the subdiag between (least,least-1) and X* (most,most-1). This component is set to zero. X* c X least=norg*45/100 X most=norg*65/100 X temp=dabs(horg(least,least-1)) X itemp=least X do 10 i=least+1,most X dtemp=dabs(horg(i,i-1)) X if (temp.gt.dtemp) then X itemp=i X temp=dtemp X endif X 10 continue X print *,'torn at ( ',itemp,', ', itemp-1,' )' c c call hqr(2) at lowest level c X do 16 j=1,norg X do 15 i=1,norg X zi(i,j)=0.0d0 X zr(i,j)=0.0d0 X 15 continue X zr(j,j)=1.d0 X 16 continue c X do j=1,norg X do i=1,norg X work(i+(j-1)*lda,1)=horg(i,j) X enddo X enddo c c first subpb. c X low=1 X ndim=itemp-1 X igh=ndim X call hqr2(lda,ndim,low,igh,work(1,1),lam(1,1), X + lam(1,2),zr(1,1),ierr) X call vec(lda,ndim,lam(1,2),zr(1,1),zi(1,1)) c c second subpb. c X low=1 X ndim=norg-itemp+1 X igh=ndim X call hqr2(lda,ndim,low,igh,work(itemp+(itemp-1)*lda,1), X + lam(itemp,1),lam(itemp,2),zr(itemp,itemp),ierr) X call vec(lda,ndim,lam(itemp,2), X + zr(itemp,itemp),zi(itemp,itemp)) c c conquer. c X ndim=norg X call defcnt(lda,ndim,ind,horg, X + lam(1,1),lam(1,2),zr,zi,ipvt,work(1,1),work(1,2), X + res,work1,work2,trace) c X return X end END_OF_FILE if test 3893 -ne `wc -c <'fdandc.f'`; then echo shar: \"'fdandc.f'\" unpacked with wrong size! fi # end of 'fdandc.f' fi if test -f 'fdefcnt.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'fdefcnt.f'\" else echo shar: Extracting \"'fdefcnt.f'\" \(2789 characters\) sed "s/^X//" >'fdefcnt.f' <<'END_OF_FILE' X subroutine defcnt(lda,ninit,ind,h,wr,wi,zr,zi, X + ipvt,hr,hi,res,work1,work2,trace) X double precision wr(*),wi(*) X double precision zr(lda,*),zi(lda,*) X double precision h(lda,*),hr(lda+1,*),hi(lda+1,*),res(lda+1,*), X & work1(lda+1,*),work2(lda+1,*) X integer ninit,lda,trace X integer ipvt(*),ind(*) c X double precision random,tol,snormh,eps X integer ig,i,j,neig,icx,icomp c X double precision eps3, smlnum, bignum, unfl, ovfl, ulp c X double precision dlamch,epslon,d1mach X external dlamch,epslon,d1mach c X external caltol,iterat c X*** X* purpose X* ------- X* calls iterat where the eigenpairs of h are computed. Also does X* some bookkeeping: ONLY ONE of a complex conjugate pair of initial X* guesses is sent to iterat. X*** c X* X* compute the tolerance to be used in the stopping test in iterat. X* c X call caltol(lda,ninit,h,tol,snormh) X print *,'tol=',tol X eps=max(d1mach(3),epslon(snormh)) c X unfl = dlamch( 'Safe minimum') X ovfl = dlamch( 'Overflow' ) X ulp = dlamch('Epsilon')*dlamch( 'Base') X smlnum = max( unfl*(ninit/ulp) , ninit/(ulp*ovfl) ) X bignum = (1.0 - ulp) / smlnum X eps3 = snormh*ulp c X icx=0 X neig=0 X ig=1 X* X* neig is the number of eigenpairs of h that have already been computed. X* This may be larger than the number of initial guesses already refined. X* (for instance if from a real initial guess a complex eigenpair is X* converged to). X* X 100 if (neig.lt.ninit) then X if (trace .eq. 1) print *,ig,'th eigenvalue ',wr(ig),wi(ig) X if (dabs(wi(ig)).gt.tol) icomp=1 X call iterat(lda,ninit,h,wr(ig),wi(ig),zr(1,ig), X + zi(1,ig),tol,eps,ipvt,hr,hi,res,work1,work2, X + eps3, smlnum, bignum,trace) X neig=neig+1 X if (dabs(wi(ig)).gt.tol) then X* X* if a complex eigenpair is known than so is its conjugate. X* X neig=neig+1 X 150 if (icomp.eq.1) then X icomp=0 X ig=ig+1 X wr(ig)=wr(ig-1) X wi(ig)=-wi(ig-1) X do 151 i=1,ninit X zr(i,ig)=zr(i,ig-1) X zi(i,ig)=-zi(i,ig-1) X 151 continue X else X icx=icx+1 X ind(icx)=ig X endif X endif X 156 ig=ig+1 X goto 100 X endif c X 200 do 300 i=ig,ninit X wr(i)=wr(ind(i-ig+1)) X wi(i)=-wi(ind(i-ig+1)) X do 299 j=1,ninit X zr(j,i)=zr(j,ind(i-ig+1)) X zi(j,i)=-zi(j,ind(i-ig+1)) X 299 continue X 300 continue c X 350 return X end END_OF_FILE if test 2789 -ne `wc -c <'fdefcnt.f'`; then echo shar: \"'fdefcnt.f'\" unpacked with wrong size! fi # end of 'fdefcnt.f' fi if test -f 'fiterat.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'fiterat.f'\" else echo shar: Extracting \"'fiterat.f'\" \(5596 characters\) sed "s/^X//" >'fiterat.f' <<'END_OF_FILE' X subroutine iterat(lda,ndim,h,wr,wi,zr,zi,tol,eps,ipvt, X + hr,hi,res,work1,work2,eps3, smlnum, bignum, trace) X double precision wr,wi X double precision zr(*),zi(*),h(lda,*) X double precision hr(lda+1,*),hi(lda+1,*),res(lda+1,*), X & work1(lda+1,*),work2(lda+1,*) X double precision tol,eps X integer ipvt(*) X integer ndim,lda,trace c X integer it,i,j,ldap1,index,maxit,indx X double precision rnorm,random X logical compx X************************ X integer ijob, ivecto, uk, lk, info X double precision eps3, smlnum, bignum X************************ X integer steps X common/steps/steps c X external scale, dlaein, resid, clufac, csol c X*** X* purpose X* ------- X* Set: lam = wr + sqrt(-1) * wi , z = zr + sqrt(-1) * zi X* Then this routine computes successive corrections to X* (lam,z) until it is an acceptable approximation to an X* eigenpair of h (in the sense that it produces a ``small'' X* residual). X* The basic correcting step consists of solving the following X* system: X* X* | | | | X* | h - lam * I -z | | lam*z-h*z | X* | | * correction = | | X* | es' 0 | | 0 | X* | | | | X* X* where : es is the sth column of I, and es' is the transpose of es. X* s is the index of the largest component of the initial z. X* Note that lam*z-h*z is the residual corresponding to (lam,z). X* X* The new approximation is : X* X* lam = lam + correction(ndim+1) X* z = z + correction(1:ndim) X* X* where : ndim is the dimension of the original matrix h (upper-Hess.) X* Note that the Jacobian has dimension ndim+1. X*** c X* X steps=steps+1 X* c X ldap1=lda+1 X ijob=1 X ivecto=1 X uk=ndim X lk=1 c X* X* Scale initial eigenvector: s mentioned above is equal to index. X* c X call scale(ndim,index,zr,zi) c X* X* Do only real arithmetic if possible. X* c X compx=.false. X if (dabs(wi).gt.tol) compx=.true. c X* X* Do no more than maxit-1 iterations; if the residual is still larger than X* tol, the initial approximation is declared to have failed to converge. X* c X maxit=36 X do 50 it=1,maxit c X if ( it.eq.7 .and. (.not.compx) )then X* X* If starting from a real eigenpair no convergence occurred in 5 steps, X* perturb the imaginary part of the eigenvalue and do complex arithmetic. X* X wi=rnorm/2.0d0 X compx=.true. c X elseif ( it.ge.12 .and. it.lt.36 .and. mod(it,6) .eq. 0) then X* X* Under these conditions, see if inverse iteration can provide a good X* eigenvector (the call is to dlaein from LAPACK; X* this will be replaced by another routine more suited to our X* purposes in later versions) ... X* X if (.not. compx) wi=0.0 X call dlaein(ijob, ivecto, ndim, h, lda, wr, wi, uk, lk, X $ res(1,1), ldap1, work1(1,1), ldap1, hr(1,1), ldap1, X $ work2(1,1), eps3, smlnum, bignum, info) X rnorm=0.0 X do 11 i=1,ndim X rnorm=rnorm+res(1,1)**2 X if (compx) rnorm=rnorm+res(1,2)**2 X 11 continue X if (rnorm.eq.0.0) goto 32 X do 12 i=1,ndim X work1(i,1)=res(i,1) X if (compx) work1(i,2)=res(i,2) X 12 continue X call resid(lda,compx,ndim,h,wr,wi, X + work1(1,1),work1(1,2),res(1,1),res(1,2),rnorm) X* print *,'rnorm = ',rnorm X if (rnorm.lt.tol) then X do 13 i=1,ndim X zr(i)=work1(i,1) X if (compx) zi(i)=work1(i,2) X 13 continue X if (trace .eq. 1) print *,'residual after call to inv. X + it. = ',rnorm X goto 100 X endif X 31 continue X do 30 i=1,ndim X zr(i)=random() X if (compx) zi(i)=random() X 30 continue X call scale(ndim,index,zr,zi) X endif c X 32 continue c X* X* compute residual: this is the right hand side. rnorm is the size of the X* residual. X* X call resid(lda,compx,ndim,h,wr,wi,zr,zi,res(1,1),res(1,2), X + rnorm) X res(ndim+1,1)=0.0d0 X res(ndim+1,2)=0.0d0 X if (trace .eq. 1) print *,'iter=',it-1,' residual=',rnorm c X if ( rnorm .lt. tol) then X goto 100 X elseif ( .not. ( rnorm .ge. tol ) ) then X print *,'********FAILURE: residual NaN' X goto 100 X endif c X* X* solve for the correction. X* X call clufac(lda,compx,ndim+1,index,h,wr,wi,zr,zi,ipvt,hr,hi) X call csol(lda,compx,ndim+1,ipvt,hr,hi,res(1,1),res(1,2),eps) X* X* correct current eigenpair. X* X do 45 i=1,ndim X zr(i)=zr(i)+res(i,1) X if (compx) zi(i)=zi(i)+res(i,2) X 45 continue X wr=wr+res(ndim+1,1) X if (compx) wi=wi+res(ndim+1,2) X 50 continue X 100 continue X if (rnorm.ge.tol) print *,'********FAILURE: no convergence in ', X $ maxit,' iterations.' X if (trace .eq. 1) print *,'converged to ',wr,wi c X call scale(ndim,index,zr,zi) c X return X end END_OF_FILE if test 5596 -ne `wc -c <'fiterat.f'`; then echo shar: \"'fiterat.f'\" unpacked with wrong size! fi # end of 'fiterat.f' fi if test -f 'fmylun.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'fmylun.f'\" else echo shar: Extracting \"'fmylun.f'\" \(14472 characters\) sed "s/^X//" >'fmylun.f' <<'END_OF_FILE' X subroutine clufac(lda,compx,ndim,index,h,wr,wi,zr,zi,ipvt,hr,hi) X double precision h(lda,*),hr(lda+1,*),hi(lda+1,*) X double precision zr(*),zi(*) X double precision wr,wi X integer ipvt(*) X integer lda,ndim,index X logical compx c X double precision temp1,temp2,temp3,temp4 X integer i,j c X external xmult, xinv, xdiv c X*** X* purpose X* ------- X* lu factorization (column version) of the Jacobian: X* X* | | X* | h - (wr + sqrt(-1) * wi) -zr - sqrt(-1) * zi | X* | e(index)' 0 | X* | | X* X* where: wr + sqrt(-1) * wi is the current eigenvalue. X* zr + sqrt(-1) * zi is the current eigenvector. X* e(index)' is the transpose of the indexth X* column of the identity matrix X* X* compx specifies whether the current eigenpair is complex or not. X* X* The factorization of the Jacobian is stored in hr + sqrt(-1) * hi X* ipvt contains pivoting information on output X* X* REMARK: X* ------ X* The code in this routine is quite messy at present: it does use X* the fact that the Jacobian is upper-Hesseberg but for possible X* non-zero entries in the last row. However, it uses approximately X* twice the storage it really needs: Indeed, hi can be stored in X* the lower half of hr plus 2 1D vectors. Finally, the Jacobian is X* not explicitly formed prior to factorization; rather h and the X* current eigenpair are used to form the factorization directly. X*** c column version c X do 1 j=1,ndim X hr(ndim,j)=0.0 X hi(ndim,j)=0.0 X 1 continue X hr(ndim,index)=1.0 c X* X* If current eigenpair not complex do real arithmetic. X* c X if (.not.compx) goto 25 c X* X* Reduce first column of the Jacobian. X* c X hr(1,1)=h(1,1)-wr X hi(1,1)=-wi X if (h(2,1) .eq. 0.0 .and. hr(ndim,1) .eq. 0.0) then X hr(2,1)=0.0 X hi(2,1)=0.0 X ipvt(1)=1 X elseif (dabs(hr(1,1))+dabs(hi(1,1)) .ge. X $ max(dabs(h(2,1)),dabs(hr(ndim,1)))) then X call xinv(h(2,1),hr(1,1),hi(1,1),hr(2,1),hi(2,1)) X call xinv(hr(ndim,1),hr(1,1),hi(1,1),hr(ndim,1), X $ hi(ndim,1)) X ipvt(1)=1 X elseif (dabs(h(2,1)).gt.dabs(hr(ndim,1))) then X hr(2,1)=hr(1,1)/h(2,1) X hi(2,1)=hi(1,1)/h(2,1) X hr(ndim,1)=hr(ndim,1)/h(2,1) X hi(ndim,1)=hi(ndim,1)/h(2,1) X hr(1,1)=h(2,1) X hi(1,1)=0.0 X ipvt(1)=2 X else X hr(2,1)=h(2,1) X hi(2,1)=0.0 X hr(ndim,1)=hr(1,1) X hi(ndim,1)=hi(1,1) X hr(1,1)=1.0 X hi(1,1)=0.0 X ipvt(1)=ndim X endif c X* X* proceed with other columns. X* c X do 10 j=2,ndim-1 X hr(1,j)=h(1,j) X hi(1,j)=0.0d0 c c apply previous interchanges and multipliers. c X do 8 i=1,j-2 X if (ipvt(i).eq.i) then X call xmult(hr(i+1,i),hi(i+1,i),hr(i,j),hi(i,j), X $ temp1,temp2) X hr(i+1,j)=h(i+1,j)-temp1 X hi(i+1,j)=-temp2 X call xmult(hr(ndim,i),hi(ndim,i),hr(i,j),hi(i,j), X $ temp1,temp2) X hr(ndim,j)=hr(ndim,j)-temp1 X hi(ndim,j)=hi(ndim,j)-temp2 X elseif (ipvt(i).eq.i+1) then X hr(i+1,j)=hr(i,j)-hr(i+1,i)*h(i+1,j) X hi(i+1,j)=hi(i,j)-hi(i+1,i)*h(i+1,j) X hr(ndim,j)=hr(ndim,j)-hr(ndim,i)*h(i+1,j) X hi(ndim,j)=hi(ndim,j)-hi(ndim,i)*h(i+1,j) X hr(i,j)=h(i+1,j) X hi(i,j)=0.0 X else X call xmult(hr(i+1,i),hi(i+1,i),hr(ndim,j),hi(ndim,j), X $ temp1,temp2) X hr(i+1,j)=h(i+1,j)-temp1 X hi(i+1,j)=-temp2 X call xmult(hr(ndim,i),hi(ndim,i),hr(ndim,j),hi(ndim,j), X $ temp1,temp2) X temp3=hr(ndim,j) X temp4=hi(ndim,j) X hr(ndim,j)=hr(i,j)-temp1 X hi(ndim,j)=hi(i,j)-temp2 X hr(i,j)=temp3 X hi(i,j)=temp4 X endif X 8 continue X if (ipvt(j-1).eq.j-1) then X call xmult(hr(j,j-1),hi(j,j-1),hr(j-1,j),hi(j-1,j), X $ temp1,temp2) X hr(j,j)=h(j,j)-wr-temp1 X hi(j,j)=-wi-temp2 X call xmult(hr(ndim,j-1),hi(ndim,j-1),hr(j-1,j),hi(j-1,j), X $ temp1,temp2) X hr(ndim,j)=hr(ndim,j)-temp1 X hi(ndim,j)=hi(ndim,j)-temp2 X elseif (ipvt(j-1).eq.j) then X call xmult(hr(j,j-1),hi(j,j-1),h(j,j)-wr,-wi,temp1, X + temp2) X hr(j,j)=hr(j-1,j)-temp1 X hi(j,j)=hi(j-1,j)-temp2 X hr(j-1,j)=h(j,j)-wr X hi(j-1,j)=-wi X call xmult(hr(ndim,j-1),hi(ndim,j-1),hr(j-1,j),hi(j-1,j), X $ temp1,temp2) X hr(ndim,j)=hr(ndim,j)-temp1 X hi(ndim,j)=hi(ndim,j)-temp2 X else X call xmult(hr(j,j-1),hi(j,j-1),hr(ndim,j),hi(ndim,j), X + temp1,temp2) X hr(j,j)=h(j,j)-wr-temp1 X hi(j,j)=-wi-temp2 X call xmult(hr(ndim,j-1),hi(ndim,j-1),hr(ndim,j),hi(ndim,j), X $ temp1,temp2) X temp3=hr(ndim,j) X temp4=hi(ndim,j) X hr(ndim,j)=hr(j-1,j)-temp1 X hi(ndim,j)=hi(j-1,j)-temp2 X hr(j-1,j)=temp3 X hi(j-1,j)=temp4 X endif c compute next multiplier. c X if ( j .eq. ndim-1 ) then X if (hr(ndim,j) .eq. 0.0 .and. hi(ndim,j) .eq. 0.0) then X ipvt(j)=j X elseif (dabs(hr(j,j))+dabs(hi(j,j)) X $ .ge. dabs(hr(ndim,j))+dabs(hi(ndim,j))) then X call xdiv(hr(ndim,j),hi(ndim,j),hr(j,j),hi(j,j), X $ hr(ndim,j),hi(ndim,j)) X ipvt(j)=j X else X temp1=hr(ndim,j) X temp2=hi(ndim,j) X call xdiv(hr(j,j),hi(j,j),hr(ndim,j),hi(ndim,j), X $ hr(ndim,j),hi(ndim,j)) X hr(j,j)=temp1 X hi(j,j)=temp2 X ipvt(j)=ndim X endif X elseif (( h(j+1,j) .eq. 0.0 .and. X $ hr(ndim,j) .eq. 0.0 .and. hi(ndim,j) .eq. 0.0)) then X hr(j+1,j) = 0.0 X hi(j+1,j) = 0.0 X ipvt(j) = j X elseif (dabs(hr(j,j))+dabs(hi(j,j)) .ge. X $ max(dabs(h(j+1,j)), X $ dabs(hr(ndim,j))+dabs(hi(ndim,j)))) then X call xinv(h(j+1,j),hr(j,j),hi(j,j), X $ hr(j+1,j),hi(j+1,j)) X call xdiv(hr(ndim,j),hi(ndim,j),hr(j,j),hi(j,j), X $ hr(ndim,j),hi(ndim,j)) X ipvt(j)=j X elseif (dabs(h(j+1,j)) .gt. X $ dabs(hr(ndim,j))+dabs(hi(ndim,j))) then X hr(j+1,j)=hr(j,j)/h(j+1,j) X hi(j+1,j)=hi(j,j)/h(j+1,j) X hr(j,j)=h(j+1,j) X hi(j,j)=0.0d0 X hr(ndim,j)=hr(ndim,j)/h(j+1,j) X hi(ndim,j)=hi(ndim,j)/h(j+1,j) X ipvt(j)=j+1 X else X call xinv(h(j+1,j),hr(ndim,j),hi(ndim,j), X $ hr(j+1,j),hi(j+1,j)) X temp1=hr(ndim,j) X temp2=hi(ndim,j) X call xdiv(hr(j,j),hi(j,j),hr(ndim,j),hi(ndim,j), X $ hr(ndim,j),hi(ndim,j)) X hr(j,j)=temp1 X hi(j,j)=temp2 X ipvt(j)=ndim X endif c X 10 continue c X* X* reduce last column X* c X hr(1,ndim)=-zr(1) X hi(1,ndim)=-zi(1) X do 11 i=1,ndim-2 X if (ipvt(i).eq.i) then X call xmult(hr(i+1,i),hi(i+1,i),hr(i,ndim),hi(i,ndim), X $ temp1,temp2) X hr(i+1,ndim)=-zr(i+1)-temp1 X hi(i+1,ndim)=-zi(i+1)-temp2 X call xmult(hr(ndim,i),hi(ndim,i),hr(i,ndim),hi(i,ndim), X $ temp1,temp2) X hr(ndim,ndim)=hr(ndim,ndim)-temp1 X hi(ndim,ndim)=hi(ndim,ndim)-temp2 X elseif (ipvt(i) .eq. i+1) then X call xmult(hr(i+1,i),hi(i+1,i),-zr(i+1),-zi(i+1), X $ temp1,temp2) X hr(i+1,ndim)=hr(i,ndim)-temp1 X hi(i+1,ndim)=hi(i,ndim)-temp2 X hr(i,ndim)=-zr(i+1) X hi(i,ndim)=-zi(i+1) X call xmult(hr(ndim,i),hi(ndim,i),hr(i,ndim),hi(i,ndim), X $ temp1,temp2) X hr(ndim,ndim)=hr(ndim,ndim)-temp1 X hi(ndim,ndim)=hi(ndim,ndim)-temp2 X else X call xmult(hr(i+1,i),hi(i+1,i),hr(ndim,ndim),hi(ndim,ndim), X $ temp1,temp2) X hr(i+1,ndim)=-zr(i+1)-temp1 X hi(i+1,ndim)=-zi(i+1)-temp2 X temp3=hr(ndim,ndim) X temp4=hi(ndim,ndim) X call xmult(hr(ndim,i),hi(ndim,i), X $ hr(ndim,ndim),hi(ndim,ndim), X $ temp1,temp2) X hr(ndim,ndim)=hr(i,ndim)-temp1 X hi(ndim,ndim)=hi(i,ndim)-temp2 X hr(i,ndim)=temp3 X hi(i,ndim)=temp4 X endif X 11 continue c X if (ipvt(ndim-1) .eq. ndim-1) then X call xmult(hr(ndim,ndim-1),hi(ndim,ndim-1), X $ hr(ndim-1,ndim),hi(ndim-1,ndim), X $ temp1,temp2) X hr(ndim,ndim)=hr(ndim,ndim)-temp1 X hi(ndim,ndim)=hi(ndim,ndim)-temp2 X else X call xmult(hr(ndim,ndim-1),hi(ndim,ndim-1), X $ hr(ndim,ndim),hi(ndim,ndim), X $ temp1,temp2) X temp3=hr(ndim,ndim) X temp4=hi(ndim,ndim) X hr(ndim,ndim)=hr(ndim-1,ndim)-temp1 X hi(ndim,ndim)=hi(ndim-1,ndim)-temp2 X hr(ndim-1,ndim)=temp3 X hi(ndim-1,ndim)=temp4 X endif c X ipvt(ndim)=ndim c X return c X* X* real case. X* c X 25 continue c X hr(1,1)=h(1,1)-wr X if (h(2,1) .eq. 0.0 .and. hr(ndim,1) .eq. 0.0) then X hr(2,1)=0.0 X ipvt(1)=1 X elseif (dabs(hr(1,1)) .ge. X $ max(dabs(h(2,1)),dabs(hr(ndim,1)))) then X hr(2,1)=h(2,1)/hr(1,1) X hr(ndim,1)=hr(ndim,1)/hr(1,1) X ipvt(1)=1 X elseif (dabs(h(2,1)).gt.dabs(hr(ndim,1))) then X hr(2,1)=hr(1,1)/h(2,1) X hr(ndim,1)=hr(ndim,1)/h(2,1) X hr(1,1)=h(2,1) X ipvt(1)=2 X else X hr(2,1)=h(2,1) X hr(ndim,1)=hr(1,1) X hr(1,1)=1.0 X ipvt(1)=ndim X endif c X do 50 j=2,ndim-1 X hr(1,j)=h(1,j) c c apply previous interchanges and multipliers. c X do 48 i=1,j-2 X if (ipvt(i).eq.i) then X hr(i+1,j)=h(i+1,j)-hr(i+1,i)*hr(i,j) X hr(ndim,j)=hr(ndim,j)-hr(ndim,i)*hr(i,j) X elseif (ipvt(i).eq.i+1) then X hr(i+1,j)=hr(i,j)-hr(i+1,i)*h(i+1,j) X hr(ndim,j)=hr(ndim,j)-hr(ndim,i)*h(i+1,j) X hr(i,j)=h(i+1,j) X else X hr(i+1,j)=h(i+1,j)-hr(i+1,i)*hr(ndim,j) X temp1=hr(ndim,j) X hr(ndim,j)=hr(i,j)-hr(ndim,i)*hr(ndim,j) X hr(i,j)=temp1 X endif X 48 continue X if (ipvt(j-1).eq.j-1) then X hr(j,j)=h(j,j)-wr-hr(j,j-1)*hr(j-1,j) X hr(ndim,j)=hr(ndim,j)-hr(ndim,j-1)*hr(j-1,j) X elseif (ipvt(j-1).eq.j) then X hr(j,j)=hr(j-1,j)-hr(j,j-1)*(h(j,j)-wr) X hr(j-1,j)=h(j,j)-wr X hr(ndim,j)=hr(ndim,j)-hr(ndim,j-1)*hr(j-1,j) X else X hr(j,j)=h(j,j)-wr-hr(j,j-1)*hr(ndim,j) X temp1=hr(ndim,j) X hr(ndim,j)=hr(j-1,j)-hr(ndim,j-1)*hr(ndim,j) X hr(j-1,j)=temp1 X endif c compute next multiplier. c X if ( j .eq. ndim-1 ) then X if (hr(ndim,j) .eq. 0.0) then X ipvt(j)=j X elseif (dabs(hr(j,j)) X $ .ge. dabs(hr(ndim,j))) then X hr(ndim,j)=hr(ndim,j)/hr(j,j) X ipvt(j)=j X else X temp1=hr(ndim,j) X hr(ndim,j)=hr(j,j)/hr(ndim,j) X hr(j,j)=temp1 X ipvt(j)=ndim X endif X elseif ( h(j+1,j) .eq. 0.0 .and. X $ hr(ndim,j) .eq. 0.0 ) then X hr(j+1,j) = 0.0 X ipvt(j) = j X elseif (dabs(hr(j,j)) .ge. X $ max(dabs(h(j+1,j)),dabs(hr(ndim,j)))) then X hr(j+1,j)=h(j+1,j)/hr(j,j) X hr(ndim,j)=hr(ndim,j)/hr(j,j) X ipvt(j)=j X elseif (dabs(h(j+1,j)) .gt. X $ dabs(hr(ndim,j))) then X hr(j+1,j)=hr(j,j)/h(j+1,j) X hr(j,j)=h(j+1,j) X hr(ndim,j)=hr(ndim,j)/h(j+1,j) X ipvt(j)=j+1 X else X hr(j+1,j)=h(j+1,j)/hr(ndim,j) X temp1=hr(ndim,j) X hr(ndim,j)=hr(j,j)/hr(ndim,j) X hr(j,j)=temp1 X ipvt(j)=ndim X endif c X 50 continue c X hr(1,ndim)=-zr(1) X do 51 i=1,ndim-2 X if (ipvt(i).eq.i) then X hr(i+1,ndim)=-zr(i+1)-hr(i+1,i)*hr(i,ndim) X hr(ndim,ndim)=hr(ndim,ndim)-hr(ndim,i)*hr(i,ndim) X elseif (ipvt(i) .eq. i+1) then X hr(i+1,ndim)=hr(i,ndim)-hr(i+1,i)*(-zr(i+1)) X hr(i,ndim)=-zr(i+1) X hr(ndim,ndim)=hr(ndim,ndim)-hr(ndim,i)*hr(i,ndim) X else X hr(i+1,ndim)=-zr(i+1)-hr(i+1,i)*hr(ndim,ndim) X temp1=hr(ndim,ndim) X hr(ndim,ndim)=hr(i,ndim)-hr(ndim,i)*hr(ndim,ndim) X hr(i,ndim)=temp1 X endif X 51 continue c X if (ipvt(ndim-1) .eq. ndim-1) then X hr(ndim,ndim)=hr(ndim,ndim)-hr(ndim,ndim-1)*hr(ndim-1,ndim) X else X temp1=hr(ndim,ndim) X hr(ndim,ndim)=hr(ndim-1,ndim)-hr(ndim,ndim-1)*hr(ndim,ndim) X hr(ndim-1,ndim)=temp1 X endif c X ipvt(ndim)=ndim c X return X end END_OF_FILE if test 14472 -ne `wc -c <'fmylun.f'`; then echo shar: \"'fmylun.f'\" unpacked with wrong size! fi # end of 'fmylun.f' fi if test -f 'fmysoln.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'fmysoln.f'\" else echo shar: Extracting \"'fmysoln.f'\" \(2515 characters\) sed "s/^X//" >'fmysoln.f' <<'END_OF_FILE' X subroutine csol(lda,compx,ndim,ipvt,hr,hi,zr,zi,eps) CVD$G noconcur X double precision hr(lda+1,*),hi(lda+1,*) X double precision zr(*),zi(*) X double precision eps X integer ipvt(*) X integer lda,ndim X logical compx c X double precision temp,temp1,temp2 X integer i,j,ip,jm1 c X external xmult, xdiv X*** X* purpose X* ------- X* solves linear system with right hand side zr + sqrt(-1) * zi X* using output from clufac. X* X* output in zr+sqrt(-1)*zi X*** c X* X* If the current eigenpair is not complex do real arithmetic. X* c X if (.not. compx) goto 25 c c pivot right hand side and forward solve. c X do 13 i=1,ndim-1 X if (ipvt(i).ne.i) then X ip=ipvt(i) X temp1=zr(i) X temp2=zi(i) X zr(i)=zr(ip) X zi(i)=zi(ip) X zr(ip)=temp1 X zi(ip)=temp2 X endif X call xmult(hr(i+1,i),hi(i+1,i),zr(i),zi(i), X + temp1,temp2) X zr(i+1)=zr(i+1)-temp1 X zi(i+1)=zi(i+1)-temp2 X if (i.eq.ndim-1) goto 13 X call xmult(hr(ndim,i),hi(ndim,i),zr(i),zi(i), X $ temp1,temp2) X zr(ndim)=zr(ndim)-temp1 X zi(ndim)=zi(ndim)-temp2 X 13 continue c column version of back subst. c X do 12 j=ndim,1,-1 X if (hr(j,j).eq.0.0 .and. hi(j,j).eq.0.0) hr(j,j)=eps X call xdiv(zr(j),zi(j),hr(j,j),hi(j,j),zr(j),zi(j)) X jm1=j-1 X do 11 i=1,jm1 X call xmult(zr(j),zi(j),hr(i,j),hi(i,j),temp1,temp2) X zr(i)=zr(i)-temp1 X zi(i)=zi(i)-temp2 X 11 continue X 12 continue c X return c X 25 continue c c pivot right hand side and forward solve. c X do 43 i=1,ndim-1 X if (ipvt(i).ne.i) then X ip=ipvt(i) X temp1=zr(i) X zr(i)=zr(ip) X zr(ip)=temp1 X endif X zr(i+1)=zr(i+1)-hr(i+1,i)*zr(i) X if (i.eq.ndim-1) goto 43 X call xmult(hr(ndim,i),hi(ndim,i),zr(i),zi(i), X $ temp1,temp2) X zr(ndim)=zr(ndim)-hr(ndim,i)*zr(i) X 43 continue c column version of back subst. c X do 52 j=ndim,1,-1 X if (hr(j,j).eq.0.0) hr(j,j)=eps X zr(j)=zr(j)/hr(j,j) X jm1=j-1 X do 51 i=1,jm1 X zr(i)=zr(i)-zr(j)*hr(i,j) X 51 continue X 52 continue c X return X end END_OF_FILE if test 2515 -ne `wc -c <'fmysoln.f'`; then echo shar: \"'fmysoln.f'\" unpacked with wrong size! fi # end of 'fmysoln.f' fi if test -f 'fresid.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'fresid.f'\" else echo shar: Extracting \"'fresid.f'\" \(2351 characters\) sed "s/^X//" >'fresid.f' <<'END_OF_FILE' X subroutine resid(lprm,compx,ndim,h,wr,wi,zr,zi,resr,resi,rnorm) X double precision rnorm,wr,wi X double precision h(lprm,*),resr(*),resi(*) X double precision zr(*),zi(*) X integer ndim,lprm X logical compx c X integer i,j,jj X double precision vnorm c X*** X* purpose X* ------- X* computes the residual: X* X* resr + sqrt(-1) * resi = ( lam * z - h * z ) X* X* with: lam = wr + sqrt(-1) * wi X* z = zr + sqrt(-1) * zi X* X* on output: rnorm contains the 2-norm of the residual divided by X* that of the current eigenvector. X*** X rnorm=0.0d0 X vnorm=0.0d0 X do 1 i=1,ndim X resr(i)=0.0d0 X resi(i)=0.0d0 X 1 continue c complex case first. c X if (.not.compx) goto 25 c X* X* Compute the residual. X* c X do 10 j=1,ndim X do 9 i=1,min(j+1,ndim) X resr(i)=resr(i)-h(i,j)*zr(j) X resi(i)=resi(i)-h(i,j)*zi(j) X 9 continue X resr(j)=wr*zr(j)-wi*zi(j)+resr(j) X resi(j)=wr*zi(j)+wi*zr(j)+resi(j) X 10 continue c X* X* Compute the norms of the residual and the current eigenvector. X* c X do 11 i=1,ndim X rnorm=rnorm+resr(i)**2+resi(i)**2 c rnorm=max(rnorm,resr(i)**2+resi(i)**2) X* rnorm=max(rnorm,dabs(resr(i))+dabs(resi(i))) X vnorm=vnorm+zr(i)**2+zi(i)**2 c vnorm=max(vnorm,zr(i)**2+zi(i)**2) X* vnorm=max(vnorm,dabs(zr(i))+dabs(zi(i))) X 11 continue c X rnorm=dsqrt(rnorm) X vnorm=dsqrt(vnorm) X if (vnorm .eq. 0.0) then X print *, 'Error in resid: zero eigenvector' X else X rnorm=rnorm/vnorm X endif c X return c c real case. c X 25 do 40 j=1,ndim X do 24 i=1,min(j+1,ndim) X resr(i)=resr(i)-h(i,j)*zr(j) X 24 continue X resr(j)=wr*zr(j)+resr(j) X 40 continue X do 41 i=1,ndim X rnorm=rnorm+resr(i)**2 c rnorm=max(rnorm,resr(i)**2) c rnorm=max(rnorm,dabs(resr(i))) X vnorm=vnorm+zr(i)**2 c vnorm=max(vnorm,zr(i)**2) c vnorm=max(vnorm,dabs(zr(i))) X 41 continue c X rnorm=dsqrt(rnorm) X vnorm=dsqrt(vnorm) X if (vnorm .eq. 0.0) then X print *, 'Error in resid: zero eigenvector' X else X rnorm=rnorm/vnorm X endif c X return X end END_OF_FILE if test 2351 -ne `wc -c <'fresid.f'`; then echo shar: \"'fresid.f'\" unpacked with wrong size! fi # end of 'fresid.f' fi if test -f 'fscale.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'fscale.f'\" else echo shar: Extracting \"'fscale.f'\" \(834 characters\) sed "s/^X//" >'fscale.f' <<'END_OF_FILE' X subroutine scale(ndim,index,xxr,xxi) X integer ndim,index X double precision xxr(*),xxi(*) X double precision temp1,temp2 c X integer i c X external xmult, xinv c X*** X* purpose X* ------- X* normalizes xxr + sqrt(-1) * xxi so that largest component is 1. X* on output, index contains the index of the largest component. X*** c X temp1=dabs(xxr(1))+dabs(xxi(1)) X index=1 X do 10 i=2,ndim X temp2=dabs(xxr(i))+dabs(xxi(i)) X if (temp2.gt.temp1) then X temp1=temp2 X index=i X endif X 10 continue c X if (temp1.eq.0.0d0) print *,'Error in scale: zero vector.' c X call xinv(1.0d0,xxr(index),xxi(index),temp1,temp2) X do 20 i=1,ndim X call xmult(xxr(i),xxi(i),temp1,temp2,xxr(i),xxi(i)) X 20 continue c X return X end END_OF_FILE if test 834 -ne `wc -c <'fscale.f'`; then echo shar: \"'fscale.f'\" unpacked with wrong size! fi # end of 'fscale.f' fi if test -f 'fvec.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'fvec.f'\" else echo shar: Extracting \"'fvec.f'\" \(874 characters\) sed "s/^X//" >'fvec.f' <<'END_OF_FILE' X subroutine vec(lda,ndim,lam,zr,zi) X double precision lam(*),zr(lda,*),zi(lda,*) X integer lda,ndim c X integer ig,i c X*** X* purpose X* ------- X* Initially zr contains the eigenvectors from the output of hqr2. X* On output, the real and imaginary parts of these eigenvectors X* are stored in 2 different arrays zr and zi. X* lam contains the imaginary parts of the eigenvalues and remains X* unchanged. X*** c X ig=1 X 5 if (ig.le.ndim) then X if (lam(ig).eq.0) then X do 1 i=1,ndim X zi(i,ig)=0.d0 X 1 continue X else X do 2 i=1,ndim X zi(i,ig)=zr(i,ig+1) X zi(i,ig+1)=-zr(i,ig+1) X zr(i,ig+1)=zr(i,ig) X 2 continue X ig=ig+1 X endif X ig=ig+1 X goto 5 X endif c X return X end END_OF_FILE if test 874 -ne `wc -c <'fvec.f'`; then echo shar: \"'fvec.f'\" unpacked with wrong size! fi # end of 'fvec.f' fi if test -f 'fxops.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'fxops.f'\" else echo shar: Extracting \"'fxops.f'\" \(1260 characters\) sed "s/^X//" >'fxops.f' <<'END_OF_FILE' X subroutine xdiv(z1r,z1i,z2r,z2i,z3r,z3i) X double precision z1r,z1i,z2r,z2i,z3r,z3i c X double precision temp,z1rq,z1iq,z2rq,z2iq c X*** X* purpose X* ------- X* complex division X*** c X if (z2i.eq.0.0d0) then X temp=z1r/z2r X z3i=z1i/z2r X z3r=temp X return X endif c X temp=dabs(z2r)+dabs(z2i) X z1rq=z1r/temp X z1iq=z1i/temp X z2rq=z2r/temp X z2iq=z2i/temp X temp=z2rq**2+z2iq**2 X z3r=(z1rq*z2rq+z1iq*z2iq)/temp X z3i=(z1iq*z2rq-z1rq*z2iq)/temp c X return X end c X subroutine xmult(z1r,z1i,z2r,z2i,z3r,z3i) X double precision z1r,z1i,z2r,z2i,z3r,z3i c X double precision temp c X*** X* purpose X* ------- X* complex multiplication X*** c X temp=z1r*z2r-z1i*z2i X z3i=z1r*z2i+z1i*z2r X z3r=temp c X return X end c X subroutine xinv(z1,z2r,z2i,z3r,z3i) X double precision z1,z2r,z2i,z3r,z3i c X double precision temp,z1rq,z1iq,z2rq,z2iq c X*** X* purpose X* ------- X* divides a real number z1 by z2r + sqrt(-1) * z2i X*** c X temp=dabs(z2r)+dabs(z2i) X z1rq=z1/temp X z2rq=z2r/temp X z2iq=z2i/temp X temp=z2rq**2+z2iq**2 X z3r=z1rq*z2rq/temp X z3i=-z1rq*z2iq/temp c X return X end END_OF_FILE if test 1260 -ne `wc -c <'fxops.f'`; then echo shar: \"'fxops.f'\" unpacked with wrong size! fi # end of 'fxops.f' fi if test -f 'idamax.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'idamax.f'\" else echo shar: Extracting \"'idamax.f'\" \(1342 characters\) sed "s/^X//" >'idamax.f' <<'END_OF_FILE' X INTEGER FUNCTION IDAMAX( N, DX, INCX ) X* X* finds the index of element having max. absolute value. X* jack dongarra, linpack, 3/11/78. X* modified to correct problem with negative increment, 8/21/90. X* X* .. Scalar Arguments .. X INTEGER INCX, N X* .. X* .. Array Arguments .. X DOUBLE PRECISION DX( 1 ) X* .. X* .. Local Scalars .. X INTEGER I, IX X DOUBLE PRECISION DMAX X* .. X* .. Intrinsic Functions .. X INTRINSIC DABS X* .. X* .. Executable Statements .. X* X IDAMAX = 0 X IF( N.LT.1 ) X $ RETURN X IDAMAX = 1 X IF( N.EQ.1 ) X $ RETURN X IF( INCX.EQ.1 ) X $ GO TO 30 X* X* code for increment not equal to 1 X* X IX = 1 X IF( INCX.LT.0 ) X $ IX = ( -N+1 )*INCX + 1 X DMAX = DABS( DX( IX ) ) X IX = IX + INCX X DO 20 I = 2, N X IF( DABS( DX( IX ) ).LE.DMAX ) X $ GO TO 10 X IDAMAX = I X DMAX = DABS( DX( IX ) ) X 10 CONTINUE X IX = IX + INCX X 20 CONTINUE X RETURN X* X* code for increment equal to 1 X* X 30 CONTINUE X DMAX = DABS( DX( 1 ) ) X DO 40 I = 2, N X IF( DABS( DX( I ) ).LE.DMAX ) X $ GO TO 40 X IDAMAX = I X DMAX = DABS( DX( I ) ) X 40 CONTINUE X RETURN X END END_OF_FILE if test 1342 -ne `wc -c <'idamax.f'`; then echo shar: \"'idamax.f'\" unpacked with wrong size! fi # end of 'idamax.f' fi if test -f 'lsame.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'lsame.f'\" else echo shar: Extracting \"'lsame.f'\" \(2383 characters\) sed "s/^X//" >'lsame.f' <<'END_OF_FILE' X LOGICAL FUNCTION LSAME( CA, CB ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER CA, CB X* .. X* X* Purpose X* ======= X* X* LSAME returns .TRUE. if CA is the same letter as CB regardless of X* case. X* X* This version of the routine is only correct for ASCII code. X* Installers must modify the routine for other character-codes. X* X* For EBCDIC systems the constant IOFF must be changed to -64. X* For CDC systems using 6-12 bit representations, the system- X* specific code in comments must be activated. X* X* Arguments X* ========= X* X* CA (input) CHARACTER*1 X* CB (input) CHARACTER*1 X* CA and CB specify the single characters to be compared. X* X* X* .. Parameters .. X INTEGER IOFF X PARAMETER ( IOFF = 32 ) X* .. X* .. Intrinsic Functions .. X INTRINSIC ICHAR X* .. X* .. Executable Statements .. X* X* Test if the characters are equal X* X LSAME = CA.EQ.CB X* X* Now test for equivalence X* X IF( .NOT.LSAME ) THEN X LSAME = ICHAR( CA ) - IOFF.EQ.ICHAR( CB ) X END IF X IF( .NOT.LSAME ) THEN X LSAME = ICHAR( CA ).EQ.ICHAR( CB ) - IOFF X END IF X* X RETURN X* X* The following comments contain code for CDC systems using 6-12 bit X* representations. X* X* .. Parameters .. X* INTEGER ICIRFX X* PARAMETER ( ICIRFX=62 ) X* .. Scalar arguments .. X* CHARACTER*1 CB X* .. Array arguments .. X* CHARACTER*1 CA(*) X* .. Local scalars .. X* INTEGER IVAL X* .. Intrinsic functions .. X* INTRINSIC ICHAR, CHAR X* .. Executable statements .. X* X* See if the first character in string CA equals string CB. X* X* LSAME = CA(1) .EQ. CB .AND. CA(1) .NE. CHAR(ICIRFX) X* X* IF (LSAME) RETURN X* X* The characters are not identical. Now check them for equivalence. X* Look for the 'escape' character, circumflex, followed by the X* letter. X* X* IVAL = ICHAR(CA(2)) X* IF (IVAL.GE.ICHAR('A') .AND. IVAL.LE.ICHAR('Z')) THEN X* LSAME = CA(1) .EQ. CHAR(ICIRFX) .AND. CA(2) .EQ. CB X* END IF X* X* RETURN X* X* End of LSAME X* X END END_OF_FILE if test 2383 -ne `wc -c <'lsame.f'`; then echo shar: \"'lsame.f'\" unpacked with wrong size! fi # end of 'lsame.f' fi if test -f 'lsamen.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'lsamen.f'\" else echo shar: Extracting \"'lsamen.f'\" \(1655 characters\) sed "s/^X//" >'lsamen.f' <<'END_OF_FILE' X LOGICAL FUNCTION LSAMEN( N, CA, CB ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER*( * ) CA, CB X INTEGER N X* .. X* X* Purpose X* ======= X* X* LSAMEN tests if the first N letters of CA are the same as the X* first N letters of CB, regardless of case. X* LSAMEN returns .TRUE. if CA and CB are equivalent except for case X* and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA ) X* or LEN( CB ) is less than N. X* X* Arguments X* ========= X* X* N (input) INTEGER X* The number of characters in CA and CB to be compared. X* X* CA (input) CHARACTER*(*) X* CB (input) CHARACTER*(*) X* CA and CB specify two character strings of length at least N. X* Only the first N characters of each string will be accessed. X* X* .. Local Scalars .. X INTEGER I X* .. X* .. External Functions .. X LOGICAL LSAME X EXTERNAL LSAME X* .. X* .. Intrinsic Functions .. X INTRINSIC LEN X* .. X* .. Executable Statements .. X* X LSAMEN = .FALSE. X IF( LEN( CA ).LT.N .OR. LEN( CB ).LT.N ) X $ GO TO 20 X* X* Do for each character in the two strings. X* X DO 10 I = 1, N X* X* Test if the characters are equal using LSAME. X* X IF( .NOT. LSAME( CA( I: I ), CB( I: I ) ) ) GOTO 20 X* X 10 CONTINUE X LSAMEN = .TRUE. X* X 20 CONTINUE X RETURN X* X* End of LSAMEN X* X END END_OF_FILE if test 1655 -ne `wc -c <'lsamen.f'`; then echo shar: \"'lsamen.f'\" unpacked with wrong size! fi # end of 'lsamen.f' fi if test -f 'test.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'test.f'\" else echo shar: Extracting \"'test.f'\" \(5532 characters\) sed "s/^X//" >'test.f' <<'END_OF_FILE' X program test X* X* This program calls DCHK21 from the LAPACK testing suite, and then calls X* the routine DANDC that implements a divide and conquer procedure for X* finding the eigensystem of the upper-hessenberg matrix from the output X* of DCHK21. X* See the comments in DANDC and the routines referred to therein X* for more information about the D&C code. X* One step of the algorithm was not implemented in this code: we did not X* include the software needed to deflate the matrix in order to obtain X* further eigenpairs (if not all of them were obtained after the initial X* guesses were exhausted). X* As it stands the storage requirement for this program is not optimal. X* The optimal storage requirement for the D&C code is: 4n^2 + O(n). The X* current version uses 5n^2 + O(n). X* X* X* Questions should be addressed to: dongarra@cs.utk.edu or sidani@cs.utk.edu X* X* X* Declarations for the LAPACK testing program X* ------------ --- --- ------ ------- ------- X* X* .. Parameters .. X INTEGER NMAX X PARAMETER ( NMAX = 132 ) X INTEGER NEED X PARAMETER ( NEED = 11 ) X INTEGER LWORK X PARAMETER ( LWORK = NMAX*( 4*NMAX+3 ) ) X INTEGER MAXIN X PARAMETER ( MAXIN = 20 ) X INTEGER MAXT X PARAMETER ( MAXT = 25 ) X INTEGER NIN, NOUT X PARAMETER ( NIN = 5, NOUT = 6 ) X* .. X* .. Local Scalars .. X CHARACTER*3 C3 X CHARACTER*10 INTSTR X INTEGER I, INFO, MAXTYP,NN X DOUBLE PRECISION THRESH X* .. X* .. Local Arrays .. X LOGICAL DOTYPE( MAXT ), LOGWRK( NMAX ) X INTEGER IOLDSD( 4 ), ISEED( 4 ), IWORK( NMAX ), X $ NVAL( MAXIN ) X DOUBLE PRECISION A( NMAX*NMAX, NEED ), D( NMAX, 6 ), X $ RESULT( 20 ), WORK( LWORK ) X* .. X* .. External Functions .. X LOGICAL LSAMEN X DOUBLE PRECISION DLAMCH, DSECND X EXTERNAL LSAMEN, DLAMCH, DSECND X* .. X* .. External Subroutines .. X EXTERNAL ALAREQ, DCHK21, DCHK22, DCHK26 X* .. X* .. Intrinsic Functions .. X INTRINSIC LEN, MIN X* .. X* .. Common blocks .. X COMMON / CENVIR / NBLOCK, NPROC, NSHIFT, MAXB X* .. X* .. Scalars in Common .. X INTEGER MAXB, NBLOCK, NPROC, NSHIFT X* .. X* .. Data statements .. X DATA INTSTR / '0123456789' / X DATA IOLDSD / 0, 0, 0, 1 / X* X* X* Declarations for the D&C X* ------------ --- --- --- X* X double precision horg(nmax,nmax),zr(nmax,nmax),zi(nmax,nmax), X $ res(nmax+1,2),work1(nmax+1,2),work2(nmax+1,2), X $ lam(nmax,2),work0((nmax+1)**2,2) X double precision error,rnorm,spnrmh,tol,d1mach,random,error2 X integer ind(nmax),ipvt(nmax),j,ii,itype,trace X logical compx X* X integer isze,inbr X* X integer steps X common/steps/steps X* X external dandc,caltol,resid X* X* .. Executable Statements .. X* X* Instruct DCHK21 that one matrix is to be generated and its eigensystem X* solved, only. X* X nn=1 X* X* itype=10 X* nval(1)=100 X* X* X* Setting THRESH to 0.0 forces DCHK21 to print the results from the tests X* it performs on the various vectors and matrices computed during the QR X* iteration. (see DCHK21 for more details) X* X thresh=0.0 X* X* MAXTYP is the number of different types of matrices to be generated. X* X maxtyp=21 X do 1 i=1,maxtyp X dotype(i)=.false. X 1 continue X* X* If TRACE is 1 than information about how residuals are varying starting X* the various initial guesses in the D&C code will be printed. X* X trace=0 X* X do 50 itype=9,maxtyp X do 49 isze=20,100,20 X print *,'----------- NEW PROBLEM ----------- ' X nval(1)=isze X* do 48 inbr=1,2 X if (itype.ne.1) dotype(itype-1)=.false. X dotype(itype)=.true. X CALL DCHK21( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT, X $ A( 1, 1 ), NMAX, horg, A( 1, 3 ), X $ A( 1, 4 ), A( 1, 5 ), NMAX, A( 1, 6 ), X $ A( 1, 7 ), D( 1, 1 ), D( 1, 2 ), D( 1, 3 ), X $ D( 1, 4 ), A( 1, 8 ), A( 1, 9 ), A( 1, 10 ), X $ A( 1, 11 ), WORK, LWORK, IWORK, LOGWRK, RESULT, X $ INFO ) X* open (9,file='matrix.dat') X* ii=1 X* do i=1,nval(1) X* if (i.ne.1) ii=i-1 X* do j=ii,nval(1) X* horg(i,j)=random() X* write(9,*) horg(i,j) X* enddo X* enddo X* close(9) X steps=0 X call dandc(nmax,nval(1),horg,lam, X $ zr,zi,ind,ipvt,res,work0,work1,work2,trace) X call caltol(nmax,nval(1),horg,tol,spnrmh) X error=0.0 X compx=.true. X do 40 i=1,nval(1) X* print *,'wr(',i,')=',lam(i,1),' wi(',i,')=',lam(i,2) X call resid(nmax,compx,nval(1),horg,lam(i,1), X $ lam(i,2),zr(1,i),zi(1,i),res(1,1),res(1,2),rnorm) X* print *,'error=',error X error=max(error,rnorm) X 40 continue X if (spnrmh.ne.0.0) error=error/(spnrmh*d1mach(3)) X print * X print *,'Maximum Residual from D&C / (macheps*norm(h)) = ', X $ error X** print *,'Average number of steps per initial guess = ', X** $ steps/nval(1) X print * X 48 continue X 49 continue X 50 continue X* X end END_OF_FILE if test 5532 -ne `wc -c <'test.f'`; then echo shar: \"'test.f'\" unpacked with wrong size! fi # end of 'test.f' fi if test -f 'xerbla.f' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'xerbla.f'\" else echo shar: Extracting \"'xerbla.f'\" \(1134 characters\) sed "s/^X//" >'xerbla.f' <<'END_OF_FILE' X SUBROUTINE XERBLA( SRNAME, INFO ) X* X* -- LAPACK auxiliary routine (preliminary version) -- X* Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab, X* Courant Institute, NAG Ltd., and Rice University X* March 26, 1990 X* X* .. Scalar Arguments .. X CHARACTER*6 SRNAME X INTEGER INFO X* .. X* X* Purpose X* ======= X* X* XERBLA is an error handler for the LAPACK routines. X* It is called by an LAPACK routine if an input parameter has an X* invalid value. A message is printed and execution stops. X* X* Installers may consider modifying the STOP statement in order to X* call system-specific exception-handling facilities. X* X* Arguments X* ========= X* X* SRNAME (input) CHARACTER*6 X* The name of the routine which called XERBLA. X* X* INFO (input) INTEGER X* The position of the invalid parameter in the parameter list X* of the calling routine. X* X* X WRITE( *, FMT = 9999 )SRNAME, INFO X* X STOP X* X 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', X $ 'an illegal value' ) X* X* End of XERBLA X* X END END_OF_FILE if test 1134 -ne `wc -c <'xerbla.f'`; then echo shar: \"'xerbla.f'\" unpacked with wrong size! fi # end of 'xerbla.f' fi if test -f 'makefile' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'makefile'\" else echo shar: Extracting \"'makefile'\" \(1304 characters\) sed "s/^X//" >'makefile' <<'END_OF_FILE' XFORTRAN = f77 OPTS = -O -u -c LOADER = f77 LOADOPTS = X DZIGTST = dlafts.o dlahd2.o dlasum.o \ X dstech.o dstect.o dsvdch.o dsvdct.o X DEIGTST = test.o \ X dchk21.o dget21.o dget22.o dstt21.o dsyt21.o \ X dgehd3.o dormc2.o dlarfy.o X DEIG = dhsein.o dhseqr.o dlabad.o dlacpy.o dlaein.o \ X dlamch.o dlange.o dlansp.o dlansy.o dlarf.o dlarfg.o \ X dlazro.o dtrevc.o dlanhs.o dlapy2.o dlahqr.o dlassq.o \ X dlangb.o dlahrd.o lsamen.o dlartg.o dlaran.o dlarnd.o \ X dlatrs.o dorgc3.o dlansb.o dorml2.o dlaln2.o envir.o X DGEN = dlatme.o dlatmr.o dlatms.o dlaror.o dlatm1.o dlatm2.o \ X dlatm3.o dlarot.o X DBLAS = daxpy.o dcopy.o ddot.o dgemm.o dgemv.o dger.o dscal.o \ X dsymv.o dsyr.o dsyr2.o idamax.o lsame.o xerbla.o \ X dtrsv.o dnrm2.o drot.o X X X DFILES = d1mach.o depslon.o dhqr2.o dmachr.o drandom.o X XFFILESN = fcaltol.o fdefcnt.o fmylun.o \ X fmysoln.o fresid.o fscale.o \ X fdandc.o fiterat.o fvec.o fxops.o X run : $(DZIGTST) $(DEIGTST) $(DEIG) $(DGEN) $(DBLAS) $(DFILES) $(FFILESN); \ X $(LOADER) $(LOADOPTS) $(DZIGTST) $(DEIGTST) $(DEIG) $(DGEN) $(DBLAS) \ X $(DFILES) $(FFILESN) \ X -o run X clean: ; \ X rm -f *.o X X.f.o: ; \ X $(FORTRAN) $(OPTS) $< END_OF_FILE if test 1304 -ne `wc -c <'makefile'`; then echo shar: \"'makefile'\" unpacked with wrong size! fi # end of 'makefile' fi echo shar: End of shell archive. exit 0