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 )
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) +
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 )
double precision function dlarnd(IDIST, ISEED)
DLARND
subroutine alahdg(IOUNIT, PATH)
ALAHDG
subroutine zcsdts(M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, RWORK, RESULT)
ZCSDTS
subroutine zdrot(N, CX, INCX, CY, INCY, C, S)
ZDROT
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 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 alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine alareq(PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT)
ALAREQ
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine zlacsg(M, P, Q, THETA, ISEED, X, LDX, WORK)
double precision function dlaran(ISEED)
DLARAN