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 = 15 )
210 parameter( ntypes = 4 )
211 DOUBLE PRECISION GAPDIGIT, ONE, ORTH, PIOVER2, TEN, ZERO
212 parameter( gapdigit = 18.0d0, one = 1.0d0,
214 $ piover2 = 1.57079632679489662d0,
215 $ ten = 10.0d0, zero = 0.0d0 )
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 DOUBLE PRECISION RESULT( ntests )
235 DOUBLE PRECISION DLARAN, DLARND
236 EXTERNAL dlaran, dlarnd
247 CALL
alareq( path, nmats, dotype, ntypes, nin, nout )
262 DO 20 imat = 1, ntypes
266 IF( .NOT.dotype( imat ) )
272 CALL
dlaror(
'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 * dlarnd( 1, iseed )
283 CALL
dlacsg( m, p, q, theta, iseed, x, ldx, work )
286 x(i+(j-1)*ldx) = x(i+(j-1)*ldx) +
287 $ orth*dlarnd(2,iseed)
290 ELSE IF( imat.EQ.3 )
THEN
291 r = min( p, m-p, q, m-q )
293 theta(i) = ten**(-dlarnd(1,iseed)*gapdigit)
296 theta(i) = theta(i-1) + theta(i)
299 theta(i) = piover2 * theta(i) / theta(r+1)
301 CALL
dlacsg( m, p, q, theta, iseed, x, ldx, work )
303 CALL
dlaset(
'F', m, m, zero, one, x, ldx )
305 j = int( dlaran( iseed ) * m ) + 1
307 CALL
drot( m, x(1+(i-1)*ldx), 1, x(1+(j-1)*ldx), 1,
315 CALL
dcsdts( 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(
' DLAROR in DCKCSD: M = ', i5,
', INFO = ', i15 )
342 9998
FORMAT(
' M=', i4,
' P=', i4,
', Q=', i4,
', type ', i2,
343 $
', test ', i2,
', ratio=', g13.6 )
352 SUBROUTINE dlacsg( M, P, Q, THETA, ISEED, X, LDX, WORK )
357 DOUBLE PRECISION THETA( * )
358 DOUBLE PRECISION WORK( * ), X( ldx, * )
360 DOUBLE PRECISION ONE, ZERO
361 parameter( one = 1.0d0, zero = 0.0d0 )
365 r = min( p, m-p, q, m-q )
367 CALL
dlaset(
'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
dlaror(
'Left',
'No init', p, m, x, ldx, iseed, work, info )
397 CALL
dlaror(
'Left',
'No init', m-p, m, x(p+1,1), ldx,
398 $ iseed, work, info )
399 CALL
dlaror(
'Right',
'No init', m, q, x, ldx, iseed,
401 CALL
dlaror(
'Right',
'No init', m, m-q,
402 $ x(1,q+1), ldx, iseed, work, info )
subroutine dlacsg(M, P, Q, THETA, ISEED, X, LDX, WORK)
subroutine alahdg(IOUNIT, PATH)
ALAHDG
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine dcsdts(M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, RWORK, RESULT)
DCSDTS
subroutine dckcsd(NM, MVAL, PVAL, QVAL, NMATS, ISEED, THRESH, MMAX, X, XF, U1, U2, V1T, V2T, THETA, IWORK, WORK, RWORK, NIN, NOUT, INFO)
DCKCSD
subroutine alareq(PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT)
ALAREQ
subroutine drot(N, DX, INCX, DY, INCY, C, S)
DROT
subroutine dlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine dlaror(SIDE, INIT, M, N, A, LDA, ISEED, X, INFO)
DLAROR