#! /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 <file", e.g.. If this archive is complete, you
# will see the following message at the end:
# "End of shell archive."
# Contents: d1mach.f daxpy.f dchk21.f dcopy.f ddot.f depslon.f
# dgehd3.f dgemm.f dgemv.f dger.f dget21.f dget22.f dhqr2.f dhsein.f
# dhseqr.f dlabad.f dlacpy.f dlaein.f dlafts.f dlahd2.f dlahqr.f
# dlahrd.f dlaln2.f dlamch.f dlangb.f dlange.f dlanhs.f dlansb.f
# dlansp.f dlansy.f dlapy2.f dlaran.f dlarf.f dlarfg.f dlarfy.f
# dlarnd.f dlaror.f dlarot.f dlartg.f dlassq.f dlasum.f dlatm1.f
# dlatm2.f dlatm3.f dlatme.f dlatmr.f dlatms.f dlatrs.f dlazro.f
# dmachr.f dnrm2.f dorgc3.f dormc2.f dorml2.f drandom.f drot.f
# dscal.f dstech.f dstect.f dstt21.f dsvdch.f dsvdct.f dsymv.f
# dsyr.f dsyr2.f dsyt21.f dtrevc.f dtrsv.f envir.f fcaltol.f
# fdandc.f fdefcnt.f fiterat.f fmylun.f fmysoln.f fresid.f fscale.f
# fvec.f fxops.f idamax.f lsame.f lsamen.f test.f xerbla.f makefile
# Wrapped by sidani@thud on Fri May 3 13:14:04 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'd1mach.f' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'d1mach.f'\"
else
echo shar: Extracting \"'d1mach.f'\" \(2192 characters\)
sed "s/^X//" >'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