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 )
subroutine slacsg(M, P, Q, THETA, ISEED, X, LDX, WORK)
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine alahdg(IOUNIT, PATH)
ALAHDG
subroutine slaror(SIDE, INIT, M, N, A, LDA, ISEED, X, INFO)
SLAROR
REAL function slarnd(IDIST, ISEED)
SLARND
REAL function slaran(ISEED)
SLARAN
subroutine scsdts(M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, RWORK, RESULT)
SCSDTS
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM
subroutine alareq(PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT)
ALAREQ
subroutine sckcsd(NM, MVAL, PVAL, QVAL, NMATS, ISEED, THRESH, MMAX, X, XF, U1, U2, V1T, V2T, THETA, IWORK, WORK, RWORK, NIN, NOUT, INFO)
SCKCSD
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT