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 = 10, 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 CLANHE, 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 ) = 'C'
233 path( 2: 3 ) = 'HE'
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
284
285
286 CALL clatb4( path, imat, n, n,
TYPE, KL, KU, ANORM, MODE,
287 $ CNDNUM, DIST )
288
289 srnamt = 'CLATMS'
290 CALL clatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
291 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
292 $ INFO )
293
294
295
296 IF( info.NE.0 ) THEN
297 CALL alaerh( path,
'CLATMS', info, 0, uplo, n, n, -1,
298 $ -1, -1, imat, nfail, nerrs, nout )
299 GO TO 160
300 END IF
301
302
303
304
305 IF( zerot ) THEN
306 IF( imat.EQ.3 ) THEN
307 izero = 1
308 ELSE IF( imat.EQ.4 ) THEN
309 izero = n
310 ELSE
311 izero = n / 2 + 1
312 END IF
313
314 IF( imat.LT.6 ) THEN
315
316
317
318 IF( iuplo.EQ.1 ) THEN
319 ioff = ( izero-1 )*lda
320 DO 20 i = 1, izero - 1
321 a( ioff+i ) = zero
322 20 CONTINUE
323 ioff = ioff + izero
324 DO 30 i = izero, n
325 a( ioff ) = zero
326 ioff = ioff + lda
327 30 CONTINUE
328 ELSE
329 ioff = izero
330 DO 40 i = 1, izero - 1
331 a( ioff ) = zero
332 ioff = ioff + lda
333 40 CONTINUE
334 ioff = ioff - izero
335 DO 50 i = izero, n
336 a( ioff+i ) = zero
337 50 CONTINUE
338 END IF
339 ELSE
340 ioff = 0
341 IF( iuplo.EQ.1 ) THEN
342
343
344
345 DO 70 j = 1, n
346 i2 = min( j, izero )
347 DO 60 i = 1, i2
348 a( ioff+i ) = zero
349 60 CONTINUE
350 ioff = ioff + lda
351 70 CONTINUE
352 ELSE
353
354
355
356 DO 90 j = 1, n
357 i1 = max( j, izero )
358 DO 80 i = i1, n
359 a( ioff+i ) = zero
360 80 CONTINUE
361 ioff = ioff + lda
362 90 CONTINUE
363 END IF
364 END IF
365 ELSE
366 izero = 0
367 END IF
368
369
370
371 CALL claipd( n, a, lda+1, 0 )
372
373 DO 150 ifact = 1, nfact
374
375
376
377 fact = facts( ifact )
378
379
380
381
382 IF( zerot ) THEN
383 IF( ifact.EQ.1 )
384 $ GO TO 150
385 rcondc = zero
386
387 ELSE IF( ifact.EQ.1 ) THEN
388
389
390
391 anorm =
clanhe(
'1', uplo, n, a, lda, rwork )
392
393
394
395 CALL clacpy( uplo, n, n, a, lda, afac, lda )
396 CALL chetrf( uplo, n, afac, lda, iwork, work,
397 $ lwork, info )
398
399
400
401 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
402 lwork = (n+nb+1)*(nb+3)
403 CALL chetri2( uplo, n, ainv, lda, iwork, work,
404 $ lwork, info )
405 ainvnm =
clanhe(
'1', uplo, n, ainv, lda, rwork )
406
407
408
409 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
410 rcondc = one
411 ELSE
412 rcondc = ( one / anorm ) / ainvnm
413 END IF
414 END IF
415
416
417
418 srnamt = 'CLARHS'
419 CALL clarhs( path, xtype, uplo,
' ', n, n, kl, ku,
420 $ nrhs, a, lda, xact, lda, b, lda, iseed,
421 $ info )
422 xtype = 'C'
423
424
425
426 IF( ifact.EQ.2 ) THEN
427 CALL clacpy( uplo, n, n, a, lda, afac, lda )
428 CALL clacpy(
'Full', n, nrhs, b, lda, x, lda )
429
430
431
432 srnamt = 'CHESV '
433 CALL chesv( uplo, n, nrhs, afac, lda, iwork, x,
434 $ lda, work, lwork, info )
435
436
437
438
439 k = izero
440 IF( k.GT.0 ) THEN
441 100 CONTINUE
442 IF( iwork( k ).LT.0 ) THEN
443 IF( iwork( k ).NE.-k ) THEN
444 k = -iwork( k )
445 GO TO 100
446 END IF
447 ELSE IF( iwork( k ).NE.k ) THEN
448 k = iwork( k )
449 GO TO 100
450 END IF
451 END IF
452
453
454
455 IF( info.NE.k ) THEN
456 CALL alaerh( path,
'CHESV ', info, k, uplo, n,
457 $ n, -1, -1, nrhs, imat, nfail,
458 $ nerrs, nout )
459 GO TO 120
460 ELSE IF( info.NE.0 ) THEN
461 GO TO 120
462 END IF
463
464
465
466
467 CALL chet01( uplo, n, a, lda, afac, lda, iwork,
468 $ ainv, lda, rwork, result( 1 ) )
469
470
471
472 CALL clacpy(
'Full', n, nrhs, b, lda, work, lda )
473 CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
474 $ lda, rwork, result( 2 ) )
475
476
477
478 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
479 $ result( 3 ) )
480 nt = 3
481
482
483
484
485 DO 110 k = 1, nt
486 IF( result( k ).GE.thresh ) THEN
487 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
488 $
CALL aladhd( nout, path )
489 WRITE( nout, fmt = 9999 )'CHESV ', uplo, n,
490 $ imat, k, result( k )
491 nfail = nfail + 1
492 END IF
493 110 CONTINUE
494 nrun = nrun + nt
495 120 CONTINUE
496 END IF
497
498
499
500 IF( ifact.EQ.2 )
501 $
CALL claset( uplo, n, n, cmplx( zero ),
502 $ cmplx( zero ), afac, lda )
503 CALL claset(
'Full', n, nrhs, cmplx( zero ),
504 $ cmplx( zero ), x, lda )
505
506
507
508
509 srnamt = 'CHESVX'
510 CALL chesvx( fact, uplo, n, nrhs, a, lda, afac, lda,
511 $ iwork, b, lda, x, lda, rcond, rwork,
512 $ rwork( nrhs+1 ), work, lwork,
513 $ rwork( 2*nrhs+1 ), info )
514
515
516
517
518 k = izero
519 IF( k.GT.0 ) THEN
520 130 CONTINUE
521 IF( iwork( k ).LT.0 ) THEN
522 IF( iwork( k ).NE.-k ) THEN
523 k = -iwork( k )
524 GO TO 130
525 END IF
526 ELSE IF( iwork( k ).NE.k ) THEN
527 k = iwork( k )
528 GO TO 130
529 END IF
530 END IF
531
532
533
534 IF( info.NE.k ) THEN
535 CALL alaerh( path,
'CHESVX', info, k, fact // uplo,
536 $ n, n, -1, -1, nrhs, imat, nfail,
537 $ nerrs, nout )
538 GO TO 150
539 END IF
540
541 IF( info.EQ.0 ) THEN
542 IF( ifact.GE.2 ) THEN
543
544
545
546
547 CALL chet01( uplo, n, a, lda, afac, lda, iwork,
548 $ ainv, lda, rwork( 2*nrhs+1 ),
549 $ result( 1 ) )
550 k1 = 1
551 ELSE
552 k1 = 2
553 END IF
554
555
556
557 CALL clacpy(
'Full', n, nrhs, b, lda, work, lda )
558 CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
559 $ lda, rwork( 2*nrhs+1 ), result( 2 ) )
560
561
562
563 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
564 $ result( 3 ) )
565
566
567
568 CALL cpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
569 $ xact, lda, rwork, rwork( nrhs+1 ),
570 $ result( 4 ) )
571 ELSE
572 k1 = 6
573 END IF
574
575
576
577
578 result( 6 ) =
sget06( rcond, rcondc )
579
580
581
582
583 DO 140 k = k1, 6
584 IF( result( k ).GE.thresh ) THEN
585 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
586 $
CALL aladhd( nout, path )
587 WRITE( nout, fmt = 9998 )'CHESVX', fact, uplo,
588 $ n, imat, k, result( k )
589 nfail = nfail + 1
590 END IF
591 140 CONTINUE
592 nrun = nrun + 7 - k1
593
594
595
596
597
598 IF( ifact.EQ.2 )
599 $
CALL claset( uplo, n, n, cmplx( zero ),
600 $ cmplx( zero ), afac, lda )
601 CALL claset(
'Full', n, nrhs, cmplx( zero ),
602 $ cmplx( zero ), x, lda )
603
604
605
606
607 srnamt = 'CHESVXX'
608 n_err_bnds = 3
609 equed = 'N'
610 CALL chesvxx( fact, uplo, n, nrhs, a, lda, afac,
611 $ lda, iwork, equed, work( n+1 ), b, lda, x,
612 $ lda, rcond, rpvgrw_svxx, berr, n_err_bnds,
613 $ errbnds_n, errbnds_c, 0, zero, work,
614 $ rwork(2*nrhs+1), info )
615
616
617
618
619 k = izero
620 IF( k.GT.0 ) THEN
621 135 CONTINUE
622 IF( iwork( k ).LT.0 ) THEN
623 IF( iwork( k ).NE.-k ) THEN
624 k = -iwork( k )
625 GO TO 135
626 END IF
627 ELSE IF( iwork( k ).NE.k ) THEN
628 k = iwork( k )
629 GO TO 135
630 END IF
631 END IF
632
633
634
635 IF( info.NE.k .AND. info.LE.n ) THEN
636 CALL alaerh( path,
'CHESVXX', info, k,
637 $ fact // uplo, n, n, -1, -1, nrhs, imat, nfail,
638 $ nerrs, nout )
639 GO TO 150
640 END IF
641
642 IF( info.EQ.0 ) THEN
643 IF( ifact.GE.2 ) THEN
644
645
646
647
648 CALL chet01( uplo, n, a, lda, afac, lda, iwork,
649 $ ainv, lda, rwork(2*nrhs+1),
650 $ result( 1 ) )
651 k1 = 1
652 ELSE
653 k1 = 2
654 END IF
655
656
657
658 CALL clacpy(
'Full', n, nrhs, b, lda, work, lda )
659 CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
660 $ lda, rwork( 2*nrhs+1 ), result( 2 ) )
661 result( 2 ) = 0.0
662
663
664
665 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
666 $ result( 3 ) )
667
668
669
670 CALL cpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
671 $ xact, lda, rwork, rwork( nrhs+1 ),
672 $ result( 4 ) )
673 ELSE
674 k1 = 6
675 END IF
676
677
678
679
680 result( 6 ) =
sget06( rcond, rcondc )
681
682
683
684
685 DO 85 k = k1, 6
686 IF( result( k ).GE.thresh ) THEN
687 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
688 $
CALL aladhd( nout, path )
689 WRITE( nout, fmt = 9998 )'CHESVXX',
690 $ fact, uplo, n, imat, k,
691 $ result( k )
692 nfail = nfail + 1
693 END IF
694 85 CONTINUE
695 nrun = nrun + 7 - k1
696
697 150 CONTINUE
698
699 160 CONTINUE
700 170 CONTINUE
701 180 CONTINUE
702
703
704
705 CALL alasvm( path, nout, nfail, nrun, nerrs )
706
707
708
709
711
712 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
713 $ ', test ', i2, ', ratio =', g12.5 )
714 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N =', i5,
715 $ ', type ', i2, ', test ', i2, ', ratio =', g12.5 )
716 RETURN
717
718
719
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 chet01(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
CHET01
subroutine claipd(n, a, inda, vinda)
CLAIPD
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 cpot02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
CPOT02
subroutine cpot05(uplo, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
CPOT05
subroutine chesv(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
CHESV computes the solution to system of linear equations A * X = B for HE matrices
subroutine chesvx(fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, lwork, rwork, info)
CHESVX computes the solution to system of linear equations A * X = B for HE matrices
subroutine chesvxx(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)
CHESVXX computes the solution to system of linear equations A * X = B for HE matrices
subroutine chetrf(uplo, n, a, lda, ipiv, work, lwork, info)
CHETRF
subroutine chetri2(uplo, n, a, lda, ipiv, work, lwork, info)
CHETRI2
subroutine clacpy(uplo, m, n, a, lda, b, ldb)
CLACPY copies all or part of one two-dimensional array to another.
real function clanhe(norm, uplo, n, a, lda, work)
CLANHE 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