175 SUBROUTINE dlatm4( ITYPE, N, NZ1, NZ2, ISIGN, AMAGN, RCOND,
176 $ triang, idist, iseed, a, lda )
184 INTEGER idist, isign, itype, lda, n, nz1, nz2
185 DOUBLE PRECISION amagn, rcond, triang
189 DOUBLE PRECISION a( lda, * )
195 DOUBLE PRECISION zero, one, two
196 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0 )
197 DOUBLE PRECISION half
198 parameter( half = one / two )
201 INTEGER i, ioff, isdb, isde, jc, jd, jr, k, kbeg, kend,
203 DOUBLE PRECISION alpha, cl, cr, safmin, sl, sr, sv1, sv2, temp
213 INTRINSIC abs, dble, exp, log, max, min, mod, sqrt
219 CALL
dlaset(
'Full', n, n, zero, zero, a, lda )
223 IF( mod( iseed( 4 ), 2 ).NE.1 )
224 $ iseed( 4 ) = iseed( 4 ) + 1
229 IF( itype.NE.0 )
THEN
230 IF( abs( itype ).GE.4 )
THEN
231 kbeg = max( 1, min( n, nz1+1 ) )
232 kend = max( kbeg, min( n, n-nz2 ) )
233 klen = kend + 1 - kbeg
241 go to( 10, 30, 50, 80, 100, 120, 140, 160,
242 $ 180, 200 )abs( itype )
272 DO 70 jd = k + 2, 2*k + 1
280 DO 90 jd = kbeg, kend
281 a( jd, jd ) = dble( jd-nz1 )
288 DO 110 jd = kbeg + 1, kend
291 a( kbeg, kbeg ) = one
297 DO 130 jd = kbeg, kend - 1
300 a( kend, kend ) = rcond
306 a( kbeg, kbeg ) = one
308 alpha = rcond**( one / dble( klen-1 ) )
310 a( nz1+i, nz1+i ) = alpha**dble( i-1 )
318 a( kbeg, kbeg ) = one
320 alpha = ( one-rcond ) / dble( klen-1 )
322 a( nz1+i, nz1+i ) = dble( klen-i )*alpha + rcond
331 DO 190 jd = kbeg, kend
332 a( jd, jd ) = exp( alpha*
dlaran( iseed ) )
339 DO 210 jd = kbeg, kend
340 a( jd, jd ) =
dlarnd( idist, iseed )
347 DO 230 jd = kbeg, kend
348 a( jd, jd ) = amagn*dble( a( jd, jd ) )
350 DO 240 jd = isdb, isde
351 a( jd+1, jd ) = amagn*dble( a( jd+1, jd ) )
357 IF( isign.GT.0 )
THEN
358 DO 250 jd = kbeg, kend
359 IF( dble( a( jd, jd ) ).NE.zero )
THEN
360 IF(
dlaran( iseed ).GT.half )
361 $ a( jd, jd ) = -a( jd, jd )
364 DO 260 jd = isdb, isde
365 IF( dble( a( jd+1, jd ) ).NE.zero )
THEN
366 IF(
dlaran( iseed ).GT.half )
367 $ a( jd+1, jd ) = -a( jd+1, jd )
374 IF( itype.LT.0 )
THEN
375 DO 270 jd = kbeg, ( kbeg+kend-1 ) / 2
377 a( jd, jd ) = a( kbeg+kend-jd, kbeg+kend-jd )
378 a( kbeg+kend-jd, kbeg+kend-jd ) = temp
380 DO 280 jd = 1, ( n-1 ) / 2
382 a( jd+1, jd ) = a( n+1-jd, n-jd )
383 a( n+1-jd, n-jd ) = temp
390 IF( isign.EQ.2 .AND. itype.NE.2 .AND. itype.NE.3 )
THEN
392 DO 290 jd = kbeg, kend - 1, 2
393 IF(
dlaran( iseed ).GT.half )
THEN
397 cl = two*
dlaran( iseed ) - one
398 sl = two*
dlaran( iseed ) - one
399 temp = one / max( safmin, sqrt( cl**2+sl**2 ) )
405 cr = two*
dlaran( iseed ) - one
406 sr = two*
dlaran( iseed ) - one
407 temp = one / max( safmin, sqrt( cr**2+sr**2 ) )
414 sv2 = a( jd+1, jd+1 )
415 a( jd, jd ) = cl*cr*sv1 + sl*sr*sv2
416 a( jd+1, jd ) = -sl*cr*sv1 + cl*sr*sv2
417 a( jd, jd+1 ) = -cl*sr*sv1 + sl*cr*sv2
418 a( jd+1, jd+1 ) = sl*sr*sv1 + cl*cr*sv2
427 IF( triang.NE.zero )
THEN
428 IF( isign.NE.2 .OR. itype.EQ.2 .OR. itype.EQ.3 )
THEN
433 IF( a( jr+1, jr ).EQ.zero )
434 $ a( jr, jr+1 ) = triang*
dlarnd( idist, iseed )
439 DO 310 jr = 1, jc - ioff
440 a( jr, jc ) = triang*
dlarnd( idist, iseed )