/*
* Generate a banded square matrix A, with dimension n and semi-bandwidth b.
*/
void
dband(int n, int b, int nonz, double **nzval, int **rowind, int **colptr)
{
int iseed[] = {1992,1993,1994,1995};
register int i, j, ub, lb, ilow, ihigh, lasta = 0;
double *a;
int *asub, *xa;
double *val;
int *row;
extern double dlaran_();
printf("A banded matrix.");
dallocateA(n, nonz, nzval, rowind, colptr); /* Allocate storage */
a = *nzval;
asub = *rowind;
xa = *colptr;
ub = lb = b;
for (i = 0; i < 4; ++i) iseed[i] = abs( iseed[i] ) % 4096;
if ( iseed[3] % 2 != 1 ) ++iseed[3];
for (j = 0; j < n; ++j) {
xa[j] = lasta;
val = &a[lasta];
row = &asub[lasta];
ilow = MAX(0, j - ub);
ihigh = MIN(n-1, j + lb);
for (i = ilow; i <= ihigh; ++i) {
val[i-ilow] = dlaran_(iseed);
row[i-ilow] = i;
}
lasta += ihigh - ilow + 1;
} /* for j ... */
xa[n] = lasta;
}
/*
* Generate a block diagonal matrix A.
*/
void
dblockdiag(int nb, /* number of blocks */
int bs, /* block size */
int nonz, double **nzval, int **rowind, int **colptr)
{
int iseed[] = {1992,1993,1994,1995};
register int i, j, b, n, lasta = 0, cstart, rstart;
double *a;
int *asub, *xa;
double *val;
int *row;
extern double dlaran_();
n = bs * nb;
printf("A block diagonal matrix: nb %d, bs %d, n %d\n", nb, bs, n);
dallocateA(n, nonz, nzval, rowind, colptr); /* Allocate storage */
a = *nzval;
asub = *rowind;
xa = *colptr;
for (i = 0; i < 4; ++i) iseed[i] = abs( iseed[i] ) % 4096;
if ( iseed[3] % 2 != 1 ) ++iseed[3];
for (b = 0; b < nb; ++b) {
cstart = b * bs; /* start of the col # of the current block */
rstart = b * bs; /* start of the row # of the current block */
for (j = cstart; j < cstart + bs; ++j) {
xa[j] = lasta;
val = &a[lasta];
row = &asub[lasta];
for (i = 0; i < bs; ++i) {
val[i] = dlaran_(iseed);
row[i] = i + rstart;
}
lasta += bs;
} /* for j ... */
} /* for b ... */
xa[n] = lasta;
}
/* Double Complex */ VOID zlatm2_(doublecomplex * ret_val, integer *m,
integer *n, integer *i, integer *j, integer *kl, integer *ku, integer
*idist, integer *iseed, doublecomplex *d, integer *igrade,
doublecomplex *dl, doublecomplex *dr, integer *ipvtng, integer *iwork,
doublereal *sparse)
{
/* System generated locals */
integer i__1, i__2;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
void z_div(doublecomplex *, doublecomplex *, doublecomplex *), d_cnjg(
doublecomplex *, doublecomplex *);
/* Local variables */
static integer isub, jsub;
static doublecomplex ctemp;
extern doublereal dlaran_(integer *);
extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *,
integer *);
/* -- LAPACK auxiliary test routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
ZLATM2 returns the (I,J) entry of a random matrix of dimension
(M, N) described by the other paramters. It is called by the
ZLATMR routine in order to build random test matrices. No error
checking on parameters is done, because this routine is called in
a tight loop by ZLATMR which has already checked the parameters.
Use of ZLATM2 differs from CLATM3 in the order in which the random
number generator is called to fill in random matrix entries.
With ZLATM2, the generator is called to fill in the pivoted matrix
columnwise. With ZLATM3, the generator is called to fill in the
matrix columnwise, after which it is pivoted. Thus, ZLATM3 can
be used to construct random matrices which differ only in their
order of rows and/or columns. ZLATM2 is used to construct band
matrices while avoiding calling the random number generator for
entries outside the band (and therefore generating random numbers
The matrix whose (I,J) entry is returned is constructed as
follows (this routine only computes one entry):
If I is outside (1..M) or J is outside (1..N), return zero
(this is convenient for generating matrices in band format).
Generate a matrix A with random entries of distribution IDIST.
Set the diagonal to D.
Grade the matrix, if desired, from the left (by DL) and/or
from the right (by DR or DL) as specified by IGRADE.
Permute, if desired, the rows and/or columns as specified by
IPVTNG and IWORK.
Band the matrix to have lower bandwidth KL and upper
bandwidth KU.
Set random entries to zero as specified by SPARSE.
Arguments
=========
M - INTEGER
Number of rows of matrix. Not modified.
N - INTEGER
Number of columns of matrix. Not modified.
I - INTEGER
Row of entry to be returned. Not modified.
J - INTEGER
Column of entry to be returned. Not modified.
KL - INTEGER
Lower bandwidth. Not modified.
KU - INTEGER
Upper bandwidth. Not modified.
IDIST - INTEGER
On entry, IDIST specifies the type of distribution to be
used to generate a random matrix .
1 => real and imaginary parts each UNIFORM( 0, 1 )
2 => real and imaginary parts each UNIFORM( -1, 1 )
3 => real and imaginary parts each NORMAL( 0, 1 )
4 => complex number uniform in DISK( 0 , 1 )
Not modified.
ISEED - INTEGER array of dimension ( 4 )
Seed for random number generator.
Changed on exit.
D - COMPLEX*16 array of dimension ( MIN( I , J ) )
Diagonal entries of matrix. Not modified.
IGRADE - INTEGER
Specifies grading of matrix as follows:
0 => no grading
1 => matrix premultiplied by diag( DL )
2 => matrix postmultiplied by diag( DR )
3 => matrix premultiplied by diag( DL ) and
postmultiplied by diag( DR )
4 => matrix premultiplied by diag( DL ) and
postmultiplied by inv( diag( DL ) )
5 => matrix premultiplied by diag( DL ) and
postmultiplied by diag( CONJG(DL) )
6 => matrix premultiplied by diag( DL ) and
postmultiplied by diag( DL )
Not modified.
DL - COMPLEX*16 array ( I or J, as appropriate )
Left scale factors for grading matrix. Not modified.
DR - COMPLEX*16 array ( I or J, as appropriate )
Right scale factors for grading matrix. Not modified.
IPVTNG - INTEGER
On entry specifies pivoting permutations as follows:
0 => none.
1 => row pivoting.
2 => column pivoting.
3 => full pivoting, i.e., on both sides.
Not modified.
IWORK - INTEGER array ( I or J, as appropriate )
This array specifies the permutation used. The
row (or column) in position K was originally in
position IWORK( K ).
This differs from IWORK for ZLATM3. Not modified.
SPARSE - DOUBLE PRECISION between 0. and 1.
On entry specifies the sparsity of the matrix
if sparse matix is to be generated.
SPARSE should lie between 0 and 1.
A uniform ( 0, 1 ) random number x is generated and
compared to SPARSE; if x is larger the matrix entry
is unchanged and if x is smaller the entry is set
to zero. Thus on the average a fraction SPARSE of the
entries will be set to zero.
Not modified.
=====================================================================
-----------------------------------------------------------------------
Check for I and J in range
Parameter adjustments */
--iwork;
--dr;
--dl;
--d;
--iseed;
/* Function Body */
if (*i < 1 || *i > *m || *j < 1 || *j > *n) {
ret_val->r = 0., ret_val->i = 0.;
return ;
}
/* Check for banding */
if (*j > *i + *ku || *j < *i - *kl) {
ret_val->r = 0., ret_val->i = 0.;
return ;
}
/* Check for sparsity */
if (*sparse > 0.) {
if (dlaran_(&iseed[1]) < *sparse) {
ret_val->r = 0., ret_val->i = 0.;
return ;
}
}
/* Compute subscripts depending on IPVTNG */
if (*ipvtng == 0) {
isub = *i;
jsub = *j;
} else if (*ipvtng == 1) {
isub = iwork[*i];
jsub = *j;
} else if (*ipvtng == 2) {
isub = *i;
jsub = iwork[*j];
} else if (*ipvtng == 3) {
isub = iwork[*i];
jsub = iwork[*j];
}
/* Compute entry and grade it according to IGRADE */
if (isub == jsub) {
i__1 = isub;
ctemp.r = d[i__1].r, ctemp.i = d[i__1].i;
} else {
zlarnd_(&z__1, idist, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
}
if (*igrade == 1) {
i__1 = isub;
z__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__1.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 2) {
i__1 = jsub;
z__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, z__1.i =
ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 3) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
i__2 = jsub;
z__1.r = z__2.r * dr[i__2].r - z__2.i * dr[i__2].i, z__1.i = z__2.r *
dr[i__2].i + z__2.i * dr[i__2].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 4 && isub != jsub) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
z_div(&z__1, &z__2, &dl[jsub]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 5) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
d_cnjg(&z__3, &dl[jsub]);
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i
+ z__2.i * z__3.r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 6) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
i__2 = jsub;
z__1.r = z__2.r * dl[i__2].r - z__2.i * dl[i__2].i, z__1.i = z__2.r *
dl[i__2].i + z__2.i * dl[i__2].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
}
ret_val->r = ctemp.r, ret_val->i = ctemp.i;
return ;
/* End of ZLATM2 */
} /* zlatm2_ */
/* Subroutine */ int dlatm7_(integer *mode, doublereal *cond, integer *irsign,
integer *idist, integer *iseed, doublereal *d__, integer *n, integer
*rank, integer *info)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Local variables */
integer i__;
doublereal temp, alpha;
extern doublereal dlaran_(integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Craig Lucas, University of Manchester / NAG Ltd. */
/* October, 2008 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLATM7 computes the entries of D as specified by MODE */
/* COND and IRSIGN. IDIST and ISEED determine the generation */
/* of random numbers. DLATM7 is called by DLATMT to generate */
/* random test matrices. */
/* Arguments */
/* ========= */
/* MODE - INTEGER */
/* On entry describes how D is to be computed: */
/* MODE = 0 means do not change D. */
/* MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND */
/* MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND */
/* MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) I=1:RANK */
/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
/* MODE = 5 sets D to random numbers in the range */
/* ( 1/COND , 1 ) such that their logarithms */
/* are uniformly distributed. */
/* MODE = 6 set D to random numbers from same distribution */
/* as the rest of the matrix. */
/* MODE < 0 has the same meaning as ABS(MODE), except that */
/* the order of the elements of D is reversed. */
/* Thus if MODE is positive, D has entries ranging from */
/* 1 to 1/COND, if negative, from 1/COND to 1, */
/* Not modified. */
/* COND - DOUBLE PRECISION */
/* On entry, used as described under MODE above. */
/* If used, it must be >= 1. Not modified. */
/* IRSIGN - INTEGER */
/* On entry, if MODE neither -6, 0 nor 6, determines sign of */
/* entries of D */
/* 0 => leave entries of D unchanged */
/* 1 => multiply each entry of D by 1 or -1 with probability .5 */
/* IDIST - CHARACTER*1 */
/* On entry, IDIST specifies the type of distribution to be */
/* used to generate a random matrix . */
/* 1 => UNIFORM( 0, 1 ) */
/* 2 => UNIFORM( -1, 1 ) */
/* 3 => NORMAL( 0, 1 ) */
/* Not modified. */
/* ISEED - INTEGER array, dimension ( 4 ) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The random number generator uses a */
/* linear congruential sequence limited to small */
/* integers, and so should produce machine independent */
/* random numbers. The values of ISEED are changed on */
/* exit, and can be used in the next call to DLATM7 */
/* to continue the same random number sequence. */
/* Changed on exit. */
/* D - DOUBLE PRECISION array, dimension ( MIN( M , N ) ) */
/* Array to be computed according to MODE, COND and IRSIGN. */
/* May be changed on exit if MODE is nonzero. */
/* N - INTEGER */
/* Number of entries of D. Not modified. */
/* RANK - INTEGER */
/* The rank of matrix to be generated for modes 1,2,3 only. */
/* D( RANK+1:N ) = 0. */
/* Not modified. */
/* INFO - INTEGER */
/* 0 => normal termination */
/* -1 => if MODE not in range -6 to 6 */
/* -2 => if MODE neither -6, 0 nor 6, and */
/* IRSIGN neither 0 nor 1 */
/* -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */
/* -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 3 */
/* -7 => if N negative */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and Test the input parameters. Initialize flags & seed. */
/* Parameter adjustments */
--d__;
--iseed;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Set INFO if an error */
if (*mode < -6 || *mode > 6) {
*info = -1;
} else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
irsign != 1)) {
*info = -2;
} else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) {
*info = -3;
} else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 3)) {
*info = -4;
} else if (*n < 0) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLATM7", &i__1);
return 0;
}
/* Compute D according to COND and MODE */
if (*mode != 0) {
switch (abs(*mode)) {
case 1: goto L100;
case 2: goto L130;
case 3: goto L160;
case 4: goto L190;
case 5: goto L210;
case 6: goto L230;
}
/* One large D value: */
L100:
i__1 = *rank;
for (i__ = 2; i__ <= i__1; ++i__) {
d__[i__] = 1. / *cond;
/* L110: */
}
i__1 = *n;
for (i__ = *rank + 1; i__ <= i__1; ++i__) {
d__[i__] = 0.;
/* L120: */
}
d__[1] = 1.;
goto L240;
/* One small D value: */
L130:
i__1 = *rank - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = 1.;
/* L140: */
}
i__1 = *n;
for (i__ = *rank + 1; i__ <= i__1; ++i__) {
d__[i__] = 0.;
/* L150: */
}
d__[*rank] = 1. / *cond;
goto L240;
/* Exponentially distributed D values: */
L160:
d__[1] = 1.;
if (*n > 1) {
d__1 = -1. / (doublereal) (*rank - 1);
alpha = pow_dd(cond, &d__1);
i__1 = *rank;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = i__ - 1;
d__[i__] = pow_di(&alpha, &i__2);
/* L170: */
}
i__1 = *n;
for (i__ = *rank + 1; i__ <= i__1; ++i__) {
d__[i__] = 0.;
/* L180: */
}
}
goto L240;
/* Arithmetically distributed D values: */
L190:
d__[1] = 1.;
if (*n > 1) {
temp = 1. / *cond;
alpha = (1. - temp) / (doublereal) (*n - 1);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
d__[i__] = (doublereal) (*n - i__) * alpha + temp;
/* L200: */
}
}
goto L240;
/* Randomly distributed D values on ( 1/COND , 1): */
L210:
alpha = log(1. / *cond);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
d__[i__] = exp(alpha * dlaran_(&iseed[1]));
/* L220: */
}
goto L240;
/* Randomly distributed D values from IDIST */
L230:
dlarnv_(idist, &iseed[1], n, &d__[1]);
L240:
/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
/* random signs to D */
if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = dlaran_(&iseed[1]);
if (temp > .5) {
d__[i__] = -d__[i__];
}
/* L250: */
}
}
/* Reverse if MODE < 0 */
if (*mode < 0) {
i__1 = *n / 2;
for (i__ = 1; i__ <= i__1; ++i__) {
temp = d__[i__];
d__[i__] = d__[*n + 1 - i__];
d__[*n + 1 - i__] = temp;
/* L260: */
}
}
}
return 0;
/* End of DLATM7 */
} /* dlatm7_ */
/* Subroutine */ int zlatm4_(integer *itype, integer *n, integer *nz1,
integer *nz2, logical *rsign, doublereal *amagn, doublereal *rcond,
doublereal *triang, integer *idist, integer *iseed, doublecomplex *a,
integer *lda)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1, z__2;
/* Local variables */
integer i__, k, jc, jd, jr, kbeg, isdb, kend, isde, klen;
doublereal alpha;
doublecomplex ctemp;
extern doublereal dlaran_(integer *);
extern /* Double Complex */ void zlarnd_(doublecomplex *, integer *,
integer *);
extern /* Subroutine */ int zlaset_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *);
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATM4 generates basic square matrices, which may later be */
/* multiplied by others in order to produce test matrices. It is */
/* intended mainly to be used to test the generalized eigenvalue */
/* routines. */
/* It first generates the diagonal and (possibly) subdiagonal, */
/* according to the value of ITYPE, NZ1, NZ2, RSIGN, AMAGN, and RCOND. */
/* It then fills in the upper triangle with random numbers, if TRIANG is */
/* non-zero. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* The "type" of matrix on the diagonal and sub-diagonal. */
/* If ITYPE < 0, then type abs(ITYPE) is generated and then */
/* swapped end for end (A(I,J) := A'(N-J,N-I).) See also */
/* the description of AMAGN and RSIGN. */
/* Special types: */
/* = 0: the zero matrix. */
/* = 1: the identity. */
/* = 2: a transposed Jordan block. */
/* = 3: If N is odd, then a k+1 x k+1 transposed Jordan block */
/* followed by a k x k identity block, where k=(N-1)/2. */
/* If N is even, then k=(N-2)/2, and a zero diagonal entry */
/* is tacked onto the end. */
/* Diagonal types. The diagonal consists of NZ1 zeros, then */
/* k=N-NZ1-NZ2 nonzeros. The subdiagonal is zero. ITYPE */
/* specifies the nonzero diagonal entries as follows: */
/* = 4: 1, ..., k */
/* = 5: 1, RCOND, ..., RCOND */
/* = 6: 1, ..., 1, RCOND */
/* = 7: 1, a, a^2, ..., a^(k-1)=RCOND */
/* = 8: 1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND */
/* = 9: random numbers chosen from (RCOND,1) */
/* = 10: random numbers with distribution IDIST (see ZLARND.) */
/* N (input) INTEGER */
/* The order of the matrix. */
/* NZ1 (input) INTEGER */
/* If abs(ITYPE) > 3, then the first NZ1 diagonal entries will */
/* be zero. */
/* NZ2 (input) INTEGER */
/* If abs(ITYPE) > 3, then the last NZ2 diagonal entries will */
/* be zero. */
/* RSIGN (input) LOGICAL */
/* = .TRUE.: The diagonal and subdiagonal entries will be */
/* multiplied by random numbers of magnitude 1. */
/* = .FALSE.: The diagonal and subdiagonal entries will be */
/* left as they are (usually non-negative real.) */
/* AMAGN (input) DOUBLE PRECISION */
/* The diagonal and subdiagonal entries will be multiplied by */
/* AMAGN. */
/* RCOND (input) DOUBLE PRECISION */
/* If abs(ITYPE) > 4, then the smallest diagonal entry will be */
/* RCOND. RCOND must be between 0 and 1. */
/* TRIANG (input) DOUBLE PRECISION */
/* The entries above the diagonal will be random numbers with */
/* magnitude bounded by TRIANG (i.e., random numbers multiplied */
/* by TRIANG.) */
/* IDIST (input) INTEGER */
/* On entry, DIST specifies the type of distribution to be used */
/* to generate a random matrix . */
/* = 1: real and imaginary parts each UNIFORM( 0, 1 ) */
/* = 2: real and imaginary parts each UNIFORM( -1, 1 ) */
/* = 3: real and imaginary parts each NORMAL( 0, 1 ) */
/* = 4: complex number uniform in DISK( 0, 1 ) */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The values of ISEED are changed on exit, and can */
/* be used in the next call to ZLATM4 to continue the same */
/* random number sequence. */
/* Note: ISEED(4) should be odd, for the random number generator */
/* used at present. */
/* A (output) COMPLEX*16 array, dimension (LDA, N) */
/* Array to be computed. */
/* LDA (input) INTEGER */
/* Leading dimension of A. Must be at least 1 and at least N. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
if (*n <= 0) {
return 0;
}
zlaset_("Full", n, n, &c_b1, &c_b1, &a[a_offset], lda);
/* Insure a correct ISEED */
if (iseed[4] % 2 != 1) {
++iseed[4];
}
/* Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2, */
/* and RCOND */
if (*itype != 0) {
if (abs(*itype) >= 4) {
/* Computing MAX */
/* Computing MIN */
i__3 = *n, i__4 = *nz1 + 1;
i__1 = 1, i__2 = min(i__3,i__4);
kbeg = max(i__1,i__2);
/* Computing MAX */
/* Computing MIN */
i__3 = *n, i__4 = *n - *nz2;
i__1 = kbeg, i__2 = min(i__3,i__4);
kend = max(i__1,i__2);
klen = kend + 1 - kbeg;
} else {
kbeg = 1;
kend = *n;
klen = *n;
}
isdb = 1;
isde = 0;
switch (abs(*itype)) {
case 1: goto L10;
case 2: goto L30;
case 3: goto L50;
case 4: goto L80;
case 5: goto L100;
case 6: goto L120;
case 7: goto L140;
case 8: goto L160;
case 9: goto L180;
case 10: goto L200;
}
/* abs(ITYPE) = 1: Identity */
L10:
i__1 = *n;
for (jd = 1; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* L20: */
}
goto L220;
/* abs(ITYPE) = 2: Transposed Jordan block */
L30:
i__1 = *n - 1;
for (jd = 1; jd <= i__1; ++jd) {
i__2 = jd + 1 + jd * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* L40: */
}
isdb = 1;
isde = *n - 1;
goto L220;
/* abs(ITYPE) = 3: Transposed Jordan block, followed by the */
/* identity. */
L50:
k = (*n - 1) / 2;
i__1 = k;
for (jd = 1; jd <= i__1; ++jd) {
i__2 = jd + 1 + jd * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* L60: */
}
isdb = 1;
isde = k;
i__1 = (k << 1) + 1;
for (jd = k + 2; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* L70: */
}
goto L220;
/* abs(ITYPE) = 4: 1,...,k */
L80:
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
i__3 = jd - *nz1;
z__1.r = (doublereal) i__3, z__1.i = 0.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L90: */
}
goto L220;
/* abs(ITYPE) = 5: One large D value: */
L100:
i__1 = kend;
for (jd = kbeg + 1; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
z__1.r = *rcond, z__1.i = 0.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L110: */
}
i__1 = kbeg + kbeg * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
goto L220;
/* abs(ITYPE) = 6: One small D value: */
L120:
i__1 = kend - 1;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
a[i__2].r = 1., a[i__2].i = 0.;
/* L130: */
}
i__1 = kend + kend * a_dim1;
z__1.r = *rcond, z__1.i = 0.;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
goto L220;
/* abs(ITYPE) = 7: Exponentially distributed D values: */
L140:
i__1 = kbeg + kbeg * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
if (klen > 1) {
d__1 = 1. / (doublereal) (klen - 1);
alpha = pow_dd(rcond, &d__1);
i__1 = klen;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = *nz1 + i__ + (*nz1 + i__) * a_dim1;
d__2 = (doublereal) (i__ - 1);
d__1 = pow_dd(&alpha, &d__2);
z__1.r = d__1, z__1.i = 0.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L150: */
}
}
goto L220;
/* abs(ITYPE) = 8: Arithmetically distributed D values: */
L160:
i__1 = kbeg + kbeg * a_dim1;
a[i__1].r = 1., a[i__1].i = 0.;
if (klen > 1) {
alpha = (1. - *rcond) / (doublereal) (klen - 1);
i__1 = klen;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = *nz1 + i__ + (*nz1 + i__) * a_dim1;
d__1 = (doublereal) (klen - i__) * alpha + *rcond;
z__1.r = d__1, z__1.i = 0.;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L170: */
}
}
goto L220;
/* abs(ITYPE) = 9: Randomly distributed D values on ( RCOND, 1): */
L180:
alpha = log(*rcond);
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
d__1 = exp(alpha * dlaran_(&iseed[1]));
a[i__2].r = d__1, a[i__2].i = 0.;
/* L190: */
}
goto L220;
/* abs(ITYPE) = 10: Randomly distributed D values from DIST */
L200:
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
zlarnd_(&z__1, idist, &iseed[1]);
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
/* L210: */
}
L220:
/* Scale by AMAGN */
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
i__3 = jd + jd * a_dim1;
d__1 = *amagn * a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
/* L230: */
}
i__1 = isde;
for (jd = isdb; jd <= i__1; ++jd) {
i__2 = jd + 1 + jd * a_dim1;
i__3 = jd + 1 + jd * a_dim1;
d__1 = *amagn * a[i__3].r;
a[i__2].r = d__1, a[i__2].i = 0.;
/* L240: */
}
/* If RSIGN = .TRUE., assign random signs to diagonal and */
/* subdiagonal */
if (*rsign) {
i__1 = kend;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
if (a[i__2].r != 0.) {
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__2 = jd + jd * a_dim1;
i__3 = jd + jd * a_dim1;
d__1 = a[i__3].r;
z__1.r = d__1 * ctemp.r, z__1.i = d__1 * ctemp.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
/* L250: */
}
i__1 = isde;
for (jd = isdb; jd <= i__1; ++jd) {
i__2 = jd + 1 + jd * a_dim1;
if (a[i__2].r != 0.) {
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
d__1 = z_abs(&ctemp);
z__1.r = ctemp.r / d__1, z__1.i = ctemp.i / d__1;
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__2 = jd + 1 + jd * a_dim1;
i__3 = jd + 1 + jd * a_dim1;
d__1 = a[i__3].r;
z__1.r = d__1 * ctemp.r, z__1.i = d__1 * ctemp.i;
a[i__2].r = z__1.r, a[i__2].i = z__1.i;
}
/* L260: */
}
}
/* Reverse if ITYPE < 0 */
if (*itype < 0) {
i__1 = (kbeg + kend - 1) / 2;
for (jd = kbeg; jd <= i__1; ++jd) {
i__2 = jd + jd * a_dim1;
ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
i__2 = jd + jd * a_dim1;
i__3 = kbeg + kend - jd + (kbeg + kend - jd) * a_dim1;
a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
i__2 = kbeg + kend - jd + (kbeg + kend - jd) * a_dim1;
a[i__2].r = ctemp.r, a[i__2].i = ctemp.i;
/* L270: */
}
i__1 = (*n - 1) / 2;
for (jd = 1; jd <= i__1; ++jd) {
i__2 = jd + 1 + jd * a_dim1;
ctemp.r = a[i__2].r, ctemp.i = a[i__2].i;
i__2 = jd + 1 + jd * a_dim1;
i__3 = *n + 1 - jd + (*n - jd) * a_dim1;
a[i__2].r = a[i__3].r, a[i__2].i = a[i__3].i;
i__2 = *n + 1 - jd + (*n - jd) * a_dim1;
a[i__2].r = ctemp.r, a[i__2].i = ctemp.i;
/* L280: */
}
}
}
/* Fill in upper triangle */
if (*triang != 0.) {
i__1 = *n;
for (jc = 2; jc <= i__1; ++jc) {
i__2 = jc - 1;
for (jr = 1; jr <= i__2; ++jr) {
i__3 = jr + jc * a_dim1;
zlarnd_(&z__2, idist, &iseed[1]);
z__1.r = *triang * z__2.r, z__1.i = *triang * z__2.i;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/* L290: */
}
/* L300: */
}
}
return 0;
/* End of ZLATM4 */
} /* zlatm4_ */
/* Subroutine */ int dlatme_(integer *n, char *dist, integer *iseed,
doublereal *d__, integer *mode, doublereal *cond, doublereal *dmax__,
char *ei, char *rsign, char *upper, char *sim, doublereal *ds,
integer *modes, doublereal *conds, integer *kl, integer *ku,
doublereal *anorm, doublereal *a, integer *lda, doublereal *work,
integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
doublereal d__1, d__2, d__3;
/* Local variables */
integer i__, j, ic, jc, ir, jr, jcr;
doublereal tau;
logical bads;
extern /* Subroutine */ int dger_(integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *);
integer isim;
doublereal temp;
logical badei;
doublereal alpha;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
integer iinfo;
doublereal tempa[1];
integer icols;
logical useei;
integer idist;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
integer irows;
extern /* Subroutine */ int dlatm1_(integer *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *, integer *);
extern doublereal dlange_(char *, integer *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dlarge_(integer *, doublereal *, integer *,
integer *, doublereal *, integer *), dlarfg_(integer *,
doublereal *, doublereal *, integer *, doublereal *);
extern doublereal dlaran_(integer *);
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), dlarnv_(integer *, integer *,
integer *, doublereal *);
integer irsign, iupper;
doublereal xnorms;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLATME generates random non-symmetric square matrices with */
/* specified eigenvalues for testing LAPACK programs. */
/* DLATME operates by applying the following sequence of */
/* operations: */
/* 1. Set the diagonal to D, where D may be input or */
/* computed according to MODE, COND, DMAX, and RSIGN */
/* as described below. */
/* 2. If complex conjugate pairs are desired (MODE=0 and EI(1)='R', */
/* or MODE=5), certain pairs of adjacent elements of D are */
/* interpreted as the real and complex parts of a complex */
/* conjugate pair; A thus becomes block diagonal, with 1x1 */
/* and 2x2 blocks. */
/* 3. If UPPER='T', the upper triangle of A is set to random values */
/* out of distribution DIST. */
/* 4. If SIM='T', A is multiplied on the left by a random matrix */
/* X, whose singular values are specified by DS, MODES, and */
/* CONDS, and on the right by X inverse. */
/* 5. If KL < N-1, the lower bandwidth is reduced to KL using */
/* Householder transformations. If KU < N-1, the upper */
/* bandwidth is reduced to KU. */
/* 6. If ANORM is not negative, the matrix is scaled to have */
/* maximum-element-norm ANORM. */
/* (Note: since the matrix cannot be reduced beyond Hessenberg form, */
/* no packing options are available.) */
/* Arguments */
/* ========= */
/* N - INTEGER */
/* The number of columns (or rows) of A. Not modified. */
/* DIST - CHARACTER*1 */
/* On entry, DIST specifies the type of distribution to be used */
/* to generate the random eigen-/singular values, and for the */
/* upper triangle (see UPPER). */
/* 'U' => UNIFORM( 0, 1 ) ( 'U' for uniform ) */
/* 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) */
/* 'N' => NORMAL( 0, 1 ) ( 'N' for normal ) */
/* Not modified. */
/* ISEED - INTEGER array, dimension ( 4 ) */
/* On entry ISEED specifies the seed of the random number */
/* generator. They should lie between 0 and 4095 inclusive, */
/* and ISEED(4) should be odd. The random number generator */
/* uses a linear congruential sequence limited to small */
/* integers, and so should produce machine independent */
/* random numbers. The values of ISEED are changed on */
/* exit, and can be used in the next call to DLATME */
/* to continue the same random number sequence. */
/* Changed on exit. */
/* D - DOUBLE PRECISION array, dimension ( N ) */
/* This array is used to specify the eigenvalues of A. If */
/* MODE=0, then D is assumed to contain the eigenvalues (but */
/* see the description of EI), otherwise they will be */
/* computed according to MODE, COND, DMAX, and RSIGN and */
/* placed in D. */
/* Modified if MODE is nonzero. */
/* MODE - INTEGER */
/* On entry this describes how the eigenvalues are to */
/* be specified: */
/* MODE = 0 means use D (with EI) as input */
/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
/* MODE = 5 sets D to random numbers in the range */
/* ( 1/COND , 1 ) such that their logarithms */
/* are uniformly distributed. Each odd-even pair */
/* of elements will be either used as two real */
/* eigenvalues or as the real and imaginary part */
/* of a complex conjugate pair of eigenvalues; */
/* the choice of which is done is random, with */
/* 50-50 probability, for each pair. */
/* MODE = 6 set D to random numbers from same distribution */
/* as the rest of the matrix. */
/* MODE < 0 has the same meaning as ABS(MODE), except that */
/* the order of the elements of D is reversed. */
/* Thus if MODE is between 1 and 4, D has entries ranging */
/* from 1 to 1/COND, if between -1 and -4, D has entries */
/* ranging from 1/COND to 1, */
/* Not modified. */
/* COND - DOUBLE PRECISION */
/* On entry, this is used as described under MODE above. */
/* If used, it must be >= 1. Not modified. */
/* DMAX - DOUBLE PRECISION */
/* If MODE is neither -6, 0 nor 6, the contents of D, as */
/* computed according to MODE and COND, will be scaled by */
/* DMAX / max(abs(D(i))). Note that DMAX need not be */
/* positive: if DMAX is negative (or zero), D will be */
/* scaled by a negative number (or zero). */
/* Not modified. */
/* EI - CHARACTER*1 array, dimension ( N ) */
/* If MODE is 0, and EI(1) is not ' ' (space character), */
/* this array specifies which elements of D (on input) are */
/* real eigenvalues and which are the real and imaginary parts */
/* of a complex conjugate pair of eigenvalues. The elements */
/* of EI may then only have the values 'R' and 'I'. If */
/* EI(j)='R' and EI(j+1)='I', then the j-th eigenvalue is */
/* CMPLX( D(j) , D(j+1) ), and the (j+1)-th is the complex */
/* conjugate thereof. If EI(j)=EI(j+1)='R', then the j-th */
/* eigenvalue is D(j) (i.e., real). EI(1) may not be 'I', */
/* nor may two adjacent elements of EI both have the value 'I'. */
/* If MODE is not 0, then EI is ignored. If MODE is 0 and */
/* EI(1)=' ', then the eigenvalues will all be real. */
/* Not modified. */
/* RSIGN - CHARACTER*1 */
/* If MODE is not 0, 6, or -6, and RSIGN='T', then the */
/* elements of D, as computed according to MODE and COND, will */
/* be multiplied by a random sign (+1 or -1). If RSIGN='F', */
/* they will not be. RSIGN may only have the values 'T' or */
/* 'F'. */
/* Not modified. */
/* UPPER - CHARACTER*1 */
/* If UPPER='T', then the elements of A above the diagonal */
/* (and above the 2x2 diagonal blocks, if A has complex */
/* eigenvalues) will be set to random numbers out of DIST. */
/* If UPPER='F', they will not. UPPER may only have the */
/* values 'T' or 'F'. */
/* Not modified. */
/* SIM - CHARACTER*1 */
/* If SIM='T', then A will be operated on by a "similarity */
/* transform", i.e., multiplied on the left by a matrix X and */
/* on the right by X inverse. X = U S V, where U and V are */
/* random unitary matrices and S is a (diagonal) matrix of */
/* singular values specified by DS, MODES, and CONDS. If */
/* SIM='F', then A will not be transformed. */
/* Not modified. */
/* DS - DOUBLE PRECISION array, dimension ( N ) */
/* This array is used to specify the singular values of X, */
/* in the same way that D specifies the eigenvalues of A. */
/* If MODE=0, the DS contains the singular values, which */
/* may not be zero. */
/* Modified if MODE is nonzero. */
/* MODES - INTEGER */
/* CONDS - DOUBLE PRECISION */
/* Same as MODE and COND, but for specifying the diagonal */
/* of S. MODES=-6 and +6 are not allowed (since they would */
/* result in randomly ill-conditioned eigenvalues.) */
/* KL - INTEGER */
/* This specifies the lower bandwidth of the matrix. KL=1 */
/* specifies upper Hessenberg form. If KL is at least N-1, */
/* then A will have full lower bandwidth. KL must be at */
/* least 1. */
/* Not modified. */
/* KU - INTEGER */
/* This specifies the upper bandwidth of the matrix. KU=1 */
/* specifies lower Hessenberg form. If KU is at least N-1, */
/* then A will have full upper bandwidth; if KU and KL */
/* are both at least N-1, then A will be dense. Only one of */
/* KU and KL may be less than N-1. KU must be at least 1. */
/* Not modified. */
/* ANORM - DOUBLE PRECISION */
/* If ANORM is not negative, then A will be scaled by a non- */
/* negative real number to make the maximum-element-norm of A */
/* to be ANORM. */
/* Not modified. */
/* A - DOUBLE PRECISION array, dimension ( LDA, N ) */
/* On exit A is the desired test matrix. */
/* Modified. */
/* LDA - INTEGER */
/* LDA specifies the first dimension of A as declared in the */
/* calling program. LDA must be at least N. */
/* Not modified. */
/* WORK - DOUBLE PRECISION array, dimension ( 3*N ) */
/* Workspace. */
/* Modified. */
/* INFO - INTEGER */
/* Error code. On exit, INFO will be set to one of the */
/* following values: */
/* 0 => normal return */
/* -1 => N negative */
/* -2 => DIST illegal string */
/* -5 => MODE not in range -6 to 6 */
/* -6 => COND less than 1.0, and MODE neither -6, 0 nor 6 */
/* -8 => EI(1) is not ' ' or 'R', EI(j) is not 'R' or 'I', or */
/* two adjacent elements of EI are 'I'. */
/* -9 => RSIGN is not 'T' or 'F' */
/* -10 => UPPER is not 'T' or 'F' */
/* -11 => SIM is not 'T' or 'F' */
/* -12 => MODES=0 and DS has a zero singular value. */
/* -13 => MODES is not in the range -5 to 5. */
/* -14 => MODES is nonzero and CONDS is less than 1. */
/* -15 => KL is less than 1. */
/* -16 => KU is less than 1, or KL and KU are both less than */
/* N-1. */
/* -19 => LDA is less than N. */
/* 1 => Error return from DLATM1 (computing D) */
/* 2 => Cannot scale to DMAX (max. eigenvalue is 0) */
/* 3 => Error return from DLATM1 (computing DS) */
/* 4 => Error return from DLARGE */
/* 5 => Zero singular value from DLATM1. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* 1) Decode and Test the input parameters. */
/* Initialize flags & seed. */
/* Parameter adjustments */
--iseed;
--d__;
--ei;
--ds;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--work;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Decode DIST */
if (lsame_(dist, "U")) {
idist = 1;
} else if (lsame_(dist, "S")) {
idist = 2;
} else if (lsame_(dist, "N")) {
idist = 3;
} else {
idist = -1;
}
/* Check EI */
useei = TRUE_;
badei = FALSE_;
if (lsame_(ei + 1, " ") || *mode != 0) {
useei = FALSE_;
} else {
if (lsame_(ei + 1, "R")) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
if (lsame_(ei + j, "I")) {
if (lsame_(ei + (j - 1), "I")) {
badei = TRUE_;
}
} else {
if (! lsame_(ei + j, "R")) {
badei = TRUE_;
}
}
/* L10: */
}
} else {
badei = TRUE_;
}
}
/* Decode RSIGN */
if (lsame_(rsign, "T")) {
irsign = 1;
} else if (lsame_(rsign, "F")) {
irsign = 0;
} else {
irsign = -1;
}
/* Decode UPPER */
if (lsame_(upper, "T")) {
iupper = 1;
} else if (lsame_(upper, "F")) {
iupper = 0;
} else {
iupper = -1;
}
/* Decode SIM */
if (lsame_(sim, "T")) {
isim = 1;
} else if (lsame_(sim, "F")) {
isim = 0;
} else {
isim = -1;
}
/* Check DS, if MODES=0 and ISIM=1 */
bads = FALSE_;
if (*modes == 0 && isim == 1) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
if (ds[j] == 0.) {
bads = TRUE_;
}
/* L20: */
}
}
/* Set INFO if an error */
if (*n < 0) {
*info = -1;
} else if (idist == -1) {
*info = -2;
} else if (abs(*mode) > 6) {
*info = -5;
} else if (*mode != 0 && abs(*mode) != 6 && *cond < 1.) {
*info = -6;
} else if (badei) {
*info = -8;
} else if (irsign == -1) {
*info = -9;
} else if (iupper == -1) {
*info = -10;
} else if (isim == -1) {
*info = -11;
} else if (bads) {
*info = -12;
} else if (isim == 1 && abs(*modes) > 5) {
*info = -13;
} else if (isim == 1 && *modes != 0 && *conds < 1.) {
*info = -14;
} else if (*kl < 1) {
*info = -15;
} else if (*ku < 1 || *ku < *n - 1 && *kl < *n - 1) {
*info = -16;
} else if (*lda < max(1,*n)) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLATME", &i__1);
return 0;
}
/* Initialize random number generator */
for (i__ = 1; i__ <= 4; ++i__) {
iseed[i__] = (i__1 = iseed[i__], abs(i__1)) % 4096;
/* L30: */
}
if (iseed[4] % 2 != 1) {
++iseed[4];
}
/* 2) Set up diagonal of A */
/* Compute D according to COND and MODE */
dlatm1_(mode, cond, &irsign, &idist, &iseed[1], &d__[1], n, &iinfo);
if (iinfo != 0) {
*info = 1;
return 0;
}
if (*mode != 0 && abs(*mode) != 6) {
/* Scale by DMAX */
temp = abs(d__[1]);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
/* Computing MAX */
d__2 = temp, d__3 = (d__1 = d__[i__], abs(d__1));
temp = max(d__2,d__3);
/* L40: */
}
if (temp > 0.) {
alpha = *dmax__ / temp;
} else if (*dmax__ != 0.) {
*info = 2;
return 0;
} else {
alpha = 0.;
}
dscal_(n, &alpha, &d__[1], &c__1);
}
dlaset_("Full", n, n, &c_b23, &c_b23, &a[a_offset], lda);
i__1 = *lda + 1;
dcopy_(n, &d__[1], &c__1, &a[a_offset], &i__1);
/* Set up complex conjugate pairs */
if (*mode == 0) {
if (useei) {
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
if (lsame_(ei + j, "I")) {
a[j - 1 + j * a_dim1] = a[j + j * a_dim1];
a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1];
a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1];
}
/* L50: */
}
}
} else if (abs(*mode) == 5) {
i__1 = *n;
for (j = 2; j <= i__1; j += 2) {
if (dlaran_(&iseed[1]) > .5) {
a[j - 1 + j * a_dim1] = a[j + j * a_dim1];
a[j + (j - 1) * a_dim1] = -a[j + j * a_dim1];
a[j + j * a_dim1] = a[j - 1 + (j - 1) * a_dim1];
}
/* L60: */
}
}
/* 3) If UPPER='T', set upper triangle of A to random numbers. */
/* (but don't modify the corners of 2x2 blocks.) */
if (iupper != 0) {
i__1 = *n;
for (jc = 2; jc <= i__1; ++jc) {
if (a[jc - 1 + jc * a_dim1] != 0.) {
jr = jc - 2;
} else {
jr = jc - 1;
}
dlarnv_(&idist, &iseed[1], &jr, &a[jc * a_dim1 + 1]);
/* L70: */
}
}
/* 4) If SIM='T', apply similarity transformation. */
/* -1 */
/* Transform is X A X , where X = U S V, thus */
/* it is U S V A V' (1/S) U' */
if (isim != 0) {
/* Compute S (singular values of the eigenvector matrix) */
/* according to CONDS and MODES */
dlatm1_(modes, conds, &c__0, &c__0, &iseed[1], &ds[1], n, &iinfo);
if (iinfo != 0) {
*info = 3;
return 0;
}
/* Multiply by V and V' */
dlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
if (iinfo != 0) {
*info = 4;
return 0;
}
/* Multiply by S and (1/S) */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dscal_(n, &ds[j], &a[j + a_dim1], lda);
if (ds[j] != 0.) {
d__1 = 1. / ds[j];
dscal_(n, &d__1, &a[j * a_dim1 + 1], &c__1);
} else {
*info = 5;
return 0;
}
/* L80: */
}
/* Multiply by U and U' */
dlarge_(n, &a[a_offset], lda, &iseed[1], &work[1], &iinfo);
if (iinfo != 0) {
*info = 4;
return 0;
}
}
/* 5) Reduce the bandwidth. */
if (*kl < *n - 1) {
/* Reduce bandwidth -- kill column */
i__1 = *n - 1;
for (jcr = *kl + 1; jcr <= i__1; ++jcr) {
ic = jcr - *kl;
irows = *n + 1 - jcr;
icols = *n + *kl - jcr;
dcopy_(&irows, &a[jcr + ic * a_dim1], &c__1, &work[1], &c__1);
xnorms = work[1];
dlarfg_(&irows, &xnorms, &work[2], &c__1, &tau);
work[1] = 1.;
dgemv_("T", &irows, &icols, &c_b39, &a[jcr + (ic + 1) * a_dim1],
lda, &work[1], &c__1, &c_b23, &work[irows + 1], &c__1);
d__1 = -tau;
dger_(&irows, &icols, &d__1, &work[1], &c__1, &work[irows + 1], &
c__1, &a[jcr + (ic + 1) * a_dim1], lda);
dgemv_("N", n, &irows, &c_b39, &a[jcr * a_dim1 + 1], lda, &work[1]
, &c__1, &c_b23, &work[irows + 1], &c__1);
d__1 = -tau;
dger_(n, &irows, &d__1, &work[irows + 1], &c__1, &work[1], &c__1,
&a[jcr * a_dim1 + 1], lda);
a[jcr + ic * a_dim1] = xnorms;
i__2 = irows - 1;
dlaset_("Full", &i__2, &c__1, &c_b23, &c_b23, &a[jcr + 1 + ic *
a_dim1], lda);
/* L90: */
}
} else if (*ku < *n - 1) {
/* Reduce upper bandwidth -- kill a row at a time. */
i__1 = *n - 1;
for (jcr = *ku + 1; jcr <= i__1; ++jcr) {
ir = jcr - *ku;
irows = *n + *ku - jcr;
icols = *n + 1 - jcr;
dcopy_(&icols, &a[ir + jcr * a_dim1], lda, &work[1], &c__1);
xnorms = work[1];
dlarfg_(&icols, &xnorms, &work[2], &c__1, &tau);
work[1] = 1.;
dgemv_("N", &irows, &icols, &c_b39, &a[ir + 1 + jcr * a_dim1],
lda, &work[1], &c__1, &c_b23, &work[icols + 1], &c__1);
d__1 = -tau;
dger_(&irows, &icols, &d__1, &work[icols + 1], &c__1, &work[1], &
c__1, &a[ir + 1 + jcr * a_dim1], lda);
dgemv_("C", &icols, n, &c_b39, &a[jcr + a_dim1], lda, &work[1], &
c__1, &c_b23, &work[icols + 1], &c__1);
d__1 = -tau;
dger_(&icols, n, &d__1, &work[1], &c__1, &work[icols + 1], &c__1,
&a[jcr + a_dim1], lda);
a[ir + jcr * a_dim1] = xnorms;
i__2 = icols - 1;
dlaset_("Full", &c__1, &i__2, &c_b23, &c_b23, &a[ir + (jcr + 1) *
a_dim1], lda);
/* L100: */
}
}
/* Scale the matrix to have norm ANORM */
if (*anorm >= 0.) {
temp = dlange_("M", n, n, &a[a_offset], lda, tempa);
if (temp > 0.) {
alpha = *anorm / temp;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dscal_(n, &alpha, &a[j * a_dim1 + 1], &c__1);
/* L110: */
}
}
}
return 0;
/* End of DLATME */
} /* dlatme_ */
/* Subroutine */ int zlatm1_(integer *mode, doublereal *cond, integer *irsign,
integer *idist, integer *iseed, doublecomplex *d__, integer *n,
integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
doublecomplex z__1, z__2;
/* Local variables */
integer i__;
doublereal temp, alpha;
doublecomplex ctemp;
extern doublereal dlaran_(integer *);
extern /* Double Complex */ void zlarnd_(doublecomplex *, integer *,
integer *);
extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *,
doublecomplex *);
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATM1 computes the entries of D(1..N) as specified by */
/* MODE, COND and IRSIGN. IDIST and ISEED determine the generation */
/* of random numbers. ZLATM1 is called by CLATMR to generate */
/* random test matrices for LAPACK programs. */
/* Arguments */
/* ========= */
/* MODE - INTEGER */
/* On entry describes how D is to be computed: */
/* MODE = 0 means do not change D. */
/* MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
/* MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
/* MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
/* MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
/* MODE = 5 sets D to random numbers in the range */
/* ( 1/COND , 1 ) such that their logarithms */
/* are uniformly distributed. */
/* MODE = 6 set D to random numbers from same distribution */
/* as the rest of the matrix. */
/* MODE < 0 has the same meaning as ABS(MODE), except that */
/* the order of the elements of D is reversed. */
/* Thus if MODE is positive, D has entries ranging from */
/* 1 to 1/COND, if negative, from 1/COND to 1, */
/* Not modified. */
/* COND - DOUBLE PRECISION */
/* On entry, used as described under MODE above. */
/* If used, it must be >= 1. Not modified. */
/* IRSIGN - INTEGER */
/* On entry, if MODE neither -6, 0 nor 6, determines sign of */
/* entries of D */
/* 0 => leave entries of D unchanged */
/* 1 => multiply each entry of D by random complex number */
/* uniformly distributed with absolute value 1 */
/* IDIST - CHARACTER*1 */
/* On entry, IDIST specifies the type of distribution to be */
/* used to generate a random matrix . */
/* 1 => real and imaginary parts each UNIFORM( 0, 1 ) */
/* 2 => real and imaginary parts each UNIFORM( -1, 1 ) */
/* 3 => real and imaginary parts each NORMAL( 0, 1 ) */
/* 4 => complex number uniform in DISK( 0, 1 ) */
/* Not modified. */
/* ISEED - INTEGER array, dimension ( 4 ) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The random number generator uses a */
/* linear congruential sequence limited to small */
/* integers, and so should produce machine independent */
/* random numbers. The values of ISEED are changed on */
/* exit, and can be used in the next call to ZLATM1 */
/* to continue the same random number sequence. */
/* Changed on exit. */
/* D - COMPLEX*16 array, dimension ( MIN( M , N ) ) */
/* Array to be computed according to MODE, COND and IRSIGN. */
/* May be changed on exit if MODE is nonzero. */
/* N - INTEGER */
/* Number of entries of D. Not modified. */
/* INFO - INTEGER */
/* 0 => normal termination */
/* -1 => if MODE not in range -6 to 6 */
/* -2 => if MODE neither -6, 0 nor 6, and */
/* IRSIGN neither 0 nor 1 */
/* -3 => if MODE neither -6, 0 nor 6 and COND less than 1 */
/* -4 => if MODE equals 6 or -6 and IDIST not in range 1 to 4 */
/* -7 => if N negative */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Decode and Test the input parameters. Initialize flags & seed. */
/* Parameter adjustments */
--d__;
--iseed;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Set INFO if an error */
if (*mode < -6 || *mode > 6) {
*info = -1;
} else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
irsign != 1)) {
*info = -2;
} else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) {
*info = -3;
} else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 4)) {
*info = -4;
} else if (*n < 0) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZLATM1", &i__1);
return 0;
}
/* Compute D according to COND and MODE */
if (*mode != 0) {
switch (abs(*mode)) {
case 1: goto L10;
case 2: goto L30;
case 3: goto L50;
case 4: goto L70;
case 5: goto L90;
case 6: goto L110;
}
/* One large D value: */
L10:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
d__1 = 1. / *cond;
d__[i__2].r = d__1, d__[i__2].i = 0.;
/* L20: */
}
d__[1].r = 1., d__[1].i = 0.;
goto L120;
/* One small D value: */
L30:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
d__[i__2].r = 1., d__[i__2].i = 0.;
/* L40: */
}
i__1 = *n;
d__1 = 1. / *cond;
d__[i__1].r = d__1, d__[i__1].i = 0.;
goto L120;
/* Exponentially distributed D values: */
L50:
d__[1].r = 1., d__[1].i = 0.;
if (*n > 1) {
d__1 = -1. / (doublereal) (*n - 1);
alpha = pow_dd(cond, &d__1);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = i__;
i__3 = i__ - 1;
d__1 = pow_di(&alpha, &i__3);
d__[i__2].r = d__1, d__[i__2].i = 0.;
/* L60: */
}
}
goto L120;
/* Arithmetically distributed D values: */
L70:
d__[1].r = 1., d__[1].i = 0.;
if (*n > 1) {
temp = 1. / *cond;
alpha = (1. - temp) / (doublereal) (*n - 1);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = i__;
d__1 = (doublereal) (*n - i__) * alpha + temp;
d__[i__2].r = d__1, d__[i__2].i = 0.;
/* L80: */
}
}
goto L120;
/* Randomly distributed D values on ( 1/COND , 1): */
L90:
alpha = log(1. / *cond);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
d__1 = exp(alpha * dlaran_(&iseed[1]));
d__[i__2].r = d__1, d__[i__2].i = 0.;
/* L100: */
}
goto L120;
/* Randomly distributed D values from IDIST */
L110:
zlarnv_(idist, &iseed[1], n, &d__[1]);
L120:
/* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
/* random signs to D */
if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
zlarnd_(&z__1, &c__3, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
i__2 = i__;
i__3 = i__;
d__1 = z_abs(&ctemp);
z__2.r = ctemp.r / d__1, z__2.i = ctemp.i / d__1;
z__1.r = d__[i__3].r * z__2.r - d__[i__3].i * z__2.i, z__1.i =
d__[i__3].r * z__2.i + d__[i__3].i * z__2.r;
d__[i__2].r = z__1.r, d__[i__2].i = z__1.i;
/* L130: */
}
}
/* Reverse if MODE < 0 */
if (*mode < 0) {
i__1 = *n / 2;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = i__;
ctemp.r = d__[i__2].r, ctemp.i = d__[i__2].i;
i__2 = i__;
i__3 = *n + 1 - i__;
d__[i__2].r = d__[i__3].r, d__[i__2].i = d__[i__3].i;
i__2 = *n + 1 - i__;
d__[i__2].r = ctemp.r, d__[i__2].i = ctemp.i;
/* L140: */
}
}
}
return 0;
/* End of ZLATM1 */
} /* zlatm1_ */
/* Double Complex */ void zlatm2_(doublecomplex * ret_val, integer *m,
integer *n, integer *i__, integer *j, integer *kl, integer *ku,
integer *idist, integer *iseed, doublecomplex *d__, integer *igrade,
doublecomplex *dl, doublecomplex *dr, integer *ipvtng, integer *iwork,
doublereal *sparse)
{
/* System generated locals */
integer i__1, i__2;
doublecomplex z__1, z__2, z__3;
/* Local variables */
integer isub, jsub;
doublecomplex ctemp;
extern doublereal dlaran_(integer *);
extern /* Double Complex */ void zlarnd_(doublecomplex *, integer *,
integer *);
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLATM2 returns the (I,J) entry of a random matrix of dimension */
/* (M, N) described by the other paramters. It is called by the */
/* ZLATMR routine in order to build random test matrices. No error */
/* checking on parameters is done, because this routine is called in */
/* a tight loop by ZLATMR which has already checked the parameters. */
/* Use of ZLATM2 differs from CLATM3 in the order in which the random */
/* number generator is called to fill in random matrix entries. */
/* With ZLATM2, the generator is called to fill in the pivoted matrix */
/* columnwise. With ZLATM3, the generator is called to fill in the */
/* matrix columnwise, after which it is pivoted. Thus, ZLATM3 can */
/* be used to construct random matrices which differ only in their */
/* order of rows and/or columns. ZLATM2 is used to construct band */
/* matrices while avoiding calling the random number generator for */
/* entries outside the band (and therefore generating random numbers */
/* The matrix whose (I,J) entry is returned is constructed as */
/* follows (this routine only computes one entry): */
/* If I is outside (1..M) or J is outside (1..N), return zero */
/* (this is convenient for generating matrices in band format). */
/* Generate a matrix A with random entries of distribution IDIST. */
/* Set the diagonal to D. */
/* Grade the matrix, if desired, from the left (by DL) and/or */
/* from the right (by DR or DL) as specified by IGRADE. */
/* Permute, if desired, the rows and/or columns as specified by */
/* IPVTNG and IWORK. */
/* Band the matrix to have lower bandwidth KL and upper */
/* bandwidth KU. */
/* Set random entries to zero as specified by SPARSE. */
/* Arguments */
/* ========= */
/* M - INTEGER */
/* Number of rows of matrix. Not modified. */
/* N - INTEGER */
/* Number of columns of matrix. Not modified. */
/* I - INTEGER */
/* Row of entry to be returned. Not modified. */
/* J - INTEGER */
/* Column of entry to be returned. Not modified. */
/* KL - INTEGER */
/* Lower bandwidth. Not modified. */
/* KU - INTEGER */
/* Upper bandwidth. Not modified. */
/* IDIST - INTEGER */
/* On entry, IDIST specifies the type of distribution to be */
/* used to generate a random matrix . */
/* 1 => real and imaginary parts each UNIFORM( 0, 1 ) */
/* 2 => real and imaginary parts each UNIFORM( -1, 1 ) */
/* 3 => real and imaginary parts each NORMAL( 0, 1 ) */
/* 4 => complex number uniform in DISK( 0 , 1 ) */
/* Not modified. */
/* ISEED - INTEGER array of dimension ( 4 ) */
/* Seed for random number generator. */
/* Changed on exit. */
/* D - COMPLEX*16 array of dimension ( MIN( I , J ) ) */
/* Diagonal entries of matrix. Not modified. */
/* IGRADE - INTEGER */
/* Specifies grading of matrix as follows: */
/* 0 => no grading */
/* 1 => matrix premultiplied by diag( DL ) */
/* 2 => matrix postmultiplied by diag( DR ) */
/* 3 => matrix premultiplied by diag( DL ) and */
/* postmultiplied by diag( DR ) */
/* 4 => matrix premultiplied by diag( DL ) and */
/* postmultiplied by inv( diag( DL ) ) */
/* 5 => matrix premultiplied by diag( DL ) and */
/* postmultiplied by diag( CONJG(DL) ) */
/* 6 => matrix premultiplied by diag( DL ) and */
/* postmultiplied by diag( DL ) */
/* Not modified. */
/* DL - COMPLEX*16 array ( I or J, as appropriate ) */
/* Left scale factors for grading matrix. Not modified. */
/* DR - COMPLEX*16 array ( I or J, as appropriate ) */
/* Right scale factors for grading matrix. Not modified. */
/* IPVTNG - INTEGER */
/* On entry specifies pivoting permutations as follows: */
/* 0 => none. */
/* 1 => row pivoting. */
/* 2 => column pivoting. */
/* 3 => full pivoting, i.e., on both sides. */
/* Not modified. */
/* IWORK - INTEGER array ( I or J, as appropriate ) */
/* This array specifies the permutation used. The */
/* row (or column) in position K was originally in */
/* position IWORK( K ). */
/* This differs from IWORK for ZLATM3. Not modified. */
/* SPARSE - DOUBLE PRECISION between 0. and 1. */
/* On entry specifies the sparsity of the matrix */
/* if sparse matix is to be generated. */
/* SPARSE should lie between 0 and 1. */
/* A uniform ( 0, 1 ) random number x is generated and */
/* compared to SPARSE; if x is larger the matrix entry */
/* is unchanged and if x is smaller the entry is set */
/* to zero. Thus on the average a fraction SPARSE of the */
/* entries will be set to zero. */
/* Not modified. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* ----------------------------------------------------------------------- */
/* .. Executable Statements .. */
/* Check for I and J in range */
/* Parameter adjustments */
--iwork;
--dr;
--dl;
--d__;
--iseed;
/* Function Body */
if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
ret_val->r = 0., ret_val->i = 0.;
return ;
}
/* Check for banding */
if (*j > *i__ + *ku || *j < *i__ - *kl) {
ret_val->r = 0., ret_val->i = 0.;
return ;
}
/* Check for sparsity */
if (*sparse > 0.) {
if (dlaran_(&iseed[1]) < *sparse) {
ret_val->r = 0., ret_val->i = 0.;
return ;
}
}
/* Compute subscripts depending on IPVTNG */
if (*ipvtng == 0) {
isub = *i__;
jsub = *j;
} else if (*ipvtng == 1) {
isub = iwork[*i__];
jsub = *j;
} else if (*ipvtng == 2) {
isub = *i__;
jsub = iwork[*j];
} else if (*ipvtng == 3) {
isub = iwork[*i__];
jsub = iwork[*j];
}
/* Compute entry and grade it according to IGRADE */
if (isub == jsub) {
i__1 = isub;
ctemp.r = d__[i__1].r, ctemp.i = d__[i__1].i;
} else {
zlarnd_(&z__1, idist, &iseed[1]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
}
if (*igrade == 1) {
i__1 = isub;
z__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__1.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 2) {
i__1 = jsub;
z__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, z__1.i =
ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 3) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
i__2 = jsub;
z__1.r = z__2.r * dr[i__2].r - z__2.i * dr[i__2].i, z__1.i = z__2.r *
dr[i__2].i + z__2.i * dr[i__2].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 4 && isub != jsub) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
z_div(&z__1, &z__2, &dl[jsub]);
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 5) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
d_cnjg(&z__3, &dl[jsub]);
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i
+ z__2.i * z__3.r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
} else if (*igrade == 6) {
i__1 = isub;
z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i =
ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
i__2 = jsub;
z__1.r = z__2.r * dl[i__2].r - z__2.i * dl[i__2].i, z__1.i = z__2.r *
dl[i__2].i + z__2.i * dl[i__2].r;
ctemp.r = z__1.r, ctemp.i = z__1.i;
}
ret_val->r = ctemp.r, ret_val->i = ctemp.i;
return ;
/* End of ZLATM2 */
} /* zlatm2_ */
doublereal dlarnd_(integer *idist, integer *iseed)
{
/* System generated locals */
doublereal ret_val;
/* Builtin functions */
double log(doublereal), sqrt(doublereal), cos(doublereal);
/* Local variables */
static doublereal t1, t2;
extern doublereal dlaran_(integer *);
/* -- LAPACK auxiliary routine (version 2.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* September 30, 1994 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLARND returns a random real number from a uniform or normal */
/* distribution. */
/* Arguments */
/* ========= */
/* IDIST (input) INTEGER */
/* Specifies the distribution of the random numbers: */
/* = 1: uniform (0,1) */
/* = 2: uniform (-1,1) */
/* = 3: normal (0,1) */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator; the array */
/* elements must be between 0 and 4095, and ISEED(4) must be */
/* odd. */
/* On exit, the seed is updated. */
/* Further Details */
/* =============== */
/* This routine calls the auxiliary routine DLARAN to generate a random */
/* real number from a uniform (0,1) distribution. The Box-Muller method */
/* is used to transform numbers from a uniform to a normal distribution. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Generate a real random number from a uniform (0,1) distribution */
/* Parameter adjustments */
--iseed;
/* Function Body */
t1 = dlaran_(&iseed[1]);
if (*idist == 1) {
/* uniform (0,1) */
ret_val = t1;
} else if (*idist == 2) {
/* uniform (-1,1) */
ret_val = t1 * 2. - 1.;
} else if (*idist == 3) {
/* normal (0,1) */
t2 = dlaran_(&iseed[1]);
ret_val = sqrt(log(t1) * -2.) * cos(t2 *
6.2831853071795864769252867663);
}
return ret_val;
/* End of DLARND */
} /* dlarnd_ */
/* Double Complex */ VOID zlarnd_(doublecomplex * ret_val, integer *idist,
integer *iseed)
{
/* System generated locals */
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
double log(doublereal), sqrt(doublereal);
void z_exp(doublecomplex *, doublecomplex *);
/* Local variables */
doublereal t1, t2;
extern doublereal dlaran_(integer *);
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZLARND returns a random complex number from a uniform or normal */
/* distribution. */
/* Arguments */
/* ========= */
/* IDIST (input) INTEGER */
/* Specifies the distribution of the random numbers: */
/* = 1: real and imaginary parts each uniform (0,1) */
/* = 2: real and imaginary parts each uniform (-1,1) */
/* = 3: real and imaginary parts each normal (0,1) */
/* = 4: uniformly distributed on the disc abs(z) <= 1 */
/* = 5: uniformly distributed on the circle abs(z) = 1 */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator; the array */
/* elements must be between 0 and 4095, and ISEED(4) must be */
/* odd. */
/* On exit, the seed is updated. */
/* Further Details */
/* =============== */
/* This routine calls the auxiliary routine DLARAN to generate a random */
/* real number from a uniform (0,1) distribution. The Box-Muller method */
/* is used to transform numbers from a uniform to a normal distribution. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Generate a pair of real random numbers from a uniform (0,1) */
/* distribution */
/* Parameter adjustments */
--iseed;
/* Function Body */
t1 = dlaran_(&iseed[1]);
t2 = dlaran_(&iseed[1]);
if (*idist == 1) {
/* real and imaginary parts each uniform (0,1) */
z__1.r = t1, z__1.i = t2;
ret_val->r = z__1.r, ret_val->i = z__1.i;
} else if (*idist == 2) {
/* real and imaginary parts each uniform (-1,1) */
d__1 = t1 * 2. - 1.;
d__2 = t2 * 2. - 1.;
z__1.r = d__1, z__1.i = d__2;
ret_val->r = z__1.r, ret_val->i = z__1.i;
} else if (*idist == 3) {
/* real and imaginary parts each normal (0,1) */
d__1 = sqrt(log(t1) * -2.);
d__2 = t2 * 6.2831853071795864769252867663;
z__3.r = 0., z__3.i = d__2;
z_exp(&z__2, &z__3);
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
ret_val->r = z__1.r, ret_val->i = z__1.i;
} else if (*idist == 4) {
/* uniform distribution on the unit disc abs(z) <= 1 */
d__1 = sqrt(t1);
d__2 = t2 * 6.2831853071795864769252867663;
z__3.r = 0., z__3.i = d__2;
z_exp(&z__2, &z__3);
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
ret_val->r = z__1.r, ret_val->i = z__1.i;
} else if (*idist == 5) {
/* uniform distribution on the unit circle abs(z) = 1 */
d__1 = t2 * 6.2831853071795864769252867663;
z__2.r = 0., z__2.i = d__1;
z_exp(&z__1, &z__2);
ret_val->r = z__1.r, ret_val->i = z__1.i;
}
return ;
/* End of ZLARND */
} /* zlarnd_ */
doublereal dlatm3_(integer *m, integer *n, integer *i__, integer *j, integer *
isub, integer *jsub, integer *kl, integer *ku, integer *idist,
integer *iseed, doublereal *d__, integer *igrade, doublereal *dl,
doublereal *dr, integer *ipvtng, integer *iwork, doublereal *sparse)
{
/* System generated locals */
doublereal ret_val;
/* Local variables */
doublereal temp;
extern doublereal dlaran_(integer *), dlarnd_(integer *, integer *);
/* -- LAPACK auxiliary test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLATM3 returns the (ISUB,JSUB) entry of a random matrix of */
/* dimension (M, N) described by the other paramters. (ISUB,JSUB) */
/* is the final position of the (I,J) entry after pivoting */
/* according to IPVTNG and IWORK. DLATM3 is called by the */
/* DLATMR routine in order to build random test matrices. No error */
/* checking on parameters is done, because this routine is called in */
/* a tight loop by DLATMR which has already checked the parameters. */
/* Use of DLATM3 differs from SLATM2 in the order in which the random */
/* number generator is called to fill in random matrix entries. */
/* With DLATM2, the generator is called to fill in the pivoted matrix */
/* columnwise. With DLATM3, the generator is called to fill in the */
/* matrix columnwise, after which it is pivoted. Thus, DLATM3 can */
/* be used to construct random matrices which differ only in their */
/* order of rows and/or columns. DLATM2 is used to construct band */
/* matrices while avoiding calling the random number generator for */
/* entries outside the band (and therefore generating random numbers */
/* in different orders for different pivot orders). */
/* The matrix whose (ISUB,JSUB) entry is returned is constructed as */
/* follows (this routine only computes one entry): */
/* If ISUB is outside (1..M) or JSUB is outside (1..N), return zero */
/* (this is convenient for generating matrices in band format). */
/* Generate a matrix A with random entries of distribution IDIST. */
/* Set the diagonal to D. */
/* Grade the matrix, if desired, from the left (by DL) and/or */
/* from the right (by DR or DL) as specified by IGRADE. */
/* Permute, if desired, the rows and/or columns as specified by */
/* IPVTNG and IWORK. */
/* Band the matrix to have lower bandwidth KL and upper */
/* bandwidth KU. */
/* Set random entries to zero as specified by SPARSE. */
/* Arguments */
/* ========= */
/* M - INTEGER */
/* Number of rows of matrix. Not modified. */
/* N - INTEGER */
/* Number of columns of matrix. Not modified. */
/* I - INTEGER */
/* Row of unpivoted entry to be returned. Not modified. */
/* J - INTEGER */
/* Column of unpivoted entry to be returned. Not modified. */
/* ISUB - INTEGER */
/* Row of pivoted entry to be returned. Changed on exit. */
/* JSUB - INTEGER */
/* Column of pivoted entry to be returned. Changed on exit. */
/* KL - INTEGER */
/* Lower bandwidth. Not modified. */
/* KU - INTEGER */
/* Upper bandwidth. Not modified. */
/* IDIST - INTEGER */
/* On entry, IDIST specifies the type of distribution to be */
/* used to generate a random matrix . */
/* 1 => UNIFORM( 0, 1 ) */
/* 2 => UNIFORM( -1, 1 ) */
/* 3 => NORMAL( 0, 1 ) */
/* Not modified. */
/* ISEED - INTEGER array of dimension ( 4 ) */
/* Seed for random number generator. */
/* Changed on exit. */
/* D - DOUBLE PRECISION array of dimension ( MIN( I , J ) ) */
/* Diagonal entries of matrix. Not modified. */
/* IGRADE - INTEGER */
/* Specifies grading of matrix as follows: */
/* 0 => no grading */
/* 1 => matrix premultiplied by diag( DL ) */
/* 2 => matrix postmultiplied by diag( DR ) */
/* 3 => matrix premultiplied by diag( DL ) and */
/* postmultiplied by diag( DR ) */
/* 4 => matrix premultiplied by diag( DL ) and */
/* postmultiplied by inv( diag( DL ) ) */
/* 5 => matrix premultiplied by diag( DL ) and */
/* postmultiplied by diag( DL ) */
/* Not modified. */
/* DL - DOUBLE PRECISION array ( I or J, as appropriate ) */
/* Left scale factors for grading matrix. Not modified. */
/* DR - DOUBLE PRECISION array ( I or J, as appropriate ) */
/* Right scale factors for grading matrix. Not modified. */
/* IPVTNG - INTEGER */
/* On entry specifies pivoting permutations as follows: */
/* 0 => none. */
/* 1 => row pivoting. */
/* 2 => column pivoting. */
/* 3 => full pivoting, i.e., on both sides. */
/* Not modified. */
/* IWORK - INTEGER array ( I or J, as appropriate ) */
/* This array specifies the permutation used. The */
/* row (or column) originally in position K is in */
/* position IWORK( K ) after pivoting. */
/* This differs from IWORK for DLATM2. Not modified. */
/* SPARSE - DOUBLE PRECISION between 0. and 1. */
/* On entry specifies the sparsity of the matrix */
/* if sparse matix is to be generated. */
/* SPARSE should lie between 0 and 1. */
/* A uniform ( 0, 1 ) random number x is generated and */
/* compared to SPARSE; if x is larger the matrix entry */
/* is unchanged and if x is smaller the entry is set */
/* to zero. Thus on the average a fraction SPARSE of the */
/* entries will be set to zero. */
/* Not modified. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* ----------------------------------------------------------------------- */
/* .. Executable Statements .. */
/* Check for I and J in range */
/* Parameter adjustments */
--iwork;
--dr;
--dl;
--d__;
--iseed;
/* Function Body */
if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
*isub = *i__;
*jsub = *j;
ret_val = 0.;
return ret_val;
}
/* Compute subscripts depending on IPVTNG */
if (*ipvtng == 0) {
*isub = *i__;
*jsub = *j;
} else if (*ipvtng == 1) {
*isub = iwork[*i__];
*jsub = *j;
} else if (*ipvtng == 2) {
*isub = *i__;
*jsub = iwork[*j];
} else if (*ipvtng == 3) {
*isub = iwork[*i__];
*jsub = iwork[*j];
}
/* Check for banding */
if (*jsub > *isub + *ku || *jsub < *isub - *kl) {
ret_val = 0.;
return ret_val;
}
/* Check for sparsity */
if (*sparse > 0.) {
if (dlaran_(&iseed[1]) < *sparse) {
ret_val = 0.;
return ret_val;
}
}
/* Compute entry and grade it according to IGRADE */
if (*i__ == *j) {
temp = d__[*i__];
} else {
temp = dlarnd_(idist, &iseed[1]);
}
if (*igrade == 1) {
temp *= dl[*i__];
} else if (*igrade == 2) {
temp *= dr[*j];
} else if (*igrade == 3) {
temp = temp * dl[*i__] * dr[*j];
} else if (*igrade == 4 && *i__ != *j) {
temp = temp * dl[*i__] / dl[*j];
} else if (*igrade == 5) {
temp = temp * dl[*i__] * dl[*j];
}
ret_val = temp;
return ret_val;
/* End of DLATM3 */
} /* dlatm3_ */
