OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
complex16
LAPACK Testing » Matrix Generation

Functions

subroutine zlagge (m, n, kl, ku, d, a, lda, iseed, work, info)
 ZLAGGE
subroutine zlaghe (n, k, d, a, lda, iseed, work, info)
 ZLAGHE
subroutine zlagsy (n, k, d, a, lda, iseed, work, info)
 ZLAGSY
subroutine zlahilb (n, nrhs, a, lda, x, ldx, b, ldb, work, info, path)
 ZLAHILB
subroutine zlakf2 (m, n, a, lda, b, d, e, z, ldz)
 ZLAKF2
subroutine zlarge (n, a, lda, iseed, work, info)
 ZLARGE
complex *16 function zlarnd (idist, iseed)
 ZLARND
subroutine zlaror (side, init, m, n, a, lda, iseed, x, info)
 ZLAROR
subroutine zlarot (lrows, lleft, lright, nl, c, s, a, lda, xleft, xright)
 ZLAROT
subroutine zlatm1 (mode, cond, irsign, idist, iseed, d, n, info)
 ZLATM1
complex *16 function zlatm2 (m, n, i, j, kl, ku, idist, iseed, d, igrade, dl, dr, ipvtng, iwork, sparse)
 ZLATM2
complex *16 function zlatm3 (m, n, i, j, isub, jsub, kl, ku, idist, iseed, d, igrade, dl, dr, ipvtng, iwork, sparse)
 ZLATM3
subroutine zlatm5 (prtype, m, n, a, lda, b, ldb, c, ldc, d, ldd, e, lde, f, ldf, r, ldr, l, ldl, alpha, qblcka, qblckb)
 ZLATM5
subroutine zlatm6 (type, n, a, lda, b, x, ldx, y, ldy, alpha, beta, wx, wy, s, dif)
 ZLATM6
subroutine zlatme (n, dist, iseed, d, mode, cond, dmax, rsign, upper, sim, ds, modes, conds, kl, ku, anorm, a, lda, work, info)
 ZLATME
subroutine zlatmr (m, n, dist, iseed, sym, d, mode, cond, dmax, rsign, grade, dl, model, condl, dr, moder, condr, pivtng, ipivot, kl, ku, sparse, anorm, pack, a, lda, iwork, info)
 ZLATMR
subroutine zlatms (m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
 ZLATMS
subroutine zlatmt (m, n, dist, iseed, sym, d, mode, cond, dmax, rank, kl, ku, pack, a, lda, work, info)
 ZLATMT

Detailed Description

This is the group of complex16 LAPACK TESTING MATGEN routines.

Function Documentation

◆ zlagge()

subroutine zlagge ( integer m,
integer n,
integer kl,
integer ku,
double precision, dimension( * ) d,
complex*16, dimension( lda, * ) a,
integer lda,
integer, dimension( 4 ) iseed,
complex*16, dimension( * ) work,
integer info )

ZLAGGE

Purpose:
!>
!> ZLAGGE generates a complex general m by n matrix A, by pre- and post-
!> multiplying a real diagonal matrix D with random unitary matrices:
!> A = U*D*V. The lower and upper bandwidths may then be reduced to
!> kl and ku by additional unitary transformations.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]KL
!>          KL is INTEGER
!>          The number of nonzero subdiagonals within the band of A.
!>          0 <= KL <= M-1.
!>
[in]KU
!>          KU is INTEGER
!>          The number of nonzero superdiagonals within the band of A.
!>          0 <= KU <= N-1.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (min(M,N))
!>          The diagonal elements of the diagonal matrix D.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The generated m by n matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= M.
!>
[in,out]ISEED
!>          ISEED is 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.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (M+N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 113 of file zlagge.f.

114*
115* -- LAPACK auxiliary routine --
116* -- LAPACK is a software package provided by Univ. of Tennessee, --
117* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
118*
119* .. Scalar Arguments ..
120 INTEGER INFO, KL, KU, LDA, M, N
121* ..
122* .. Array Arguments ..
123 INTEGER ISEED( 4 )
124 DOUBLE PRECISION D( * )
125 COMPLEX*16 A( LDA, * ), WORK( * )
126* ..
127*
128* =====================================================================
129*
130* .. Parameters ..
131 COMPLEX*16 ZERO, ONE
132 parameter( zero = ( 0.0d+0, 0.0d+0 ),
133 $ one = ( 1.0d+0, 0.0d+0 ) )
134* ..
135* .. Local Scalars ..
136 INTEGER I, J
137 DOUBLE PRECISION WN
138 COMPLEX*16 TAU, WA, WB
139* ..
140* .. External Subroutines ..
141 EXTERNAL xerbla, zgemv, zgerc, zlacgv, zlarnv, zscal
142* ..
143* .. Intrinsic Functions ..
144 INTRINSIC abs, dble, max, min
145* ..
146* .. External Functions ..
147 DOUBLE PRECISION DZNRM2
148 EXTERNAL dznrm2
149* ..
150* .. Executable Statements ..
151*
152* Test the input arguments
153*
154 info = 0
155 IF( m.LT.0 ) THEN
156 info = -1
157 ELSE IF( n.LT.0 ) THEN
158 info = -2
159 ELSE IF( kl.LT.0 .OR. kl.GT.m-1 ) THEN
160 info = -3
161 ELSE IF( ku.LT.0 .OR. ku.GT.n-1 ) THEN
162 info = -4
163 ELSE IF( lda.LT.max( 1, m ) ) THEN
164 info = -7
165 END IF
166 IF( info.LT.0 ) THEN
167 CALL xerbla( 'ZLAGGE', -info )
168 RETURN
169 END IF
170*
171* initialize A to diagonal matrix
172*
173 DO 20 j = 1, n
174 DO 10 i = 1, m
175 a( i, j ) = zero
176 10 CONTINUE
177 20 CONTINUE
178 DO 30 i = 1, min( m, n )
179 a( i, i ) = d( i )
180 30 CONTINUE
181*
182* Quick exit if the user wants a diagonal matrix
183*
184 IF(( kl .EQ. 0 ).AND.( ku .EQ. 0)) RETURN
185*
186* pre- and post-multiply A by random unitary matrices
187*
188 DO 40 i = min( m, n ), 1, -1
189 IF( i.LT.m ) THEN
190*
191* generate random reflection
192*
193 CALL zlarnv( 3, iseed, m-i+1, work )
194 wn = dznrm2( m-i+1, work, 1 )
195 wa = ( wn / abs( work( 1 ) ) )*work( 1 )
196 IF( wn.EQ.zero ) THEN
197 tau = zero
198 ELSE
199 wb = work( 1 ) + wa
200 CALL zscal( m-i, one / wb, work( 2 ), 1 )
201 work( 1 ) = one
202 tau = dble( wb / wa )
203 END IF
204*
205* multiply A(i:m,i:n) by random reflection from the left
206*
207 CALL zgemv( 'Conjugate transpose', m-i+1, n-i+1, one,
208 $ a( i, i ), lda, work, 1, zero, work( m+1 ), 1 )
209 CALL zgerc( m-i+1, n-i+1, -tau, work, 1, work( m+1 ), 1,
210 $ a( i, i ), lda )
211 END IF
212 IF( i.LT.n ) THEN
213*
214* generate random reflection
215*
216 CALL zlarnv( 3, iseed, n-i+1, work )
217 wn = dznrm2( n-i+1, work, 1 )
218 wa = ( wn / abs( work( 1 ) ) )*work( 1 )
219 IF( wn.EQ.zero ) THEN
220 tau = zero
221 ELSE
222 wb = work( 1 ) + wa
223 CALL zscal( n-i, one / wb, work( 2 ), 1 )
224 work( 1 ) = one
225 tau = dble( wb / wa )
226 END IF
227*
228* multiply A(i:m,i:n) by random reflection from the right
229*
230 CALL zgemv( 'No transpose', m-i+1, n-i+1, one, a( i, i ),
231 $ lda, work, 1, zero, work( n+1 ), 1 )
232 CALL zgerc( m-i+1, n-i+1, -tau, work( n+1 ), 1, work, 1,
233 $ a( i, i ), lda )
234 END IF
235 40 CONTINUE
236*
237* Reduce number of subdiagonals to KL and number of superdiagonals
238* to KU
239*
240 DO 70 i = 1, max( m-1-kl, n-1-ku )
241 IF( kl.LE.ku ) THEN
242*
243* annihilate subdiagonal elements first (necessary if KL = 0)
244*
245 IF( i.LE.min( m-1-kl, n ) ) THEN
246*
247* generate reflection to annihilate A(kl+i+1:m,i)
248*
249 wn = dznrm2( m-kl-i+1, a( kl+i, i ), 1 )
250 wa = ( wn / abs( a( kl+i, i ) ) )*a( kl+i, i )
251 IF( wn.EQ.zero ) THEN
252 tau = zero
253 ELSE
254 wb = a( kl+i, i ) + wa
255 CALL zscal( m-kl-i, one / wb, a( kl+i+1, i ), 1 )
256 a( kl+i, i ) = one
257 tau = dble( wb / wa )
258 END IF
259*
260* apply reflection to A(kl+i:m,i+1:n) from the left
261*
262 CALL zgemv( 'Conjugate transpose', m-kl-i+1, n-i, one,
263 $ a( kl+i, i+1 ), lda, a( kl+i, i ), 1, zero,
264 $ work, 1 )
265 CALL zgerc( m-kl-i+1, n-i, -tau, a( kl+i, i ), 1, work,
266 $ 1, a( kl+i, i+1 ), lda )
267 a( kl+i, i ) = -wa
268 END IF
269*
270 IF( i.LE.min( n-1-ku, m ) ) THEN
271*
272* generate reflection to annihilate A(i,ku+i+1:n)
273*
274 wn = dznrm2( n-ku-i+1, a( i, ku+i ), lda )
275 wa = ( wn / abs( a( i, ku+i ) ) )*a( i, ku+i )
276 IF( wn.EQ.zero ) THEN
277 tau = zero
278 ELSE
279 wb = a( i, ku+i ) + wa
280 CALL zscal( n-ku-i, one / wb, a( i, ku+i+1 ), lda )
281 a( i, ku+i ) = one
282 tau = dble( wb / wa )
283 END IF
284*
285* apply reflection to A(i+1:m,ku+i:n) from the right
286*
287 CALL zlacgv( n-ku-i+1, a( i, ku+i ), lda )
288 CALL zgemv( 'No transpose', m-i, n-ku-i+1, one,
289 $ a( i+1, ku+i ), lda, a( i, ku+i ), lda, zero,
290 $ work, 1 )
291 CALL zgerc( m-i, n-ku-i+1, -tau, work, 1, a( i, ku+i ),
292 $ lda, a( i+1, ku+i ), lda )
293 a( i, ku+i ) = -wa
294 END IF
295 ELSE
296*
297* annihilate superdiagonal elements first (necessary if
298* KU = 0)
299*
300 IF( i.LE.min( n-1-ku, m ) ) THEN
301*
302* generate reflection to annihilate A(i,ku+i+1:n)
303*
304 wn = dznrm2( n-ku-i+1, a( i, ku+i ), lda )
305 wa = ( wn / abs( a( i, ku+i ) ) )*a( i, ku+i )
306 IF( wn.EQ.zero ) THEN
307 tau = zero
308 ELSE
309 wb = a( i, ku+i ) + wa
310 CALL zscal( n-ku-i, one / wb, a( i, ku+i+1 ), lda )
311 a( i, ku+i ) = one
312 tau = dble( wb / wa )
313 END IF
314*
315* apply reflection to A(i+1:m,ku+i:n) from the right
316*
317 CALL zlacgv( n-ku-i+1, a( i, ku+i ), lda )
318 CALL zgemv( 'No transpose', m-i, n-ku-i+1, one,
319 $ a( i+1, ku+i ), lda, a( i, ku+i ), lda, zero,
320 $ work, 1 )
321 CALL zgerc( m-i, n-ku-i+1, -tau, work, 1, a( i, ku+i ),
322 $ lda, a( i+1, ku+i ), lda )
323 a( i, ku+i ) = -wa
324 END IF
325*
326 IF( i.LE.min( m-1-kl, n ) ) THEN
327*
328* generate reflection to annihilate A(kl+i+1:m,i)
329*
330 wn = dznrm2( m-kl-i+1, a( kl+i, i ), 1 )
331 wa = ( wn / abs( a( kl+i, i ) ) )*a( kl+i, i )
332 IF( wn.EQ.zero ) THEN
333 tau = zero
334 ELSE
335 wb = a( kl+i, i ) + wa
336 CALL zscal( m-kl-i, one / wb, a( kl+i+1, i ), 1 )
337 a( kl+i, i ) = one
338 tau = dble( wb / wa )
339 END IF
340*
341* apply reflection to A(kl+i:m,i+1:n) from the left
342*
343 CALL zgemv( 'Conjugate transpose', m-kl-i+1, n-i, one,
344 $ a( kl+i, i+1 ), lda, a( kl+i, i ), 1, zero,
345 $ work, 1 )
346 CALL zgerc( m-kl-i+1, n-i, -tau, a( kl+i, i ), 1, work,
347 $ 1, a( kl+i, i+1 ), lda )
348 a( kl+i, i ) = -wa
349 END IF
350 END IF
351*
352 IF (i .LE. n) THEN
353 DO 50 j = kl + i + 1, m
354 a( j, i ) = zero
355 50 CONTINUE
356 END IF
357*
358 IF (i .LE. m) THEN
359 DO 60 j = ku + i + 1, n
360 a( i, j ) = zero
361 60 CONTINUE
362 END IF
363 70 CONTINUE
364 RETURN
365*
366* End of ZLAGGE
367*
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60
zlarnv
subroutine zlarnv(idist, iseed, n, x)
ZLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition zlarnv.f:99
zlacgv
subroutine zlacgv(n, x, incx)
ZLACGV conjugates a complex vector.
Definition zlacgv.f:74
zscal
subroutine zscal(n, za, zx, incx)
ZSCAL
Definition zscal.f:78
zgemv
subroutine zgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
ZGEMV
Definition zgemv.f:158
zgerc
subroutine zgerc(m, n, alpha, x, incx, y, incy, a, lda)
ZGERC
Definition zgerc.f:130
dznrm2
real(wp) function dznrm2(n, x, incx)
DZNRM2
Definition dznrm2.f90:90
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21

◆ zlaghe()

subroutine zlaghe ( integer n,
integer k,
double precision, dimension( * ) d,
complex*16, dimension( lda, * ) a,
integer lda,
integer, dimension( 4 ) iseed,
complex*16, dimension( * ) work,
integer info )

ZLAGHE

Purpose:
!>
!> ZLAGHE generates a complex hermitian matrix A, by pre- and post-
!> multiplying a real diagonal matrix D with a random unitary matrix:
!> A = U*D*U'. The semi-bandwidth may then be reduced to k by additional
!> unitary transformations.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of nonzero subdiagonals within the band of A.
!>          0 <= K <= N-1.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of the diagonal matrix D.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The generated n by n hermitian matrix A (the full matrix is
!>          stored).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= N.
!>
[in,out]ISEED
!>          ISEED is 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.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 101 of file zlaghe.f.

102*
103* -- LAPACK auxiliary routine --
104* -- LAPACK is a software package provided by Univ. of Tennessee, --
105* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
106*
107* .. Scalar Arguments ..
108 INTEGER INFO, K, LDA, N
109* ..
110* .. Array Arguments ..
111 INTEGER ISEED( 4 )
112 DOUBLE PRECISION D( * )
113 COMPLEX*16 A( LDA, * ), WORK( * )
114* ..
115*
116* =====================================================================
117*
118* .. Parameters ..
119 COMPLEX*16 ZERO, ONE, HALF
120 parameter( zero = ( 0.0d+0, 0.0d+0 ),
121 $ one = ( 1.0d+0, 0.0d+0 ),
122 $ half = ( 0.5d+0, 0.0d+0 ) )
123* ..
124* .. Local Scalars ..
125 INTEGER I, J
126 DOUBLE PRECISION WN
127 COMPLEX*16 ALPHA, TAU, WA, WB
128* ..
129* .. External Subroutines ..
130 EXTERNAL xerbla, zaxpy, zgemv, zgerc, zhemv, zher2,
131 $ zlarnv, zscal
132* ..
133* .. External Functions ..
134 DOUBLE PRECISION DZNRM2
135 COMPLEX*16 ZDOTC
136 EXTERNAL dznrm2, zdotc
137* ..
138* .. Intrinsic Functions ..
139 INTRINSIC abs, dble, dconjg, max
140* ..
141* .. Executable Statements ..
142*
143* Test the input arguments
144*
145 info = 0
146 IF( n.LT.0 ) THEN
147 info = -1
148 ELSE IF( k.LT.0 .OR. k.GT.n-1 ) THEN
149 info = -2
150 ELSE IF( lda.LT.max( 1, n ) ) THEN
151 info = -5
152 END IF
153 IF( info.LT.0 ) THEN
154 CALL xerbla( 'ZLAGHE', -info )
155 RETURN
156 END IF
157*
158* initialize lower triangle of A to diagonal matrix
159*
160 DO 20 j = 1, n
161 DO 10 i = j + 1, n
162 a( i, j ) = zero
163 10 CONTINUE
164 20 CONTINUE
165 DO 30 i = 1, n
166 a( i, i ) = d( i )
167 30 CONTINUE
168*
169* Generate lower triangle of hermitian matrix
170*
171 DO 40 i = n - 1, 1, -1
172*
173* generate random reflection
174*
175 CALL zlarnv( 3, iseed, n-i+1, work )
176 wn = dznrm2( n-i+1, work, 1 )
177 wa = ( wn / abs( work( 1 ) ) )*work( 1 )
178 IF( wn.EQ.zero ) THEN
179 tau = zero
180 ELSE
181 wb = work( 1 ) + wa
182 CALL zscal( n-i, one / wb, work( 2 ), 1 )
183 work( 1 ) = one
184 tau = dble( wb / wa )
185 END IF
186*
187* apply random reflection to A(i:n,i:n) from the left
188* and the right
189*
190* compute y := tau * A * u
191*
192 CALL zhemv( 'Lower', n-i+1, tau, a( i, i ), lda, work, 1, zero,
193 $ work( n+1 ), 1 )
194*
195* compute v := y - 1/2 * tau * ( y, u ) * u
196*
197 alpha = -half*tau*zdotc( n-i+1, work( n+1 ), 1, work, 1 )
198 CALL zaxpy( n-i+1, alpha, work, 1, work( n+1 ), 1 )
199*
200* apply the transformation as a rank-2 update to A(i:n,i:n)
201*
202 CALL zher2( 'Lower', n-i+1, -one, work, 1, work( n+1 ), 1,
203 $ a( i, i ), lda )
204 40 CONTINUE
205*
206* Reduce number of subdiagonals to K
207*
208 DO 60 i = 1, n - 1 - k
209*
210* generate reflection to annihilate A(k+i+1:n,i)
211*
212 wn = dznrm2( n-k-i+1, a( k+i, i ), 1 )
213 wa = ( wn / abs( a( k+i, i ) ) )*a( k+i, i )
214 IF( wn.EQ.zero ) THEN
215 tau = zero
216 ELSE
217 wb = a( k+i, i ) + wa
218 CALL zscal( n-k-i, one / wb, a( k+i+1, i ), 1 )
219 a( k+i, i ) = one
220 tau = dble( wb / wa )
221 END IF
222*
223* apply reflection to A(k+i:n,i+1:k+i-1) from the left
224*
225 CALL zgemv( 'Conjugate transpose', n-k-i+1, k-1, one,
226 $ a( k+i, i+1 ), lda, a( k+i, i ), 1, zero, work, 1 )
227 CALL zgerc( n-k-i+1, k-1, -tau, a( k+i, i ), 1, work, 1,
228 $ a( k+i, i+1 ), lda )
229*
230* apply reflection to A(k+i:n,k+i:n) from the left and the right
231*
232* compute y := tau * A * u
233*
234 CALL zhemv( 'Lower', n-k-i+1, tau, a( k+i, k+i ), lda,
235 $ a( k+i, i ), 1, zero, work, 1 )
236*
237* compute v := y - 1/2 * tau * ( y, u ) * u
238*
239 alpha = -half*tau*zdotc( n-k-i+1, work, 1, a( k+i, i ), 1 )
240 CALL zaxpy( n-k-i+1, alpha, a( k+i, i ), 1, work, 1 )
241*
242* apply hermitian rank-2 update to A(k+i:n,k+i:n)
243*
244 CALL zher2( 'Lower', n-k-i+1, -one, a( k+i, i ), 1, work, 1,
245 $ a( k+i, k+i ), lda )
246*
247 a( k+i, i ) = -wa
248 DO 50 j = k + i + 1, n
249 a( j, i ) = zero
250 50 CONTINUE
251 60 CONTINUE
252*
253* Store full hermitian matrix
254*
255 DO 80 j = 1, n
256 DO 70 i = j + 1, n
257 a( j, i ) = dconjg( a( i, j ) )
258 70 CONTINUE
259 80 CONTINUE
260 RETURN
261*
262* End of ZLAGHE
263*
alpha
#define alpha
Definition eval.h:35
zdotc
complex *16 function zdotc(n, zx, incx, zy, incy)
ZDOTC
Definition zdotc.f:83
zaxpy
subroutine zaxpy(n, za, zx, incx, zy, incy)
ZAXPY
Definition zaxpy.f:88
zher2
subroutine zher2(uplo, n, alpha, x, incx, y, incy, a, lda)
ZHER2
Definition zher2.f:150
zhemv
subroutine zhemv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
ZHEMV
Definition zhemv.f:154

◆ zlagsy()

subroutine zlagsy ( integer n,
integer k,
double precision, dimension( * ) d,
complex*16, dimension( lda, * ) a,
integer lda,
integer, dimension( 4 ) iseed,
complex*16, dimension( * ) work,
integer info )

ZLAGSY

Purpose:
!>
!> ZLAGSY generates a complex symmetric matrix A, by pre- and post-
!> multiplying a real diagonal matrix D with a random unitary matrix:
!> A = U*D*U**T. The semi-bandwidth may then be reduced to k by
!> additional unitary transformations.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of nonzero subdiagonals within the band of A.
!>          0 <= K <= N-1.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of the diagonal matrix D.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The generated n by n symmetric matrix A (the full matrix is
!>          stored).
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= N.
!>
[in,out]ISEED
!>          ISEED is 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.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 101 of file zlagsy.f.

102*
103* -- LAPACK auxiliary routine --
104* -- LAPACK is a software package provided by Univ. of Tennessee, --
105* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
106*
107* .. Scalar Arguments ..
108 INTEGER INFO, K, LDA, N
109* ..
110* .. Array Arguments ..
111 INTEGER ISEED( 4 )
112 DOUBLE PRECISION D( * )
113 COMPLEX*16 A( LDA, * ), WORK( * )
114* ..
115*
116* =====================================================================
117*
118* .. Parameters ..
119 COMPLEX*16 ZERO, ONE, HALF
120 parameter( zero = ( 0.0d+0, 0.0d+0 ),
121 $ one = ( 1.0d+0, 0.0d+0 ),
122 $ half = ( 0.5d+0, 0.0d+0 ) )
123* ..
124* .. Local Scalars ..
125 INTEGER I, II, J, JJ
126 DOUBLE PRECISION WN
127 COMPLEX*16 ALPHA, TAU, WA, WB
128* ..
129* .. External Subroutines ..
130 EXTERNAL xerbla, zaxpy, zgemv, zgerc, zlacgv, zlarnv,
131 $ zscal, zsymv
132* ..
133* .. External Functions ..
134 DOUBLE PRECISION DZNRM2
135 COMPLEX*16 ZDOTC
136 EXTERNAL dznrm2, zdotc
137* ..
138* .. Intrinsic Functions ..
139 INTRINSIC abs, dble, max
140* ..
141* .. Executable Statements ..
142*
143* Test the input arguments
144*
145 info = 0
146 IF( n.LT.0 ) THEN
147 info = -1
148 ELSE IF( k.LT.0 .OR. k.GT.n-1 ) THEN
149 info = -2
150 ELSE IF( lda.LT.max( 1, n ) ) THEN
151 info = -5
152 END IF
153 IF( info.LT.0 ) THEN
154 CALL xerbla( 'ZLAGSY', -info )
155 RETURN
156 END IF
157*
158* initialize lower triangle of A to diagonal matrix
159*
160 DO 20 j = 1, n
161 DO 10 i = j + 1, n
162 a( i, j ) = zero
163 10 CONTINUE
164 20 CONTINUE
165 DO 30 i = 1, n
166 a( i, i ) = d( i )
167 30 CONTINUE
168*
169* Generate lower triangle of symmetric matrix
170*
171 DO 60 i = n - 1, 1, -1
172*
173* generate random reflection
174*
175 CALL zlarnv( 3, iseed, n-i+1, work )
176 wn = dznrm2( n-i+1, work, 1 )
177 wa = ( wn / abs( work( 1 ) ) )*work( 1 )
178 IF( wn.EQ.zero ) THEN
179 tau = zero
180 ELSE
181 wb = work( 1 ) + wa
182 CALL zscal( n-i, one / wb, work( 2 ), 1 )
183 work( 1 ) = one
184 tau = dble( wb / wa )
185 END IF
186*
187* apply random reflection to A(i:n,i:n) from the left
188* and the right
189*
190* compute y := tau * A * conjg(u)
191*
192 CALL zlacgv( n-i+1, work, 1 )
193 CALL zsymv( 'Lower', n-i+1, tau, a( i, i ), lda, work, 1, zero,
194 $ work( n+1 ), 1 )
195 CALL zlacgv( n-i+1, work, 1 )
196*
197* compute v := y - 1/2 * tau * ( u, y ) * u
198*
199 alpha = -half*tau*zdotc( n-i+1, work, 1, work( n+1 ), 1 )
200 CALL zaxpy( n-i+1, alpha, work, 1, work( n+1 ), 1 )
201*
202* apply the transformation as a rank-2 update to A(i:n,i:n)
203*
204* CALL ZSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1,
205* $ A( I, I ), LDA )
206*
207 DO 50 jj = i, n
208 DO 40 ii = jj, n
209 a( ii, jj ) = a( ii, jj ) -
210 $ work( ii-i+1 )*work( n+jj-i+1 ) -
211 $ work( n+ii-i+1 )*work( jj-i+1 )
212 40 CONTINUE
213 50 CONTINUE
214 60 CONTINUE
215*
216* Reduce number of subdiagonals to K
217*
218 DO 100 i = 1, n - 1 - k
219*
220* generate reflection to annihilate A(k+i+1:n,i)
221*
222 wn = dznrm2( n-k-i+1, a( k+i, i ), 1 )
223 wa = ( wn / abs( a( k+i, i ) ) )*a( k+i, i )
224 IF( wn.EQ.zero ) THEN
225 tau = zero
226 ELSE
227 wb = a( k+i, i ) + wa
228 CALL zscal( n-k-i, one / wb, a( k+i+1, i ), 1 )
229 a( k+i, i ) = one
230 tau = dble( wb / wa )
231 END IF
232*
233* apply reflection to A(k+i:n,i+1:k+i-1) from the left
234*
235 CALL zgemv( 'Conjugate transpose', n-k-i+1, k-1, one,
236 $ a( k+i, i+1 ), lda, a( k+i, i ), 1, zero, work, 1 )
237 CALL zgerc( n-k-i+1, k-1, -tau, a( k+i, i ), 1, work, 1,
238 $ a( k+i, i+1 ), lda )
239*
240* apply reflection to A(k+i:n,k+i:n) from the left and the right
241*
242* compute y := tau * A * conjg(u)
243*
244 CALL zlacgv( n-k-i+1, a( k+i, i ), 1 )
245 CALL zsymv( 'Lower', n-k-i+1, tau, a( k+i, k+i ), lda,
246 $ a( k+i, i ), 1, zero, work, 1 )
247 CALL zlacgv( n-k-i+1, a( k+i, i ), 1 )
248*
249* compute v := y - 1/2 * tau * ( u, y ) * u
250*
251 alpha = -half*tau*zdotc( n-k-i+1, a( k+i, i ), 1, work, 1 )
252 CALL zaxpy( n-k-i+1, alpha, a( k+i, i ), 1, work, 1 )
253*
254* apply symmetric rank-2 update to A(k+i:n,k+i:n)
255*
256* CALL ZSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1,
257* $ A( K+I, K+I ), LDA )
258*
259 DO 80 jj = k + i, n
260 DO 70 ii = jj, n
261 a( ii, jj ) = a( ii, jj ) - a( ii, i )*work( jj-k-i+1 ) -
262 $ work( ii-k-i+1 )*a( jj, i )
263 70 CONTINUE
264 80 CONTINUE
265*
266 a( k+i, i ) = -wa
267 DO 90 j = k + i + 1, n
268 a( j, i ) = zero
269 90 CONTINUE
270 100 CONTINUE
271*
272* Store full symmetric matrix
273*
274 DO 120 j = 1, n
275 DO 110 i = j + 1, n
276 a( j, i ) = a( i, j )
277 110 CONTINUE
278 120 CONTINUE
279 RETURN
280*
281* End of ZLAGSY
282*
zsymv
subroutine zsymv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
ZSYMV computes a matrix-vector product for a complex symmetric matrix.
Definition zsymv.f:157

◆ zlahilb()

subroutine zlahilb ( integer n,
integer nrhs,
complex*16, dimension(lda,n) a,
integer lda,
complex*16, dimension(ldx, nrhs) x,
integer ldx,
complex*16, dimension(ldb, nrhs) b,
integer ldb,
double precision, dimension(n) work,
integer info,
character*3 path )

ZLAHILB

Purpose:
!>
!> ZLAHILB generates an N by N scaled Hilbert matrix in A along with
!> NRHS right-hand sides in B and solutions in X such that A*X=B.
!>
!> The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all
!> entries are integers.  The right-hand sides are the first NRHS
!> columns of M * the identity matrix, and the solutions are the
!> first NRHS columns of the inverse Hilbert matrix.
!>
!> The condition number of the Hilbert matrix grows exponentially with
!> its size, roughly as O(e ** (3.5*N)).  Additionally, the inverse
!> Hilbert matrices beyond a relatively small dimension cannot be
!> generated exactly without extra precision.  Precision is exhausted
!> when the largest entry in the inverse Hilbert matrix is greater than
!> 2 to the power of the number of bits in the fraction of the data type
!> used plus one, which is 24 for single precision.
!>
!> In single, the generated solution is exact for N <= 6 and has
!> small componentwise error for 7 <= N <= 11.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The dimension of the matrix A.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The requested number of right-hand sides.
!>
[out]A
!>          A is COMPLEX array, dimension (LDA, N)
!>          The generated scaled Hilbert matrix.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= N.
!>
[out]X
!>          X is COMPLEX array, dimension (LDX, NRHS)
!>          The generated exact solutions.  Currently, the first NRHS
!>          columns of the inverse Hilbert matrix.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= N.
!>
[out]B
!>          B is REAL array, dimension (LDB, NRHS)
!>          The generated right-hand sides.  Currently, the first NRHS
!>          columns of LCM(1, 2, ..., 2*N-1) * the identity matrix.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= N.
!>
[out]WORK
!>          WORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          = 1: N is too large; the data is still generated but may not
!>               be not exact.
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 132 of file zlahilb.f.

134*
135* -- LAPACK test routine --
136* -- LAPACK is a software package provided by Univ. of Tennessee, --
137* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
138*
139* .. Scalar Arguments ..
140 INTEGER N, NRHS, LDA, LDX, LDB, INFO
141* .. Array Arguments ..
142 DOUBLE PRECISION WORK(N)
143 COMPLEX*16 A(LDA,N), X(LDX, NRHS), B(LDB, NRHS)
144 CHARACTER*3 PATH
145* ..
146*
147* =====================================================================
148* .. Local Scalars ..
149 INTEGER TM, TI, R
150 INTEGER M
151 INTEGER I, J
152 COMPLEX*16 TMP
153 CHARACTER*2 C2
154* ..
155* .. Parameters ..
156* NMAX_EXACT the largest dimension where the generated data is
157* exact.
158* NMAX_APPROX the largest dimension where the generated data has
159* a small componentwise relative error.
160* ??? complex uses how many bits ???
161 INTEGER NMAX_EXACT, NMAX_APPROX, SIZE_D
162 parameter(nmax_exact = 6, nmax_approx = 11, size_d = 8)
163*
164* d's are generated from random permutation of those eight elements.
165 COMPLEX*16 d1(8), d2(8), invd1(8), invd2(8)
166 DATA d1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/
167 DATA d2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/
168
169 DATA invd1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0),
170 $ (-.5,-.5),(.5,-.5),(.5,.5)/
171 DATA invd2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0),
172 $ (-.5,.5),(.5,.5),(.5,-.5)/
173* ..
174* .. External Subroutines ..
175 EXTERNAL xerbla
176* ..
177* .. External Functions
178 EXTERNAL zlaset, lsamen
179 INTRINSIC dble
180 LOGICAL LSAMEN
181* ..
182* .. Executable Statements ..
183 c2 = path( 2: 3 )
184*
185* Test the input arguments
186*
187 info = 0
188 IF (n .LT. 0 .OR. n .GT. nmax_approx) THEN
189 info = -1
190 ELSE IF (nrhs .LT. 0) THEN
191 info = -2
192 ELSE IF (lda .LT. n) THEN
193 info = -4
194 ELSE IF (ldx .LT. n) THEN
195 info = -6
196 ELSE IF (ldb .LT. n) THEN
197 info = -8
198 END IF
199 IF (info .LT. 0) THEN
200 CALL xerbla('ZLAHILB', -info)
201 RETURN
202 END IF
203 IF (n .GT. nmax_exact) THEN
204 info = 1
205 END IF
206*
207* Compute M = the LCM of the integers [1, 2*N-1]. The largest
208* reasonable N is small enough that integers suffice (up to N = 11).
209 m = 1
210 DO i = 2, (2*n-1)
211 tm = m
212 ti = i
213 r = mod(tm, ti)
214 DO WHILE (r .NE. 0)
215 tm = ti
216 ti = r
217 r = mod(tm, ti)
218 END DO
219 m = (m / ti) * i
220 END DO
221*
222* Generate the scaled Hilbert matrix in A
223* If we are testing SY routines,
224* take D1_i = D2_i, else, D1_i = D2_i*
225 IF ( lsamen( 2, c2, 'SY' ) ) THEN
226 DO j = 1, n
227 DO i = 1, n
228 a(i, j) = d1(mod(j,size_d)+1) * (dble(m) / (i + j - 1))
229 $ * d1(mod(i,size_d)+1)
230 END DO
231 END DO
232 ELSE
233 DO j = 1, n
234 DO i = 1, n
235 a(i, j) = d1(mod(j,size_d)+1) * (dble(m) / (i + j - 1))
236 $ * d2(mod(i,size_d)+1)
237 END DO
238 END DO
239 END IF
240*
241* Generate matrix B as simply the first NRHS columns of M * the
242* identity.
243 tmp = dble(m)
244 CALL zlaset('Full', n, nrhs, (0.0d+0,0.0d+0), tmp, b, ldb)
245*
246* Generate the true solutions in X. Because B = the first NRHS
247* columns of M*I, the true solutions are just the first NRHS columns
248* of the inverse Hilbert matrix.
249 work(1) = n
250 DO j = 2, n
251 work(j) = ( ( (work(j-1)/(j-1)) * (j-1 - n) ) /(j-1) )
252 $ * (n +j -1)
253 END DO
254
255* If we are testing SY routines,
256* take D1_i = D2_i, else, D1_i = D2_i*
257 IF ( lsamen( 2, c2, 'SY' ) ) THEN
258 DO j = 1, nrhs
259 DO i = 1, n
260 x(i, j) = invd1(mod(j,size_d)+1) *
261 $ ((work(i)*work(j)) / (i + j - 1))
262 $ * invd1(mod(i,size_d)+1)
263 END DO
264 END DO
265 ELSE
266 DO j = 1, nrhs
267 DO i = 1, n
268 x(i, j) = invd2(mod(j,size_d)+1) *
269 $ ((work(i)*work(j)) / (i + j - 1))
270 $ * invd1(mod(i,size_d)+1)
271 END DO
272 END DO
273 END IF
lsamen
logical function lsamen(n, ca, cb)
LSAMEN
Definition lsamen.f:74
zlaset
subroutine zlaset(uplo, m, n, alpha, beta, a, lda)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition zlaset.f:106

◆ zlakf2()

subroutine zlakf2 ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( lda, * ) b,
complex*16, dimension( lda, * ) d,
complex*16, dimension( lda, * ) e,
complex*16, dimension( ldz, * ) z,
integer ldz )

ZLAKF2

Purpose:
!>
!> Form the 2*M*N by 2*M*N matrix
!>
!>        Z = [ kron(In, A)  -kron(B', Im) ]
!>            [ kron(In, D)  -kron(E', Im) ],
!>
!> where In is the identity matrix of size n and X' is the transpose
!> of X. kron(X, Y) is the Kronecker product between the matrices X
!> and Y.
!>
Parameters
[in]M
!>          M is INTEGER
!>          Size of matrix, must be >= 1.
!>
[in]N
!>          N is INTEGER
!>          Size of matrix, must be >= 1.
!>
[in]A
!>          A is COMPLEX*16, dimension ( LDA, M )
!>          The matrix A in the output matrix Z.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A, B, D, and E. ( LDA >= M+N )
!>
[in]B
!>          B is COMPLEX*16, dimension ( LDA, N )
!>
[in]D
!>          D is COMPLEX*16, dimension ( LDA, M )
!>
[in]E
!>          E is COMPLEX*16, dimension ( LDA, N )
!>
!>          The matrices used in forming the output matrix Z.
!>
[out]Z
!>          Z is COMPLEX*16, dimension ( LDZ, 2*M*N )
!>          The resultant Kronecker M*N*2 by M*N*2 matrix (see above.)
!>
[in]LDZ
!>          LDZ is INTEGER
!>          The leading dimension of Z. ( LDZ >= 2*M*N )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 104 of file zlakf2.f.

105*
106* -- LAPACK computational routine --
107* -- LAPACK is a software package provided by Univ. of Tennessee, --
108* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
109*
110* .. Scalar Arguments ..
111 INTEGER LDA, LDZ, M, N
112* ..
113* .. Array Arguments ..
114 COMPLEX*16 A( LDA, * ), B( LDA, * ), D( LDA, * ),
115 $ E( LDA, * ), Z( LDZ, * )
116* ..
117*
118* ====================================================================
119*
120* .. Parameters ..
121 COMPLEX*16 ZERO
122 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
123* ..
124* .. Local Scalars ..
125 INTEGER I, IK, J, JK, L, MN, MN2
126* ..
127* .. External Subroutines ..
128 EXTERNAL zlaset
129* ..
130* .. Executable Statements ..
131*
132* Initialize Z
133*
134 mn = m*n
135 mn2 = 2*mn
136 CALL zlaset( 'Full', mn2, mn2, zero, zero, z, ldz )
137*
138 ik = 1
139 DO 50 l = 1, n
140*
141* form kron(In, A)
142*
143 DO 20 i = 1, m
144 DO 10 j = 1, m
145 z( ik+i-1, ik+j-1 ) = a( i, j )
146 10 CONTINUE
147 20 CONTINUE
148*
149* form kron(In, D)
150*
151 DO 40 i = 1, m
152 DO 30 j = 1, m
153 z( ik+mn+i-1, ik+j-1 ) = d( i, j )
154 30 CONTINUE
155 40 CONTINUE
156*
157 ik = ik + m
158 50 CONTINUE
159*
160 ik = 1
161 DO 90 l = 1, n
162 jk = mn + 1
163*
164 DO 80 j = 1, n
165*
166* form -kron(B', Im)
167*
168 DO 60 i = 1, m
169 z( ik+i-1, jk+i-1 ) = -b( j, l )
170 60 CONTINUE
171*
172* form -kron(E', Im)
173*
174 DO 70 i = 1, m
175 z( ik+mn+i-1, jk+i-1 ) = -e( j, l )
176 70 CONTINUE
177*
178 jk = jk + m
179 80 CONTINUE
180*
181 ik = ik + m
182 90 CONTINUE
183*
184 RETURN
185*
186* End of ZLAKF2
187*

◆ zlarge()

subroutine zlarge ( integer n,
complex*16, dimension( lda, * ) a,
integer lda,
integer, dimension( 4 ) iseed,
complex*16, dimension( * ) work,
integer info )

ZLARGE

Purpose:
!>
!> ZLARGE pre- and post-multiplies a complex general n by n matrix A
!> with a random unitary matrix: A = U*D*U'.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the original n by n matrix A.
!>          On exit, A is overwritten by U*A*U' for some random
!>          unitary matrix U.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= N.
!>
[in,out]ISEED
!>          ISEED is 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.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 86 of file zlarge.f.

87*
88* -- LAPACK auxiliary routine --
89* -- LAPACK is a software package provided by Univ. of Tennessee, --
90* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
91*
92* .. Scalar Arguments ..
93 INTEGER INFO, LDA, N
94* ..
95* .. Array Arguments ..
96 INTEGER ISEED( 4 )
97 COMPLEX*16 A( LDA, * ), WORK( * )
98* ..
99*
100* =====================================================================
101*
102* .. Parameters ..
103 COMPLEX*16 ZERO, ONE
104 parameter( zero = ( 0.0d+0, 0.0d+0 ),
105 $ one = ( 1.0d+0, 0.0d+0 ) )
106* ..
107* .. Local Scalars ..
108 INTEGER I
109 DOUBLE PRECISION WN
110 COMPLEX*16 TAU, WA, WB
111* ..
112* .. External Subroutines ..
113 EXTERNAL xerbla, zgemv, zgerc, zlarnv, zscal
114* ..
115* .. Intrinsic Functions ..
116 INTRINSIC abs, dble, max
117* ..
118* .. External Functions ..
119 DOUBLE PRECISION DZNRM2
120 EXTERNAL dznrm2
121* ..
122* .. Executable Statements ..
123*
124* Test the input arguments
125*
126 info = 0
127 IF( n.LT.0 ) THEN
128 info = -1
129 ELSE IF( lda.LT.max( 1, n ) ) THEN
130 info = -3
131 END IF
132 IF( info.LT.0 ) THEN
133 CALL xerbla( 'ZLARGE', -info )
134 RETURN
135 END IF
136*
137* pre- and post-multiply A by random unitary matrix
138*
139 DO 10 i = n, 1, -1
140*
141* generate random reflection
142*
143 CALL zlarnv( 3, iseed, n-i+1, work )
144 wn = dznrm2( n-i+1, work, 1 )
145 wa = ( wn / abs( work( 1 ) ) )*work( 1 )
146 IF( wn.EQ.zero ) THEN
147 tau = zero
148 ELSE
149 wb = work( 1 ) + wa
150 CALL zscal( n-i, one / wb, work( 2 ), 1 )
151 work( 1 ) = one
152 tau = dble( wb / wa )
153 END IF
154*
155* multiply A(i:n,1:n) by random reflection from the left
156*
157 CALL zgemv( 'Conjugate transpose', n-i+1, n, one, a( i, 1 ),
158 $ lda, work, 1, zero, work( n+1 ), 1 )
159 CALL zgerc( n-i+1, n, -tau, work, 1, work( n+1 ), 1, a( i, 1 ),
160 $ lda )
161*
162* multiply A(1:n,i:n) by random reflection from the right
163*
164 CALL zgemv( 'No transpose', n, n-i+1, one, a( 1, i ), lda,
165 $ work, 1, zero, work( n+1 ), 1 )
166 CALL zgerc( n, n-i+1, -tau, work( n+1 ), 1, work, 1, a( 1, i ),
167 $ lda )
168 10 CONTINUE
169 RETURN
170*
171* End of ZLARGE
172*

◆ zlarnd()

complex*16 function zlarnd ( integer idist,
integer, dimension( 4 ) iseed )

ZLARND

Purpose:
!>
!> ZLARND returns a random complex number from a uniform or normal
!> distribution.
!>
Parameters
[in]IDIST
!>          IDIST is 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
!>
[in,out]ISEED
!>          ISEED is 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.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
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.
!>

Definition at line 74 of file zlarnd.f.

75*
76* -- LAPACK auxiliary routine --
77* -- LAPACK is a software package provided by Univ. of Tennessee, --
78* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
79*
80* .. Scalar Arguments ..
81 INTEGER IDIST
82* ..
83* .. Array Arguments ..
84 INTEGER ISEED( 4 )
85* ..
86*
87* =====================================================================
88*
89* .. Parameters ..
90 DOUBLE PRECISION ZERO, ONE, TWO
91 parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0 )
92 DOUBLE PRECISION TWOPI
93 parameter( twopi = 6.28318530717958647692528676655900576839d+0 )
94* ..
95* .. Local Scalars ..
96 DOUBLE PRECISION T1, T2
97* ..
98* .. External Functions ..
99 DOUBLE PRECISION DLARAN
100 EXTERNAL dlaran
101* ..
102* .. Intrinsic Functions ..
103 INTRINSIC dcmplx, exp, log, sqrt
104* ..
105* .. Executable Statements ..
106*
107* Generate a pair of real random numbers from a uniform (0,1)
108* distribution
109*
110 t1 = dlaran( iseed )
111 t2 = dlaran( iseed )
112*
113 IF( idist.EQ.1 ) THEN
114*
115* real and imaginary parts each uniform (0,1)
116*
117 zlarnd = dcmplx( t1, t2 )
118 ELSE IF( idist.EQ.2 ) THEN
119*
120* real and imaginary parts each uniform (-1,1)
121*
122 zlarnd = dcmplx( two*t1-one, two*t2-one )
123 ELSE IF( idist.EQ.3 ) THEN
124*
125* real and imaginary parts each normal (0,1)
126*
127 zlarnd = sqrt( -two*log( t1 ) )*exp( dcmplx( zero, twopi*t2 ) )
128 ELSE IF( idist.EQ.4 ) THEN
129*
130* uniform distribution on the unit disc abs(z) <= 1
131*
132 zlarnd = sqrt( t1 )*exp( dcmplx( zero, twopi*t2 ) )
133 ELSE IF( idist.EQ.5 ) THEN
134*
135* uniform distribution on the unit circle abs(z) = 1
136*
137 zlarnd = exp( dcmplx( zero, twopi*t2 ) )
138 END IF
139 RETURN
140*
141* End of ZLARND
142*
zlarnd
complex *16 function zlarnd(idist, iseed)
ZLARND
Definition zlarnd.f:75
dlaran
double precision function dlaran(iseed)
DLARAN
Definition dlaran.f:67

◆ zlaror()

subroutine zlaror ( character side,
character init,
integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
integer, dimension( 4 ) iseed,
complex*16, dimension( * ) x,
integer info )

ZLAROR

Purpose:
!>
!>    ZLAROR pre- or post-multiplies an M by N matrix A by a random
!>    unitary matrix U, overwriting A. A may optionally be
!>    initialized to the identity matrix before multiplying by U.
!>    U is generated using the method of G.W. Stewart
!>    ( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ).
!>    (BLAS-2 version)
!>
Parameters
[in]SIDE
!>          SIDE is CHARACTER*1
!>           SIDE specifies whether A is multiplied on the left or right
!>           by U.
!>       SIDE = 'L'   Multiply A on the left (premultiply) by U
!>       SIDE = 'R'   Multiply A on the right (postmultiply) by UC>       SIDE = 'C'   Multiply A on the left by U and the right by UC>       SIDE = 'T'   Multiply A on the left by U and the right by U'
!>           Not modified.
!>
[in]INIT
!>          INIT is CHARACTER*1
!>           INIT specifies whether or not A should be initialized to
!>           the identity matrix.
!>              INIT = 'I'   Initialize A to (a section of) the
!>                           identity matrix before applying U.
!>              INIT = 'N'   No initialization.  Apply U to the
!>                           input matrix A.
!>
!>           INIT = 'I' may be used to generate square (i.e., unitary)
!>           or rectangular orthogonal matrices (orthogonality being
!>           in the sense of ZDOTC):
!>
!>           For square matrices, M=N, and SIDE many be either 'L' or
!>           'R'; the rows will be orthogonal to each other, as will the
!>           columns.
!>           For rectangular matrices where M < N, SIDE = 'R' will
!>           produce a dense matrix whose rows will be orthogonal and
!>           whose columns will not, while SIDE = 'L' will produce a
!>           matrix whose rows will be orthogonal, and whose first M
!>           columns will be orthogonal, the remaining columns being
!>           zero.
!>           For matrices where M > N, just use the previous
!>           explanation, interchanging 'L' and 'R' and  and
!>           .
!>
!>           Not modified.
!>
[in]M
!>          M is INTEGER
!>           Number of rows of A. Not modified.
!>
[in]N
!>          N is INTEGER
!>           Number of columns of A. Not modified.
!>
[in,out]A
!>           A is COMPLEX*16 array, dimension ( LDA, N )
!>           Input and output array. Overwritten by U A ( if SIDE = 'L' )
!>           or by A U ( if SIDE = 'R' )
!>           or by U A U* ( if SIDE = 'C')
!>           or by U A U' ( if SIDE = 'T') on exit.
!>
[in]LDA
!>          LDA is INTEGER
!>           Leading dimension of A. Must be at least MAX ( 1, M ).
!>           Not modified.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension ( 4 )
!>           On entry ISEED specifies the seed of the random number
!>           generator. The array elements should be between 0 and 4095;
!>           if not they will be reduced mod 4096.  Also, ISEED(4) must
!>           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 ZLAROR to continue the same random number
!>           sequence.
!>           Modified.
!>
[out]X
!>          X is COMPLEX*16 array, dimension ( 3*MAX( M, N ) )
!>           Workspace. Of length:
!>               2*M + N if SIDE = 'L',
!>               2*N + M if SIDE = 'R',
!>               3*N     if SIDE = 'C' or 'T'.
!>           Modified.
!>
[out]INFO
!>          INFO is INTEGER
!>           An error flag.  It is set to:
!>            0  if no error.
!>            1  if ZLARND returned a bad random number (installation
!>               problem)
!>           -1  if SIDE is not L, R, C, or T.
!>           -3  if M is negative.
!>           -4  if N is negative or if SIDE is C or T and N is not equal
!>               to M.
!>           -6  if LDA is less than M.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 157 of file zlaror.f.

158*
159* -- LAPACK auxiliary routine --
160* -- LAPACK is a software package provided by Univ. of Tennessee, --
161* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
162*
163* .. Scalar Arguments ..
164 CHARACTER INIT, SIDE
165 INTEGER INFO, LDA, M, N
166* ..
167* .. Array Arguments ..
168 INTEGER ISEED( 4 )
169 COMPLEX*16 A( LDA, * ), X( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 DOUBLE PRECISION ZERO, ONE, TOOSML
176 parameter( zero = 0.0d+0, one = 1.0d+0,
177 $ toosml = 1.0d-20 )
178 COMPLEX*16 CZERO, CONE
179 parameter( czero = ( 0.0d+0, 0.0d+0 ),
180 $ cone = ( 1.0d+0, 0.0d+0 ) )
181* ..
182* .. Local Scalars ..
183 INTEGER IROW, ITYPE, IXFRM, J, JCOL, KBEG, NXFRM
184 DOUBLE PRECISION FACTOR, XABS, XNORM
185 COMPLEX*16 CSIGN, XNORMS
186* ..
187* .. External Functions ..
188 LOGICAL LSAME
189 DOUBLE PRECISION DZNRM2
190 COMPLEX*16 ZLARND
191 EXTERNAL lsame, dznrm2, zlarnd
192* ..
193* .. External Subroutines ..
194 EXTERNAL xerbla, zgemv, zgerc, zlacgv, zlaset, zscal
195* ..
196* .. Intrinsic Functions ..
197 INTRINSIC abs, dcmplx, dconjg
198* ..
199* .. Executable Statements ..
200*
201 info = 0
202 IF( n.EQ.0 .OR. m.EQ.0 )
203 $ RETURN
204*
205 itype = 0
206 IF( lsame( side, 'L' ) ) THEN
207 itype = 1
208 ELSE IF( lsame( side, 'R' ) ) THEN
209 itype = 2
210 ELSE IF( lsame( side, 'C' ) ) THEN
211 itype = 3
212 ELSE IF( lsame( side, 'T' ) ) THEN
213 itype = 4
214 END IF
215*
216* Check for argument errors.
217*
218 IF( itype.EQ.0 ) THEN
219 info = -1
220 ELSE IF( m.LT.0 ) THEN
221 info = -3
222 ELSE IF( n.LT.0 .OR. ( itype.EQ.3 .AND. n.NE.m ) ) THEN
223 info = -4
224 ELSE IF( lda.LT.m ) THEN
225 info = -6
226 END IF
227 IF( info.NE.0 ) THEN
228 CALL xerbla( 'ZLAROR', -info )
229 RETURN
230 END IF
231*
232 IF( itype.EQ.1 ) THEN
233 nxfrm = m
234 ELSE
235 nxfrm = n
236 END IF
237*
238* Initialize A to the identity matrix if desired
239*
240 IF( lsame( init, 'I' ) )
241 $ CALL zlaset( 'Full', m, n, czero, cone, a, lda )
242*
243* If no rotation possible, still multiply by
244* a random complex number from the circle |x| = 1
245*
246* 2) Compute Rotation by computing Householder
247* Transformations H(2), H(3), ..., H(n). Note that the
248* order in which they are computed is irrelevant.
249*
250 DO 10 j = 1, nxfrm
251 x( j ) = czero
252 10 CONTINUE
253*
254 DO 30 ixfrm = 2, nxfrm
255 kbeg = nxfrm - ixfrm + 1
256*
257* Generate independent normal( 0, 1 ) random numbers
258*
259 DO 20 j = kbeg, nxfrm
260 x( j ) = zlarnd( 3, iseed )
261 20 CONTINUE
262*
263* Generate a Householder transformation from the random vector X
264*
265 xnorm = dznrm2( ixfrm, x( kbeg ), 1 )
266 xabs = abs( x( kbeg ) )
267 IF( xabs.NE.czero ) THEN
268 csign = x( kbeg ) / xabs
269 ELSE
270 csign = cone
271 END IF
272 xnorms = csign*xnorm
273 x( nxfrm+kbeg ) = -csign
274 factor = xnorm*( xnorm+xabs )
275 IF( abs( factor ).LT.toosml ) THEN
276 info = 1
277 CALL xerbla( 'ZLAROR', -info )
278 RETURN
279 ELSE
280 factor = one / factor
281 END IF
282 x( kbeg ) = x( kbeg ) + xnorms
283*
284* Apply Householder transformation to A
285*
286 IF( itype.EQ.1 .OR. itype.EQ.3 .OR. itype.EQ.4 ) THEN
287*
288* Apply H(k) on the left of A
289*
290 CALL zgemv( 'C', ixfrm, n, cone, a( kbeg, 1 ), lda,
291 $ x( kbeg ), 1, czero, x( 2*nxfrm+1 ), 1 )
292 CALL zgerc( ixfrm, n, -dcmplx( factor ), x( kbeg ), 1,
293 $ x( 2*nxfrm+1 ), 1, a( kbeg, 1 ), lda )
294*
295 END IF
296*
297 IF( itype.GE.2 .AND. itype.LE.4 ) THEN
298*
299* Apply H(k)* (or H(k)') on the right of A
300*
301 IF( itype.EQ.4 ) THEN
302 CALL zlacgv( ixfrm, x( kbeg ), 1 )
303 END IF
304*
305 CALL zgemv( 'N', m, ixfrm, cone, a( 1, kbeg ), lda,
306 $ x( kbeg ), 1, czero, x( 2*nxfrm+1 ), 1 )
307 CALL zgerc( m, ixfrm, -dcmplx( factor ), x( 2*nxfrm+1 ), 1,
308 $ x( kbeg ), 1, a( 1, kbeg ), lda )
309*
310 END IF
311 30 CONTINUE
312*
313 x( 1 ) = zlarnd( 3, iseed )
314 xabs = abs( x( 1 ) )
315 IF( xabs.NE.zero ) THEN
316 csign = x( 1 ) / xabs
317 ELSE
318 csign = cone
319 END IF
320 x( 2*nxfrm ) = csign
321*
322* Scale the matrix A by D.
323*
324 IF( itype.EQ.1 .OR. itype.EQ.3 .OR. itype.EQ.4 ) THEN
325 DO 40 irow = 1, m
326 CALL zscal( n, dconjg( x( nxfrm+irow ) ), a( irow, 1 ),
327 $ lda )
328 40 CONTINUE
329 END IF
330*
331 IF( itype.EQ.2 .OR. itype.EQ.3 ) THEN
332 DO 50 jcol = 1, n
333 CALL zscal( m, x( nxfrm+jcol ), a( 1, jcol ), 1 )
334 50 CONTINUE
335 END IF
336*
337 IF( itype.EQ.4 ) THEN
338 DO 60 jcol = 1, n
339 CALL zscal( m, dconjg( x( nxfrm+jcol ) ), a( 1, jcol ), 1 )
340 60 CONTINUE
341 END IF
342 RETURN
343*
344* End of ZLAROR
345*
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53

◆ zlarot()

subroutine zlarot ( logical lrows,
logical lleft,
logical lright,
integer nl,
complex*16 c,
complex*16 s,
complex*16, dimension( * ) a,
integer lda,
complex*16 xleft,
complex*16 xright )

ZLAROT

Purpose:
!>
!>    ZLAROT applies a (Givens) rotation to two adjacent rows or
!>    columns, where one element of the first and/or last column/row
!>    for use on matrices stored in some format other than GE, so
!>    that elements of the matrix may be used or modified for which
!>    no array element is provided.
!>
!>    One example is a symmetric matrix in SB format (bandwidth=4), for
!>    which UPLO='L':  Two adjacent rows will have the format:
!>
!>    row j:     C> C> C> C> C> .  .  .  .
!>    row j+1:      C> C> C> C> C> .  .  .  .
!>
!>    '*' indicates elements for which storage is provided,
!>    '.' indicates elements for which no storage is provided, but
!>    are not necessarily zero; their values are determined by
!>    symmetry.  ' ' indicates elements which are necessarily zero,
!>     and have no storage provided.
!>
!>    Those columns which have two '*'s can be handled by DROT.
!>    Those columns which have no '*'s can be ignored, since as long
!>    as the Givens rotations are carefully applied to preserve
!>    symmetry, their values are determined.
!>    Those columns which have one '*' have to be handled separately,
!>    by using separate variables  and :
!>
!>    row j:     C> C> C> C> C> p  .  .  .
!>    row j+1:   q  C> C> C> C> C> .  .  .  .
!>
!>    The element p would have to be set correctly, then that column
!>    is rotated, setting p to its new value.  The next call to
!>    ZLAROT would rotate columns j and j+1, using p, and restore
!>    symmetry.  The element q would start out being zero, and be
!>    made non-zero by the rotation.  Later, rotations would presumably
!>    be chosen to zero q out.
!>
!>    Typical Calling Sequences: rotating the i-th and (i+1)-st rows.
!>    ------- ------- ---------
!>
!>      General dense matrix:
!>
!>              CALL ZLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S,
!>                      A(i,1),LDA, DUMMY, DUMMY)
!>
!>      General banded matrix in GB format:
!>
!>              j = MAX(1, i-KL )
!>              NL = MIN( N, i+KU+1 ) + 1-j
!>              CALL ZLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S,
!>                      A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT )
!>
!>              [ note that i+1-j is just MIN(i,KL+1) ]
!>
!>      Symmetric banded matrix in SY format, bandwidth K,
!>      lower triangle only:
!>
!>              j = MAX(1, i-K )
!>              NL = MIN( K+1, i ) + 1
!>              CALL ZLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S,
!>                      A(i,j), LDA, XLEFT, XRIGHT )
!>
!>      Same, but upper triangle only:
!>
!>              NL = MIN( K+1, N-i ) + 1
!>              CALL ZLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S,
!>                      A(i,i), LDA, XLEFT, XRIGHT )
!>
!>      Symmetric banded matrix in SB format, bandwidth K,
!>      lower triangle only:
!>
!>              [ same as for SY, except:]
!>                  . . . .
!>                      A(i+1-j,j), LDA-1, XLEFT, XRIGHT )
!>
!>              [ note that i+1-j is just MIN(i,K+1) ]
!>
!>      Same, but upper triangle only:
!>                  . . .
!>                      A(K+1,i), LDA-1, XLEFT, XRIGHT )
!>
!>      Rotating columns is just the transpose of rotating rows, except
!>      for GB and SB: (rotating columns i and i+1)
!>
!>      GB:
!>              j = MAX(1, i-KU )
!>              NL = MIN( N, i+KL+1 ) + 1-j
!>              CALL ZLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S,
!>                      A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM )
!>
!>              [note that KU+j+1-i is just MAX(1,KU+2-i)]
!>
!>      SB: (upper triangle)
!>
!>                   . . . . . .
!>                      A(K+j+1-i,i),LDA-1, XTOP, XBOTTM )
!>
!>      SB: (lower triangle)
!>
!>                   . . . . . .
!>                      A(1,i),LDA-1, XTOP, XBOTTM )
!> 
!>  LROWS  - LOGICAL
!>           If .TRUE., then ZLAROT will rotate two rows.  If .FALSE.,
!>           then it will rotate two columns.
!>           Not modified.
!>
!>  LLEFT  - LOGICAL
!>           If .TRUE., then XLEFT will be used instead of the
!>           corresponding element of A for the first element in the
!>           second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.)
!>           If .FALSE., then the corresponding element of A will be
!>           used.
!>           Not modified.
!>
!>  LRIGHT - LOGICAL
!>           If .TRUE., then XRIGHT will be used instead of the
!>           corresponding element of A for the last element in the
!>           first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If
!>           .FALSE., then the corresponding element of A will be used.
!>           Not modified.
!>
!>  NL     - INTEGER
!>           The length of the rows (if LROWS=.TRUE.) or columns (if
!>           LROWS=.FALSE.) to be rotated.  If XLEFT and/or XRIGHT are
!>           used, the columns/rows they are in should be included in
!>           NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at
!>           least 2.  The number of rows/columns to be rotated
!>           exclusive of those involving XLEFT and/or XRIGHT may
!>           not be negative, i.e., NL minus how many of LLEFT and
!>           LRIGHT are .TRUE. must be at least zero; if not, XERBLA
!>           will be called.
!>           Not modified.
!>
!>  C, S   - COMPLEX*16
!>           Specify the Givens rotation to be applied.  If LROWS is
!>           true, then the matrix ( c  s )
!>                                 ( _  _ )
!>                                 (-s  c )  is applied from the left;
!>           if false, then the transpose (not conjugated) thereof is
!>           applied from the right.  Note that in contrast to the
!>           output of ZROTG or to most versions of ZROT, both C and S
!>           are complex.  For a Givens rotation, |C|**2 + |S|**2 should
!>           be 1, but this is not checked.
!>           Not modified.
!>
!>  A      - COMPLEX*16 array.
!>           The array containing the rows/columns to be rotated.  The
!>           first element of A should be the upper left element to
!>           be rotated.
!>           Read and modified.
!>
!>  LDA    - INTEGER
!>           The  leading dimension of A.  If A contains
!>           a matrix stored in GE, HE, or SY format, then this is just
!>           the leading dimension of A as dimensioned in the calling
!>           routine.  If A contains a matrix stored in band (GB, HB, or
!>           SB) format, then this should be *one less* than the leading
!>           dimension used in the calling routine.  Thus, if A were
!>           dimensioned A(LDA,*) in ZLAROT, then A(1,j) would be the
!>           j-th element in the first of the two rows to be rotated,
!>           and A(2,j) would be the j-th in the second, regardless of
!>           how the array may be stored in the calling routine.  [A
!>           cannot, however, actually be dimensioned thus, since for
!>           band format, the row number may exceed LDA, which is not
!>           legal FORTRAN.]
!>           If LROWS=.TRUE., then LDA must be at least 1, otherwise
!>           it must be at least NL minus the number of .TRUE. values
!>           in XLEFT and XRIGHT.
!>           Not modified.
!>
!>  XLEFT  - COMPLEX*16
!>           If LLEFT is .TRUE., then XLEFT will be used and modified
!>           instead of A(2,1) (if LROWS=.TRUE.) or A(1,2)
!>           (if LROWS=.FALSE.).
!>           Read and modified.
!>
!>  XRIGHT - COMPLEX*16
!>           If LRIGHT is .TRUE., then XRIGHT will be used and modified
!>           instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1)
!>           (if LROWS=.FALSE.).
!>           Read and modified.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 227 of file zlarot.f.

229*
230* -- LAPACK auxiliary routine --
231* -- LAPACK is a software package provided by Univ. of Tennessee, --
232* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
233*
234* .. Scalar Arguments ..
235 LOGICAL LLEFT, LRIGHT, LROWS
236 INTEGER LDA, NL
237 COMPLEX*16 C, S, XLEFT, XRIGHT
238* ..
239* .. Array Arguments ..
240 COMPLEX*16 A( * )
241* ..
242*
243* =====================================================================
244*
245* .. Local Scalars ..
246 INTEGER IINC, INEXT, IX, IY, IYT, J, NT
247 COMPLEX*16 TEMPX
248* ..
249* .. Local Arrays ..
250 COMPLEX*16 XT( 2 ), YT( 2 )
251* ..
252* .. External Subroutines ..
253 EXTERNAL xerbla
254* ..
255* .. Intrinsic Functions ..
256 INTRINSIC dconjg
257* ..
258* .. Executable Statements ..
259*
260* Set up indices, arrays for ends
261*
262 IF( lrows ) THEN
263 iinc = lda
264 inext = 1
265 ELSE
266 iinc = 1
267 inext = lda
268 END IF
269*
270 IF( lleft ) THEN
271 nt = 1
272 ix = 1 + iinc
273 iy = 2 + lda
274 xt( 1 ) = a( 1 )
275 yt( 1 ) = xleft
276 ELSE
277 nt = 0
278 ix = 1
279 iy = 1 + inext
280 END IF
281*
282 IF( lright ) THEN
283 iyt = 1 + inext + ( nl-1 )*iinc
284 nt = nt + 1
285 xt( nt ) = xright
286 yt( nt ) = a( iyt )
287 END IF
288*
289* Check for errors
290*
291 IF( nl.LT.nt ) THEN
292 CALL xerbla( 'ZLAROT', 4 )
293 RETURN
294 END IF
295 IF( lda.LE.0 .OR. ( .NOT.lrows .AND. lda.LT.nl-nt ) ) THEN
296 CALL xerbla( 'ZLAROT', 8 )
297 RETURN
298 END IF
299*
300* Rotate
301*
302* ZROT( NL-NT, A(IX),IINC, A(IY),IINC, C, S ) with complex C, S
303*
304 DO 10 j = 0, nl - nt - 1
305 tempx = c*a( ix+j*iinc ) + s*a( iy+j*iinc )
306 a( iy+j*iinc ) = -dconjg( s )*a( ix+j*iinc ) +
307 $ dconjg( c )*a( iy+j*iinc )
308 a( ix+j*iinc ) = tempx
309 10 CONTINUE
310*
311* ZROT( NT, XT,1, YT,1, C, S ) with complex C, S
312*
313 DO 20 j = 1, nt
314 tempx = c*xt( j ) + s*yt( j )
315 yt( j ) = -dconjg( s )*xt( j ) + dconjg( c )*yt( j )
316 xt( j ) = tempx
317 20 CONTINUE
318*
319* Stuff values back into XLEFT, XRIGHT, etc.
320*
321 IF( lleft ) THEN
322 a( 1 ) = xt( 1 )
323 xleft = yt( 1 )
324 END IF
325*
326 IF( lright ) THEN
327 xright = xt( nt )
328 a( iyt ) = yt( nt )
329 END IF
330*
331 RETURN
332*
333* End of ZLAROT
334*
nl
character *2 function nl()
Definition message.F:2354

◆ zlatm1()

subroutine zlatm1 ( integer mode,
double precision cond,
integer irsign,
integer idist,
integer, dimension( 4 ) iseed,
complex*16, dimension( * ) d,
integer n,
integer info )

ZLATM1

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 ZLATMR to generate
!>    random test matrices for LAPACK programs.
!>
Parameters
[in]MODE
!>          MODE is 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.
!>
[in]COND
!>          COND is DOUBLE PRECISION
!>           On entry, used as described under MODE above.
!>           If used, it must be >= 1. Not modified.
!>
[in]IRSIGN
!>          IRSIGN is 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
!>
[in]IDIST
!>          IDIST is 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.
!>
[in,out]ISEED
!>          ISEED is 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.
!>
[in,out]D
!>          D is COMPLEX*16 array, dimension ( N )
!>           Array to be computed according to MODE, COND and IRSIGN.
!>           May be changed on exit if MODE is nonzero.
!>
[in]N
!>          N is INTEGER
!>           Number of entries of D. Not modified.
!>
[out]INFO
!>          INFO is 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
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 136 of file zlatm1.f.

137*
138* -- LAPACK auxiliary routine --
139* -- LAPACK is a software package provided by Univ. of Tennessee, --
140* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
141*
142* .. Scalar Arguments ..
143 INTEGER IDIST, INFO, IRSIGN, MODE, N
144 DOUBLE PRECISION COND
145* ..
146* .. Array Arguments ..
147 INTEGER ISEED( 4 )
148 COMPLEX*16 D( * )
149* ..
150*
151* =====================================================================
152*
153* .. Parameters ..
154 DOUBLE PRECISION ONE
155 parameter( one = 1.0d0 )
156* ..
157* .. Local Scalars ..
158 INTEGER I
159 DOUBLE PRECISION ALPHA, TEMP
160 COMPLEX*16 CTEMP
161* ..
162* .. External Functions ..
163 DOUBLE PRECISION DLARAN
164 COMPLEX*16 ZLARND
165 EXTERNAL dlaran, zlarnd
166* ..
167* .. External Subroutines ..
168 EXTERNAL xerbla, zlarnv
169* ..
170* .. Intrinsic Functions ..
171 INTRINSIC abs, dble, exp, log
172* ..
173* .. Executable Statements ..
174*
175* Decode and Test the input parameters. Initialize flags & seed.
176*
177 info = 0
178*
179* Quick return if possible
180*
181 IF( n.EQ.0 )
182 $ RETURN
183*
184* Set INFO if an error
185*
186 IF( mode.LT.-6 .OR. mode.GT.6 ) THEN
187 info = -1
188 ELSE IF( ( mode.NE.-6 .AND. mode.NE.0 .AND. mode.NE.6 ) .AND.
189 $ ( irsign.NE.0 .AND. irsign.NE.1 ) ) THEN
190 info = -2
191 ELSE IF( ( mode.NE.-6 .AND. mode.NE.0 .AND. mode.NE.6 ) .AND.
192 $ cond.LT.one ) THEN
193 info = -3
194 ELSE IF( ( mode.EQ.6 .OR. mode.EQ.-6 ) .AND.
195 $ ( idist.LT.1 .OR. idist.GT.4 ) ) THEN
196 info = -4
197 ELSE IF( n.LT.0 ) THEN
198 info = -7
199 END IF
200*
201 IF( info.NE.0 ) THEN
202 CALL xerbla( 'ZLATM1', -info )
203 RETURN
204 END IF
205*
206* Compute D according to COND and MODE
207*
208 IF( mode.NE.0 ) THEN
209 GO TO ( 10, 30, 50, 70, 90, 110 )abs( mode )
210*
211* One large D value:
212*
213 10 CONTINUE
214 DO 20 i = 1, n
215 d( i ) = one / cond
216 20 CONTINUE
217 d( 1 ) = one
218 GO TO 120
219*
220* One small D value:
221*
222 30 CONTINUE
223 DO 40 i = 1, n
224 d( i ) = one
225 40 CONTINUE
226 d( n ) = one / cond
227 GO TO 120
228*
229* Exponentially distributed D values:
230*
231 50 CONTINUE
232 d( 1 ) = one
233 IF( n.GT.1 ) THEN
234 alpha = cond**( -one / dble( n-1 ) )
235 DO 60 i = 2, n
236 d( i ) = alpha**( i-1 )
237 60 CONTINUE
238 END IF
239 GO TO 120
240*
241* Arithmetically distributed D values:
242*
243 70 CONTINUE
244 d( 1 ) = one
245 IF( n.GT.1 ) THEN
246 temp = one / cond
247 alpha = ( one-temp ) / dble( n-1 )
248 DO 80 i = 2, n
249 d( i ) = dble( n-i )*alpha + temp
250 80 CONTINUE
251 END IF
252 GO TO 120
253*
254* Randomly distributed D values on ( 1/COND , 1):
255*
256 90 CONTINUE
257 alpha = log( one / cond )
258 DO 100 i = 1, n
259 d( i ) = exp( alpha*dlaran( iseed ) )
260 100 CONTINUE
261 GO TO 120
262*
263* Randomly distributed D values from IDIST
264*
265 110 CONTINUE
266 CALL zlarnv( idist, iseed, n, d )
267*
268 120 CONTINUE
269*
270* If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign
271* random signs to D
272*
273 IF( ( mode.NE.-6 .AND. mode.NE.0 .AND. mode.NE.6 ) .AND.
274 $ irsign.EQ.1 ) THEN
275 DO 130 i = 1, n
276 ctemp = zlarnd( 3, iseed )
277 d( i ) = d( i )*( ctemp / abs( ctemp ) )
278 130 CONTINUE
279 END IF
280*
281* Reverse if MODE < 0
282*
283 IF( mode.LT.0 ) THEN
284 DO 140 i = 1, n / 2
285 ctemp = d( i )
286 d( i ) = d( n+1-i )
287 d( n+1-i ) = ctemp
288 140 CONTINUE
289 END IF
290*
291 END IF
292*
293 RETURN
294*
295* End of ZLATM1
296*

◆ zlatm2()

complex*16 function zlatm2 ( integer m,
integer n,
integer i,
integer j,
integer kl,
integer ku,
integer idist,
integer, dimension( 4 ) iseed,
complex*16, dimension( * ) d,
integer igrade,
complex*16, dimension( * ) dl,
complex*16, dimension( * ) dr,
integer ipvtng,
integer, dimension( * ) iwork,
double precision sparse )

ZLATM2

Purpose:
!>
!>    ZLATM2 returns the (I,J) entry of a random matrix of dimension
!>    (M, N) described by the other parameters. 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.
!>
Parameters
[in]M
!>          M is INTEGER
!>           Number of rows of matrix. Not modified.
!>
[in]N
!>          N is INTEGER
!>           Number of columns of matrix. Not modified.
!>
[in]I
!>          I is INTEGER
!>           Row of entry to be returned. Not modified.
!>
[in]J
!>          J is INTEGER
!>           Column of entry to be returned. Not modified.
!>
[in]KL
!>          KL is INTEGER
!>           Lower bandwidth. Not modified.
!>
[in]KU
!>          KU is INTEGER
!>           Upper bandwidth. Not modified.
!>
[in]IDIST
!>          IDIST is 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.
!>
[in,out]ISEED
!>          ISEED is INTEGER array of dimension ( 4 )
!>           Seed for random number generator.
!>           Changed on exit.
!>
[in]D
!>          D is COMPLEX*16 array of dimension ( MIN( I , J ) )
!>           Diagonal entries of matrix. Not modified.
!>
[in]IGRADE
!>          IGRADE is 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.
!>
[in]DL
!>          DL is COMPLEX*16 array ( I or J, as appropriate )
!>           Left scale factors for grading matrix.  Not modified.
!>
[in]DR
!>          DR is COMPLEX*16 array ( I or J, as appropriate )
!>           Right scale factors for grading matrix.  Not modified.
!>
[in]IPVTNG
!>          IPVTNG is 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.
!>
[out]IWORK
!>          IWORK is 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.
!>
[in]SPARSE
!>          SPARSE is DOUBLE PRECISION between 0. and 1.
!>           On entry specifies the sparsity of the matrix
!>           if sparse matrix 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.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 209 of file zlatm2.f.

211*
212* -- LAPACK auxiliary routine --
213* -- LAPACK is a software package provided by Univ. of Tennessee, --
214* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
215*
216* .. Scalar Arguments ..
217*
218 INTEGER I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N
219 DOUBLE PRECISION SPARSE
220* ..
221*
222* .. Array Arguments ..
223*
224 INTEGER ISEED( 4 ), IWORK( * )
225 COMPLEX*16 D( * ), DL( * ), DR( * )
226* ..
227*
228* =====================================================================
229*
230* .. Parameters ..
231*
232 COMPLEX*16 CZERO
233 parameter( czero = ( 0.0d0, 0.0d0 ) )
234 DOUBLE PRECISION ZERO
235 parameter( zero = 0.0d0 )
236* ..
237*
238* .. Local Scalars ..
239*
240 INTEGER ISUB, JSUB
241 COMPLEX*16 CTEMP
242* ..
243*
244* .. External Functions ..
245*
246 DOUBLE PRECISION DLARAN
247 COMPLEX*16 ZLARND
248 EXTERNAL dlaran, zlarnd
249* ..
250*
251* .. Intrinsic Functions ..
252*
253 INTRINSIC dconjg
254* ..
255*
256*-----------------------------------------------------------------------
257*
258* .. Executable Statements ..
259*
260*
261* Check for I and J in range
262*
263 IF( i.LT.1 .OR. i.GT.m .OR. j.LT.1 .OR. j.GT.n ) THEN
264 zlatm2 = czero
265 RETURN
266 END IF
267*
268* Check for banding
269*
270 IF( j.GT.i+ku .OR. j.LT.i-kl ) THEN
271 zlatm2 = czero
272 RETURN
273 END IF
274*
275* Check for sparsity
276*
277 IF( sparse.GT.zero ) THEN
278 IF( dlaran( iseed ).LT.sparse ) THEN
279 zlatm2 = czero
280 RETURN
281 END IF
282 END IF
283*
284* Compute subscripts depending on IPVTNG
285*
286 IF( ipvtng.EQ.0 ) THEN
287 isub = i
288 jsub = j
289 ELSE IF( ipvtng.EQ.1 ) THEN
290 isub = iwork( i )
291 jsub = j
292 ELSE IF( ipvtng.EQ.2 ) THEN
293 isub = i
294 jsub = iwork( j )
295 ELSE IF( ipvtng.EQ.3 ) THEN
296 isub = iwork( i )
297 jsub = iwork( j )
298 END IF
299*
300* Compute entry and grade it according to IGRADE
301*
302 IF( isub.EQ.jsub ) THEN
303 ctemp = d( isub )
304 ELSE
305 ctemp = zlarnd( idist, iseed )
306 END IF
307 IF( igrade.EQ.1 ) THEN
308 ctemp = ctemp*dl( isub )
309 ELSE IF( igrade.EQ.2 ) THEN
310 ctemp = ctemp*dr( jsub )
311 ELSE IF( igrade.EQ.3 ) THEN
312 ctemp = ctemp*dl( isub )*dr( jsub )
313 ELSE IF( igrade.EQ.4 .AND. isub.NE.jsub ) THEN
314 ctemp = ctemp*dl( isub ) / dl( jsub )
315 ELSE IF( igrade.EQ.5 ) THEN
316 ctemp = ctemp*dl( isub )*dconjg( dl( jsub ) )
317 ELSE IF( igrade.EQ.6 ) THEN
318 ctemp = ctemp*dl( isub )*dl( jsub )
319 END IF
320 zlatm2 = ctemp
321 RETURN
322*
323* End of ZLATM2
324*
zlatm2
complex *16 function zlatm2(m, n, i, j, kl, ku, idist, iseed, d, igrade, dl, dr, ipvtng, iwork, sparse)
ZLATM2
Definition zlatm2.f:211

◆ zlatm3()

complex*16 function zlatm3 ( integer m,
integer n,
integer i,
integer j,
integer isub,
integer jsub,
integer kl,
integer ku,
integer idist,
integer, dimension( 4 ) iseed,
complex*16, dimension( * ) d,
integer igrade,
complex*16, dimension( * ) dl,
complex*16, dimension( * ) dr,
integer ipvtng,
integer, dimension( * ) iwork,
double precision sparse )

ZLATM3

Purpose:
!>
!>    ZLATM3 returns the (ISUB,JSUB) entry of a random matrix of
!>    dimension (M, N) described by the other parameters. (ISUB,JSUB)
!>    is the final position of the (I,J) entry after pivoting
!>    according to IPVTNG and IWORK. ZLATM3 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 ZLATM3 differs from CLATM2 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
!>    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.
!>
Parameters
[in]M
!>          M is INTEGER
!>           Number of rows of matrix. Not modified.
!>
[in]N
!>          N is INTEGER
!>           Number of columns of matrix. Not modified.
!>
[in]I
!>          I is INTEGER
!>           Row of unpivoted entry to be returned. Not modified.
!>
[in]J
!>          J is INTEGER
!>           Column of unpivoted entry to be returned. Not modified.
!>
[in,out]ISUB
!>          ISUB is INTEGER
!>           Row of pivoted entry to be returned. Changed on exit.
!>
[in,out]JSUB
!>          JSUB is INTEGER
!>           Column of pivoted entry to be returned. Changed on exit.
!>
[in]KL
!>          KL is INTEGER
!>           Lower bandwidth. Not modified.
!>
[in]KU
!>          KU is INTEGER
!>           Upper bandwidth. Not modified.
!>
[in]IDIST
!>          IDIST is 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.
!>
[in,out]ISEED
!>          ISEED is INTEGER array of dimension ( 4 )
!>           Seed for random number generator.
!>           Changed on exit.
!>
[in]D
!>          D is COMPLEX*16 array of dimension ( MIN( I , J ) )
!>           Diagonal entries of matrix. Not modified.
!>
[in]IGRADE
!>          IGRADE is 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.
!>
[in]DL
!>          DL is COMPLEX*16 array ( I or J, as appropriate )
!>           Left scale factors for grading matrix.  Not modified.
!>
[in]DR
!>          DR is COMPLEX*16 array ( I or J, as appropriate )
!>           Right scale factors for grading matrix.  Not modified.
!>
[in]IPVTNG
!>          IPVTNG is 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.
!>
[in]IWORK
!>          IWORK is 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 ZLATM2. Not modified.
!>
[in]SPARSE
!>          SPARSE is DOUBLE PRECISION between 0. and 1.
!>           On entry specifies the sparsity of the matrix
!>           if sparse matrix 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.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 226 of file zlatm3.f.

229*
230* -- LAPACK auxiliary routine --
231* -- LAPACK is a software package provided by Univ. of Tennessee, --
232* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
233*
234* .. Scalar Arguments ..
235*
236 INTEGER I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL,
237 $ KU, M, N
238 DOUBLE PRECISION SPARSE
239* ..
240*
241* .. Array Arguments ..
242*
243 INTEGER ISEED( 4 ), IWORK( * )
244 COMPLEX*16 D( * ), DL( * ), DR( * )
245* ..
246*
247* =====================================================================
248*
249* .. Parameters ..
250*
251 DOUBLE PRECISION ZERO
252 parameter( zero = 0.0d0 )
253 COMPLEX*16 CZERO
254 parameter( czero = ( 0.0d0, 0.0d0 ) )
255* ..
256*
257* .. Local Scalars ..
258*
259 COMPLEX*16 CTEMP
260* ..
261*
262* .. External Functions ..
263*
264 DOUBLE PRECISION DLARAN
265 COMPLEX*16 ZLARND
266 EXTERNAL dlaran, zlarnd
267* ..
268*
269* .. Intrinsic Functions ..
270*
271 INTRINSIC dconjg
272* ..
273*
274*-----------------------------------------------------------------------
275*
276* .. Executable Statements ..
277*
278*
279* Check for I and J in range
280*
281 IF( i.LT.1 .OR. i.GT.m .OR. j.LT.1 .OR. j.GT.n ) THEN
282 isub = i
283 jsub = j
284 zlatm3 = czero
285 RETURN
286 END IF
287*
288* Compute subscripts depending on IPVTNG
289*
290 IF( ipvtng.EQ.0 ) THEN
291 isub = i
292 jsub = j
293 ELSE IF( ipvtng.EQ.1 ) THEN
294 isub = iwork( i )
295 jsub = j
296 ELSE IF( ipvtng.EQ.2 ) THEN
297 isub = i
298 jsub = iwork( j )
299 ELSE IF( ipvtng.EQ.3 ) THEN
300 isub = iwork( i )
301 jsub = iwork( j )
302 END IF
303*
304* Check for banding
305*
306 IF( jsub.GT.isub+ku .OR. jsub.LT.isub-kl ) THEN
307 zlatm3 = czero
308 RETURN
309 END IF
310*
311* Check for sparsity
312*
313 IF( sparse.GT.zero ) THEN
314 IF( dlaran( iseed ).LT.sparse ) THEN
315 zlatm3 = czero
316 RETURN
317 END IF
318 END IF
319*
320* Compute entry and grade it according to IGRADE
321*
322 IF( i.EQ.j ) THEN
323 ctemp = d( i )
324 ELSE
325 ctemp = zlarnd( idist, iseed )
326 END IF
327 IF( igrade.EQ.1 ) THEN
328 ctemp = ctemp*dl( i )
329 ELSE IF( igrade.EQ.2 ) THEN
330 ctemp = ctemp*dr( j )
331 ELSE IF( igrade.EQ.3 ) THEN
332 ctemp = ctemp*dl( i )*dr( j )
333 ELSE IF( igrade.EQ.4 .AND. i.NE.j ) THEN
334 ctemp = ctemp*dl( i ) / dl( j )
335 ELSE IF( igrade.EQ.5 ) THEN
336 ctemp = ctemp*dl( i )*dconjg( dl( j ) )
337 ELSE IF( igrade.EQ.6 ) THEN
338 ctemp = ctemp*dl( i )*dl( j )
339 END IF
340 zlatm3 = ctemp
341 RETURN
342*
343* End of ZLATM3
344*
zlatm3
complex *16 function zlatm3(m, n, i, j, isub, jsub, kl, ku, idist, iseed, d, igrade, dl, dr, ipvtng, iwork, sparse)
ZLATM3
Definition zlatm3.f:229

◆ zlatm5()

subroutine zlatm5 ( integer prtype,
integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldc, * ) c,
integer ldc,
complex*16, dimension( ldd, * ) d,
integer ldd,
complex*16, dimension( lde, * ) e,
integer lde,
complex*16, dimension( ldf, * ) f,
integer ldf,
complex*16, dimension( ldr, * ) r,
integer ldr,
complex*16, dimension( ldl, * ) l,
integer ldl,
double precision alpha,
integer qblcka,
integer qblckb )

ZLATM5

Purpose:
!>
!> ZLATM5 generates matrices involved in the Generalized Sylvester
!> equation:
!>
!>     A * R - L * B = C
!>     D * R - L * E = F
!>
!> They also satisfy (the diagonalization condition)
!>
!>  [ I -L ] ( [ A  -C ], [ D -F ] ) [ I  R ] = ( [ A    ], [ D    ] )
!>  [    I ] ( [     B ]  [    E ] ) [    I ]   ( [    B ]  [    E ] )
!>
!>
Parameters
[in]PRTYPE
!>          PRTYPE is INTEGER
!>           to a certain type of the matrices to generate
!>          (see further details).
!>
[in]M
!>          M is INTEGER
!>          Specifies the order of A and D and the number of rows in
!>          C, F,  R and L.
!>
[in]N
!>          N is INTEGER
!>          Specifies the order of B and E and the number of columns in
!>          C, F, R and L.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA, M).
!>          On exit A M-by-M is initialized according to PRTYPE.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A.
!>
[out]B
!>          B is COMPLEX*16 array, dimension (LDB, N).
!>          On exit B N-by-N is initialized according to PRTYPE.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of B.
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDC, N).
!>          On exit C M-by-N is initialized according to PRTYPE.
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of C.
!>
[out]D
!>          D is COMPLEX*16 array, dimension (LDD, M).
!>          On exit D M-by-M is initialized according to PRTYPE.
!>
[in]LDD
!>          LDD is INTEGER
!>          The leading dimension of D.
!>
[out]E
!>          E is COMPLEX*16 array, dimension (LDE, N).
!>          On exit E N-by-N is initialized according to PRTYPE.
!>
[in]LDE
!>          LDE is INTEGER
!>          The leading dimension of E.
!>
[out]F
!>          F is COMPLEX*16 array, dimension (LDF, N).
!>          On exit F M-by-N is initialized according to PRTYPE.
!>
[in]LDF
!>          LDF is INTEGER
!>          The leading dimension of F.
!>
[out]R
!>          R is COMPLEX*16 array, dimension (LDR, N).
!>          On exit R M-by-N is initialized according to PRTYPE.
!>
[in]LDR
!>          LDR is INTEGER
!>          The leading dimension of R.
!>
[out]L
!>          L is COMPLEX*16 array, dimension (LDL, N).
!>          On exit L M-by-N is initialized according to PRTYPE.
!>
[in]LDL
!>          LDL is INTEGER
!>          The leading dimension of L.
!>
[in]ALPHA
!>          ALPHA is DOUBLE PRECISION
!>          Parameter used in generating PRTYPE = 1 and 5 matrices.
!>
[in]QBLCKA
!>          QBLCKA is INTEGER
!>          When PRTYPE = 3, specifies the distance between 2-by-2
!>          blocks on the diagonal in A. Otherwise, QBLCKA is not
!>          referenced. QBLCKA > 1.
!>
[in]QBLCKB
!>          QBLCKB is INTEGER
!>          When PRTYPE = 3, specifies the distance between 2-by-2
!>          blocks on the diagonal in B. Otherwise, QBLCKB is not
!>          referenced. QBLCKB > 1.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Further Details:
!>
!>  PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices
!>
!>             A : if (i == j) then A(i, j) = 1.0
!>                 if (j == i + 1) then A(i, j) = -1.0
!>                 else A(i, j) = 0.0,            i, j = 1...M
!>
!>             B : if (i == j) then B(i, j) = 1.0 - ALPHA
!>                 if (j == i + 1) then B(i, j) = 1.0
!>                 else B(i, j) = 0.0,            i, j = 1...N
!>
!>             D : if (i == j) then D(i, j) = 1.0
!>                 else D(i, j) = 0.0,            i, j = 1...M
!>
!>             E : if (i == j) then E(i, j) = 1.0
!>                 else E(i, j) = 0.0,            i, j = 1...N
!>
!>             L =  R are chosen from [-10...10],
!>                  which specifies the right hand sides (C, F).
!>
!>  PRTYPE = 2 or 3: Triangular and/or quasi- triangular.
!>
!>             A : if (i <= j) then A(i, j) = [-1...1]
!>                 else A(i, j) = 0.0,             i, j = 1...M
!>
!>                 if (PRTYPE = 3) then
!>                    A(k + 1, k + 1) = A(k, k)
!>                    A(k + 1, k) = [-1...1]
!>                    sign(A(k, k + 1) = -(sin(A(k + 1, k))
!>                        k = 1, M - 1, QBLCKA
!>
!>             B : if (i <= j) then B(i, j) = [-1...1]
!>                 else B(i, j) = 0.0,            i, j = 1...N
!>
!>                 if (PRTYPE = 3) then
!>                    B(k + 1, k + 1) = B(k, k)
!>                    B(k + 1, k) = [-1...1]
!>                    sign(B(k, k + 1) = -(sign(B(k + 1, k))
!>                        k = 1, N - 1, QBLCKB
!>
!>             D : if (i <= j) then D(i, j) = [-1...1].
!>                 else D(i, j) = 0.0,            i, j = 1...M
!>
!>
!>             E : if (i <= j) then D(i, j) = [-1...1]
!>                 else E(i, j) = 0.0,            i, j = 1...N
!>
!>                 L, R are chosen from [-10...10],
!>                 which specifies the right hand sides (C, F).
!>
!>  PRTYPE = 4 Full
!>             A(i, j) = [-10...10]
!>             D(i, j) = [-1...1]    i,j = 1...M
!>             B(i, j) = [-10...10]
!>             E(i, j) = [-1...1]    i,j = 1...N
!>             R(i, j) = [-10...10]
!>             L(i, j) = [-1...1]    i = 1..M ,j = 1...N
!>
!>             L, R specifies the right hand sides (C, F).
!>
!>  PRTYPE = 5 special case common and/or close eigs.
!>

Definition at line 265 of file zlatm5.f.

268*
269* -- LAPACK computational routine --
270* -- LAPACK is a software package provided by Univ. of Tennessee, --
271* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
272*
273* .. Scalar Arguments ..
274 INTEGER LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N,
275 $ PRTYPE, QBLCKA, QBLCKB
276 DOUBLE PRECISION ALPHA
277* ..
278* .. Array Arguments ..
279 COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ),
280 $ D( LDD, * ), E( LDE, * ), F( LDF, * ),
281 $ L( LDL, * ), R( LDR, * )
282* ..
283*
284* =====================================================================
285*
286* .. Parameters ..
287 COMPLEX*16 ONE, TWO, ZERO, HALF, TWENTY
288 parameter( one = ( 1.0d+0, 0.0d+0 ),
289 $ two = ( 2.0d+0, 0.0d+0 ),
290 $ zero = ( 0.0d+0, 0.0d+0 ),
291 $ half = ( 0.5d+0, 0.0d+0 ),
292 $ twenty = ( 2.0d+1, 0.0d+0 ) )
293* ..
294* .. Local Scalars ..
295 INTEGER I, J, K
296 COMPLEX*16 IMEPS, REEPS
297* ..
298* .. Intrinsic Functions ..
299 INTRINSIC dcmplx, mod, sin
300* ..
301* .. External Subroutines ..
302 EXTERNAL zgemm
303* ..
304* .. Executable Statements ..
305*
306 IF( prtype.EQ.1 ) THEN
307 DO 20 i = 1, m
308 DO 10 j = 1, m
309 IF( i.EQ.j ) THEN
310 a( i, j ) = one
311 d( i, j ) = one
312 ELSE IF( i.EQ.j-1 ) THEN
313 a( i, j ) = -one
314 d( i, j ) = zero
315 ELSE
316 a( i, j ) = zero
317 d( i, j ) = zero
318 END IF
319 10 CONTINUE
320 20 CONTINUE
321*
322 DO 40 i = 1, n
323 DO 30 j = 1, n
324 IF( i.EQ.j ) THEN
325 b( i, j ) = one - alpha
326 e( i, j ) = one
327 ELSE IF( i.EQ.j-1 ) THEN
328 b( i, j ) = one
329 e( i, j ) = zero
330 ELSE
331 b( i, j ) = zero
332 e( i, j ) = zero
333 END IF
334 30 CONTINUE
335 40 CONTINUE
336*
337 DO 60 i = 1, m
338 DO 50 j = 1, n
339 r( i, j ) = ( half-sin( dcmplx( i / j ) ) )*twenty
340 l( i, j ) = r( i, j )
341 50 CONTINUE
342 60 CONTINUE
343*
344 ELSE IF( prtype.EQ.2 .OR. prtype.EQ.3 ) THEN
345 DO 80 i = 1, m
346 DO 70 j = 1, m
347 IF( i.LE.j ) THEN
348 a( i, j ) = ( half-sin( dcmplx( i ) ) )*two
349 d( i, j ) = ( half-sin( dcmplx( i*j ) ) )*two
350 ELSE
351 a( i, j ) = zero
352 d( i, j ) = zero
353 END IF
354 70 CONTINUE
355 80 CONTINUE
356*
357 DO 100 i = 1, n
358 DO 90 j = 1, n
359 IF( i.LE.j ) THEN
360 b( i, j ) = ( half-sin( dcmplx( i+j ) ) )*two
361 e( i, j ) = ( half-sin( dcmplx( j ) ) )*two
362 ELSE
363 b( i, j ) = zero
364 e( i, j ) = zero
365 END IF
366 90 CONTINUE
367 100 CONTINUE
368*
369 DO 120 i = 1, m
370 DO 110 j = 1, n
371 r( i, j ) = ( half-sin( dcmplx( i*j ) ) )*twenty
372 l( i, j ) = ( half-sin( dcmplx( i+j ) ) )*twenty
373 110 CONTINUE
374 120 CONTINUE
375*
376 IF( prtype.EQ.3 ) THEN
377 IF( qblcka.LE.1 )
378 $ qblcka = 2
379 DO 130 k = 1, m - 1, qblcka
380 a( k+1, k+1 ) = a( k, k )
381 a( k+1, k ) = -sin( a( k, k+1 ) )
382 130 CONTINUE
383*
384 IF( qblckb.LE.1 )
385 $ qblckb = 2
386 DO 140 k = 1, n - 1, qblckb
387 b( k+1, k+1 ) = b( k, k )
388 b( k+1, k ) = -sin( b( k, k+1 ) )
389 140 CONTINUE
390 END IF
391*
392 ELSE IF( prtype.EQ.4 ) THEN
393 DO 160 i = 1, m
394 DO 150 j = 1, m
395 a( i, j ) = ( half-sin( dcmplx( i*j ) ) )*twenty
396 d( i, j ) = ( half-sin( dcmplx( i+j ) ) )*two
397 150 CONTINUE
398 160 CONTINUE
399*
400 DO 180 i = 1, n
401 DO 170 j = 1, n
402 b( i, j ) = ( half-sin( dcmplx( i+j ) ) )*twenty
403 e( i, j ) = ( half-sin( dcmplx( i*j ) ) )*two
404 170 CONTINUE
405 180 CONTINUE
406*
407 DO 200 i = 1, m
408 DO 190 j = 1, n
409 r( i, j ) = ( half-sin( dcmplx( j / i ) ) )*twenty
410 l( i, j ) = ( half-sin( dcmplx( i*j ) ) )*two
411 190 CONTINUE
412 200 CONTINUE
413*
414 ELSE IF( prtype.GE.5 ) THEN
415 reeps = half*two*twenty / alpha
416 imeps = ( half-two ) / alpha
417 DO 220 i = 1, m
418 DO 210 j = 1, n
419 r( i, j ) = ( half-sin( dcmplx( i*j ) ) )*alpha / twenty
420 l( i, j ) = ( half-sin( dcmplx( i+j ) ) )*alpha / twenty
421 210 CONTINUE
422 220 CONTINUE
423*
424 DO 230 i = 1, m
425 d( i, i ) = one
426 230 CONTINUE
427*
428 DO 240 i = 1, m
429 IF( i.LE.4 ) THEN
430 a( i, i ) = one
431 IF( i.GT.2 )
432 $ a( i, i ) = one + reeps
433 IF( mod( i, 2 ).NE.0 .AND. i.LT.m ) THEN
434 a( i, i+1 ) = imeps
435 ELSE IF( i.GT.1 ) THEN
436 a( i, i-1 ) = -imeps
437 END IF
438 ELSE IF( i.LE.8 ) THEN
439 IF( i.LE.6 ) THEN
440 a( i, i ) = reeps
441 ELSE
442 a( i, i ) = -reeps
443 END IF
444 IF( mod( i, 2 ).NE.0 .AND. i.LT.m ) THEN
445 a( i, i+1 ) = one
446 ELSE IF( i.GT.1 ) THEN
447 a( i, i-1 ) = -one
448 END IF
449 ELSE
450 a( i, i ) = one
451 IF( mod( i, 2 ).NE.0 .AND. i.LT.m ) THEN
452 a( i, i+1 ) = imeps*2
453 ELSE IF( i.GT.1 ) THEN
454 a( i, i-1 ) = -imeps*2
455 END IF
456 END IF
457 240 CONTINUE
458*
459 DO 250 i = 1, n
460 e( i, i ) = one
461 IF( i.LE.4 ) THEN
462 b( i, i ) = -one
463 IF( i.GT.2 )
464 $ b( i, i ) = one - reeps
465 IF( mod( i, 2 ).NE.0 .AND. i.LT.n ) THEN
466 b( i, i+1 ) = imeps
467 ELSE IF( i.GT.1 ) THEN
468 b( i, i-1 ) = -imeps
469 END IF
470 ELSE IF( i.LE.8 ) THEN
471 IF( i.LE.6 ) THEN
472 b( i, i ) = reeps
473 ELSE
474 b( i, i ) = -reeps
475 END IF
476 IF( mod( i, 2 ).NE.0 .AND. i.LT.n ) THEN
477 b( i, i+1 ) = one + imeps
478 ELSE IF( i.GT.1 ) THEN
479 b( i, i-1 ) = -one - imeps
480 END IF
481 ELSE
482 b( i, i ) = one - reeps
483 IF( mod( i, 2 ).NE.0 .AND. i.LT.n ) THEN
484 b( i, i+1 ) = imeps*2
485 ELSE IF( i.GT.1 ) THEN
486 b( i, i-1 ) = -imeps*2
487 END IF
488 END IF
489 250 CONTINUE
490 END IF
491*
492* Compute rhs (C, F)
493*
494 CALL zgemm( 'N', 'N', m, n, m, one, a, lda, r, ldr, zero, c, ldc )
495 CALL zgemm( 'N', 'N', m, n, n, -one, l, ldl, b, ldb, one, c, ldc )
496 CALL zgemm( 'N', 'N', m, n, m, one, d, ldd, r, ldr, zero, f, ldf )
497 CALL zgemm( 'N', 'N', m, n, n, -one, l, ldl, e, lde, one, f, ldf )
498*
499* End of ZLATM5
500*
lde
logical function lde(ri, rj, lr)
Definition dblat2.f:2942
zgemm
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
Definition zgemm.f:187

◆ zlatm6()

subroutine zlatm6 ( integer type,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( lda, * ) b,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldy, * ) y,
integer ldy,
complex*16 alpha,
complex*16 beta,
complex*16 wx,
complex*16 wy,
double precision, dimension( * ) s,
double precision, dimension( * ) dif )

ZLATM6

Purpose:
!>
!> ZLATM6 generates test matrices for the generalized eigenvalue
!> problem, their corresponding right and left eigenvector matrices,
!> and also reciprocal condition numbers for all eigenvalues and
!> the reciprocal condition numbers of eigenvectors corresponding to
!> the 1th and 5th eigenvalues.
!>
!> Test Matrices
!> =============
!>
!> Two kinds of test matrix pairs
!>          (A, B) = inverse(YH) * (Da, Db) * inverse(X)
!> are used in the tests:
!>
!> Type 1:
!>    Da = 1+a   0    0    0    0    Db = 1   0   0   0   0
!>          0   2+a   0    0    0         0   1   0   0   0
!>          0    0   3+a   0    0         0   0   1   0   0
!>          0    0    0   4+a   0         0   0   0   1   0
!>          0    0    0    0   5+a ,      0   0   0   0   1
!> and Type 2:
!>    Da = 1+i   0    0       0       0    Db = 1   0   0   0   0
!>          0   1-i   0       0       0         0   1   0   0   0
!>          0    0    1       0       0         0   0   1   0   0
!>          0    0    0 (1+a)+(1+b)i  0         0   0   0   1   0
!>          0    0    0       0 (1+a)-(1+b)i,   0   0   0   0   1 .
!>
!> In both cases the same inverse(YH) and inverse(X) are used to compute
!> (A, B), giving the exact eigenvectors to (A,B) as (YH, X):
!>
!> YH:  =  1    0   -y    y   -y    X =  1   0  -x  -x   x
!>         0    1   -y    y   -y         0   1   x  -x  -x
!>         0    0    1    0    0         0   0   1   0   0
!>         0    0    0    1    0         0   0   0   1   0
!>         0    0    0    0    1,        0   0   0   0   1 , where
!>
!> a, b, x and y will have all values independently of each other.
!>
Parameters
[in]TYPE
!>          TYPE is INTEGER
!>          Specifies the problem type (see further details).
!>
[in]N
!>          N is INTEGER
!>          Size of the matrices A and B.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA, N).
!>          On exit A N-by-N is initialized according to TYPE.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of A and of B.
!>
[out]B
!>          B is COMPLEX*16 array, dimension (LDA, N).
!>          On exit B N-by-N is initialized according to TYPE.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (LDX, N).
!>          On exit X is the N-by-N matrix of right eigenvectors.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of X.
!>
[out]Y
!>          Y is COMPLEX*16 array, dimension (LDY, N).
!>          On exit Y is the N-by-N matrix of left eigenvectors.
!>
[in]LDY
!>          LDY is INTEGER
!>          The leading dimension of Y.
!>
[in]ALPHA
!>          ALPHA is COMPLEX*16
!>
[in]BETA
!>          BETA is COMPLEX*16
!> \verbatim
!>          Weighting constants for matrix A.
!>
[in]WX
!>          WX is COMPLEX*16
!>          Constant for right eigenvector matrix.
!>
[in]WY
!>          WY is COMPLEX*16
!>          Constant for left eigenvector matrix.
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (N)
!>          S(i) is the reciprocal condition number for eigenvalue i.
!>
[out]DIF
!>          DIF is DOUBLE PRECISION array, dimension (N)
!>          DIF(i) is the reciprocal condition number for eigenvector i.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 172 of file zlatm6.f.

174*
175* -- LAPACK computational routine --
176* -- LAPACK is a software package provided by Univ. of Tennessee, --
177* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
178*
179* .. Scalar Arguments ..
180 INTEGER LDA, LDX, LDY, N, TYPE
181 COMPLEX*16 ALPHA, BETA, WX, WY
182* ..
183* .. Array Arguments ..
184 DOUBLE PRECISION DIF( * ), S( * )
185 COMPLEX*16 A( LDA, * ), B( LDA, * ), X( LDX, * ),
186 $ Y( LDY, * )
187* ..
188*
189* =====================================================================
190*
191* .. Parameters ..
192 DOUBLE PRECISION RONE, TWO, THREE
193 parameter( rone = 1.0d+0, two = 2.0d+0, three = 3.0d+0 )
194 COMPLEX*16 ZERO, ONE
195 parameter( zero = ( 0.0d+0, 0.0d+0 ),
196 $ one = ( 1.0d+0, 0.0d+0 ) )
197* ..
198* .. Local Scalars ..
199 INTEGER I, INFO, J
200* ..
201* .. Local Arrays ..
202 DOUBLE PRECISION RWORK( 50 )
203 COMPLEX*16 WORK( 26 ), Z( 8, 8 )
204* ..
205* .. Intrinsic Functions ..
206 INTRINSIC cdabs, dble, dcmplx, dconjg, sqrt
207* ..
208* .. External Subroutines ..
209 EXTERNAL zgesvd, zlacpy, zlakf2
210* ..
211* .. Executable Statements ..
212*
213* Generate test problem ...
214* (Da, Db) ...
215*
216 DO 20 i = 1, n
217 DO 10 j = 1, n
218*
219 IF( i.EQ.j ) THEN
220 a( i, i ) = dcmplx( i ) + alpha
221 b( i, i ) = one
222 ELSE
223 a( i, j ) = zero
224 b( i, j ) = zero
225 END IF
226*
227 10 CONTINUE
228 20 CONTINUE
229 IF( type.EQ.2 ) THEN
230 a( 1, 1 ) = dcmplx( rone, rone )
231 a( 2, 2 ) = dconjg( a( 1, 1 ) )
232 a( 3, 3 ) = one
233 a( 4, 4 ) = dcmplx( dble( one+alpha ), dble( one+beta ) )
234 a( 5, 5 ) = dconjg( a( 4, 4 ) )
235 END IF
236*
237* Form X and Y
238*
239 CALL zlacpy( 'F', n, n, b, lda, y, ldy )
240 y( 3, 1 ) = -dconjg( wy )
241 y( 4, 1 ) = dconjg( wy )
242 y( 5, 1 ) = -dconjg( wy )
243 y( 3, 2 ) = -dconjg( wy )
244 y( 4, 2 ) = dconjg( wy )
245 y( 5, 2 ) = -dconjg( wy )
246*
247 CALL zlacpy( 'F', n, n, b, lda, x, ldx )
248 x( 1, 3 ) = -wx
249 x( 1, 4 ) = -wx
250 x( 1, 5 ) = wx
251 x( 2, 3 ) = wx
252 x( 2, 4 ) = -wx
253 x( 2, 5 ) = -wx
254*
255* Form (A, B)
256*
257 b( 1, 3 ) = wx + wy
258 b( 2, 3 ) = -wx + wy
259 b( 1, 4 ) = wx - wy
260 b( 2, 4 ) = wx - wy
261 b( 1, 5 ) = -wx + wy
262 b( 2, 5 ) = wx + wy
263 a( 1, 3 ) = wx*a( 1, 1 ) + wy*a( 3, 3 )
264 a( 2, 3 ) = -wx*a( 2, 2 ) + wy*a( 3, 3 )
265 a( 1, 4 ) = wx*a( 1, 1 ) - wy*a( 4, 4 )
266 a( 2, 4 ) = wx*a( 2, 2 ) - wy*a( 4, 4 )
267 a( 1, 5 ) = -wx*a( 1, 1 ) + wy*a( 5, 5 )
268 a( 2, 5 ) = wx*a( 2, 2 ) + wy*a( 5, 5 )
269*
270* Compute condition numbers
271*
272 s( 1 ) = rone / sqrt( ( rone+three*cdabs( wy )*cdabs( wy ) ) /
273 $ ( rone+cdabs( a( 1, 1 ) )*cdabs( a( 1, 1 ) ) ) )
274 s( 2 ) = rone / sqrt( ( rone+three*cdabs( wy )*cdabs( wy ) ) /
275 $ ( rone+cdabs( a( 2, 2 ) )*cdabs( a( 2, 2 ) ) ) )
276 s( 3 ) = rone / sqrt( ( rone+two*cdabs( wx )*cdabs( wx ) ) /
277 $ ( rone+cdabs( a( 3, 3 ) )*cdabs( a( 3, 3 ) ) ) )
278 s( 4 ) = rone / sqrt( ( rone+two*cdabs( wx )*cdabs( wx ) ) /
279 $ ( rone+cdabs( a( 4, 4 ) )*cdabs( a( 4, 4 ) ) ) )
280 s( 5 ) = rone / sqrt( ( rone+two*cdabs( wx )*cdabs( wx ) ) /
281 $ ( rone+cdabs( a( 5, 5 ) )*cdabs( a( 5, 5 ) ) ) )
282*
283 CALL zlakf2( 1, 4, a, lda, a( 2, 2 ), b, b( 2, 2 ), z, 8 )
284 CALL zgesvd( 'N', 'N', 8, 8, z, 8, rwork, work, 1, work( 2 ), 1,
285 $ work( 3 ), 24, rwork( 9 ), info )
286 dif( 1 ) = rwork( 8 )
287*
288 CALL zlakf2( 4, 1, a, lda, a( 5, 5 ), b, b( 5, 5 ), z, 8 )
289 CALL zgesvd( 'N', 'N', 8, 8, z, 8, rwork, work, 1, work( 2 ), 1,
290 $ work( 3 ), 24, rwork( 9 ), info )
291 dif( 5 ) = rwork( 8 )
292*
293 RETURN
294*
295* End of ZLATM6
296*
zgesvd
subroutine zgesvd(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, rwork, info)
ZGESVD computes the singular value decomposition (SVD) for GE matrices
Definition zgesvd.f:214
zlacpy
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
Definition zlacpy.f:103
zlakf2
subroutine zlakf2(m, n, a, lda, b, d, e, z, ldz)
ZLAKF2
Definition zlakf2.f:105

◆ zlatme()

subroutine zlatme ( integer n,
character dist,
integer, dimension( 4 ) iseed,
complex*16, dimension( * ) d,
integer mode,
double precision cond,
complex*16 dmax,
character rsign,
character upper,
character sim,
double precision, dimension( * ) ds,
integer modes,
double precision conds,
integer kl,
integer ku,
double precision anorm,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) work,
integer info )

ZLATME

Purpose:
!>
!>    ZLATME generates random non-symmetric square matrices with
!>    specified eigenvalues for testing LAPACK programs.
!>
!>    ZLATME 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 UPPER='T', the upper triangle of A is set to random values
!>         out of distribution DIST.
!>
!>    3. 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.
!>
!>    4. 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.
!>
!>    5. 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.)
!>
Parameters
[in]N
!>          N is INTEGER
!>           The number of columns (or rows) of A. Not modified.
!>
[in]DIST
!>          DIST is CHARACTER*1
!>           On entry, DIST specifies the type of distribution to be used
!>           to generate the random eigen-/singular values, and on 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 )
!>           'D' => uniform on the complex disc |z| < 1.
!>           Not modified.
!>
[in,out]ISEED
!>          ISEED is 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 ZLATME
!>           to continue the same random number sequence.
!>           Changed on exit.
!>
[in,out]D
!>          D is COMPLEX*16 array, dimension ( N )
!>           This array is used to specify the eigenvalues of A.  If
!>           MODE=0, then D is assumed to contain the eigenvalues
!>           otherwise they will be computed according to MODE, COND,
!>           DMAX, and RSIGN and placed in D.
!>           Modified if MODE is nonzero.
!>
[in]MODE
!>          MODE is INTEGER
!>           On entry this describes how the eigenvalues are to
!>           be specified:
!>           MODE = 0 means use D 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.
!>           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.
!>
[in]COND
!>          COND is DOUBLE PRECISION
!>           On entry, this is used as described under MODE above.
!>           If used, it must be >= 1. Not modified.
!>
[in]DMAX
!>          DMAX is COMPLEX*16
!>           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 or real: if DMAX is negative or complex (or zero),
!>           D will be scaled by a negative or complex number (or zero).
!>           If RSIGN='F' then the largest (absolute) eigenvalue will be
!>           equal to DMAX.
!>           Not modified.
!>
[in]RSIGN
!>          RSIGN is 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 complex number from the unit
!>           circle |z| = 1.  If RSIGN='F', they will not be.  RSIGN may
!>           only have the values 'T' or 'F'.
!>           Not modified.
!>
[in]UPPER
!>          UPPER is CHARACTER*1
!>           If UPPER='T', then the elements of A above the diagonal
!>           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.
!>
[in]SIM
!>          SIM is CHARACTER*1
!>           If SIM='T', then A will be operated on by a , 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.
!>
[in,out]DS
!>          DS is 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.
!>
[in]MODES
!>          MODES is INTEGER
!>
[in]CONDS
!>          CONDS is DOUBLE PRECISION
!>           Similar to 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.)
!>
[in]KL
!>          KL is 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.
!>           Not modified.
!>
[in]KU
!>          KU is 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.
!>           Not modified.
!>
[in]ANORM
!>          ANORM is 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.
!>
[out]A
!>          A is COMPLEX*16 array, dimension ( LDA, N )
!>           On exit A is the desired test matrix.
!>           Modified.
!>
[in]LDA
!>          LDA is INTEGER
!>           LDA specifies the first dimension of A as declared in the
!>           calling program.  LDA must be at least M.
!>           Not modified.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension ( 3*N )
!>           Workspace.
!>           Modified.
!>
[out]INFO
!>          INFO is 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
!>            -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 M.
!>            1  => Error return from ZLATM1 (computing D)
!>            2  => Cannot scale to DMAX (max. eigenvalue is 0)
!>            3  => Error return from DLATM1 (computing DS)
!>            4  => Error return from ZLARGE
!>            5  => Zero singular value from DLATM1.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 296 of file zlatme.f.

301*
302* -- LAPACK computational routine --
303* -- LAPACK is a software package provided by Univ. of Tennessee, --
304* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
305*
306* .. Scalar Arguments ..
307 CHARACTER DIST, RSIGN, SIM, UPPER
308 INTEGER INFO, KL, KU, LDA, MODE, MODES, N
309 DOUBLE PRECISION ANORM, COND, CONDS
310 COMPLEX*16 DMAX
311* ..
312* .. Array Arguments ..
313 INTEGER ISEED( 4 )
314 DOUBLE PRECISION DS( * )
315 COMPLEX*16 A( LDA, * ), D( * ), WORK( * )
316* ..
317*
318* =====================================================================
319*
320* .. Parameters ..
321 DOUBLE PRECISION ZERO
322 parameter( zero = 0.0d+0 )
323 DOUBLE PRECISION ONE
324 parameter( one = 1.0d+0 )
325 COMPLEX*16 CZERO
326 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
327 COMPLEX*16 CONE
328 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
329* ..
330* .. Local Scalars ..
331 LOGICAL BADS
332 INTEGER I, IC, ICOLS, IDIST, IINFO, IR, IROWS, IRSIGN,
333 $ ISIM, IUPPER, J, JC, JCR
334 DOUBLE PRECISION RALPHA, TEMP
335 COMPLEX*16 ALPHA, TAU, XNORMS
336* ..
337* .. Local Arrays ..
338 DOUBLE PRECISION TEMPA( 1 )
339* ..
340* .. External Functions ..
341 LOGICAL LSAME
342 DOUBLE PRECISION ZLANGE
343 COMPLEX*16 ZLARND
344 EXTERNAL lsame, zlange, zlarnd
345* ..
346* .. External Subroutines ..
347 EXTERNAL dlatm1, xerbla, zcopy, zdscal, zgemv, zgerc,
348 $ zlacgv, zlarfg, zlarge, zlarnv, zlaset, zlatm1,
349 $ zscal
350* ..
351* .. Intrinsic Functions ..
352 INTRINSIC abs, dconjg, max, mod
353* ..
354* .. Executable Statements ..
355*
356* 1) Decode and Test the input parameters.
357* Initialize flags & seed.
358*
359 info = 0
360*
361* Quick return if possible
362*
363 IF( n.EQ.0 )
364 $ RETURN
365*
366* Decode DIST
367*
368 IF( lsame( dist, 'U' ) ) THEN
369 idist = 1
370 ELSE IF( lsame( dist, 'S' ) ) THEN
371 idist = 2
372 ELSE IF( lsame( dist, 'N' ) ) THEN
373 idist = 3
374 ELSE IF( lsame( dist, 'D' ) ) THEN
375 idist = 4
376 ELSE
377 idist = -1
378 END IF
379*
380* Decode RSIGN
381*
382 IF( lsame( rsign, 'T' ) ) THEN
383 irsign = 1
384 ELSE IF( lsame( rsign, 'F' ) ) THEN
385 irsign = 0
386 ELSE
387 irsign = -1
388 END IF
389*
390* Decode UPPER
391*
392 IF( lsame( upper, 'T' ) ) THEN
393 iupper = 1
394 ELSE IF( lsame( upper, 'F' ) ) THEN
395 iupper = 0
396 ELSE
397 iupper = -1
398 END IF
399*
400* Decode SIM
401*
402 IF( lsame( sim, 'T' ) ) THEN
403 isim = 1
404 ELSE IF( lsame( sim, 'F' ) ) THEN
405 isim = 0
406 ELSE
407 isim = -1
408 END IF
409*
410* Check DS, if MODES=0 and ISIM=1
411*
412 bads = .false.
413 IF( modes.EQ.0 .AND. isim.EQ.1 ) THEN
414 DO 10 j = 1, n
415 IF( ds( j ).EQ.zero )
416 $ bads = .true.
417 10 CONTINUE
418 END IF
419*
420* Set INFO if an error
421*
422 IF( n.LT.0 ) THEN
423 info = -1
424 ELSE IF( idist.EQ.-1 ) THEN
425 info = -2
426 ELSE IF( abs( mode ).GT.6 ) THEN
427 info = -5
428 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
429 $ THEN
430 info = -6
431 ELSE IF( irsign.EQ.-1 ) THEN
432 info = -9
433 ELSE IF( iupper.EQ.-1 ) THEN
434 info = -10
435 ELSE IF( isim.EQ.-1 ) THEN
436 info = -11
437 ELSE IF( bads ) THEN
438 info = -12
439 ELSE IF( isim.EQ.1 .AND. abs( modes ).GT.5 ) THEN
440 info = -13
441 ELSE IF( isim.EQ.1 .AND. modes.NE.0 .AND. conds.LT.one ) THEN
442 info = -14
443 ELSE IF( kl.LT.1 ) THEN
444 info = -15
445 ELSE IF( ku.LT.1 .OR. ( ku.LT.n-1 .AND. kl.LT.n-1 ) ) THEN
446 info = -16
447 ELSE IF( lda.LT.max( 1, n ) ) THEN
448 info = -19
449 END IF
450*
451 IF( info.NE.0 ) THEN
452 CALL xerbla( 'ZLATME', -info )
453 RETURN
454 END IF
455*
456* Initialize random number generator
457*
458 DO 20 i = 1, 4
459 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
460 20 CONTINUE
461*
462 IF( mod( iseed( 4 ), 2 ).NE.1 )
463 $ iseed( 4 ) = iseed( 4 ) + 1
464*
465* 2) Set up diagonal of A
466*
467* Compute D according to COND and MODE
468*
469 CALL zlatm1( mode, cond, irsign, idist, iseed, d, n, iinfo )
470 IF( iinfo.NE.0 ) THEN
471 info = 1
472 RETURN
473 END IF
474 IF( mode.NE.0 .AND. abs( mode ).NE.6 ) THEN
475*
476* Scale by DMAX
477*
478 temp = abs( d( 1 ) )
479 DO 30 i = 2, n
480 temp = max( temp, abs( d( i ) ) )
481 30 CONTINUE
482*
483 IF( temp.GT.zero ) THEN
484 alpha = dmax / temp
485 ELSE
486 info = 2
487 RETURN
488 END IF
489*
490 CALL zscal( n, alpha, d, 1 )
491*
492 END IF
493*
494 CALL zlaset( 'Full', n, n, czero, czero, a, lda )
495 CALL zcopy( n, d, 1, a, lda+1 )
496*
497* 3) If UPPER='T', set upper triangle of A to random numbers.
498*
499 IF( iupper.NE.0 ) THEN
500 DO 40 jc = 2, n
501 CALL zlarnv( idist, iseed, jc-1, a( 1, jc ) )
502 40 CONTINUE
503 END IF
504*
505* 4) If SIM='T', apply similarity transformation.
506*
507* -1
508* Transform is X A X , where X = U S V, thus
509*
510* it is U S V A V' (1/S) U'
511*
512 IF( isim.NE.0 ) THEN
513*
514* Compute S (singular values of the eigenvector matrix)
515* according to CONDS and MODES
516*
517 CALL dlatm1( modes, conds, 0, 0, iseed, ds, n, iinfo )
518 IF( iinfo.NE.0 ) THEN
519 info = 3
520 RETURN
521 END IF
522*
523* Multiply by V and V'
524*
525 CALL zlarge( n, a, lda, iseed, work, iinfo )
526 IF( iinfo.NE.0 ) THEN
527 info = 4
528 RETURN
529 END IF
530*
531* Multiply by S and (1/S)
532*
533 DO 50 j = 1, n
534 CALL zdscal( n, ds( j ), a( j, 1 ), lda )
535 IF( ds( j ).NE.zero ) THEN
536 CALL zdscal( n, one / ds( j ), a( 1, j ), 1 )
537 ELSE
538 info = 5
539 RETURN
540 END IF
541 50 CONTINUE
542*
543* Multiply by U and U'
544*
545 CALL zlarge( n, a, lda, iseed, work, iinfo )
546 IF( iinfo.NE.0 ) THEN
547 info = 4
548 RETURN
549 END IF
550 END IF
551*
552* 5) Reduce the bandwidth.
553*
554 IF( kl.LT.n-1 ) THEN
555*
556* Reduce bandwidth -- kill column
557*
558 DO 60 jcr = kl + 1, n - 1
559 ic = jcr - kl
560 irows = n + 1 - jcr
561 icols = n + kl - jcr
562*
563 CALL zcopy( irows, a( jcr, ic ), 1, work, 1 )
564 xnorms = work( 1 )
565 CALL zlarfg( irows, xnorms, work( 2 ), 1, tau )
566 tau = dconjg( tau )
567 work( 1 ) = cone
568 alpha = zlarnd( 5, iseed )
569*
570 CALL zgemv( 'C', irows, icols, cone, a( jcr, ic+1 ), lda,
571 $ work, 1, czero, work( irows+1 ), 1 )
572 CALL zgerc( irows, icols, -tau, work, 1, work( irows+1 ), 1,
573 $ a( jcr, ic+1 ), lda )
574*
575 CALL zgemv( 'N', n, irows, cone, a( 1, jcr ), lda, work, 1,
576 $ czero, work( irows+1 ), 1 )
577 CALL zgerc( n, irows, -dconjg( tau ), work( irows+1 ), 1,
578 $ work, 1, a( 1, jcr ), lda )
579*
580 a( jcr, ic ) = xnorms
581 CALL zlaset( 'Full', irows-1, 1, czero, czero,
582 $ a( jcr+1, ic ), lda )
583*
584 CALL zscal( icols+1, alpha, a( jcr, ic ), lda )
585 CALL zscal( n, dconjg( alpha ), a( 1, jcr ), 1 )
586 60 CONTINUE
587 ELSE IF( ku.LT.n-1 ) THEN
588*
589* Reduce upper bandwidth -- kill a row at a time.
590*
591 DO 70 jcr = ku + 1, n - 1
592 ir = jcr - ku
593 irows = n + ku - jcr
594 icols = n + 1 - jcr
595*
596 CALL zcopy( icols, a( ir, jcr ), lda, work, 1 )
597 xnorms = work( 1 )
598 CALL zlarfg( icols, xnorms, work( 2 ), 1, tau )
599 tau = dconjg( tau )
600 work( 1 ) = cone
601 CALL zlacgv( icols-1, work( 2 ), 1 )
602 alpha = zlarnd( 5, iseed )
603*
604 CALL zgemv( 'N', irows, icols, cone, a( ir+1, jcr ), lda,
605 $ work, 1, czero, work( icols+1 ), 1 )
606 CALL zgerc( irows, icols, -tau, work( icols+1 ), 1, work, 1,
607 $ a( ir+1, jcr ), lda )
608*
609 CALL zgemv( 'C', icols, n, cone, a( jcr, 1 ), lda, work, 1,
610 $ czero, work( icols+1 ), 1 )
611 CALL zgerc( icols, n, -dconjg( tau ), work, 1,
612 $ work( icols+1 ), 1, a( jcr, 1 ), lda )
613*
614 a( ir, jcr ) = xnorms
615 CALL zlaset( 'Full', 1, icols-1, czero, czero,
616 $ a( ir, jcr+1 ), lda )
617*
618 CALL zscal( irows+1, alpha, a( ir, jcr ), 1 )
619 CALL zscal( n, dconjg( alpha ), a( jcr, 1 ), lda )
620 70 CONTINUE
621 END IF
622*
623* Scale the matrix to have norm ANORM
624*
625 IF( anorm.GE.zero ) THEN
626 temp = zlange( 'M', n, n, a, lda, tempa )
627 IF( temp.GT.zero ) THEN
628 ralpha = anorm / temp
629 DO 80 j = 1, n
630 CALL zdscal( n, ralpha, a( 1, j ), 1 )
631 80 CONTINUE
632 END IF
633 END IF
634*
635 RETURN
636*
637* End of ZLATME
638*
zlange
double precision function zlange(norm, m, n, a, lda, work)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition zlange.f:115
zlarfg
subroutine zlarfg(n, alpha, x, incx, tau)
ZLARFG generates an elementary reflector (Householder matrix).
Definition zlarfg.f:106
zdscal
subroutine zdscal(n, da, zx, incx)
ZDSCAL
Definition zdscal.f:78
zcopy
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
Definition zcopy.f:81
zlarge
subroutine zlarge(n, a, lda, iseed, work, info)
ZLARGE
Definition zlarge.f:87
zlatm1
subroutine zlatm1(mode, cond, irsign, idist, iseed, d, n, info)
ZLATM1
Definition zlatm1.f:137
dlatm1
subroutine dlatm1(mode, cond, irsign, idist, iseed, d, n, info)
DLATM1
Definition dlatm1.f:135
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ zlatmr()

subroutine zlatmr ( integer m,
integer n,
character dist,
integer, dimension( 4 ) iseed,
character sym,
complex*16, dimension( * ) d,
integer mode,
double precision cond,
complex*16 dmax,
character rsign,
character grade,
complex*16, dimension( * ) dl,
integer model,
double precision condl,
complex*16, dimension( * ) dr,
integer moder,
double precision condr,
character pivtng,
integer, dimension( * ) ipivot,
integer kl,
integer ku,
double precision sparse,
double precision anorm,
character pack,
complex*16, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) iwork,
integer info )

ZLATMR

Purpose:
!>
!>    ZLATMR generates random matrices of various types for testing
!>    LAPACK programs.
!>
!>    ZLATMR operates by applying the following sequence of
!>    operations:
!>
!>      Generate a matrix A with random entries of distribution DIST
!>         which is symmetric if SYM='S', Hermitian if SYM='H', and
!>         nonsymmetric if SYM='N'.
!>
!>      Set the diagonal to D, where D may be input or
!>         computed according to MODE, COND, DMAX and RSIGN
!>         as described below.
!>
!>      Grade the matrix, if desired, from the left and/or right
!>         as specified by GRADE. The inputs DL, MODEL, CONDL, DR,
!>         MODER and CONDR also determine the grading as described
!>         below.
!>
!>      Permute, if desired, the rows and/or columns as specified by
!>         PIVTNG and IPIVOT.
!>
!>      Set random entries to zero, if desired, to get a random sparse
!>         matrix as specified by SPARSE.
!>
!>      Make A a band matrix, if desired, by zeroing out the matrix
!>         outside a band of lower bandwidth KL and upper bandwidth KU.
!>
!>      Scale A, if desired, to have maximum entry ANORM.
!>
!>      Pack the matrix if desired. Options specified by PACK are:
!>         no packing
!>         zero out upper half (if symmetric or Hermitian)
!>         zero out lower half (if symmetric or Hermitian)
!>         store the upper half columnwise (if symmetric or Hermitian
!>             or square upper triangular)
!>         store the lower half columnwise (if symmetric or Hermitian
!>             or square lower triangular)
!>             same as upper half rowwise if symmetric
!>             same as conjugate upper half rowwise if Hermitian
!>         store the lower triangle in banded format
!>             (if symmetric or Hermitian)
!>         store the upper triangle in banded format
!>             (if symmetric or Hermitian)
!>         store the entire matrix in banded format
!>
!>    Note: If two calls to ZLATMR differ only in the PACK parameter,
!>          they will generate mathematically equivalent matrices.
!>
!>          If two calls to ZLATMR both have full bandwidth (KL = M-1
!>          and KU = N-1), and differ only in the PIVTNG and PACK
!>          parameters, then the matrices generated will differ only
!>          in the order of the rows and/or columns, and otherwise
!>          contain the same data. This consistency cannot be and
!>          is not maintained with less than full bandwidth.
!>
Parameters
[in]M
!>          M is INTEGER
!>           Number of rows of A. Not modified.
!>
[in]N
!>          N is INTEGER
!>           Number of columns of A. Not modified.
!>
[in]DIST
!>          DIST is CHARACTER*1
!>           On entry, DIST specifies the type of distribution to be used
!>           to generate a random matrix .
!>           'U' => real and imaginary parts are independent
!>                  UNIFORM( 0, 1 )  ( 'U' for uniform )
!>           'S' => real and imaginary parts are independent
!>                  UNIFORM( -1, 1 ) ( 'S' for symmetric )
!>           'N' => real and imaginary parts are independent
!>                  NORMAL( 0, 1 )   ( 'N' for normal )
!>           'D' => uniform on interior of unit disk ( 'D' for disk )
!>           Not modified.
!>
[in,out]ISEED
!>          ISEED is 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 ZLATMR
!>           to continue the same random number sequence.
!>           Changed on exit.
!>
[in]SYM
!>          SYM is CHARACTER*1
!>           If SYM='S', generated matrix is symmetric.
!>           If SYM='H', generated matrix is Hermitian.
!>           If SYM='N', generated matrix is nonsymmetric.
!>           Not modified.
!>
[in,out]D
!>          D is COMPLEX*16 array, dimension (min(M,N))
!>           On entry this array specifies the diagonal entries
!>           of the diagonal of A.  D may either be specified
!>           on entry, or set according to MODE and COND as described
!>           below. If the matrix is Hermitian, the real part of D
!>           will be taken. May be changed on exit if MODE is nonzero.
!>
[in]MODE
!>          MODE is INTEGER
!>           On entry describes how D is to be used:
!>           MODE = 0 means use D 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.
!>           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.
!>
[in]COND
!>          COND is DOUBLE PRECISION
!>           On entry, used as described under MODE above.
!>           If used, it must be >= 1. Not modified.
!>
[in]DMAX
!>          DMAX is COMPLEX*16
!>           If MODE neither -6, 0 nor 6, the diagonal is scaled by
!>           DMAX / max(abs(D(i))), so that maximum absolute entry
!>           of diagonal is abs(DMAX). If DMAX is complex (or zero),
!>           diagonal will be scaled by a complex number (or zero).
!>
[in]RSIGN
!>          RSIGN is CHARACTER*1
!>           If MODE neither -6, 0 nor 6, specifies sign of diagonal
!>           as follows:
!>           'T' => diagonal entries are multiplied by a random complex
!>                  number uniformly distributed with absolute value 1
!>           'F' => diagonal unchanged
!>           Not modified.
!>
[in]GRADE
!>          GRADE is CHARACTER*1
!>           Specifies grading of matrix as follows:
!>           'N'  => no grading
!>           'L'  => matrix premultiplied by diag( DL )
!>                   (only if matrix nonsymmetric)
!>           'R'  => matrix postmultiplied by diag( DR )
!>                   (only if matrix nonsymmetric)
!>           'B'  => matrix premultiplied by diag( DL ) and
!>                         postmultiplied by diag( DR )
!>                   (only if matrix nonsymmetric)
!>           'H'  => matrix premultiplied by diag( DL ) and
!>                         postmultiplied by diag( CONJG(DL) )
!>                   (only if matrix Hermitian or nonsymmetric)
!>           'S'  => matrix premultiplied by diag( DL ) and
!>                         postmultiplied by diag( DL )
!>                   (only if matrix symmetric or nonsymmetric)
!>           'E'  => matrix premultiplied by diag( DL ) and
!>                         postmultiplied by inv( diag( DL ) )
!>                         ( 'S' for similarity )
!>                   (only if matrix nonsymmetric)
!>                   Note: if GRADE='S', then M must equal N.
!>           Not modified.
!>
[in,out]DL
!>          DL is COMPLEX*16 array, dimension (M)
!>           If MODEL=0, then on entry this array specifies the diagonal
!>           entries of a diagonal matrix used as described under GRADE
!>           above. If MODEL is not zero, then DL will be set according
!>           to MODEL and CONDL, analogous to the way D is set according
!>           to MODE and COND (except there is no DMAX parameter for DL).
!>           If GRADE='E', then DL cannot have zero entries.
!>           Not referenced if GRADE = 'N' or 'R'. Changed on exit.
!>
[in]MODEL
!>          MODEL is INTEGER
!>           This specifies how the diagonal array DL is to be computed,
!>           just as MODE specifies how D is to be computed.
!>           Not modified.
!>
[in]CONDL
!>          CONDL is DOUBLE PRECISION
!>           When MODEL is not zero, this specifies the condition number
!>           of the computed DL.  Not modified.
!>
[in,out]DR
!>          DR is COMPLEX*16 array, dimension (N)
!>           If MODER=0, then on entry this array specifies the diagonal
!>           entries of a diagonal matrix used as described under GRADE
!>           above. If MODER is not zero, then DR will be set according
!>           to MODER and CONDR, analogous to the way D is set according
!>           to MODE and COND (except there is no DMAX parameter for DR).
!>           Not referenced if GRADE = 'N', 'L', 'H' or 'S'.
!>           Changed on exit.
!>
[in]MODER
!>          MODER is INTEGER
!>           This specifies how the diagonal array DR is to be computed,
!>           just as MODE specifies how D is to be computed.
!>           Not modified.
!>
[in]CONDR
!>          CONDR is DOUBLE PRECISION
!>           When MODER is not zero, this specifies the condition number
!>           of the computed DR.  Not modified.
!>
[in]PIVTNG
!>          PIVTNG is CHARACTER*1
!>           On entry specifies pivoting permutations as follows:
!>           'N' or ' ' => none.
!>           'L' => left or row pivoting (matrix must be nonsymmetric).
!>           'R' => right or column pivoting (matrix must be
!>                  nonsymmetric).
!>           'B' or 'F' => both or full pivoting, i.e., on both sides.
!>                         In this case, M must equal N
!>
!>           If two calls to ZLATMR both have full bandwidth (KL = M-1
!>           and KU = N-1), and differ only in the PIVTNG and PACK
!>           parameters, then the matrices generated will differ only
!>           in the order of the rows and/or columns, and otherwise
!>           contain the same data. This consistency cannot be
!>           maintained with less than full bandwidth.
!>
[in]IPIVOT
!>          IPIVOT is INTEGER array, dimension (N or M)
!>           This array specifies the permutation used.  After the
!>           basic matrix is generated, the rows, columns, or both
!>           are permuted.   If, say, row pivoting is selected, ZLATMR
!>           starts with the *last* row and interchanges the M-th and
!>           IPIVOT(M)-th rows, then moves to the next-to-last row,
!>           interchanging the (M-1)-th and the IPIVOT(M-1)-th rows,
!>           and so on.  In terms of , the permutation is
!>           (1 IPIVOT(1)) (2 IPIVOT(2)) ... (M IPIVOT(M))
!>           where the rightmost cycle is applied first.  This is the
!>           *inverse* of the effect of pivoting in LINPACK.  The idea
!>           is that factoring (with pivoting) an identity matrix
!>           which has been inverse-pivoted in this way should
!>           result in a pivot vector identical to IPIVOT.
!>           Not referenced if PIVTNG = 'N'. Not modified.
!>
[in]KL
!>          KL is INTEGER
!>           On entry specifies the lower bandwidth of the  matrix. For
!>           example, KL=0 implies upper triangular, KL=1 implies upper
!>           Hessenberg, and KL at least M-1 implies the matrix is not
!>           banded. Must equal KU if matrix is symmetric or Hermitian.
!>           Not modified.
!>
[in]KU
!>          KU is INTEGER
!>           On entry specifies the upper bandwidth of the  matrix. For
!>           example, KU=0 implies lower triangular, KU=1 implies lower
!>           Hessenberg, and KU at least N-1 implies the matrix is not
!>           banded. Must equal KL if matrix is symmetric or Hermitian.
!>           Not modified.
!>
[in]SPARSE
!>          SPARSE is DOUBLE PRECISION
!>           On entry specifies the sparsity of the matrix if a sparse
!>           matrix is to be generated. SPARSE should lie between
!>           0 and 1. To generate a sparse matrix, for each matrix entry
!>           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.
!>
[in]ANORM
!>          ANORM is DOUBLE PRECISION
!>           On entry specifies maximum entry of output matrix
!>           (output matrix will by multiplied by a constant so that
!>           its largest absolute entry equal ANORM)
!>           if ANORM is nonnegative. If ANORM is negative no scaling
!>           is done. Not modified.
!>
[in]PACK
!>          PACK is CHARACTER*1
!>           On entry specifies packing of matrix as follows:
!>           'N' => no packing
!>           'U' => zero out all subdiagonal entries
!>                  (if symmetric or Hermitian)
!>           'L' => zero out all superdiagonal entries
!>                  (if symmetric or Hermitian)
!>           'C' => store the upper triangle columnwise
!>                  (only if matrix symmetric or Hermitian or
!>                   square upper triangular)
!>           'R' => store the lower triangle columnwise
!>                  (only if matrix symmetric or Hermitian or
!>                   square lower triangular)
!>                  (same as upper half rowwise if symmetric)
!>                  (same as conjugate upper half rowwise if Hermitian)
!>           'B' => store the lower triangle in band storage scheme
!>                  (only if matrix symmetric or Hermitian)
!>           'Q' => store the upper triangle in band storage scheme
!>                  (only if matrix symmetric or Hermitian)
!>           'Z' => store the entire matrix in band storage scheme
!>                      (pivoting can be provided for by using this
!>                      option to store A in the trailing rows of
!>                      the allocated storage)
!>
!>           Using these options, the various LAPACK packed and banded
!>           storage schemes can be obtained:
!>           GB               - use 'Z'
!>           PB, HB or TB     - use 'B' or 'Q'
!>           PP, HP or TP     - use 'C' or 'R'
!>
!>           If two calls to ZLATMR differ only in the PACK parameter,
!>           they will generate mathematically equivalent matrices.
!>           Not modified.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>           On exit A is the desired test matrix. Only those
!>           entries of A which are significant on output
!>           will be referenced (even if A is in packed or band
!>           storage format). The 'unoccupied corners' of A in
!>           band format will be zeroed out.
!>
[in]LDA
!>          LDA is INTEGER
!>           on entry LDA specifies the first dimension of A as
!>           declared in the calling program.
!>           If PACK='N', 'U' or 'L', LDA must be at least max ( 1, M ).
!>           If PACK='C' or 'R', LDA must be at least 1.
!>           If PACK='B', or 'Q', LDA must be MIN ( KU+1, N )
!>           If PACK='Z', LDA must be at least KUU+KLL+1, where
!>           KUU = MIN ( KU, N-1 ) and KLL = MIN ( KL, M-1 )
!>           Not modified.
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (N or M)
!>           Workspace. Not referenced if PIVTNG = 'N'. Changed on exit.
!>
[out]INFO
!>          INFO is INTEGER
!>           Error parameter on exit:
!>             0 => normal return
!>            -1 => M negative or unequal to N and SYM='S' or 'H'
!>            -2 => N negative
!>            -3 => DIST illegal string
!>            -5 => SYM illegal string
!>            -7 => MODE not in range -6 to 6
!>            -8 => COND less than 1.0, and MODE neither -6, 0 nor 6
!>           -10 => MODE neither -6, 0 nor 6 and RSIGN illegal string
!>           -11 => GRADE illegal string, or GRADE='E' and
!>                  M not equal to N, or GRADE='L', 'R', 'B', 'S' or 'E'
!>                  and SYM = 'H', or GRADE='L', 'R', 'B', 'H' or 'E'
!>                  and SYM = 'S'
!>           -12 => GRADE = 'E' and DL contains zero
!>           -13 => MODEL not in range -6 to 6 and GRADE= 'L', 'B', 'H',
!>                  'S' or 'E'
!>           -14 => CONDL less than 1.0, GRADE='L', 'B', 'H', 'S' or 'E',
!>                  and MODEL neither -6, 0 nor 6
!>           -16 => MODER not in range -6 to 6 and GRADE= 'R' or 'B'
!>           -17 => CONDR less than 1.0, GRADE='R' or 'B', and
!>                  MODER neither -6, 0 nor 6
!>           -18 => PIVTNG illegal string, or PIVTNG='B' or 'F' and
!>                  M not equal to N, or PIVTNG='L' or 'R' and SYM='S'
!>                  or 'H'
!>           -19 => IPIVOT contains out of range number and
!>                  PIVTNG not equal to 'N'
!>           -20 => KL negative
!>           -21 => KU negative, or SYM='S' or 'H' and KU not equal to KL
!>           -22 => SPARSE not in range 0. to 1.
!>           -24 => PACK illegal string, or PACK='U', 'L', 'B' or 'Q'
!>                  and SYM='N', or PACK='C' and SYM='N' and either KL
!>                  not equal to 0 or N not equal to M, or PACK='R' and
!>                  SYM='N', and either KU not equal to 0 or N not equal
!>                  to M
!>           -26 => LDA too small
!>             1 => Error return from ZLATM1 (computing D)
!>             2 => Cannot scale diagonal to DMAX (max. entry is 0)
!>             3 => Error return from ZLATM1 (computing DL)
!>             4 => Error return from ZLATM1 (computing DR)
!>             5 => ANORM is positive, but matrix constructed prior to
!>                  attempting to scale it to have norm ANORM, is zero
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 486 of file zlatmr.f.

490*
491* -- LAPACK computational routine --
492* -- LAPACK is a software package provided by Univ. of Tennessee, --
493* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
494*
495* .. Scalar Arguments ..
496 CHARACTER DIST, GRADE, PACK, PIVTNG, RSIGN, SYM
497 INTEGER INFO, KL, KU, LDA, M, MODE, MODEL, MODER, N
498 DOUBLE PRECISION ANORM, COND, CONDL, CONDR, SPARSE
499 COMPLEX*16 DMAX
500* ..
501* .. Array Arguments ..
502 INTEGER IPIVOT( * ), ISEED( 4 ), IWORK( * )
503 COMPLEX*16 A( LDA, * ), D( * ), DL( * ), DR( * )
504* ..
505*
506* =====================================================================
507*
508* .. Parameters ..
509 DOUBLE PRECISION ZERO
510 parameter( zero = 0.0d0 )
511 DOUBLE PRECISION ONE
512 parameter( one = 1.0d0 )
513 COMPLEX*16 CONE
514 parameter( cone = ( 1.0d0, 0.0d0 ) )
515 COMPLEX*16 CZERO
516 parameter( czero = ( 0.0d0, 0.0d0 ) )
517* ..
518* .. Local Scalars ..
519 LOGICAL BADPVT, DZERO, FULBND
520 INTEGER I, IDIST, IGRADE, IISUB, IPACK, IPVTNG, IRSIGN,
521 $ ISUB, ISYM, J, JJSUB, JSUB, K, KLL, KUU, MNMIN,
522 $ MNSUB, MXSUB, NPVTS
523 DOUBLE PRECISION ONORM, TEMP
524 COMPLEX*16 CALPHA, CTEMP
525* ..
526* .. Local Arrays ..
527 DOUBLE PRECISION TEMPA( 1 )
528* ..
529* .. External Functions ..
530 LOGICAL LSAME
531 DOUBLE PRECISION ZLANGB, ZLANGE, ZLANSB, ZLANSP, ZLANSY
532 COMPLEX*16 ZLATM2, ZLATM3
533 EXTERNAL lsame, zlangb, zlange, zlansb, zlansp, zlansy,
534 $ zlatm2, zlatm3
535* ..
536* .. External Subroutines ..
537 EXTERNAL xerbla, zdscal, zlatm1
538* ..
539* .. Intrinsic Functions ..
540 INTRINSIC abs, dble, dconjg, max, min, mod
541* ..
542* .. Executable Statements ..
543*
544* 1) Decode and Test the input parameters.
545* Initialize flags & seed.
546*
547 info = 0
548*
549* Quick return if possible
550*
551 IF( m.EQ.0 .OR. n.EQ.0 )
552 $ RETURN
553*
554* Decode DIST
555*
556 IF( lsame( dist, 'U' ) ) THEN
557 idist = 1
558 ELSE IF( lsame( dist, 'S' ) ) THEN
559 idist = 2
560 ELSE IF( lsame( dist, 'N' ) ) THEN
561 idist = 3
562 ELSE IF( lsame( dist, 'D' ) ) THEN
563 idist = 4
564 ELSE
565 idist = -1
566 END IF
567*
568* Decode SYM
569*
570 IF( lsame( sym, 'H' ) ) THEN
571 isym = 0
572 ELSE IF( lsame( sym, 'N' ) ) THEN
573 isym = 1
574 ELSE IF( lsame( sym, 'S' ) ) THEN
575 isym = 2
576 ELSE
577 isym = -1
578 END IF
579*
580* Decode RSIGN
581*
582 IF( lsame( rsign, 'F' ) ) THEN
583 irsign = 0
584 ELSE IF( lsame( rsign, 'T' ) ) THEN
585 irsign = 1
586 ELSE
587 irsign = -1
588 END IF
589*
590* Decode PIVTNG
591*
592 IF( lsame( pivtng, 'N' ) ) THEN
593 ipvtng = 0
594 ELSE IF( lsame( pivtng, ' ' ) ) THEN
595 ipvtng = 0
596 ELSE IF( lsame( pivtng, 'L' ) ) THEN
597 ipvtng = 1
598 npvts = m
599 ELSE IF( lsame( pivtng, 'R' ) ) THEN
600 ipvtng = 2
601 npvts = n
602 ELSE IF( lsame( pivtng, 'B' ) ) THEN
603 ipvtng = 3
604 npvts = min( n, m )
605 ELSE IF( lsame( pivtng, 'F' ) ) THEN
606 ipvtng = 3
607 npvts = min( n, m )
608 ELSE
609 ipvtng = -1
610 END IF
611*
612* Decode GRADE
613*
614 IF( lsame( grade, 'N' ) ) THEN
615 igrade = 0
616 ELSE IF( lsame( grade, 'L' ) ) THEN
617 igrade = 1
618 ELSE IF( lsame( grade, 'R' ) ) THEN
619 igrade = 2
620 ELSE IF( lsame( grade, 'B' ) ) THEN
621 igrade = 3
622 ELSE IF( lsame( grade, 'E' ) ) THEN
623 igrade = 4
624 ELSE IF( lsame( grade, 'H' ) ) THEN
625 igrade = 5
626 ELSE IF( lsame( grade, 'S' ) ) THEN
627 igrade = 6
628 ELSE
629 igrade = -1
630 END IF
631*
632* Decode PACK
633*
634 IF( lsame( pack, 'N' ) ) THEN
635 ipack = 0
636 ELSE IF( lsame( pack, 'U' ) ) THEN
637 ipack = 1
638 ELSE IF( lsame( pack, 'L' ) ) THEN
639 ipack = 2
640 ELSE IF( lsame( pack, 'C' ) ) THEN
641 ipack = 3
642 ELSE IF( lsame( pack, 'R' ) ) THEN
643 ipack = 4
644 ELSE IF( lsame( pack, 'B' ) ) THEN
645 ipack = 5
646 ELSE IF( lsame( pack, 'Q' ) ) THEN
647 ipack = 6
648 ELSE IF( lsame( pack, 'Z' ) ) THEN
649 ipack = 7
650 ELSE
651 ipack = -1
652 END IF
653*
654* Set certain internal parameters
655*
656 mnmin = min( m, n )
657 kll = min( kl, m-1 )
658 kuu = min( ku, n-1 )
659*
660* If inv(DL) is used, check to see if DL has a zero entry.
661*
662 dzero = .false.
663 IF( igrade.EQ.4 .AND. model.EQ.0 ) THEN
664 DO 10 i = 1, m
665 IF( dl( i ).EQ.czero )
666 $ dzero = .true.
667 10 CONTINUE
668 END IF
669*
670* Check values in IPIVOT
671*
672 badpvt = .false.
673 IF( ipvtng.GT.0 ) THEN
674 DO 20 j = 1, npvts
675 IF( ipivot( j ).LE.0 .OR. ipivot( j ).GT.npvts )
676 $ badpvt = .true.
677 20 CONTINUE
678 END IF
679*
680* Set INFO if an error
681*
682 IF( m.LT.0 ) THEN
683 info = -1
684 ELSE IF( m.NE.n .AND. ( isym.EQ.0 .OR. isym.EQ.2 ) ) THEN
685 info = -1
686 ELSE IF( n.LT.0 ) THEN
687 info = -2
688 ELSE IF( idist.EQ.-1 ) THEN
689 info = -3
690 ELSE IF( isym.EQ.-1 ) THEN
691 info = -5
692 ELSE IF( mode.LT.-6 .OR. mode.GT.6 ) THEN
693 info = -7
694 ELSE IF( ( mode.NE.-6 .AND. mode.NE.0 .AND. mode.NE.6 ) .AND.
695 $ cond.LT.one ) THEN
696 info = -8
697 ELSE IF( ( mode.NE.-6 .AND. mode.NE.0 .AND. mode.NE.6 ) .AND.
698 $ irsign.EQ.-1 ) THEN
699 info = -10
700 ELSE IF( igrade.EQ.-1 .OR. ( igrade.EQ.4 .AND. m.NE.n ) .OR.
701 $ ( ( igrade.EQ.1 .OR. igrade.EQ.2 .OR. igrade.EQ.3 .OR.
702 $ igrade.EQ.4 .OR. igrade.EQ.6 ) .AND. isym.EQ.0 ) .OR.
703 $ ( ( igrade.EQ.1 .OR. igrade.EQ.2 .OR. igrade.EQ.3 .OR.
704 $ igrade.EQ.4 .OR. igrade.EQ.5 ) .AND. isym.EQ.2 ) ) THEN
705 info = -11
706 ELSE IF( igrade.EQ.4 .AND. dzero ) THEN
707 info = -12
708 ELSE IF( ( igrade.EQ.1 .OR. igrade.EQ.3 .OR. igrade.EQ.4 .OR.
709 $ igrade.EQ.5 .OR. igrade.EQ.6 ) .AND.
710 $ ( model.LT.-6 .OR. model.GT.6 ) ) THEN
711 info = -13
712 ELSE IF( ( igrade.EQ.1 .OR. igrade.EQ.3 .OR. igrade.EQ.4 .OR.
713 $ igrade.EQ.5 .OR. igrade.EQ.6 ) .AND.
714 $ ( model.NE.-6 .AND. model.NE.0 .AND. model.NE.6 ) .AND.
715 $ condl.LT.one ) THEN
716 info = -14
717 ELSE IF( ( igrade.EQ.2 .OR. igrade.EQ.3 ) .AND.
718 $ ( moder.LT.-6 .OR. moder.GT.6 ) ) THEN
719 info = -16
720 ELSE IF( ( igrade.EQ.2 .OR. igrade.EQ.3 ) .AND.
721 $ ( moder.NE.-6 .AND. moder.NE.0 .AND. moder.NE.6 ) .AND.
722 $ condr.LT.one ) THEN
723 info = -17
724 ELSE IF( ipvtng.EQ.-1 .OR. ( ipvtng.EQ.3 .AND. m.NE.n ) .OR.
725 $ ( ( ipvtng.EQ.1 .OR. ipvtng.EQ.2 ) .AND. ( isym.EQ.0 .OR.
726 $ isym.EQ.2 ) ) ) THEN
727 info = -18
728 ELSE IF( ipvtng.NE.0 .AND. badpvt ) THEN
729 info = -19
730 ELSE IF( kl.LT.0 ) THEN
731 info = -20
732 ELSE IF( ku.LT.0 .OR. ( ( isym.EQ.0 .OR. isym.EQ.2 ) .AND. kl.NE.
733 $ ku ) ) THEN
734 info = -21
735 ELSE IF( sparse.LT.zero .OR. sparse.GT.one ) THEN
736 info = -22
737 ELSE IF( ipack.EQ.-1 .OR. ( ( ipack.EQ.1 .OR. ipack.EQ.2 .OR.
738 $ ipack.EQ.5 .OR. ipack.EQ.6 ) .AND. isym.EQ.1 ) .OR.
739 $ ( ipack.EQ.3 .AND. isym.EQ.1 .AND. ( kl.NE.0 .OR. m.NE.
740 $ n ) ) .OR. ( ipack.EQ.4 .AND. isym.EQ.1 .AND. ( ku.NE.
741 $ 0 .OR. m.NE.n ) ) ) THEN
742 info = -24
743 ELSE IF( ( ( ipack.EQ.0 .OR. ipack.EQ.1 .OR. ipack.EQ.2 ) .AND.
744 $ lda.LT.max( 1, m ) ) .OR. ( ( ipack.EQ.3 .OR. ipack.EQ.
745 $ 4 ) .AND. lda.LT.1 ) .OR. ( ( ipack.EQ.5 .OR. ipack.EQ.
746 $ 6 ) .AND. lda.LT.kuu+1 ) .OR.
747 $ ( ipack.EQ.7 .AND. lda.LT.kll+kuu+1 ) ) THEN
748 info = -26
749 END IF
750*
751 IF( info.NE.0 ) THEN
752 CALL xerbla( 'ZLATMR', -info )
753 RETURN
754 END IF
755*
756* Decide if we can pivot consistently
757*
758 fulbnd = .false.
759 IF( kuu.EQ.n-1 .AND. kll.EQ.m-1 )
760 $ fulbnd = .true.
761*
762* Initialize random number generator
763*
764 DO 30 i = 1, 4
765 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
766 30 CONTINUE
767*
768 iseed( 4 ) = 2*( iseed( 4 ) / 2 ) + 1
769*
770* 2) Set up D, DL, and DR, if indicated.
771*
772* Compute D according to COND and MODE
773*
774 CALL zlatm1( mode, cond, irsign, idist, iseed, d, mnmin, info )
775 IF( info.NE.0 ) THEN
776 info = 1
777 RETURN
778 END IF
779 IF( mode.NE.0 .AND. mode.NE.-6 .AND. mode.NE.6 ) THEN
780*
781* Scale by DMAX
782*
783 temp = abs( d( 1 ) )
784 DO 40 i = 2, mnmin
785 temp = max( temp, abs( d( i ) ) )
786 40 CONTINUE
787 IF( temp.EQ.zero .AND. dmax.NE.czero ) THEN
788 info = 2
789 RETURN
790 END IF
791 IF( temp.NE.zero ) THEN
792 calpha = dmax / temp
793 ELSE
794 calpha = cone
795 END IF
796 DO 50 i = 1, mnmin
797 d( i ) = calpha*d( i )
798 50 CONTINUE
799*
800 END IF
801*
802* If matrix Hermitian, make D real
803*
804 IF( isym.EQ.0 ) THEN
805 DO 60 i = 1, mnmin
806 d( i ) = dble( d( i ) )
807 60 CONTINUE
808 END IF
809*
810* Compute DL if grading set
811*
812 IF( igrade.EQ.1 .OR. igrade.EQ.3 .OR. igrade.EQ.4 .OR. igrade.EQ.
813 $ 5 .OR. igrade.EQ.6 ) THEN
814 CALL zlatm1( model, condl, 0, idist, iseed, dl, m, info )
815 IF( info.NE.0 ) THEN
816 info = 3
817 RETURN
818 END IF
819 END IF
820*
821* Compute DR if grading set
822*
823 IF( igrade.EQ.2 .OR. igrade.EQ.3 ) THEN
824 CALL zlatm1( moder, condr, 0, idist, iseed, dr, n, info )
825 IF( info.NE.0 ) THEN
826 info = 4
827 RETURN
828 END IF
829 END IF
830*
831* 3) Generate IWORK if pivoting
832*
833 IF( ipvtng.GT.0 ) THEN
834 DO 70 i = 1, npvts
835 iwork( i ) = i
836 70 CONTINUE
837 IF( fulbnd ) THEN
838 DO 80 i = 1, npvts
839 k = ipivot( i )
840 j = iwork( i )
841 iwork( i ) = iwork( k )
842 iwork( k ) = j
843 80 CONTINUE
844 ELSE
845 DO 90 i = npvts, 1, -1
846 k = ipivot( i )
847 j = iwork( i )
848 iwork( i ) = iwork( k )
849 iwork( k ) = j
850 90 CONTINUE
851 END IF
852 END IF
853*
854* 4) Generate matrices for each kind of PACKing
855* Always sweep matrix columnwise (if symmetric, upper
856* half only) so that matrix generated does not depend
857* on PACK
858*
859 IF( fulbnd ) THEN
860*
861* Use ZLATM3 so matrices generated with differing PIVOTing only
862* differ only in the order of their rows and/or columns.
863*
864 IF( ipack.EQ.0 ) THEN
865 IF( isym.EQ.0 ) THEN
866 DO 110 j = 1, n
867 DO 100 i = 1, j
868 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku,
869 $ idist, iseed, d, igrade, dl, dr, ipvtng,
870 $ iwork, sparse )
871 a( isub, jsub ) = ctemp
872 a( jsub, isub ) = dconjg( ctemp )
873 100 CONTINUE
874 110 CONTINUE
875 ELSE IF( isym.EQ.1 ) THEN
876 DO 130 j = 1, n
877 DO 120 i = 1, m
878 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku,
879 $ idist, iseed, d, igrade, dl, dr, ipvtng,
880 $ iwork, sparse )
881 a( isub, jsub ) = ctemp
882 120 CONTINUE
883 130 CONTINUE
884 ELSE IF( isym.EQ.2 ) THEN
885 DO 150 j = 1, n
886 DO 140 i = 1, j
887 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku,
888 $ idist, iseed, d, igrade, dl, dr, ipvtng,
889 $ iwork, sparse )
890 a( isub, jsub ) = ctemp
891 a( jsub, isub ) = ctemp
892 140 CONTINUE
893 150 CONTINUE
894 END IF
895*
896 ELSE IF( ipack.EQ.1 ) THEN
897*
898 DO 170 j = 1, n
899 DO 160 i = 1, j
900 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku, idist,
901 $ iseed, d, igrade, dl, dr, ipvtng, iwork,
902 $ sparse )
903 mnsub = min( isub, jsub )
904 mxsub = max( isub, jsub )
905 IF( mxsub.EQ.isub .AND. isym.EQ.0 ) THEN
906 a( mnsub, mxsub ) = dconjg( ctemp )
907 ELSE
908 a( mnsub, mxsub ) = ctemp
909 END IF
910 IF( mnsub.NE.mxsub )
911 $ a( mxsub, mnsub ) = czero
912 160 CONTINUE
913 170 CONTINUE
914*
915 ELSE IF( ipack.EQ.2 ) THEN
916*
917 DO 190 j = 1, n
918 DO 180 i = 1, j
919 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku, idist,
920 $ iseed, d, igrade, dl, dr, ipvtng, iwork,
921 $ sparse )
922 mnsub = min( isub, jsub )
923 mxsub = max( isub, jsub )
924 IF( mxsub.EQ.jsub .AND. isym.EQ.0 ) THEN
925 a( mxsub, mnsub ) = dconjg( ctemp )
926 ELSE
927 a( mxsub, mnsub ) = ctemp
928 END IF
929 IF( mnsub.NE.mxsub )
930 $ a( mnsub, mxsub ) = czero
931 180 CONTINUE
932 190 CONTINUE
933*
934 ELSE IF( ipack.EQ.3 ) THEN
935*
936 DO 210 j = 1, n
937 DO 200 i = 1, j
938 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku, idist,
939 $ iseed, d, igrade, dl, dr, ipvtng, iwork,
940 $ sparse )
941*
942* Compute K = location of (ISUB,JSUB) entry in packed
943* array
944*
945 mnsub = min( isub, jsub )
946 mxsub = max( isub, jsub )
947 k = mxsub*( mxsub-1 ) / 2 + mnsub
948*
949* Convert K to (IISUB,JJSUB) location
950*
951 jjsub = ( k-1 ) / lda + 1
952 iisub = k - lda*( jjsub-1 )
953*
954 IF( mxsub.EQ.isub .AND. isym.EQ.0 ) THEN
955 a( iisub, jjsub ) = dconjg( ctemp )
956 ELSE
957 a( iisub, jjsub ) = ctemp
958 END IF
959 200 CONTINUE
960 210 CONTINUE
961*
962 ELSE IF( ipack.EQ.4 ) THEN
963*
964 DO 230 j = 1, n
965 DO 220 i = 1, j
966 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku, idist,
967 $ iseed, d, igrade, dl, dr, ipvtng, iwork,
968 $ sparse )
969*
970* Compute K = location of (I,J) entry in packed array
971*
972 mnsub = min( isub, jsub )
973 mxsub = max( isub, jsub )
974 IF( mnsub.EQ.1 ) THEN
975 k = mxsub
976 ELSE
977 k = n*( n+1 ) / 2 - ( n-mnsub+1 )*( n-mnsub+2 ) /
978 $ 2 + mxsub - mnsub + 1
979 END IF
980*
981* Convert K to (IISUB,JJSUB) location
982*
983 jjsub = ( k-1 ) / lda + 1
984 iisub = k - lda*( jjsub-1 )
985*
986 IF( mxsub.EQ.jsub .AND. isym.EQ.0 ) THEN
987 a( iisub, jjsub ) = dconjg( ctemp )
988 ELSE
989 a( iisub, jjsub ) = ctemp
990 END IF
991 220 CONTINUE
992 230 CONTINUE
993*
994 ELSE IF( ipack.EQ.5 ) THEN
995*
996 DO 250 j = 1, n
997 DO 240 i = j - kuu, j
998 IF( i.LT.1 ) THEN
999 a( j-i+1, i+n ) = czero
1000 ELSE
1001 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku,
1002 $ idist, iseed, d, igrade, dl, dr, ipvtng,
1003 $ iwork, sparse )
1004 mnsub = min( isub, jsub )
1005 mxsub = max( isub, jsub )
1006 IF( mxsub.EQ.jsub .AND. isym.EQ.0 ) THEN
1007 a( mxsub-mnsub+1, mnsub ) = dconjg( ctemp )
1008 ELSE
1009 a( mxsub-mnsub+1, mnsub ) = ctemp
1010 END IF
1011 END IF
1012 240 CONTINUE
1013 250 CONTINUE
1014*
1015 ELSE IF( ipack.EQ.6 ) THEN
1016*
1017 DO 270 j = 1, n
1018 DO 260 i = j - kuu, j
1019 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku, idist,
1020 $ iseed, d, igrade, dl, dr, ipvtng, iwork,
1021 $ sparse )
1022 mnsub = min( isub, jsub )
1023 mxsub = max( isub, jsub )
1024 IF( mxsub.EQ.isub .AND. isym.EQ.0 ) THEN
1025 a( mnsub-mxsub+kuu+1, mxsub ) = dconjg( ctemp )
1026 ELSE
1027 a( mnsub-mxsub+kuu+1, mxsub ) = ctemp
1028 END IF
1029 260 CONTINUE
1030 270 CONTINUE
1031*
1032 ELSE IF( ipack.EQ.7 ) THEN
1033*
1034 IF( isym.NE.1 ) THEN
1035 DO 290 j = 1, n
1036 DO 280 i = j - kuu, j
1037 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku,
1038 $ idist, iseed, d, igrade, dl, dr, ipvtng,
1039 $ iwork, sparse )
1040 mnsub = min( isub, jsub )
1041 mxsub = max( isub, jsub )
1042 IF( i.LT.1 )
1043 $ a( j-i+1+kuu, i+n ) = czero
1044 IF( mxsub.EQ.isub .AND. isym.EQ.0 ) THEN
1045 a( mnsub-mxsub+kuu+1, mxsub ) = dconjg( ctemp )
1046 ELSE
1047 a( mnsub-mxsub+kuu+1, mxsub ) = ctemp
1048 END IF
1049 IF( i.GE.1 .AND. mnsub.NE.mxsub ) THEN
1050 IF( mnsub.EQ.isub .AND. isym.EQ.0 ) THEN
1051 a( mxsub-mnsub+1+kuu,
1052 $ mnsub ) = dconjg( ctemp )
1053 ELSE
1054 a( mxsub-mnsub+1+kuu, mnsub ) = ctemp
1055 END IF
1056 END IF
1057 280 CONTINUE
1058 290 CONTINUE
1059 ELSE IF( isym.EQ.1 ) THEN
1060 DO 310 j = 1, n
1061 DO 300 i = j - kuu, j + kll
1062 ctemp = zlatm3( m, n, i, j, isub, jsub, kl, ku,
1063 $ idist, iseed, d, igrade, dl, dr, ipvtng,
1064 $ iwork, sparse )
1065 a( isub-jsub+kuu+1, jsub ) = ctemp
1066 300 CONTINUE
1067 310 CONTINUE
1068 END IF
1069*
1070 END IF
1071*
1072 ELSE
1073*
1074* Use ZLATM2
1075*
1076 IF( ipack.EQ.0 ) THEN
1077 IF( isym.EQ.0 ) THEN
1078 DO 330 j = 1, n
1079 DO 320 i = 1, j
1080 a( i, j ) = zlatm2( m, n, i, j, kl, ku, idist,
1081 $ iseed, d, igrade, dl, dr, ipvtng,
1082 $ iwork, sparse )
1083 a( j, i ) = dconjg( a( i, j ) )
1084 320 CONTINUE
1085 330 CONTINUE
1086 ELSE IF( isym.EQ.1 ) THEN
1087 DO 350 j = 1, n
1088 DO 340 i = 1, m
1089 a( i, j ) = zlatm2( m, n, i, j, kl, ku, idist,
1090 $ iseed, d, igrade, dl, dr, ipvtng,
1091 $ iwork, sparse )
1092 340 CONTINUE
1093 350 CONTINUE
1094 ELSE IF( isym.EQ.2 ) THEN
1095 DO 370 j = 1, n
1096 DO 360 i = 1, j
1097 a( i, j ) = zlatm2( m, n, i, j, kl, ku, idist,
1098 $ iseed, d, igrade, dl, dr, ipvtng,
1099 $ iwork, sparse )
1100 a( j, i ) = a( i, j )
1101 360 CONTINUE
1102 370 CONTINUE
1103 END IF
1104*
1105 ELSE IF( ipack.EQ.1 ) THEN
1106*
1107 DO 390 j = 1, n
1108 DO 380 i = 1, j
1109 a( i, j ) = zlatm2( m, n, i, j, kl, ku, idist, iseed,
1110 $ d, igrade, dl, dr, ipvtng, iwork, sparse )
1111 IF( i.NE.j )
1112 $ a( j, i ) = czero
1113 380 CONTINUE
1114 390 CONTINUE
1115*
1116 ELSE IF( ipack.EQ.2 ) THEN
1117*
1118 DO 410 j = 1, n
1119 DO 400 i = 1, j
1120 IF( isym.EQ.0 ) THEN
1121 a( j, i ) = dconjg( zlatm2( m, n, i, j, kl, ku,
1122 $ idist, iseed, d, igrade, dl, dr,
1123 $ ipvtng, iwork, sparse ) )
1124 ELSE
1125 a( j, i ) = zlatm2( m, n, i, j, kl, ku, idist,
1126 $ iseed, d, igrade, dl, dr, ipvtng,
1127 $ iwork, sparse )
1128 END IF
1129 IF( i.NE.j )
1130 $ a( i, j ) = czero
1131 400 CONTINUE
1132 410 CONTINUE
1133*
1134 ELSE IF( ipack.EQ.3 ) THEN
1135*
1136 isub = 0
1137 jsub = 1
1138 DO 430 j = 1, n
1139 DO 420 i = 1, j
1140 isub = isub + 1
1141 IF( isub.GT.lda ) THEN
1142 isub = 1
1143 jsub = jsub + 1
1144 END IF
1145 a( isub, jsub ) = zlatm2( m, n, i, j, kl, ku, idist,
1146 $ iseed, d, igrade, dl, dr, ipvtng,
1147 $ iwork, sparse )
1148 420 CONTINUE
1149 430 CONTINUE
1150*
1151 ELSE IF( ipack.EQ.4 ) THEN
1152*
1153 IF( isym.EQ.0 .OR. isym.EQ.2 ) THEN
1154 DO 450 j = 1, n
1155 DO 440 i = 1, j
1156*
1157* Compute K = location of (I,J) entry in packed array
1158*
1159 IF( i.EQ.1 ) THEN
1160 k = j
1161 ELSE
1162 k = n*( n+1 ) / 2 - ( n-i+1 )*( n-i+2 ) / 2 +
1163 $ j - i + 1
1164 END IF
1165*
1166* Convert K to (ISUB,JSUB) location
1167*
1168 jsub = ( k-1 ) / lda + 1
1169 isub = k - lda*( jsub-1 )
1170*
1171 a( isub, jsub ) = zlatm2( m, n, i, j, kl, ku,
1172 $ idist, iseed, d, igrade, dl, dr,
1173 $ ipvtng, iwork, sparse )
1174 IF( isym.EQ.0 )
1175 $ a( isub, jsub ) = dconjg( a( isub, jsub ) )
1176 440 CONTINUE
1177 450 CONTINUE
1178 ELSE
1179 isub = 0
1180 jsub = 1
1181 DO 470 j = 1, n
1182 DO 460 i = j, m
1183 isub = isub + 1
1184 IF( isub.GT.lda ) THEN
1185 isub = 1
1186 jsub = jsub + 1
1187 END IF
1188 a( isub, jsub ) = zlatm2( m, n, i, j, kl, ku,
1189 $ idist, iseed, d, igrade, dl, dr,
1190 $ ipvtng, iwork, sparse )
1191 460 CONTINUE
1192 470 CONTINUE
1193 END IF
1194*
1195 ELSE IF( ipack.EQ.5 ) THEN
1196*
1197 DO 490 j = 1, n
1198 DO 480 i = j - kuu, j
1199 IF( i.LT.1 ) THEN
1200 a( j-i+1, i+n ) = czero
1201 ELSE
1202 IF( isym.EQ.0 ) THEN
1203 a( j-i+1, i ) = dconjg( zlatm2( m, n, i, j, kl,
1204 $ ku, idist, iseed, d, igrade, dl,
1205 $ dr, ipvtng, iwork, sparse ) )
1206 ELSE
1207 a( j-i+1, i ) = zlatm2( m, n, i, j, kl, ku,
1208 $ idist, iseed, d, igrade, dl, dr,
1209 $ ipvtng, iwork, sparse )
1210 END IF
1211 END IF
1212 480 CONTINUE
1213 490 CONTINUE
1214*
1215 ELSE IF( ipack.EQ.6 ) THEN
1216*
1217 DO 510 j = 1, n
1218 DO 500 i = j - kuu, j
1219 a( i-j+kuu+1, j ) = zlatm2( m, n, i, j, kl, ku, idist,
1220 $ iseed, d, igrade, dl, dr, ipvtng,
1221 $ iwork, sparse )
1222 500 CONTINUE
1223 510 CONTINUE
1224*
1225 ELSE IF( ipack.EQ.7 ) THEN
1226*
1227 IF( isym.NE.1 ) THEN
1228 DO 530 j = 1, n
1229 DO 520 i = j - kuu, j
1230 a( i-j+kuu+1, j ) = zlatm2( m, n, i, j, kl, ku,
1231 $ idist, iseed, d, igrade, dl,
1232 $ dr, ipvtng, iwork, sparse )
1233 IF( i.LT.1 )
1234 $ a( j-i+1+kuu, i+n ) = czero
1235 IF( i.GE.1 .AND. i.NE.j ) THEN
1236 IF( isym.EQ.0 ) THEN
1237 a( j-i+1+kuu, i ) = dconjg( a( i-j+kuu+1,
1238 $ j ) )
1239 ELSE
1240 a( j-i+1+kuu, i ) = a( i-j+kuu+1, j )
1241 END IF
1242 END IF
1243 520 CONTINUE
1244 530 CONTINUE
1245 ELSE IF( isym.EQ.1 ) THEN
1246 DO 550 j = 1, n
1247 DO 540 i = j - kuu, j + kll
1248 a( i-j+kuu+1, j ) = zlatm2( m, n, i, j, kl, ku,
1249 $ idist, iseed, d, igrade, dl,
1250 $ dr, ipvtng, iwork, sparse )
1251 540 CONTINUE
1252 550 CONTINUE
1253 END IF
1254*
1255 END IF
1256*
1257 END IF
1258*
1259* 5) Scaling the norm
1260*
1261 IF( ipack.EQ.0 ) THEN
1262 onorm = zlange( 'M', m, n, a, lda, tempa )
1263 ELSE IF( ipack.EQ.1 ) THEN
1264 onorm = zlansy( 'M', 'U', n, a, lda, tempa )
1265 ELSE IF( ipack.EQ.2 ) THEN
1266 onorm = zlansy( 'M', 'L', n, a, lda, tempa )
1267 ELSE IF( ipack.EQ.3 ) THEN
1268 onorm = zlansp( 'M', 'U', n, a, tempa )
1269 ELSE IF( ipack.EQ.4 ) THEN
1270 onorm = zlansp( 'M', 'L', n, a, tempa )
1271 ELSE IF( ipack.EQ.5 ) THEN
1272 onorm = zlansb( 'M', 'L', n, kll, a, lda, tempa )
1273 ELSE IF( ipack.EQ.6 ) THEN
1274 onorm = zlansb( 'M', 'U', n, kuu, a, lda, tempa )
1275 ELSE IF( ipack.EQ.7 ) THEN
1276 onorm = zlangb( 'M', n, kll, kuu, a, lda, tempa )
1277 END IF
1278*
1279 IF( anorm.GE.zero ) THEN
1280*
1281 IF( anorm.GT.zero .AND. onorm.EQ.zero ) THEN
1282*
1283* Desired scaling impossible
1284*
1285 info = 5
1286 RETURN
1287*
1288 ELSE IF( ( anorm.GT.one .AND. onorm.LT.one ) .OR.
1289 $ ( anorm.LT.one .AND. onorm.GT.one ) ) THEN
1290*
1291* Scale carefully to avoid over / underflow
1292*
1293 IF( ipack.LE.2 ) THEN
1294 DO 560 j = 1, n
1295 CALL zdscal( m, one / onorm, a( 1, j ), 1 )
1296 CALL zdscal( m, anorm, a( 1, j ), 1 )
1297 560 CONTINUE
1298*
1299 ELSE IF( ipack.EQ.3 .OR. ipack.EQ.4 ) THEN
1300*
1301 CALL zdscal( n*( n+1 ) / 2, one / onorm, a, 1 )
1302 CALL zdscal( n*( n+1 ) / 2, anorm, a, 1 )
1303*
1304 ELSE IF( ipack.GE.5 ) THEN
1305*
1306 DO 570 j = 1, n
1307 CALL zdscal( kll+kuu+1, one / onorm, a( 1, j ), 1 )
1308 CALL zdscal( kll+kuu+1, anorm, a( 1, j ), 1 )
1309 570 CONTINUE
1310*
1311 END IF
1312*
1313 ELSE
1314*
1315* Scale straightforwardly
1316*
1317 IF( ipack.LE.2 ) THEN
1318 DO 580 j = 1, n
1319 CALL zdscal( m, anorm / onorm, a( 1, j ), 1 )
1320 580 CONTINUE
1321*
1322 ELSE IF( ipack.EQ.3 .OR. ipack.EQ.4 ) THEN
1323*
1324 CALL zdscal( n*( n+1 ) / 2, anorm / onorm, a, 1 )
1325*
1326 ELSE IF( ipack.GE.5 ) THEN
1327*
1328 DO 590 j = 1, n
1329 CALL zdscal( kll+kuu+1, anorm / onorm, a( 1, j ), 1 )
1330 590 CONTINUE
1331 END IF
1332*
1333 END IF
1334*
1335 END IF
1336*
1337* End of ZLATMR
1338*
zlangb
double precision function zlangb(norm, n, kl, ku, ab, ldab, work)
ZLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition zlangb.f:125
zlansp
double precision function zlansp(norm, uplo, n, ap, work)
ZLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlansp.f:115
zlansb
double precision function zlansb(norm, uplo, n, k, ab, ldab, work)
ZLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlansb.f:130
zlansy
double precision function zlansy(norm, uplo, n, a, lda, work)
ZLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlansy.f:123

◆ zlatms()

subroutine zlatms ( integer m,
integer n,
character dist,
integer, dimension( 4 ) iseed,
character sym,
double precision, dimension( * ) d,
integer mode,
double precision cond,
double precision dmax,
integer kl,
integer ku,
character pack,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) work,
integer info )

ZLATMS

Purpose:
!>
!>    ZLATMS generates random matrices with specified singular values
!>    (or hermitian with specified eigenvalues)
!>    for testing LAPACK programs.
!>
!>    ZLATMS operates by applying the following sequence of
!>    operations:
!>
!>      Set the diagonal to D, where D may be input or
!>         computed according to MODE, COND, DMAX, and SYM
!>         as described below.
!>
!>      Generate a matrix with the appropriate band structure, by one
!>         of two methods:
!>
!>      Method A:
!>          Generate a dense M x N matrix by multiplying D on the left
!>              and the right by random unitary matrices, then:
!>
!>          Reduce the bandwidth according to KL and KU, using
!>              Householder transformations.
!>
!>      Method B:
!>          Convert the bandwidth-0 (i.e., diagonal) matrix to a
!>              bandwidth-1 matrix using Givens rotations, 
!>              out-of-band elements back, much as in QR; then convert
!>              the bandwidth-1 to a bandwidth-2 matrix, etc.  Note
!>              that for reasonably small bandwidths (relative to M and
!>              N) this requires less storage, as a dense matrix is not
!>              generated.  Also, for hermitian or symmetric matrices,
!>              only one triangle is generated.
!>
!>      Method A is chosen if the bandwidth is a large fraction of the
!>          order of the matrix, and LDA is at least M (so a dense
!>          matrix can be stored.)  Method B is chosen if the bandwidth
!>          is small (< 1/2 N for hermitian or symmetric, < .3 N+M for
!>          non-symmetric), or LDA is less than M and not less than the
!>          bandwidth.
!>
!>      Pack the matrix if desired. Options specified by PACK are:
!>         no packing
!>         zero out upper half (if hermitian)
!>         zero out lower half (if hermitian)
!>         store the upper half columnwise (if hermitian or upper
!>               triangular)
!>         store the lower half columnwise (if hermitian or lower
!>               triangular)
!>         store the lower triangle in banded format (if hermitian or
!>               lower triangular)
!>         store the upper triangle in banded format (if hermitian or
!>               upper triangular)
!>         store the entire matrix in banded format
!>      If Method B is chosen, and band format is specified, then the
!>         matrix will be generated in the band format, so no repacking
!>         will be necessary.
!>
Parameters
[in]M
!>          M is INTEGER
!>           The number of rows of A. Not modified.
!>
[in]N
!>          N is INTEGER
!>           The number of columns of A. N must equal M if the matrix
!>           is symmetric or hermitian (i.e., if SYM is not 'N')
!>           Not modified.
!>
[in]DIST
!>          DIST is CHARACTER*1
!>           On entry, DIST specifies the type of distribution to be used
!>           to generate the random eigen-/singular values.
!>           'U' => UNIFORM( 0, 1 )  ( 'U' for uniform )
!>           'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
!>           'N' => NORMAL( 0, 1 )   ( 'N' for normal )
!>           Not modified.
!>
[in,out]ISEED
!>          ISEED is 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 ZLATMS
!>           to continue the same random number sequence.
!>           Changed on exit.
!>
[in]SYM
!>          SYM is CHARACTER*1
!>           If SYM='H', the generated matrix is hermitian, with
!>             eigenvalues specified by D, COND, MODE, and DMAX; they
!>             may be positive, negative, or zero.
!>           If SYM='P', the generated matrix is hermitian, with
!>             eigenvalues (= singular values) specified by D, COND,
!>             MODE, and DMAX; they will not be negative.
!>           If SYM='N', the generated matrix is nonsymmetric, with
!>             singular values specified by D, COND, MODE, and DMAX;
!>             they will not be negative.
!>           If SYM='S', the generated matrix is (complex) symmetric,
!>             with singular values specified by D, COND, MODE, and
!>             DMAX; they will not be negative.
!>           Not modified.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension ( MIN( M, N ) )
!>           This array is used to specify the singular values or
!>           eigenvalues of A (see SYM, above.)  If MODE=0, then D is
!>           assumed to contain the singular/eigenvalues, otherwise
!>           they will be computed according to MODE, COND, and DMAX,
!>           and placed in D.
!>           Modified if MODE is nonzero.
!>
[in]MODE
!>          MODE is INTEGER
!>           On entry this describes how the singular/eigenvalues are to
!>           be specified:
!>           MODE = 0 means use D 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.
!>           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,
!>           If SYM='H', and MODE is neither 0, 6, nor -6, then
!>              the elements of D will also be multiplied by a random
!>              sign (i.e., +1 or -1.)
!>           Not modified.
!>
[in]COND
!>          COND is DOUBLE PRECISION
!>           On entry, this is used as described under MODE above.
!>           If used, it must be >= 1. Not modified.
!>
[in]DMAX
!>          DMAX is 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))); thus, the maximum absolute eigen- or
!>           singular value (which is to say the norm) will be abs(DMAX).
!>           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.
!>
[in]KL
!>          KL is INTEGER
!>           This specifies the lower bandwidth of the  matrix. For
!>           example, KL=0 implies upper triangular, KL=1 implies upper
!>           Hessenberg, and KL being at least M-1 means that the matrix
!>           has full lower bandwidth.  KL must equal KU if the matrix
!>           is symmetric or hermitian.
!>           Not modified.
!>
[in]KU
!>          KU is INTEGER
!>           This specifies the upper bandwidth of the  matrix. For
!>           example, KU=0 implies lower triangular, KU=1 implies lower
!>           Hessenberg, and KU being at least N-1 means that the matrix
!>           has full upper bandwidth.  KL must equal KU if the matrix
!>           is symmetric or hermitian.
!>           Not modified.
!>
[in]PACK
!>          PACK is CHARACTER*1
!>           This specifies packing of matrix as follows:
!>           'N' => no packing
!>           'U' => zero out all subdiagonal entries (if symmetric
!>                  or hermitian)
!>           'L' => zero out all superdiagonal entries (if symmetric
!>                  or hermitian)
!>           'C' => store the upper triangle columnwise (only if the
!>                  matrix is symmetric, hermitian, or upper triangular)
!>           'R' => store the lower triangle columnwise (only if the
!>                  matrix is symmetric, hermitian, or lower triangular)
!>           'B' => store the lower triangle in band storage scheme
!>                  (only if the matrix is symmetric, hermitian, or
!>                  lower triangular)
!>           'Q' => store the upper triangle in band storage scheme
!>                  (only if the matrix is symmetric, hermitian, or
!>                  upper triangular)
!>           'Z' => store the entire matrix in band storage scheme
!>                      (pivoting can be provided for by using this
!>                      option to store A in the trailing rows of
!>                      the allocated storage)
!>
!>           Using these options, the various LAPACK packed and banded
!>           storage schemes can be obtained:
!>           GB                    - use 'Z'
!>           PB, SB, HB, or TB     - use 'B' or 'Q'
!>           PP, SP, HB, or TP     - use 'C' or 'R'
!>
!>           If two calls to ZLATMS differ only in the PACK parameter,
!>           they will generate mathematically equivalent matrices.
!>           Not modified.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension ( LDA, N )
!>           On exit A is the desired test matrix.  A is first generated
!>           in full (unpacked) form, and then packed, if so specified
!>           by PACK.  Thus, the first M elements of the first N
!>           columns will always be modified.  If PACK specifies a
!>           packed or banded storage scheme, all LDA elements of the
!>           first N columns will be modified; the elements of the
!>           array which do not correspond to elements of the generated
!>           matrix are set to zero.
!>           Modified.
!>
[in]LDA
!>          LDA is INTEGER
!>           LDA specifies the first dimension of A as declared in the
!>           calling program.  If PACK='N', 'U', 'L', 'C', or 'R', then
!>           LDA must be at least M.  If PACK='B' or 'Q', then LDA must
!>           be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)).
!>           If PACK='Z', LDA must be large enough to hold the packed
!>           array: MIN( KU, N-1) + MIN( KL, M-1) + 1.
!>           Not modified.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension ( 3*MAX( N, M ) )
!>           Workspace.
!>           Modified.
!>
[out]INFO
!>          INFO is INTEGER
!>           Error code.  On exit, INFO will be set to one of the
!>           following values:
!>             0 => normal return
!>            -1 => M negative or unequal to N and SYM='S', 'H', or 'P'
!>            -2 => N negative
!>            -3 => DIST illegal string
!>            -5 => SYM illegal string
!>            -7 => MODE not in range -6 to 6
!>            -8 => COND less than 1.0, and MODE neither -6, 0 nor 6
!>           -10 => KL negative
!>           -11 => KU negative, or SYM is not 'N' and KU is not equal to
!>                  KL
!>           -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N';
!>                  or PACK='C' or 'Q' and SYM='N' and KL is not zero;
!>                  or PACK='R' or 'B' and SYM='N' and KU is not zero;
!>                  or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not
!>                  N.
!>           -14 => LDA is less than M, or PACK='Z' and LDA is less than
!>                  MIN(KU,N-1) + MIN(KL,M-1) + 1.
!>            1  => Error return from DLATM1
!>            2  => Cannot scale to DMAX (max. sing. value is 0)
!>            3  => Error return from ZLAGGE, CLAGHE or CLAGSY
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 330 of file zlatms.f.

332*
333* -- LAPACK computational routine --
334* -- LAPACK is a software package provided by Univ. of Tennessee, --
335* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
336*
337* .. Scalar Arguments ..
338 CHARACTER DIST, PACK, SYM
339 INTEGER INFO, KL, KU, LDA, M, MODE, N
340 DOUBLE PRECISION COND, DMAX
341* ..
342* .. Array Arguments ..
343 INTEGER ISEED( 4 )
344 DOUBLE PRECISION D( * )
345 COMPLEX*16 A( LDA, * ), WORK( * )
346* ..
347*
348* =====================================================================
349*
350* .. Parameters ..
351 DOUBLE PRECISION ZERO
352 parameter( zero = 0.0d+0 )
353 DOUBLE PRECISION ONE
354 parameter( one = 1.0d+0 )
355 COMPLEX*16 CZERO
356 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
357 DOUBLE PRECISION TWOPI
358 parameter( twopi = 6.28318530717958647692528676655900576839d+0 )
359* ..
360* .. Local Scalars ..
361 LOGICAL GIVENS, ILEXTR, ILTEMP, TOPDWN, ZSYM
362 INTEGER I, IC, ICOL, IDIST, IENDCH, IINFO, IL, ILDA,
363 $ IOFFG, IOFFST, IPACK, IPACKG, IR, IR1, IR2,
364 $ IROW, IRSIGN, ISKEW, ISYM, ISYMPK, J, JC, JCH,
365 $ JKL, JKU, JR, K, LLB, MINLDA, MNMIN, MR, NC,
366 $ UUB
367 DOUBLE PRECISION ALPHA, ANGLE, REALC, TEMP
368 COMPLEX*16 C, CT, CTEMP, DUMMY, EXTRA, S, ST
369* ..
370* .. External Functions ..
371 LOGICAL LSAME
372 DOUBLE PRECISION DLARND
373 COMPLEX*16 ZLARND
374 EXTERNAL lsame, dlarnd, zlarnd
375* ..
376* .. External Subroutines ..
377 EXTERNAL dlatm1, dscal, xerbla, zlagge, zlaghe, zlagsy,
378 $ zlarot, zlartg, zlaset
379* ..
380* .. Intrinsic Functions ..
381 INTRINSIC abs, cos, dble, dcmplx, dconjg, max, min, mod,
382 $ sin
383* ..
384* .. Executable Statements ..
385*
386* 1) Decode and Test the input parameters.
387* Initialize flags & seed.
388*
389 info = 0
390*
391* Quick return if possible
392*
393 IF( m.EQ.0 .OR. n.EQ.0 )
394 $ RETURN
395*
396* Decode DIST
397*
398 IF( lsame( dist, 'U' ) ) THEN
399 idist = 1
400 ELSE IF( lsame( dist, 'S' ) ) THEN
401 idist = 2
402 ELSE IF( lsame( dist, 'N' ) ) THEN
403 idist = 3
404 ELSE
405 idist = -1
406 END IF
407*
408* Decode SYM
409*
410 IF( lsame( sym, 'N' ) ) THEN
411 isym = 1
412 irsign = 0
413 zsym = .false.
414 ELSE IF( lsame( sym, 'P' ) ) THEN
415 isym = 2
416 irsign = 0
417 zsym = .false.
418 ELSE IF( lsame( sym, 'S' ) ) THEN
419 isym = 2
420 irsign = 0
421 zsym = .true.
422 ELSE IF( lsame( sym, 'H' ) ) THEN
423 isym = 2
424 irsign = 1
425 zsym = .false.
426 ELSE
427 isym = -1
428 END IF
429*
430* Decode PACK
431*
432 isympk = 0
433 IF( lsame( pack, 'N' ) ) THEN
434 ipack = 0
435 ELSE IF( lsame( pack, 'U' ) ) THEN
436 ipack = 1
437 isympk = 1
438 ELSE IF( lsame( pack, 'L' ) ) THEN
439 ipack = 2
440 isympk = 1
441 ELSE IF( lsame( pack, 'C' ) ) THEN
442 ipack = 3
443 isympk = 2
444 ELSE IF( lsame( pack, 'R' ) ) THEN
445 ipack = 4
446 isympk = 3
447 ELSE IF( lsame( pack, 'B' ) ) THEN
448 ipack = 5
449 isympk = 3
450 ELSE IF( lsame( pack, 'Q' ) ) THEN
451 ipack = 6
452 isympk = 2
453 ELSE IF( lsame( pack, 'Z' ) ) THEN
454 ipack = 7
455 ELSE
456 ipack = -1
457 END IF
458*
459* Set certain internal parameters
460*
461 mnmin = min( m, n )
462 llb = min( kl, m-1 )
463 uub = min( ku, n-1 )
464 mr = min( m, n+llb )
465 nc = min( n, m+uub )
466*
467 IF( ipack.EQ.5 .OR. ipack.EQ.6 ) THEN
468 minlda = uub + 1
469 ELSE IF( ipack.EQ.7 ) THEN
470 minlda = llb + uub + 1
471 ELSE
472 minlda = m
473 END IF
474*
475* Use Givens rotation method if bandwidth small enough,
476* or if LDA is too small to store the matrix unpacked.
477*
478 givens = .false.
479 IF( isym.EQ.1 ) THEN
480 IF( dble( llb+uub ).LT.0.3d0*dble( max( 1, mr+nc ) ) )
481 $ givens = .true.
482 ELSE
483 IF( 2*llb.LT.m )
484 $ givens = .true.
485 END IF
486 IF( lda.LT.m .AND. lda.GE.minlda )
487 $ givens = .true.
488*
489* Set INFO if an error
490*
491 IF( m.LT.0 ) THEN
492 info = -1
493 ELSE IF( m.NE.n .AND. isym.NE.1 ) THEN
494 info = -1
495 ELSE IF( n.LT.0 ) THEN
496 info = -2
497 ELSE IF( idist.EQ.-1 ) THEN
498 info = -3
499 ELSE IF( isym.EQ.-1 ) THEN
500 info = -5
501 ELSE IF( abs( mode ).GT.6 ) THEN
502 info = -7
503 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
504 $ THEN
505 info = -8
506 ELSE IF( kl.LT.0 ) THEN
507 info = -10
508 ELSE IF( ku.LT.0 .OR. ( isym.NE.1 .AND. kl.NE.ku ) ) THEN
509 info = -11
510 ELSE IF( ipack.EQ.-1 .OR. ( isympk.EQ.1 .AND. isym.EQ.1 ) .OR.
511 $ ( isympk.EQ.2 .AND. isym.EQ.1 .AND. kl.GT.0 ) .OR.
512 $ ( isympk.EQ.3 .AND. isym.EQ.1 .AND. ku.GT.0 ) .OR.
513 $ ( isympk.NE.0 .AND. m.NE.n ) ) THEN
514 info = -12
515 ELSE IF( lda.LT.max( 1, minlda ) ) THEN
516 info = -14
517 END IF
518*
519 IF( info.NE.0 ) THEN
520 CALL xerbla( 'ZLATMS', -info )
521 RETURN
522 END IF
523*
524* Initialize random number generator
525*
526 DO 10 i = 1, 4
527 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
528 10 CONTINUE
529*
530 IF( mod( iseed( 4 ), 2 ).NE.1 )
531 $ iseed( 4 ) = iseed( 4 ) + 1
532*
533* 2) Set up D if indicated.
534*
535* Compute D according to COND and MODE
536*
537 CALL dlatm1( mode, cond, irsign, idist, iseed, d, mnmin, iinfo )
538 IF( iinfo.NE.0 ) THEN
539 info = 1
540 RETURN
541 END IF
542*
543* Choose Top-Down if D is (apparently) increasing,
544* Bottom-Up if D is (apparently) decreasing.
545*
546 IF( abs( d( 1 ) ).LE.abs( d( mnmin ) ) ) THEN
547 topdwn = .true.
548 ELSE
549 topdwn = .false.
550 END IF
551*
552 IF( mode.NE.0 .AND. abs( mode ).NE.6 ) THEN
553*
554* Scale by DMAX
555*
556 temp = abs( d( 1 ) )
557 DO 20 i = 2, mnmin
558 temp = max( temp, abs( d( i ) ) )
559 20 CONTINUE
560*
561 IF( temp.GT.zero ) THEN
562 alpha = dmax / temp
563 ELSE
564 info = 2
565 RETURN
566 END IF
567*
568 CALL dscal( mnmin, alpha, d, 1 )
569*
570 END IF
571*
572 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
573*
574* 3) Generate Banded Matrix using Givens rotations.
575* Also the special case of UUB=LLB=0
576*
577* Compute Addressing constants to cover all
578* storage formats. Whether GE, HE, SY, GB, HB, or SB,
579* upper or lower triangle or both,
580* the (i,j)-th element is in
581* A( i - ISKEW*j + IOFFST, j )
582*
583 IF( ipack.GT.4 ) THEN
584 ilda = lda - 1
585 iskew = 1
586 IF( ipack.GT.5 ) THEN
587 ioffst = uub + 1
588 ELSE
589 ioffst = 1
590 END IF
591 ELSE
592 ilda = lda
593 iskew = 0
594 ioffst = 0
595 END IF
596*
597* IPACKG is the format that the matrix is generated in. If this is
598* different from IPACK, then the matrix must be repacked at the
599* end. It also signals how to compute the norm, for scaling.
600*
601 ipackg = 0
602*
603* Diagonal Matrix -- We are done, unless it
604* is to be stored HP/SP/PP/TP (PACK='R' or 'C')
605*
606 IF( llb.EQ.0 .AND. uub.EQ.0 ) THEN
607 DO 30 j = 1, mnmin
608 a( ( 1-iskew )*j+ioffst, j ) = dcmplx( d( j ) )
609 30 CONTINUE
610*
611 IF( ipack.LE.2 .OR. ipack.GE.5 )
612 $ ipackg = ipack
613*
614 ELSE IF( givens ) THEN
615*
616* Check whether to use Givens rotations,
617* Householder transformations, or nothing.
618*
619 IF( isym.EQ.1 ) THEN
620*
621* Non-symmetric -- A = U D V
622*
623 IF( ipack.GT.4 ) THEN
624 ipackg = ipack
625 ELSE
626 ipackg = 0
627 END IF
628*
629 DO 40 j = 1, mnmin
630 a( ( 1-iskew )*j+ioffst, j ) = dcmplx( d( j ) )
631 40 CONTINUE
632*
633 IF( topdwn ) THEN
634 jkl = 0
635 DO 70 jku = 1, uub
636*
637* Transform from bandwidth JKL, JKU-1 to JKL, JKU
638*
639* Last row actually rotated is M
640* Last column actually rotated is MIN( M+JKU, N )
641*
642 DO 60 jr = 1, min( m+jku, n ) + jkl - 1
643 extra = czero
644 angle = twopi*dlarnd( 1, iseed )
645 c = cos( angle )*zlarnd( 5, iseed )
646 s = sin( angle )*zlarnd( 5, iseed )
647 icol = max( 1, jr-jkl )
648 IF( jr.LT.m ) THEN
649 il = min( n, jr+jku ) + 1 - icol
650 CALL zlarot( .true., jr.GT.jkl, .false., il, c,
651 $ s, a( jr-iskew*icol+ioffst, icol ),
652 $ ilda, extra, dummy )
653 END IF
654*
655* Chase "EXTRA" back up
656*
657 ir = jr
658 ic = icol
659 DO 50 jch = jr - jkl, 1, -jkl - jku
660 IF( ir.LT.m ) THEN
661 CALL zlartg( a( ir+1-iskew*( ic+1 )+ioffst,
662 $ ic+1 ), extra, realc, s, dummy )
663 dummy = zlarnd( 5, iseed )
664 c = dconjg( realc*dummy )
665 s = dconjg( -s*dummy )
666 END IF
667 irow = max( 1, jch-jku )
668 il = ir + 2 - irow
669 ctemp = czero
670 iltemp = jch.GT.jku
671 CALL zlarot( .false., iltemp, .true., il, c, s,
672 $ a( irow-iskew*ic+ioffst, ic ),
673 $ ilda, ctemp, extra )
674 IF( iltemp ) THEN
675 CALL zlartg( a( irow+1-iskew*( ic+1 )+ioffst,
676 $ ic+1 ), ctemp, realc, s, dummy )
677 dummy = zlarnd( 5, iseed )
678 c = dconjg( realc*dummy )
679 s = dconjg( -s*dummy )
680*
681 icol = max( 1, jch-jku-jkl )
682 il = ic + 2 - icol
683 extra = czero
684 CALL zlarot( .true., jch.GT.jku+jkl, .true.,
685 $ il, c, s, a( irow-iskew*icol+
686 $ ioffst, icol ), ilda, extra,
687 $ ctemp )
688 ic = icol
689 ir = irow
690 END IF
691 50 CONTINUE
692 60 CONTINUE
693 70 CONTINUE
694*
695 jku = uub
696 DO 100 jkl = 1, llb
697*
698* Transform from bandwidth JKL-1, JKU to JKL, JKU
699*
700 DO 90 jc = 1, min( n+jkl, m ) + jku - 1
701 extra = czero
702 angle = twopi*dlarnd( 1, iseed )
703 c = cos( angle )*zlarnd( 5, iseed )
704 s = sin( angle )*zlarnd( 5, iseed )
705 irow = max( 1, jc-jku )
706 IF( jc.LT.n ) THEN
707 il = min( m, jc+jkl ) + 1 - irow
708 CALL zlarot( .false., jc.GT.jku, .false., il, c,
709 $ s, a( irow-iskew*jc+ioffst, jc ),
710 $ ilda, extra, dummy )
711 END IF
712*
713* Chase "EXTRA" back up
714*
715 ic = jc
716 ir = irow
717 DO 80 jch = jc - jku, 1, -jkl - jku
718 IF( ic.LT.n ) THEN
719 CALL zlartg( a( ir+1-iskew*( ic+1 )+ioffst,
720 $ ic+1 ), extra, realc, s, dummy )
721 dummy = zlarnd( 5, iseed )
722 c = dconjg( realc*dummy )
723 s = dconjg( -s*dummy )
724 END IF
725 icol = max( 1, jch-jkl )
726 il = ic + 2 - icol
727 ctemp = czero
728 iltemp = jch.GT.jkl
729 CALL zlarot( .true., iltemp, .true., il, c, s,
730 $ a( ir-iskew*icol+ioffst, icol ),
731 $ ilda, ctemp, extra )
732 IF( iltemp ) THEN
733 CALL zlartg( a( ir+1-iskew*( icol+1 )+ioffst,
734 $ icol+1 ), ctemp, realc, s,
735 $ dummy )
736 dummy = zlarnd( 5, iseed )
737 c = dconjg( realc*dummy )
738 s = dconjg( -s*dummy )
739 irow = max( 1, jch-jkl-jku )
740 il = ir + 2 - irow
741 extra = czero
742 CALL zlarot( .false., jch.GT.jkl+jku, .true.,
743 $ il, c, s, a( irow-iskew*icol+
744 $ ioffst, icol ), ilda, extra,
745 $ ctemp )
746 ic = icol
747 ir = irow
748 END IF
749 80 CONTINUE
750 90 CONTINUE
751 100 CONTINUE
752*
753 ELSE
754*
755* Bottom-Up -- Start at the bottom right.
756*
757 jkl = 0
758 DO 130 jku = 1, uub
759*
760* Transform from bandwidth JKL, JKU-1 to JKL, JKU
761*
762* First row actually rotated is M
763* First column actually rotated is MIN( M+JKU, N )
764*
765 iendch = min( m, n+jkl ) - 1
766 DO 120 jc = min( m+jku, n ) - 1, 1 - jkl, -1
767 extra = czero
768 angle = twopi*dlarnd( 1, iseed )
769 c = cos( angle )*zlarnd( 5, iseed )
770 s = sin( angle )*zlarnd( 5, iseed )
771 irow = max( 1, jc-jku+1 )
772 IF( jc.GT.0 ) THEN
773 il = min( m, jc+jkl+1 ) + 1 - irow
774 CALL zlarot( .false., .false., jc+jkl.LT.m, il,
775 $ c, s, a( irow-iskew*jc+ioffst,
776 $ jc ), ilda, dummy, extra )
777 END IF
778*
779* Chase "EXTRA" back down
780*
781 ic = jc
782 DO 110 jch = jc + jkl, iendch, jkl + jku
783 ilextr = ic.GT.0
784 IF( ilextr ) THEN
785 CALL zlartg( a( jch-iskew*ic+ioffst, ic ),
786 $ extra, realc, s, dummy )
787 dummy = zlarnd( 5, iseed )
788 c = realc*dummy
789 s = s*dummy
790 END IF
791 ic = max( 1, ic )
792 icol = min( n-1, jch+jku )
793 iltemp = jch + jku.LT.n
794 ctemp = czero
795 CALL zlarot( .true., ilextr, iltemp, icol+2-ic,
796 $ c, s, a( jch-iskew*ic+ioffst, ic ),
797 $ ilda, extra, ctemp )
798 IF( iltemp ) THEN
799 CALL zlartg( a( jch-iskew*icol+ioffst,
800 $ icol ), ctemp, realc, s, dummy )
801 dummy = zlarnd( 5, iseed )
802 c = realc*dummy
803 s = s*dummy
804 il = min( iendch, jch+jkl+jku ) + 2 - jch
805 extra = czero
806 CALL zlarot( .false., .true.,
807 $ jch+jkl+jku.LE.iendch, il, c, s,
808 $ a( jch-iskew*icol+ioffst,
809 $ icol ), ilda, ctemp, extra )
810 ic = icol
811 END IF
812 110 CONTINUE
813 120 CONTINUE
814 130 CONTINUE
815*
816 jku = uub
817 DO 160 jkl = 1, llb
818*
819* Transform from bandwidth JKL-1, JKU to JKL, JKU
820*
821* First row actually rotated is MIN( N+JKL, M )
822* First column actually rotated is N
823*
824 iendch = min( n, m+jku ) - 1
825 DO 150 jr = min( n+jkl, m ) - 1, 1 - jku, -1
826 extra = czero
827 angle = twopi*dlarnd( 1, iseed )
828 c = cos( angle )*zlarnd( 5, iseed )
829 s = sin( angle )*zlarnd( 5, iseed )
830 icol = max( 1, jr-jkl+1 )
831 IF( jr.GT.0 ) THEN
832 il = min( n, jr+jku+1 ) + 1 - icol
833 CALL zlarot( .true., .false., jr+jku.LT.n, il,
834 $ c, s, a( jr-iskew*icol+ioffst,
835 $ icol ), ilda, dummy, extra )
836 END IF
837*
838* Chase "EXTRA" back down
839*
840 ir = jr
841 DO 140 jch = jr + jku, iendch, jkl + jku
842 ilextr = ir.GT.0
843 IF( ilextr ) THEN
844 CALL zlartg( a( ir-iskew*jch+ioffst, jch ),
845 $ extra, realc, s, dummy )
846 dummy = zlarnd( 5, iseed )
847 c = realc*dummy
848 s = s*dummy
849 END IF
850 ir = max( 1, ir )
851 irow = min( m-1, jch+jkl )
852 iltemp = jch + jkl.LT.m
853 ctemp = czero
854 CALL zlarot( .false., ilextr, iltemp, irow+2-ir,
855 $ c, s, a( ir-iskew*jch+ioffst,
856 $ jch ), ilda, extra, ctemp )
857 IF( iltemp ) THEN
858 CALL zlartg( a( irow-iskew*jch+ioffst, jch ),
859 $ ctemp, realc, s, dummy )
860 dummy = zlarnd( 5, iseed )
861 c = realc*dummy
862 s = s*dummy
863 il = min( iendch, jch+jkl+jku ) + 2 - jch
864 extra = czero
865 CALL zlarot( .true., .true.,
866 $ jch+jkl+jku.LE.iendch, il, c, s,
867 $ a( irow-iskew*jch+ioffst, jch ),
868 $ ilda, ctemp, extra )
869 ir = irow
870 END IF
871 140 CONTINUE
872 150 CONTINUE
873 160 CONTINUE
874*
875 END IF
876*
877 ELSE
878*
879* Symmetric -- A = U D U'
880* Hermitian -- A = U D U*
881*
882 ipackg = ipack
883 ioffg = ioffst
884*
885 IF( topdwn ) THEN
886*
887* Top-Down -- Generate Upper triangle only
888*
889 IF( ipack.GE.5 ) THEN
890 ipackg = 6
891 ioffg = uub + 1
892 ELSE
893 ipackg = 1
894 END IF
895*
896 DO 170 j = 1, mnmin
897 a( ( 1-iskew )*j+ioffg, j ) = dcmplx( d( j ) )
898 170 CONTINUE
899*
900 DO 200 k = 1, uub
901 DO 190 jc = 1, n - 1
902 irow = max( 1, jc-k )
903 il = min( jc+1, k+2 )
904 extra = czero
905 ctemp = a( jc-iskew*( jc+1 )+ioffg, jc+1 )
906 angle = twopi*dlarnd( 1, iseed )
907 c = cos( angle )*zlarnd( 5, iseed )
908 s = sin( angle )*zlarnd( 5, iseed )
909 IF( zsym ) THEN
910 ct = c
911 st = s
912 ELSE
913 ctemp = dconjg( ctemp )
914 ct = dconjg( c )
915 st = dconjg( s )
916 END IF
917 CALL zlarot( .false., jc.GT.k, .true., il, c, s,
918 $ a( irow-iskew*jc+ioffg, jc ), ilda,
919 $ extra, ctemp )
920 CALL zlarot( .true., .true., .false.,
921 $ min( k, n-jc )+1, ct, st,
922 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
923 $ ctemp, dummy )
924*
925* Chase EXTRA back up the matrix
926*
927 icol = jc
928 DO 180 jch = jc - k, 1, -k
929 CALL zlartg( a( jch+1-iskew*( icol+1 )+ioffg,
930 $ icol+1 ), extra, realc, s, dummy )
931 dummy = zlarnd( 5, iseed )
932 c = dconjg( realc*dummy )
933 s = dconjg( -s*dummy )
934 ctemp = a( jch-iskew*( jch+1 )+ioffg, jch+1 )
935 IF( zsym ) THEN
936 ct = c
937 st = s
938 ELSE
939 ctemp = dconjg( ctemp )
940 ct = dconjg( c )
941 st = dconjg( s )
942 END IF
943 CALL zlarot( .true., .true., .true., k+2, c, s,
944 $ a( ( 1-iskew )*jch+ioffg, jch ),
945 $ ilda, ctemp, extra )
946 irow = max( 1, jch-k )
947 il = min( jch+1, k+2 )
948 extra = czero
949 CALL zlarot( .false., jch.GT.k, .true., il, ct,
950 $ st, a( irow-iskew*jch+ioffg, jch ),
951 $ ilda, extra, ctemp )
952 icol = jch
953 180 CONTINUE
954 190 CONTINUE
955 200 CONTINUE
956*
957* If we need lower triangle, copy from upper. Note that
958* the order of copying is chosen to work for 'q' -> 'b'
959*
960 IF( ipack.NE.ipackg .AND. ipack.NE.3 ) THEN
961 DO 230 jc = 1, n
962 irow = ioffst - iskew*jc
963 IF( zsym ) THEN
964 DO 210 jr = jc, min( n, jc+uub )
965 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
966 210 CONTINUE
967 ELSE
968 DO 220 jr = jc, min( n, jc+uub )
969 a( jr+irow, jc ) = dconjg( a( jc-iskew*jr+
970 $ ioffg, jr ) )
971 220 CONTINUE
972 END IF
973 230 CONTINUE
974 IF( ipack.EQ.5 ) THEN
975 DO 250 jc = n - uub + 1, n
976 DO 240 jr = n + 2 - jc, uub + 1
977 a( jr, jc ) = czero
978 240 CONTINUE
979 250 CONTINUE
980 END IF
981 IF( ipackg.EQ.6 ) THEN
982 ipackg = ipack
983 ELSE
984 ipackg = 0
985 END IF
986 END IF
987 ELSE
988*
989* Bottom-Up -- Generate Lower triangle only
990*
991 IF( ipack.GE.5 ) THEN
992 ipackg = 5
993 IF( ipack.EQ.6 )
994 $ ioffg = 1
995 ELSE
996 ipackg = 2
997 END IF
998*
999 DO 260 j = 1, mnmin
1000 a( ( 1-iskew )*j+ioffg, j ) = dcmplx( d( j ) )
1001 260 CONTINUE
1002*
1003 DO 290 k = 1, uub
1004 DO 280 jc = n - 1, 1, -1
1005 il = min( n+1-jc, k+2 )
1006 extra = czero
1007 ctemp = a( 1+( 1-iskew )*jc+ioffg, jc )
1008 angle = twopi*dlarnd( 1, iseed )
1009 c = cos( angle )*zlarnd( 5, iseed )
1010 s = sin( angle )*zlarnd( 5, iseed )
1011 IF( zsym ) THEN
1012 ct = c
1013 st = s
1014 ELSE
1015 ctemp = dconjg( ctemp )
1016 ct = dconjg( c )
1017 st = dconjg( s )
1018 END IF
1019 CALL zlarot( .false., .true., n-jc.GT.k, il, c, s,
1020 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
1021 $ ctemp, extra )
1022 icol = max( 1, jc-k+1 )
1023 CALL zlarot( .true., .false., .true., jc+2-icol,
1024 $ ct, st, a( jc-iskew*icol+ioffg,
1025 $ icol ), ilda, dummy, ctemp )
1026*
1027* Chase EXTRA back down the matrix
1028*
1029 icol = jc
1030 DO 270 jch = jc + k, n - 1, k
1031 CALL zlartg( a( jch-iskew*icol+ioffg, icol ),
1032 $ extra, realc, s, dummy )
1033 dummy = zlarnd( 5, iseed )
1034 c = realc*dummy
1035 s = s*dummy
1036 ctemp = a( 1+( 1-iskew )*jch+ioffg, jch )
1037 IF( zsym ) THEN
1038 ct = c
1039 st = s
1040 ELSE
1041 ctemp = dconjg( ctemp )
1042 ct = dconjg( c )
1043 st = dconjg( s )
1044 END IF
1045 CALL zlarot( .true., .true., .true., k+2, c, s,
1046 $ a( jch-iskew*icol+ioffg, icol ),
1047 $ ilda, extra, ctemp )
1048 il = min( n+1-jch, k+2 )
1049 extra = czero
1050 CALL zlarot( .false., .true., n-jch.GT.k, il,
1051 $ ct, st, a( ( 1-iskew )*jch+ioffg,
1052 $ jch ), ilda, ctemp, extra )
1053 icol = jch
1054 270 CONTINUE
1055 280 CONTINUE
1056 290 CONTINUE
1057*
1058* If we need upper triangle, copy from lower. Note that
1059* the order of copying is chosen to work for 'b' -> 'q'
1060*
1061 IF( ipack.NE.ipackg .AND. ipack.NE.4 ) THEN
1062 DO 320 jc = n, 1, -1
1063 irow = ioffst - iskew*jc
1064 IF( zsym ) THEN
1065 DO 300 jr = jc, max( 1, jc-uub ), -1
1066 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
1067 300 CONTINUE
1068 ELSE
1069 DO 310 jr = jc, max( 1, jc-uub ), -1
1070 a( jr+irow, jc ) = dconjg( a( jc-iskew*jr+
1071 $ ioffg, jr ) )
1072 310 CONTINUE
1073 END IF
1074 320 CONTINUE
1075 IF( ipack.EQ.6 ) THEN
1076 DO 340 jc = 1, uub
1077 DO 330 jr = 1, uub + 1 - jc
1078 a( jr, jc ) = czero
1079 330 CONTINUE
1080 340 CONTINUE
1081 END IF
1082 IF( ipackg.EQ.5 ) THEN
1083 ipackg = ipack
1084 ELSE
1085 ipackg = 0
1086 END IF
1087 END IF
1088 END IF
1089*
1090* Ensure that the diagonal is real if Hermitian
1091*
1092 IF( .NOT.zsym ) THEN
1093 DO 350 jc = 1, n
1094 irow = ioffst + ( 1-iskew )*jc
1095 a( irow, jc ) = dcmplx( dble( a( irow, jc ) ) )
1096 350 CONTINUE
1097 END IF
1098*
1099 END IF
1100*
1101 ELSE
1102*
1103* 4) Generate Banded Matrix by first
1104* Rotating by random Unitary matrices,
1105* then reducing the bandwidth using Householder
1106* transformations.
1107*
1108* Note: we should get here only if LDA .ge. N
1109*
1110 IF( isym.EQ.1 ) THEN
1111*
1112* Non-symmetric -- A = U D V
1113*
1114 CALL zlagge( mr, nc, llb, uub, d, a, lda, iseed, work,
1115 $ iinfo )
1116 ELSE
1117*
1118* Symmetric -- A = U D U' or
1119* Hermitian -- A = U D U*
1120*
1121 IF( zsym ) THEN
1122 CALL zlagsy( m, llb, d, a, lda, iseed, work, iinfo )
1123 ELSE
1124 CALL zlaghe( m, llb, d, a, lda, iseed, work, iinfo )
1125 END IF
1126 END IF
1127*
1128 IF( iinfo.NE.0 ) THEN
1129 info = 3
1130 RETURN
1131 END IF
1132 END IF
1133*
1134* 5) Pack the matrix
1135*
1136 IF( ipack.NE.ipackg ) THEN
1137 IF( ipack.EQ.1 ) THEN
1138*
1139* 'U' -- Upper triangular, not packed
1140*
1141 DO 370 j = 1, m
1142 DO 360 i = j + 1, m
1143 a( i, j ) = czero
1144 360 CONTINUE
1145 370 CONTINUE
1146*
1147 ELSE IF( ipack.EQ.2 ) THEN
1148*
1149* 'L' -- Lower triangular, not packed
1150*
1151 DO 390 j = 2, m
1152 DO 380 i = 1, j - 1
1153 a( i, j ) = czero
1154 380 CONTINUE
1155 390 CONTINUE
1156*
1157 ELSE IF( ipack.EQ.3 ) THEN
1158*
1159* 'C' -- Upper triangle packed Columnwise.
1160*
1161 icol = 1
1162 irow = 0
1163 DO 410 j = 1, m
1164 DO 400 i = 1, j
1165 irow = irow + 1
1166 IF( irow.GT.lda ) THEN
1167 irow = 1
1168 icol = icol + 1
1169 END IF
1170 a( irow, icol ) = a( i, j )
1171 400 CONTINUE
1172 410 CONTINUE
1173*
1174 ELSE IF( ipack.EQ.4 ) THEN
1175*
1176* 'R' -- Lower triangle packed Columnwise.
1177*
1178 icol = 1
1179 irow = 0
1180 DO 430 j = 1, m
1181 DO 420 i = j, m
1182 irow = irow + 1
1183 IF( irow.GT.lda ) THEN
1184 irow = 1
1185 icol = icol + 1
1186 END IF
1187 a( irow, icol ) = a( i, j )
1188 420 CONTINUE
1189 430 CONTINUE
1190*
1191 ELSE IF( ipack.GE.5 ) THEN
1192*
1193* 'B' -- The lower triangle is packed as a band matrix.
1194* 'Q' -- The upper triangle is packed as a band matrix.
1195* 'Z' -- The whole matrix is packed as a band matrix.
1196*
1197 IF( ipack.EQ.5 )
1198 $ uub = 0
1199 IF( ipack.EQ.6 )
1200 $ llb = 0
1201*
1202 DO 450 j = 1, uub
1203 DO 440 i = min( j+llb, m ), 1, -1
1204 a( i-j+uub+1, j ) = a( i, j )
1205 440 CONTINUE
1206 450 CONTINUE
1207*
1208 DO 470 j = uub + 2, n
1209 DO 460 i = j - uub, min( j+llb, m )
1210 a( i-j+uub+1, j ) = a( i, j )
1211 460 CONTINUE
1212 470 CONTINUE
1213 END IF
1214*
1215* If packed, zero out extraneous elements.
1216*
1217* Symmetric/Triangular Packed --
1218* zero out everything after A(IROW,ICOL)
1219*
1220 IF( ipack.EQ.3 .OR. ipack.EQ.4 ) THEN
1221 DO 490 jc = icol, m
1222 DO 480 jr = irow + 1, lda
1223 a( jr, jc ) = czero
1224 480 CONTINUE
1225 irow = 0
1226 490 CONTINUE
1227*
1228 ELSE IF( ipack.GE.5 ) THEN
1229*
1230* Packed Band --
1231* 1st row is now in A( UUB+2-j, j), zero above it
1232* m-th row is now in A( M+UUB-j,j), zero below it
1233* last non-zero diagonal is now in A( UUB+LLB+1,j ),
1234* zero below it, too.
1235*
1236 ir1 = uub + llb + 2
1237 ir2 = uub + m + 2
1238 DO 520 jc = 1, n
1239 DO 500 jr = 1, uub + 1 - jc
1240 a( jr, jc ) = czero
1241 500 CONTINUE
1242 DO 510 jr = max( 1, min( ir1, ir2-jc ) ), lda
1243 a( jr, jc ) = czero
1244 510 CONTINUE
1245 520 CONTINUE
1246 END IF
1247 END IF
1248*
1249 RETURN
1250*
1251* End of ZLATMS
1252*
zlartg
subroutine zlartg(f, g, c, s, r)
ZLARTG generates a plane rotation with real cosine and complex sine.
Definition zlartg.f90:118
zlagge
subroutine zlagge(m, n, kl, ku, d, a, lda, iseed, work, info)
ZLAGGE
Definition zlagge.f:114
zlarot
subroutine zlarot(lrows, lleft, lright, nl, c, s, a, lda, xleft, xright)
ZLAROT
Definition zlarot.f:229
zlagsy
subroutine zlagsy(n, k, d, a, lda, iseed, work, info)
ZLAGSY
Definition zlagsy.f:102
zlaghe
subroutine zlaghe(n, k, d, a, lda, iseed, work, info)
ZLAGHE
Definition zlaghe.f:102
dscal
subroutine dscal(n, da, dx, incx)
DSCAL
Definition dscal.f:79
dlarnd
double precision function dlarnd(idist, iseed)
DLARND
Definition dlarnd.f:73

◆ zlatmt()

subroutine zlatmt ( integer m,
integer n,
character dist,
integer, dimension( 4 ) iseed,
character sym,
double precision, dimension( * ) d,
integer mode,
double precision cond,
double precision dmax,
integer rank,
integer kl,
integer ku,
character pack,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) work,
integer info )

ZLATMT

Purpose:
!>
!>    ZLATMT generates random matrices with specified singular values
!>    (or hermitian with specified eigenvalues)
!>    for testing LAPACK programs.
!>
!>    ZLATMT operates by applying the following sequence of
!>    operations:
!>
!>      Set the diagonal to D, where D may be input or
!>         computed according to MODE, COND, DMAX, and SYM
!>         as described below.
!>
!>      Generate a matrix with the appropriate band structure, by one
!>         of two methods:
!>
!>      Method A:
!>          Generate a dense M x N matrix by multiplying D on the left
!>              and the right by random unitary matrices, then:
!>
!>          Reduce the bandwidth according to KL and KU, using
!>              Householder transformations.
!>
!>      Method B:
!>          Convert the bandwidth-0 (i.e., diagonal) matrix to a
!>              bandwidth-1 matrix using Givens rotations, 
!>              out-of-band elements back, much as in QR; then convert
!>              the bandwidth-1 to a bandwidth-2 matrix, etc.  Note
!>              that for reasonably small bandwidths (relative to M and
!>              N) this requires less storage, as a dense matrix is not
!>              generated.  Also, for hermitian or symmetric matrices,
!>              only one triangle is generated.
!>
!>      Method A is chosen if the bandwidth is a large fraction of the
!>          order of the matrix, and LDA is at least M (so a dense
!>          matrix can be stored.)  Method B is chosen if the bandwidth
!>          is small (< 1/2 N for hermitian or symmetric, < .3 N+M for
!>          non-symmetric), or LDA is less than M and not less than the
!>          bandwidth.
!>
!>      Pack the matrix if desired. Options specified by PACK are:
!>         no packing
!>         zero out upper half (if hermitian)
!>         zero out lower half (if hermitian)
!>         store the upper half columnwise (if hermitian or upper
!>               triangular)
!>         store the lower half columnwise (if hermitian or lower
!>               triangular)
!>         store the lower triangle in banded format (if hermitian or
!>               lower triangular)
!>         store the upper triangle in banded format (if hermitian or
!>               upper triangular)
!>         store the entire matrix in banded format
!>      If Method B is chosen, and band format is specified, then the
!>         matrix will be generated in the band format, so no repacking
!>         will be necessary.
!>
Parameters
[in]M
!>          M is INTEGER
!>           The number of rows of A. Not modified.
!>
[in]N
!>          N is INTEGER
!>           The number of columns of A. N must equal M if the matrix
!>           is symmetric or hermitian (i.e., if SYM is not 'N')
!>           Not modified.
!>
[in]DIST
!>          DIST is CHARACTER*1
!>           On entry, DIST specifies the type of distribution to be used
!>           to generate the random eigen-/singular values.
!>           'U' => UNIFORM( 0, 1 )  ( 'U' for uniform )
!>           'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric )
!>           'N' => NORMAL( 0, 1 )   ( 'N' for normal )
!>           Not modified.
!>
[in,out]ISEED
!>          ISEED is 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 ZLATMT
!>           to continue the same random number sequence.
!>           Changed on exit.
!>
[in]SYM
!>          SYM is CHARACTER*1
!>           If SYM='H', the generated matrix is hermitian, with
!>             eigenvalues specified by D, COND, MODE, and DMAX; they
!>             may be positive, negative, or zero.
!>           If SYM='P', the generated matrix is hermitian, with
!>             eigenvalues (= singular values) specified by D, COND,
!>             MODE, and DMAX; they will not be negative.
!>           If SYM='N', the generated matrix is nonsymmetric, with
!>             singular values specified by D, COND, MODE, and DMAX;
!>             they will not be negative.
!>           If SYM='S', the generated matrix is (complex) symmetric,
!>             with singular values specified by D, COND, MODE, and
!>             DMAX; they will not be negative.
!>           Not modified.
!>
[in,out]D
!>          D is DOUBLE PRECISION array, dimension ( MIN( M, N ) )
!>           This array is used to specify the singular values or
!>           eigenvalues of A (see SYM, above.)  If MODE=0, then D is
!>           assumed to contain the singular/eigenvalues, otherwise
!>           they will be computed according to MODE, COND, and DMAX,
!>           and placed in D.
!>           Modified if MODE is nonzero.
!>
[in]MODE
!>          MODE is INTEGER
!>           On entry this describes how the singular/eigenvalues are to
!>           be specified:
!>           MODE = 0 means use D as input
!>           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))
!>           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,
!>           If SYM='H', and MODE is neither 0, 6, nor -6, then
!>              the elements of D will also be multiplied by a random
!>              sign (i.e., +1 or -1.)
!>           Not modified.
!>
[in]COND
!>          COND is DOUBLE PRECISION
!>           On entry, this is used as described under MODE above.
!>           If used, it must be >= 1. Not modified.
!>
[in]DMAX
!>          DMAX is 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))); thus, the maximum absolute eigen- or
!>           singular value (which is to say the norm) will be abs(DMAX).
!>           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.
!>
[in]RANK
!>          RANK is INTEGER
!>           The rank of matrix to be generated for modes 1,2,3 only.
!>           D( RANK+1:N ) = 0.
!>           Not modified.
!>
[in]KL
!>          KL is INTEGER
!>           This specifies the lower bandwidth of the  matrix. For
!>           example, KL=0 implies upper triangular, KL=1 implies upper
!>           Hessenberg, and KL being at least M-1 means that the matrix
!>           has full lower bandwidth.  KL must equal KU if the matrix
!>           is symmetric or hermitian.
!>           Not modified.
!>
[in]KU
!>          KU is INTEGER
!>           This specifies the upper bandwidth of the  matrix. For
!>           example, KU=0 implies lower triangular, KU=1 implies lower
!>           Hessenberg, and KU being at least N-1 means that the matrix
!>           has full upper bandwidth.  KL must equal KU if the matrix
!>           is symmetric or hermitian.
!>           Not modified.
!>
[in]PACK
!>          PACK is CHARACTER*1
!>           This specifies packing of matrix as follows:
!>           'N' => no packing
!>           'U' => zero out all subdiagonal entries (if symmetric
!>                  or hermitian)
!>           'L' => zero out all superdiagonal entries (if symmetric
!>                  or hermitian)
!>           'C' => store the upper triangle columnwise (only if the
!>                  matrix is symmetric, hermitian, or upper triangular)
!>           'R' => store the lower triangle columnwise (only if the
!>                  matrix is symmetric, hermitian, or lower triangular)
!>           'B' => store the lower triangle in band storage scheme
!>                  (only if the matrix is symmetric, hermitian, or
!>                  lower triangular)
!>           'Q' => store the upper triangle in band storage scheme
!>                  (only if the matrix is symmetric, hermitian, or
!>                  upper triangular)
!>           'Z' => store the entire matrix in band storage scheme
!>                      (pivoting can be provided for by using this
!>                      option to store A in the trailing rows of
!>                      the allocated storage)
!>
!>           Using these options, the various LAPACK packed and banded
!>           storage schemes can be obtained:
!>           GB                    - use 'Z'
!>           PB, SB, HB, or TB     - use 'B' or 'Q'
!>           PP, SP, HB, or TP     - use 'C' or 'R'
!>
!>           If two calls to ZLATMT differ only in the PACK parameter,
!>           they will generate mathematically equivalent matrices.
!>           Not modified.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension ( LDA, N )
!>           On exit A is the desired test matrix.  A is first generated
!>           in full (unpacked) form, and then packed, if so specified
!>           by PACK.  Thus, the first M elements of the first N
!>           columns will always be modified.  If PACK specifies a
!>           packed or banded storage scheme, all LDA elements of the
!>           first N columns will be modified; the elements of the
!>           array which do not correspond to elements of the generated
!>           matrix are set to zero.
!>           Modified.
!>
[in]LDA
!>          LDA is INTEGER
!>           LDA specifies the first dimension of A as declared in the
!>           calling program.  If PACK='N', 'U', 'L', 'C', or 'R', then
!>           LDA must be at least M.  If PACK='B' or 'Q', then LDA must
!>           be at least MIN( KL, M-1) (which is equal to MIN(KU,N-1)).
!>           If PACK='Z', LDA must be large enough to hold the packed
!>           array: MIN( KU, N-1) + MIN( KL, M-1) + 1.
!>           Not modified.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension ( 3*MAX( N, M ) )
!>           Workspace.
!>           Modified.
!>
[out]INFO
!>          INFO is INTEGER
!>           Error code.  On exit, INFO will be set to one of the
!>           following values:
!>             0 => normal return
!>            -1 => M negative or unequal to N and SYM='S', 'H', or 'P'
!>            -2 => N negative
!>            -3 => DIST illegal string
!>            -5 => SYM illegal string
!>            -7 => MODE not in range -6 to 6
!>            -8 => COND less than 1.0, and MODE neither -6, 0 nor 6
!>           -10 => KL negative
!>           -11 => KU negative, or SYM is not 'N' and KU is not equal to
!>                  KL
!>           -12 => PACK illegal string, or PACK='U' or 'L', and SYM='N';
!>                  or PACK='C' or 'Q' and SYM='N' and KL is not zero;
!>                  or PACK='R' or 'B' and SYM='N' and KU is not zero;
!>                  or PACK='U', 'L', 'C', 'R', 'B', or 'Q', and M is not
!>                  N.
!>           -14 => LDA is less than M, or PACK='Z' and LDA is less than
!>                  MIN(KU,N-1) + MIN(KL,M-1) + 1.
!>            1  => Error return from DLATM7
!>            2  => Cannot scale to DMAX (max. sing. value is 0)
!>            3  => Error return from ZLAGGE, ZLAGHE or ZLAGSY
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 338 of file zlatmt.f.

340*
341* -- LAPACK computational routine --
342* -- LAPACK is a software package provided by Univ. of Tennessee, --
343* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
344*
345* .. Scalar Arguments ..
346 DOUBLE PRECISION COND, DMAX
347 INTEGER INFO, KL, KU, LDA, M, MODE, N, RANK
348 CHARACTER DIST, PACK, SYM
349* ..
350* .. Array Arguments ..
351 COMPLEX*16 A( LDA, * ), WORK( * )
352 DOUBLE PRECISION D( * )
353 INTEGER ISEED( 4 )
354* ..
355*
356* =====================================================================
357*
358* .. Parameters ..
359 DOUBLE PRECISION ZERO
360 parameter( zero = 0.0d+0 )
361 DOUBLE PRECISION ONE
362 parameter( one = 1.0d+0 )
363 COMPLEX*16 CZERO
364 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
365 DOUBLE PRECISION TWOPI
366 parameter( twopi = 6.28318530717958647692528676655900576839d+0 )
367* ..
368* .. Local Scalars ..
369 COMPLEX*16 C, CT, DUMMY, EXTRA, S, ST, ZTEMP
370 DOUBLE PRECISION ALPHA, ANGLE, REALC, TEMP
371 INTEGER I, IC, ICOL, IDIST, IENDCH, IINFO, IL, ILDA,
372 $ IOFFG, IOFFST, IPACK, IPACKG, IR, IR1, IR2,
373 $ IROW, IRSIGN, ISKEW, ISYM, ISYMPK, J, JC, JCH,
374 $ JKL, JKU, JR, K, LLB, MINLDA, MNMIN, MR, NC,
375 $ UUB
376 LOGICAL CSYM, GIVENS, ILEXTR, ILTEMP, TOPDWN
377* ..
378* .. External Functions ..
379 COMPLEX*16 ZLARND
380 DOUBLE PRECISION DLARND
381 LOGICAL LSAME
382 EXTERNAL zlarnd, dlarnd, lsame
383* ..
384* .. External Subroutines ..
385 EXTERNAL dlatm7, dscal, xerbla, zlagge, zlaghe,
386 $ zlagsy, zlarot, zlartg, zlaset
387* ..
388* .. Intrinsic Functions ..
389 INTRINSIC abs, cos, dble, dcmplx, dconjg, max, min, mod,
390 $ sin
391* ..
392* .. Executable Statements ..
393*
394* 1) Decode and Test the input parameters.
395* Initialize flags & seed.
396*
397 info = 0
398*
399* Quick return if possible
400*
401 IF( m.EQ.0 .OR. n.EQ.0 )
402 $ RETURN
403*
404* Decode DIST
405*
406 IF( lsame( dist, 'U' ) ) THEN
407 idist = 1
408 ELSE IF( lsame( dist, 'S' ) ) THEN
409 idist = 2
410 ELSE IF( lsame( dist, 'N' ) ) THEN
411 idist = 3
412 ELSE
413 idist = -1
414 END IF
415*
416* Decode SYM
417*
418 IF( lsame( sym, 'N' ) ) THEN
419 isym = 1
420 irsign = 0
421 csym = .false.
422 ELSE IF( lsame( sym, 'P' ) ) THEN
423 isym = 2
424 irsign = 0
425 csym = .false.
426 ELSE IF( lsame( sym, 'S' ) ) THEN
427 isym = 2
428 irsign = 0
429 csym = .true.
430 ELSE IF( lsame( sym, 'H' ) ) THEN
431 isym = 2
432 irsign = 1
433 csym = .false.
434 ELSE
435 isym = -1
436 END IF
437*
438* Decode PACK
439*
440 isympk = 0
441 IF( lsame( pack, 'N' ) ) THEN
442 ipack = 0
443 ELSE IF( lsame( pack, 'U' ) ) THEN
444 ipack = 1
445 isympk = 1
446 ELSE IF( lsame( pack, 'L' ) ) THEN
447 ipack = 2
448 isympk = 1
449 ELSE IF( lsame( pack, 'C' ) ) THEN
450 ipack = 3
451 isympk = 2
452 ELSE IF( lsame( pack, 'R' ) ) THEN
453 ipack = 4
454 isympk = 3
455 ELSE IF( lsame( pack, 'B' ) ) THEN
456 ipack = 5
457 isympk = 3
458 ELSE IF( lsame( pack, 'Q' ) ) THEN
459 ipack = 6
460 isympk = 2
461 ELSE IF( lsame( pack, 'Z' ) ) THEN
462 ipack = 7
463 ELSE
464 ipack = -1
465 END IF
466*
467* Set certain internal parameters
468*
469 mnmin = min( m, n )
470 llb = min( kl, m-1 )
471 uub = min( ku, n-1 )
472 mr = min( m, n+llb )
473 nc = min( n, m+uub )
474*
475 IF( ipack.EQ.5 .OR. ipack.EQ.6 ) THEN
476 minlda = uub + 1
477 ELSE IF( ipack.EQ.7 ) THEN
478 minlda = llb + uub + 1
479 ELSE
480 minlda = m
481 END IF
482*
483* Use Givens rotation method if bandwidth small enough,
484* or if LDA is too small to store the matrix unpacked.
485*
486 givens = .false.
487 IF( isym.EQ.1 ) THEN
488 IF( dble( llb+uub ).LT.0.3d0*dble( max( 1, mr+nc ) ) )
489 $ givens = .true.
490 ELSE
491 IF( 2*llb.LT.m )
492 $ givens = .true.
493 END IF
494 IF( lda.LT.m .AND. lda.GE.minlda )
495 $ givens = .true.
496*
497* Set INFO if an error
498*
499 IF( m.LT.0 ) THEN
500 info = -1
501 ELSE IF( m.NE.n .AND. isym.NE.1 ) THEN
502 info = -1
503 ELSE IF( n.LT.0 ) THEN
504 info = -2
505 ELSE IF( idist.EQ.-1 ) THEN
506 info = -3
507 ELSE IF( isym.EQ.-1 ) THEN
508 info = -5
509 ELSE IF( abs( mode ).GT.6 ) THEN
510 info = -7
511 ELSE IF( ( mode.NE.0 .AND. abs( mode ).NE.6 ) .AND. cond.LT.one )
512 $ THEN
513 info = -8
514 ELSE IF( kl.LT.0 ) THEN
515 info = -10
516 ELSE IF( ku.LT.0 .OR. ( isym.NE.1 .AND. kl.NE.ku ) ) THEN
517 info = -11
518 ELSE IF( ipack.EQ.-1 .OR. ( isympk.EQ.1 .AND. isym.EQ.1 ) .OR.
519 $ ( isympk.EQ.2 .AND. isym.EQ.1 .AND. kl.GT.0 ) .OR.
520 $ ( isympk.EQ.3 .AND. isym.EQ.1 .AND. ku.GT.0 ) .OR.
521 $ ( isympk.NE.0 .AND. m.NE.n ) ) THEN
522 info = -12
523 ELSE IF( lda.LT.max( 1, minlda ) ) THEN
524 info = -14
525 END IF
526*
527 IF( info.NE.0 ) THEN
528 CALL xerbla( 'ZLATMT', -info )
529 RETURN
530 END IF
531*
532* Initialize random number generator
533*
534 DO 100 i = 1, 4
535 iseed( i ) = mod( abs( iseed( i ) ), 4096 )
536 100 CONTINUE
537*
538 IF( mod( iseed( 4 ), 2 ).NE.1 )
539 $ iseed( 4 ) = iseed( 4 ) + 1
540*
541* 2) Set up D if indicated.
542*
543* Compute D according to COND and MODE
544*
545 CALL dlatm7( mode, cond, irsign, idist, iseed, d, mnmin, rank,
546 $ iinfo )
547 IF( iinfo.NE.0 ) THEN
548 info = 1
549 RETURN
550 END IF
551*
552* Choose Top-Down if D is (apparently) increasing,
553* Bottom-Up if D is (apparently) decreasing.
554*
555 IF( abs( d( 1 ) ).LE.abs( d( rank ) ) ) THEN
556 topdwn = .true.
557 ELSE
558 topdwn = .false.
559 END IF
560*
561 IF( mode.NE.0 .AND. abs( mode ).NE.6 ) THEN
562*
563* Scale by DMAX
564*
565 temp = abs( d( 1 ) )
566 DO 110 i = 2, rank
567 temp = max( temp, abs( d( i ) ) )
568 110 CONTINUE
569*
570 IF( temp.GT.zero ) THEN
571 alpha = dmax / temp
572 ELSE
573 info = 2
574 RETURN
575 END IF
576*
577 CALL dscal( rank, alpha, d, 1 )
578*
579 END IF
580*
581 CALL zlaset( 'Full', lda, n, czero, czero, a, lda )
582*
583* 3) Generate Banded Matrix using Givens rotations.
584* Also the special case of UUB=LLB=0
585*
586* Compute Addressing constants to cover all
587* storage formats. Whether GE, HE, SY, GB, HB, or SB,
588* upper or lower triangle or both,
589* the (i,j)-th element is in
590* A( i - ISKEW*j + IOFFST, j )
591*
592 IF( ipack.GT.4 ) THEN
593 ilda = lda - 1
594 iskew = 1
595 IF( ipack.GT.5 ) THEN
596 ioffst = uub + 1
597 ELSE
598 ioffst = 1
599 END IF
600 ELSE
601 ilda = lda
602 iskew = 0
603 ioffst = 0
604 END IF
605*
606* IPACKG is the format that the matrix is generated in. If this is
607* different from IPACK, then the matrix must be repacked at the
608* end. It also signals how to compute the norm, for scaling.
609*
610 ipackg = 0
611*
612* Diagonal Matrix -- We are done, unless it
613* is to be stored HP/SP/PP/TP (PACK='R' or 'C')
614*
615 IF( llb.EQ.0 .AND. uub.EQ.0 ) THEN
616 DO 120 j = 1, mnmin
617 a( ( 1-iskew )*j+ioffst, j ) = dcmplx( d( j ) )
618 120 CONTINUE
619*
620 IF( ipack.LE.2 .OR. ipack.GE.5 )
621 $ ipackg = ipack
622*
623 ELSE IF( givens ) THEN
624*
625* Check whether to use Givens rotations,
626* Householder transformations, or nothing.
627*
628 IF( isym.EQ.1 ) THEN
629*
630* Non-symmetric -- A = U D V
631*
632 IF( ipack.GT.4 ) THEN
633 ipackg = ipack
634 ELSE
635 ipackg = 0
636 END IF
637*
638 DO 130 j = 1, mnmin
639 a( ( 1-iskew )*j+ioffst, j ) = dcmplx( d( j ) )
640 130 CONTINUE
641*
642 IF( topdwn ) THEN
643 jkl = 0
644 DO 160 jku = 1, uub
645*
646* Transform from bandwidth JKL, JKU-1 to JKL, JKU
647*
648* Last row actually rotated is M
649* Last column actually rotated is MIN( M+JKU, N )
650*
651 DO 150 jr = 1, min( m+jku, n ) + jkl - 1
652 extra = czero
653 angle = twopi*dlarnd( 1, iseed )
654 c = cos( angle )*zlarnd( 5, iseed )
655 s = sin( angle )*zlarnd( 5, iseed )
656 icol = max( 1, jr-jkl )
657 IF( jr.LT.m ) THEN
658 il = min( n, jr+jku ) + 1 - icol
659 CALL zlarot( .true., jr.GT.jkl, .false., il, c,
660 $ s, a( jr-iskew*icol+ioffst, icol ),
661 $ ilda, extra, dummy )
662 END IF
663*
664* Chase "EXTRA" back up
665*
666 ir = jr
667 ic = icol
668 DO 140 jch = jr - jkl, 1, -jkl - jku
669 IF( ir.LT.m ) THEN
670 CALL zlartg( a( ir+1-iskew*( ic+1 )+ioffst,
671 $ ic+1 ), extra, realc, s, dummy )
672 dummy = dlarnd( 5, iseed )
673 c = dconjg( realc*dummy )
674 s = dconjg( -s*dummy )
675 END IF
676 irow = max( 1, jch-jku )
677 il = ir + 2 - irow
678 ztemp = czero
679 iltemp = jch.GT.jku
680 CALL zlarot( .false., iltemp, .true., il, c, s,
681 $ a( irow-iskew*ic+ioffst, ic ),
682 $ ilda, ztemp, extra )
683 IF( iltemp ) THEN
684 CALL zlartg( a( irow+1-iskew*( ic+1 )+ioffst,
685 $ ic+1 ), ztemp, realc, s, dummy )
686 dummy = zlarnd( 5, iseed )
687 c = dconjg( realc*dummy )
688 s = dconjg( -s*dummy )
689*
690 icol = max( 1, jch-jku-jkl )
691 il = ic + 2 - icol
692 extra = czero
693 CALL zlarot( .true., jch.GT.jku+jkl, .true.,
694 $ il, c, s, a( irow-iskew*icol+
695 $ ioffst, icol ), ilda, extra,
696 $ ztemp )
697 ic = icol
698 ir = irow
699 END IF
700 140 CONTINUE
701 150 CONTINUE
702 160 CONTINUE
703*
704 jku = uub
705 DO 190 jkl = 1, llb
706*
707* Transform from bandwidth JKL-1, JKU to JKL, JKU
708*
709 DO 180 jc = 1, min( n+jkl, m ) + jku - 1
710 extra = czero
711 angle = twopi*dlarnd( 1, iseed )
712 c = cos( angle )*zlarnd( 5, iseed )
713 s = sin( angle )*zlarnd( 5, iseed )
714 irow = max( 1, jc-jku )
715 IF( jc.LT.n ) THEN
716 il = min( m, jc+jkl ) + 1 - irow
717 CALL zlarot( .false., jc.GT.jku, .false., il, c,
718 $ s, a( irow-iskew*jc+ioffst, jc ),
719 $ ilda, extra, dummy )
720 END IF
721*
722* Chase "EXTRA" back up
723*
724 ic = jc
725 ir = irow
726 DO 170 jch = jc - jku, 1, -jkl - jku
727 IF( ic.LT.n ) THEN
728 CALL zlartg( a( ir+1-iskew*( ic+1 )+ioffst,
729 $ ic+1 ), extra, realc, s, dummy )
730 dummy = zlarnd( 5, iseed )
731 c = dconjg( realc*dummy )
732 s = dconjg( -s*dummy )
733 END IF
734 icol = max( 1, jch-jkl )
735 il = ic + 2 - icol
736 ztemp = czero
737 iltemp = jch.GT.jkl
738 CALL zlarot( .true., iltemp, .true., il, c, s,
739 $ a( ir-iskew*icol+ioffst, icol ),
740 $ ilda, ztemp, extra )
741 IF( iltemp ) THEN
742 CALL zlartg( a( ir+1-iskew*( icol+1 )+ioffst,
743 $ icol+1 ), ztemp, realc, s,
744 $ dummy )
745 dummy = zlarnd( 5, iseed )
746 c = dconjg( realc*dummy )
747 s = dconjg( -s*dummy )
748 irow = max( 1, jch-jkl-jku )
749 il = ir + 2 - irow
750 extra = czero
751 CALL zlarot( .false., jch.GT.jkl+jku, .true.,
752 $ il, c, s, a( irow-iskew*icol+
753 $ ioffst, icol ), ilda, extra,
754 $ ztemp )
755 ic = icol
756 ir = irow
757 END IF
758 170 CONTINUE
759 180 CONTINUE
760 190 CONTINUE
761*
762 ELSE
763*
764* Bottom-Up -- Start at the bottom right.
765*
766 jkl = 0
767 DO 220 jku = 1, uub
768*
769* Transform from bandwidth JKL, JKU-1 to JKL, JKU
770*
771* First row actually rotated is M
772* First column actually rotated is MIN( M+JKU, N )
773*
774 iendch = min( m, n+jkl ) - 1
775 DO 210 jc = min( m+jku, n ) - 1, 1 - jkl, -1
776 extra = czero
777 angle = twopi*dlarnd( 1, iseed )
778 c = cos( angle )*zlarnd( 5, iseed )
779 s = sin( angle )*zlarnd( 5, iseed )
780 irow = max( 1, jc-jku+1 )
781 IF( jc.GT.0 ) THEN
782 il = min( m, jc+jkl+1 ) + 1 - irow
783 CALL zlarot( .false., .false., jc+jkl.LT.m, il,
784 $ c, s, a( irow-iskew*jc+ioffst,
785 $ jc ), ilda, dummy, extra )
786 END IF
787*
788* Chase "EXTRA" back down
789*
790 ic = jc
791 DO 200 jch = jc + jkl, iendch, jkl + jku
792 ilextr = ic.GT.0
793 IF( ilextr ) THEN
794 CALL zlartg( a( jch-iskew*ic+ioffst, ic ),
795 $ extra, realc, s, dummy )
796 dummy = zlarnd( 5, iseed )
797 c = realc*dummy
798 s = s*dummy
799 END IF
800 ic = max( 1, ic )
801 icol = min( n-1, jch+jku )
802 iltemp = jch + jku.LT.n
803 ztemp = czero
804 CALL zlarot( .true., ilextr, iltemp, icol+2-ic,
805 $ c, s, a( jch-iskew*ic+ioffst, ic ),
806 $ ilda, extra, ztemp )
807 IF( iltemp ) THEN
808 CALL zlartg( a( jch-iskew*icol+ioffst,
809 $ icol ), ztemp, realc, s, dummy )
810 dummy = zlarnd( 5, iseed )
811 c = realc*dummy
812 s = s*dummy
813 il = min( iendch, jch+jkl+jku ) + 2 - jch
814 extra = czero
815 CALL zlarot( .false., .true.,
816 $ jch+jkl+jku.LE.iendch, il, c, s,
817 $ a( jch-iskew*icol+ioffst,
818 $ icol ), ilda, ztemp, extra )
819 ic = icol
820 END IF
821 200 CONTINUE
822 210 CONTINUE
823 220 CONTINUE
824*
825 jku = uub
826 DO 250 jkl = 1, llb
827*
828* Transform from bandwidth JKL-1, JKU to JKL, JKU
829*
830* First row actually rotated is MIN( N+JKL, M )
831* First column actually rotated is N
832*
833 iendch = min( n, m+jku ) - 1
834 DO 240 jr = min( n+jkl, m ) - 1, 1 - jku, -1
835 extra = czero
836 angle = twopi*dlarnd( 1, iseed )
837 c = cos( angle )*zlarnd( 5, iseed )
838 s = sin( angle )*zlarnd( 5, iseed )
839 icol = max( 1, jr-jkl+1 )
840 IF( jr.GT.0 ) THEN
841 il = min( n, jr+jku+1 ) + 1 - icol
842 CALL zlarot( .true., .false., jr+jku.LT.n, il,
843 $ c, s, a( jr-iskew*icol+ioffst,
844 $ icol ), ilda, dummy, extra )
845 END IF
846*
847* Chase "EXTRA" back down
848*
849 ir = jr
850 DO 230 jch = jr + jku, iendch, jkl + jku
851 ilextr = ir.GT.0
852 IF( ilextr ) THEN
853 CALL zlartg( a( ir-iskew*jch+ioffst, jch ),
854 $ extra, realc, s, dummy )
855 dummy = zlarnd( 5, iseed )
856 c = realc*dummy
857 s = s*dummy
858 END IF
859 ir = max( 1, ir )
860 irow = min( m-1, jch+jkl )
861 iltemp = jch + jkl.LT.m
862 ztemp = czero
863 CALL zlarot( .false., ilextr, iltemp, irow+2-ir,
864 $ c, s, a( ir-iskew*jch+ioffst,
865 $ jch ), ilda, extra, ztemp )
866 IF( iltemp ) THEN
867 CALL zlartg( a( irow-iskew*jch+ioffst, jch ),
868 $ ztemp, realc, s, dummy )
869 dummy = zlarnd( 5, iseed )
870 c = realc*dummy
871 s = s*dummy
872 il = min( iendch, jch+jkl+jku ) + 2 - jch
873 extra = czero
874 CALL zlarot( .true., .true.,
875 $ jch+jkl+jku.LE.iendch, il, c, s,
876 $ a( irow-iskew*jch+ioffst, jch ),
877 $ ilda, ztemp, extra )
878 ir = irow
879 END IF
880 230 CONTINUE
881 240 CONTINUE
882 250 CONTINUE
883*
884 END IF
885*
886 ELSE
887*
888* Symmetric -- A = U D U'
889* Hermitian -- A = U D U*
890*
891 ipackg = ipack
892 ioffg = ioffst
893*
894 IF( topdwn ) THEN
895*
896* Top-Down -- Generate Upper triangle only
897*
898 IF( ipack.GE.5 ) THEN
899 ipackg = 6
900 ioffg = uub + 1
901 ELSE
902 ipackg = 1
903 END IF
904*
905 DO 260 j = 1, mnmin
906 a( ( 1-iskew )*j+ioffg, j ) = dcmplx( d( j ) )
907 260 CONTINUE
908*
909 DO 290 k = 1, uub
910 DO 280 jc = 1, n - 1
911 irow = max( 1, jc-k )
912 il = min( jc+1, k+2 )
913 extra = czero
914 ztemp = a( jc-iskew*( jc+1 )+ioffg, jc+1 )
915 angle = twopi*dlarnd( 1, iseed )
916 c = cos( angle )*zlarnd( 5, iseed )
917 s = sin( angle )*zlarnd( 5, iseed )
918 IF( csym ) THEN
919 ct = c
920 st = s
921 ELSE
922 ztemp = dconjg( ztemp )
923 ct = dconjg( c )
924 st = dconjg( s )
925 END IF
926 CALL zlarot( .false., jc.GT.k, .true., il, c, s,
927 $ a( irow-iskew*jc+ioffg, jc ), ilda,
928 $ extra, ztemp )
929 CALL zlarot( .true., .true., .false.,
930 $ min( k, n-jc )+1, ct, st,
931 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
932 $ ztemp, dummy )
933*
934* Chase EXTRA back up the matrix
935*
936 icol = jc
937 DO 270 jch = jc - k, 1, -k
938 CALL zlartg( a( jch+1-iskew*( icol+1 )+ioffg,
939 $ icol+1 ), extra, realc, s, dummy )
940 dummy = zlarnd( 5, iseed )
941 c = dconjg( realc*dummy )
942 s = dconjg( -s*dummy )
943 ztemp = a( jch-iskew*( jch+1 )+ioffg, jch+1 )
944 IF( csym ) THEN
945 ct = c
946 st = s
947 ELSE
948 ztemp = dconjg( ztemp )
949 ct = dconjg( c )
950 st = dconjg( s )
951 END IF
952 CALL zlarot( .true., .true., .true., k+2, c, s,
953 $ a( ( 1-iskew )*jch+ioffg, jch ),
954 $ ilda, ztemp, extra )
955 irow = max( 1, jch-k )
956 il = min( jch+1, k+2 )
957 extra = czero
958 CALL zlarot( .false., jch.GT.k, .true., il, ct,
959 $ st, a( irow-iskew*jch+ioffg, jch ),
960 $ ilda, extra, ztemp )
961 icol = jch
962 270 CONTINUE
963 280 CONTINUE
964 290 CONTINUE
965*
966* If we need lower triangle, copy from upper. Note that
967* the order of copying is chosen to work for 'q' -> 'b'
968*
969 IF( ipack.NE.ipackg .AND. ipack.NE.3 ) THEN
970 DO 320 jc = 1, n
971 irow = ioffst - iskew*jc
972 IF( csym ) THEN
973 DO 300 jr = jc, min( n, jc+uub )
974 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
975 300 CONTINUE
976 ELSE
977 DO 310 jr = jc, min( n, jc+uub )
978 a( jr+irow, jc ) = dconjg( a( jc-iskew*jr+
979 $ ioffg, jr ) )
980 310 CONTINUE
981 END IF
982 320 CONTINUE
983 IF( ipack.EQ.5 ) THEN
984 DO 340 jc = n - uub + 1, n
985 DO 330 jr = n + 2 - jc, uub + 1
986 a( jr, jc ) = czero
987 330 CONTINUE
988 340 CONTINUE
989 END IF
990 IF( ipackg.EQ.6 ) THEN
991 ipackg = ipack
992 ELSE
993 ipackg = 0
994 END IF
995 END IF
996 ELSE
997*
998* Bottom-Up -- Generate Lower triangle only
999*
1000 IF( ipack.GE.5 ) THEN
1001 ipackg = 5
1002 IF( ipack.EQ.6 )
1003 $ ioffg = 1
1004 ELSE
1005 ipackg = 2
1006 END IF
1007*
1008 DO 350 j = 1, mnmin
1009 a( ( 1-iskew )*j+ioffg, j ) = dcmplx( d( j ) )
1010 350 CONTINUE
1011*
1012 DO 380 k = 1, uub
1013 DO 370 jc = n - 1, 1, -1
1014 il = min( n+1-jc, k+2 )
1015 extra = czero
1016 ztemp = a( 1+( 1-iskew )*jc+ioffg, jc )
1017 angle = twopi*dlarnd( 1, iseed )
1018 c = cos( angle )*zlarnd( 5, iseed )
1019 s = sin( angle )*zlarnd( 5, iseed )
1020 IF( csym ) THEN
1021 ct = c
1022 st = s
1023 ELSE
1024 ztemp = dconjg( ztemp )
1025 ct = dconjg( c )
1026 st = dconjg( s )
1027 END IF
1028 CALL zlarot( .false., .true., n-jc.GT.k, il, c, s,
1029 $ a( ( 1-iskew )*jc+ioffg, jc ), ilda,
1030 $ ztemp, extra )
1031 icol = max( 1, jc-k+1 )
1032 CALL zlarot( .true., .false., .true., jc+2-icol,
1033 $ ct, st, a( jc-iskew*icol+ioffg,
1034 $ icol ), ilda, dummy, ztemp )
1035*
1036* Chase EXTRA back down the matrix
1037*
1038 icol = jc
1039 DO 360 jch = jc + k, n - 1, k
1040 CALL zlartg( a( jch-iskew*icol+ioffg, icol ),
1041 $ extra, realc, s, dummy )
1042 dummy = zlarnd( 5, iseed )
1043 c = realc*dummy
1044 s = s*dummy
1045 ztemp = a( 1+( 1-iskew )*jch+ioffg, jch )
1046 IF( csym ) THEN
1047 ct = c
1048 st = s
1049 ELSE
1050 ztemp = dconjg( ztemp )
1051 ct = dconjg( c )
1052 st = dconjg( s )
1053 END IF
1054 CALL zlarot( .true., .true., .true., k+2, c, s,
1055 $ a( jch-iskew*icol+ioffg, icol ),
1056 $ ilda, extra, ztemp )
1057 il = min( n+1-jch, k+2 )
1058 extra = czero
1059 CALL zlarot( .false., .true., n-jch.GT.k, il,
1060 $ ct, st, a( ( 1-iskew )*jch+ioffg,
1061 $ jch ), ilda, ztemp, extra )
1062 icol = jch
1063 360 CONTINUE
1064 370 CONTINUE
1065 380 CONTINUE
1066*
1067* If we need upper triangle, copy from lower. Note that
1068* the order of copying is chosen to work for 'b' -> 'q'
1069*
1070 IF( ipack.NE.ipackg .AND. ipack.NE.4 ) THEN
1071 DO 410 jc = n, 1, -1
1072 irow = ioffst - iskew*jc
1073 IF( csym ) THEN
1074 DO 390 jr = jc, max( 1, jc-uub ), -1
1075 a( jr+irow, jc ) = a( jc-iskew*jr+ioffg, jr )
1076 390 CONTINUE
1077 ELSE
1078 DO 400 jr = jc, max( 1, jc-uub ), -1
1079 a( jr+irow, jc ) = dconjg( a( jc-iskew*jr+
1080 $ ioffg, jr ) )
1081 400 CONTINUE
1082 END IF
1083 410 CONTINUE
1084 IF( ipack.EQ.6 ) THEN
1085 DO 430 jc = 1, uub
1086 DO 420 jr = 1, uub + 1 - jc
1087 a( jr, jc ) = czero
1088 420 CONTINUE
1089 430 CONTINUE
1090 END IF
1091 IF( ipackg.EQ.5 ) THEN
1092 ipackg = ipack
1093 ELSE
1094 ipackg = 0
1095 END IF
1096 END IF
1097 END IF
1098*
1099* Ensure that the diagonal is real if Hermitian
1100*
1101 IF( .NOT.csym ) THEN
1102 DO 440 jc = 1, n
1103 irow = ioffst + ( 1-iskew )*jc
1104 a( irow, jc ) = dcmplx( dble( a( irow, jc ) ) )
1105 440 CONTINUE
1106 END IF
1107*
1108 END IF
1109*
1110 ELSE
1111*
1112* 4) Generate Banded Matrix by first
1113* Rotating by random Unitary matrices,
1114* then reducing the bandwidth using Householder
1115* transformations.
1116*
1117* Note: we should get here only if LDA .ge. N
1118*
1119 IF( isym.EQ.1 ) THEN
1120*
1121* Non-symmetric -- A = U D V
1122*
1123 CALL zlagge( mr, nc, llb, uub, d, a, lda, iseed, work,
1124 $ iinfo )
1125 ELSE
1126*
1127* Symmetric -- A = U D U' or
1128* Hermitian -- A = U D U*
1129*
1130 IF( csym ) THEN
1131 CALL zlagsy( m, llb, d, a, lda, iseed, work, iinfo )
1132 ELSE
1133 CALL zlaghe( m, llb, d, a, lda, iseed, work, iinfo )
1134 END IF
1135 END IF
1136*
1137 IF( iinfo.NE.0 ) THEN
1138 info = 3
1139 RETURN
1140 END IF
1141 END IF
1142*
1143* 5) Pack the matrix
1144*
1145 IF( ipack.NE.ipackg ) THEN
1146 IF( ipack.EQ.1 ) THEN
1147*
1148* 'U' -- Upper triangular, not packed
1149*
1150 DO 460 j = 1, m
1151 DO 450 i = j + 1, m
1152 a( i, j ) = czero
1153 450 CONTINUE
1154 460 CONTINUE
1155*
1156 ELSE IF( ipack.EQ.2 ) THEN
1157*
1158* 'L' -- Lower triangular, not packed
1159*
1160 DO 480 j = 2, m
1161 DO 470 i = 1, j - 1
1162 a( i, j ) = czero
1163 470 CONTINUE
1164 480 CONTINUE
1165*
1166 ELSE IF( ipack.EQ.3 ) THEN
1167*
1168* 'C' -- Upper triangle packed Columnwise.
1169*
1170 icol = 1
1171 irow = 0
1172 DO 500 j = 1, m
1173 DO 490 i = 1, j
1174 irow = irow + 1
1175 IF( irow.GT.lda ) THEN
1176 irow = 1
1177 icol = icol + 1
1178 END IF
1179 a( irow, icol ) = a( i, j )
1180 490 CONTINUE
1181 500 CONTINUE
1182*
1183 ELSE IF( ipack.EQ.4 ) THEN
1184*
1185* 'R' -- Lower triangle packed Columnwise.
1186*
1187 icol = 1
1188 irow = 0
1189 DO 520 j = 1, m
1190 DO 510 i = j, m
1191 irow = irow + 1
1192 IF( irow.GT.lda ) THEN
1193 irow = 1
1194 icol = icol + 1
1195 END IF
1196 a( irow, icol ) = a( i, j )
1197 510 CONTINUE
1198 520 CONTINUE
1199*
1200 ELSE IF( ipack.GE.5 ) THEN
1201*
1202* 'B' -- The lower triangle is packed as a band matrix.
1203* 'Q' -- The upper triangle is packed as a band matrix.
1204* 'Z' -- The whole matrix is packed as a band matrix.
1205*
1206 IF( ipack.EQ.5 )
1207 $ uub = 0
1208 IF( ipack.EQ.6 )
1209 $ llb = 0
1210*
1211 DO 540 j = 1, uub
1212 DO 530 i = min( j+llb, m ), 1, -1
1213 a( i-j+uub+1, j ) = a( i, j )
1214 530 CONTINUE
1215 540 CONTINUE
1216*
1217 DO 560 j = uub + 2, n
1218 DO 550 i = j - uub, min( j+llb, m )
1219 a( i-j+uub+1, j ) = a( i, j )
1220 550 CONTINUE
1221 560 CONTINUE
1222 END IF
1223*
1224* If packed, zero out extraneous elements.
1225*
1226* Symmetric/Triangular Packed --
1227* zero out everything after A(IROW,ICOL)
1228*
1229 IF( ipack.EQ.3 .OR. ipack.EQ.4 ) THEN
1230 DO 580 jc = icol, m
1231 DO 570 jr = irow + 1, lda
1232 a( jr, jc ) = czero
1233 570 CONTINUE
1234 irow = 0
1235 580 CONTINUE
1236*
1237 ELSE IF( ipack.GE.5 ) THEN
1238*
1239* Packed Band --
1240* 1st row is now in A( UUB+2-j, j), zero above it
1241* m-th row is now in A( M+UUB-j,j), zero below it
1242* last non-zero diagonal is now in A( UUB+LLB+1,j ),
1243* zero below it, too.
1244*
1245 ir1 = uub + llb + 2
1246 ir2 = uub + m + 2
1247 DO 610 jc = 1, n
1248 DO 590 jr = 1, uub + 1 - jc
1249 a( jr, jc ) = czero
1250 590 CONTINUE
1251 DO 600 jr = max( 1, min( ir1, ir2-jc ) ), lda
1252 a( jr, jc ) = czero
1253 600 CONTINUE
1254 610 CONTINUE
1255 END IF
1256 END IF
1257*
1258 RETURN
1259*
1260* End of ZLATMT
1261*
dlatm7
subroutine dlatm7(mode, cond, irsign, idist, iseed, d, n, rank, info)
DLATM7
Definition dlatm7.f:122