157
158
159
160
161
162
163 LOGICAL TSTERR
164 INTEGER NMAX, NN, NOUT, NRHS
165 REAL THRESH
166
167
168 LOGICAL DOTYPE( * )
169 INTEGER IWORK( * ), NVAL( * )
170 REAL RWORK( * )
171 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
172 $ WORK( * ), X( * ), XACT( * )
173
174
175
176
177
178 REAL ONE, ZERO
179 parameter( one = 1.0e+0, zero = 0.0e+0 )
180 INTEGER NTYPES, NTESTS
181 parameter( ntypes = 11, ntests = 6 )
182 INTEGER NFACT
183 parameter( nfact = 2 )
184
185
186 LOGICAL ZEROT
187 CHARACTER DIST, EQUED, FACT, TYPE, UPLO, XTYPE
188 CHARACTER*3 PATH
189 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
190 $ IZERO, J, K, K1, KL, KU, LDA, LWORK, MODE, N,
191 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT,
192 $ N_ERR_BNDS
193 REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC,
194 $ RPVGRW_SVXX
195
196
197 CHARACTER FACTS( NFACT ), UPLOS( 2 )
198 INTEGER ISEED( 4 ), ISEEDY( 4 )
199 REAL RESULT( NTESTS ), BERR( NRHS ),
200 $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 )
201
202
203 REAL CLANSY, SGET06
205
206
211
212
213 LOGICAL LERR, OK
214 CHARACTER*32 SRNAMT
215 INTEGER INFOT, NUNIT
216
217
218 COMMON / infoc / infot, nunit, ok, lerr
219 COMMON / srnamc / srnamt
220
221
222 INTRINSIC cmplx, max, min
223
224
225 DATA iseedy / 1988, 1989, 1990, 1991 /
226 DATA uplos / 'U', 'L' / , facts / 'F', 'N' /
227
228
229
230
231
232 path( 1: 1 ) = 'Complex precision'
233 path( 2: 3 ) = 'SY'
234 nrun = 0
235 nfail = 0
236 nerrs = 0
237 DO 10 i = 1, 4
238 iseed( i ) = iseedy( i )
239 10 CONTINUE
240 lwork = max( 2*nmax, nmax*nrhs )
241
242
243
244 IF( tsterr )
245 $
CALL cerrvx( path, nout )
246 infot = 0
247
248
249
250 nb = 1
251 nbmin = 2
254
255
256
257 DO 180 in = 1, nn
258 n = nval( in )
259 lda = max( n, 1 )
260 xtype = 'N'
261 nimat = ntypes
262 IF( n.LE.0 )
263 $ nimat = 1
264
265 DO 170 imat = 1, nimat
266
267
268
269 IF( .NOT.dotype( imat ) )
270 $ GO TO 170
271
272
273
274 zerot = imat.GE.3 .AND. imat.LE.6
275 IF( zerot .AND. n.LT.imat-2 )
276 $ GO TO 170
277
278
279
280 DO 160 iuplo = 1, 2
281 uplo = uplos( iuplo )
282
283 IF( imat.NE.ntypes ) THEN
284
285
286
287
288 CALL clatb4( path, imat, n, n,
TYPE, KL, KU, ANORM,
289 $ MODE, CNDNUM, DIST )
290
291 srnamt = 'CLATMS'
292 CALL clatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
293 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
294 $ WORK, INFO )
295
296
297
298 IF( info.NE.0 ) THEN
299 CALL alaerh( path,
'CLATMS', info, 0, uplo, n, n,
300 $ -1, -1, -1, imat, nfail, nerrs, nout )
301 GO TO 160
302 END IF
303
304
305
306
307 IF( zerot ) THEN
308 IF( imat.EQ.3 ) THEN
309 izero = 1
310 ELSE IF( imat.EQ.4 ) THEN
311 izero = n
312 ELSE
313 izero = n / 2 + 1
314 END IF
315
316 IF( imat.LT.6 ) THEN
317
318
319
320 IF( iuplo.EQ.1 ) THEN
321 ioff = ( izero-1 )*lda
322 DO 20 i = 1, izero - 1
323 a( ioff+i ) = zero
324 20 CONTINUE
325 ioff = ioff + izero
326 DO 30 i = izero, n
327 a( ioff ) = zero
328 ioff = ioff + lda
329 30 CONTINUE
330 ELSE
331 ioff = izero
332 DO 40 i = 1, izero - 1
333 a( ioff ) = zero
334 ioff = ioff + lda
335 40 CONTINUE
336 ioff = ioff - izero
337 DO 50 i = izero, n
338 a( ioff+i ) = zero
339 50 CONTINUE
340 END IF
341 ELSE
342 IF( iuplo.EQ.1 ) THEN
343
344
345
346 ioff = 0
347 DO 70 j = 1, n
348 i2 = min( j, izero )
349 DO 60 i = 1, i2
350 a( ioff+i ) = zero
351 60 CONTINUE
352 ioff = ioff + lda
353 70 CONTINUE
354 ELSE
355
356
357
358 ioff = 0
359 DO 90 j = 1, n
360 i1 = max( j, izero )
361 DO 80 i = i1, n
362 a( ioff+i ) = zero
363 80 CONTINUE
364 ioff = ioff + lda
365 90 CONTINUE
366 END IF
367 END IF
368 ELSE
369 izero = 0
370 END IF
371 ELSE
372
373
374
375
376 CALL clatsy( uplo, n, a, lda, iseed )
377 END IF
378
379 DO 150 ifact = 1, nfact
380
381
382
383 fact = facts( ifact )
384
385
386
387
388 IF( zerot ) THEN
389 IF( ifact.EQ.1 )
390 $ GO TO 150
391 rcondc = zero
392
393 ELSE IF( ifact.EQ.1 ) THEN
394
395
396
397 anorm =
clansy(
'1', uplo, n, a, lda, rwork )
398
399
400
401 CALL clacpy( uplo, n, n, a, lda, afac, lda )
402 CALL csytrf( uplo, n, afac, lda, iwork, work,
403 $ lwork, info )
404
405
406
407 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
408 lwork = (n+nb+1)*(nb+3)
409 CALL csytri2( uplo, n, ainv, lda, iwork, work,
410 $ lwork, info )
411 ainvnm =
clansy(
'1', uplo, n, ainv, lda, rwork )
412
413
414
415 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
416 rcondc = one
417 ELSE
418 rcondc = ( one / anorm ) / ainvnm
419 END IF
420 END IF
421
422
423
424 srnamt = 'CLARHS'
425 CALL clarhs( path, xtype, uplo,
' ', n, n, kl, ku,
426 $ nrhs, a, lda, xact, lda, b, lda, iseed,
427 $ info )
428 xtype = 'C'
429
430
431
432 IF( ifact.EQ.2 ) THEN
433 CALL clacpy( uplo, n, n, a, lda, afac, lda )
434 CALL clacpy(
'Full', n, nrhs, b, lda, x, lda )
435
436
437
438 srnamt = 'CSYSV '
439 CALL csysv( uplo, n, nrhs, afac, lda, iwork, x,
440 $ lda, work, lwork, info )
441
442
443
444
445 k = izero
446 IF( k.GT.0 ) THEN
447 100 CONTINUE
448 IF( iwork( k ).LT.0 ) THEN
449 IF( iwork( k ).NE.-k ) THEN
450 k = -iwork( k )
451 GO TO 100
452 END IF
453 ELSE IF( iwork( k ).NE.k ) THEN
454 k = iwork( k )
455 GO TO 100
456 END IF
457 END IF
458
459
460
461 IF( info.NE.k ) THEN
462 CALL alaerh( path,
'CSYSV ', info, k, uplo, n,
463 $ n, -1, -1, nrhs, imat, nfail,
464 $ nerrs, nout )
465 GO TO 120
466 ELSE IF( info.NE.0 ) THEN
467 GO TO 120
468 END IF
469
470
471
472
473 CALL csyt01( uplo, n, a, lda, afac, lda, iwork,
474 $ ainv, lda, rwork, result( 1 ) )
475
476
477
478 CALL clacpy(
'Full', n, nrhs, b, lda, work, lda )
479 CALL csyt02( uplo, n, nrhs, a, lda, x, lda, work,
480 $ lda, rwork, result( 2 ) )
481
482
483
484 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
485 $ result( 3 ) )
486 nt = 3
487
488
489
490
491 DO 110 k = 1, nt
492 IF( result( k ).GE.thresh ) THEN
493 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
494 $
CALL aladhd( nout, path )
495 WRITE( nout, fmt = 9999 )'CSYSV ', uplo, n,
496 $ imat, k, result( k )
497 nfail = nfail + 1
498 END IF
499 110 CONTINUE
500 nrun = nrun + nt
501 120 CONTINUE
502 END IF
503
504
505
506 IF( ifact.EQ.2 )
507 $
CALL claset( uplo, n, n, cmplx( zero ),
508 $ cmplx( zero ), afac, lda )
509 CALL claset(
'Full', n, nrhs, cmplx( zero ),
510 $ cmplx( zero ), x, lda )
511
512
513
514
515 srnamt = 'CSYSVX'
516 CALL csysvx( fact, uplo, n, nrhs, a, lda, afac, lda,
517 $ iwork, b, lda, x, lda, rcond, rwork,
518 $ rwork( nrhs+1 ), work, lwork,
519 $ rwork( 2*nrhs+1 ), info )
520
521
522
523
524 k = izero
525 IF( k.GT.0 ) THEN
526 130 CONTINUE
527 IF( iwork( k ).LT.0 ) THEN
528 IF( iwork( k ).NE.-k ) THEN
529 k = -iwork( k )
530 GO TO 130
531 END IF
532 ELSE IF( iwork( k ).NE.k ) THEN
533 k = iwork( k )
534 GO TO 130
535 END IF
536 END IF
537
538
539
540 IF( info.NE.k ) THEN
541 CALL alaerh( path,
'CSYSVX', info, k, fact // uplo,
542 $ n, n, -1, -1, nrhs, imat, nfail,
543 $ nerrs, nout )
544 GO TO 150
545 END IF
546
547 IF( info.EQ.0 ) THEN
548 IF( ifact.GE.2 ) THEN
549
550
551
552
553 CALL csyt01( uplo, n, a, lda, afac, lda, iwork,
554 $ ainv, lda, rwork( 2*nrhs+1 ),
555 $ result( 1 ) )
556 k1 = 1
557 ELSE
558 k1 = 2
559 END IF
560
561
562
563 CALL clacpy(
'Full', n, nrhs, b, lda, work, lda )
564 CALL csyt02( uplo, n, nrhs, a, lda, x, lda, work,
565 $ lda, rwork( 2*nrhs+1 ), result( 2 ) )
566
567
568
569 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
570 $ result( 3 ) )
571
572
573
574 CALL cpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
575 $ xact, lda, rwork, rwork( nrhs+1 ),
576 $ result( 4 ) )
577 ELSE
578 k1 = 6
579 END IF
580
581
582
583
584 result( 6 ) =
sget06( rcond, rcondc )
585
586
587
588
589 DO 140 k = k1, 6
590 IF( result( k ).GE.thresh ) THEN
591 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
592 $
CALL aladhd( nout, path )
593 WRITE( nout, fmt = 9998 )'CSYSVX', fact, uplo,
594 $ n, imat, k, result( k )
595 nfail = nfail + 1
596 END IF
597 140 CONTINUE
598 nrun = nrun + 7 - k1
599
600
601
602
603
604 IF( ifact.EQ.2 )
605 $
CALL claset( uplo, n, n, cmplx( zero ),
606 $ cmplx( zero ), afac, lda )
607 CALL claset(
'Full', n, nrhs, cmplx( zero ),
608 $ cmplx( zero ), x, lda )
609
610
611
612
613 srnamt = 'CSYSVXX'
614 n_err_bnds = 3
615 equed = 'N'
616 CALL csysvxx( fact, uplo, n, nrhs, a, lda, afac,
617 $ lda, iwork, equed, work( n+1 ), b, lda, x,
618 $ lda, rcond, rpvgrw_svxx, berr, n_err_bnds,
619 $ errbnds_n, errbnds_c, 0, zero, work,
620 $ rwork, info )
621
622
623
624
625 k = izero
626 IF( k.GT.0 ) THEN
627 135 CONTINUE
628 IF( iwork( k ).LT.0 ) THEN
629 IF( iwork( k ).NE.-k ) THEN
630 k = -iwork( k )
631 GO TO 135
632 END IF
633 ELSE IF( iwork( k ).NE.k ) THEN
634 k = iwork( k )
635 GO TO 135
636 END IF
637 END IF
638
639
640
641 IF( info.NE.k .AND. info.LE.n ) THEN
642 CALL alaerh( path,
'CSYSVXX', info, k,
643 $ fact // uplo, n, n, -1, -1, nrhs, imat, nfail,
644 $ nerrs, nout )
645 GO TO 150
646 END IF
647
648 IF( info.EQ.0 ) THEN
649 IF( ifact.GE.2 ) THEN
650
651
652
653
654 CALL csyt01( uplo, n, a, lda, afac, lda, iwork,
655 $ ainv, lda, rwork(2*nrhs+1),
656 $ result( 1 ) )
657 k1 = 1
658 ELSE
659 k1 = 2
660 END IF
661
662
663
664 CALL clacpy(
'Full', n, nrhs, b, lda, work, lda )
665 CALL csyt02( uplo, n, nrhs, a, lda, x, lda, work,
666 $ lda, rwork( 2*nrhs+1 ), result( 2 ) )
667 result( 2 ) = 0.0
668
669
670
671 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
672 $ result( 3 ) )
673
674
675
676 CALL cpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
677 $ xact, lda, rwork, rwork( nrhs+1 ),
678 $ result( 4 ) )
679 ELSE
680 k1 = 6
681 END IF
682
683
684
685
686 result( 6 ) =
sget06( rcond, rcondc )
687
688
689
690
691 DO 85 k = k1, 6
692 IF( result( k ).GE.thresh ) THEN
693 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
694 $
CALL aladhd( nout, path )
695 WRITE( nout, fmt = 9998 )'CSYSVXX',
696 $ fact, uplo, n, imat, k,
697 $ result( k )
698 nfail = nfail + 1
699 END IF
700 85 CONTINUE
701 nrun = nrun + 7 - k1
702
703 150 CONTINUE
704
705 160 CONTINUE
706 170 CONTINUE
707 180 CONTINUE
708
709
710
711 CALL alasvm( path, nout, nfail, nrun, nerrs )
712
713
714
715
717
718 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
719 $ ', test ', i2, ', ratio =', g12.5 )
720 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N =', i5,
721 $ ', type ', i2, ', test ', i2, ', ratio =', g12.5 )
722 RETURN
723
724
725
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
subroutine clarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
CLARHS
subroutine xlaenv(ispec, nvalue)
XLAENV
subroutine aladhd(iounit, path)
ALADHD
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
subroutine cebchvxx(thresh, path)
CEBCHVXX
subroutine cerrvx(path, nunit)
CERRVX
subroutine cget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
CGET04
subroutine clatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
CLATB4
subroutine clatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
CLATMS
subroutine clatsy(uplo, n, x, ldx, iseed)
CLATSY
subroutine cpot05(uplo, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
CPOT05
subroutine csyt01(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
CSYT01
subroutine csyt02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
CSYT02
subroutine csysv(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
CSYSV computes the solution to system of linear equations A * X = B for SY matrices
subroutine csysvx(fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, lwork, rwork, info)
CSYSVX computes the solution to system of linear equations A * X = B for SY matrices
subroutine csysvxx(fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, equed, s, b, ldb, x, ldx, rcond, rpvgrw, berr, n_err_bnds, err_bnds_norm, err_bnds_comp, nparams, params, work, rwork, info)
CSYSVXX computes the solution to system of linear equations A * X = B for SY matrices
subroutine csytrf(uplo, n, a, lda, ipiv, work, lwork, info)
CSYTRF
subroutine csytri2(uplo, n, a, lda, ipiv, work, lwork, info)
CSYTRI2
subroutine clacpy(uplo, m, n, a, lda, b, ldb)
CLACPY copies all or part of one two-dimensional array to another.
real function clansy(norm, uplo, n, a, lda, work)
CLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
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.
real function sget06(rcond, rcondc)
SGET06