183 SUBROUTINE dckcsd( 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
194 DOUBLE PRECISION thresh
197 INTEGER iseed( 4 ), iwork( * ), mval( * ), pval( * ),
199 DOUBLE PRECISION rwork( * ), theta( * )
200 DOUBLE PRECISION u1( * ), u2( * ), v1t( * ), v2t( * ),
201 $ work( * ), x( * ), xf( * )
208 parameter( ntests = 9 )
210 parameter( ntypes = 3 )
211 DOUBLE PRECISION gapdigit, orth, piover2, ten
212 parameter( gapdigit = 18.0d0, orth = 1.0d-12,
213 $ piover2 = 1.57079632679489662d0,
219 INTEGER i, iinfo, im, imat, j, ldu1, ldu2, ldv1t,
220 $ ldv2t, ldx, lwork, m, nfail, nrun, nt, p, q, r
223 LOGICAL dotype( ntypes )
224 DOUBLE PRECISION result( ntests )
246 CALL
alareq( path, nmats, dotype, ntypes, nin, nout )
261 DO 20 imat = 1, ntypes
265 IF( .NOT.dotype( imat ) )
271 CALL
dlaror(
'L',
'I', m, m, x, ldx, iseed, work, iinfo )
272 IF( m .NE. 0 .AND. iinfo .NE. 0 )
THEN
273 WRITE( nout, fmt = 9999 ) m, iinfo
277 ELSE IF( imat.EQ.2 )
THEN
278 r = min( p, m-p, q, m-q )
280 theta(i) = piover2 *
dlarnd( 1, iseed )
282 CALL
dlacsg( m, p, q, theta, iseed, x, ldx, work )
285 x(i+(j-1)*ldx) = x(i+(j-1)*ldx) +
290 r = min( p, m-p, q, m-q )
292 theta(i) = ten**(-
dlarnd(1,iseed)*gapdigit)
295 theta(i) = theta(i-1) + theta(i)
298 theta(i) = piover2 * theta(i) / theta(r+1)
300 CALL
dlacsg( m, p, q, theta, iseed, x, ldx, work )
305 CALL
dcsdts( m, p, q, x, xf, ldx, u1, ldu1, u2, ldu2, v1t,
306 $ ldv1t, v2t, ldv2t, theta, iwork, work, lwork,
313 IF( result( i ).GE.thresh )
THEN
314 IF( nfail.EQ.0 .AND. firstt )
THEN
318 WRITE( nout, fmt = 9998 )m, p, q, imat, i,
329 CALL
alasum( path, nout, nfail, nrun, 0 )
331 9999 format(
' DLAROR in DCKCSD: M = ', i5,
', INFO = ', i15 )
332 9998 format(
' M=', i4,
' P=', i4,
', Q=', i4,
', type ', i2,
333 $
', test ', i2,
', ratio=', g13.6 )
342 SUBROUTINE dlacsg( M, P, Q, THETA, ISEED, X, LDX, WORK )
347 DOUBLE PRECISION theta( * )
348 DOUBLE PRECISION work( * ), x( ldx, * )
350 DOUBLE PRECISION one, zero
351 parameter( one = 1.0d0, zero = 0.0d0 )
355 r = min( p, m-p, q, m-q )
357 CALL
dlaset(
'Full', m, m, zero, zero, x, ldx )
363 x(min(p,q)-r+i,min(p,q)-r+i) = cos(theta(i))
365 DO i = 1, min(p,m-q)-r
366 x(p-i+1,m-i+1) = -one
369 x(p-(min(p,m-q)-r)+1-i,m-(min(p,m-q)-r)+1-i) =
372 DO i = 1, min(m-p,q)-r
376 x(m-(min(m-p,q)-r)+1-i,q-(min(m-p,q)-r)+1-i) =
379 DO i = 1, min(m-p,m-q)-r
383 x(p+(min(m-p,m-q)-r)+i,q+(min(m-p,m-q)-r)+i) =
386 CALL
dlaror(
'Left',
'No init', p, m, x, ldx, iseed, work, info )
387 CALL
dlaror(
'Left',
'No init', m-p, m, x(p+1,1), ldx,
388 $ iseed, work, info )
389 CALL
dlaror(
'Right',
'No init', m, q, x, ldx, iseed,
391 CALL
dlaror(
'Right',
'No init', m, m-q,
392 $ x(1,q+1), ldx, iseed, work, info )