183 SUBROUTINE cckcsd( 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 COMPLEX U1( * ), U2( * ), V1T( * ), V2T( * ),
201 $ work( * ), x( * ), xf( * )
208 parameter ( ntests = 15 )
210 parameter ( ntypes = 4 )
211 REAL GAPDIGIT, ORTH, PIOVER2, REALONE, REALZERO, TEN
212 parameter ( gapdigit = 10.0e0, orth = 1.0e-4,
213 $ piover2 = 1.57079632679489662e0,
214 $ realone = 1.0e0, realzero = 0.0e0,
217 parameter ( one = (1.0e0,0.0e0), zero = (0.0e0,0.0e0) )
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 REAL RESULT( ntests )
238 EXTERNAL slaran, slarnd
249 CALL alareq( path, nmats, dotype, ntypes, nin, nout )
264 DO 20 imat = 1, ntypes
268 IF( .NOT.dotype( imat ) )
274 CALL claror(
'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 * slarnd( 1, iseed )
285 CALL clacsg( m, p, q, theta, iseed, x, ldx, work )
288 x(i+(j-1)*ldx) = x(i+(j-1)*ldx) +
289 $ orth*slarnd(2,iseed)
292 ELSE IF( imat.EQ.3 )
THEN
293 r = min( p, m-p, q, m-q )
295 theta(i) = ten**(-slarnd(1,iseed)*gapdigit)
298 theta(i) = theta(i-1) + theta(i)
301 theta(i) = piover2 * theta(i) / theta(r+1)
303 CALL clacsg( m, p, q, theta, iseed, x, ldx, work )
305 CALL claset(
'F', m, m, zero, one, x, ldx )
307 j = int( slaran( iseed ) * m ) + 1
309 CALL csrot( m, x(1+(i-1)*ldx), 1, x(1+(j-1)*ldx),
310 $ 1, realzero, realone )
317 CALL ccsdts( 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(
' CLAROR in CCKCSD: M = ', i5,
', INFO = ', i15 )
344 9998
FORMAT(
' M=', i4,
' P=', i4,
', Q=', i4,
', type ', i2,
345 $
', test ', i2,
', ratio=', g13.6 )
354 SUBROUTINE clacsg( M, P, Q, THETA, ISEED, X, LDX, WORK )
360 COMPLEX WORK( * ), X( ldx, * )
363 parameter ( one = (1.0e0,0.0e0), zero = (0.0e0,0.0e0) )
367 r = min( p, m-p, q, m-q )
369 CALL claset(
'Full', m, m, zero, zero, x, ldx )
375 x(min(p,q)-r+i,min(p,q)-r+i) = cmplx( cos(theta(i)), 0.0e0 )
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 $ cmplx( -sin(theta(r-i+1)), 0.0e0 )
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 $ cmplx( sin(theta(r-i+1)), 0.0e0 )
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 $ cmplx( cos(theta(i)), 0.0e0 )
398 CALL claror(
'Left',
'No init', p, m, x, ldx, iseed, work, info )
399 CALL claror(
'Left',
'No init', m-p, m, x(p+1,1), ldx,
400 $ iseed, work, info )
401 CALL claror(
'Right',
'No init', m, q, x, ldx, iseed,
403 CALL claror(
'Right',
'No init', m, m-q,
404 $ x(1,q+1), ldx, iseed, work, info )
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine claror(SIDE, INIT, M, N, A, LDA, ISEED, X, INFO)
CLAROR
subroutine alareq(PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT)
ALAREQ
subroutine cckcsd(NM, MVAL, PVAL, QVAL, NMATS, ISEED, THRESH, MMAX, X, XF, U1, U2, V1T, V2T, THETA, IWORK, WORK, RWORK, NIN, NOUT, INFO)
CCKCSD
subroutine ccsdts(M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK, RWORK, RESULT)
CCSDTS
subroutine clacsg(M, P, Q, THETA, ISEED, X, LDX, WORK)
subroutine csrot(N, CX, INCX, CY, INCY, C, S)
CSROT
subroutine alahdg(IOUNIT, PATH)
ALAHDG
subroutine alasum(TYPE, NOUT, NFAIL, NRUN, NERRS)
ALASUM