183 SUBROUTINE sckcsd( NM, MVAL, PVAL, QVAL, NMATS, ISEED, THRESH,
184 $ mmax, x, xf, u1, u2, v1t, v2t, theta, iwork,
185 $ work, rwork, nin, nout, info )
193 INTEGER info, nin, nm, nmats, mmax, nout
197 INTEGER iseed( 4 ), iwork( * ), mval( * ), pval( * ),
199 REAL rwork( * ), theta( * )
200 REAL u1( * ), u2( * ), v1t( * ), v2t( * ),
201 $ work( * ), x( * ), xf( * )
208 parameter( ntests = 15 )
210 parameter( ntypes = 4 )
211 REAL gapdigit, one, orth, piover2, ten, zero
212 parameter( gapdigit = 10.0e0, one = 1.0e0,
214 $ piover2 = 1.57079632679489662e0,
215 $ ten = 10.0e0, zero = 0.0e0 )
220 INTEGER i, iinfo, im, imat,
j, ldu1, ldu2, ldv1t,
221 $ ldv2t, ldx, lwork, m, nfail, nrun, nt, p, q, r
224 LOGICAL dotype( ntypes )
225 REAL result( ntests )
247 CALL
alareq( path, nmats, dotype, ntypes, nin, nout )
262 DO 20 imat = 1, ntypes
266 IF( .NOT.dotype( imat ) )
272 CALL
slaror(
'L',
'I', m, m, x, ldx, iseed, work, iinfo )
273 IF( m .NE. 0 .AND. iinfo .NE. 0 )
THEN
274 WRITE( nout, fmt = 9999 ) m, iinfo
278 ELSE IF( imat.EQ.2 )
THEN
279 r = min( p, m-p, q, m-q )
281 theta(i) = piover2 *
slarnd( 1, iseed )
283 CALL
slacsg( m, p, q, theta, iseed, x, ldx, work )
286 x(i+(
j-1)*ldx) = x(i+(
j-1)*ldx) +
290 ELSE IF( imat.EQ.3 )
THEN
291 r = min( p, m-p, q, m-q )
293 theta(i) = ten**(-
slarnd(1,iseed)*gapdigit)
296 theta(i) = theta(i-1) + theta(i)
299 theta(i) = piover2 * theta(i) / theta(r+1)
301 CALL
slacsg( m, p, q, theta, iseed, x, ldx, work )
303 CALL
slaset(
'F', m, m, zero, one, x, ldx )
305 j = int(
slaran( iseed ) * m ) + 1
307 CALL
srot( m, x(1+(i-1)*ldx), 1, x(1+(
j-1)*ldx), 1,
315 CALL
scsdts( m, p, q, x, xf, ldx, u1, ldu1, u2, ldu2, v1t,
316 $ ldv1t, v2t, ldv2t, theta, iwork, work, lwork,
323 IF( result( i ).GE.thresh )
THEN
324 IF( nfail.EQ.0 .AND. firstt )
THEN
328 WRITE( nout, fmt = 9998 )m, p, q, imat, i,
339 CALL
alasum( path, nout, nfail, nrun, 0 )
341 9999
FORMAT(
' SLAROR in SCKCSD: M = ', i5,
', INFO = ', i15 )
342 9998
FORMAT(
' M=', i4,
' P=', i4,
', Q=', i4,
', type ', i2,
343 $
', test ', i2,
', ratio=', g13.6 )
352 SUBROUTINE slacsg( M, P, Q, THETA, ISEED, X, LDX, WORK )
358 REAL work( * ), x( ldx, * )
361 parameter( one = 1.0e0, zero = 0.0e0 )
365 r = min( p, m-p, q, m-q )
367 CALL
slaset(
'Full', m, m, zero, zero, x, ldx )
373 x(min(p,q)-r+i,min(p,q)-r+i) = cos(theta(i))
375 DO i = 1, min(p,m-q)-r
376 x(p-i+1,m-i+1) = -one
379 x(p-(min(p,m-q)-r)+1-i,m-(min(p,m-q)-r)+1-i) =
382 DO i = 1, min(m-p,q)-r
386 x(m-(min(m-p,q)-r)+1-i,q-(min(m-p,q)-r)+1-i) =
389 DO i = 1, min(m-p,m-q)-r
393 x(p+(min(m-p,m-q)-r)+i,q+(min(m-p,m-q)-r)+i) =
396 CALL
slaror(
'Left',
'No init', p, m, x, ldx, iseed, work, info )
397 CALL
slaror(
'Left',
'No init', m-p, m, x(p+1,1), ldx,
398 $ iseed, work, info )
399 CALL
slaror(
'Right',
'No init', m, q, x, ldx, iseed,
401 CALL
slaror(
'Right',
'No init', m, m-q,
402 $ x(1,q+1), ldx, iseed, work, info )