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 )
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) +
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 )