183 SUBROUTINE zckcsd( 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 COMPLEX*16 U1( * ), U2( * ), V1T( * ), V2T( * ),
201 $ work( * ), x( * ), xf( * )
208 parameter ( ntests = 15 )
210 parameter ( ntypes = 4 )
211 DOUBLE PRECISION GAPDIGIT, ORTH, PIOVER2, REALONE, REALZERO, TEN
212 parameter ( gapdigit = 18.0d0, orth = 1.0d-12,
213 $ piover2 = 1.57079632679489662d0,
214 $ realone = 1.0d0, realzero = 0.0d0,
217 parameter ( one = (1.0d0,0.0d0), zero = (0.0d0,0.0d0) )
222 INTEGER I, IINFO, IM, IMAT, J, LDU1, LDU2, LDV1T,
223 $ ldv2t, ldx, lwork, m, nfail, nrun, nt, p, q, r
226 LOGICAL DOTYPE( ntypes )
227 DOUBLE PRECISION RESULT( ntests )
237 DOUBLE PRECISION DLARAN, DLARND
238 EXTERNAL dlaran, dlarnd
249 CALL alareq( path, nmats, dotype, ntypes, nin, nout )
264 DO 20 imat = 1, ntypes
268 IF( .NOT.dotype( imat ) )
274 CALL zlaror(
'L',
'I', m, m, x, ldx, iseed, work, iinfo )
275 IF( m .NE. 0 .AND. iinfo .NE. 0 )
THEN
276 WRITE( nout, fmt = 9999 ) m, iinfo
280 ELSE IF( imat.EQ.2 )
THEN
281 r = min( p, m-p, q, m-q )
283 theta(i) = piover2 * dlarnd( 1, iseed )
285 CALL zlacsg( m, p, q, theta, iseed, x, ldx, work )
288 x(i+(j-1)*ldx) = x(i+(j-1)*ldx) +
289 $ orth*dlarnd(2,iseed)
292 ELSE IF( imat.EQ.3 )
THEN
293 r = min( p, m-p, q, m-q )
295 theta(i) = ten**(-dlarnd(1,iseed)*gapdigit)
298 theta(i) = theta(i-1) + theta(i)
301 theta(i) = piover2 * theta(i) / theta(r+1)
303 CALL zlacsg( m, p, q, theta, iseed, x, ldx, work )
305 CALL zlaset(
'F', m, m, zero, one, x, ldx )
307 j = int( dlaran( iseed ) * m ) + 1
309 CALL zdrot( m, x(1+(i-1)*ldx), 1, x(1+(j-1)*ldx),
310 $ 1, realzero, realone )
317 CALL zcsdts( m, p, q, x, xf, ldx, u1, ldu1, u2, ldu2, v1t,
318 $ ldv1t, v2t, ldv2t, theta, iwork, work, lwork,
325 IF( result( i ).GE.thresh )
THEN
326 IF( nfail.EQ.0 .AND. firstt )
THEN
330 WRITE( nout, fmt = 9998 )m, p, q, imat, i,
341 CALL alasum( path, nout, nfail, nrun, 0 )
343 9999
FORMAT(
' ZLAROR in ZCKCSD: M = ', i5,
', INFO = ', i15 )
344 9998
FORMAT(
' M=', i4,
' P=', i4,
', Q=', i4,
', type ', i2,
345 $
', test ', i2,
', ratio=', g13.6 )
354 SUBROUTINE zlacsg( M, P, Q, THETA, ISEED, X, LDX, WORK )
359 DOUBLE PRECISION THETA( * )
360 COMPLEX*16 WORK( * ), X( ldx, * )
363 parameter ( one = (1.0d0,0.0d0), zero = (0.0d0,0.0d0) )
367 r = min( p, m-p, q, m-q )
369 CALL zlaset(
'Full', m, m, zero, zero, x, ldx )
375 x(min(p,q)-r+i,min(p,q)-r+i) = dcmplx( cos(theta(i)), 0.0d0 )
377 DO i = 1, min(p,m-q)-r
378 x(p-i+1,m-i+1) = -one
381 x(p-(min(p,m-q)-r)+1-i,m-(min(p,m-q)-r)+1-i) =
382 $ dcmplx( -sin(theta(r-i+1)), 0.0d0 )
384 DO i = 1, min(m-p,q)-r
388 x(m-(min(m-p,q)-r)+1-i,q-(min(m-p,q)-r)+1-i) =
389 $ dcmplx( sin(theta(r-i+1)), 0.0d0 )
391 DO i = 1, min(m-p,m-q)-r
395 x(p+(min(m-p,m-q)-r)+i,q+(min(m-p,m-q)-r)+i) =
396 $ dcmplx( cos(theta(i)), 0.0d0 )
398 CALL zlaror(
'Left',
'No init', p, m, x, ldx, iseed, work, info )
399 CALL zlaror(
'Left',
'No init', m-p, m, x(p+1,1), ldx,
400 $ iseed, work, info )
401 CALL zlaror(
'Right',
'No init', m, q, x, ldx, iseed,
403 CALL zlaror(
'Right',
'No init', m, m-q,
404 $ x(1,q+1), ldx, iseed, work, info )
subroutine zcsdts(M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, RWORK, RESULT)
ZCSDTS
subroutine zlaror(SIDE, INIT, M, N, A, LDA, ISEED, X, INFO)
ZLAROR
subroutine zckcsd(NM, MVAL, PVAL, QVAL, NMATS, ISEED, THRESH, MMAX, X, XF, U1, U2, V1T, V2T, THETA, IWORK, WORK, RWORK, NIN, NOUT, INFO)
ZCKCSD
subroutine alareq(PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT)
ALAREQ
subroutine zdrot(N, CX, INCX, CY, INCY, C, S)
ZDROT
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...
subroutine zlacsg(M, P, Q, THETA, ISEED, X, LDX, WORK)
subroutine alahdg(IOUNIT, PATH)
ALAHDG
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM