157
158
159
160
161
162
163 LOGICAL TSTERR
164 INTEGER NMAX, NN, NOUT, NRHS
165 DOUBLE PRECISION THRESH
166
167
168 LOGICAL DOTYPE( * )
169 INTEGER IWORK( * ), NVAL( * )
170 DOUBLE PRECISION RWORK( * )
171 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
172 $ WORK( * ), X( * ), XACT( * )
173
174
175
176
177
178 DOUBLE PRECISION ONE, ZERO
179 parameter( one = 1.0d+0, zero = 0.0d+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 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC,
194 $ RPVGRW_SVXX
195
196
197 CHARACTER FACTS( NFACT ), UPLOS( 2 )
198 INTEGER ISEED( 4 ), ISEEDY( 4 )
199 DOUBLE PRECISION RESULT( NTESTS ), BERR( NRHS ),
200 $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 )
201
202
203 DOUBLE PRECISION DGET06, ZLANHE
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 dcmplx, 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 ) = 'Z'
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 zerrvx( 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 zlatb4( path, imat, n, n,
TYPE, KL, KU, ANORM, MODE,
287 $ CNDNUM, DIST )
288
289 srnamt = 'ZLATMS'
290 CALL zlatms( 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,
'ZLATMS', 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 zlaipd( 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 =
zlanhe(
'1', uplo, n, a, lda, rwork )
392
393
394
395 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
396 CALL zhetrf( uplo, n, afac, lda, iwork, work,
397 $ lwork, info )
398
399
400
401 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
402 lwork = (n+nb+1)*(nb+3)
403 CALL zhetri2( uplo, n, ainv, lda, iwork, work,
404 $ lwork, info )
405 ainvnm =
zlanhe(
'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 = 'ZLARHS'
419 CALL zlarhs( 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 zlacpy( uplo, n, n, a, lda, afac, lda )
428 CALL zlacpy(
'Full', n, nrhs, b, lda, x, lda )
429
430
431
432 srnamt = 'ZHESV '
433 CALL zhesv( 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,
'ZHESV ', 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 zhet01( uplo, n, a, lda, afac, lda, iwork,
468 $ ainv, lda, rwork, result( 1 ) )
469
470
471
472 CALL zlacpy(
'Full', n, nrhs, b, lda, work, lda )
473 CALL zpot02( uplo, n, nrhs, a, lda, x, lda, work,
474 $ lda, rwork, result( 2 ) )
475
476
477
478 CALL zget04( 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 )'ZHESV ', 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 zlaset( uplo, n, n, dcmplx( zero ),
502 $ dcmplx( zero ), afac, lda )
503 CALL zlaset(
'Full', n, nrhs, dcmplx( zero ),
504 $ dcmplx( zero ), x, lda )
505
506
507
508
509 srnamt = 'ZHESVX'
510 CALL zhesvx( 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,
'ZHESVX', 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 zhet01( 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 zlacpy(
'Full', n, nrhs, b, lda, work, lda )
558 CALL zpot02( uplo, n, nrhs, a, lda, x, lda, work,
559 $ lda, rwork( 2*nrhs+1 ), result( 2 ) )
560
561
562
563 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
564 $ result( 3 ) )
565
566
567
568 CALL zpot05( 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 ) =
dget06( 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 )'ZHESVX', 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 zlaset( uplo, n, n, dcmplx( zero ),
600 $ dcmplx( zero ), afac, lda )
601 CALL zlaset(
'Full', n, nrhs, dcmplx( zero ),
602 $ dcmplx( zero ), x, lda )
603
604
605
606
607 srnamt = 'ZHESVXX'
608 n_err_bnds = 3
609 equed = 'N'
610 CALL zhesvxx( 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,
'ZHESVXX', 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 zhet01( 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 zlacpy(
'Full', n, nrhs, b, lda, work, lda )
659 CALL zpot02( 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 zget04( n, nrhs, x, lda, xact, lda, rcondc,
666 $ result( 3 ) )
667
668
669
670 CALL zpot05( 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 ) =
dget06( 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 )'ZHESVXX',
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 xlaenv(ispec, nvalue)
XLAENV
subroutine zlarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
ZLARHS
subroutine aladhd(iounit, path)
ALADHD
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
double precision function dget06(rcond, rcondc)
DGET06
subroutine zhesv(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
ZHESV computes the solution to system of linear equations A * X = B for HE matrices
subroutine zhesvx(fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, lwork, rwork, info)
ZHESVX computes the solution to system of linear equations A * X = B for HE matrices
subroutine zhesvxx(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)
ZHESVXX computes the solution to system of linear equations A * X = B for HE matrices
subroutine zhetrf(uplo, n, a, lda, ipiv, work, lwork, info)
ZHETRF
subroutine zhetri2(uplo, n, a, lda, ipiv, work, lwork, info)
ZHETRI2
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
double precision function zlanhe(norm, uplo, n, a, lda, work)
ZLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
subroutine zlaset(uplo, m, n, alpha, beta, a, lda)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
subroutine zebchvxx(thresh, path)
ZEBCHVXX
subroutine zerrvx(path, nunit)
ZERRVX
subroutine zget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
ZGET04
subroutine zhet01(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
ZHET01
subroutine zlaipd(n, a, inda, vinda)
ZLAIPD
subroutine zlatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
ZLATB4
subroutine zlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
ZLATMS
subroutine zpot02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
ZPOT02
subroutine zpot05(uplo, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
ZPOT05