162
163
164
165
166
167
168 LOGICAL TSTERR
169 INTEGER NMAX, NN, NOUT, NRHS
170 DOUBLE PRECISION THRESH
171
172
173 LOGICAL DOTYPE( * )
174 INTEGER NVAL( * )
175 DOUBLE PRECISION RWORK( * ), S( * )
176 COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ),
177 $ BSAV( * ), WORK( * ), X( * ), XACT( * )
178
179
180
181
182
183 DOUBLE PRECISION ONE, ZERO
184 parameter( one = 1.0d+0, zero = 0.0d+0 )
185 INTEGER NTYPES
186 parameter( ntypes = 9 )
187 INTEGER NTESTS
188 parameter( ntests = 6 )
189
190
191 LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
192 CHARACTER DIST, EQUED, FACT, TYPE, UPLO, XTYPE
193 CHARACTER*3 PATH
194 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
195 $ IZERO, K, K1, KL, KU, LDA, MODE, N, NB, NBMIN,
196 $ NERRS, NFACT, NFAIL, NIMAT, NRUN, NT,
197 $ N_ERR_BNDS
198 DOUBLE PRECISION AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
199 $ ROLDC, SCOND, RPVGRW_SVXX
200
201
202 CHARACTER EQUEDS( 2 ), FACTS( 3 ), UPLOS( 2 )
203 INTEGER ISEED( 4 ), ISEEDY( 4 )
204 DOUBLE PRECISION RESULT( NTESTS ), BERR( NRHS ),
205 $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 )
206
207
208 LOGICAL LSAME
209 DOUBLE PRECISION DGET06, ZLANHE
211
212
217
218
219 LOGICAL LERR, OK
220 CHARACTER*32 SRNAMT
221 INTEGER INFOT, NUNIT
222
223
224 COMMON / infoc / infot, nunit, ok, lerr
225 COMMON / srnamc / srnamt
226
227
228 INTRINSIC dcmplx, max
229
230
231 DATA iseedy / 1988, 1989, 1990, 1991 /
232 DATA uplos / 'U', 'L' /
233 DATA facts / 'F', 'N', 'E' /
234 DATA equeds / 'N', 'Y' /
235
236
237
238
239
240 path( 1: 1 ) = 'Zomplex precision'
241 path( 2: 3 ) = 'PO'
242 nrun = 0
243 nfail = 0
244 nerrs = 0
245 DO 10 i = 1, 4
246 iseed( i ) = iseedy( i )
247 10 CONTINUE
248
249
250
251 IF( tsterr )
252 $
CALL zerrvx( path, nout )
253 infot = 0
254
255
256
257 nb = 1
258 nbmin = 2
261
262
263
264 DO 130 in = 1, nn
265 n = nval( in )
266 lda = max( n, 1 )
267 xtype = 'N'
268 nimat = ntypes
269 IF( n.LE.0 )
270 $ nimat = 1
271
272 DO 120 imat = 1, nimat
273
274
275
276 IF( .NOT.dotype( imat ) )
277 $ GO TO 120
278
279
280
281 zerot = imat.GE.3 .AND. imat.LE.5
282 IF( zerot .AND. n.LT.imat-2 )
283 $ GO TO 120
284
285
286
287 DO 110 iuplo = 1, 2
288 uplo = uplos( iuplo )
289
290
291
292
293 CALL zlatb4( path, imat, n, n,
TYPE, KL, KU, ANORM, MODE,
294 $ CNDNUM, DIST )
295
296 srnamt = 'ZLATMS'
297 CALL zlatms( n, n, dist, iseed,
TYPE, RWORK, MODE,
298 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
299 $ INFO )
300
301
302
303 IF( info.NE.0 ) THEN
304 CALL alaerh( path,
'ZLATMS', info, 0, uplo, n, n, -1,
305 $ -1, -1, imat, nfail, nerrs, nout )
306 GO TO 110
307 END IF
308
309
310
311
312 IF( zerot ) THEN
313 IF( imat.EQ.3 ) THEN
314 izero = 1
315 ELSE IF( imat.EQ.4 ) THEN
316 izero = n
317 ELSE
318 izero = n / 2 + 1
319 END IF
320 ioff = ( izero-1 )*lda
321
322
323
324 IF( iuplo.EQ.1 ) THEN
325 DO 20 i = 1, izero - 1
326 a( ioff+i ) = zero
327 20 CONTINUE
328 ioff = ioff + izero
329 DO 30 i = izero, n
330 a( ioff ) = zero
331 ioff = ioff + lda
332 30 CONTINUE
333 ELSE
334 ioff = izero
335 DO 40 i = 1, izero - 1
336 a( ioff ) = zero
337 ioff = ioff + lda
338 40 CONTINUE
339 ioff = ioff - izero
340 DO 50 i = izero, n
341 a( ioff+i ) = zero
342 50 CONTINUE
343 END IF
344 ELSE
345 izero = 0
346 END IF
347
348
349
350 CALL zlaipd( n, a, lda+1, 0 )
351
352
353
354 CALL zlacpy( uplo, n, n, a, lda, asav, lda )
355
356 DO 100 iequed = 1, 2
357 equed = equeds( iequed )
358 IF( iequed.EQ.1 ) THEN
359 nfact = 3
360 ELSE
361 nfact = 1
362 END IF
363
364 DO 90 ifact = 1, nfact
365 fact = facts( ifact )
366 prefac =
lsame( fact,
'F' )
367 nofact =
lsame( fact,
'N' )
368 equil =
lsame( fact,
'E' )
369
370 IF( zerot ) THEN
371 IF( prefac )
372 $ GO TO 90
373 rcondc = zero
374
375 ELSE IF( .NOT.
lsame( fact,
'N' ) )
THEN
376
377
378
379
380
381
382 CALL zlacpy( uplo, n, n, asav, lda, afac, lda )
383 IF( equil .OR. iequed.GT.1 ) THEN
384
385
386
387
388 CALL zpoequ( n, afac, lda, s, scond, amax,
389 $ info )
390 IF( info.EQ.0 .AND. n.GT.0 ) THEN
391 IF( iequed.GT.1 )
392 $ scond = zero
393
394
395
396 CALL zlaqhe( uplo, n, afac, lda, s, scond,
397 $ amax, equed )
398 END IF
399 END IF
400
401
402
403
404 IF( equil )
405 $ roldc = rcondc
406
407
408
409 anorm =
zlanhe(
'1', uplo, n, afac, lda, rwork )
410
411
412
413 CALL zpotrf( uplo, n, afac, lda, info )
414
415
416
417 CALL zlacpy( uplo, n, n, afac, lda, a, lda )
418 CALL zpotri( uplo, n, a, lda, info )
419
420
421
422 ainvnm =
zlanhe(
'1', uplo, n, a, lda, rwork )
423 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
424 rcondc = one
425 ELSE
426 rcondc = ( one / anorm ) / ainvnm
427 END IF
428 END IF
429
430
431
432 CALL zlacpy( uplo, n, n, asav, lda, a, lda )
433
434
435
436 srnamt = 'ZLARHS'
437 CALL zlarhs( path, xtype, uplo,
' ', n, n, kl, ku,
438 $ nrhs, a, lda, xact, lda, b, lda,
439 $ iseed, info )
440 xtype = 'C'
441 CALL zlacpy(
'Full', n, nrhs, b, lda, bsav, lda )
442
443 IF( nofact ) THEN
444
445
446
447
448
449
450 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
451 CALL zlacpy(
'Full', n, nrhs, b, lda, x, lda )
452
453 srnamt = 'ZPOSV '
454 CALL zposv( uplo, n, nrhs, afac, lda, x, lda,
455 $ info )
456
457
458
459 IF( info.NE.izero ) THEN
460 CALL alaerh( path,
'ZPOSV ', info, izero,
461 $ uplo, n, n, -1, -1, nrhs, imat,
462 $ nfail, nerrs, nout )
463 GO TO 70
464 ELSE IF( info.NE.0 ) THEN
465 GO TO 70
466 END IF
467
468
469
470
471 CALL zpot01( uplo, n, a, lda, afac, lda, rwork,
472 $ result( 1 ) )
473
474
475
476 CALL zlacpy(
'Full', n, nrhs, b, lda, work,
477 $ lda )
478 CALL zpot02( uplo, n, nrhs, a, lda, x, lda,
479 $ work, lda, rwork, result( 2 ) )
480
481
482
483 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
484 $ result( 3 ) )
485 nt = 3
486
487
488
489
490 DO 60 k = 1, nt
491 IF( result( k ).GE.thresh ) THEN
492 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
493 $
CALL aladhd( nout, path )
494 WRITE( nout, fmt = 9999 )'ZPOSV ', uplo,
495 $ n, imat, k, result( k )
496 nfail = nfail + 1
497 END IF
498 60 CONTINUE
499 nrun = nrun + nt
500 70 CONTINUE
501 END IF
502
503
504
505 IF( .NOT.prefac )
506 $
CALL zlaset( uplo, n, n, dcmplx( zero ),
507 $ dcmplx( zero ), afac, lda )
508 CALL zlaset(
'Full', n, nrhs, dcmplx( zero ),
509 $ dcmplx( zero ), x, lda )
510 IF( iequed.GT.1 .AND. n.GT.0 ) THEN
511
512
513
514
515 CALL zlaqhe( uplo, n, a, lda, s, scond, amax,
516 $ equed )
517 END IF
518
519
520
521
522 srnamt = 'ZPOSVX'
523 CALL zposvx( fact, uplo, n, nrhs, a, lda, afac,
524 $ lda, equed, s, b, lda, x, lda, rcond,
525 $ rwork, rwork( nrhs+1 ), work,
526 $ rwork( 2*nrhs+1 ), info )
527
528
529
530 IF( info.NE.izero ) THEN
531 CALL alaerh( path,
'ZPOSVX', info, izero,
532 $ fact // uplo, n, n, -1, -1, nrhs,
533 $ imat, nfail, nerrs, nout )
534 GO TO 90
535 END IF
536
537 IF( info.EQ.0 ) THEN
538 IF( .NOT.prefac ) THEN
539
540
541
542
543 CALL zpot01( uplo, n, a, lda, afac, lda,
544 $ rwork( 2*nrhs+1 ), result( 1 ) )
545 k1 = 1
546 ELSE
547 k1 = 2
548 END IF
549
550
551
552 CALL zlacpy(
'Full', n, nrhs, bsav, lda, work,
553 $ lda )
554 CALL zpot02( uplo, n, nrhs, asav, lda, x, lda,
555 $ work, lda, rwork( 2*nrhs+1 ),
556 $ result( 2 ) )
557
558
559
560 IF( nofact .OR. ( prefac .AND.
lsame( equed,
561 $ 'N' ) ) ) THEN
562 CALL zget04( n, nrhs, x, lda, xact, lda,
563 $ rcondc, result( 3 ) )
564 ELSE
565 CALL zget04( n, nrhs, x, lda, xact, lda,
566 $ roldc, result( 3 ) )
567 END IF
568
569
570
571
572 CALL zpot05( uplo, n, nrhs, asav, lda, b, lda,
573 $ x, lda, xact, lda, rwork,
574 $ rwork( nrhs+1 ), result( 4 ) )
575 ELSE
576 k1 = 6
577 END IF
578
579
580
581
582 result( 6 ) =
dget06( rcond, rcondc )
583
584
585
586
587 DO 80 k = k1, 6
588 IF( result( k ).GE.thresh ) THEN
589 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
590 $
CALL aladhd( nout, path )
591 IF( prefac ) THEN
592 WRITE( nout, fmt = 9997 )'ZPOSVX', fact,
593 $ uplo, n, equed, imat, k, result( k )
594 ELSE
595 WRITE( nout, fmt = 9998 )'ZPOSVX', fact,
596 $ uplo, n, imat, k, result( k )
597 END IF
598 nfail = nfail + 1
599 END IF
600 80 CONTINUE
601 nrun = nrun + 7 - k1
602
603
604
605
606
607 CALL zlacpy(
'Full', n, n, asav, lda, a, lda )
608 CALL zlacpy(
'Full', n, nrhs, bsav, lda, b, lda )
609
610 IF( .NOT.prefac )
611 $
CALL zlaset( uplo, n, n, dcmplx( zero ),
612 $ dcmplx( zero ), afac, lda )
613 CALL zlaset(
'Full', n, nrhs, dcmplx( zero ),
614 $ dcmplx( zero ), x, lda )
615 IF( iequed.GT.1 .AND. n.GT.0 ) THEN
616
617
618
619
620 CALL zlaqhe( uplo, n, a, lda, s, scond, amax,
621 $ equed )
622 END IF
623
624
625
626
627 srnamt = 'ZPOSVXX'
628 n_err_bnds = 3
629 CALL zposvxx( fact, uplo, n, nrhs, a, lda, afac,
630 $ lda, equed, s, b, lda, x,
631 $ lda, rcond, rpvgrw_svxx, berr, n_err_bnds,
632 $ errbnds_n, errbnds_c, 0, zero, work,
633 $ rwork( 2*nrhs+1 ), info )
634
635
636
637 IF( info.EQ.n+1 ) GOTO 90
638 IF( info.NE.izero ) THEN
639 CALL alaerh( path,
'ZPOSVXX', info, izero,
640 $ fact // uplo, n, n, -1, -1, nrhs,
641 $ imat, nfail, nerrs, nout )
642 GO TO 90
643 END IF
644
645 IF( info.EQ.0 ) THEN
646 IF( .NOT.prefac ) THEN
647
648
649
650
651 CALL zpot01( uplo, n, a, lda, afac, lda,
652 $ rwork( 2*nrhs+1 ), result( 1 ) )
653 k1 = 1
654 ELSE
655 k1 = 2
656 END IF
657
658
659
660 CALL zlacpy(
'Full', n, nrhs, bsav, lda, work,
661 $ lda )
662 CALL zpot02( uplo, n, nrhs, asav, lda, x, lda,
663 $ work, lda, rwork( 2*nrhs+1 ),
664 $ result( 2 ) )
665
666
667
668 IF( nofact .OR. ( prefac .AND.
lsame( equed,
669 $ 'N' ) ) ) THEN
670 CALL zget04( n, nrhs, x, lda, xact, lda,
671 $ rcondc, result( 3 ) )
672 ELSE
673 CALL zget04( n, nrhs, x, lda, xact, lda,
674 $ roldc, result( 3 ) )
675 END IF
676
677
678
679
680 CALL zpot05( uplo, n, nrhs, asav, lda, b, lda,
681 $ x, lda, xact, lda, rwork,
682 $ rwork( nrhs+1 ), result( 4 ) )
683 ELSE
684 k1 = 6
685 END IF
686
687
688
689
690 result( 6 ) =
dget06( rcond, rcondc )
691
692
693
694
695 DO 85 k = k1, 6
696 IF( result( k ).GE.thresh ) THEN
697 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
698 $
CALL aladhd( nout, path )
699 IF( prefac ) THEN
700 WRITE( nout, fmt = 9997 )'ZPOSVXX', fact,
701 $ uplo, n, equed, imat, k, result( k )
702 ELSE
703 WRITE( nout, fmt = 9998 )'ZPOSVXX', fact,
704 $ uplo, n, imat, k, result( k )
705 END IF
706 nfail = nfail + 1
707 END IF
708 85 CONTINUE
709 nrun = nrun + 7 - k1
710 90 CONTINUE
711 100 CONTINUE
712 110 CONTINUE
713 120 CONTINUE
714 130 CONTINUE
715
716
717
718 CALL alasvm( path, nout, nfail, nrun, nerrs )
719
720
721
722
724
725 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i1,
726 $ ', test(', i1, ')=', g12.5 )
727 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N=', i5,
728 $ ', type ', i1, ', test(', i1, ')=', g12.5 )
729 9997 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N=', i5,
730 $ ', EQUED=''', a1, ''', type ', i1, ', test(', i1, ') =',
731 $ g12.5 )
732 RETURN
733
734
735
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 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 zlaqhe(uplo, n, a, lda, s, scond, amax, equed)
ZLAQHE scales a Hermitian matrix.
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.
logical function lsame(ca, cb)
LSAME
subroutine zpoequ(n, a, lda, s, scond, amax, info)
ZPOEQU
subroutine zposv(uplo, n, nrhs, a, lda, b, ldb, info)
ZPOSV computes the solution to system of linear equations A * X = B for PO matrices
subroutine zposvx(fact, uplo, n, nrhs, a, lda, af, ldaf, equed, s, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
ZPOSVX computes the solution to system of linear equations A * X = B for PO matrices
subroutine zposvxx(fact, uplo, n, nrhs, a, lda, af, ldaf, equed, s, b, ldb, x, ldx, rcond, rpvgrw, berr, n_err_bnds, err_bnds_norm, err_bnds_comp, nparams, params, work, rwork, info)
ZPOSVXX computes the solution to system of linear equations A * X = B for PO matrices
subroutine zpotrf(uplo, n, a, lda, info)
ZPOTRF
subroutine zpotri(uplo, n, a, lda, info)
ZPOTRI
subroutine zebchvxx(thresh, path)
ZEBCHVXX
subroutine zerrvx(path, nunit)
ZERRVX
subroutine zget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
ZGET04
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 zpot01(uplo, n, a, lda, afac, ldafac, rwork, resid)
ZPOT01
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