OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
complex16
LAPACK Testing » Linear Solve

Functions

program zchkaa
 ZCHKAA
program zchkab
 ZCHKAB
subroutine zchkeq (thresh, nout)
 ZCHKEQ
subroutine zchkgb (dotype, nm, mval, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, a, la, afac, lafac, b, x, xact, work, rwork, iwork, nout)
 ZCHKGB
subroutine zchkge (dotype, nm, mval, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZCHKGE
subroutine zchkgt (dotype, nn, nval, nns, nsval, thresh, tsterr, a, af, b, x, xact, work, rwork, iwork, nout)
 ZCHKGT
subroutine zchkhe (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZCHKHE
subroutine zchkhe_aa (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZCHKHE_AA
subroutine zchkhe_aa_2stage (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZCHKHE_AA_2STAGE
subroutine zchkhe_rk (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, e, ainv, b, x, xact, work, rwork, iwork, nout)
 ZCHKHE_RK
subroutine zchkhe_rook (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZCHKHE_ROOK
subroutine zchkhp (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZCHKHP
subroutine zchklq (dotype, nm, mval, nn, nval, nnb, nbval, nxval, nrhs, thresh, tsterr, nmax, a, af, aq, al, ac, b, x, xact, tau, work, rwork, nout)
 ZCHKLQ
subroutine zchkpb (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, nout)
 ZCHKPB
subroutine zchkpo (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, nout)
 ZCHKPO
subroutine zchkpp (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, nout)
 ZCHKPP
subroutine zchkps (dotype, nn, nval, nnb, nbval, nrank, rankval, thresh, tsterr, nmax, a, afac, perm, piv, work, rwork, nout)
 ZCHKPS
subroutine zchkpt (dotype, nn, nval, nns, nsval, thresh, tsterr, a, d, e, b, x, xact, work, rwork, nout)
 ZCHKPT
subroutine zchkq3 (dotype, nm, mval, nn, nval, nnb, nbval, nxval, thresh, a, copya, s, tau, work, rwork, iwork, nout)
 ZCHKQ3
subroutine zchkql (dotype, nm, mval, nn, nval, nnb, nbval, nxval, nrhs, thresh, tsterr, nmax, a, af, aq, al, ac, b, x, xact, tau, work, rwork, nout)
 ZCHKQL
subroutine zchkqr (dotype, nm, mval, nn, nval, nnb, nbval, nxval, nrhs, thresh, tsterr, nmax, a, af, aq, ar, ac, b, x, xact, tau, work, rwork, iwork, nout)
 ZCHKQR
subroutine zchkqrt (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 ZCHKQRT
subroutine zchkqrtp (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 ZCHKQRTP
program zchkrfp
 ZCHKRFP
subroutine zchkrq (dotype, nm, mval, nn, nval, nnb, nbval, nxval, nrhs, thresh, tsterr, nmax, a, af, aq, ar, ac, b, x, xact, tau, work, rwork, iwork, nout)
 ZCHKRQ
subroutine zchksp (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZCHKSP
subroutine zchksy (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZCHKSY
subroutine zchksy_aa (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZCHKSY_AA
subroutine zchksy_aa_2stage (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZCHKSY_AA_2STAGE
subroutine zchksy_rk (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, e, ainv, b, x, xact, work, rwork, iwork, nout)
 ZCHKSY_RK
subroutine zchksy_rook (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZCHKSY_ROOK
subroutine zchktb (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, ab, ainv, b, x, xact, work, rwork, nout)
 ZCHKTB
subroutine zchktp (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, ap, ainvp, b, x, xact, work, rwork, nout)
 ZCHKTP
subroutine zchktr (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, ainv, b, x, xact, work, rwork, nout)
 ZCHKTR
subroutine zchktz (dotype, nm, mval, nn, nval, thresh, tsterr, a, copya, s, tau, work, rwork, nout)
 ZCHKTZ
subroutine zchkunhr_col (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 ZCHKUNHR_COL
subroutine zdrvab (dotype, nm, mval, nns, nsval, thresh, nmax, a, afac, b, x, work, rwork, swork, iwork, nout)
 ZDRVAB
subroutine zdrvac (dotype, nm, mval, nns, nsval, thresh, nmax, a, afac, b, x, work, rwork, swork, nout)
 ZDRVAC
subroutine zdrvgb (dotype, nn, nval, nrhs, thresh, tsterr, a, la, afb, lafb, asav, b, bsav, x, xact, s, work, rwork, iwork, nout)
 ZDRVGB
subroutine zdrvge (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, asav, b, bsav, x, xact, s, work, rwork, iwork, nout)
 ZDRVGE
subroutine zdrvgt (dotype, nn, nval, nrhs, thresh, tsterr, a, af, b, x, xact, work, rwork, iwork, nout)
 ZDRVGT
subroutine zdrvhe (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZDRVHE
subroutine zdrvhe_aa (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZDRVHE_AA
subroutine zdrvhe_aa_2stage (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZDRVHE_AA_2STAGE
subroutine zdrvhe_rk (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, e, ainv, b, x, xact, work, rwork, iwork, nout)
 ZDRVHE_RK
subroutine zdrvhe_rook (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZDRVHE_ROOK
subroutine zdrvhp (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZDRVHP
subroutine zdrvls (dotype, nm, mval, nn, nval, nns, nsval, nnb, nbval, nxval, thresh, tsterr, a, copya, b, copyb, c, s, copys, nout)
 ZDRVLS
subroutine zdrvpb (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, asav, b, bsav, x, xact, s, work, rwork, nout)
 ZDRVPB
subroutine zdrvpo (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, asav, b, bsav, x, xact, s, work, rwork, nout)
 ZDRVPO
subroutine zdrvpp (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, asav, b, bsav, x, xact, s, work, rwork, nout)
 ZDRVPP
subroutine zdrvpt (dotype, nn, nval, nrhs, thresh, tsterr, a, d, e, b, x, xact, work, rwork, nout)
 ZDRVPT
subroutine zdrvrf1 (nout, nn, nval, thresh, a, lda, arf, work)
 ZDRVRF1
subroutine zdrvrf2 (nout, nn, nval, a, lda, arf, ap, asav)
 ZDRVRF2
subroutine zdrvrf3 (nout, nn, nval, thresh, a, lda, arf, b1, b2, d_work_zlange, z_work_zgeqrf, tau)
 ZDRVRF3
subroutine zdrvrf4 (nout, nn, nval, thresh, c1, c2, ldc, crf, a, lda, d_work_zlange)
 ZDRVRF4
subroutine zdrvrfp (nout, nn, nval, nns, nsval, nnt, ntval, thresh, a, asav, afac, ainv, b, bsav, xact, x, arf, arfinv, z_work_zlatms, z_work_zpot02, z_work_zpot03, d_work_zlatms, d_work_zlanhe, d_work_zpot01, d_work_zpot02, d_work_zpot03)
 ZDRVRFP
subroutine zdrvsp (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZDRVSP
subroutine zdrvsy (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZDRVSY
subroutine zdrvsy_aa (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZDRVSY_AA
subroutine zdrvsy_aa_2stage (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZDRVSY_AA_2STAGE
subroutine zdrvsy_rk (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, e, ainv, b, x, xact, work, rwork, iwork, nout)
 ZDRVSY_RK
subroutine zdrvsy_rook (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 ZDRVSY_ROOK
subroutine zebchvxx (thresh, path)
 ZEBCHVXX
subroutine zerrab (nunit)
 ZERRAB
subroutine zerrac (nunit)
 ZERRAC
subroutine zerrge (path, nunit)
 ZERRGE
subroutine zerrgt (path, nunit)
 ZERRGT
subroutine zerrhe (path, nunit)
 ZERRHE
subroutine zerrlq (path, nunit)
 ZERRLQ
subroutine zerrls (path, nunit)
 ZERRLS
subroutine zerrpo (path, nunit)
 ZERRPO
subroutine zerrps (path, nunit)
 ZERRPS
subroutine zerrql (path, nunit)
 ZERRQL
subroutine zerrqp (path, nunit)
 ZERRQP
subroutine zerrqr (path, nunit)
 ZERRQR
subroutine zerrqrt (path, nunit)
 ZERRQRT
subroutine zerrqrtp (path, nunit)
 ZERRQRTP
subroutine zerrrfp (nunit)
 ZERRRFP
subroutine zerrrq (path, nunit)
 ZERRRQ
subroutine zerrsy (path, nunit)
 ZERRSY
subroutine zerrtr (path, nunit)
 ZERRTR
subroutine zerrtz (path, nunit)
 ZERRTZ
subroutine zerrunhr_col (path, nunit)
 ZERRUNHR_COL
subroutine zerrvx (path, nunit)
 ZERRVX
subroutine zgbt01 (m, n, kl, ku, a, lda, afac, ldafac, ipiv, work, resid)
 ZGBT01
subroutine zgbt02 (trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 ZGBT02
subroutine zgbt05 (trans, n, kl, ku, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 ZGBT05
subroutine zgelqs (m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
 ZGELQS
logical function zgennd (m, n, a, lda)
 ZGENND
subroutine zgeqls (m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
 ZGEQLS
subroutine zgeqrs (m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
 ZGEQRS
subroutine zgerqs (m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
 ZGERQS
subroutine zget01 (m, n, a, lda, afac, ldafac, ipiv, rwork, resid)
 ZGET01
subroutine zget02 (trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 ZGET02
subroutine zget03 (n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
 ZGET03
subroutine zget04 (n, nrhs, x, ldx, xact, ldxact, rcond, resid)
 ZGET04
subroutine zget07 (trans, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, chkferr, berr, reslts)
 ZGET07
subroutine zget08 (trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 ZGET08
subroutine zgtt01 (n, dl, d, du, dlf, df, duf, du2, ipiv, work, ldwork, rwork, resid)
 ZGTT01
subroutine zgtt02 (trans, n, nrhs, dl, d, du, x, ldx, b, ldb, resid)
 ZGTT02
subroutine zgtt05 (trans, n, nrhs, dl, d, du, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 ZGTT05
subroutine zhet01 (uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
 ZHET01
subroutine zhet01_3 (uplo, n, a, lda, afac, ldafac, e, ipiv, c, ldc, rwork, resid)
 ZHET01_3
subroutine zhet01_aa (uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
 ZHET01_AA
subroutine zhet01_rook (uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
 ZHET01_ROOK
subroutine zhpt01 (uplo, n, a, afac, ipiv, c, ldc, rwork, resid)
 ZHPT01
subroutine zlahilb (n, nrhs, a, lda, x, ldx, b, ldb, work, info, path)
 ZLAHILB
subroutine zlaipd (n, a, inda, vinda)
 ZLAIPD
subroutine zlaptm (uplo, n, nrhs, alpha, d, e, x, ldx, beta, b, ldb)
 ZLAPTM
subroutine zlarhs (path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
 ZLARHS
subroutine zlatb4 (path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
 ZLATB4
subroutine zlatb5 (path, imat, n, type, kl, ku, anorm, mode, cndnum, dist)
 ZLATB5
subroutine zlatsp (uplo, n, x, iseed)
 ZLATSP
subroutine zlatsy (uplo, n, x, ldx, iseed)
 ZLATSY
subroutine zlattb (imat, uplo, trans, diag, iseed, n, kd, ab, ldab, b, work, rwork, info)
 ZLATTB
subroutine zlattp (imat, uplo, trans, diag, iseed, n, ap, b, work, rwork, info)
 ZLATTP
subroutine zlattr (imat, uplo, trans, diag, iseed, n, a, lda, b, work, rwork, info)
 ZLATTR
subroutine zlavhe (uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
 ZLAVHE
subroutine zlavhe_rook (uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
 ZLAVHE_ROOK
subroutine zlavhp (uplo, trans, diag, n, nrhs, a, ipiv, b, ldb, info)
 ZLAVHP
subroutine zlavsp (uplo, trans, diag, n, nrhs, a, ipiv, b, ldb, info)
 ZLAVSP
subroutine zlavsy (uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
 ZLAVSY
subroutine zlavsy_rook (uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
 ZLAVSY_ROOK
subroutine zlqt01 (m, n, a, af, q, l, lda, tau, work, lwork, rwork, result)
 ZLQT01
subroutine zlqt02 (m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
 ZLQT02
subroutine zlqt03 (m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
 ZLQT03
subroutine zpbt01 (uplo, n, kd, a, lda, afac, ldafac, rwork, resid)
 ZPBT01
subroutine zpbt02 (uplo, n, kd, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 ZPBT02
subroutine zpbt05 (uplo, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 ZPBT05
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 zpot03 (uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
 ZPOT03
subroutine zpot05 (uplo, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 ZPOT05
subroutine zpot06 (uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 ZPOT06
subroutine zppt01 (uplo, n, a, afac, rwork, resid)
 ZPPT01
subroutine zppt02 (uplo, n, nrhs, a, x, ldx, b, ldb, rwork, resid)
 ZPPT02
subroutine zppt03 (uplo, n, a, ainv, work, ldwork, rwork, rcond, resid)
 ZPPT03
subroutine zppt05 (uplo, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 ZPPT05
subroutine zpst01 (uplo, n, a, lda, afac, ldafac, perm, ldperm, piv, rwork, resid, rank)
 ZPST01
subroutine zptt01 (n, d, e, df, ef, work, resid)
 ZPTT01
subroutine zptt02 (uplo, n, nrhs, d, e, x, ldx, b, ldb, resid)
 ZPTT02
subroutine zptt05 (n, nrhs, d, e, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 ZPTT05
subroutine zqlt01 (m, n, a, af, q, l, lda, tau, work, lwork, rwork, result)
 ZQLT01
subroutine zqlt02 (m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
 ZQLT02
subroutine zqlt03 (m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
 ZQLT03
double precision function zqpt01 (m, n, k, a, af, lda, tau, jpvt, work, lwork)
 ZQPT01
subroutine zqrt01 (m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
 ZQRT01
subroutine zqrt01p (m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
 ZQRT01P
subroutine zqrt02 (m, n, k, a, af, q, r, lda, tau, work, lwork, rwork, result)
 ZQRT02
subroutine zqrt03 (m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
 ZQRT03
subroutine zqrt04 (m, n, nb, result)
 ZQRT04
subroutine zqrt05 (m, n, l, nb, result)
 ZQRT05
double precision function zqrt11 (m, k, a, lda, tau, work, lwork)
 ZQRT11
double precision function zqrt12 (m, n, a, lda, s, work, lwork, rwork)
 ZQRT12
subroutine zqrt13 (scale, m, n, a, lda, norma, iseed)
 ZQRT13
double precision function zqrt14 (trans, m, n, nrhs, a, lda, x, ldx, work, lwork)
 ZQRT14
subroutine zqrt15 (scale, rksel, m, n, nrhs, a, lda, b, ldb, s, rank, norma, normb, iseed, work, lwork)
 ZQRT15
subroutine zqrt16 (trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 ZQRT16
double precision function zqrt17 (trans, iresid, m, n, nrhs, a, lda, x, ldx, b, ldb, c, work, lwork)
 ZQRT17
subroutine zrqt01 (m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
 ZRQT01
subroutine zrqt02 (m, n, k, a, af, q, r, lda, tau, work, lwork, rwork, result)
 ZRQT02
subroutine zrqt03 (m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
 ZRQT03
double precision function zrzt01 (m, n, a, af, lda, tau, work, lwork)
 ZRZT01
double precision function zrzt02 (m, n, af, lda, tau, work, lwork)
 ZRZT02
subroutine zsbmv (uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
 ZSBMV
subroutine zspt01 (uplo, n, a, afac, ipiv, c, ldc, rwork, resid)
 ZSPT01
subroutine zspt02 (uplo, n, nrhs, a, x, ldx, b, ldb, rwork, resid)
 ZSPT02
subroutine zspt03 (uplo, n, a, ainv, work, ldw, rwork, rcond, resid)
 ZSPT03
subroutine zsyt01 (uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
 ZSYT01
subroutine zsyt01_3 (uplo, n, a, lda, afac, ldafac, e, ipiv, c, ldc, rwork, resid)
 ZSYT01_3
subroutine zsyt01_aa (uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
 ZSYT01
subroutine zsyt01_rook (uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
 ZSYT01_ROOK
subroutine zsyt02 (uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 ZSYT02
subroutine zsyt03 (uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
 ZSYT03
subroutine ztbt02 (uplo, trans, diag, n, kd, nrhs, ab, ldab, x, ldx, b, ldb, work, rwork, resid)
 ZTBT02
subroutine ztbt03 (uplo, trans, diag, n, kd, nrhs, ab, ldab, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
 ZTBT03
subroutine ztbt05 (uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 ZTBT05
subroutine ztbt06 (rcond, rcondc, uplo, diag, n, kd, ab, ldab, rwork, rat)
 ZTBT06
subroutine ztpt01 (uplo, diag, n, ap, ainvp, rcond, rwork, resid)
 ZTPT01
subroutine ztpt02 (uplo, trans, diag, n, nrhs, ap, x, ldx, b, ldb, work, rwork, resid)
 ZTPT02
subroutine ztpt03 (uplo, trans, diag, n, nrhs, ap, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
 ZTPT03
subroutine ztpt05 (uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 ZTPT05
subroutine ztpt06 (rcond, rcondc, uplo, diag, n, ap, rwork, rat)
 ZTPT06
subroutine ztrt01 (uplo, diag, n, a, lda, ainv, ldainv, rcond, rwork, resid)
 ZTRT01
subroutine ztrt02 (uplo, trans, diag, n, nrhs, a, lda, x, ldx, b, ldb, work, rwork, resid)
 ZTRT02
subroutine ztrt03 (uplo, trans, diag, n, nrhs, a, lda, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
 ZTRT03
subroutine ztrt05 (uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 ZTRT05
subroutine ztrt06 (rcond, rcondc, uplo, diag, n, a, lda, rwork, rat)
 ZTRT06
subroutine zunhr_col01 (m, n, mb1, nb1, nb2, result)
 ZUNHR_COL01
subroutine zunhr_col02 (m, n, mb1, nb1, nb2, result)
 ZUNHR_COL02

Detailed Description

This is the group of complex16 LAPACK TESTING LIN routines.

Function Documentation

◆ zchkaa()

program zchkaa

ZCHKAA

Purpose:
!>
!> ZCHKAA is the main test program for the COMPLEX*16 linear equation
!> routines.
!>
!> The program must be driven by a short data file. The first 15 records
!> (not including the first comment  line) specify problem dimensions
!> and program options using list-directed input. The remaining lines
!> specify the LAPACK test paths and the number of matrix types to use
!> in testing.  An annotated example of a data file can be obtained by
!> deleting the first 3 characters from the following 42 lines:
!> Data file for testing COMPLEX*16 LAPACK linear equation routines
!> 7                      Number of values of M
!> 0 1 2 3 5 10 16        Values of M (row dimension)
!> 7                      Number of values of N
!> 0 1 2 3 5 10 16        Values of N (column dimension)
!> 1                      Number of values of NRHS
!> 2                      Values of NRHS (number of right hand sides)
!> 5                      Number of values of NB
!> 1 3 3 3 20             Values of NB (the blocksize)
!> 1 0 5 9 1              Values of NX (crossover point)
!> 3                      Number of values of RANK
!> 30 50 90               Values of rank (as a % of N)
!> 30.0                   Threshold value of test ratio
!> T                      Put T to test the LAPACK routines
!> T                      Put T to test the driver routines
!> T                      Put T to test the error exits
!> ZGE   11               List types on next line if 0 < NTYPES < 11
!> ZGB    8               List types on next line if 0 < NTYPES <  8
!> ZGT   12               List types on next line if 0 < NTYPES < 12
!> ZPO    9               List types on next line if 0 < NTYPES <  9
!> ZPS    9               List types on next line if 0 < NTYPES <  9
!> ZPP    9               List types on next line if 0 < NTYPES <  9
!> ZPB    8               List types on next line if 0 < NTYPES <  8
!> ZPT   12               List types on next line if 0 < NTYPES < 12
!> ZHE   10               List types on next line if 0 < NTYPES < 10
!> ZHR   10               List types on next line if 0 < NTYPES < 10
!> ZHK   10               List types on next line if 0 < NTYPES < 10
!> ZHA   10               List types on next line if 0 < NTYPES < 10
!> ZH2   10               List types on next line if 0 < NTYPES < 10
!> ZSA   11               List types on next line if 0 < NTYPES < 10
!> ZS2   11               List types on next line if 0 < NTYPES < 10
!> ZHP   10               List types on next line if 0 < NTYPES < 10
!> ZSY   11               List types on next line if 0 < NTYPES < 11
!> ZSR   11               List types on next line if 0 < NTYPES < 11
!> ZSK   11               List types on next line if 0 < NTYPES < 11
!> ZSP   11               List types on next line if 0 < NTYPES < 11
!> ZTR   18               List types on next line if 0 < NTYPES < 18
!> ZTP   18               List types on next line if 0 < NTYPES < 18
!> ZTB   17               List types on next line if 0 < NTYPES < 17
!> ZQR    8               List types on next line if 0 < NTYPES <  8
!> ZRQ    8               List types on next line if 0 < NTYPES <  8
!> ZLQ    8               List types on next line if 0 < NTYPES <  8
!> ZQL    8               List types on next line if 0 < NTYPES <  8
!> ZQP    6               List types on next line if 0 < NTYPES <  6
!> ZTZ    3               List types on next line if 0 < NTYPES <  3
!> ZLS    6               List types on next line if 0 < NTYPES <  6
!> ZEQ
!> ZQT
!> ZQX
!> ZTS
!> ZHH
!> 
!>  NMAX    INTEGER
!>          The maximum allowable value for M and N.
!>
!>  MAXIN   INTEGER
!>          The number of different values that can be used for each of
!>          M, N, NRHS, NB, NX and RANK
!>
!>  MAXRHS  INTEGER
!>          The maximum number of right hand sides
!>
!>  MATMAX  INTEGER
!>          The maximum number of matrix types to use for testing
!>
!>  NIN     INTEGER
!>          The unit number for input
!>
!>  NOUT    INTEGER
!>          The unit number for output
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 116 of file zchkaa.F.

◆ zchkab()

program zchkab

ZCHKAB

Purpose:
!>
!> ZCHKAB is the test program for the COMPLEX*16 LAPACK
!> ZCGESV/ZCPOSV routine
!>
!> The program must be driven by a short data file. The first 5 records
!> specify problem dimensions and program options using list-directed
!> input. The remaining lines specify the LAPACK test paths and the
!> number of matrix types to use in testing.  An annotated example of a
!> data file can be obtained by deleting the first 3 characters from the
!> following 9 lines:
!> Data file for testing COMPLEX*16 LAPACK ZCGESV
!> 7                      Number of values of M
!> 0 1 2 3 5 10 16        Values of M (row dimension)
!> 1                      Number of values of NRHS
!> 2                      Values of NRHS (number of right hand sides)
!> 20.0                   Threshold value of test ratio
!> T                      Put T to test the LAPACK routine
!> T                      Put T to test the error exits
!> DGE    11              List types on next line if 0 < NTYPES < 11
!> DPO    9               List types on next line if 0 < NTYPES <  9
!> 
!>  NMAX    INTEGER
!>          The maximum allowable value for N
!>
!>  MAXIN   INTEGER
!>          The number of different values that can be used for each of
!>          M, N, NRHS, NB, and NX
!>
!>  MAXRHS  INTEGER
!>          The maximum number of right hand sides
!>
!>  NIN     INTEGER
!>          The unit number for input
!>
!>  NOUT    INTEGER
!>          The unit number for output
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 72 of file zchkab.f.

◆ zchkeq()

subroutine zchkeq ( double precision thresh,
integer nout )

ZCHKEQ

Purpose:
!>
!> ZCHKEQ tests ZGEEQU, ZGBEQU, ZPOEQU, ZPPEQU and ZPBEQU
!>
Parameters
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          Threshold for testing routines. Should be between 2 and 10.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 53 of file zchkeq.f.

54*
55* -- LAPACK test routine --
56* -- LAPACK is a software package provided by Univ. of Tennessee, --
57* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
58*
59* .. Scalar Arguments ..
60 INTEGER NOUT
61 DOUBLE PRECISION THRESH
62* ..
63*
64* =====================================================================
65*
66* .. Parameters ..
67 DOUBLE PRECISION ZERO, ONE, TEN
68 parameter( zero = 0.0d0, one = 1.0d+0, ten = 1.0d1 )
69 COMPLEX*16 CZERO
70 parameter( czero = ( 0.0d0, 0.0d0 ) )
71 COMPLEX*16 CONE
72 parameter( cone = ( 1.0d0, 0.0d0 ) )
73 INTEGER NSZ, NSZB
74 parameter( nsz = 5, nszb = 3*nsz-2 )
75 INTEGER NSZP, NPOW
76 parameter( nszp = ( nsz*( nsz+1 ) ) / 2,
77 $ npow = 2*nsz+1 )
78* ..
79* .. Local Scalars ..
80 LOGICAL OK
81 CHARACTER*3 PATH
82 INTEGER I, INFO, J, KL, KU, M, N
83 DOUBLE PRECISION CCOND, EPS, NORM, RATIO, RCMAX, RCMIN, RCOND
84* ..
85* .. Local Arrays ..
86 DOUBLE PRECISION C( NSZ ), POW( NPOW ), R( NSZ ), RESLTS( 5 ),
87 $ RPOW( NPOW )
88 COMPLEX*16 A( NSZ, NSZ ), AB( NSZB, NSZ ), AP( NSZP )
89* ..
90* .. External Functions ..
91 DOUBLE PRECISION DLAMCH
92 EXTERNAL dlamch
93* ..
94* .. External Subroutines ..
95 EXTERNAL zgbequ, zgeequ, zpbequ, zpoequ, zppequ
96* ..
97* .. Intrinsic Functions ..
98 INTRINSIC abs, max, min
99* ..
100* .. Executable Statements ..
101*
102 path( 1: 1 ) = 'Zomplex precision'
103 path( 2: 3 ) = 'EQ'
104*
105 eps = dlamch( 'P' )
106 DO 10 i = 1, 5
107 reslts( i ) = zero
108 10 CONTINUE
109 DO 20 i = 1, npow
110 pow( i ) = ten**( i-1 )
111 rpow( i ) = one / pow( i )
112 20 CONTINUE
113*
114* Test ZGEEQU
115*
116 DO 80 n = 0, nsz
117 DO 70 m = 0, nsz
118*
119 DO 40 j = 1, nsz
120 DO 30 i = 1, nsz
121 IF( i.LE.m .AND. j.LE.n ) THEN
122 a( i, j ) = pow( i+j+1 )*( -1 )**( i+j )
123 ELSE
124 a( i, j ) = czero
125 END IF
126 30 CONTINUE
127 40 CONTINUE
128*
129 CALL zgeequ( m, n, a, nsz, r, c, rcond, ccond, norm, info )
130*
131 IF( info.NE.0 ) THEN
132 reslts( 1 ) = one
133 ELSE
134 IF( n.NE.0 .AND. m.NE.0 ) THEN
135 reslts( 1 ) = max( reslts( 1 ),
136 $ abs( ( rcond-rpow( m ) ) / rpow( m ) ) )
137 reslts( 1 ) = max( reslts( 1 ),
138 $ abs( ( ccond-rpow( n ) ) / rpow( n ) ) )
139 reslts( 1 ) = max( reslts( 1 ),
140 $ abs( ( norm-pow( n+m+1 ) ) / pow( n+m+
141 $ 1 ) ) )
142 DO 50 i = 1, m
143 reslts( 1 ) = max( reslts( 1 ),
144 $ abs( ( r( i )-rpow( i+n+1 ) ) /
145 $ rpow( i+n+1 ) ) )
146 50 CONTINUE
147 DO 60 j = 1, n
148 reslts( 1 ) = max( reslts( 1 ),
149 $ abs( ( c( j )-pow( n-j+1 ) ) /
150 $ pow( n-j+1 ) ) )
151 60 CONTINUE
152 END IF
153 END IF
154*
155 70 CONTINUE
156 80 CONTINUE
157*
158* Test with zero rows and columns
159*
160 DO 90 j = 1, nsz
161 a( max( nsz-1, 1 ), j ) = czero
162 90 CONTINUE
163 CALL zgeequ( nsz, nsz, a, nsz, r, c, rcond, ccond, norm, info )
164 IF( info.NE.max( nsz-1, 1 ) )
165 $ reslts( 1 ) = one
166*
167 DO 100 j = 1, nsz
168 a( max( nsz-1, 1 ), j ) = cone
169 100 CONTINUE
170 DO 110 i = 1, nsz
171 a( i, max( nsz-1, 1 ) ) = czero
172 110 CONTINUE
173 CALL zgeequ( nsz, nsz, a, nsz, r, c, rcond, ccond, norm, info )
174 IF( info.NE.nsz+max( nsz-1, 1 ) )
175 $ reslts( 1 ) = one
176 reslts( 1 ) = reslts( 1 ) / eps
177*
178* Test ZGBEQU
179*
180 DO 250 n = 0, nsz
181 DO 240 m = 0, nsz
182 DO 230 kl = 0, max( m-1, 0 )
183 DO 220 ku = 0, max( n-1, 0 )
184*
185 DO 130 j = 1, nsz
186 DO 120 i = 1, nszb
187 ab( i, j ) = czero
188 120 CONTINUE
189 130 CONTINUE
190 DO 150 j = 1, n
191 DO 140 i = 1, m
192 IF( i.LE.min( m, j+kl ) .AND. i.GE.
193 $ max( 1, j-ku ) .AND. j.LE.n ) THEN
194 ab( ku+1+i-j, j ) = pow( i+j+1 )*
195 $ ( -1 )**( i+j )
196 END IF
197 140 CONTINUE
198 150 CONTINUE
199*
200 CALL zgbequ( m, n, kl, ku, ab, nszb, r, c, rcond,
201 $ ccond, norm, info )
202*
203 IF( info.NE.0 ) THEN
204 IF( .NOT.( ( n+kl.LT.m .AND. info.EQ.n+kl+1 ) .OR.
205 $ ( m+ku.LT.n .AND. info.EQ.2*m+ku+1 ) ) ) THEN
206 reslts( 2 ) = one
207 END IF
208 ELSE
209 IF( n.NE.0 .AND. m.NE.0 ) THEN
210*
211 rcmin = r( 1 )
212 rcmax = r( 1 )
213 DO 160 i = 1, m
214 rcmin = min( rcmin, r( i ) )
215 rcmax = max( rcmax, r( i ) )
216 160 CONTINUE
217 ratio = rcmin / rcmax
218 reslts( 2 ) = max( reslts( 2 ),
219 $ abs( ( rcond-ratio ) / ratio ) )
220*
221 rcmin = c( 1 )
222 rcmax = c( 1 )
223 DO 170 j = 1, n
224 rcmin = min( rcmin, c( j ) )
225 rcmax = max( rcmax, c( j ) )
226 170 CONTINUE
227 ratio = rcmin / rcmax
228 reslts( 2 ) = max( reslts( 2 ),
229 $ abs( ( ccond-ratio ) / ratio ) )
230*
231 reslts( 2 ) = max( reslts( 2 ),
232 $ abs( ( norm-pow( n+m+1 ) ) /
233 $ pow( n+m+1 ) ) )
234 DO 190 i = 1, m
235 rcmax = zero
236 DO 180 j = 1, n
237 IF( i.LE.j+kl .AND. i.GE.j-ku ) THEN
238 ratio = abs( r( i )*pow( i+j+1 )*
239 $ c( j ) )
240 rcmax = max( rcmax, ratio )
241 END IF
242 180 CONTINUE
243 reslts( 2 ) = max( reslts( 2 ),
244 $ abs( one-rcmax ) )
245 190 CONTINUE
246*
247 DO 210 j = 1, n
248 rcmax = zero
249 DO 200 i = 1, m
250 IF( i.LE.j+kl .AND. i.GE.j-ku ) THEN
251 ratio = abs( r( i )*pow( i+j+1 )*
252 $ c( j ) )
253 rcmax = max( rcmax, ratio )
254 END IF
255 200 CONTINUE
256 reslts( 2 ) = max( reslts( 2 ),
257 $ abs( one-rcmax ) )
258 210 CONTINUE
259 END IF
260 END IF
261*
262 220 CONTINUE
263 230 CONTINUE
264 240 CONTINUE
265 250 CONTINUE
266 reslts( 2 ) = reslts( 2 ) / eps
267*
268* Test ZPOEQU
269*
270 DO 290 n = 0, nsz
271*
272 DO 270 i = 1, nsz
273 DO 260 j = 1, nsz
274 IF( i.LE.n .AND. j.EQ.i ) THEN
275 a( i, j ) = pow( i+j+1 )*( -1 )**( i+j )
276 ELSE
277 a( i, j ) = czero
278 END IF
279 260 CONTINUE
280 270 CONTINUE
281*
282 CALL zpoequ( n, a, nsz, r, rcond, norm, info )
283*
284 IF( info.NE.0 ) THEN
285 reslts( 3 ) = one
286 ELSE
287 IF( n.NE.0 ) THEN
288 reslts( 3 ) = max( reslts( 3 ),
289 $ abs( ( rcond-rpow( n ) ) / rpow( n ) ) )
290 reslts( 3 ) = max( reslts( 3 ),
291 $ abs( ( norm-pow( 2*n+1 ) ) / pow( 2*n+
292 $ 1 ) ) )
293 DO 280 i = 1, n
294 reslts( 3 ) = max( reslts( 3 ),
295 $ abs( ( r( i )-rpow( i+1 ) ) / rpow( i+
296 $ 1 ) ) )
297 280 CONTINUE
298 END IF
299 END IF
300 290 CONTINUE
301 a( max( nsz-1, 1 ), max( nsz-1, 1 ) ) = -cone
302 CALL zpoequ( nsz, a, nsz, r, rcond, norm, info )
303 IF( info.NE.max( nsz-1, 1 ) )
304 $ reslts( 3 ) = one
305 reslts( 3 ) = reslts( 3 ) / eps
306*
307* Test ZPPEQU
308*
309 DO 360 n = 0, nsz
310*
311* Upper triangular packed storage
312*
313 DO 300 i = 1, ( n*( n+1 ) ) / 2
314 ap( i ) = czero
315 300 CONTINUE
316 DO 310 i = 1, n
317 ap( ( i*( i+1 ) ) / 2 ) = pow( 2*i+1 )
318 310 CONTINUE
319*
320 CALL zppequ( 'U', n, ap, r, rcond, norm, info )
321*
322 IF( info.NE.0 ) THEN
323 reslts( 4 ) = one
324 ELSE
325 IF( n.NE.0 ) THEN
326 reslts( 4 ) = max( reslts( 4 ),
327 $ abs( ( rcond-rpow( n ) ) / rpow( n ) ) )
328 reslts( 4 ) = max( reslts( 4 ),
329 $ abs( ( norm-pow( 2*n+1 ) ) / pow( 2*n+
330 $ 1 ) ) )
331 DO 320 i = 1, n
332 reslts( 4 ) = max( reslts( 4 ),
333 $ abs( ( r( i )-rpow( i+1 ) ) / rpow( i+
334 $ 1 ) ) )
335 320 CONTINUE
336 END IF
337 END IF
338*
339* Lower triangular packed storage
340*
341 DO 330 i = 1, ( n*( n+1 ) ) / 2
342 ap( i ) = czero
343 330 CONTINUE
344 j = 1
345 DO 340 i = 1, n
346 ap( j ) = pow( 2*i+1 )
347 j = j + ( n-i+1 )
348 340 CONTINUE
349*
350 CALL zppequ( 'L', n, ap, r, rcond, norm, info )
351*
352 IF( info.NE.0 ) THEN
353 reslts( 4 ) = one
354 ELSE
355 IF( n.NE.0 ) THEN
356 reslts( 4 ) = max( reslts( 4 ),
357 $ abs( ( rcond-rpow( n ) ) / rpow( n ) ) )
358 reslts( 4 ) = max( reslts( 4 ),
359 $ abs( ( norm-pow( 2*n+1 ) ) / pow( 2*n+
360 $ 1 ) ) )
361 DO 350 i = 1, n
362 reslts( 4 ) = max( reslts( 4 ),
363 $ abs( ( r( i )-rpow( i+1 ) ) / rpow( i+
364 $ 1 ) ) )
365 350 CONTINUE
366 END IF
367 END IF
368*
369 360 CONTINUE
370 i = ( nsz*( nsz+1 ) ) / 2 - 2
371 ap( i ) = -cone
372 CALL zppequ( 'L', nsz, ap, r, rcond, norm, info )
373 IF( info.NE.max( nsz-1, 1 ) )
374 $ reslts( 4 ) = one
375 reslts( 4 ) = reslts( 4 ) / eps
376*
377* Test ZPBEQU
378*
379 DO 460 n = 0, nsz
380 DO 450 kl = 0, max( n-1, 0 )
381*
382* Test upper triangular storage
383*
384 DO 380 j = 1, nsz
385 DO 370 i = 1, nszb
386 ab( i, j ) = czero
387 370 CONTINUE
388 380 CONTINUE
389 DO 390 j = 1, n
390 ab( kl+1, j ) = pow( 2*j+1 )
391 390 CONTINUE
392*
393 CALL zpbequ( 'U', n, kl, ab, nszb, r, rcond, norm, info )
394*
395 IF( info.NE.0 ) THEN
396 reslts( 5 ) = one
397 ELSE
398 IF( n.NE.0 ) THEN
399 reslts( 5 ) = max( reslts( 5 ),
400 $ abs( ( rcond-rpow( n ) ) / rpow( n ) ) )
401 reslts( 5 ) = max( reslts( 5 ),
402 $ abs( ( norm-pow( 2*n+1 ) ) / pow( 2*n+
403 $ 1 ) ) )
404 DO 400 i = 1, n
405 reslts( 5 ) = max( reslts( 5 ),
406 $ abs( ( r( i )-rpow( i+1 ) ) /
407 $ rpow( i+1 ) ) )
408 400 CONTINUE
409 END IF
410 END IF
411 IF( n.NE.0 ) THEN
412 ab( kl+1, max( n-1, 1 ) ) = -cone
413 CALL zpbequ( 'U', n, kl, ab, nszb, r, rcond, norm, info )
414 IF( info.NE.max( n-1, 1 ) )
415 $ reslts( 5 ) = one
416 END IF
417*
418* Test lower triangular storage
419*
420 DO 420 j = 1, nsz
421 DO 410 i = 1, nszb
422 ab( i, j ) = czero
423 410 CONTINUE
424 420 CONTINUE
425 DO 430 j = 1, n
426 ab( 1, j ) = pow( 2*j+1 )
427 430 CONTINUE
428*
429 CALL zpbequ( 'L', n, kl, ab, nszb, r, rcond, norm, info )
430*
431 IF( info.NE.0 ) THEN
432 reslts( 5 ) = one
433 ELSE
434 IF( n.NE.0 ) THEN
435 reslts( 5 ) = max( reslts( 5 ),
436 $ abs( ( rcond-rpow( n ) ) / rpow( n ) ) )
437 reslts( 5 ) = max( reslts( 5 ),
438 $ abs( ( norm-pow( 2*n+1 ) ) / pow( 2*n+
439 $ 1 ) ) )
440 DO 440 i = 1, n
441 reslts( 5 ) = max( reslts( 5 ),
442 $ abs( ( r( i )-rpow( i+1 ) ) /
443 $ rpow( i+1 ) ) )
444 440 CONTINUE
445 END IF
446 END IF
447 IF( n.NE.0 ) THEN
448 ab( 1, max( n-1, 1 ) ) = -cone
449 CALL zpbequ( 'L', n, kl, ab, nszb, r, rcond, norm, info )
450 IF( info.NE.max( n-1, 1 ) )
451 $ reslts( 5 ) = one
452 END IF
453 450 CONTINUE
454 460 CONTINUE
455 reslts( 5 ) = reslts( 5 ) / eps
456 ok = ( reslts( 1 ).LE.thresh ) .AND.
457 $ ( reslts( 2 ).LE.thresh ) .AND.
458 $ ( reslts( 3 ).LE.thresh ) .AND.
459 $ ( reslts( 4 ).LE.thresh ) .AND. ( reslts( 5 ).LE.thresh )
460 WRITE( nout, fmt = * )
461 IF( ok ) THEN
462 WRITE( nout, fmt = 9999 )path
463 ELSE
464 IF( reslts( 1 ).GT.thresh )
465 $ WRITE( nout, fmt = 9998 )reslts( 1 ), thresh
466 IF( reslts( 2 ).GT.thresh )
467 $ WRITE( nout, fmt = 9997 )reslts( 2 ), thresh
468 IF( reslts( 3 ).GT.thresh )
469 $ WRITE( nout, fmt = 9996 )reslts( 3 ), thresh
470 IF( reslts( 4 ).GT.thresh )
471 $ WRITE( nout, fmt = 9995 )reslts( 4 ), thresh
472 IF( reslts( 5 ).GT.thresh )
473 $ WRITE( nout, fmt = 9994 )reslts( 5 ), thresh
474 END IF
475 9999 FORMAT( 1x, 'All tests for ', a3,
476 $ ' routines passed the threshold' )
477 9998 FORMAT( ' ZGEEQU failed test with value ', d10.3, ' exceeding',
478 $ ' threshold ', d10.3 )
479 9997 FORMAT( ' ZGBEQU failed test with value ', d10.3, ' exceeding',
480 $ ' threshold ', d10.3 )
481 9996 FORMAT( ' ZPOEQU failed test with value ', d10.3, ' exceeding',
482 $ ' threshold ', d10.3 )
483 9995 FORMAT( ' ZPPEQU failed test with value ', d10.3, ' exceeding',
484 $ ' threshold ', d10.3 )
485 9994 FORMAT( ' ZPBEQU failed test with value ', d10.3, ' exceeding',
486 $ ' threshold ', d10.3 )
487 RETURN
488*
489* End of ZCHKEQ
490*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
zgbequ
subroutine zgbequ(m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, info)
ZGBEQU
Definition zgbequ.f:154
zgeequ
subroutine zgeequ(m, n, a, lda, r, c, rowcnd, colcnd, amax, info)
ZGEEQU
Definition zgeequ.f:140
zppequ
subroutine zppequ(uplo, n, ap, s, scond, amax, info)
ZPPEQU
Definition zppequ.f:117
zpbequ
subroutine zpbequ(uplo, n, kd, ab, ldab, s, scond, amax, info)
ZPBEQU
Definition zpbequ.f:130
zpoequ
subroutine zpoequ(n, a, lda, s, scond, amax, info)
ZPOEQU
Definition zpoequ.f:113
dlamch
double precision function dlamch(cmach)
DLAMCH
Definition dlamch.f:69
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21

◆ zchkgb()

subroutine zchkgb ( logical, dimension( * ) dotype,
integer nm,
integer, dimension( * ) mval,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
complex*16, dimension( * ) a,
integer la,
complex*16, dimension( * ) afac,
integer lafac,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKGB

Purpose:
!>
!> ZCHKGB tests ZGBTRF, -TRS, -RFS, and -CON
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LA)
!>
[in]LA
!>          LA is INTEGER
!>          The length of the array A.  LA >= (KLMAX+KUMAX+1)*NMAX
!>          where KLMAX is the largest entry in the local array KLVAL,
!>                KUMAX is the largest entry in the local array KUVAL and
!>                NMAX is the largest entry in the input array NVAL.
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (LAFAC)
!>
[in]LAFAC
!>          LAFAC is INTEGER
!>          The length of the array AFAC. LAFAC >= (2*KLMAX+KUMAX+1)*NMAX
!>          where KLMAX is the largest entry in the local array KLVAL,
!>                KUMAX is the largest entry in the local array KUVAL and
!>                NMAX is the largest entry in the input array NVAL.
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NSMAX,NMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (NMAX+2*NSMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 188 of file zchkgb.f.

191*
192* -- LAPACK test routine --
193* -- LAPACK is a software package provided by Univ. of Tennessee, --
194* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
195*
196* .. Scalar Arguments ..
197 LOGICAL TSTERR
198 INTEGER LA, LAFAC, NM, NN, NNB, NNS, NOUT
199 DOUBLE PRECISION THRESH
200* ..
201* .. Array Arguments ..
202 LOGICAL DOTYPE( * )
203 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
204 $ NVAL( * )
205 DOUBLE PRECISION RWORK( * )
206 COMPLEX*16 A( * ), AFAC( * ), B( * ), WORK( * ), X( * ),
207 $ XACT( * )
208* ..
209*
210* =====================================================================
211*
212* .. Parameters ..
213 DOUBLE PRECISION ONE, ZERO
214 parameter( one = 1.0d+0, zero = 0.0d+0 )
215 INTEGER NTYPES, NTESTS
216 parameter( ntypes = 8, ntests = 7 )
217 INTEGER NBW, NTRAN
218 parameter( nbw = 4, ntran = 3 )
219* ..
220* .. Local Scalars ..
221 LOGICAL TRFCON, ZEROT
222 CHARACTER DIST, NORM, TRANS, TYPE, XTYPE
223 CHARACTER*3 PATH
224 INTEGER I, I1, I2, IKL, IKU, IM, IMAT, IN, INB, INFO,
225 $ IOFF, IRHS, ITRAN, IZERO, J, K, KL, KOFF, KU,
226 $ LDA, LDAFAC, LDB, M, MODE, N, NB, NERRS, NFAIL,
227 $ NIMAT, NKL, NKU, NRHS, NRUN
228 DOUBLE PRECISION AINVNM, ANORM, ANORMI, ANORMO, CNDNUM, RCOND,
229 $ RCONDC, RCONDI, RCONDO
230* ..
231* .. Local Arrays ..
232 CHARACTER TRANSS( NTRAN )
233 INTEGER ISEED( 4 ), ISEEDY( 4 ), KLVAL( NBW ),
234 $ KUVAL( NBW )
235 DOUBLE PRECISION RESULT( NTESTS )
236* ..
237* .. External Functions ..
238 DOUBLE PRECISION DGET06, ZLANGB, ZLANGE
239 EXTERNAL dget06, zlangb, zlange
240* ..
241* .. External Subroutines ..
242 EXTERNAL alaerh, alahd, alasum, xlaenv, zcopy, zerrge,
243 $ zgbcon, zgbrfs, zgbt01, zgbt02, zgbt05, zgbtrf,
244 $ zgbtrs, zget04, zlacpy, zlarhs, zlaset, zlatb4,
245 $ zlatms
246* ..
247* .. Intrinsic Functions ..
248 INTRINSIC dcmplx, max, min
249* ..
250* .. Scalars in Common ..
251 LOGICAL LERR, OK
252 CHARACTER*32 SRNAMT
253 INTEGER INFOT, NUNIT
254* ..
255* .. Common blocks ..
256 COMMON / infoc / infot, nunit, ok, lerr
257 COMMON / srnamc / srnamt
258* ..
259* .. Data statements ..
260 DATA iseedy / 1988, 1989, 1990, 1991 / ,
261 $ transs / 'N', 'T', 'C' /
262* ..
263* .. Executable Statements ..
264*
265* Initialize constants and the random number seed.
266*
267 path( 1: 1 ) = 'Zomplex precision'
268 path( 2: 3 ) = 'GB'
269 nrun = 0
270 nfail = 0
271 nerrs = 0
272 DO 10 i = 1, 4
273 iseed( i ) = iseedy( i )
274 10 CONTINUE
275*
276* Test the error exits
277*
278 IF( tsterr )
279 $ CALL zerrge( path, nout )
280 infot = 0
281*
282* Initialize the first value for the lower and upper bandwidths.
283*
284 klval( 1 ) = 0
285 kuval( 1 ) = 0
286*
287* Do for each value of M in MVAL
288*
289 DO 160 im = 1, nm
290 m = mval( im )
291*
292* Set values to use for the lower bandwidth.
293*
294 klval( 2 ) = m + ( m+1 ) / 4
295*
296* KLVAL( 2 ) = MAX( M-1, 0 )
297*
298 klval( 3 ) = ( 3*m-1 ) / 4
299 klval( 4 ) = ( m+1 ) / 4
300*
301* Do for each value of N in NVAL
302*
303 DO 150 in = 1, nn
304 n = nval( in )
305 xtype = 'N'
306*
307* Set values to use for the upper bandwidth.
308*
309 kuval( 2 ) = n + ( n+1 ) / 4
310*
311* KUVAL( 2 ) = MAX( N-1, 0 )
312*
313 kuval( 3 ) = ( 3*n-1 ) / 4
314 kuval( 4 ) = ( n+1 ) / 4
315*
316* Set limits on the number of loop iterations.
317*
318 nkl = min( m+1, 4 )
319 IF( n.EQ.0 )
320 $ nkl = 2
321 nku = min( n+1, 4 )
322 IF( m.EQ.0 )
323 $ nku = 2
324 nimat = ntypes
325 IF( m.LE.0 .OR. n.LE.0 )
326 $ nimat = 1
327*
328 DO 140 ikl = 1, nkl
329*
330* Do for KL = 0, (5*M+1)/4, (3M-1)/4, and (M+1)/4. This
331* order makes it easier to skip redundant values for small
332* values of M.
333*
334 kl = klval( ikl )
335 DO 130 iku = 1, nku
336*
337* Do for KU = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This
338* order makes it easier to skip redundant values for
339* small values of N.
340*
341 ku = kuval( iku )
342*
343* Check that A and AFAC are big enough to generate this
344* matrix.
345*
346 lda = kl + ku + 1
347 ldafac = 2*kl + ku + 1
348 IF( ( lda*n ).GT.la .OR. ( ldafac*n ).GT.lafac ) THEN
349 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
350 $ CALL alahd( nout, path )
351 IF( n*( kl+ku+1 ).GT.la ) THEN
352 WRITE( nout, fmt = 9999 )la, m, n, kl, ku,
353 $ n*( kl+ku+1 )
354 nerrs = nerrs + 1
355 END IF
356 IF( n*( 2*kl+ku+1 ).GT.lafac ) THEN
357 WRITE( nout, fmt = 9998 )lafac, m, n, kl, ku,
358 $ n*( 2*kl+ku+1 )
359 nerrs = nerrs + 1
360 END IF
361 GO TO 130
362 END IF
363*
364 DO 120 imat = 1, nimat
365*
366* Do the tests only if DOTYPE( IMAT ) is true.
367*
368 IF( .NOT.dotype( imat ) )
369 $ GO TO 120
370*
371* Skip types 2, 3, or 4 if the matrix size is too
372* small.
373*
374 zerot = imat.GE.2 .AND. imat.LE.4
375 IF( zerot .AND. n.LT.imat-1 )
376 $ GO TO 120
377*
378 IF( .NOT.zerot .OR. .NOT.dotype( 1 ) ) THEN
379*
380* Set up parameters with ZLATB4 and generate a
381* test matrix with ZLATMS.
382*
383 CALL zlatb4( path, imat, m, n, TYPE, KL, KU,
384 $ ANORM, MODE, CNDNUM, DIST )
385*
386 koff = max( 1, ku+2-n )
387 DO 20 i = 1, koff - 1
388 a( i ) = zero
389 20 CONTINUE
390 srnamt = 'ZLATMS'
391 CALL zlatms( m, n, dist, iseed, TYPE, RWORK,
392 $ MODE, CNDNUM, ANORM, KL, KU, 'Z',
393 $ A( KOFF ), LDA, WORK, INFO )
394*
395* Check the error code from ZLATMS.
396*
397 IF( info.NE.0 ) THEN
398 CALL alaerh( path, 'ZLATMS', info, 0, ' ', m,
399 $ n, kl, ku, -1, imat, nfail,
400 $ nerrs, nout )
401 GO TO 120
402 END IF
403 ELSE IF( izero.GT.0 ) THEN
404*
405* Use the same matrix for types 3 and 4 as for
406* type 2 by copying back the zeroed out column.
407*
408 CALL zcopy( i2-i1+1, b, 1, a( ioff+i1 ), 1 )
409 END IF
410*
411* For types 2, 3, and 4, zero one or more columns of
412* the matrix to test that INFO is returned correctly.
413*
414 izero = 0
415 IF( zerot ) THEN
416 IF( imat.EQ.2 ) THEN
417 izero = 1
418 ELSE IF( imat.EQ.3 ) THEN
419 izero = min( m, n )
420 ELSE
421 izero = min( m, n ) / 2 + 1
422 END IF
423 ioff = ( izero-1 )*lda
424 IF( imat.LT.4 ) THEN
425*
426* Store the column to be zeroed out in B.
427*
428 i1 = max( 1, ku+2-izero )
429 i2 = min( kl+ku+1, ku+1+( m-izero ) )
430 CALL zcopy( i2-i1+1, a( ioff+i1 ), 1, b, 1 )
431*
432 DO 30 i = i1, i2
433 a( ioff+i ) = zero
434 30 CONTINUE
435 ELSE
436 DO 50 j = izero, n
437 DO 40 i = max( 1, ku+2-j ),
438 $ min( kl+ku+1, ku+1+( m-j ) )
439 a( ioff+i ) = zero
440 40 CONTINUE
441 ioff = ioff + lda
442 50 CONTINUE
443 END IF
444 END IF
445*
446* These lines, if used in place of the calls in the
447* loop over INB, cause the code to bomb on a Sun
448* SPARCstation.
449*
450* ANORMO = ZLANGB( 'O', N, KL, KU, A, LDA, RWORK )
451* ANORMI = ZLANGB( 'I', N, KL, KU, A, LDA, RWORK )
452*
453* Do for each blocksize in NBVAL
454*
455 DO 110 inb = 1, nnb
456 nb = nbval( inb )
457 CALL xlaenv( 1, nb )
458*
459* Compute the LU factorization of the band matrix.
460*
461 IF( m.GT.0 .AND. n.GT.0 )
462 $ CALL zlacpy( 'Full', kl+ku+1, n, a, lda,
463 $ afac( kl+1 ), ldafac )
464 srnamt = 'ZGBTRF'
465 CALL zgbtrf( m, n, kl, ku, afac, ldafac, iwork,
466 $ info )
467*
468* Check error code from ZGBTRF.
469*
470 IF( info.NE.izero )
471 $ CALL alaerh( path, 'ZGBTRF', info, izero,
472 $ ' ', m, n, kl, ku, nb, imat,
473 $ nfail, nerrs, nout )
474 trfcon = .false.
475*
476*+ TEST 1
477* Reconstruct matrix from factors and compute
478* residual.
479*
480 CALL zgbt01( m, n, kl, ku, a, lda, afac, ldafac,
481 $ iwork, work, result( 1 ) )
482*
483* Print information about the tests so far that
484* did not pass the threshold.
485*
486 IF( result( 1 ).GE.thresh ) THEN
487 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
488 $ CALL alahd( nout, path )
489 WRITE( nout, fmt = 9997 )m, n, kl, ku, nb,
490 $ imat, 1, result( 1 )
491 nfail = nfail + 1
492 END IF
493 nrun = nrun + 1
494*
495* Skip the remaining tests if this is not the
496* first block size or if M .ne. N.
497*
498 IF( inb.GT.1 .OR. m.NE.n )
499 $ GO TO 110
500*
501 anormo = zlangb( 'O', n, kl, ku, a, lda, rwork )
502 anormi = zlangb( 'I', n, kl, ku, a, lda, rwork )
503*
504 IF( info.EQ.0 ) THEN
505*
506* Form the inverse of A so we can get a good
507* estimate of CNDNUM = norm(A) * norm(inv(A)).
508*
509 ldb = max( 1, n )
510 CALL zlaset( 'Full', n, n, dcmplx( zero ),
511 $ dcmplx( one ), work, ldb )
512 srnamt = 'ZGBTRS'
513 CALL zgbtrs( 'No transpose', n, kl, ku, n,
514 $ afac, ldafac, iwork, work, ldb,
515 $ info )
516*
517* Compute the 1-norm condition number of A.
518*
519 ainvnm = zlange( 'O', n, n, work, ldb,
520 $ rwork )
521 IF( anormo.LE.zero .OR. ainvnm.LE.zero ) THEN
522 rcondo = one
523 ELSE
524 rcondo = ( one / anormo ) / ainvnm
525 END IF
526*
527* Compute the infinity-norm condition number of
528* A.
529*
530 ainvnm = zlange( 'I', n, n, work, ldb,
531 $ rwork )
532 IF( anormi.LE.zero .OR. ainvnm.LE.zero ) THEN
533 rcondi = one
534 ELSE
535 rcondi = ( one / anormi ) / ainvnm
536 END IF
537 ELSE
538*
539* Do only the condition estimate if INFO.NE.0.
540*
541 trfcon = .true.
542 rcondo = zero
543 rcondi = zero
544 END IF
545*
546* Skip the solve tests if the matrix is singular.
547*
548 IF( trfcon )
549 $ GO TO 90
550*
551 DO 80 irhs = 1, nns
552 nrhs = nsval( irhs )
553 xtype = 'N'
554*
555 DO 70 itran = 1, ntran
556 trans = transs( itran )
557 IF( itran.EQ.1 ) THEN
558 rcondc = rcondo
559 norm = 'O'
560 ELSE
561 rcondc = rcondi
562 norm = 'I'
563 END IF
564*
565*+ TEST 2:
566* Solve and compute residual for op(A) * X = B.
567*
568 srnamt = 'ZLARHS'
569 CALL zlarhs( path, xtype, ' ', trans, n,
570 $ n, kl, ku, nrhs, a, lda,
571 $ xact, ldb, b, ldb, iseed,
572 $ info )
573 xtype = 'C'
574 CALL zlacpy( 'Full', n, nrhs, b, ldb, x,
575 $ ldb )
576*
577 srnamt = 'ZGBTRS'
578 CALL zgbtrs( trans, n, kl, ku, nrhs, afac,
579 $ ldafac, iwork, x, ldb, info )
580*
581* Check error code from ZGBTRS.
582*
583 IF( info.NE.0 )
584 $ CALL alaerh( path, 'ZGBTRS', info, 0,
585 $ trans, n, n, kl, ku, -1,
586 $ imat, nfail, nerrs, nout )
587*
588 CALL zlacpy( 'Full', n, nrhs, b, ldb,
589 $ work, ldb )
590 CALL zgbt02( trans, m, n, kl, ku, nrhs, a,
591 $ lda, x, ldb, work, ldb,
592 $ rwork, result( 2 ) )
593*
594*+ TEST 3:
595* Check solution from generated exact
596* solution.
597*
598 CALL zget04( n, nrhs, x, ldb, xact, ldb,
599 $ rcondc, result( 3 ) )
600*
601*+ TESTS 4, 5, 6:
602* Use iterative refinement to improve the
603* solution.
604*
605 srnamt = 'ZGBRFS'
606 CALL zgbrfs( trans, n, kl, ku, nrhs, a,
607 $ lda, afac, ldafac, iwork, b,
608 $ ldb, x, ldb, rwork,
609 $ rwork( nrhs+1 ), work,
610 $ rwork( 2*nrhs+1 ), info )
611*
612* Check error code from ZGBRFS.
613*
614 IF( info.NE.0 )
615 $ CALL alaerh( path, 'ZGBRFS', info, 0,
616 $ trans, n, n, kl, ku, nrhs,
617 $ imat, nfail, nerrs, nout )
618*
619 CALL zget04( n, nrhs, x, ldb, xact, ldb,
620 $ rcondc, result( 4 ) )
621 CALL zgbt05( trans, n, kl, ku, nrhs, a,
622 $ lda, b, ldb, x, ldb, xact,
623 $ ldb, rwork, rwork( nrhs+1 ),
624 $ result( 5 ) )
625*
626* Print information about the tests that did
627* not pass the threshold.
628*
629 DO 60 k = 2, 6
630 IF( result( k ).GE.thresh ) THEN
631 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
632 $ CALL alahd( nout, path )
633 WRITE( nout, fmt = 9996 )trans, n,
634 $ kl, ku, nrhs, imat, k,
635 $ result( k )
636 nfail = nfail + 1
637 END IF
638 60 CONTINUE
639 nrun = nrun + 5
640 70 CONTINUE
641 80 CONTINUE
642*
643*+ TEST 7:
644* Get an estimate of RCOND = 1/CNDNUM.
645*
646 90 CONTINUE
647 DO 100 itran = 1, 2
648 IF( itran.EQ.1 ) THEN
649 anorm = anormo
650 rcondc = rcondo
651 norm = 'O'
652 ELSE
653 anorm = anormi
654 rcondc = rcondi
655 norm = 'I'
656 END IF
657 srnamt = 'ZGBCON'
658 CALL zgbcon( norm, n, kl, ku, afac, ldafac,
659 $ iwork, anorm, rcond, work,
660 $ rwork, info )
661*
662* Check error code from ZGBCON.
663*
664 IF( info.NE.0 )
665 $ CALL alaerh( path, 'ZGBCON', info, 0,
666 $ norm, n, n, kl, ku, -1, imat,
667 $ nfail, nerrs, nout )
668*
669 result( 7 ) = dget06( rcond, rcondc )
670*
671* Print information about the tests that did
672* not pass the threshold.
673*
674 IF( result( 7 ).GE.thresh ) THEN
675 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
676 $ CALL alahd( nout, path )
677 WRITE( nout, fmt = 9995 )norm, n, kl, ku,
678 $ imat, 7, result( 7 )
679 nfail = nfail + 1
680 END IF
681 nrun = nrun + 1
682 100 CONTINUE
683 110 CONTINUE
684 120 CONTINUE
685 130 CONTINUE
686 140 CONTINUE
687 150 CONTINUE
688 160 CONTINUE
689*
690* Print a summary of the results.
691*
692 CALL alasum( path, nout, nfail, nrun, nerrs )
693*
694 9999 FORMAT( ' *** In ZCHKGB, LA=', i5, ' is too small for M=', i5,
695 $ ', N=', i5, ', KL=', i4, ', KU=', i4,
696 $ / ' ==> Increase LA to at least ', i5 )
697 9998 FORMAT( ' *** In ZCHKGB, LAFAC=', i5, ' is too small for M=', i5,
698 $ ', N=', i5, ', KL=', i4, ', KU=', i4,
699 $ / ' ==> Increase LAFAC to at least ', i5 )
700 9997 FORMAT( ' M =', i5, ', N =', i5, ', KL=', i5, ', KU=', i5,
701 $ ', NB =', i4, ', type ', i1, ', test(', i1, ')=', g12.5 )
702 9996 FORMAT( ' TRANS=''', a1, ''', N=', i5, ', KL=', i5, ', KU=', i5,
703 $ ', NRHS=', i3, ', type ', i1, ', test(', i1, ')=', g12.5 )
704 9995 FORMAT( ' NORM =''', a1, ''', N=', i5, ', KL=', i5, ', KU=', i5,
705 $ ',', 10x, ' type ', i1, ', test(', i1, ')=', g12.5 )
706*
707 RETURN
708*
709* End of ZCHKGB
710*
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
alasum
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
alahd
subroutine alahd(iounit, path)
ALAHD
Definition alahd.f:107
alaerh
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
zlangb
double precision function zlangb(norm, n, kl, ku, ab, ldab, work)
ZLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition zlangb.f:125
zgbtrs
subroutine zgbtrs(trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
ZGBTRS
Definition zgbtrs.f:138
zgbtrf
subroutine zgbtrf(m, n, kl, ku, ab, ldab, ipiv, info)
ZGBTRF
Definition zgbtrf.f:144
zgbcon
subroutine zgbcon(norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond, work, rwork, info)
ZGBCON
Definition zgbcon.f:147
zgbrfs
subroutine zgbrfs(trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
ZGBRFS
Definition zgbrfs.f:206
zlange
double precision function zlange(norm, m, n, a, lda, work)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition zlange.f:115
zlacpy
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
Definition zlacpy.f:103
zlaset
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.
Definition zlaset.f:106
zcopy
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
Definition zcopy.f:81
zlarhs
subroutine zlarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
ZLARHS
Definition zlarhs.f:208
zgbt02
subroutine zgbt02(trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
ZGBT02
Definition zgbt02.f:148
zgbt01
subroutine zgbt01(m, n, kl, ku, a, lda, afac, ldafac, ipiv, work, resid)
ZGBT01
Definition zgbt01.f:126
zget04
subroutine zget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
ZGET04
Definition zget04.f:102
zgbt05
subroutine zgbt05(trans, n, kl, ku, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
ZGBT05
Definition zgbt05.f:176
zerrge
subroutine zerrge(path, nunit)
ZERRGE
Definition zerrge.f:55
zlatb4
subroutine zlatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
ZLATB4
Definition zlatb4.f:121
zlatms
subroutine zlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
ZLATMS
Definition zlatms.f:332
dget06
double precision function dget06(rcond, rcondc)
DGET06
Definition dget06.f:55

◆ zchkge()

subroutine zchkge ( logical, dimension( * ) dotype,
integer nm,
integer, dimension( * ) mval,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKGE

Purpose:
!>
!> ZCHKGE tests ZGETRF, -TRI, -TRS, -RFS, and -CON.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for M or N, used in dimensioning
!>          the work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (max(2*NMAX,2*NSMAX+NWORK))
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 183 of file zchkge.f.

186*
187* -- LAPACK test routine --
188* -- LAPACK is a software package provided by Univ. of Tennessee, --
189* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
190*
191* .. Scalar Arguments ..
192 LOGICAL TSTERR
193 INTEGER NM, NMAX, NN, NNB, NNS, NOUT
194 DOUBLE PRECISION THRESH
195* ..
196* .. Array Arguments ..
197 LOGICAL DOTYPE( * )
198 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
199 $ NVAL( * )
200 DOUBLE PRECISION RWORK( * )
201 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
202 $ WORK( * ), X( * ), XACT( * )
203* ..
204*
205* =====================================================================
206*
207* .. Parameters ..
208 DOUBLE PRECISION ONE, ZERO
209 parameter( one = 1.0d+0, zero = 0.0d+0 )
210 INTEGER NTYPES
211 parameter( ntypes = 11 )
212 INTEGER NTESTS
213 parameter( ntests = 8 )
214 INTEGER NTRAN
215 parameter( ntran = 3 )
216* ..
217* .. Local Scalars ..
218 LOGICAL TRFCON, ZEROT
219 CHARACTER DIST, NORM, TRANS, TYPE, XTYPE
220 CHARACTER*3 PATH
221 INTEGER I, IM, IMAT, IN, INB, INFO, IOFF, IRHS, ITRAN,
222 $ IZERO, K, KL, KU, LDA, LWORK, M, MODE, N, NB,
223 $ NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
224 DOUBLE PRECISION AINVNM, ANORM, ANORMI, ANORMO, CNDNUM, DUMMY,
225 $ RCOND, RCONDC, RCONDI, RCONDO
226* ..
227* .. Local Arrays ..
228 CHARACTER TRANSS( NTRAN )
229 INTEGER ISEED( 4 ), ISEEDY( 4 )
230 DOUBLE PRECISION RESULT( NTESTS )
231* ..
232* .. External Functions ..
233 DOUBLE PRECISION DGET06, ZLANGE
234 EXTERNAL dget06, zlange
235* ..
236* .. External Subroutines ..
237 EXTERNAL alaerh, alahd, alasum, xlaenv, zerrge, zgecon,
238 $ zgerfs, zget01, zget02, zget03, zget04, zget07,
239 $ zgetrf, zgetri, zgetrs, zlacpy, zlarhs, zlaset,
240 $ zlatb4, zlatms
241* ..
242* .. Intrinsic Functions ..
243 INTRINSIC dcmplx, max, min
244* ..
245* .. Scalars in Common ..
246 LOGICAL LERR, OK
247 CHARACTER*32 SRNAMT
248 INTEGER INFOT, NUNIT
249* ..
250* .. Common blocks ..
251 COMMON / infoc / infot, nunit, ok, lerr
252 COMMON / srnamc / srnamt
253* ..
254* .. Data statements ..
255 DATA iseedy / 1988, 1989, 1990, 1991 / ,
256 $ transs / 'N', 'T', 'C' /
257* ..
258* .. Executable Statements ..
259*
260* Initialize constants and the random number seed.
261*
262 path( 1: 1 ) = 'Zomplex precision'
263 path( 2: 3 ) = 'GE'
264 nrun = 0
265 nfail = 0
266 nerrs = 0
267 DO 10 i = 1, 4
268 iseed( i ) = iseedy( i )
269 10 CONTINUE
270*
271* Test the error exits
272*
273 CALL xlaenv( 1, 1 )
274 IF( tsterr )
275 $ CALL zerrge( path, nout )
276 infot = 0
277 CALL xlaenv( 2, 2 )
278*
279* Do for each value of M in MVAL
280*
281 DO 120 im = 1, nm
282 m = mval( im )
283 lda = max( 1, m )
284*
285* Do for each value of N in NVAL
286*
287 DO 110 in = 1, nn
288 n = nval( in )
289 xtype = 'N'
290 nimat = ntypes
291 IF( m.LE.0 .OR. n.LE.0 )
292 $ nimat = 1
293*
294 DO 100 imat = 1, nimat
295*
296* Do the tests only if DOTYPE( IMAT ) is true.
297*
298 IF( .NOT.dotype( imat ) )
299 $ GO TO 100
300*
301* Skip types 5, 6, or 7 if the matrix size is too small.
302*
303 zerot = imat.GE.5 .AND. imat.LE.7
304 IF( zerot .AND. n.LT.imat-4 )
305 $ GO TO 100
306*
307* Set up parameters with ZLATB4 and generate a test matrix
308* with ZLATMS.
309*
310 CALL zlatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
311 $ CNDNUM, DIST )
312*
313 srnamt = 'ZLATMS'
314 CALL zlatms( m, n, dist, iseed, TYPE, RWORK, MODE,
315 $ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
316 $ WORK, INFO )
317*
318* Check error code from ZLATMS.
319*
320 IF( info.NE.0 ) THEN
321 CALL alaerh( path, 'ZLATMS', info, 0, ' ', m, n, -1,
322 $ -1, -1, imat, nfail, nerrs, nout )
323 GO TO 100
324 END IF
325*
326* For types 5-7, zero one or more columns of the matrix to
327* test that INFO is returned correctly.
328*
329 IF( zerot ) THEN
330 IF( imat.EQ.5 ) THEN
331 izero = 1
332 ELSE IF( imat.EQ.6 ) THEN
333 izero = min( m, n )
334 ELSE
335 izero = min( m, n ) / 2 + 1
336 END IF
337 ioff = ( izero-1 )*lda
338 IF( imat.LT.7 ) THEN
339 DO 20 i = 1, m
340 a( ioff+i ) = zero
341 20 CONTINUE
342 ELSE
343 CALL zlaset( 'Full', m, n-izero+1, dcmplx( zero ),
344 $ dcmplx( zero ), a( ioff+1 ), lda )
345 END IF
346 ELSE
347 izero = 0
348 END IF
349*
350* These lines, if used in place of the calls in the DO 60
351* loop, cause the code to bomb on a Sun SPARCstation.
352*
353* ANORMO = ZLANGE( 'O', M, N, A, LDA, RWORK )
354* ANORMI = ZLANGE( 'I', M, N, A, LDA, RWORK )
355*
356* Do for each blocksize in NBVAL
357*
358 DO 90 inb = 1, nnb
359 nb = nbval( inb )
360 CALL xlaenv( 1, nb )
361*
362* Compute the LU factorization of the matrix.
363*
364 CALL zlacpy( 'Full', m, n, a, lda, afac, lda )
365 srnamt = 'ZGETRF'
366 CALL zgetrf( m, n, afac, lda, iwork, info )
367*
368* Check error code from ZGETRF.
369*
370 IF( info.NE.izero )
371 $ CALL alaerh( path, 'ZGETRF', info, izero, ' ', m,
372 $ n, -1, -1, nb, imat, nfail, nerrs,
373 $ nout )
374 trfcon = .false.
375*
376*+ TEST 1
377* Reconstruct matrix from factors and compute residual.
378*
379 CALL zlacpy( 'Full', m, n, afac, lda, ainv, lda )
380 CALL zget01( m, n, a, lda, ainv, lda, iwork, rwork,
381 $ result( 1 ) )
382 nt = 1
383*
384*+ TEST 2
385* Form the inverse if the factorization was successful
386* and compute the residual.
387*
388 IF( m.EQ.n .AND. info.EQ.0 ) THEN
389 CALL zlacpy( 'Full', n, n, afac, lda, ainv, lda )
390 srnamt = 'ZGETRI'
391 nrhs = nsval( 1 )
392 lwork = nmax*max( 3, nrhs )
393 CALL zgetri( n, ainv, lda, iwork, work, lwork,
394 $ info )
395*
396* Check error code from ZGETRI.
397*
398 IF( info.NE.0 )
399 $ CALL alaerh( path, 'ZGETRI', info, 0, ' ', n, n,
400 $ -1, -1, nb, imat, nfail, nerrs,
401 $ nout )
402*
403* Compute the residual for the matrix times its
404* inverse. Also compute the 1-norm condition number
405* of A.
406*
407 CALL zget03( n, a, lda, ainv, lda, work, lda,
408 $ rwork, rcondo, result( 2 ) )
409 anormo = zlange( 'O', m, n, a, lda, rwork )
410*
411* Compute the infinity-norm condition number of A.
412*
413 anormi = zlange( 'I', m, n, a, lda, rwork )
414 ainvnm = zlange( 'I', n, n, ainv, lda, rwork )
415 IF( anormi.LE.zero .OR. ainvnm.LE.zero ) THEN
416 rcondi = one
417 ELSE
418 rcondi = ( one / anormi ) / ainvnm
419 END IF
420 nt = 2
421 ELSE
422*
423* Do only the condition estimate if INFO > 0.
424*
425 trfcon = .true.
426 anormo = zlange( 'O', m, n, a, lda, rwork )
427 anormi = zlange( 'I', m, n, a, lda, rwork )
428 rcondo = zero
429 rcondi = zero
430 END IF
431*
432* Print information about the tests so far that did not
433* pass the threshold.
434*
435 DO 30 k = 1, nt
436 IF( result( k ).GE.thresh ) THEN
437 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
438 $ CALL alahd( nout, path )
439 WRITE( nout, fmt = 9999 )m, n, nb, imat, k,
440 $ result( k )
441 nfail = nfail + 1
442 END IF
443 30 CONTINUE
444 nrun = nrun + nt
445*
446* Skip the remaining tests if this is not the first
447* block size or if M .ne. N. Skip the solve tests if
448* the matrix is singular.
449*
450 IF( inb.GT.1 .OR. m.NE.n )
451 $ GO TO 90
452 IF( trfcon )
453 $ GO TO 70
454*
455 DO 60 irhs = 1, nns
456 nrhs = nsval( irhs )
457 xtype = 'N'
458*
459 DO 50 itran = 1, ntran
460 trans = transs( itran )
461 IF( itran.EQ.1 ) THEN
462 rcondc = rcondo
463 ELSE
464 rcondc = rcondi
465 END IF
466*
467*+ TEST 3
468* Solve and compute residual for A * X = B.
469*
470 srnamt = 'ZLARHS'
471 CALL zlarhs( path, xtype, ' ', trans, n, n, kl,
472 $ ku, nrhs, a, lda, xact, lda, b,
473 $ lda, iseed, info )
474 xtype = 'C'
475*
476 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
477 srnamt = 'ZGETRS'
478 CALL zgetrs( trans, n, nrhs, afac, lda, iwork,
479 $ x, lda, info )
480*
481* Check error code from ZGETRS.
482*
483 IF( info.NE.0 )
484 $ CALL alaerh( path, 'ZGETRS', info, 0, trans,
485 $ n, n, -1, -1, nrhs, imat, nfail,
486 $ nerrs, nout )
487*
488 CALL zlacpy( 'Full', n, nrhs, b, lda, work,
489 $ lda )
490 CALL zget02( trans, n, n, nrhs, a, lda, x, lda,
491 $ work, lda, rwork, result( 3 ) )
492*
493*+ TEST 4
494* Check solution from generated exact solution.
495*
496 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
497 $ result( 4 ) )
498*
499*+ TESTS 5, 6, and 7
500* Use iterative refinement to improve the
501* solution.
502*
503 srnamt = 'ZGERFS'
504 CALL zgerfs( trans, n, nrhs, a, lda, afac, lda,
505 $ iwork, b, lda, x, lda, rwork,
506 $ rwork( nrhs+1 ), work,
507 $ rwork( 2*nrhs+1 ), info )
508*
509* Check error code from ZGERFS.
510*
511 IF( info.NE.0 )
512 $ CALL alaerh( path, 'ZGERFS', info, 0, trans,
513 $ n, n, -1, -1, nrhs, imat, nfail,
514 $ nerrs, nout )
515*
516 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
517 $ result( 5 ) )
518 CALL zget07( trans, n, nrhs, a, lda, b, lda, x,
519 $ lda, xact, lda, rwork, .true.,
520 $ rwork( nrhs+1 ), result( 6 ) )
521*
522* Print information about the tests that did not
523* pass the threshold.
524*
525 DO 40 k = 3, 7
526 IF( result( k ).GE.thresh ) THEN
527 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
528 $ CALL alahd( nout, path )
529 WRITE( nout, fmt = 9998 )trans, n, nrhs,
530 $ imat, k, result( k )
531 nfail = nfail + 1
532 END IF
533 40 CONTINUE
534 nrun = nrun + 5
535 50 CONTINUE
536 60 CONTINUE
537*
538*+ TEST 8
539* Get an estimate of RCOND = 1/CNDNUM.
540*
541 70 CONTINUE
542 DO 80 itran = 1, 2
543 IF( itran.EQ.1 ) THEN
544 anorm = anormo
545 rcondc = rcondo
546 norm = 'O'
547 ELSE
548 anorm = anormi
549 rcondc = rcondi
550 norm = 'I'
551 END IF
552 srnamt = 'ZGECON'
553 CALL zgecon( norm, n, afac, lda, anorm, rcond,
554 $ work, rwork, info )
555*
556* Check error code from ZGECON.
557*
558 IF( info.NE.0 )
559 $ CALL alaerh( path, 'ZGECON', info, 0, norm, n,
560 $ n, -1, -1, -1, imat, nfail, nerrs,
561 $ nout )
562*
563* This line is needed on a Sun SPARCstation.
564*
565 dummy = rcond
566*
567 result( 8 ) = dget06( rcond, rcondc )
568*
569* Print information about the tests that did not pass
570* the threshold.
571*
572 IF( result( 8 ).GE.thresh ) THEN
573 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
574 $ CALL alahd( nout, path )
575 WRITE( nout, fmt = 9997 )norm, n, imat, 8,
576 $ result( 8 )
577 nfail = nfail + 1
578 END IF
579 nrun = nrun + 1
580 80 CONTINUE
581 90 CONTINUE
582 100 CONTINUE
583*
584 110 CONTINUE
585 120 CONTINUE
586*
587* Print a summary of the results.
588*
589 CALL alasum( path, nout, nfail, nrun, nerrs )
590*
591 9999 FORMAT( ' M = ', i5, ', N =', i5, ', NB =', i4, ', type ', i2,
592 $ ', test(', i2, ') =', g12.5 )
593 9998 FORMAT( ' TRANS=''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
594 $ i2, ', test(', i2, ') =', g12.5 )
595 9997 FORMAT( ' NORM =''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
596 $ ', test(', i2, ') =', g12.5 )
597 RETURN
598*
599* End of ZCHKGE
600*
zgerfs
subroutine zgerfs(trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
ZGERFS
Definition zgerfs.f:186
zgetri
subroutine zgetri(n, a, lda, ipiv, work, lwork, info)
ZGETRI
Definition zgetri.f:114
zgecon
subroutine zgecon(norm, n, a, lda, anorm, rcond, work, rwork, info)
ZGECON
Definition zgecon.f:124
zgetrs
subroutine zgetrs(trans, n, nrhs, a, lda, ipiv, b, ldb, info)
ZGETRS
Definition zgetrs.f:121
zget02
subroutine zget02(trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
ZGET02
Definition zget02.f:134
zget07
subroutine zget07(trans, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, chkferr, berr, reslts)
ZGET07
Definition zget07.f:166
zget03
subroutine zget03(n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
ZGET03
Definition zget03.f:110
zget01
subroutine zget01(m, n, a, lda, afac, ldafac, ipiv, rwork, resid)
ZGET01
Definition zget01.f:108
zgetrf
subroutine zgetrf(m, n, a, lda, ipiv, info)
ZGETRF VARIANT: Crout Level 3 BLAS version of the algorithm.
Definition zgetrf.f:102

◆ zchkgt()

subroutine zchkgt ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
complex*16, dimension( * ) a,
complex*16, dimension( * ) af,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKGT

Purpose:
!>
!> ZCHKGT tests ZGTTRF, -TRS, -RFS, and -CON
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*4)
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (NMAX*4)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (max(NMAX)+2*NSMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 145 of file zchkgt.f.

147*
148* -- LAPACK test routine --
149* -- LAPACK is a software package provided by Univ. of Tennessee, --
150* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
151*
152* .. Scalar Arguments ..
153 LOGICAL TSTERR
154 INTEGER NN, NNS, NOUT
155 DOUBLE PRECISION THRESH
156* ..
157* .. Array Arguments ..
158 LOGICAL DOTYPE( * )
159 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
160 DOUBLE PRECISION RWORK( * )
161 COMPLEX*16 A( * ), AF( * ), B( * ), WORK( * ), X( * ),
162 $ XACT( * )
163* ..
164*
165* =====================================================================
166*
167* .. Parameters ..
168 DOUBLE PRECISION ONE, ZERO
169 parameter( one = 1.0d+0, zero = 0.0d+0 )
170 INTEGER NTYPES
171 parameter( ntypes = 12 )
172 INTEGER NTESTS
173 parameter( ntests = 7 )
174* ..
175* .. Local Scalars ..
176 LOGICAL TRFCON, ZEROT
177 CHARACTER DIST, NORM, TRANS, TYPE
178 CHARACTER*3 PATH
179 INTEGER I, IMAT, IN, INFO, IRHS, ITRAN, IX, IZERO, J,
180 $ K, KL, KOFF, KU, LDA, M, MODE, N, NERRS, NFAIL,
181 $ NIMAT, NRHS, NRUN
182 DOUBLE PRECISION AINVNM, ANORM, COND, RCOND, RCONDC, RCONDI,
183 $ RCONDO
184* ..
185* .. Local Arrays ..
186 CHARACTER TRANSS( 3 )
187 INTEGER ISEED( 4 ), ISEEDY( 4 )
188 DOUBLE PRECISION RESULT( NTESTS )
189 COMPLEX*16 Z( 3 )
190* ..
191* .. External Functions ..
192 DOUBLE PRECISION DGET06, DZASUM, ZLANGT
193 EXTERNAL dget06, dzasum, zlangt
194* ..
195* .. External Subroutines ..
196 EXTERNAL alaerh, alahd, alasum, zcopy, zdscal, zerrge,
197 $ zget04, zgtcon, zgtrfs, zgtt01, zgtt02, zgtt05,
198 $ zgttrf, zgttrs, zlacpy, zlagtm, zlarnv, zlatb4,
199 $ zlatms
200* ..
201* .. Intrinsic Functions ..
202 INTRINSIC max
203* ..
204* .. Scalars in Common ..
205 LOGICAL LERR, OK
206 CHARACTER*32 SRNAMT
207 INTEGER INFOT, NUNIT
208* ..
209* .. Common blocks ..
210 COMMON / infoc / infot, nunit, ok, lerr
211 COMMON / srnamc / srnamt
212* ..
213* .. Data statements ..
214 DATA iseedy / 0, 0, 0, 1 / , transs / 'N', 'T',
215 $ 'C' /
216* ..
217* .. Executable Statements ..
218*
219 path( 1: 1 ) = 'Zomplex precision'
220 path( 2: 3 ) = 'GT'
221 nrun = 0
222 nfail = 0
223 nerrs = 0
224 DO 10 i = 1, 4
225 iseed( i ) = iseedy( i )
226 10 CONTINUE
227*
228* Test the error exits
229*
230 IF( tsterr )
231 $ CALL zerrge( path, nout )
232 infot = 0
233*
234 DO 110 in = 1, nn
235*
236* Do for each value of N in NVAL.
237*
238 n = nval( in )
239 m = max( n-1, 0 )
240 lda = max( 1, n )
241 nimat = ntypes
242 IF( n.LE.0 )
243 $ nimat = 1
244*
245 DO 100 imat = 1, nimat
246*
247* Do the tests only if DOTYPE( IMAT ) is true.
248*
249 IF( .NOT.dotype( imat ) )
250 $ GO TO 100
251*
252* Set up parameters with ZLATB4.
253*
254 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
255 $ COND, DIST )
256*
257 zerot = imat.GE.8 .AND. imat.LE.10
258 IF( imat.LE.6 ) THEN
259*
260* Types 1-6: generate matrices of known condition number.
261*
262 koff = max( 2-ku, 3-max( 1, n ) )
263 srnamt = 'ZLATMS'
264 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE, COND,
265 $ ANORM, KL, KU, 'Z', AF( KOFF ), 3, WORK,
266 $ INFO )
267*
268* Check the error code from ZLATMS.
269*
270 IF( info.NE.0 ) THEN
271 CALL alaerh( path, 'ZLATMS', info, 0, ' ', n, n, kl,
272 $ ku, -1, imat, nfail, nerrs, nout )
273 GO TO 100
274 END IF
275 izero = 0
276*
277 IF( n.GT.1 ) THEN
278 CALL zcopy( n-1, af( 4 ), 3, a, 1 )
279 CALL zcopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
280 END IF
281 CALL zcopy( n, af( 2 ), 3, a( m+1 ), 1 )
282 ELSE
283*
284* Types 7-12: generate tridiagonal matrices with
285* unknown condition numbers.
286*
287 IF( .NOT.zerot .OR. .NOT.dotype( 7 ) ) THEN
288*
289* Generate a matrix with elements whose real and
290* imaginary parts are from [-1,1].
291*
292 CALL zlarnv( 2, iseed, n+2*m, a )
293 IF( anorm.NE.one )
294 $ CALL zdscal( n+2*m, anorm, a, 1 )
295 ELSE IF( izero.GT.0 ) THEN
296*
297* Reuse the last matrix by copying back the zeroed out
298* elements.
299*
300 IF( izero.EQ.1 ) THEN
301 a( n ) = z( 2 )
302 IF( n.GT.1 )
303 $ a( 1 ) = z( 3 )
304 ELSE IF( izero.EQ.n ) THEN
305 a( 3*n-2 ) = z( 1 )
306 a( 2*n-1 ) = z( 2 )
307 ELSE
308 a( 2*n-2+izero ) = z( 1 )
309 a( n-1+izero ) = z( 2 )
310 a( izero ) = z( 3 )
311 END IF
312 END IF
313*
314* If IMAT > 7, set one column of the matrix to 0.
315*
316 IF( .NOT.zerot ) THEN
317 izero = 0
318 ELSE IF( imat.EQ.8 ) THEN
319 izero = 1
320 z( 2 ) = a( n )
321 a( n ) = zero
322 IF( n.GT.1 ) THEN
323 z( 3 ) = a( 1 )
324 a( 1 ) = zero
325 END IF
326 ELSE IF( imat.EQ.9 ) THEN
327 izero = n
328 z( 1 ) = a( 3*n-2 )
329 z( 2 ) = a( 2*n-1 )
330 a( 3*n-2 ) = zero
331 a( 2*n-1 ) = zero
332 ELSE
333 izero = ( n+1 ) / 2
334 DO 20 i = izero, n - 1
335 a( 2*n-2+i ) = zero
336 a( n-1+i ) = zero
337 a( i ) = zero
338 20 CONTINUE
339 a( 3*n-2 ) = zero
340 a( 2*n-1 ) = zero
341 END IF
342 END IF
343*
344*+ TEST 1
345* Factor A as L*U and compute the ratio
346* norm(L*U - A) / (n * norm(A) * EPS )
347*
348 CALL zcopy( n+2*m, a, 1, af, 1 )
349 srnamt = 'ZGTTRF'
350 CALL zgttrf( n, af, af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
351 $ iwork, info )
352*
353* Check error code from ZGTTRF.
354*
355 IF( info.NE.izero )
356 $ CALL alaerh( path, 'ZGTTRF', info, izero, ' ', n, n, 1,
357 $ 1, -1, imat, nfail, nerrs, nout )
358 trfcon = info.NE.0
359*
360 CALL zgtt01( n, a, a( m+1 ), a( n+m+1 ), af, af( m+1 ),
361 $ af( n+m+1 ), af( n+2*m+1 ), iwork, work, lda,
362 $ rwork, result( 1 ) )
363*
364* Print the test ratio if it is .GE. THRESH.
365*
366 IF( result( 1 ).GE.thresh ) THEN
367 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
368 $ CALL alahd( nout, path )
369 WRITE( nout, fmt = 9999 )n, imat, 1, result( 1 )
370 nfail = nfail + 1
371 END IF
372 nrun = nrun + 1
373*
374 DO 50 itran = 1, 2
375 trans = transs( itran )
376 IF( itran.EQ.1 ) THEN
377 norm = 'O'
378 ELSE
379 norm = 'I'
380 END IF
381 anorm = zlangt( norm, n, a, a( m+1 ), a( n+m+1 ) )
382*
383 IF( .NOT.trfcon ) THEN
384*
385* Use ZGTTRS to solve for one column at a time of
386* inv(A), computing the maximum column sum as we go.
387*
388 ainvnm = zero
389 DO 40 i = 1, n
390 DO 30 j = 1, n
391 x( j ) = zero
392 30 CONTINUE
393 x( i ) = one
394 CALL zgttrs( trans, n, 1, af, af( m+1 ),
395 $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
396 $ lda, info )
397 ainvnm = max( ainvnm, dzasum( n, x, 1 ) )
398 40 CONTINUE
399*
400* Compute RCONDC = 1 / (norm(A) * norm(inv(A))
401*
402 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
403 rcondc = one
404 ELSE
405 rcondc = ( one / anorm ) / ainvnm
406 END IF
407 IF( itran.EQ.1 ) THEN
408 rcondo = rcondc
409 ELSE
410 rcondi = rcondc
411 END IF
412 ELSE
413 rcondc = zero
414 END IF
415*
416*+ TEST 7
417* Estimate the reciprocal of the condition number of the
418* matrix.
419*
420 srnamt = 'ZGTCON'
421 CALL zgtcon( norm, n, af, af( m+1 ), af( n+m+1 ),
422 $ af( n+2*m+1 ), iwork, anorm, rcond, work,
423 $ info )
424*
425* Check error code from ZGTCON.
426*
427 IF( info.NE.0 )
428 $ CALL alaerh( path, 'ZGTCON', info, 0, norm, n, n, -1,
429 $ -1, -1, imat, nfail, nerrs, nout )
430*
431 result( 7 ) = dget06( rcond, rcondc )
432*
433* Print the test ratio if it is .GE. THRESH.
434*
435 IF( result( 7 ).GE.thresh ) THEN
436 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
437 $ CALL alahd( nout, path )
438 WRITE( nout, fmt = 9997 )norm, n, imat, 7,
439 $ result( 7 )
440 nfail = nfail + 1
441 END IF
442 nrun = nrun + 1
443 50 CONTINUE
444*
445* Skip the remaining tests if the matrix is singular.
446*
447 IF( trfcon )
448 $ GO TO 100
449*
450 DO 90 irhs = 1, nns
451 nrhs = nsval( irhs )
452*
453* Generate NRHS random solution vectors.
454*
455 ix = 1
456 DO 60 j = 1, nrhs
457 CALL zlarnv( 2, iseed, n, xact( ix ) )
458 ix = ix + lda
459 60 CONTINUE
460*
461 DO 80 itran = 1, 3
462 trans = transs( itran )
463 IF( itran.EQ.1 ) THEN
464 rcondc = rcondo
465 ELSE
466 rcondc = rcondi
467 END IF
468*
469* Set the right hand side.
470*
471 CALL zlagtm( trans, n, nrhs, one, a, a( m+1 ),
472 $ a( n+m+1 ), xact, lda, zero, b, lda )
473*
474*+ TEST 2
475* Solve op(A) * X = B and compute the residual.
476*
477 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
478 srnamt = 'ZGTTRS'
479 CALL zgttrs( trans, n, nrhs, af, af( m+1 ),
480 $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
481 $ lda, info )
482*
483* Check error code from ZGTTRS.
484*
485 IF( info.NE.0 )
486 $ CALL alaerh( path, 'ZGTTRS', info, 0, trans, n, n,
487 $ -1, -1, nrhs, imat, nfail, nerrs,
488 $ nout )
489*
490 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
491 CALL zgtt02( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
492 $ x, lda, work, lda, result( 2 ) )
493*
494*+ TEST 3
495* Check solution from generated exact solution.
496*
497 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
498 $ result( 3 ) )
499*
500*+ TESTS 4, 5, and 6
501* Use iterative refinement to improve the solution.
502*
503 srnamt = 'ZGTRFS'
504 CALL zgtrfs( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
505 $ af, af( m+1 ), af( n+m+1 ),
506 $ af( n+2*m+1 ), iwork, b, lda, x, lda,
507 $ rwork, rwork( nrhs+1 ), work,
508 $ rwork( 2*nrhs+1 ), info )
509*
510* Check error code from ZGTRFS.
511*
512 IF( info.NE.0 )
513 $ CALL alaerh( path, 'ZGTRFS', info, 0, trans, n, n,
514 $ -1, -1, nrhs, imat, nfail, nerrs,
515 $ nout )
516*
517 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
518 $ result( 4 ) )
519 CALL zgtt05( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
520 $ b, lda, x, lda, xact, lda, rwork,
521 $ rwork( nrhs+1 ), result( 5 ) )
522*
523* Print information about the tests that did not pass the
524* threshold.
525*
526 DO 70 k = 2, 6
527 IF( result( k ).GE.thresh ) THEN
528 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
529 $ CALL alahd( nout, path )
530 WRITE( nout, fmt = 9998 )trans, n, nrhs, imat,
531 $ k, result( k )
532 nfail = nfail + 1
533 END IF
534 70 CONTINUE
535 nrun = nrun + 5
536 80 CONTINUE
537 90 CONTINUE
538 100 CONTINUE
539 110 CONTINUE
540*
541* Print a summary of the results.
542*
543 CALL alasum( path, nout, nfail, nrun, nerrs )
544*
545 9999 FORMAT( 12x, 'N =', i5, ',', 10x, ' type ', i2, ', test(', i2,
546 $ ') = ', g12.5 )
547 9998 FORMAT( ' TRANS=''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
548 $ i2, ', test(', i2, ') = ', g12.5 )
549 9997 FORMAT( ' NORM =''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
550 $ ', test(', i2, ') = ', g12.5 )
551 RETURN
552*
553* End of ZCHKGT
554*
zgtrfs
subroutine zgtrfs(trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
ZGTRFS
Definition zgtrfs.f:210
zgtcon
subroutine zgtcon(norm, n, dl, d, du, du2, ipiv, anorm, rcond, work, info)
ZGTCON
Definition zgtcon.f:141
zgttrs
subroutine zgttrs(trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb, info)
ZGTTRS
Definition zgttrs.f:138
zgttrf
subroutine zgttrf(n, dl, d, du, du2, ipiv, info)
ZGTTRF
Definition zgttrf.f:124
zlangt
double precision function zlangt(norm, n, dl, d, du)
ZLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition zlangt.f:106
zlarnv
subroutine zlarnv(idist, iseed, n, x)
ZLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition zlarnv.f:99
zlagtm
subroutine zlagtm(trans, n, nrhs, alpha, dl, d, du, x, ldx, beta, b, ldb)
ZLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix,...
Definition zlagtm.f:145
zdscal
subroutine zdscal(n, da, zx, incx)
ZDSCAL
Definition zdscal.f:78
zgtt05
subroutine zgtt05(trans, n, nrhs, dl, d, du, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
ZGTT05
Definition zgtt05.f:165
zgtt01
subroutine zgtt01(n, dl, d, du, dlf, df, duf, du2, ipiv, work, ldwork, rwork, resid)
ZGTT01
Definition zgtt01.f:134
zgtt02
subroutine zgtt02(trans, n, nrhs, dl, d, du, x, ldx, b, ldb, resid)
ZGTT02
Definition zgtt02.f:124
dzasum
double precision function dzasum(n, zx, incx)
DZASUM
Definition dzasum.f:72

◆ zchkhe()

subroutine zchkhe ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKHE

Purpose:
!>
!> ZCHKHE tests ZHETRF, -TRI2, -TRS, -TRS2, -RFS, and -CON.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX))
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 168 of file zchkhe.f.

171*
172* -- LAPACK test routine --
173* -- LAPACK is a software package provided by Univ. of Tennessee, --
174* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
175*
176* .. Scalar Arguments ..
177 LOGICAL TSTERR
178 INTEGER NMAX, NN, NNB, NNS, NOUT
179 DOUBLE PRECISION THRESH
180* ..
181* .. Array Arguments ..
182 LOGICAL DOTYPE( * )
183 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
184 DOUBLE PRECISION RWORK( * )
185 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
186 $ WORK( * ), X( * ), XACT( * )
187* ..
188*
189* =====================================================================
190*
191* .. Parameters ..
192 DOUBLE PRECISION ZERO
193 parameter( zero = 0.0d+0 )
194 COMPLEX*16 CZERO
195 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
196 INTEGER NTYPES
197 parameter( ntypes = 10 )
198 INTEGER NTESTS
199 parameter( ntests = 9 )
200* ..
201* .. Local Scalars ..
202 LOGICAL TRFCON, ZEROT
203 CHARACTER DIST, TYPE, UPLO, XTYPE
204 CHARACTER*3 PATH
205 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
206 $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
207 $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
208 DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
209* ..
210* .. Local Arrays ..
211 CHARACTER UPLOS( 2 )
212 INTEGER ISEED( 4 ), ISEEDY( 4 )
213 DOUBLE PRECISION RESULT( NTESTS )
214* ..
215* .. External Functions ..
216 DOUBLE PRECISION DGET06, ZLANHE
217 EXTERNAL dget06, zlanhe
218* ..
219* .. External Subroutines ..
220 EXTERNAL alaerh, alahd, alasum, xlaenv, zerrhe, zget04,
221 $ zhecon, zherfs, zhet01, zhetrf, zhetri2,
222 $ zhetrs, zlacpy, zlaipd, zlarhs, zlatb4, zlatms,
223 $ zpot02, zpot03, zpot05
224* ..
225* .. Intrinsic Functions ..
226 INTRINSIC max, min
227* ..
228* .. Scalars in Common ..
229 LOGICAL LERR, OK
230 CHARACTER*32 SRNAMT
231 INTEGER INFOT, NUNIT
232* ..
233* .. Common blocks ..
234 COMMON / infoc / infot, nunit, ok, lerr
235 COMMON / srnamc / srnamt
236* ..
237* .. Data statements ..
238 DATA iseedy / 1988, 1989, 1990, 1991 /
239 DATA uplos / 'U', 'L' /
240* ..
241* .. Executable Statements ..
242*
243* Initialize constants and the random number seed.
244*
245 path( 1: 1 ) = 'Zomplex precision'
246 path( 2: 3 ) = 'HE'
247 nrun = 0
248 nfail = 0
249 nerrs = 0
250 DO 10 i = 1, 4
251 iseed( i ) = iseedy( i )
252 10 CONTINUE
253*
254* Test the error exits
255*
256 IF( tsterr )
257 $ CALL zerrhe( path, nout )
258 infot = 0
259*
260* Set the minimum block size for which the block routine should
261* be used, which will be later returned by ILAENV
262*
263 CALL xlaenv( 2, 2 )
264*
265* Do for each value of N in NVAL
266*
267 DO 180 in = 1, nn
268 n = nval( in )
269 lda = max( n, 1 )
270 xtype = 'N'
271 nimat = ntypes
272 IF( n.LE.0 )
273 $ nimat = 1
274*
275 izero = 0
276 DO 170 imat = 1, nimat
277*
278* Do the tests only if DOTYPE( IMAT ) is true.
279*
280 IF( .NOT.dotype( imat ) )
281 $ GO TO 170
282*
283* Skip types 3, 4, 5, or 6 if the matrix size is too small.
284*
285 zerot = imat.GE.3 .AND. imat.LE.6
286 IF( zerot .AND. n.LT.imat-2 )
287 $ GO TO 170
288*
289* Do first for UPLO = 'U', then for UPLO = 'L'
290*
291 DO 160 iuplo = 1, 2
292 uplo = uplos( iuplo )
293*
294* Set up parameters with ZLATB4 for the matrix generator
295* based on the type of matrix to be generated.
296*
297 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
298 $ CNDNUM, DIST )
299*
300* Generate a matrix with ZLATMS.
301*
302 srnamt = 'ZLATMS'
303 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
304 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
305 $ INFO )
306*
307* Check error code from ZLATMS and handle error.
308*
309 IF( info.NE.0 ) THEN
310 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n, -1,
311 $ -1, -1, imat, nfail, nerrs, nout )
312*
313* Skip all tests for this generated matrix
314*
315 GO TO 160
316 END IF
317*
318* For types 3-6, zero one or more rows and columns of
319* the matrix to test that INFO is returned correctly.
320*
321 IF( zerot ) THEN
322 IF( imat.EQ.3 ) THEN
323 izero = 1
324 ELSE IF( imat.EQ.4 ) THEN
325 izero = n
326 ELSE
327 izero = n / 2 + 1
328 END IF
329*
330 IF( imat.LT.6 ) THEN
331*
332* Set row and column IZERO to zero.
333*
334 IF( iuplo.EQ.1 ) THEN
335 ioff = ( izero-1 )*lda
336 DO 20 i = 1, izero - 1
337 a( ioff+i ) = czero
338 20 CONTINUE
339 ioff = ioff + izero
340 DO 30 i = izero, n
341 a( ioff ) = czero
342 ioff = ioff + lda
343 30 CONTINUE
344 ELSE
345 ioff = izero
346 DO 40 i = 1, izero - 1
347 a( ioff ) = czero
348 ioff = ioff + lda
349 40 CONTINUE
350 ioff = ioff - izero
351 DO 50 i = izero, n
352 a( ioff+i ) = czero
353 50 CONTINUE
354 END IF
355 ELSE
356 IF( iuplo.EQ.1 ) THEN
357*
358* Set the first IZERO rows and columns to zero.
359*
360 ioff = 0
361 DO 70 j = 1, n
362 i2 = min( j, izero )
363 DO 60 i = 1, i2
364 a( ioff+i ) = czero
365 60 CONTINUE
366 ioff = ioff + lda
367 70 CONTINUE
368 ELSE
369*
370* Set the last IZERO rows and columns to zero.
371*
372 ioff = 0
373 DO 90 j = 1, n
374 i1 = max( j, izero )
375 DO 80 i = i1, n
376 a( ioff+i ) = czero
377 80 CONTINUE
378 ioff = ioff + lda
379 90 CONTINUE
380 END IF
381 END IF
382 ELSE
383 izero = 0
384 END IF
385*
386* End generate test matrix A.
387*
388*
389* Set the imaginary part of the diagonals.
390*
391 CALL zlaipd( n, a, lda+1, 0 )
392*
393* Do for each value of NB in NBVAL
394*
395 DO 150 inb = 1, nnb
396*
397* Set the optimal blocksize, which will be later
398* returned by ILAENV.
399*
400 nb = nbval( inb )
401 CALL xlaenv( 1, nb )
402*
403* Copy the test matrix A into matrix AFAC which
404* will be factorized in place. This is needed to
405* preserve the test matrix A for subsequent tests.
406*
407 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
408*
409* Compute the L*D*L**T or U*D*U**T factorization of the
410* matrix. IWORK stores details of the interchanges and
411* the block structure of D. AINV is a work array for
412* block factorization, LWORK is the length of AINV.
413*
414 lwork = max( 2, nb )*lda
415 srnamt = 'ZHETRF'
416 CALL zhetrf( uplo, n, afac, lda, iwork, ainv, lwork,
417 $ info )
418*
419* Adjust the expected value of INFO to account for
420* pivoting.
421*
422 k = izero
423 IF( k.GT.0 ) THEN
424 100 CONTINUE
425 IF( iwork( k ).LT.0 ) THEN
426 IF( iwork( k ).NE.-k ) THEN
427 k = -iwork( k )
428 GO TO 100
429 END IF
430 ELSE IF( iwork( k ).NE.k ) THEN
431 k = iwork( k )
432 GO TO 100
433 END IF
434 END IF
435*
436* Check error code from ZHETRF and handle error.
437*
438 IF( info.NE.k )
439 $ CALL alaerh( path, 'ZHETRF', info, k, uplo, n, n,
440 $ -1, -1, nb, imat, nfail, nerrs, nout )
441*
442* Set the condition estimate flag if the INFO is not 0.
443*
444 IF( info.NE.0 ) THEN
445 trfcon = .true.
446 ELSE
447 trfcon = .false.
448 END IF
449*
450*+ TEST 1
451* Reconstruct matrix from factors and compute residual.
452*
453 CALL zhet01( uplo, n, a, lda, afac, lda, iwork, ainv,
454 $ lda, rwork, result( 1 ) )
455 nt = 1
456*
457*+ TEST 2
458* Form the inverse and compute the residual.
459*
460 IF( inb.EQ.1 .AND. .NOT.trfcon ) THEN
461 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
462 srnamt = 'ZHETRI2'
463 lwork = (n+nb+1)*(nb+3)
464 CALL zhetri2( uplo, n, ainv, lda, iwork, work,
465 $ lwork, info )
466*
467* Check error code from ZHETRI and handle error.
468*
469 IF( info.NE.0 )
470 $ CALL alaerh( path, 'ZHETRI', info, -1, uplo, n,
471 $ n, -1, -1, -1, imat, nfail, nerrs,
472 $ nout )
473*
474* Compute the residual for a symmetric matrix times
475* its inverse.
476*
477 CALL zpot03( uplo, n, a, lda, ainv, lda, work, lda,
478 $ rwork, rcondc, result( 2 ) )
479 nt = 2
480 END IF
481*
482* Print information about the tests that did not pass
483* the threshold.
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 alahd( nout, path )
489 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
490 $ result( k )
491 nfail = nfail + 1
492 END IF
493 110 CONTINUE
494 nrun = nrun + nt
495*
496* Skip the other tests if this is not the first block
497* size.
498*
499 IF( inb.GT.1 )
500 $ GO TO 150
501*
502* Do only the condition estimate if INFO is not 0.
503*
504 IF( trfcon ) THEN
505 rcondc = zero
506 GO TO 140
507 END IF
508*
509* Do for each value of NRHS in NSVAL.
510*
511 DO 130 irhs = 1, nns
512 nrhs = nsval( irhs )
513*
514*+ TEST 3 (Using TRS)
515* Solve and compute residual for A * X = B.
516*
517* Choose a set of NRHS random solution vectors
518* stored in XACT and set up the right hand side B
519*
520 srnamt = 'ZLARHS'
521 CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
522 $ nrhs, a, lda, xact, lda, b, lda,
523 $ iseed, info )
524 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
525*
526 srnamt = 'ZHETRS'
527 CALL zhetrs( uplo, n, nrhs, afac, lda, iwork, x,
528 $ lda, info )
529*
530* Check error code from ZHETRS and handle error.
531*
532 IF( info.NE.0 )
533 $ CALL alaerh( path, 'ZHETRS', info, 0, uplo, n,
534 $ n, -1, -1, nrhs, imat, nfail,
535 $ nerrs, nout )
536*
537 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
538*
539* Compute the residual for the solution
540*
541 CALL zpot02( uplo, n, nrhs, a, lda, x, lda, work,
542 $ lda, rwork, result( 3 ) )
543*
544*+ TEST 4 (Using TRS2)
545* Solve and compute residual for A * X = B.
546*
547* Choose a set of NRHS random solution vectors
548* stored in XACT and set up the right hand side B
549*
550 srnamt = 'ZLARHS'
551 CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
552 $ nrhs, a, lda, xact, lda, b, lda,
553 $ iseed, info )
554 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
555*
556 srnamt = 'ZHETRS2'
557 CALL zhetrs2( uplo, n, nrhs, afac, lda, iwork, x,
558 $ lda, work, info )
559*
560* Check error code from ZHETRS2 and handle error.
561*
562 IF( info.NE.0 )
563 $ CALL alaerh( path, 'ZHETRS2', info, 0, uplo, n,
564 $ n, -1, -1, nrhs, imat, nfail,
565 $ nerrs, nout )
566*
567 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
568*
569* Compute the residual for the solution
570*
571 CALL zpot02( uplo, n, nrhs, a, lda, x, lda, work,
572 $ lda, rwork, result( 4 ) )
573*
574*+ TEST 5
575* Check solution from generated exact solution.
576*
577 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
578 $ result( 5 ) )
579*
580*+ TESTS 6, 7, and 8
581* Use iterative refinement to improve the solution.
582*
583 srnamt = 'ZHERFS'
584 CALL zherfs( uplo, n, nrhs, a, lda, afac, lda,
585 $ iwork, b, lda, x, lda, rwork,
586 $ rwork( nrhs+1 ), work,
587 $ rwork( 2*nrhs+1 ), info )
588*
589* Check error code from ZHERFS.
590*
591 IF( info.NE.0 )
592 $ CALL alaerh( path, 'ZHERFS', info, 0, uplo, n,
593 $ n, -1, -1, nrhs, imat, nfail,
594 $ nerrs, nout )
595*
596 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
597 $ result( 6 ) )
598 CALL zpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
599 $ xact, lda, rwork, rwork( nrhs+1 ),
600 $ result( 7 ) )
601*
602* Print information about the tests that did not pass
603* the threshold.
604*
605 DO 120 k = 3, 8
606 IF( result( k ).GE.thresh ) THEN
607 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
608 $ CALL alahd( nout, path )
609 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
610 $ imat, k, result( k )
611 nfail = nfail + 1
612 END IF
613 120 CONTINUE
614 nrun = nrun + 6
615*
616* End do for each value of NRHS in NSVAL.
617*
618 130 CONTINUE
619*
620*+ TEST 9
621* Get an estimate of RCOND = 1/CNDNUM.
622*
623 140 CONTINUE
624 anorm = zlanhe( '1', uplo, n, a, lda, rwork )
625 srnamt = 'ZHECON'
626 CALL zhecon( uplo, n, afac, lda, iwork, anorm, rcond,
627 $ work, info )
628*
629* Check error code from ZHECON and handle error.
630*
631 IF( info.NE.0 )
632 $ CALL alaerh( path, 'ZHECON', info, 0, uplo, n, n,
633 $ -1, -1, -1, imat, nfail, nerrs, nout )
634*
635 result( 9 ) = dget06( rcond, rcondc )
636*
637* Print information about the tests that did not pass
638* the threshold.
639*
640 IF( result( 9 ).GE.thresh ) THEN
641 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
642 $ CALL alahd( nout, path )
643 WRITE( nout, fmt = 9997 )uplo, n, imat, 9,
644 $ result( 9 )
645 nfail = nfail + 1
646 END IF
647 nrun = nrun + 1
648 150 CONTINUE
649 160 CONTINUE
650 170 CONTINUE
651 180 CONTINUE
652*
653* Print a summary of the results.
654*
655 CALL alasum( path, nout, nfail, nrun, nerrs )
656*
657 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
658 $ i2, ', test ', i2, ', ratio =', g12.5 )
659 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
660 $ i2, ', test(', i2, ') =', g12.5 )
661 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
662 $ ', test(', i2, ') =', g12.5 )
663 RETURN
664*
665* End of ZCHKHE
666*
zlanhe
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,...
Definition zlanhe.f:124
zhetrf
subroutine zhetrf(uplo, n, a, lda, ipiv, work, lwork, info)
ZHETRF
Definition zhetrf.f:177
zhecon
subroutine zhecon(uplo, n, a, lda, ipiv, anorm, rcond, work, info)
ZHECON
Definition zhecon.f:125
zhetri2
subroutine zhetri2(uplo, n, a, lda, ipiv, work, lwork, info)
ZHETRI2
Definition zhetri2.f:127
zhetrs
subroutine zhetrs(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
ZHETRS
Definition zhetrs.f:120
zherfs
subroutine zherfs(uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
ZHERFS
Definition zherfs.f:192
zhetrs2
subroutine zhetrs2(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, info)
ZHETRS2
Definition zhetrs2.f:127
zpot03
subroutine zpot03(uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
ZPOT03
Definition zpot03.f:126
zerrhe
subroutine zerrhe(path, nunit)
ZERRHE
Definition zerrhe.f:55
zhet01
subroutine zhet01(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
ZHET01
Definition zhet01.f:126
zpot05
subroutine zpot05(uplo, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
ZPOT05
Definition zpot05.f:165
zpot02
subroutine zpot02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
ZPOT02
Definition zpot02.f:127
zlaipd
subroutine zlaipd(n, a, inda, vinda)
ZLAIPD
Definition zlaipd.f:83

◆ zchkhe_aa()

subroutine zchkhe_aa ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKHE_AA

Purpose:
!>
!> ZCHKHE_AA tests ZHETRF_AA, -TRS_AA.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX))
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 168 of file zchkhe_aa.f.

171*
172* -- LAPACK test routine --
173* -- LAPACK is a software package provided by Univ. of Tennessee, --
174* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
175*
176 IMPLICIT NONE
177*
178* .. Scalar Arguments ..
179 LOGICAL TSTERR
180 INTEGER NMAX, NN, NNB, NNS, NOUT
181 DOUBLE PRECISION THRESH
182* ..
183* .. Array Arguments ..
184 LOGICAL DOTYPE( * )
185 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
186 DOUBLE PRECISION RWORK( * )
187 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
188 $ WORK( * ), X( * ), XACT( * )
189* ..
190*
191* =====================================================================
192*
193* .. Parameters ..
194 DOUBLE PRECISION ZERO
195 parameter( zero = 0.0d+0 )
196 COMPLEX*16 CZERO
197 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
198 INTEGER NTYPES
199 parameter( ntypes = 10 )
200 INTEGER NTESTS
201 parameter( ntests = 9 )
202* ..
203* .. Local Scalars ..
204 LOGICAL ZEROT
205 CHARACTER DIST, TYPE, UPLO, XTYPE
206 CHARACTER*3 PATH, MATPATH
207 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
208 $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
209 $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
210 DOUBLE PRECISION ANORM, CNDNUM
211* ..
212* .. Local Arrays ..
213 CHARACTER UPLOS( 2 )
214 INTEGER ISEED( 4 ), ISEEDY( 4 )
215 DOUBLE PRECISION RESULT( NTESTS )
216* ..
217* .. External Subroutines ..
218 EXTERNAL alaerh, alahd, alasum, xlaenv, zerrhe,
219 $ zhet01_aa, zhetrf_aa, zhetrs_aa, zlacpy,
220 $ zlaipd, zlarhs, zlatb4, zlatms, zpot02
221* ..
222* .. Intrinsic Functions ..
223 INTRINSIC max, min
224* ..
225* .. Scalars in Common ..
226 LOGICAL LERR, OK
227 CHARACTER*32 SRNAMT
228 INTEGER INFOT, NUNIT
229* ..
230* .. Common blocks ..
231 COMMON / infoc / infot, nunit, ok, lerr
232 COMMON / srnamc / srnamt
233* ..
234* .. Data statements ..
235 DATA iseedy / 1988, 1989, 1990, 1991 /
236 DATA uplos / 'U', 'L' /
237* ..
238* .. Executable Statements ..
239*
240* Initialize constants and the random number seed.
241*
242* Test path
243*
244 path( 1: 1 ) = 'Zomplex precision'
245 path( 2: 3 ) = 'HA'
246*
247* Path to generate matrices
248*
249 matpath( 1: 1 ) = 'Zomplex precision'
250 matpath( 2: 3 ) = 'HE'
251 nrun = 0
252 nfail = 0
253 nerrs = 0
254 DO 10 i = 1, 4
255 iseed( i ) = iseedy( i )
256 10 CONTINUE
257*
258* Test the error exits
259*
260 IF( tsterr )
261 $ CALL zerrhe( path, nout )
262 infot = 0
263*
264* Set the minimum block size for which the block routine should
265* be used, which will be later returned by ILAENV
266*
267 CALL xlaenv( 2, 2 )
268*
269* Do for each value of N in NVAL
270*
271 DO 180 in = 1, nn
272 n = nval( in )
273 IF( n .GT. nmax ) THEN
274 nfail = nfail + 1
275 WRITE(nout, 9995) 'M ', n, nmax
276 GO TO 180
277 END IF
278 lda = max( n, 1 )
279 xtype = 'N'
280 nimat = ntypes
281 IF( n.LE.0 )
282 $ nimat = 1
283*
284 izero = 0
285 DO 170 imat = 1, nimat
286*
287* Do the tests only if DOTYPE( IMAT ) is true.
288*
289 IF( .NOT.dotype( imat ) )
290 $ GO TO 170
291*
292* Skip types 3, 4, 5, or 6 if the matrix size is too small.
293*
294 zerot = imat.GE.3 .AND. imat.LE.6
295 IF( zerot .AND. n.LT.imat-2 )
296 $ GO TO 170
297*
298* Do first for UPLO = 'U', then for UPLO = 'L'
299*
300 DO 160 iuplo = 1, 2
301 uplo = uplos( iuplo )
302*
303* Set up parameters with ZLATB4 for the matrix generator
304* based on the type of matrix to be generated.
305*
306 CALL zlatb4( matpath, imat, n, n, TYPE, KL, KU,
307 $ ANORM, MODE, CNDNUM, DIST )
308*
309* Generate a matrix with ZLATMS.
310*
311 srnamt = 'ZLATMS'
312 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
313 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
314 $ INFO )
315*
316* Check error code from ZLATMS and handle error.
317*
318 IF( info.NE.0 ) THEN
319 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n, -1,
320 $ -1, -1, imat, nfail, nerrs, nout )
321*
322* Skip all tests for this generated matrix
323*
324 GO TO 160
325 END IF
326*
327* For types 3-6, zero one or more rows and columns of
328* the matrix to test that INFO is returned correctly.
329*
330 IF( zerot ) THEN
331 IF( imat.EQ.3 ) THEN
332 izero = 1
333 ELSE IF( imat.EQ.4 ) THEN
334 izero = n
335 ELSE
336 izero = n / 2 + 1
337 END IF
338*
339 IF( imat.LT.6 ) THEN
340*
341* Set row and column IZERO to zero.
342*
343 IF( iuplo.EQ.1 ) THEN
344 ioff = ( izero-1 )*lda
345 DO 20 i = 1, izero - 1
346 a( ioff+i ) = czero
347 20 CONTINUE
348 ioff = ioff + izero
349 DO 30 i = izero, n
350 a( ioff ) = czero
351 ioff = ioff + lda
352 30 CONTINUE
353 ELSE
354 ioff = izero
355 DO 40 i = 1, izero - 1
356 a( ioff ) = czero
357 ioff = ioff + lda
358 40 CONTINUE
359 ioff = ioff - izero
360 DO 50 i = izero, n
361 a( ioff+i ) = czero
362 50 CONTINUE
363 END IF
364 ELSE
365 IF( iuplo.EQ.1 ) THEN
366*
367* Set the first IZERO rows and columns to zero.
368*
369 ioff = 0
370 DO 70 j = 1, n
371 i2 = min( j, izero )
372 DO 60 i = 1, i2
373 a( ioff+i ) = czero
374 60 CONTINUE
375 ioff = ioff + lda
376 70 CONTINUE
377 izero = 1
378 ELSE
379*
380* Set the last IZERO rows and columns to zero.
381*
382 ioff = 0
383 DO 90 j = 1, n
384 i1 = max( j, izero )
385 DO 80 i = i1, n
386 a( ioff+i ) = czero
387 80 CONTINUE
388 ioff = ioff + lda
389 90 CONTINUE
390 END IF
391 END IF
392 ELSE
393 izero = 0
394 END IF
395*
396* End generate test matrix A.
397*
398*
399* Set the imaginary part of the diagonals.
400*
401 CALL zlaipd( n, a, lda+1, 0 )
402*
403* Do for each value of NB in NBVAL
404*
405 DO 150 inb = 1, nnb
406*
407* Set the optimal blocksize, which will be later
408* returned by ILAENV.
409*
410 nb = nbval( inb )
411 CALL xlaenv( 1, nb )
412*
413* Copy the test matrix A into matrix AFAC which
414* will be factorized in place. This is needed to
415* preserve the test matrix A for subsequent tests.
416*
417 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
418*
419* Compute the L*D*L**T or U*D*U**T factorization of the
420* matrix. IWORK stores details of the interchanges and
421* the block structure of D. AINV is a work array for
422* block factorization, LWORK is the length of AINV.
423*
424 lwork = max( 1, ( nb+1 )*lda )
425 srnamt = 'ZHETRF_AA'
426 CALL zhetrf_aa( uplo, n, afac, lda, iwork, ainv,
427 $ lwork, info )
428*
429* Adjust the expected value of INFO to account for
430* pivoting.
431*
432c IF( IZERO.GT.0 ) THEN
433c J = 1
434c K = IZERO
435c 100 CONTINUE
436c IF( J.EQ.K ) THEN
437c K = IWORK( J )
438c ELSE IF( IWORK( J ).EQ.K ) THEN
439c K = J
440c END IF
441c IF( J.LT.K ) THEN
442c J = J + 1
443c GO TO 100
444c END IF
445c ELSE
446 k = 0
447c END IF
448*
449* Check error code from ZHETRF and handle error.
450*
451 IF( info.NE.k ) THEN
452 CALL alaerh( path, 'ZHETRF_AA', info, k, uplo,
453 $ n, n, -1, -1, nb, imat, nfail, nerrs,
454 $ nout )
455 END IF
456*
457*+ TEST 1
458* Reconstruct matrix from factors and compute residual.
459*
460 CALL zhet01_aa( uplo, n, a, lda, afac, lda, iwork,
461 $ ainv, lda, rwork, result( 1 ) )
462 nt = 1
463*
464*
465* Print information about the tests that did not pass
466* the threshold.
467*
468 DO 110 k = 1, nt
469 IF( result( k ).GE.thresh ) THEN
470 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
471 $ CALL alahd( nout, path )
472 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
473 $ result( k )
474 nfail = nfail + 1
475 END IF
476 110 CONTINUE
477 nrun = nrun + nt
478*
479* Skip solver test if INFO is not 0.
480*
481 IF( info.NE.0 ) THEN
482 GO TO 140
483 END IF
484*
485* Do for each value of NRHS in NSVAL.
486*
487 DO 130 irhs = 1, nns
488 nrhs = nsval( irhs )
489*
490*+ TEST 2 (Using TRS)
491* Solve and compute residual for A * X = B.
492*
493* Choose a set of NRHS random solution vectors
494* stored in XACT and set up the right hand side B
495*
496 srnamt = 'ZLARHS'
497 CALL zlarhs( matpath, xtype, uplo, ' ', n, n,
498 $ kl, ku, nrhs, a, lda, xact, lda,
499 $ b, lda, iseed, info )
500 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
501*
502 srnamt = 'ZHETRS_AA'
503 lwork = max( 1, 3*n-2 )
504 CALL zhetrs_aa( uplo, n, nrhs, afac, lda, iwork,
505 $ x, lda, work, lwork, info )
506*
507* Check error code from ZHETRS and handle error.
508*
509 IF( info.NE.0 ) THEN
510 IF( izero.EQ.0 ) THEN
511 CALL alaerh( path, 'ZHETRS_AA', info, 0,
512 $ uplo, n, n, -1, -1, nrhs, imat,
513 $ nfail, nerrs, nout )
514 END IF
515 ELSE
516*
517 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda
518 $ )
519*
520* Compute the residual for the solution
521*
522 CALL zpot02( uplo, n, nrhs, a, lda, x, lda,
523 $ work, lda, rwork, result( 2 ) )
524*
525* Print information about the tests that did not pass
526* the threshold.
527*
528 DO 120 k = 2, 2
529 IF( result( k ).GE.thresh ) THEN
530 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
531 $ CALL alahd( nout, path )
532 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
533 $ imat, k, result( k )
534 nfail = nfail + 1
535 END IF
536 120 CONTINUE
537 END IF
538 nrun = nrun + 1
539*
540* End do for each value of NRHS in NSVAL.
541*
542 130 CONTINUE
543 140 CONTINUE
544 150 CONTINUE
545 160 CONTINUE
546 170 CONTINUE
547 180 CONTINUE
548*
549* Print a summary of the results.
550*
551 CALL alasum( path, nout, nfail, nrun, nerrs )
552*
553 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
554 $ i2, ', test ', i2, ', ratio =', g12.5 )
555 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
556 $ i2, ', test(', i2, ') =', g12.5 )
557c 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2,
558c $ ', test(', I2, ') =', G12.5 )
559 9995 FORMAT( ' Invalid input value: ', a4, '=', i6, '; must be <=',
560 $ i6 )
561 RETURN
562*
563* End of ZCHKHE_AA
564*
zhetrf_aa
subroutine zhetrf_aa(uplo, n, a, lda, ipiv, work, lwork, info)
ZHETRF_AA
Definition zhetrf_aa.f:132
zhetrs_aa
subroutine zhetrs_aa(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
ZHETRS_AA
Definition zhetrs_aa.f:132
zhet01_aa
subroutine zhet01_aa(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
ZHET01_AA
Definition zhet01_aa.f:124

◆ zchkhe_aa_2stage()

subroutine zchkhe_aa_2stage ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
complex*16, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKHE_AA_2STAGE

Purpose:
!>
!> ZCHKSY_AA_2STAGE tests ZHETRF_AA_2STAGE, -TRS_AA_2STAGE.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX))
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (2*NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 169 of file zchkhe_aa_2stage.f.

172*
173* -- LAPACK test routine --
174* -- LAPACK is a software package provided by Univ. of Tennessee, --
175* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176*
177 IMPLICIT NONE
178*
179* .. Scalar Arguments ..
180 LOGICAL TSTERR
181 INTEGER NN, NNB, NNS, NMAX, NOUT
182 DOUBLE PRECISION THRESH
183* ..
184* .. Array Arguments ..
185 LOGICAL DOTYPE( * )
186 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
187 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
188 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
189* ..
190*
191* =====================================================================
192*
193* .. Parameters ..
194 DOUBLE PRECISION ZERO
195 parameter( zero = 0.0d+0 )
196 COMPLEX*16 CZERO
197 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
198 INTEGER NTYPES
199 parameter( ntypes = 10 )
200 INTEGER NTESTS
201 parameter( ntests = 9 )
202* ..
203* .. Local Scalars ..
204 LOGICAL ZEROT
205 CHARACTER DIST, TYPE, UPLO, XTYPE
206 CHARACTER*3 PATH, MATPATH
207 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
208 $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
209 $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
210 DOUBLE PRECISION ANORM, CNDNUM
211* ..
212* .. Local Arrays ..
213 CHARACTER UPLOS( 2 )
214 INTEGER ISEED( 4 ), ISEEDY( 4 )
215 DOUBLE PRECISION RESULT( NTESTS )
216* ..
217* .. External Subroutines ..
218 EXTERNAL alaerh, alahd, alasum, zerrhe, zlacpy,
219 $ zlarhs, zlatb4, zlatms, zpot02,
220 $ zhetrf_aa_2stage, zhetrs_aa_2stage,
221 $ xlaenv
222* ..
223* .. Intrinsic Functions ..
224 INTRINSIC max, min
225* ..
226* .. Scalars in Common ..
227 LOGICAL LERR, OK
228 CHARACTER*32 SRNAMT
229 INTEGER INFOT, NUNIT
230* ..
231* .. Common blocks ..
232 COMMON / infoc / infot, nunit, ok, lerr
233 COMMON / srnamc / srnamt
234* ..
235* .. Data statements ..
236 DATA iseedy / 1988, 1989, 1990, 1991 /
237 DATA uplos / 'U', 'L' /
238* ..
239* .. Executable Statements ..
240*
241* Initialize constants and the random number seed.
242*
243* Test path
244*
245 path( 1: 1 ) = 'Zomplex precision'
246 path( 2: 3 ) = 'H2'
247*
248* Path to generate matrices
249*
250 matpath( 1: 1 ) = 'Zomplex precision'
251 matpath( 2: 3 ) = 'HE'
252 nrun = 0
253 nfail = 0
254 nerrs = 0
255 DO 10 i = 1, 4
256 iseed( i ) = iseedy( i )
257 10 CONTINUE
258*
259* Test the error exits
260*
261 IF( tsterr )
262 $ CALL zerrhe( path, nout )
263 infot = 0
264*
265* Set the minimum block size for which the block routine should
266* be used, which will be later returned by ILAENV
267*
268 CALL xlaenv( 2, 2 )
269*
270* Do for each value of N in NVAL
271*
272 DO 180 in = 1, nn
273 n = nval( in )
274 IF( n .GT. nmax ) THEN
275 nfail = nfail + 1
276 WRITE(nout, 9995) 'M ', n, nmax
277 GO TO 180
278 END IF
279 lda = max( n, 1 )
280 xtype = 'N'
281 nimat = ntypes
282 IF( n.LE.0 )
283 $ nimat = 1
284*
285 izero = 0
286*
287* Do for each value of matrix type IMAT
288*
289 DO 170 imat = 1, nimat
290*
291* Do the tests only if DOTYPE( IMAT ) is true.
292*
293 IF( .NOT.dotype( imat ) )
294 $ GO TO 170
295*
296* Skip types 3, 4, 5, or 6 if the matrix size is too small.
297*
298 zerot = imat.GE.3 .AND. imat.LE.6
299 IF( zerot .AND. n.LT.imat-2 )
300 $ GO TO 170
301*
302* Do first for UPLO = 'U', then for UPLO = 'L'
303*
304 DO 160 iuplo = 1, 2
305 uplo = uplos( iuplo )
306*
307* Begin generate the test matrix A.
308*
309*
310* Set up parameters with ZLATB4 for the matrix generator
311* based on the type of matrix to be generated.
312*
313 CALL zlatb4( matpath, imat, n, n, TYPE, KL, KU,
314 $ ANORM, MODE, CNDNUM, DIST )
315*
316* Generate a matrix with ZLATMS.
317*
318 srnamt = 'ZLATMS'
319 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
320 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
321 $ INFO )
322*
323* Check error code from ZLATMS and handle error.
324*
325 IF( info.NE.0 ) THEN
326 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n, -1,
327 $ -1, -1, imat, nfail, nerrs, nout )
328*
329* Skip all tests for this generated matrix
330*
331 GO TO 160
332 END IF
333*
334* For matrix types 3-6, zero one or more rows and
335* columns of the matrix to test that INFO is returned
336* correctly.
337*
338 IF( zerot ) THEN
339 IF( imat.EQ.3 ) THEN
340 izero = 1
341 ELSE IF( imat.EQ.4 ) THEN
342 izero = n
343 ELSE
344 izero = n / 2 + 1
345 END IF
346*
347 IF( imat.LT.6 ) THEN
348*
349* Set row and column IZERO to zero.
350*
351 IF( iuplo.EQ.1 ) THEN
352 ioff = ( izero-1 )*lda
353 DO 20 i = 1, izero - 1
354 a( ioff+i ) = czero
355 20 CONTINUE
356 ioff = ioff + izero
357 DO 30 i = izero, n
358 a( ioff ) = czero
359 ioff = ioff + lda
360 30 CONTINUE
361 ELSE
362 ioff = izero
363 DO 40 i = 1, izero - 1
364 a( ioff ) = czero
365 ioff = ioff + lda
366 40 CONTINUE
367 ioff = ioff - izero
368 DO 50 i = izero, n
369 a( ioff+i ) = czero
370 50 CONTINUE
371 END IF
372 ELSE
373 IF( iuplo.EQ.1 ) THEN
374*
375* Set the first IZERO rows and columns to zero.
376*
377 ioff = 0
378 DO 70 j = 1, n
379 i2 = min( j, izero )
380 DO 60 i = 1, i2
381 a( ioff+i ) = czero
382 60 CONTINUE
383 ioff = ioff + lda
384 70 CONTINUE
385 izero = 1
386 ELSE
387*
388* Set the last IZERO rows and columns to zero.
389*
390 ioff = 0
391 DO 90 j = 1, n
392 i1 = max( j, izero )
393 DO 80 i = i1, n
394 a( ioff+i ) = czero
395 80 CONTINUE
396 ioff = ioff + lda
397 90 CONTINUE
398 END IF
399 END IF
400 ELSE
401 izero = 0
402 END IF
403*
404* End generate test matrix A.
405*
406*
407* Set the imaginary part of the diagonals.
408*
409 CALL zlaipd( n, a, lda+1, 0 )
410*
411* Do for each value of NB in NBVAL
412*
413 DO 150 inb = 1, nnb
414*
415* Set the optimal blocksize, which will be later
416* returned by ILAENV.
417*
418 nb = nbval( inb )
419 CALL xlaenv( 1, nb )
420*
421* Copy the test matrix A into matrix AFAC which
422* will be factorized in place. This is needed to
423* preserve the test matrix A for subsequent tests.
424*
425 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
426*
427* Compute the L*D*L**T or U*D*U**T factorization of the
428* matrix. IWORK stores details of the interchanges and
429* the block structure of D. AINV is a work array for
430* block factorization, LWORK is the length of AINV.
431*
432 srnamt = 'ZHETRF_AA_2STAGE'
433 lwork = min(n*nb, 3*nmax*nmax)
434 CALL zhetrf_aa_2stage( uplo, n, afac, lda,
435 $ ainv, (3*nb+1)*n,
436 $ iwork, iwork( 1+n ),
437 $ work, lwork,
438 $ info )
439*
440* Adjust the expected value of INFO to account for
441* pivoting.
442*
443 IF( izero.GT.0 ) THEN
444 j = 1
445 k = izero
446 100 CONTINUE
447 IF( j.EQ.k ) THEN
448 k = iwork( j )
449 ELSE IF( iwork( j ).EQ.k ) THEN
450 k = j
451 END IF
452 IF( j.LT.k ) THEN
453 j = j + 1
454 GO TO 100
455 END IF
456 ELSE
457 k = 0
458 END IF
459*
460* Check error code from CHETRF and handle error.
461*
462 IF( info.NE.k ) THEN
463 CALL alaerh( path, 'ZHETRF_AA_2STAGE', info, k,
464 $ uplo, n, n, -1, -1, nb, imat, nfail,
465 $ nerrs, nout )
466 END IF
467*
468*+ TEST 1
469* Reconstruct matrix from factors and compute residual.
470*
471* NEED TO CREATE ZHET01_AA_2STAGE
472* CALL ZHET01_AA( UPLO, N, A, LDA, AFAC, LDA, IWORK,
473* $ AINV, LDA, RWORK, RESULT( 1 ) )
474* NT = 1
475 nt = 0
476*
477*
478* Print information about the tests that did not pass
479* the threshold.
480*
481 DO 110 k = 1, nt
482 IF( result( k ).GE.thresh ) THEN
483 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
484 $ CALL alahd( nout, path )
485 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
486 $ result( k )
487 nfail = nfail + 1
488 END IF
489 110 CONTINUE
490 nrun = nrun + nt
491*
492* Skip solver test if INFO is not 0.
493*
494 IF( info.NE.0 ) THEN
495 GO TO 140
496 END IF
497*
498* Do for each value of NRHS in NSVAL.
499*
500 DO 130 irhs = 1, nns
501 nrhs = nsval( irhs )
502*
503*+ TEST 2 (Using TRS)
504* Solve and compute residual for A * X = B.
505*
506* Choose a set of NRHS random solution vectors
507* stored in XACT and set up the right hand side B
508*
509 srnamt = 'ZLARHS'
510 CALL zlarhs( matpath, xtype, uplo, ' ', n, n,
511 $ kl, ku, nrhs, a, lda, xact, lda,
512 $ b, lda, iseed, info )
513 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
514*
515 srnamt = 'ZHETRS_AA_2STAGE'
516 lwork = max( 1, 3*n-2 )
517 CALL zhetrs_aa_2stage( uplo, n, nrhs, afac, lda,
518 $ ainv, (3*nb+1)*n, iwork, iwork( 1+n ),
519 $ x, lda, info )
520*
521* Check error code from ZHETRS and handle error.
522*
523 IF( info.NE.0 ) THEN
524 IF( izero.EQ.0 ) THEN
525 CALL alaerh( path, 'ZHETRS_AA_2STAGE',
526 $ info, 0, uplo, n, n, -1, -1,
527 $ nrhs, imat, nfail, nerrs, nout )
528 END IF
529 ELSE
530*
531 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda
532 $ )
533*
534* Compute the residual for the solution
535*
536 CALL zpot02( uplo, n, nrhs, a, lda, x, lda,
537 $ work, lda, rwork, result( 2 ) )
538*
539* Print information about the tests that did not pass
540* the threshold.
541*
542 DO 120 k = 2, 2
543 IF( result( k ).GE.thresh ) THEN
544 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
545 $ CALL alahd( nout, path )
546 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
547 $ imat, k, result( k )
548 nfail = nfail + 1
549 END IF
550 120 CONTINUE
551 END IF
552 nrun = nrun + 1
553*
554* End do for each value of NRHS in NSVAL.
555*
556 130 CONTINUE
557 140 CONTINUE
558 150 CONTINUE
559 160 CONTINUE
560 170 CONTINUE
561 180 CONTINUE
562*
563* Print a summary of the results.
564*
565 CALL alasum( path, nout, nfail, nrun, nerrs )
566*
567 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
568 $ i2, ', test ', i2, ', ratio =', g12.5 )
569 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
570 $ i2, ', test(', i2, ') =', g12.5 )
571 9995 FORMAT( ' Invalid input value: ', a4, '=', i6, '; must be <=',
572 $ i6 )
573 RETURN
574*
575* End of ZCHKHE_AA_2STAGE
576*
zhetrs_aa_2stage
subroutine zhetrs_aa_2stage(uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, info)
ZHETRS_AA_2STAGE
Definition zhetrs_aa_2stage.f:141
zhetrf_aa_2stage
subroutine zhetrf_aa_2stage(uplo, n, a, lda, tb, ltb, ipiv, ipiv2, work, lwork, info)
ZHETRF_AA_2STAGE
Definition zhetrf_aa_2stage.f:160

◆ zchkhe_rk()

subroutine zchkhe_rk ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) e,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKHE_RK

Purpose:
!>
!> ZCHKHE_RK tests ZHETRF_RK, -TRI_3, -TRS_3,
!> and -CON_3.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is CCOMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]E
!>          E is COMPLEX*16 array, dimension (NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is CCOMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (2*NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 174 of file zchkhe_rk.f.

177*
178* -- LAPACK test routine --
179* -- LAPACK is a software package provided by Univ. of Tennessee, --
180* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
181*
182* .. Scalar Arguments ..
183 LOGICAL TSTERR
184 INTEGER NMAX, NN, NNB, NNS, NOUT
185 DOUBLE PRECISION THRESH
186* ..
187* .. Array Arguments ..
188 LOGICAL DOTYPE( * )
189 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
190 DOUBLE PRECISION RWORK( * )
191 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
192 $ WORK( * ), X( * ), XACT( * )
193* ..
194*
195* =====================================================================
196*
197* .. Parameters ..
198 DOUBLE PRECISION ZERO, ONE
199 parameter( zero = 0.0d+0, one = 1.0d+0 )
200 DOUBLE PRECISION ONEHALF
201 parameter( onehalf = 0.5d+0 )
202 DOUBLE PRECISION EIGHT, SEVTEN
203 parameter( eight = 8.0d+0, sevten = 17.0d+0 )
204 COMPLEX*16 CZERO
205 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
206 INTEGER NTYPES
207 parameter( ntypes = 10 )
208 INTEGER NTESTS
209 parameter( ntests = 7 )
210* ..
211* .. Local Scalars ..
212 LOGICAL TRFCON, ZEROT
213 CHARACTER DIST, TYPE, UPLO, XTYPE
214 CHARACTER*3 PATH, MATPATH
215 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
216 $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA,
217 $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS,
218 $ NRUN, NT
219 DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
220 $ SING_MIN, RCOND, RCONDC, DTEMP
221* ..
222* .. Local Arrays ..
223 CHARACTER UPLOS( 2 )
224 INTEGER ISEED( 4 ), ISEEDY( 4 ), IDUMMY( 1 )
225 DOUBLE PRECISION RESULT( NTESTS )
226 COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 )
227* ..
228* .. External Functions ..
229 DOUBLE PRECISION DGET06, ZLANGE, ZLANHE
230 EXTERNAL dget06, zlange, zlanhe
231* ..
232* .. External Subroutines ..
233 EXTERNAL alaerh, alahd, alasum, zerrhe, zgesvd, zget04,
234 $ zlacpy, zlarhs, zlatb4, zlatms, zpot02, zpot03,
235 $ zhecon_3, zhet01_3, zhetrf_rk, zhetri_3,
236 $ zhetrs_3, xlaenv
237* ..
238* .. Intrinsic Functions ..
239 INTRINSIC dconjg, max, min, sqrt
240* ..
241* .. Scalars in Common ..
242 LOGICAL LERR, OK
243 CHARACTER*32 SRNAMT
244 INTEGER INFOT, NUNIT
245* ..
246* .. Common blocks ..
247 COMMON / infoc / infot, nunit, ok, lerr
248 COMMON / srnamc / srnamt
249* ..
250* .. Data statements ..
251 DATA iseedy / 1988, 1989, 1990, 1991 /
252 DATA uplos / 'U', 'L' /
253* ..
254* .. Executable Statements ..
255*
256* Initialize constants and the random number seed.
257*
258 alpha = ( one+sqrt( sevten ) ) / eight
259*
260* Test path
261*
262 path( 1: 1 ) = 'Zomplex precision'
263 path( 2: 3 ) = 'HK'
264*
265* Path to generate matrices
266*
267 matpath( 1: 1 ) = 'Zomplex precision'
268 matpath( 2: 3 ) = 'HE'
269*
270 nrun = 0
271 nfail = 0
272 nerrs = 0
273 DO 10 i = 1, 4
274 iseed( i ) = iseedy( i )
275 10 CONTINUE
276*
277* Test the error exits
278*
279 IF( tsterr )
280 $ CALL zerrhe( path, nout )
281 infot = 0
282*
283* Set the minimum block size for which the block routine should
284* be used, which will be later returned by ILAENV
285*
286 CALL xlaenv( 2, 2 )
287*
288* Do for each value of N in NVAL
289*
290 DO 270 in = 1, nn
291 n = nval( in )
292 lda = max( n, 1 )
293 xtype = 'N'
294 nimat = ntypes
295 IF( n.LE.0 )
296 $ nimat = 1
297*
298 izero = 0
299*
300* Do for each value of matrix type IMAT
301*
302 DO 260 imat = 1, nimat
303*
304* Do the tests only if DOTYPE( IMAT ) is true.
305*
306 IF( .NOT.dotype( imat ) )
307 $ GO TO 260
308*
309* Skip types 3, 4, 5, or 6 if the matrix size is too small.
310*
311 zerot = imat.GE.3 .AND. imat.LE.6
312 IF( zerot .AND. n.LT.imat-2 )
313 $ GO TO 260
314*
315* Do first for UPLO = 'U', then for UPLO = 'L'
316*
317 DO 250 iuplo = 1, 2
318 uplo = uplos( iuplo )
319*
320* Begin generate the test matrix A.
321*
322* Set up parameters with ZLATB4 for the matrix generator
323* based on the type of matrix to be generated.
324*
325 CALL zlatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
326 $ MODE, CNDNUM, DIST )
327*
328* Generate a matrix with ZLATMS.
329*
330 srnamt = 'ZLATMS'
331 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
332 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
333 $ WORK, INFO )
334*
335* Check error code from ZLATMS and handle error.
336*
337 IF( info.NE.0 ) THEN
338 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n,
339 $ -1, -1, -1, imat, nfail, nerrs, nout )
340*
341* Skip all tests for this generated matrix
342*
343 GO TO 250
344 END IF
345*
346* For matrix types 3-6, zero one or more rows and
347* columns of the matrix to test that INFO is returned
348* correctly.
349*
350 IF( zerot ) THEN
351 IF( imat.EQ.3 ) THEN
352 izero = 1
353 ELSE IF( imat.EQ.4 ) THEN
354 izero = n
355 ELSE
356 izero = n / 2 + 1
357 END IF
358*
359 IF( imat.LT.6 ) THEN
360*
361* Set row and column IZERO to zero.
362*
363 IF( iuplo.EQ.1 ) THEN
364 ioff = ( izero-1 )*lda
365 DO 20 i = 1, izero - 1
366 a( ioff+i ) = czero
367 20 CONTINUE
368 ioff = ioff + izero
369 DO 30 i = izero, n
370 a( ioff ) = czero
371 ioff = ioff + lda
372 30 CONTINUE
373 ELSE
374 ioff = izero
375 DO 40 i = 1, izero - 1
376 a( ioff ) = czero
377 ioff = ioff + lda
378 40 CONTINUE
379 ioff = ioff - izero
380 DO 50 i = izero, n
381 a( ioff+i ) = czero
382 50 CONTINUE
383 END IF
384 ELSE
385 IF( iuplo.EQ.1 ) THEN
386*
387* Set the first IZERO rows and columns to zero.
388*
389 ioff = 0
390 DO 70 j = 1, n
391 i2 = min( j, izero )
392 DO 60 i = 1, i2
393 a( ioff+i ) = czero
394 60 CONTINUE
395 ioff = ioff + lda
396 70 CONTINUE
397 ELSE
398*
399* Set the last IZERO rows and columns to zero.
400*
401 ioff = 0
402 DO 90 j = 1, n
403 i1 = max( j, izero )
404 DO 80 i = i1, n
405 a( ioff+i ) = czero
406 80 CONTINUE
407 ioff = ioff + lda
408 90 CONTINUE
409 END IF
410 END IF
411 ELSE
412 izero = 0
413 END IF
414*
415* End generate the test matrix A.
416*
417*
418* Do for each value of NB in NBVAL
419*
420 DO 240 inb = 1, nnb
421*
422* Set the optimal blocksize, which will be later
423* returned by ILAENV.
424*
425 nb = nbval( inb )
426 CALL xlaenv( 1, nb )
427*
428* Copy the test matrix A into matrix AFAC which
429* will be factorized in place. This is needed to
430* preserve the test matrix A for subsequent tests.
431*
432 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
433*
434* Compute the L*D*L**T or U*D*U**T factorization of the
435* matrix. IWORK stores details of the interchanges and
436* the block structure of D. AINV is a work array for
437* block factorization, LWORK is the length of AINV.
438*
439 lwork = max( 2, nb )*lda
440 srnamt = 'ZHETRF_RK'
441 CALL zhetrf_rk( uplo, n, afac, lda, e, iwork, ainv,
442 $ lwork, info )
443*
444* Adjust the expected value of INFO to account for
445* pivoting.
446*
447 k = izero
448 IF( k.GT.0 ) THEN
449 100 CONTINUE
450 IF( iwork( k ).LT.0 ) THEN
451 IF( iwork( k ).NE.-k ) THEN
452 k = -iwork( k )
453 GO TO 100
454 END IF
455 ELSE IF( iwork( k ).NE.k ) THEN
456 k = iwork( k )
457 GO TO 100
458 END IF
459 END IF
460*
461* Check error code from ZHETRF_RK and handle error.
462*
463 IF( info.NE.k)
464 $ CALL alaerh( path, 'ZHETRF_RK', info, k,
465 $ uplo, n, n, -1, -1, nb, imat,
466 $ nfail, nerrs, nout )
467*
468* Set the condition estimate flag if the INFO is not 0.
469*
470 IF( info.NE.0 ) THEN
471 trfcon = .true.
472 ELSE
473 trfcon = .false.
474 END IF
475*
476*+ TEST 1
477* Reconstruct matrix from factors and compute residual.
478*
479 CALL zhet01_3( uplo, n, a, lda, afac, lda, e, iwork,
480 $ ainv, lda, rwork, result( 1 ) )
481 nt = 1
482*
483*+ TEST 2
484* Form the inverse and compute the residual,
485* if the factorization was competed without INFO > 0
486* (i.e. there is no zero rows and columns).
487* Do it only for the first block size.
488*
489 IF( inb.EQ.1 .AND. .NOT.trfcon ) THEN
490 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
491 srnamt = 'ZHETRI_3'
492*
493* Another reason that we need to compute the inverse
494* is that ZPOT03 produces RCONDC which is used later
495* in TEST6 and TEST7.
496*
497 lwork = (n+nb+1)*(nb+3)
498 CALL zhetri_3( uplo, n, ainv, lda, e, iwork, work,
499 $ lwork, info )
500*
501* Check error code from ZHETRI_3 and handle error.
502*
503 IF( info.NE.0 )
504 $ CALL alaerh( path, 'ZHETRI_3', info, -1,
505 $ uplo, n, n, -1, -1, -1, imat,
506 $ nfail, nerrs, nout )
507*
508* Compute the residual for a Hermitian matrix times
509* its inverse.
510*
511 CALL zpot03( uplo, n, a, lda, ainv, lda, work, lda,
512 $ rwork, rcondc, result( 2 ) )
513 nt = 2
514 END IF
515*
516* Print information about the tests that did not pass
517* the threshold.
518*
519 DO 110 k = 1, nt
520 IF( result( k ).GE.thresh ) THEN
521 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
522 $ CALL alahd( nout, path )
523 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
524 $ result( k )
525 nfail = nfail + 1
526 END IF
527 110 CONTINUE
528 nrun = nrun + nt
529*
530*+ TEST 3
531* Compute largest element in U or L
532*
533 result( 3 ) = zero
534 dtemp = zero
535*
536 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) ) /
537 $ ( one-alpha )
538*
539 IF( iuplo.EQ.1 ) THEN
540*
541* Compute largest element in U
542*
543 k = n
544 120 CONTINUE
545 IF( k.LE.1 )
546 $ GO TO 130
547*
548 IF( iwork( k ).GT.zero ) THEN
549*
550* Get max absolute value from elements
551* in column k in U
552*
553 dtemp = zlange( 'M', k-1, 1,
554 $ afac( ( k-1 )*lda+1 ), lda, rwork )
555 ELSE
556*
557* Get max absolute value from elements
558* in columns k and k-1 in U
559*
560 dtemp = zlange( 'M', k-2, 2,
561 $ afac( ( k-2 )*lda+1 ), lda, rwork )
562 k = k - 1
563*
564 END IF
565*
566* DTEMP should be bounded by CONST
567*
568 dtemp = dtemp - const + thresh
569 IF( dtemp.GT.result( 3 ) )
570 $ result( 3 ) = dtemp
571*
572 k = k - 1
573*
574 GO TO 120
575 130 CONTINUE
576*
577 ELSE
578*
579* Compute largest element in L
580*
581 k = 1
582 140 CONTINUE
583 IF( k.GE.n )
584 $ GO TO 150
585*
586 IF( iwork( k ).GT.zero ) THEN
587*
588* Get max absolute value from elements
589* in column k in L
590*
591 dtemp = zlange( 'M', n-k, 1,
592 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
593 ELSE
594*
595* Get max absolute value from elements
596* in columns k and k+1 in L
597*
598 dtemp = zlange( 'M', n-k-1, 2,
599 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
600 k = k + 1
601*
602 END IF
603*
604* DTEMP should be bounded by CONST
605*
606 dtemp = dtemp - const + thresh
607 IF( dtemp.GT.result( 3 ) )
608 $ result( 3 ) = dtemp
609*
610 k = k + 1
611*
612 GO TO 140
613 150 CONTINUE
614 END IF
615*
616*
617*+ TEST 4
618* Compute largest 2-Norm (condition number)
619* of 2-by-2 diag blocks
620*
621 result( 4 ) = zero
622 dtemp = zero
623*
624 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) )*
625 $ ( ( one + alpha ) / ( one - alpha ) )
626 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
627*
628 IF( iuplo.EQ.1 ) THEN
629*
630* Loop backward for UPLO = 'U'
631*
632 k = n
633 160 CONTINUE
634 IF( k.LE.1 )
635 $ GO TO 170
636*
637 IF( iwork( k ).LT.zero ) THEN
638*
639* Get the two singular values
640* (real and non-negative) of a 2-by-2 block,
641* store them in RWORK array
642*
643 block( 1, 1 ) = afac( ( k-2 )*lda+k-1 )
644 block( 1, 2 ) = e( k )
645 block( 2, 1 ) = dconjg( block( 1, 2 ) )
646 block( 2, 2 ) = afac( (k-1)*lda+k )
647*
648 CALL zgesvd( 'N', 'N', 2, 2, block, 2, rwork,
649 $ zdummy, 1, zdummy, 1,
650 $ work, 6, rwork( 3 ), info )
651*
652*
653 sing_max = rwork( 1 )
654 sing_min = rwork( 2 )
655*
656 dtemp = sing_max / sing_min
657*
658* DTEMP should be bounded by CONST
659*
660 dtemp = dtemp - const + thresh
661 IF( dtemp.GT.result( 4 ) )
662 $ result( 4 ) = dtemp
663 k = k - 1
664*
665 END IF
666*
667 k = k - 1
668*
669 GO TO 160
670 170 CONTINUE
671*
672 ELSE
673*
674* Loop forward for UPLO = 'L'
675*
676 k = 1
677 180 CONTINUE
678 IF( k.GE.n )
679 $ GO TO 190
680*
681 IF( iwork( k ).LT.zero ) THEN
682*
683* Get the two singular values
684* (real and non-negative) of a 2-by-2 block,
685* store them in RWORK array
686*
687 block( 1, 1 ) = afac( ( k-1 )*lda+k )
688 block( 2, 1 ) = e( k )
689 block( 1, 2 ) = dconjg( block( 2, 1 ) )
690 block( 2, 2 ) = afac( k*lda+k+1 )
691*
692 CALL zgesvd( 'N', 'N', 2, 2, block, 2, rwork,
693 $ zdummy, 1, zdummy, 1,
694 $ work, 6, rwork(3), info )
695*
696 sing_max = rwork( 1 )
697 sing_min = rwork( 2 )
698*
699 dtemp = sing_max / sing_min
700*
701* DTEMP should be bounded by CONST
702*
703 dtemp = dtemp - const + thresh
704 IF( dtemp.GT.result( 4 ) )
705 $ result( 4 ) = dtemp
706 k = k + 1
707*
708 END IF
709*
710 k = k + 1
711*
712 GO TO 180
713 190 CONTINUE
714 END IF
715*
716* Print information about the tests that did not pass
717* the threshold.
718*
719 DO 200 k = 3, 4
720 IF( result( k ).GE.thresh ) THEN
721 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
722 $ CALL alahd( nout, path )
723 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
724 $ result( k )
725 nfail = nfail + 1
726 END IF
727 200 CONTINUE
728 nrun = nrun + 2
729*
730* Skip the other tests if this is not the first block
731* size.
732*
733 IF( inb.GT.1 )
734 $ GO TO 240
735*
736* Do only the condition estimate if INFO is not 0.
737*
738 IF( trfcon ) THEN
739 rcondc = zero
740 GO TO 230
741 END IF
742*
743* Do for each value of NRHS in NSVAL.
744*
745 DO 220 irhs = 1, nns
746 nrhs = nsval( irhs )
747*
748* Begin loop over NRHS values
749*
750*
751*+ TEST 5 ( Using TRS_3)
752* Solve and compute residual for A * X = B.
753*
754* Choose a set of NRHS random solution vectors
755* stored in XACT and set up the right hand side B
756*
757 srnamt = 'ZLARHS'
758 CALL zlarhs( matpath, xtype, uplo, ' ', n, n,
759 $ kl, ku, nrhs, a, lda, xact, lda,
760 $ b, lda, iseed, info )
761 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
762*
763 srnamt = 'ZHETRS_3'
764 CALL zhetrs_3( uplo, n, nrhs, afac, lda, e, iwork,
765 $ x, lda, info )
766*
767* Check error code from ZHETRS_3 and handle error.
768*
769 IF( info.NE.0 )
770 $ CALL alaerh( path, 'ZHETRS_3', info, 0,
771 $ uplo, n, n, -1, -1, nrhs, imat,
772 $ nfail, nerrs, nout )
773*
774 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
775*
776* Compute the residual for the solution
777*
778 CALL zpot02( uplo, n, nrhs, a, lda, x, lda, work,
779 $ lda, rwork, result( 5 ) )
780*
781*+ TEST 6
782* Check solution from generated exact solution.
783*
784 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
785 $ result( 6 ) )
786*
787* Print information about the tests that did not pass
788* the threshold.
789*
790 DO 210 k = 5, 6
791 IF( result( k ).GE.thresh ) THEN
792 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
793 $ CALL alahd( nout, path )
794 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
795 $ imat, k, result( k )
796 nfail = nfail + 1
797 END IF
798 210 CONTINUE
799 nrun = nrun + 2
800*
801* End do for each value of NRHS in NSVAL.
802*
803 220 CONTINUE
804*
805*+ TEST 7
806* Get an estimate of RCOND = 1/CNDNUM.
807*
808 230 CONTINUE
809 anorm = zlanhe( '1', uplo, n, a, lda, rwork )
810 srnamt = 'ZHECON_3'
811 CALL zhecon_3( uplo, n, afac, lda, e, iwork, anorm,
812 $ rcond, work, info )
813*
814* Check error code from ZHECON_3 and handle error.
815*
816 IF( info.NE.0 )
817 $ CALL alaerh( path, 'ZHECON_3', info, 0,
818 $ uplo, n, n, -1, -1, -1, imat,
819 $ nfail, nerrs, nout )
820*
821* Compute the test ratio to compare values of RCOND
822*
823 result( 7 ) = dget06( rcond, rcondc )
824*
825* Print information about the tests that did not pass
826* the threshold.
827*
828 IF( result( 7 ).GE.thresh ) THEN
829 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
830 $ CALL alahd( nout, path )
831 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
832 $ result( 7 )
833 nfail = nfail + 1
834 END IF
835 nrun = nrun + 1
836 240 CONTINUE
837*
838 250 CONTINUE
839 260 CONTINUE
840 270 CONTINUE
841*
842* Print a summary of the results.
843*
844 CALL alasum( path, nout, nfail, nrun, nerrs )
845*
846 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
847 $ i2, ', test ', i2, ', ratio =', g12.5 )
848 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
849 $ i2, ', test ', i2, ', ratio =', g12.5 )
850 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
851 $ ', test ', i2, ', ratio =', g12.5 )
852 RETURN
853*
854* End of ZCHKHE_RK
855*
alpha
#define alpha
Definition eval.h:35
zgesvd
subroutine zgesvd(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, rwork, info)
ZGESVD computes the singular value decomposition (SVD) for GE matrices
Definition zgesvd.f:214
zhetri_3
subroutine zhetri_3(uplo, n, a, lda, e, ipiv, work, lwork, info)
ZHETRI_3
Definition zhetri_3.f:170
zhetrf_rk
subroutine zhetrf_rk(uplo, n, a, lda, e, ipiv, work, lwork, info)
ZHETRF_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch...
Definition zhetrf_rk.f:259
zhetrs_3
subroutine zhetrs_3(uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info)
ZHETRS_3
Definition zhetrs_3.f:165
zhecon_3
subroutine zhecon_3(uplo, n, a, lda, e, ipiv, anorm, rcond, work, info)
ZHECON_3
Definition zhecon_3.f:166
zhet01_3
subroutine zhet01_3(uplo, n, a, lda, afac, ldafac, e, ipiv, c, ldc, rwork, resid)
ZHET01_3
Definition zhet01_3.f:141

◆ zchkhe_rook()

subroutine zchkhe_rook ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKHE_ROOK

Purpose:
!>
!> ZCHKHE_ROOK tests ZHETRF_ROOK, -TRI_ROOK, -TRS_ROOK,
!> and -CON_ROOK.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is CCOMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is CCOMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (2*NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 169 of file zchkhe_rook.f.

172*
173* -- LAPACK test routine --
174* -- LAPACK is a software package provided by Univ. of Tennessee, --
175* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176*
177* .. Scalar Arguments ..
178 LOGICAL TSTERR
179 INTEGER NMAX, NN, NNB, NNS, NOUT
180 DOUBLE PRECISION THRESH
181* ..
182* .. Array Arguments ..
183 LOGICAL DOTYPE( * )
184 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
185 DOUBLE PRECISION RWORK( * )
186 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
187 $ WORK( * ), X( * ), XACT( * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 DOUBLE PRECISION ZERO, ONE
194 parameter( zero = 0.0d+0, one = 1.0d+0 )
195 DOUBLE PRECISION ONEHALF
196 parameter( onehalf = 0.5d+0 )
197 DOUBLE PRECISION EIGHT, SEVTEN
198 parameter( eight = 8.0d+0, sevten = 17.0d+0 )
199 COMPLEX*16 CZERO
200 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
201 INTEGER NTYPES
202 parameter( ntypes = 10 )
203 INTEGER NTESTS
204 parameter( ntests = 7 )
205* ..
206* .. Local Scalars ..
207 LOGICAL TRFCON, ZEROT
208 CHARACTER DIST, TYPE, UPLO, XTYPE
209 CHARACTER*3 PATH, MATPATH
210 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
211 $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
212 $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
213 DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
214 $ SING_MIN, RCOND, RCONDC, DTEMP
215* ..
216* .. Local Arrays ..
217 CHARACTER UPLOS( 2 )
218 INTEGER ISEED( 4 ), ISEEDY( 4 )
219 DOUBLE PRECISION RESULT( NTESTS )
220 COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 )
221* ..
222* .. External Functions ..
223 DOUBLE PRECISION ZLANGE, ZLANHE, DGET06
224 EXTERNAL zlange, zlanhe, dget06
225* ..
226* .. External Subroutines ..
227 EXTERNAL alaerh, alahd, alasum, zerrhe, zgesvd, zget04,
228 $ zlacpy, zlarhs, zlatb4, zlatms, zpot02,
229 $ zpot03, zhecon_rook, zhet01_rook, zhetrf_rook,
230 $ zhetri_rook, zhetrs_rook, xlaenv
231* ..
232* .. Intrinsic Functions ..
233 INTRINSIC conjg, max, min, sqrt
234* ..
235* .. Scalars in Common ..
236 LOGICAL LERR, OK
237 CHARACTER*32 SRNAMT
238 INTEGER INFOT, NUNIT
239* ..
240* .. Common blocks ..
241 COMMON / infoc / infot, nunit, ok, lerr
242 COMMON / srnamc / srnamt
243* ..
244* .. Data statements ..
245 DATA iseedy / 1988, 1989, 1990, 1991 /
246 DATA uplos / 'U', 'L' /
247* ..
248* .. Executable Statements ..
249*
250* Initialize constants and the random number seed.
251*
252 alpha = ( one+sqrt( sevten ) ) / eight
253*
254* Test path
255*
256 path( 1: 1 ) = 'Zomplex precision'
257 path( 2: 3 ) = 'HR'
258*
259* Path to generate matrices
260*
261 matpath( 1: 1 ) = 'Zomplex precision'
262 matpath( 2: 3 ) = 'HE'
263*
264 nrun = 0
265 nfail = 0
266 nerrs = 0
267 DO 10 i = 1, 4
268 iseed( i ) = iseedy( i )
269 10 CONTINUE
270*
271* Test the error exits
272*
273 IF( tsterr )
274 $ CALL zerrhe( path, nout )
275 infot = 0
276*
277* Set the minimum block size for which the block routine should
278* be used, which will be later returned by ILAENV
279*
280 CALL xlaenv( 2, 2 )
281*
282* Do for each value of N in NVAL
283*
284 DO 270 in = 1, nn
285 n = nval( in )
286 lda = max( n, 1 )
287 xtype = 'N'
288 nimat = ntypes
289 IF( n.LE.0 )
290 $ nimat = 1
291*
292 izero = 0
293*
294* Do for each value of matrix type IMAT
295*
296 DO 260 imat = 1, nimat
297*
298* Do the tests only if DOTYPE( IMAT ) is true.
299*
300 IF( .NOT.dotype( imat ) )
301 $ GO TO 260
302*
303* Skip types 3, 4, 5, or 6 if the matrix size is too small.
304*
305 zerot = imat.GE.3 .AND. imat.LE.6
306 IF( zerot .AND. n.LT.imat-2 )
307 $ GO TO 260
308*
309* Do first for UPLO = 'U', then for UPLO = 'L'
310*
311 DO 250 iuplo = 1, 2
312 uplo = uplos( iuplo )
313*
314* Begin generate the test matrix A.
315*
316* Set up parameters with ZLATB4 for the matrix generator
317* based on the type of matrix to be generated.
318*
319 CALL zlatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
320 $ MODE, CNDNUM, DIST )
321*
322* Generate a matrix with ZLATMS.
323*
324 srnamt = 'ZLATMS'
325 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
326 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
327 $ WORK, INFO )
328*
329* Check error code from ZLATMS and handle error.
330*
331 IF( info.NE.0 ) THEN
332 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n,
333 $ -1, -1, -1, imat, nfail, nerrs, nout )
334*
335* Skip all tests for this generated matrix
336*
337 GO TO 250
338 END IF
339*
340* For matrix types 3-6, zero one or more rows and
341* columns of the matrix to test that INFO is returned
342* correctly.
343*
344 IF( zerot ) THEN
345 IF( imat.EQ.3 ) THEN
346 izero = 1
347 ELSE IF( imat.EQ.4 ) THEN
348 izero = n
349 ELSE
350 izero = n / 2 + 1
351 END IF
352*
353 IF( imat.LT.6 ) THEN
354*
355* Set row and column IZERO to zero.
356*
357 IF( iuplo.EQ.1 ) THEN
358 ioff = ( izero-1 )*lda
359 DO 20 i = 1, izero - 1
360 a( ioff+i ) = czero
361 20 CONTINUE
362 ioff = ioff + izero
363 DO 30 i = izero, n
364 a( ioff ) = czero
365 ioff = ioff + lda
366 30 CONTINUE
367 ELSE
368 ioff = izero
369 DO 40 i = 1, izero - 1
370 a( ioff ) = czero
371 ioff = ioff + lda
372 40 CONTINUE
373 ioff = ioff - izero
374 DO 50 i = izero, n
375 a( ioff+i ) = czero
376 50 CONTINUE
377 END IF
378 ELSE
379 IF( iuplo.EQ.1 ) THEN
380*
381* Set the first IZERO rows and columns to zero.
382*
383 ioff = 0
384 DO 70 j = 1, n
385 i2 = min( j, izero )
386 DO 60 i = 1, i2
387 a( ioff+i ) = czero
388 60 CONTINUE
389 ioff = ioff + lda
390 70 CONTINUE
391 ELSE
392*
393* Set the last IZERO rows and columns to zero.
394*
395 ioff = 0
396 DO 90 j = 1, n
397 i1 = max( j, izero )
398 DO 80 i = i1, n
399 a( ioff+i ) = czero
400 80 CONTINUE
401 ioff = ioff + lda
402 90 CONTINUE
403 END IF
404 END IF
405 ELSE
406 izero = 0
407 END IF
408*
409* End generate the test matrix A.
410*
411*
412* Do for each value of NB in NBVAL
413*
414 DO 240 inb = 1, nnb
415*
416* Set the optimal blocksize, which will be later
417* returned by ILAENV.
418*
419 nb = nbval( inb )
420 CALL xlaenv( 1, nb )
421*
422* Copy the test matrix A into matrix AFAC which
423* will be factorized in place. This is needed to
424* preserve the test matrix A for subsequent tests.
425*
426 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
427*
428* Compute the L*D*L**T or U*D*U**T factorization of the
429* matrix. IWORK stores details of the interchanges and
430* the block structure of D. AINV is a work array for
431* block factorization, LWORK is the length of AINV.
432*
433 lwork = max( 2, nb )*lda
434 srnamt = 'ZHETRF_ROOK'
435 CALL zhetrf_rook( uplo, n, afac, lda, iwork, ainv,
436 $ lwork, info )
437*
438* Adjust the expected value of INFO to account for
439* pivoting.
440*
441 k = izero
442 IF( k.GT.0 ) THEN
443 100 CONTINUE
444 IF( iwork( k ).LT.0 ) THEN
445 IF( iwork( k ).NE.-k ) THEN
446 k = -iwork( k )
447 GO TO 100
448 END IF
449 ELSE IF( iwork( k ).NE.k ) THEN
450 k = iwork( k )
451 GO TO 100
452 END IF
453 END IF
454*
455* Check error code from ZHETRF_ROOK and handle error.
456*
457 IF( info.NE.k)
458 $ CALL alaerh( path, 'ZHETRF_ROOK', info, k,
459 $ uplo, n, n, -1, -1, nb, imat,
460 $ nfail, nerrs, nout )
461*
462* Set the condition estimate flag if the INFO is not 0.
463*
464 IF( info.NE.0 ) THEN
465 trfcon = .true.
466 ELSE
467 trfcon = .false.
468 END IF
469*
470*+ TEST 1
471* Reconstruct matrix from factors and compute residual.
472*
473 CALL zhet01_rook( uplo, n, a, lda, afac, lda, iwork,
474 $ ainv, lda, rwork, result( 1 ) )
475 nt = 1
476*
477*+ TEST 2
478* Form the inverse and compute the residual,
479* if the factorization was competed without INFO > 0
480* (i.e. there is no zero rows and columns).
481* Do it only for the first block size.
482*
483 IF( inb.EQ.1 .AND. .NOT.trfcon ) THEN
484 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
485 srnamt = 'ZHETRI_ROOK'
486 CALL zhetri_rook( uplo, n, ainv, lda, iwork, work,
487 $ info )
488*
489* Check error code from ZHETRI_ROOK and handle error.
490*
491 IF( info.NE.0 )
492 $ CALL alaerh( path, 'ZHETRI_ROOK', info, -1,
493 $ uplo, n, n, -1, -1, -1, imat,
494 $ nfail, nerrs, nout )
495*
496* Compute the residual for a Hermitian matrix times
497* its inverse.
498*
499 CALL zpot03( uplo, n, a, lda, ainv, lda, work, lda,
500 $ rwork, rcondc, result( 2 ) )
501 nt = 2
502 END IF
503*
504* Print information about the tests that did not pass
505* the threshold.
506*
507 DO 110 k = 1, nt
508 IF( result( k ).GE.thresh ) THEN
509 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
510 $ CALL alahd( nout, path )
511 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
512 $ result( k )
513 nfail = nfail + 1
514 END IF
515 110 CONTINUE
516 nrun = nrun + nt
517*
518*+ TEST 3
519* Compute largest element in U or L
520*
521 result( 3 ) = zero
522 dtemp = zero
523*
524 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) ) /
525 $ ( one-alpha )
526*
527 IF( iuplo.EQ.1 ) THEN
528*
529* Compute largest element in U
530*
531 k = n
532 120 CONTINUE
533 IF( k.LE.1 )
534 $ GO TO 130
535*
536 IF( iwork( k ).GT.zero ) THEN
537*
538* Get max absolute value from elements
539* in column k in U
540*
541 dtemp = zlange( 'M', k-1, 1,
542 $ afac( ( k-1 )*lda+1 ), lda, rwork )
543 ELSE
544*
545* Get max absolute value from elements
546* in columns k and k-1 in U
547*
548 dtemp = zlange( 'M', k-2, 2,
549 $ afac( ( k-2 )*lda+1 ), lda, rwork )
550 k = k - 1
551*
552 END IF
553*
554* DTEMP should be bounded by CONST
555*
556 dtemp = dtemp - const + thresh
557 IF( dtemp.GT.result( 3 ) )
558 $ result( 3 ) = dtemp
559*
560 k = k - 1
561*
562 GO TO 120
563 130 CONTINUE
564*
565 ELSE
566*
567* Compute largest element in L
568*
569 k = 1
570 140 CONTINUE
571 IF( k.GE.n )
572 $ GO TO 150
573*
574 IF( iwork( k ).GT.zero ) THEN
575*
576* Get max absolute value from elements
577* in column k in L
578*
579 dtemp = zlange( 'M', n-k, 1,
580 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
581 ELSE
582*
583* Get max absolute value from elements
584* in columns k and k+1 in L
585*
586 dtemp = zlange( 'M', n-k-1, 2,
587 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
588 k = k + 1
589*
590 END IF
591*
592* DTEMP should be bounded by CONST
593*
594 dtemp = dtemp - const + thresh
595 IF( dtemp.GT.result( 3 ) )
596 $ result( 3 ) = dtemp
597*
598 k = k + 1
599*
600 GO TO 140
601 150 CONTINUE
602 END IF
603*
604*
605*+ TEST 4
606* Compute largest 2-Norm (condition number)
607* of 2-by-2 diag blocks
608*
609 result( 4 ) = zero
610 dtemp = zero
611*
612 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) )*
613 $ ( ( one + alpha ) / ( one - alpha ) )
614 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
615*
616 IF( iuplo.EQ.1 ) THEN
617*
618* Loop backward for UPLO = 'U'
619*
620 k = n
621 160 CONTINUE
622 IF( k.LE.1 )
623 $ GO TO 170
624*
625 IF( iwork( k ).LT.zero ) THEN
626*
627* Get the two singular values
628* (real and non-negative) of a 2-by-2 block,
629* store them in RWORK array
630*
631 block( 1, 1 ) = afac( ( k-2 )*lda+k-1 )
632 block( 1, 2 ) = afac( (k-1)*lda+k-1 )
633 block( 2, 1 ) = conjg( block( 1, 2 ) )
634 block( 2, 2 ) = afac( (k-1)*lda+k )
635*
636 CALL zgesvd( 'N', 'N', 2, 2, block, 2, rwork,
637 $ zdummy, 1, zdummy, 1,
638 $ work, 6, rwork( 3 ), info )
639*
640*
641 sing_max = rwork( 1 )
642 sing_min = rwork( 2 )
643*
644 dtemp = sing_max / sing_min
645*
646* DTEMP should be bounded by CONST
647*
648 dtemp = dtemp - const + thresh
649 IF( dtemp.GT.result( 4 ) )
650 $ result( 4 ) = dtemp
651 k = k - 1
652*
653 END IF
654*
655 k = k - 1
656*
657 GO TO 160
658 170 CONTINUE
659*
660 ELSE
661*
662* Loop forward for UPLO = 'L'
663*
664 k = 1
665 180 CONTINUE
666 IF( k.GE.n )
667 $ GO TO 190
668*
669 IF( iwork( k ).LT.zero ) THEN
670*
671* Get the two singular values
672* (real and non-negative) of a 2-by-2 block,
673* store them in RWORK array
674*
675 block( 1, 1 ) = afac( ( k-1 )*lda+k )
676 block( 2, 1 ) = afac( ( k-1 )*lda+k+1 )
677 block( 1, 2 ) = conjg( block( 2, 1 ) )
678 block( 2, 2 ) = afac( k*lda+k+1 )
679*
680 CALL zgesvd( 'N', 'N', 2, 2, block, 2, rwork,
681 $ zdummy, 1, zdummy, 1,
682 $ work, 6, rwork(3), info )
683*
684 sing_max = rwork( 1 )
685 sing_min = rwork( 2 )
686*
687 dtemp = sing_max / sing_min
688*
689* DTEMP should be bounded by CONST
690*
691 dtemp = dtemp - const + thresh
692 IF( dtemp.GT.result( 4 ) )
693 $ result( 4 ) = dtemp
694 k = k + 1
695*
696 END IF
697*
698 k = k + 1
699*
700 GO TO 180
701 190 CONTINUE
702 END IF
703*
704* Print information about the tests that did not pass
705* the threshold.
706*
707 DO 200 k = 3, 4
708 IF( result( k ).GE.thresh ) THEN
709 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
710 $ CALL alahd( nout, path )
711 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
712 $ result( k )
713 nfail = nfail + 1
714 END IF
715 200 CONTINUE
716 nrun = nrun + 2
717*
718* Skip the other tests if this is not the first block
719* size.
720*
721 IF( inb.GT.1 )
722 $ GO TO 240
723*
724* Do only the condition estimate if INFO is not 0.
725*
726 IF( trfcon ) THEN
727 rcondc = zero
728 GO TO 230
729 END IF
730*
731* Do for each value of NRHS in NSVAL.
732*
733 DO 220 irhs = 1, nns
734 nrhs = nsval( irhs )
735*
736* Begin loop over NRHS values
737*
738*
739*+ TEST 5 ( Using TRS_ROOK)
740* Solve and compute residual for A * X = B.
741*
742* Choose a set of NRHS random solution vectors
743* stored in XACT and set up the right hand side B
744*
745 srnamt = 'ZLARHS'
746 CALL zlarhs( matpath, xtype, uplo, ' ', n, n,
747 $ kl, ku, nrhs, a, lda, xact, lda,
748 $ b, lda, iseed, info )
749 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
750*
751 srnamt = 'ZHETRS_ROOK'
752 CALL zhetrs_rook( uplo, n, nrhs, afac, lda, iwork,
753 $ x, lda, info )
754*
755* Check error code from ZHETRS_ROOK and handle error.
756*
757 IF( info.NE.0 )
758 $ CALL alaerh( path, 'ZHETRS_ROOK', info, 0,
759 $ uplo, n, n, -1, -1, nrhs, imat,
760 $ nfail, nerrs, nout )
761*
762 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
763*
764* Compute the residual for the solution
765*
766 CALL zpot02( uplo, n, nrhs, a, lda, x, lda, work,
767 $ lda, rwork, result( 5 ) )
768*
769*+ TEST 6
770* Check solution from generated exact solution.
771*
772 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
773 $ result( 6 ) )
774*
775* Print information about the tests that did not pass
776* the threshold.
777*
778 DO 210 k = 5, 6
779 IF( result( k ).GE.thresh ) THEN
780 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
781 $ CALL alahd( nout, path )
782 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
783 $ imat, k, result( k )
784 nfail = nfail + 1
785 END IF
786 210 CONTINUE
787 nrun = nrun + 2
788*
789* End do for each value of NRHS in NSVAL.
790*
791 220 CONTINUE
792*
793*+ TEST 7
794* Get an estimate of RCOND = 1/CNDNUM.
795*
796 230 CONTINUE
797 anorm = zlanhe( '1', uplo, n, a, lda, rwork )
798 srnamt = 'ZHECON_ROOK'
799 CALL zhecon_rook( uplo, n, afac, lda, iwork, anorm,
800 $ rcond, work, info )
801*
802* Check error code from ZHECON_ROOK and handle error.
803*
804 IF( info.NE.0 )
805 $ CALL alaerh( path, 'ZHECON_ROOK', info, 0,
806 $ uplo, n, n, -1, -1, -1, imat,
807 $ nfail, nerrs, nout )
808*
809* Compute the test ratio to compare values of RCOND
810*
811 result( 7 ) = dget06( rcond, rcondc )
812*
813* Print information about the tests that did not pass
814* the threshold.
815*
816 IF( result( 7 ).GE.thresh ) THEN
817 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
818 $ CALL alahd( nout, path )
819 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
820 $ result( 7 )
821 nfail = nfail + 1
822 END IF
823 nrun = nrun + 1
824 240 CONTINUE
825*
826 250 CONTINUE
827 260 CONTINUE
828 270 CONTINUE
829*
830* Print a summary of the results.
831*
832 CALL alasum( path, nout, nfail, nrun, nerrs )
833*
834 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
835 $ i2, ', test ', i2, ', ratio =', g12.5 )
836 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
837 $ i2, ', test ', i2, ', ratio =', g12.5 )
838 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
839 $ ', test ', i2, ', ratio =', g12.5 )
840 RETURN
841*
842* End of ZCHKHE_ROOK
843*
zhetrs_rook
subroutine zhetrs_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
ZHETRS_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using fac...
Definition zhetrs_rook.f:136
zhetri_rook
subroutine zhetri_rook(uplo, n, a, lda, ipiv, work, info)
ZHETRI_ROOK computes the inverse of HE matrix using the factorization obtained with the bounded Bunch...
Definition zhetri_rook.f:128
zhecon_rook
subroutine zhecon_rook(uplo, n, a, lda, ipiv, anorm, rcond, work, info)
ZHECON_ROOK estimates the reciprocal of the condition number fort HE matrices using factorization obt...
Definition zhecon_rook.f:139
zhetrf_rook
subroutine zhetrf_rook(uplo, n, a, lda, ipiv, work, lwork, info)
ZHETRF_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bun...
Definition zhetrf_rook.f:212
zhet01_rook
subroutine zhet01_rook(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
ZHET01_ROOK
Definition zhet01_rook.f:125

◆ zchkhp()

subroutine zchkhp ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKHP

Purpose:
!>
!> ZCHKHP tests ZHPTRF, -TRI, -TRS, -RFS, and -CON
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(2,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array,
!>                                 dimension (NMAX+2*NSMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 161 of file zchkhp.f.

164*
165* -- LAPACK test routine --
166* -- LAPACK is a software package provided by Univ. of Tennessee, --
167* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
168*
169* .. Scalar Arguments ..
170 LOGICAL TSTERR
171 INTEGER NMAX, NN, NNS, NOUT
172 DOUBLE PRECISION THRESH
173* ..
174* .. Array Arguments ..
175 LOGICAL DOTYPE( * )
176 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
177 DOUBLE PRECISION RWORK( * )
178 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
179 $ WORK( * ), X( * ), XACT( * )
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 DOUBLE PRECISION ZERO
186 parameter( zero = 0.0d+0 )
187 INTEGER NTYPES
188 parameter( ntypes = 10 )
189 INTEGER NTESTS
190 parameter( ntests = 8 )
191* ..
192* .. Local Scalars ..
193 LOGICAL TRFCON, ZEROT
194 CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE
195 CHARACTER*3 PATH
196 INTEGER I, I1, I2, IMAT, IN, INFO, IOFF, IRHS, IUPLO,
197 $ IZERO, J, K, KL, KU, LDA, MODE, N, NERRS,
198 $ NFAIL, NIMAT, NPP, NRHS, NRUN, NT
199 DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
200* ..
201* .. Local Arrays ..
202 CHARACTER UPLOS( 2 )
203 INTEGER ISEED( 4 ), ISEEDY( 4 )
204 DOUBLE PRECISION RESULT( NTESTS )
205* ..
206* .. External Functions ..
207 LOGICAL LSAME
208 DOUBLE PRECISION DGET06, ZLANHP
209 EXTERNAL lsame, dget06, zlanhp
210* ..
211* .. External Subroutines ..
212 EXTERNAL alaerh, alahd, alasum, zcopy, zerrsy, zget04,
213 $ zhpcon, zhprfs, zhpt01, zhptrf, zhptri, zhptrs,
214 $ zlacpy, zlaipd, zlarhs, zlatb4, zlatms, zppt02,
215 $ zppt03, zppt05
216* ..
217* .. Intrinsic Functions ..
218 INTRINSIC max, min
219* ..
220* .. Scalars in Common ..
221 LOGICAL LERR, OK
222 CHARACTER*32 SRNAMT
223 INTEGER INFOT, NUNIT
224* ..
225* .. Common blocks ..
226 COMMON / infoc / infot, nunit, ok, lerr
227 COMMON / srnamc / srnamt
228* ..
229* .. Data statements ..
230 DATA iseedy / 1988, 1989, 1990, 1991 /
231 DATA uplos / 'U', 'L' /
232* ..
233* .. Executable Statements ..
234*
235* Initialize constants and the random number seed.
236*
237 path( 1: 1 ) = 'Zomplex precision'
238 path( 2: 3 ) = 'HP'
239 nrun = 0
240 nfail = 0
241 nerrs = 0
242 DO 10 i = 1, 4
243 iseed( i ) = iseedy( i )
244 10 CONTINUE
245*
246* Test the error exits
247*
248 IF( tsterr )
249 $ CALL zerrsy( path, nout )
250 infot = 0
251*
252* Do for each value of N in NVAL
253*
254 DO 170 in = 1, nn
255 n = nval( in )
256 lda = max( n, 1 )
257 xtype = 'N'
258 nimat = ntypes
259 IF( n.LE.0 )
260 $ nimat = 1
261*
262 izero = 0
263 DO 160 imat = 1, nimat
264*
265* Do the tests only if DOTYPE( IMAT ) is true.
266*
267 IF( .NOT.dotype( imat ) )
268 $ GO TO 160
269*
270* Skip types 3, 4, 5, or 6 if the matrix size is too small.
271*
272 zerot = imat.GE.3 .AND. imat.LE.6
273 IF( zerot .AND. n.LT.imat-2 )
274 $ GO TO 160
275*
276* Do first for UPLO = 'U', then for UPLO = 'L'
277*
278 DO 150 iuplo = 1, 2
279 uplo = uplos( iuplo )
280 IF( lsame( uplo, 'U' ) ) THEN
281 packit = 'C'
282 ELSE
283 packit = 'R'
284 END IF
285*
286* Set up parameters with ZLATB4 and generate a test matrix
287* with ZLATMS.
288*
289 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
290 $ CNDNUM, DIST )
291*
292 srnamt = 'ZLATMS'
293 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
294 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
295 $ INFO )
296*
297* Check error code from ZLATMS.
298*
299 IF( info.NE.0 ) THEN
300 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n, -1,
301 $ -1, -1, imat, nfail, nerrs, nout )
302 GO TO 150
303 END IF
304*
305* For types 3-6, zero one or more rows and columns of
306* the matrix to test that INFO is returned correctly.
307*
308 IF( zerot ) THEN
309 IF( imat.EQ.3 ) THEN
310 izero = 1
311 ELSE IF( imat.EQ.4 ) THEN
312 izero = n
313 ELSE
314 izero = n / 2 + 1
315 END IF
316*
317 IF( imat.LT.6 ) THEN
318*
319* Set row and column IZERO to zero.
320*
321 IF( iuplo.EQ.1 ) THEN
322 ioff = ( izero-1 )*izero / 2
323 DO 20 i = 1, izero - 1
324 a( ioff+i ) = zero
325 20 CONTINUE
326 ioff = ioff + izero
327 DO 30 i = izero, n
328 a( ioff ) = zero
329 ioff = ioff + i
330 30 CONTINUE
331 ELSE
332 ioff = izero
333 DO 40 i = 1, izero - 1
334 a( ioff ) = zero
335 ioff = ioff + n - i
336 40 CONTINUE
337 ioff = ioff - izero
338 DO 50 i = izero, n
339 a( ioff+i ) = zero
340 50 CONTINUE
341 END IF
342 ELSE
343 ioff = 0
344 IF( iuplo.EQ.1 ) THEN
345*
346* Set the first IZERO rows and columns to zero.
347*
348 DO 70 j = 1, n
349 i2 = min( j, izero )
350 DO 60 i = 1, i2
351 a( ioff+i ) = zero
352 60 CONTINUE
353 ioff = ioff + j
354 70 CONTINUE
355 ELSE
356*
357* Set the last IZERO rows and columns to zero.
358*
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 + n - j
365 90 CONTINUE
366 END IF
367 END IF
368 ELSE
369 izero = 0
370 END IF
371*
372* Set the imaginary part of the diagonals.
373*
374 IF( iuplo.EQ.1 ) THEN
375 CALL zlaipd( n, a, 2, 1 )
376 ELSE
377 CALL zlaipd( n, a, n, -1 )
378 END IF
379*
380* Compute the L*D*L' or U*D*U' factorization of the matrix.
381*
382 npp = n*( n+1 ) / 2
383 CALL zcopy( npp, a, 1, afac, 1 )
384 srnamt = 'ZHPTRF'
385 CALL zhptrf( uplo, n, afac, iwork, info )
386*
387* Adjust the expected value of INFO to account for
388* pivoting.
389*
390 k = izero
391 IF( k.GT.0 ) THEN
392 100 CONTINUE
393 IF( iwork( k ).LT.0 ) THEN
394 IF( iwork( k ).NE.-k ) THEN
395 k = -iwork( k )
396 GO TO 100
397 END IF
398 ELSE IF( iwork( k ).NE.k ) THEN
399 k = iwork( k )
400 GO TO 100
401 END IF
402 END IF
403*
404* Check error code from ZHPTRF.
405*
406 IF( info.NE.k )
407 $ CALL alaerh( path, 'ZHPTRF', info, k, uplo, n, n, -1,
408 $ -1, -1, imat, nfail, nerrs, nout )
409 IF( info.NE.0 ) THEN
410 trfcon = .true.
411 ELSE
412 trfcon = .false.
413 END IF
414*
415*+ TEST 1
416* Reconstruct matrix from factors and compute residual.
417*
418 CALL zhpt01( uplo, n, a, afac, iwork, ainv, lda, rwork,
419 $ result( 1 ) )
420 nt = 1
421*
422*+ TEST 2
423* Form the inverse and compute the residual.
424*
425 IF( .NOT.trfcon ) THEN
426 CALL zcopy( npp, afac, 1, ainv, 1 )
427 srnamt = 'ZHPTRI'
428 CALL zhptri( uplo, n, ainv, iwork, work, info )
429*
430* Check error code from ZHPTRI.
431*
432 IF( info.NE.0 )
433 $ CALL alaerh( path, 'ZHPTRI', info, 0, uplo, n, n,
434 $ -1, -1, -1, imat, nfail, nerrs, nout )
435*
436 CALL zppt03( uplo, n, a, ainv, work, lda, rwork,
437 $ rcondc, result( 2 ) )
438 nt = 2
439 END IF
440*
441* Print information about the tests that did not pass
442* the threshold.
443*
444 DO 110 k = 1, nt
445 IF( result( k ).GE.thresh ) THEN
446 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
447 $ CALL alahd( nout, path )
448 WRITE( nout, fmt = 9999 )uplo, n, imat, k,
449 $ result( k )
450 nfail = nfail + 1
451 END IF
452 110 CONTINUE
453 nrun = nrun + nt
454*
455* Do only the condition estimate if INFO is not 0.
456*
457 IF( trfcon ) THEN
458 rcondc = zero
459 GO TO 140
460 END IF
461*
462 DO 130 irhs = 1, nns
463 nrhs = nsval( irhs )
464*
465*+ TEST 3
466* Solve and compute residual for A * X = B.
467*
468 srnamt = 'ZLARHS'
469 CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
470 $ nrhs, a, lda, xact, lda, b, lda, iseed,
471 $ info )
472 xtype = 'C'
473 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
474*
475 srnamt = 'ZHPTRS'
476 CALL zhptrs( uplo, n, nrhs, afac, iwork, x, lda,
477 $ info )
478*
479* Check error code from ZHPTRS.
480*
481 IF( info.NE.0 )
482 $ CALL alaerh( path, 'ZHPTRS', info, 0, uplo, n, n,
483 $ -1, -1, nrhs, imat, nfail, nerrs,
484 $ nout )
485*
486 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
487 CALL zppt02( uplo, n, nrhs, a, x, lda, work, lda,
488 $ rwork, result( 3 ) )
489*
490*+ TEST 4
491* Check solution from generated exact solution.
492*
493 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
494 $ result( 4 ) )
495*
496*+ TESTS 5, 6, and 7
497* Use iterative refinement to improve the solution.
498*
499 srnamt = 'ZHPRFS'
500 CALL zhprfs( uplo, n, nrhs, a, afac, iwork, b, lda, x,
501 $ lda, rwork, rwork( nrhs+1 ), work,
502 $ rwork( 2*nrhs+1 ), info )
503*
504* Check error code from ZHPRFS.
505*
506 IF( info.NE.0 )
507 $ CALL alaerh( path, 'ZHPRFS', info, 0, uplo, n, n,
508 $ -1, -1, nrhs, imat, nfail, nerrs,
509 $ nout )
510*
511 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
512 $ result( 5 ) )
513 CALL zppt05( uplo, n, nrhs, a, b, lda, x, lda, xact,
514 $ lda, rwork, rwork( nrhs+1 ),
515 $ result( 6 ) )
516*
517* Print information about the tests that did not pass
518* the threshold.
519*
520 DO 120 k = 3, 7
521 IF( result( k ).GE.thresh ) THEN
522 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
523 $ CALL alahd( nout, path )
524 WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat,
525 $ k, result( k )
526 nfail = nfail + 1
527 END IF
528 120 CONTINUE
529 nrun = nrun + 5
530 130 CONTINUE
531*
532*+ TEST 8
533* Get an estimate of RCOND = 1/CNDNUM.
534*
535 140 CONTINUE
536 anorm = zlanhp( '1', uplo, n, a, rwork )
537 srnamt = 'ZHPCON'
538 CALL zhpcon( uplo, n, afac, iwork, anorm, rcond, work,
539 $ info )
540*
541* Check error code from ZHPCON.
542*
543 IF( info.NE.0 )
544 $ CALL alaerh( path, 'ZHPCON', info, 0, uplo, n, n, -1,
545 $ -1, -1, imat, nfail, nerrs, nout )
546*
547 result( 8 ) = dget06( rcond, rcondc )
548*
549* Print the test ratio if it is .GE. THRESH.
550*
551 IF( result( 8 ).GE.thresh ) THEN
552 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
553 $ CALL alahd( nout, path )
554 WRITE( nout, fmt = 9999 )uplo, n, imat, 8,
555 $ result( 8 )
556 nfail = nfail + 1
557 END IF
558 nrun = nrun + 1
559 150 CONTINUE
560 160 CONTINUE
561 170 CONTINUE
562*
563* Print a summary of the results.
564*
565 CALL alasum( path, nout, nfail, nrun, nerrs )
566*
567 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', type ', i2, ', test ',
568 $ i2, ', ratio =', g12.5 )
569 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
570 $ i2, ', test(', i2, ') =', g12.5 )
571 RETURN
572*
573* End of ZCHKHP
574*
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
zlanhp
double precision function zlanhp(norm, uplo, n, ap, work)
ZLANHP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlanhp.f:117
zhptrs
subroutine zhptrs(uplo, n, nrhs, ap, ipiv, b, ldb, info)
ZHPTRS
Definition zhptrs.f:115
zhptri
subroutine zhptri(uplo, n, ap, ipiv, work, info)
ZHPTRI
Definition zhptri.f:109
zhpcon
subroutine zhpcon(uplo, n, ap, ipiv, anorm, rcond, work, info)
ZHPCON
Definition zhpcon.f:118
zhprfs
subroutine zhprfs(uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
ZHPRFS
Definition zhprfs.f:180
zhptrf
subroutine zhptrf(uplo, n, ap, ipiv, info)
ZHPTRF
Definition zhptrf.f:159
zppt05
subroutine zppt05(uplo, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
ZPPT05
Definition zppt05.f:157
zppt03
subroutine zppt03(uplo, n, a, ainv, work, ldwork, rwork, rcond, resid)
ZPPT03
Definition zppt03.f:110
zppt02
subroutine zppt02(uplo, n, nrhs, a, x, ldx, b, ldb, rwork, resid)
ZPPT02
Definition zppt02.f:123
zerrsy
subroutine zerrsy(path, nunit)
ZERRSY
Definition zerrsy.f:55
zhpt01
subroutine zhpt01(uplo, n, a, afac, ipiv, c, ldc, rwork, resid)
ZHPT01
Definition zhpt01.f:113

◆ zchklq()

subroutine zchklq ( logical, dimension( * ) dotype,
integer nm,
integer, dimension( * ) mval,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer, dimension( * ) nxval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) af,
complex*16, dimension( * ) aq,
complex*16, dimension( * ) al,
complex*16, dimension( * ) ac,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nout )

ZCHKLQ

Purpose:
!>
!> ZCHKLQ tests ZGELQF, ZUNGLQ and ZUNMLQ.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB and NX contained in the
!>          vectors NBVAL and NXVAL.  The blocking parameters are used
!>          in pairs (NB,NX).
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NXVAL
!>          NXVAL is INTEGER array, dimension (NNB)
!>          The values of the crossover point NX.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for M or N, used in dimensioning
!>          the work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AQ
!>          AQ is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AL
!>          AL is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AC
!>          AC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 193 of file zchklq.f.

196*
197* -- LAPACK test routine --
198* -- LAPACK is a software package provided by Univ. of Tennessee, --
199* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
200*
201* .. Scalar Arguments ..
202 LOGICAL TSTERR
203 INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
204 DOUBLE PRECISION THRESH
205* ..
206* .. Array Arguments ..
207 LOGICAL DOTYPE( * )
208 INTEGER MVAL( * ), NBVAL( * ), NVAL( * ),
209 $ NXVAL( * )
210 DOUBLE PRECISION RWORK( * )
211 COMPLEX*16 A( * ), AC( * ), AF( * ), AL( * ), AQ( * ),
212 $ B( * ), TAU( * ), WORK( * ), X( * ), XACT( * )
213* ..
214*
215* =====================================================================
216*
217* .. Parameters ..
218 INTEGER NTESTS
219 parameter( ntests = 7 )
220 INTEGER NTYPES
221 parameter( ntypes = 8 )
222 DOUBLE PRECISION ZERO
223 parameter( zero = 0.0d0 )
224* ..
225* .. Local Scalars ..
226 CHARACTER DIST, TYPE
227 CHARACTER*3 PATH
228 INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
229 $ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
230 $ NRUN, NT, NX
231 DOUBLE PRECISION ANORM, CNDNUM
232* ..
233* .. Local Arrays ..
234 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
235 DOUBLE PRECISION RESULT( NTESTS )
236* ..
237* .. External Subroutines ..
238 EXTERNAL alaerh, alahd, alasum, xlaenv, zerrlq, zgelqs,
239 $ zget02, zlacpy, zlarhs, zlatb4, zlatms, zlqt01,
240 $ zlqt02, zlqt03
241* ..
242* .. Intrinsic Functions ..
243 INTRINSIC max, min
244* ..
245* .. Scalars in Common ..
246 LOGICAL LERR, OK
247 CHARACTER*32 SRNAMT
248 INTEGER INFOT, NUNIT
249* ..
250* .. Common blocks ..
251 COMMON / infoc / infot, nunit, ok, lerr
252 COMMON / srnamc / srnamt
253* ..
254* .. Data statements ..
255 DATA iseedy / 1988, 1989, 1990, 1991 /
256* ..
257* .. Executable Statements ..
258*
259* Initialize constants and the random number seed.
260*
261 path( 1: 1 ) = 'Zomplex precision'
262 path( 2: 3 ) = 'LQ'
263 nrun = 0
264 nfail = 0
265 nerrs = 0
266 DO 10 i = 1, 4
267 iseed( i ) = iseedy( i )
268 10 CONTINUE
269*
270* Test the error exits
271*
272 IF( tsterr )
273 $ CALL zerrlq( path, nout )
274 infot = 0
275 CALL xlaenv( 2, 2 )
276*
277 lda = nmax
278 lwork = nmax*max( nmax, nrhs )
279*
280* Do for each value of M in MVAL.
281*
282 DO 70 im = 1, nm
283 m = mval( im )
284*
285* Do for each value of N in NVAL.
286*
287 DO 60 in = 1, nn
288 n = nval( in )
289 minmn = min( m, n )
290 DO 50 imat = 1, ntypes
291*
292* Do the tests only if DOTYPE( IMAT ) is true.
293*
294 IF( .NOT.dotype( imat ) )
295 $ GO TO 50
296*
297* Set up parameters with ZLATB4 and generate a test matrix
298* with ZLATMS.
299*
300 CALL zlatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
301 $ CNDNUM, DIST )
302*
303 srnamt = 'ZLATMS'
304 CALL zlatms( m, n, dist, iseed, TYPE, RWORK, MODE,
305 $ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
306 $ WORK, INFO )
307*
308* Check error code from ZLATMS.
309*
310 IF( info.NE.0 ) THEN
311 CALL alaerh( path, 'ZLATMS', info, 0, ' ', m, n, -1,
312 $ -1, -1, imat, nfail, nerrs, nout )
313 GO TO 50
314 END IF
315*
316* Set some values for K: the first value must be MINMN,
317* corresponding to the call of ZLQT01; other values are
318* used in the calls of ZLQT02, and must not exceed MINMN.
319*
320 kval( 1 ) = minmn
321 kval( 2 ) = 0
322 kval( 3 ) = 1
323 kval( 4 ) = minmn / 2
324 IF( minmn.EQ.0 ) THEN
325 nk = 1
326 ELSE IF( minmn.EQ.1 ) THEN
327 nk = 2
328 ELSE IF( minmn.LE.3 ) THEN
329 nk = 3
330 ELSE
331 nk = 4
332 END IF
333*
334* Do for each value of K in KVAL
335*
336 DO 40 ik = 1, nk
337 k = kval( ik )
338*
339* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
340*
341 DO 30 inb = 1, nnb
342 nb = nbval( inb )
343 CALL xlaenv( 1, nb )
344 nx = nxval( inb )
345 CALL xlaenv( 3, nx )
346 DO i = 1, ntests
347 result( i ) = zero
348 END DO
349 nt = 2
350 IF( ik.EQ.1 ) THEN
351*
352* Test ZGELQF
353*
354 CALL zlqt01( m, n, a, af, aq, al, lda, tau,
355 $ work, lwork, rwork, result( 1 ) )
356 ELSE IF( m.LE.n ) THEN
357*
358* Test ZUNGLQ, using factorization
359* returned by ZLQT01
360*
361 CALL zlqt02( m, n, k, a, af, aq, al, lda, tau,
362 $ work, lwork, rwork, result( 1 ) )
363 END IF
364 IF( m.GE.k ) THEN
365*
366* Test ZUNMLQ, using factorization returned
367* by ZLQT01
368*
369 CALL zlqt03( m, n, k, af, ac, al, aq, lda, tau,
370 $ work, lwork, rwork, result( 3 ) )
371 nt = nt + 4
372*
373* If M>=N and K=N, call ZGELQS to solve a system
374* with NRHS right hand sides and compute the
375* residual.
376*
377 IF( k.EQ.m .AND. inb.EQ.1 ) THEN
378*
379* Generate a solution and set the right
380* hand side.
381*
382 srnamt = 'ZLARHS'
383 CALL zlarhs( path, 'New', 'Full',
384 $ 'No transpose', m, n, 0, 0,
385 $ nrhs, a, lda, xact, lda, b, lda,
386 $ iseed, info )
387*
388 CALL zlacpy( 'Full', m, nrhs, b, lda, x,
389 $ lda )
390 srnamt = 'ZGELQS'
391 CALL zgelqs( m, n, nrhs, af, lda, tau, x,
392 $ lda, work, lwork, info )
393*
394* Check error code from ZGELQS.
395*
396 IF( info.NE.0 )
397 $ CALL alaerh( path, 'ZGELQS', info, 0, ' ',
398 $ m, n, nrhs, -1, nb, imat,
399 $ nfail, nerrs, nout )
400*
401 CALL zget02( 'No transpose', m, n, nrhs, a,
402 $ lda, x, lda, b, lda, rwork,
403 $ result( 7 ) )
404 nt = nt + 1
405 END IF
406 END IF
407*
408* Print information about the tests that did not
409* pass the threshold.
410*
411 DO 20 i = 1, nt
412 IF( result( i ).GE.thresh ) THEN
413 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
414 $ CALL alahd( nout, path )
415 WRITE( nout, fmt = 9999 )m, n, k, nb, nx,
416 $ imat, i, result( i )
417 nfail = nfail + 1
418 END IF
419 20 CONTINUE
420 nrun = nrun + nt
421 30 CONTINUE
422 40 CONTINUE
423 50 CONTINUE
424 60 CONTINUE
425 70 CONTINUE
426*
427* Print a summary of the results.
428*
429 CALL alasum( path, nout, nfail, nrun, nerrs )
430*
431 9999 FORMAT( ' M=', i5, ', N=', i5, ', K=', i5, ', NB=', i4, ', NX=',
432 $ i5, ', type ', i2, ', test(', i2, ')=', g12.5 )
433 RETURN
434*
435* End of ZCHKLQ
436*
zlqt01
subroutine zlqt01(m, n, a, af, q, l, lda, tau, work, lwork, rwork, result)
ZLQT01
Definition zlqt01.f:126
zlqt02
subroutine zlqt02(m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
ZLQT02
Definition zlqt02.f:135
zgelqs
subroutine zgelqs(m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
ZGELQS
Definition zgelqs.f:121
zlqt03
subroutine zlqt03(m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
ZLQT03
Definition zlqt03.f:136
zerrlq
subroutine zerrlq(path, nunit)
ZERRLQ
Definition zerrlq.f:55

◆ zchkpb()

subroutine zchkpb ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nout )

ZCHKPB

Purpose:
!>
!> ZCHKPB tests ZPBTRF, -TRS, -RFS, and -CON.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is DOUBLE PRECISION array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (max(NMAX,2*NSMAX))
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 165 of file zchkpb.f.

168*
169* -- LAPACK test routine --
170* -- LAPACK is a software package provided by Univ. of Tennessee, --
171* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
172*
173* .. Scalar Arguments ..
174 LOGICAL TSTERR
175 INTEGER NMAX, NN, NNB, NNS, NOUT
176 DOUBLE PRECISION THRESH
177* ..
178* .. Array Arguments ..
179 LOGICAL DOTYPE( * )
180 INTEGER NBVAL( * ), NSVAL( * ), NVAL( * )
181 DOUBLE PRECISION RWORK( * )
182 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
183 $ WORK( * ), X( * ), XACT( * )
184* ..
185*
186* =====================================================================
187*
188* .. Parameters ..
189 DOUBLE PRECISION ONE, ZERO
190 parameter( one = 1.0d+0, zero = 0.0d+0 )
191 INTEGER NTYPES, NTESTS
192 parameter( ntypes = 8, ntests = 7 )
193 INTEGER NBW
194 parameter( nbw = 4 )
195* ..
196* .. Local Scalars ..
197 LOGICAL ZEROT
198 CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE
199 CHARACTER*3 PATH
200 INTEGER I, I1, I2, IKD, IMAT, IN, INB, INFO, IOFF,
201 $ IRHS, IUPLO, IW, IZERO, K, KD, KL, KOFF, KU,
202 $ LDA, LDAB, MODE, N, NB, NERRS, NFAIL, NIMAT,
203 $ NKD, NRHS, NRUN
204 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC
205* ..
206* .. Local Arrays ..
207 INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW )
208 DOUBLE PRECISION RESULT( NTESTS )
209* ..
210* .. External Functions ..
211 DOUBLE PRECISION DGET06, ZLANGE, ZLANHB
212 EXTERNAL dget06, zlange, zlanhb
213* ..
214* .. External Subroutines ..
215 EXTERNAL alaerh, alahd, alasum, xlaenv, zcopy, zerrpo,
216 $ zget04, zlacpy, zlaipd, zlarhs, zlaset, zlatb4,
217 $ zlatms, zpbcon, zpbrfs, zpbt01, zpbt02, zpbt05,
218 $ zpbtrf, zpbtrs, zswap
219* ..
220* .. Intrinsic Functions ..
221 INTRINSIC dcmplx, max, min
222* ..
223* .. Scalars in Common ..
224 LOGICAL LERR, OK
225 CHARACTER*32 SRNAMT
226 INTEGER INFOT, NUNIT
227* ..
228* .. Common blocks ..
229 COMMON / infoc / infot, nunit, ok, lerr
230 COMMON / srnamc / srnamt
231* ..
232* .. Data statements ..
233 DATA iseedy / 1988, 1989, 1990, 1991 /
234* ..
235* .. Executable Statements ..
236*
237* Initialize constants and the random number seed.
238*
239 path( 1: 1 ) = 'Zomplex precision'
240 path( 2: 3 ) = 'PB'
241 nrun = 0
242 nfail = 0
243 nerrs = 0
244 DO 10 i = 1, 4
245 iseed( i ) = iseedy( i )
246 10 CONTINUE
247*
248* Test the error exits
249*
250 IF( tsterr )
251 $ CALL zerrpo( path, nout )
252 infot = 0
253 kdval( 1 ) = 0
254*
255* Do for each value of N in NVAL
256*
257 DO 90 in = 1, nn
258 n = nval( in )
259 lda = max( n, 1 )
260 xtype = 'N'
261*
262* Set limits on the number of loop iterations.
263*
264 nkd = max( 1, min( n, 4 ) )
265 nimat = ntypes
266 IF( n.EQ.0 )
267 $ nimat = 1
268*
269 kdval( 2 ) = n + ( n+1 ) / 4
270 kdval( 3 ) = ( 3*n-1 ) / 4
271 kdval( 4 ) = ( n+1 ) / 4
272*
273 DO 80 ikd = 1, nkd
274*
275* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order
276* makes it easier to skip redundant values for small values
277* of N.
278*
279 kd = kdval( ikd )
280 ldab = kd + 1
281*
282* Do first for UPLO = 'U', then for UPLO = 'L'
283*
284 DO 70 iuplo = 1, 2
285 koff = 1
286 IF( iuplo.EQ.1 ) THEN
287 uplo = 'U'
288 koff = max( 1, kd+2-n )
289 packit = 'Q'
290 ELSE
291 uplo = 'L'
292 packit = 'B'
293 END IF
294*
295 DO 60 imat = 1, nimat
296*
297* Do the tests only if DOTYPE( IMAT ) is true.
298*
299 IF( .NOT.dotype( imat ) )
300 $ GO TO 60
301*
302* Skip types 2, 3, or 4 if the matrix size is too small.
303*
304 zerot = imat.GE.2 .AND. imat.LE.4
305 IF( zerot .AND. n.LT.imat-1 )
306 $ GO TO 60
307*
308 IF( .NOT.zerot .OR. .NOT.dotype( 1 ) ) THEN
309*
310* Set up parameters with ZLATB4 and generate a test
311* matrix with ZLATMS.
312*
313 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
314 $ MODE, CNDNUM, DIST )
315*
316 srnamt = 'ZLATMS'
317 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
318 $ CNDNUM, ANORM, KD, KD, PACKIT,
319 $ A( KOFF ), LDAB, WORK, INFO )
320*
321* Check error code from ZLATMS.
322*
323 IF( info.NE.0 ) THEN
324 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n,
325 $ n, kd, kd, -1, imat, nfail, nerrs,
326 $ nout )
327 GO TO 60
328 END IF
329 ELSE IF( izero.GT.0 ) THEN
330*
331* Use the same matrix for types 3 and 4 as for type
332* 2 by copying back the zeroed out column,
333*
334 iw = 2*lda + 1
335 IF( iuplo.EQ.1 ) THEN
336 ioff = ( izero-1 )*ldab + kd + 1
337 CALL zcopy( izero-i1, work( iw ), 1,
338 $ a( ioff-izero+i1 ), 1 )
339 iw = iw + izero - i1
340 CALL zcopy( i2-izero+1, work( iw ), 1,
341 $ a( ioff ), max( ldab-1, 1 ) )
342 ELSE
343 ioff = ( i1-1 )*ldab + 1
344 CALL zcopy( izero-i1, work( iw ), 1,
345 $ a( ioff+izero-i1 ),
346 $ max( ldab-1, 1 ) )
347 ioff = ( izero-1 )*ldab + 1
348 iw = iw + izero - i1
349 CALL zcopy( i2-izero+1, work( iw ), 1,
350 $ a( ioff ), 1 )
351 END IF
352 END IF
353*
354* For types 2-4, zero one row and column of the matrix
355* to test that INFO is returned correctly.
356*
357 izero = 0
358 IF( zerot ) THEN
359 IF( imat.EQ.2 ) THEN
360 izero = 1
361 ELSE IF( imat.EQ.3 ) THEN
362 izero = n
363 ELSE
364 izero = n / 2 + 1
365 END IF
366*
367* Save the zeroed out row and column in WORK(*,3)
368*
369 iw = 2*lda
370 DO 20 i = 1, min( 2*kd+1, n )
371 work( iw+i ) = zero
372 20 CONTINUE
373 iw = iw + 1
374 i1 = max( izero-kd, 1 )
375 i2 = min( izero+kd, n )
376*
377 IF( iuplo.EQ.1 ) THEN
378 ioff = ( izero-1 )*ldab + kd + 1
379 CALL zswap( izero-i1, a( ioff-izero+i1 ), 1,
380 $ work( iw ), 1 )
381 iw = iw + izero - i1
382 CALL zswap( i2-izero+1, a( ioff ),
383 $ max( ldab-1, 1 ), work( iw ), 1 )
384 ELSE
385 ioff = ( i1-1 )*ldab + 1
386 CALL zswap( izero-i1, a( ioff+izero-i1 ),
387 $ max( ldab-1, 1 ), work( iw ), 1 )
388 ioff = ( izero-1 )*ldab + 1
389 iw = iw + izero - i1
390 CALL zswap( i2-izero+1, a( ioff ), 1,
391 $ work( iw ), 1 )
392 END IF
393 END IF
394*
395* Set the imaginary part of the diagonals.
396*
397 IF( iuplo.EQ.1 ) THEN
398 CALL zlaipd( n, a( kd+1 ), ldab, 0 )
399 ELSE
400 CALL zlaipd( n, a( 1 ), ldab, 0 )
401 END IF
402*
403* Do for each value of NB in NBVAL
404*
405 DO 50 inb = 1, nnb
406 nb = nbval( inb )
407 CALL xlaenv( 1, nb )
408*
409* Compute the L*L' or U'*U factorization of the band
410* matrix.
411*
412 CALL zlacpy( 'Full', kd+1, n, a, ldab, afac, ldab )
413 srnamt = 'ZPBTRF'
414 CALL zpbtrf( uplo, n, kd, afac, ldab, info )
415*
416* Check error code from ZPBTRF.
417*
418 IF( info.NE.izero ) THEN
419 CALL alaerh( path, 'ZPBTRF', info, izero, uplo,
420 $ n, n, kd, kd, nb, imat, nfail,
421 $ nerrs, nout )
422 GO TO 50
423 END IF
424*
425* Skip the tests if INFO is not 0.
426*
427 IF( info.NE.0 )
428 $ GO TO 50
429*
430*+ TEST 1
431* Reconstruct matrix from factors and compute
432* residual.
433*
434 CALL zlacpy( 'Full', kd+1, n, afac, ldab, ainv,
435 $ ldab )
436 CALL zpbt01( uplo, n, kd, a, ldab, ainv, ldab,
437 $ rwork, result( 1 ) )
438*
439* Print the test ratio if it is .GE. THRESH.
440*
441 IF( result( 1 ).GE.thresh ) THEN
442 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
443 $ CALL alahd( nout, path )
444 WRITE( nout, fmt = 9999 )uplo, n, kd, nb, imat,
445 $ 1, result( 1 )
446 nfail = nfail + 1
447 END IF
448 nrun = nrun + 1
449*
450* Only do other tests if this is the first blocksize.
451*
452 IF( inb.GT.1 )
453 $ GO TO 50
454*
455* Form the inverse of A so we can get a good estimate
456* of RCONDC = 1/(norm(A) * norm(inv(A))).
457*
458 CALL zlaset( 'Full', n, n, dcmplx( zero ),
459 $ dcmplx( one ), ainv, lda )
460 srnamt = 'ZPBTRS'
461 CALL zpbtrs( uplo, n, kd, n, afac, ldab, ainv, lda,
462 $ info )
463*
464* Compute RCONDC = 1/(norm(A) * norm(inv(A))).
465*
466 anorm = zlanhb( '1', uplo, n, kd, a, ldab, rwork )
467 ainvnm = zlange( '1', n, n, ainv, lda, rwork )
468 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
469 rcondc = one
470 ELSE
471 rcondc = ( one / anorm ) / ainvnm
472 END IF
473*
474 DO 40 irhs = 1, nns
475 nrhs = nsval( irhs )
476*
477*+ TEST 2
478* Solve and compute residual for A * X = B.
479*
480 srnamt = 'ZLARHS'
481 CALL zlarhs( path, xtype, uplo, ' ', n, n, kd,
482 $ kd, nrhs, a, ldab, xact, lda, b,
483 $ lda, iseed, info )
484 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
485*
486 srnamt = 'ZPBTRS'
487 CALL zpbtrs( uplo, n, kd, nrhs, afac, ldab, x,
488 $ lda, info )
489*
490* Check error code from ZPBTRS.
491*
492 IF( info.NE.0 )
493 $ CALL alaerh( path, 'ZPBTRS', info, 0, uplo,
494 $ n, n, kd, kd, nrhs, imat, nfail,
495 $ nerrs, nout )
496*
497 CALL zlacpy( 'Full', n, nrhs, b, lda, work,
498 $ lda )
499 CALL zpbt02( uplo, n, kd, nrhs, a, ldab, x, lda,
500 $ work, lda, rwork, result( 2 ) )
501*
502*+ TEST 3
503* Check solution from generated exact solution.
504*
505 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
506 $ result( 3 ) )
507*
508*+ TESTS 4, 5, and 6
509* Use iterative refinement to improve the solution.
510*
511 srnamt = 'ZPBRFS'
512 CALL zpbrfs( uplo, n, kd, nrhs, a, ldab, afac,
513 $ ldab, b, lda, x, lda, rwork,
514 $ rwork( nrhs+1 ), work,
515 $ rwork( 2*nrhs+1 ), info )
516*
517* Check error code from ZPBRFS.
518*
519 IF( info.NE.0 )
520 $ CALL alaerh( path, 'ZPBRFS', info, 0, uplo,
521 $ n, n, kd, kd, nrhs, imat, nfail,
522 $ nerrs, nout )
523*
524 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
525 $ result( 4 ) )
526 CALL zpbt05( uplo, n, kd, nrhs, a, ldab, b, lda,
527 $ x, lda, xact, lda, rwork,
528 $ rwork( nrhs+1 ), result( 5 ) )
529*
530* Print information about the tests that did not
531* pass the threshold.
532*
533 DO 30 k = 2, 6
534 IF( result( k ).GE.thresh ) THEN
535 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
536 $ CALL alahd( nout, path )
537 WRITE( nout, fmt = 9998 )uplo, n, kd,
538 $ nrhs, imat, k, result( k )
539 nfail = nfail + 1
540 END IF
541 30 CONTINUE
542 nrun = nrun + 5
543 40 CONTINUE
544*
545*+ TEST 7
546* Get an estimate of RCOND = 1/CNDNUM.
547*
548 srnamt = 'ZPBCON'
549 CALL zpbcon( uplo, n, kd, afac, ldab, anorm, rcond,
550 $ work, rwork, info )
551*
552* Check error code from ZPBCON.
553*
554 IF( info.NE.0 )
555 $ CALL alaerh( path, 'ZPBCON', info, 0, uplo, n,
556 $ n, kd, kd, -1, imat, nfail, nerrs,
557 $ nout )
558*
559 result( 7 ) = dget06( rcond, rcondc )
560*
561* Print the test ratio if it is .GE. THRESH.
562*
563 IF( result( 7 ).GE.thresh ) THEN
564 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
565 $ CALL alahd( nout, path )
566 WRITE( nout, fmt = 9997 )uplo, n, kd, imat, 7,
567 $ result( 7 )
568 nfail = nfail + 1
569 END IF
570 nrun = nrun + 1
571 50 CONTINUE
572 60 CONTINUE
573 70 CONTINUE
574 80 CONTINUE
575 90 CONTINUE
576*
577* Print a summary of the results.
578*
579 CALL alasum( path, nout, nfail, nrun, nerrs )
580*
581 9999 FORMAT( ' UPLO=''', a1, ''', N=', i5, ', KD=', i5, ', NB=', i4,
582 $ ', type ', i2, ', test ', i2, ', ratio= ', g12.5 )
583 9998 FORMAT( ' UPLO=''', a1, ''', N=', i5, ', KD=', i5, ', NRHS=', i3,
584 $ ', type ', i2, ', test(', i2, ') = ', g12.5 )
585 9997 FORMAT( ' UPLO=''', a1, ''', N=', i5, ', KD=', i5, ',', 10x,
586 $ ' type ', i2, ', test(', i2, ') = ', g12.5 )
587 RETURN
588*
589* End of ZCHKPB
590*
zlanhb
double precision function zlanhb(norm, uplo, n, k, ab, ldab, work)
ZLANHB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlanhb.f:132
zpbtrs
subroutine zpbtrs(uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
ZPBTRS
Definition zpbtrs.f:121
zpbtrf
subroutine zpbtrf(uplo, n, kd, ab, ldab, info)
ZPBTRF
Definition zpbtrf.f:142
zpbcon
subroutine zpbcon(uplo, n, kd, ab, ldab, anorm, rcond, work, rwork, info)
ZPBCON
Definition zpbcon.f:133
zpbrfs
subroutine zpbrfs(uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x, ldx, ferr, berr, work, rwork, info)
ZPBRFS
Definition zpbrfs.f:189
zswap
subroutine zswap(n, zx, incx, zy, incy)
ZSWAP
Definition zswap.f:81
zpbt05
subroutine zpbt05(uplo, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
ZPBT05
Definition zpbt05.f:171
zerrpo
subroutine zerrpo(path, nunit)
ZERRPO
Definition zerrpo.f:55
zpbt01
subroutine zpbt01(uplo, n, kd, a, lda, afac, ldafac, rwork, resid)
ZPBT01
Definition zpbt01.f:120
zpbt02
subroutine zpbt02(uplo, n, kd, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
ZPBT02
Definition zpbt02.f:136

◆ zchkpo()

subroutine zchkpo ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nout )

ZCHKPO

Purpose:
!>
!> ZCHKPO tests ZPOTRF, -TRI, -TRS, -RFS, and -CON
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (NMAX+2*NSMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 165 of file zchkpo.f.

168*
169* -- LAPACK test routine --
170* -- LAPACK is a software package provided by Univ. of Tennessee, --
171* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
172*
173* .. Scalar Arguments ..
174 LOGICAL TSTERR
175 INTEGER NMAX, NN, NNB, NNS, NOUT
176 DOUBLE PRECISION THRESH
177* ..
178* .. Array Arguments ..
179 LOGICAL DOTYPE( * )
180 INTEGER NBVAL( * ), NSVAL( * ), NVAL( * )
181 DOUBLE PRECISION RWORK( * )
182 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
183 $ WORK( * ), X( * ), XACT( * )
184* ..
185*
186* =====================================================================
187*
188* .. Parameters ..
189 COMPLEX*16 CZERO
190 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
191 INTEGER NTYPES
192 parameter( ntypes = 9 )
193 INTEGER NTESTS
194 parameter( ntests = 8 )
195* ..
196* .. Local Scalars ..
197 LOGICAL ZEROT
198 CHARACTER DIST, TYPE, UPLO, XTYPE
199 CHARACTER*3 PATH
200 INTEGER I, IMAT, IN, INB, INFO, IOFF, IRHS, IUPLO,
201 $ IZERO, K, KL, KU, LDA, MODE, N, NB, NERRS,
202 $ NFAIL, NIMAT, NRHS, NRUN
203 DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
204* ..
205* .. Local Arrays ..
206 CHARACTER UPLOS( 2 )
207 INTEGER ISEED( 4 ), ISEEDY( 4 )
208 DOUBLE PRECISION RESULT( NTESTS )
209* ..
210* .. External Functions ..
211 DOUBLE PRECISION DGET06, ZLANHE
212 EXTERNAL dget06, zlanhe
213* ..
214* .. External Subroutines ..
215 EXTERNAL alaerh, alahd, alasum, xlaenv, zerrpo, zget04,
216 $ zlacpy, zlaipd, zlarhs, zlatb4, zlatms, zpocon,
217 $ zporfs, zpot01, zpot02, zpot03, zpot05, zpotrf,
218 $ zpotri, zpotrs
219* ..
220* .. Scalars in Common ..
221 LOGICAL LERR, OK
222 CHARACTER*32 SRNAMT
223 INTEGER INFOT, NUNIT
224* ..
225* .. Common blocks ..
226 COMMON / infoc / infot, nunit, ok, lerr
227 COMMON / srnamc / srnamt
228* ..
229* .. Intrinsic Functions ..
230 INTRINSIC max
231* ..
232* .. Data statements ..
233 DATA iseedy / 1988, 1989, 1990, 1991 /
234 DATA uplos / 'U', 'L' /
235* ..
236* .. Executable Statements ..
237*
238* Initialize constants and the random number seed.
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* Test the error exits
250*
251 IF( tsterr )
252 $ CALL zerrpo( path, nout )
253 infot = 0
254*
255* Do for each value of N in NVAL
256*
257 DO 120 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 izero = 0
266 DO 110 imat = 1, nimat
267*
268* Do the tests only if DOTYPE( IMAT ) is true.
269*
270 IF( .NOT.dotype( imat ) )
271 $ GO TO 110
272*
273* Skip types 3, 4, or 5 if the matrix size is too small.
274*
275 zerot = imat.GE.3 .AND. imat.LE.5
276 IF( zerot .AND. n.LT.imat-2 )
277 $ GO TO 110
278*
279* Do first for UPLO = 'U', then for UPLO = 'L'
280*
281 DO 100 iuplo = 1, 2
282 uplo = uplos( iuplo )
283*
284* Set up parameters with ZLATB4 and generate a test matrix
285* with ZLATMS.
286*
287 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
288 $ CNDNUM, DIST )
289*
290 srnamt = 'ZLATMS'
291 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
292 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
293 $ INFO )
294*
295* Check error code from ZLATMS.
296*
297 IF( info.NE.0 ) THEN
298 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n, -1,
299 $ -1, -1, imat, nfail, nerrs, nout )
300 GO TO 100
301 END IF
302*
303* For types 3-5, zero one row and column of the matrix to
304* test that INFO is returned correctly.
305*
306 IF( zerot ) THEN
307 IF( imat.EQ.3 ) THEN
308 izero = 1
309 ELSE IF( imat.EQ.4 ) THEN
310 izero = n
311 ELSE
312 izero = n / 2 + 1
313 END IF
314 ioff = ( izero-1 )*lda
315*
316* Set row and column IZERO of A to 0.
317*
318 IF( iuplo.EQ.1 ) THEN
319 DO 20 i = 1, izero - 1
320 a( ioff+i ) = czero
321 20 CONTINUE
322 ioff = ioff + izero
323 DO 30 i = izero, n
324 a( ioff ) = czero
325 ioff = ioff + lda
326 30 CONTINUE
327 ELSE
328 ioff = izero
329 DO 40 i = 1, izero - 1
330 a( ioff ) = czero
331 ioff = ioff + lda
332 40 CONTINUE
333 ioff = ioff - izero
334 DO 50 i = izero, n
335 a( ioff+i ) = czero
336 50 CONTINUE
337 END IF
338 ELSE
339 izero = 0
340 END IF
341*
342* Set the imaginary part of the diagonals.
343*
344 CALL zlaipd( n, a, lda+1, 0 )
345*
346* Do for each value of NB in NBVAL
347*
348 DO 90 inb = 1, nnb
349 nb = nbval( inb )
350 CALL xlaenv( 1, nb )
351*
352* Compute the L*L' or U'*U factorization of the matrix.
353*
354 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
355 srnamt = 'ZPOTRF'
356 CALL zpotrf( uplo, n, afac, lda, info )
357*
358* Check error code from ZPOTRF.
359*
360 IF( info.NE.izero ) THEN
361 CALL alaerh( path, 'ZPOTRF', info, izero, uplo, n,
362 $ n, -1, -1, nb, imat, nfail, nerrs,
363 $ nout )
364 GO TO 90
365 END IF
366*
367* Skip the tests if INFO is not 0.
368*
369 IF( info.NE.0 )
370 $ GO TO 90
371*
372*+ TEST 1
373* Reconstruct matrix from factors and compute residual.
374*
375 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
376 CALL zpot01( uplo, n, a, lda, ainv, lda, rwork,
377 $ result( 1 ) )
378*
379*+ TEST 2
380* Form the inverse and compute the residual.
381*
382 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
383 srnamt = 'ZPOTRI'
384 CALL zpotri( uplo, n, ainv, lda, info )
385*
386* Check error code from ZPOTRI.
387*
388 IF( info.NE.0 )
389 $ CALL alaerh( path, 'ZPOTRI', info, 0, uplo, n, n,
390 $ -1, -1, -1, imat, nfail, nerrs, nout )
391*
392 CALL zpot03( uplo, n, a, lda, ainv, lda, work, lda,
393 $ rwork, rcondc, result( 2 ) )
394*
395* Print information about the tests that did not pass
396* the threshold.
397*
398 DO 60 k = 1, 2
399 IF( result( k ).GE.thresh ) THEN
400 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
401 $ CALL alahd( nout, path )
402 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
403 $ result( k )
404 nfail = nfail + 1
405 END IF
406 60 CONTINUE
407 nrun = nrun + 2
408*
409* Skip the rest of the tests unless this is the first
410* blocksize.
411*
412 IF( inb.NE.1 )
413 $ GO TO 90
414*
415 DO 80 irhs = 1, nns
416 nrhs = nsval( irhs )
417*
418*+ TEST 3
419* Solve and compute residual for A * X = B .
420*
421 srnamt = 'ZLARHS'
422 CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
423 $ nrhs, a, lda, xact, lda, b, lda,
424 $ iseed, info )
425 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
426*
427 srnamt = 'ZPOTRS'
428 CALL zpotrs( uplo, n, nrhs, afac, lda, x, lda,
429 $ info )
430*
431* Check error code from ZPOTRS.
432*
433 IF( info.NE.0 )
434 $ CALL alaerh( path, 'ZPOTRS', info, 0, uplo, n,
435 $ n, -1, -1, nrhs, imat, nfail,
436 $ nerrs, nout )
437*
438 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
439 CALL zpot02( uplo, n, nrhs, a, lda, x, lda, work,
440 $ lda, rwork, result( 3 ) )
441*
442*+ TEST 4
443* Check solution from generated exact solution.
444*
445 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
446 $ result( 4 ) )
447*
448*+ TESTS 5, 6, and 7
449* Use iterative refinement to improve the solution.
450*
451 srnamt = 'ZPORFS'
452 CALL zporfs( uplo, n, nrhs, a, lda, afac, lda, b,
453 $ lda, x, lda, rwork, rwork( nrhs+1 ),
454 $ work, rwork( 2*nrhs+1 ), info )
455*
456* Check error code from ZPORFS.
457*
458 IF( info.NE.0 )
459 $ CALL alaerh( path, 'ZPORFS', info, 0, uplo, n,
460 $ n, -1, -1, nrhs, imat, nfail,
461 $ nerrs, nout )
462*
463 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
464 $ result( 5 ) )
465 CALL zpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
466 $ xact, lda, rwork, rwork( nrhs+1 ),
467 $ result( 6 ) )
468*
469* Print information about the tests that did not pass
470* the threshold.
471*
472 DO 70 k = 3, 7
473 IF( result( k ).GE.thresh ) THEN
474 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
475 $ CALL alahd( nout, path )
476 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
477 $ imat, k, result( k )
478 nfail = nfail + 1
479 END IF
480 70 CONTINUE
481 nrun = nrun + 5
482 80 CONTINUE
483*
484*+ TEST 8
485* Get an estimate of RCOND = 1/CNDNUM.
486*
487 anorm = zlanhe( '1', uplo, n, a, lda, rwork )
488 srnamt = 'ZPOCON'
489 CALL zpocon( uplo, n, afac, lda, anorm, rcond, work,
490 $ rwork, info )
491*
492* Check error code from ZPOCON.
493*
494 IF( info.NE.0 )
495 $ CALL alaerh( path, 'ZPOCON', info, 0, uplo, n, n,
496 $ -1, -1, -1, imat, nfail, nerrs, nout )
497*
498 result( 8 ) = dget06( rcond, rcondc )
499*
500* Print the test ratio if it is .GE. THRESH.
501*
502 IF( result( 8 ).GE.thresh ) THEN
503 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
504 $ CALL alahd( nout, path )
505 WRITE( nout, fmt = 9997 )uplo, n, imat, 8,
506 $ result( 8 )
507 nfail = nfail + 1
508 END IF
509 nrun = nrun + 1
510 90 CONTINUE
511 100 CONTINUE
512 110 CONTINUE
513 120 CONTINUE
514*
515* Print a summary of the results.
516*
517 CALL alasum( path, nout, nfail, nrun, nerrs )
518*
519 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
520 $ i2, ', test ', i2, ', ratio =', g12.5 )
521 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
522 $ i2, ', test(', i2, ') =', g12.5 )
523 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
524 $ ', test(', i2, ') =', g12.5 )
525 RETURN
526*
527* End of ZCHKPO
528*
zpocon
subroutine zpocon(uplo, n, a, lda, anorm, rcond, work, rwork, info)
ZPOCON
Definition zpocon.f:121
zporfs
subroutine zporfs(uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx, ferr, berr, work, rwork, info)
ZPORFS
Definition zporfs.f:183
zpotri
subroutine zpotri(uplo, n, a, lda, info)
ZPOTRI
Definition zpotri.f:95
zpotrs
subroutine zpotrs(uplo, n, nrhs, a, lda, b, ldb, info)
ZPOTRS
Definition zpotrs.f:110
zpot01
subroutine zpot01(uplo, n, a, lda, afac, ldafac, rwork, resid)
ZPOT01
Definition zpot01.f:106
zpotrf
subroutine zpotrf(uplo, n, a, lda, info)
ZPOTRF VARIANT: right looking block version of the algorithm, calling Level 3 BLAS.
Definition zpotrf.f:102

◆ zchkpp()

subroutine zchkpp ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nout )

ZCHKPP

Purpose:
!>
!> ZCHKPP tests ZPPTRF, -TRI, -TRS, -RFS, and -CON
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (max(NMAX,2*NSMAX))
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 156 of file zchkpp.f.

159*
160* -- LAPACK test routine --
161* -- LAPACK is a software package provided by Univ. of Tennessee, --
162* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
163*
164* .. Scalar Arguments ..
165 LOGICAL TSTERR
166 INTEGER NMAX, NN, NNS, NOUT
167 DOUBLE PRECISION THRESH
168* ..
169* .. Array Arguments ..
170 LOGICAL DOTYPE( * )
171 INTEGER NSVAL( * ), NVAL( * )
172 DOUBLE PRECISION RWORK( * )
173 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
174 $ WORK( * ), X( * ), XACT( * )
175* ..
176*
177* =====================================================================
178*
179* .. Parameters ..
180 DOUBLE PRECISION ZERO
181 parameter( zero = 0.0d+0 )
182 INTEGER NTYPES
183 parameter( ntypes = 9 )
184 INTEGER NTESTS
185 parameter( ntests = 8 )
186* ..
187* .. Local Scalars ..
188 LOGICAL ZEROT
189 CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE
190 CHARACTER*3 PATH
191 INTEGER I, IMAT, IN, INFO, IOFF, IRHS, IUPLO, IZERO, K,
192 $ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT, NPP,
193 $ NRHS, NRUN
194 DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
195* ..
196* .. Local Arrays ..
197 CHARACTER PACKS( 2 ), UPLOS( 2 )
198 INTEGER ISEED( 4 ), ISEEDY( 4 )
199 DOUBLE PRECISION RESULT( NTESTS )
200* ..
201* .. External Functions ..
202 DOUBLE PRECISION DGET06, ZLANHP
203 EXTERNAL dget06, zlanhp
204* ..
205* .. External Subroutines ..
206 EXTERNAL alaerh, alahd, alasum, zcopy, zerrpo, zget04,
207 $ zlacpy, zlaipd, zlarhs, zlatb4, zlatms, zppcon,
208 $ zpprfs, zppt01, zppt02, zppt03, zppt05, zpptrf,
209 $ zpptri, zpptrs
210* ..
211* .. Scalars in Common ..
212 LOGICAL LERR, OK
213 CHARACTER*32 SRNAMT
214 INTEGER INFOT, NUNIT
215* ..
216* .. Common blocks ..
217 COMMON / infoc / infot, nunit, ok, lerr
218 COMMON / srnamc / srnamt
219* ..
220* .. Intrinsic Functions ..
221 INTRINSIC max
222* ..
223* .. Data statements ..
224 DATA iseedy / 1988, 1989, 1990, 1991 /
225 DATA uplos / 'U', 'L' / , packs / 'C', 'R' /
226* ..
227* .. Executable Statements ..
228*
229* Initialize constants and the random number seed.
230*
231 path( 1: 1 ) = 'Zomplex precision'
232 path( 2: 3 ) = 'PP'
233 nrun = 0
234 nfail = 0
235 nerrs = 0
236 DO 10 i = 1, 4
237 iseed( i ) = iseedy( i )
238 10 CONTINUE
239*
240* Test the error exits
241*
242 IF( tsterr )
243 $ CALL zerrpo( path, nout )
244 infot = 0
245*
246* Do for each value of N in NVAL
247*
248 DO 110 in = 1, nn
249 n = nval( in )
250 lda = max( n, 1 )
251 xtype = 'N'
252 nimat = ntypes
253 IF( n.LE.0 )
254 $ nimat = 1
255*
256 DO 100 imat = 1, nimat
257*
258* Do the tests only if DOTYPE( IMAT ) is true.
259*
260 IF( .NOT.dotype( imat ) )
261 $ GO TO 100
262*
263* Skip types 3, 4, or 5 if the matrix size is too small.
264*
265 zerot = imat.GE.3 .AND. imat.LE.5
266 IF( zerot .AND. n.LT.imat-2 )
267 $ GO TO 100
268*
269* Do first for UPLO = 'U', then for UPLO = 'L'
270*
271 DO 90 iuplo = 1, 2
272 uplo = uplos( iuplo )
273 packit = packs( iuplo )
274*
275* Set up parameters with ZLATB4 and generate a test matrix
276* with ZLATMS.
277*
278 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
279 $ CNDNUM, DIST )
280*
281 srnamt = 'ZLATMS'
282 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
283 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
284 $ INFO )
285*
286* Check error code from ZLATMS.
287*
288 IF( info.NE.0 ) THEN
289 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n, -1,
290 $ -1, -1, imat, nfail, nerrs, nout )
291 GO TO 90
292 END IF
293*
294* For types 3-5, zero one row and column of the matrix to
295* test that INFO is returned correctly.
296*
297 IF( zerot ) THEN
298 IF( imat.EQ.3 ) THEN
299 izero = 1
300 ELSE IF( imat.EQ.4 ) THEN
301 izero = n
302 ELSE
303 izero = n / 2 + 1
304 END IF
305*
306* Set row and column IZERO of A to 0.
307*
308 IF( iuplo.EQ.1 ) THEN
309 ioff = ( izero-1 )*izero / 2
310 DO 20 i = 1, izero - 1
311 a( ioff+i ) = zero
312 20 CONTINUE
313 ioff = ioff + izero
314 DO 30 i = izero, n
315 a( ioff ) = zero
316 ioff = ioff + i
317 30 CONTINUE
318 ELSE
319 ioff = izero
320 DO 40 i = 1, izero - 1
321 a( ioff ) = zero
322 ioff = ioff + n - i
323 40 CONTINUE
324 ioff = ioff - izero
325 DO 50 i = izero, n
326 a( ioff+i ) = zero
327 50 CONTINUE
328 END IF
329 ELSE
330 izero = 0
331 END IF
332*
333* Set the imaginary part of the diagonals.
334*
335 IF( iuplo.EQ.1 ) THEN
336 CALL zlaipd( n, a, 2, 1 )
337 ELSE
338 CALL zlaipd( n, a, n, -1 )
339 END IF
340*
341* Compute the L*L' or U'*U factorization of the matrix.
342*
343 npp = n*( n+1 ) / 2
344 CALL zcopy( npp, a, 1, afac, 1 )
345 srnamt = 'ZPPTRF'
346 CALL zpptrf( uplo, n, afac, info )
347*
348* Check error code from ZPPTRF.
349*
350 IF( info.NE.izero ) THEN
351 CALL alaerh( path, 'ZPPTRF', info, izero, uplo, n, n,
352 $ -1, -1, -1, imat, nfail, nerrs, nout )
353 GO TO 90
354 END IF
355*
356* Skip the tests if INFO is not 0.
357*
358 IF( info.NE.0 )
359 $ GO TO 90
360*
361*+ TEST 1
362* Reconstruct matrix from factors and compute residual.
363*
364 CALL zcopy( npp, afac, 1, ainv, 1 )
365 CALL zppt01( uplo, n, a, ainv, rwork, result( 1 ) )
366*
367*+ TEST 2
368* Form the inverse and compute the residual.
369*
370 CALL zcopy( npp, afac, 1, ainv, 1 )
371 srnamt = 'ZPPTRI'
372 CALL zpptri( uplo, n, ainv, info )
373*
374* Check error code from ZPPTRI.
375*
376 IF( info.NE.0 )
377 $ CALL alaerh( path, 'ZPPTRI', info, 0, uplo, n, n, -1,
378 $ -1, -1, imat, nfail, nerrs, nout )
379*
380 CALL zppt03( uplo, n, a, ainv, work, lda, rwork, rcondc,
381 $ result( 2 ) )
382*
383* Print information about the tests that did not pass
384* the threshold.
385*
386 DO 60 k = 1, 2
387 IF( result( k ).GE.thresh ) THEN
388 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
389 $ CALL alahd( nout, path )
390 WRITE( nout, fmt = 9999 )uplo, n, imat, k,
391 $ result( k )
392 nfail = nfail + 1
393 END IF
394 60 CONTINUE
395 nrun = nrun + 2
396*
397 DO 80 irhs = 1, nns
398 nrhs = nsval( irhs )
399*
400*+ TEST 3
401* Solve and compute residual for A * X = B.
402*
403 srnamt = 'ZLARHS'
404 CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
405 $ nrhs, a, lda, xact, lda, b, lda, iseed,
406 $ info )
407 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
408*
409 srnamt = 'ZPPTRS'
410 CALL zpptrs( uplo, n, nrhs, afac, x, lda, info )
411*
412* Check error code from ZPPTRS.
413*
414 IF( info.NE.0 )
415 $ CALL alaerh( path, 'ZPPTRS', info, 0, uplo, n, n,
416 $ -1, -1, nrhs, imat, nfail, nerrs,
417 $ nout )
418*
419 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
420 CALL zppt02( uplo, n, nrhs, a, x, lda, work, lda,
421 $ rwork, result( 3 ) )
422*
423*+ TEST 4
424* Check solution from generated exact solution.
425*
426 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
427 $ result( 4 ) )
428*
429*+ TESTS 5, 6, and 7
430* Use iterative refinement to improve the solution.
431*
432 srnamt = 'ZPPRFS'
433 CALL zpprfs( uplo, n, nrhs, a, afac, b, lda, x, lda,
434 $ rwork, rwork( nrhs+1 ), work,
435 $ rwork( 2*nrhs+1 ), info )
436*
437* Check error code from ZPPRFS.
438*
439 IF( info.NE.0 )
440 $ CALL alaerh( path, 'ZPPRFS', info, 0, uplo, n, n,
441 $ -1, -1, nrhs, imat, nfail, nerrs,
442 $ nout )
443*
444 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
445 $ result( 5 ) )
446 CALL zppt05( uplo, n, nrhs, a, b, lda, x, lda, xact,
447 $ lda, rwork, rwork( nrhs+1 ),
448 $ result( 6 ) )
449*
450* Print information about the tests that did not pass
451* the threshold.
452*
453 DO 70 k = 3, 7
454 IF( result( k ).GE.thresh ) THEN
455 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
456 $ CALL alahd( nout, path )
457 WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat,
458 $ k, result( k )
459 nfail = nfail + 1
460 END IF
461 70 CONTINUE
462 nrun = nrun + 5
463 80 CONTINUE
464*
465*+ TEST 8
466* Get an estimate of RCOND = 1/CNDNUM.
467*
468 anorm = zlanhp( '1', uplo, n, a, rwork )
469 srnamt = 'ZPPCON'
470 CALL zppcon( uplo, n, afac, anorm, rcond, work, rwork,
471 $ info )
472*
473* Check error code from ZPPCON.
474*
475 IF( info.NE.0 )
476 $ CALL alaerh( path, 'ZPPCON', info, 0, uplo, n, n, -1,
477 $ -1, -1, imat, nfail, nerrs, nout )
478*
479 result( 8 ) = dget06( rcond, rcondc )
480*
481* Print the test ratio if greater than or equal to THRESH.
482*
483 IF( result( 8 ).GE.thresh ) THEN
484 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
485 $ CALL alahd( nout, path )
486 WRITE( nout, fmt = 9999 )uplo, n, imat, 8,
487 $ result( 8 )
488 nfail = nfail + 1
489 END IF
490 nrun = nrun + 1
491*
492 90 CONTINUE
493 100 CONTINUE
494 110 CONTINUE
495*
496* Print a summary of the results.
497*
498 CALL alasum( path, nout, nfail, nrun, nerrs )
499*
500 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', type ', i2, ', test ',
501 $ i2, ', ratio =', g12.5 )
502 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
503 $ i2, ', test(', i2, ') =', g12.5 )
504 RETURN
505*
506* End of ZCHKPP
507*
zpptrs
subroutine zpptrs(uplo, n, nrhs, ap, b, ldb, info)
ZPPTRS
Definition zpptrs.f:108
zpprfs
subroutine zpprfs(uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr, work, rwork, info)
ZPPRFS
Definition zpprfs.f:171
zppcon
subroutine zppcon(uplo, n, ap, anorm, rcond, work, rwork, info)
ZPPCON
Definition zppcon.f:118
zpptri
subroutine zpptri(uplo, n, ap, info)
ZPPTRI
Definition zpptri.f:93
zpptrf
subroutine zpptrf(uplo, n, ap, info)
ZPPTRF
Definition zpptrf.f:119
zppt01
subroutine zppt01(uplo, n, a, afac, rwork, resid)
ZPPT01
Definition zppt01.f:95

◆ zchkps()

subroutine zchkps ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nrank,
integer, dimension( * ) rankval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) perm,
integer, dimension( * ) piv,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nout )

ZCHKPS

Purpose:
!>
!> ZCHKPS tests ZPSTRF.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the block size NB.
!>
[in]NRANK
!>          NRANK is INTEGER
!>          The number of values of RANK contained in the vector RANKVAL.
!>
[in]RANKVAL
!>          RANKVAL is INTEGER array, dimension (NBVAL)
!>          The values of the block size NB.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]PERM
!>          PERM is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]PIV
!>          PIV is INTEGER array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*3)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 151 of file zchkps.f.

154*
155* -- LAPACK test routine --
156* -- LAPACK is a software package provided by Univ. of Tennessee, --
157* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
158*
159* .. Scalar Arguments ..
160 DOUBLE PRECISION THRESH
161 INTEGER NMAX, NN, NNB, NOUT, NRANK
162 LOGICAL TSTERR
163* ..
164* .. Array Arguments ..
165 COMPLEX*16 A( * ), AFAC( * ), PERM( * ), WORK( * )
166 DOUBLE PRECISION RWORK( * )
167 INTEGER NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * )
168 LOGICAL DOTYPE( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 DOUBLE PRECISION ONE
175 parameter( one = 1.0e+0 )
176 INTEGER NTYPES
177 parameter( ntypes = 9 )
178* ..
179* .. Local Scalars ..
180 DOUBLE PRECISION ANORM, CNDNUM, RESULT, TOL
181 INTEGER COMPRANK, I, IMAT, IN, INB, INFO, IRANK, IUPLO,
182 $ IZERO, KL, KU, LDA, MODE, N, NB, NERRS, NFAIL,
183 $ NIMAT, NRUN, RANK, RANKDIFF
184 CHARACTER DIST, TYPE, UPLO
185 CHARACTER*3 PATH
186* ..
187* .. Local Arrays ..
188 INTEGER ISEED( 4 ), ISEEDY( 4 )
189 CHARACTER UPLOS( 2 )
190* ..
191* .. External Subroutines ..
192 EXTERNAL alaerh, alahd, alasum, xlaenv, zerrps, zlacpy,
193 $ zlatb5, zlatmt, zpst01, zpstrf
194* ..
195* .. Scalars in Common ..
196 INTEGER INFOT, NUNIT
197 LOGICAL LERR, OK
198 CHARACTER*32 SRNAMT
199* ..
200* .. Common blocks ..
201 COMMON / infoc / infot, nunit, ok, lerr
202 COMMON / srnamc / srnamt
203* ..
204* .. Intrinsic Functions ..
205 INTRINSIC dble, max, ceiling
206* ..
207* .. Data statements ..
208 DATA iseedy / 1988, 1989, 1990, 1991 /
209 DATA uplos / 'U', 'L' /
210* ..
211* .. Executable Statements ..
212*
213* Initialize constants and the random number seed.
214*
215 path( 1: 1 ) = 'Zomplex Precision'
216 path( 2: 3 ) = 'PS'
217 nrun = 0
218 nfail = 0
219 nerrs = 0
220 DO 100 i = 1, 4
221 iseed( i ) = iseedy( i )
222 100 CONTINUE
223*
224* Test the error exits
225*
226 IF( tsterr )
227 $ CALL zerrps( path, nout )
228 infot = 0
229*
230* Do for each value of N in NVAL
231*
232 DO 150 in = 1, nn
233 n = nval( in )
234 lda = max( n, 1 )
235 nimat = ntypes
236 IF( n.LE.0 )
237 $ nimat = 1
238*
239 izero = 0
240 DO 140 imat = 1, nimat
241*
242* Do the tests only if DOTYPE( IMAT ) is true.
243*
244 IF( .NOT.dotype( imat ) )
245 $ GO TO 140
246*
247* Do for each value of RANK in RANKVAL
248*
249 DO 130 irank = 1, nrank
250*
251* Only repeat test 3 to 5 for different ranks
252* Other tests use full rank
253*
254 IF( ( imat.LT.3 .OR. imat.GT.5 ) .AND. irank.GT.1 )
255 $ GO TO 130
256*
257 rank = ceiling( ( n * dble( rankval( irank ) ) )
258 $ / 100.e+0 )
259*
260*
261* Do first for UPLO = 'U', then for UPLO = 'L'
262*
263 DO 120 iuplo = 1, 2
264 uplo = uplos( iuplo )
265*
266* Set up parameters with ZLATB5 and generate a test matrix
267* with ZLATMT.
268*
269 CALL zlatb5( path, imat, n, TYPE, KL, KU, ANORM,
270 $ MODE, CNDNUM, DIST )
271*
272 srnamt = 'ZLATMT'
273 CALL zlatmt( n, n, dist, iseed, TYPE, RWORK, MODE,
274 $ CNDNUM, ANORM, RANK, KL, KU, UPLO, A,
275 $ LDA, WORK, INFO )
276*
277* Check error code from ZLATMT.
278*
279 IF( info.NE.0 ) THEN
280 CALL alaerh( path, 'ZLATMT', info, 0, uplo, n,
281 $ n, -1, -1, -1, imat, nfail, nerrs,
282 $ nout )
283 GO TO 120
284 END IF
285*
286* Do for each value of NB in NBVAL
287*
288 DO 110 inb = 1, nnb
289 nb = nbval( inb )
290 CALL xlaenv( 1, nb )
291*
292* Compute the pivoted L*L' or U'*U factorization
293* of the matrix.
294*
295 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
296 srnamt = 'ZPSTRF'
297*
298* Use default tolerance
299*
300 tol = -one
301 CALL zpstrf( uplo, n, afac, lda, piv, comprank,
302 $ tol, rwork, info )
303*
304* Check error code from ZPSTRF.
305*
306 IF( (info.LT.izero)
307 $ .OR.(info.NE.izero.AND.rank.EQ.n)
308 $ .OR.(info.LE.izero.AND.rank.LT.n) ) THEN
309 CALL alaerh( path, 'ZPSTRF', info, izero,
310 $ uplo, n, n, -1, -1, nb, imat,
311 $ nfail, nerrs, nout )
312 GO TO 110
313 END IF
314*
315* Skip the test if INFO is not 0.
316*
317 IF( info.NE.0 )
318 $ GO TO 110
319*
320* Reconstruct matrix from factors and compute residual.
321*
322* PERM holds permuted L*L^T or U^T*U
323*
324 CALL zpst01( uplo, n, a, lda, afac, lda, perm, lda,
325 $ piv, rwork, result, comprank )
326*
327* Print information about the tests that did not pass
328* the threshold or where computed rank was not RANK.
329*
330 IF( n.EQ.0 )
331 $ comprank = 0
332 rankdiff = rank - comprank
333 IF( result.GE.thresh ) THEN
334 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
335 $ CALL alahd( nout, path )
336 WRITE( nout, fmt = 9999 )uplo, n, rank,
337 $ rankdiff, nb, imat, result
338 nfail = nfail + 1
339 END IF
340 nrun = nrun + 1
341 110 CONTINUE
342*
343 120 CONTINUE
344 130 CONTINUE
345 140 CONTINUE
346 150 CONTINUE
347*
348* Print a summary of the results.
349*
350 CALL alasum( path, nout, nfail, nrun, nerrs )
351*
352 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', RANK =', i3,
353 $ ', Diff =', i5, ', NB =', i4, ', type ', i2, ', Ratio =',
354 $ g12.5 )
355 RETURN
356*
357* End of ZCHKPS
358*
zpstrf
subroutine zpstrf(uplo, n, a, lda, piv, rank, tol, work, info)
ZPSTRF computes the Cholesky factorization with complete pivoting of a complex Hermitian positive sem...
Definition zpstrf.f:142
zerrps
subroutine zerrps(path, nunit)
ZERRPS
Definition zerrps.f:55
zlatb5
subroutine zlatb5(path, imat, n, type, kl, ku, anorm, mode, cndnum, dist)
ZLATB5
Definition zlatb5.f:114
zpst01
subroutine zpst01(uplo, n, a, lda, afac, ldafac, perm, ldperm, piv, rwork, resid, rank)
ZPST01
Definition zpst01.f:136
zlatmt
subroutine zlatmt(m, n, dist, iseed, sym, d, mode, cond, dmax, rank, kl, ku, pack, a, lda, work, info)
ZLATMT
Definition zlatmt.f:340

◆ zchkpt()

subroutine zchkpt ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
complex*16, dimension( * ) a,
double precision, dimension( * ) d,
complex*16, dimension( * ) e,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nout )

ZCHKPT

Purpose:
!>
!> ZCHKPT tests ZPTTRF, -TRS, -RFS, and -CON
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*2)
!>
[out]D
!>          D is DOUBLE PRECISION array, dimension (NMAX*2)
!>
[out]E
!>          E is COMPLEX*16 array, dimension (NMAX*2)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (max(NMAX,2*NSMAX))
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 145 of file zchkpt.f.

147*
148* -- LAPACK test routine --
149* -- LAPACK is a software package provided by Univ. of Tennessee, --
150* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
151*
152* .. Scalar Arguments ..
153 LOGICAL TSTERR
154 INTEGER NN, NNS, NOUT
155 DOUBLE PRECISION THRESH
156* ..
157* .. Array Arguments ..
158 LOGICAL DOTYPE( * )
159 INTEGER NSVAL( * ), NVAL( * )
160 DOUBLE PRECISION D( * ), RWORK( * )
161 COMPLEX*16 A( * ), B( * ), E( * ), WORK( * ), X( * ),
162 $ XACT( * )
163* ..
164*
165* =====================================================================
166*
167* .. Parameters ..
168 DOUBLE PRECISION ONE, ZERO
169 parameter( one = 1.0d+0, zero = 0.0d+0 )
170 INTEGER NTYPES
171 parameter( ntypes = 12 )
172 INTEGER NTESTS
173 parameter( ntests = 7 )
174* ..
175* .. Local Scalars ..
176 LOGICAL ZEROT
177 CHARACTER DIST, TYPE, UPLO
178 CHARACTER*3 PATH
179 INTEGER I, IA, IMAT, IN, INFO, IRHS, IUPLO, IX, IZERO,
180 $ J, K, KL, KU, LDA, MODE, N, NERRS, NFAIL,
181 $ NIMAT, NRHS, NRUN
182 DOUBLE PRECISION AINVNM, ANORM, COND, DMAX, RCOND, RCONDC
183* ..
184* .. Local Arrays ..
185 CHARACTER UPLOS( 2 )
186 INTEGER ISEED( 4 ), ISEEDY( 4 )
187 DOUBLE PRECISION RESULT( NTESTS )
188 COMPLEX*16 Z( 3 )
189* ..
190* .. External Functions ..
191 INTEGER IDAMAX
192 DOUBLE PRECISION DGET06, DZASUM, ZLANHT
193 EXTERNAL idamax, dget06, dzasum, zlanht
194* ..
195* .. External Subroutines ..
196 EXTERNAL alaerh, alahd, alasum, dcopy, dlarnv, dscal,
197 $ zcopy, zdscal, zerrgt, zget04, zlacpy, zlaptm,
198 $ zlarnv, zlatb4, zlatms, zptcon, zptrfs, zptt01,
199 $ zptt02, zptt05, zpttrf, zpttrs
200* ..
201* .. Intrinsic Functions ..
202 INTRINSIC abs, dble, max
203* ..
204* .. Scalars in Common ..
205 LOGICAL LERR, OK
206 CHARACTER*32 SRNAMT
207 INTEGER INFOT, NUNIT
208* ..
209* .. Common blocks ..
210 COMMON / infoc / infot, nunit, ok, lerr
211 COMMON / srnamc / srnamt
212* ..
213* .. Data statements ..
214 DATA iseedy / 0, 0, 0, 1 / , uplos / 'U', 'L' /
215* ..
216* .. Executable Statements ..
217*
218 path( 1: 1 ) = 'Zomplex precision'
219 path( 2: 3 ) = 'PT'
220 nrun = 0
221 nfail = 0
222 nerrs = 0
223 DO 10 i = 1, 4
224 iseed( i ) = iseedy( i )
225 10 CONTINUE
226*
227* Test the error exits
228*
229 IF( tsterr )
230 $ CALL zerrgt( path, nout )
231 infot = 0
232*
233 DO 120 in = 1, nn
234*
235* Do for each value of N in NVAL.
236*
237 n = nval( in )
238 lda = max( 1, n )
239 nimat = ntypes
240 IF( n.LE.0 )
241 $ nimat = 1
242*
243 DO 110 imat = 1, nimat
244*
245* Do the tests only if DOTYPE( IMAT ) is true.
246*
247 IF( n.GT.0 .AND. .NOT.dotype( imat ) )
248 $ GO TO 110
249*
250* Set up parameters with ZLATB4.
251*
252 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
253 $ COND, DIST )
254*
255 zerot = imat.GE.8 .AND. imat.LE.10
256 IF( imat.LE.6 ) THEN
257*
258* Type 1-6: generate a Hermitian tridiagonal matrix of
259* known condition number in lower triangular band storage.
260*
261 srnamt = 'ZLATMS'
262 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE, COND,
263 $ ANORM, KL, KU, 'B', A, 2, WORK, INFO )
264*
265* Check the error code from ZLATMS.
266*
267 IF( info.NE.0 ) THEN
268 CALL alaerh( path, 'ZLATMS', info, 0, ' ', n, n, kl,
269 $ ku, -1, imat, nfail, nerrs, nout )
270 GO TO 110
271 END IF
272 izero = 0
273*
274* Copy the matrix to D and E.
275*
276 ia = 1
277 DO 20 i = 1, n - 1
278 d( i ) = dble( a( ia ) )
279 e( i ) = a( ia+1 )
280 ia = ia + 2
281 20 CONTINUE
282 IF( n.GT.0 )
283 $ d( n ) = dble( a( ia ) )
284 ELSE
285*
286* Type 7-12: generate a diagonally dominant matrix with
287* unknown condition number in the vectors D and E.
288*
289 IF( .NOT.zerot .OR. .NOT.dotype( 7 ) ) THEN
290*
291* Let E be complex, D real, with values from [-1,1].
292*
293 CALL dlarnv( 2, iseed, n, d )
294 CALL zlarnv( 2, iseed, n-1, e )
295*
296* Make the tridiagonal matrix diagonally dominant.
297*
298 IF( n.EQ.1 ) THEN
299 d( 1 ) = abs( d( 1 ) )
300 ELSE
301 d( 1 ) = abs( d( 1 ) ) + abs( e( 1 ) )
302 d( n ) = abs( d( n ) ) + abs( e( n-1 ) )
303 DO 30 i = 2, n - 1
304 d( i ) = abs( d( i ) ) + abs( e( i ) ) +
305 $ abs( e( i-1 ) )
306 30 CONTINUE
307 END IF
308*
309* Scale D and E so the maximum element is ANORM.
310*
311 ix = idamax( n, d, 1 )
312 dmax = d( ix )
313 CALL dscal( n, anorm / dmax, d, 1 )
314 CALL zdscal( n-1, anorm / dmax, e, 1 )
315*
316 ELSE IF( izero.GT.0 ) THEN
317*
318* Reuse the last matrix by copying back the zeroed out
319* elements.
320*
321 IF( izero.EQ.1 ) THEN
322 d( 1 ) = z( 2 )
323 IF( n.GT.1 )
324 $ e( 1 ) = z( 3 )
325 ELSE IF( izero.EQ.n ) THEN
326 e( n-1 ) = z( 1 )
327 d( n ) = z( 2 )
328 ELSE
329 e( izero-1 ) = z( 1 )
330 d( izero ) = z( 2 )
331 e( izero ) = z( 3 )
332 END IF
333 END IF
334*
335* For types 8-10, set one row and column of the matrix to
336* zero.
337*
338 izero = 0
339 IF( imat.EQ.8 ) THEN
340 izero = 1
341 z( 2 ) = d( 1 )
342 d( 1 ) = zero
343 IF( n.GT.1 ) THEN
344 z( 3 ) = e( 1 )
345 e( 1 ) = zero
346 END IF
347 ELSE IF( imat.EQ.9 ) THEN
348 izero = n
349 IF( n.GT.1 ) THEN
350 z( 1 ) = e( n-1 )
351 e( n-1 ) = zero
352 END IF
353 z( 2 ) = d( n )
354 d( n ) = zero
355 ELSE IF( imat.EQ.10 ) THEN
356 izero = ( n+1 ) / 2
357 IF( izero.GT.1 ) THEN
358 z( 1 ) = e( izero-1 )
359 z( 3 ) = e( izero )
360 e( izero-1 ) = zero
361 e( izero ) = zero
362 END IF
363 z( 2 ) = d( izero )
364 d( izero ) = zero
365 END IF
366 END IF
367*
368 CALL dcopy( n, d, 1, d( n+1 ), 1 )
369 IF( n.GT.1 )
370 $ CALL zcopy( n-1, e, 1, e( n+1 ), 1 )
371*
372*+ TEST 1
373* Factor A as L*D*L' and compute the ratio
374* norm(L*D*L' - A) / (n * norm(A) * EPS )
375*
376 CALL zpttrf( n, d( n+1 ), e( n+1 ), info )
377*
378* Check error code from ZPTTRF.
379*
380 IF( info.NE.izero ) THEN
381 CALL alaerh( path, 'ZPTTRF', info, izero, ' ', n, n, -1,
382 $ -1, -1, imat, nfail, nerrs, nout )
383 GO TO 110
384 END IF
385*
386 IF( info.GT.0 ) THEN
387 rcondc = zero
388 GO TO 100
389 END IF
390*
391 CALL zptt01( n, d, e, d( n+1 ), e( n+1 ), work,
392 $ result( 1 ) )
393*
394* Print the test ratio if greater than or equal to THRESH.
395*
396 IF( result( 1 ).GE.thresh ) THEN
397 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
398 $ CALL alahd( nout, path )
399 WRITE( nout, fmt = 9999 )n, imat, 1, result( 1 )
400 nfail = nfail + 1
401 END IF
402 nrun = nrun + 1
403*
404* Compute RCONDC = 1 / (norm(A) * norm(inv(A))
405*
406* Compute norm(A).
407*
408 anorm = zlanht( '1', n, d, e )
409*
410* Use ZPTTRS to solve for one column at a time of inv(A),
411* computing the maximum column sum as we go.
412*
413 ainvnm = zero
414 DO 50 i = 1, n
415 DO 40 j = 1, n
416 x( j ) = zero
417 40 CONTINUE
418 x( i ) = one
419 CALL zpttrs( 'Lower', n, 1, d( n+1 ), e( n+1 ), x, lda,
420 $ info )
421 ainvnm = max( ainvnm, dzasum( n, x, 1 ) )
422 50 CONTINUE
423 rcondc = one / max( one, anorm*ainvnm )
424*
425 DO 90 irhs = 1, nns
426 nrhs = nsval( irhs )
427*
428* Generate NRHS random solution vectors.
429*
430 ix = 1
431 DO 60 j = 1, nrhs
432 CALL zlarnv( 2, iseed, n, xact( ix ) )
433 ix = ix + lda
434 60 CONTINUE
435*
436 DO 80 iuplo = 1, 2
437*
438* Do first for UPLO = 'U', then for UPLO = 'L'.
439*
440 uplo = uplos( iuplo )
441*
442* Set the right hand side.
443*
444 CALL zlaptm( uplo, n, nrhs, one, d, e, xact, lda,
445 $ zero, b, lda )
446*
447*+ TEST 2
448* Solve A*x = b and compute the residual.
449*
450 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
451 CALL zpttrs( uplo, n, nrhs, d( n+1 ), e( n+1 ), x,
452 $ lda, info )
453*
454* Check error code from ZPTTRS.
455*
456 IF( info.NE.0 )
457 $ CALL alaerh( path, 'ZPTTRS', info, 0, uplo, n, n,
458 $ -1, -1, nrhs, imat, nfail, nerrs,
459 $ nout )
460*
461 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
462 CALL zptt02( uplo, n, nrhs, d, e, x, lda, work, lda,
463 $ result( 2 ) )
464*
465*+ TEST 3
466* Check solution from generated exact solution.
467*
468 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
469 $ result( 3 ) )
470*
471*+ TESTS 4, 5, and 6
472* Use iterative refinement to improve the solution.
473*
474 srnamt = 'ZPTRFS'
475 CALL zptrfs( uplo, n, nrhs, d, e, d( n+1 ), e( n+1 ),
476 $ b, lda, x, lda, rwork, rwork( nrhs+1 ),
477 $ work, rwork( 2*nrhs+1 ), info )
478*
479* Check error code from ZPTRFS.
480*
481 IF( info.NE.0 )
482 $ CALL alaerh( path, 'ZPTRFS', info, 0, uplo, n, n,
483 $ -1, -1, nrhs, imat, nfail, nerrs,
484 $ nout )
485*
486 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
487 $ result( 4 ) )
488 CALL zptt05( n, nrhs, d, e, b, lda, x, lda, xact, lda,
489 $ rwork, rwork( nrhs+1 ), result( 5 ) )
490*
491* Print information about the tests that did not pass the
492* threshold.
493*
494 DO 70 k = 2, 6
495 IF( result( k ).GE.thresh ) THEN
496 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
497 $ CALL alahd( nout, path )
498 WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat,
499 $ k, result( k )
500 nfail = nfail + 1
501 END IF
502 70 CONTINUE
503 nrun = nrun + 5
504*
505 80 CONTINUE
506 90 CONTINUE
507*
508*+ TEST 7
509* Estimate the reciprocal of the condition number of the
510* matrix.
511*
512 100 CONTINUE
513 srnamt = 'ZPTCON'
514 CALL zptcon( n, d( n+1 ), e( n+1 ), anorm, rcond, rwork,
515 $ info )
516*
517* Check error code from ZPTCON.
518*
519 IF( info.NE.0 )
520 $ CALL alaerh( path, 'ZPTCON', info, 0, ' ', n, n, -1, -1,
521 $ -1, imat, nfail, nerrs, nout )
522*
523 result( 7 ) = dget06( rcond, rcondc )
524*
525* Print the test ratio if greater than or equal to THRESH.
526*
527 IF( result( 7 ).GE.thresh ) THEN
528 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
529 $ CALL alahd( nout, path )
530 WRITE( nout, fmt = 9999 )n, imat, 7, result( 7 )
531 nfail = nfail + 1
532 END IF
533 nrun = nrun + 1
534 110 CONTINUE
535 120 CONTINUE
536*
537* Print a summary of the results.
538*
539 CALL alasum( path, nout, nfail, nrun, nerrs )
540*
541 9999 FORMAT( ' N =', i5, ', type ', i2, ', test ', i2, ', ratio = ',
542 $ g12.5 )
543 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS =', i3,
544 $ ', type ', i2, ', test ', i2, ', ratio = ', g12.5 )
545 RETURN
546*
547* End of ZCHKPT
548*
dlarnv
subroutine dlarnv(idist, iseed, n, x)
DLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition dlarnv.f:97
idamax
integer function idamax(n, dx, incx)
IDAMAX
Definition idamax.f:71
zlanht
double precision function zlanht(norm, n, d, e)
ZLANHT returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlanht.f:101
zptrfs
subroutine zptrfs(uplo, n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr, berr, work, rwork, info)
ZPTRFS
Definition zptrfs.f:183
zpttrf
subroutine zpttrf(n, d, e, info)
ZPTTRF
Definition zpttrf.f:92
zpttrs
subroutine zpttrs(uplo, n, nrhs, d, e, b, ldb, info)
ZPTTRS
Definition zpttrs.f:121
zptcon
subroutine zptcon(n, d, e, anorm, rcond, rwork, info)
ZPTCON
Definition zptcon.f:119
zerrgt
subroutine zerrgt(path, nunit)
ZERRGT
Definition zerrgt.f:55
zlaptm
subroutine zlaptm(uplo, n, nrhs, alpha, d, e, x, ldx, beta, b, ldb)
ZLAPTM
Definition zlaptm.f:129
zptt02
subroutine zptt02(uplo, n, nrhs, d, e, x, ldx, b, ldb, resid)
ZPTT02
Definition zptt02.f:115
zptt05
subroutine zptt05(n, nrhs, d, e, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
ZPTT05
Definition zptt05.f:150
zptt01
subroutine zptt01(n, d, e, df, ef, work, resid)
ZPTT01
Definition zptt01.f:92
dscal
subroutine dscal(n, da, dx, incx)
DSCAL
Definition dscal.f:79
dcopy
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
Definition dcopy.f:82

◆ zchkq3()

subroutine zchkq3 ( logical, dimension( * ) dotype,
integer nm,
integer, dimension( * ) mval,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer, dimension( * ) nxval,
double precision thresh,
complex*16, dimension( * ) a,
complex*16, dimension( * ) copya,
double precision, dimension( * ) s,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKQ3

Purpose:
!>
!> ZCHKQ3 tests ZGEQP3.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB and NX contained in the
!>          vectors NBVAL and NXVAL.  The blocking parameters are used
!>          in pairs (NB,NX).
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NXVAL
!>          NXVAL is INTEGER array, dimension (NNB)
!>          The values of the crossover point NX.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (MMAX*NMAX)
!>          where MMAX is the maximum value of M in MVAL and NMAX is the
!>          maximum value of N in NVAL.
!>
[out]COPYA
!>          COPYA is COMPLEX*16 array, dimension (MMAX*NMAX)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension
!>                      (min(MMAX,NMAX))
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (MMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (max(M*max(M,N) + 4*min(M,N) + max(M,N)))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (4*NMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (2*NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 155 of file zchkq3.f.

158*
159* -- LAPACK test routine --
160* -- LAPACK is a software package provided by Univ. of Tennessee, --
161* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
162*
163* .. Scalar Arguments ..
164 INTEGER NM, NN, NNB, NOUT
165 DOUBLE PRECISION THRESH
166* ..
167* .. Array Arguments ..
168 LOGICAL DOTYPE( * )
169 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
170 $ NXVAL( * )
171 DOUBLE PRECISION S( * ), RWORK( * )
172 COMPLEX*16 A( * ), COPYA( * ), TAU( * ), WORK( * )
173* ..
174*
175* =====================================================================
176*
177* .. Parameters ..
178 INTEGER NTYPES
179 parameter( ntypes = 6 )
180 INTEGER NTESTS
181 parameter( ntests = 3 )
182 DOUBLE PRECISION ONE, ZERO
183 COMPLEX*16 CZERO
184 parameter( one = 1.0d+0, zero = 0.0d+0,
185 $ czero = ( 0.0d+0, 0.0d+0 ) )
186* ..
187* .. Local Scalars ..
188 CHARACTER*3 PATH
189 INTEGER I, IHIGH, ILOW, IM, IMODE, IN, INB, INFO,
190 $ ISTEP, K, LDA, LW, LWORK, M, MNMIN, MODE, N,
191 $ NB, NERRS, NFAIL, NRUN, NX
192 DOUBLE PRECISION EPS
193* ..
194* .. Local Arrays ..
195 INTEGER ISEED( 4 ), ISEEDY( 4 )
196 DOUBLE PRECISION RESULT( NTESTS )
197* ..
198* .. External Functions ..
199 DOUBLE PRECISION DLAMCH, ZQPT01, ZQRT11, ZQRT12
200 EXTERNAL dlamch, zqpt01, zqrt11, zqrt12
201* ..
202* .. External Subroutines ..
203 EXTERNAL alahd, alasum, dlaord, icopy, xlaenv, zgeqp3,
204 $ zlacpy, zlaset, zlatms
205* ..
206* .. Intrinsic Functions ..
207 INTRINSIC max, min
208* ..
209* .. Scalars in Common ..
210 LOGICAL LERR, OK
211 CHARACTER*32 SRNAMT
212 INTEGER INFOT, IOUNIT
213* ..
214* .. Common blocks ..
215 COMMON / infoc / infot, iounit, ok, lerr
216 COMMON / srnamc / srnamt
217* ..
218* .. Data statements ..
219 DATA iseedy / 1988, 1989, 1990, 1991 /
220* ..
221* .. Executable Statements ..
222*
223* Initialize constants and the random number seed.
224*
225 path( 1: 1 ) = 'Zomplex precision'
226 path( 2: 3 ) = 'Q3'
227 nrun = 0
228 nfail = 0
229 nerrs = 0
230 DO 10 i = 1, 4
231 iseed( i ) = iseedy( i )
232 10 CONTINUE
233 eps = dlamch( 'Epsilon' )
234 infot = 0
235*
236 DO 90 im = 1, nm
237*
238* Do for each value of M in MVAL.
239*
240 m = mval( im )
241 lda = max( 1, m )
242*
243 DO 80 in = 1, nn
244*
245* Do for each value of N in NVAL.
246*
247 n = nval( in )
248 mnmin = min( m, n )
249 lwork = max( 1, m*max( m, n )+4*mnmin+max( m, n ) )
250*
251 DO 70 imode = 1, ntypes
252 IF( .NOT.dotype( imode ) )
253 $ GO TO 70
254*
255* Do for each type of matrix
256* 1: zero matrix
257* 2: one small singular value
258* 3: geometric distribution of singular values
259* 4: first n/2 columns fixed
260* 5: last n/2 columns fixed
261* 6: every second column fixed
262*
263 mode = imode
264 IF( imode.GT.3 )
265 $ mode = 1
266*
267* Generate test matrix of size m by n using
268* singular value distribution indicated by `mode'.
269*
270 DO 20 i = 1, n
271 iwork( i ) = 0
272 20 CONTINUE
273 IF( imode.EQ.1 ) THEN
274 CALL zlaset( 'Full', m, n, czero, czero, copya, lda )
275 DO 30 i = 1, mnmin
276 s( i ) = zero
277 30 CONTINUE
278 ELSE
279 CALL zlatms( m, n, 'Uniform', iseed, 'Nonsymm', s,
280 $ mode, one / eps, one, m, n, 'No packing',
281 $ copya, lda, work, info )
282 IF( imode.GE.4 ) THEN
283 IF( imode.EQ.4 ) THEN
284 ilow = 1
285 istep = 1
286 ihigh = max( 1, n / 2 )
287 ELSE IF( imode.EQ.5 ) THEN
288 ilow = max( 1, n / 2 )
289 istep = 1
290 ihigh = n
291 ELSE IF( imode.EQ.6 ) THEN
292 ilow = 1
293 istep = 2
294 ihigh = n
295 END IF
296 DO 40 i = ilow, ihigh, istep
297 iwork( i ) = 1
298 40 CONTINUE
299 END IF
300 CALL dlaord( 'Decreasing', mnmin, s, 1 )
301 END IF
302*
303 DO 60 inb = 1, nnb
304*
305* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
306*
307 nb = nbval( inb )
308 CALL xlaenv( 1, nb )
309 nx = nxval( inb )
310 CALL xlaenv( 3, nx )
311*
312* Save A and its singular values and a copy of
313* vector IWORK.
314*
315 CALL zlacpy( 'All', m, n, copya, lda, a, lda )
316 CALL icopy( n, iwork( 1 ), 1, iwork( n+1 ), 1 )
317*
318* Workspace needed.
319*
320 lw = nb*( n+1 )
321*
322 srnamt = 'ZGEQP3'
323 CALL zgeqp3( m, n, a, lda, iwork( n+1 ), tau, work,
324 $ lw, rwork, info )
325*
326* Compute norm(svd(a) - svd(r))
327*
328 result( 1 ) = zqrt12( m, n, a, lda, s, work,
329 $ lwork, rwork )
330*
331* Compute norm( A*P - Q*R )
332*
333 result( 2 ) = zqpt01( m, n, mnmin, copya, a, lda, tau,
334 $ iwork( n+1 ), work, lwork )
335*
336* Compute Q'*Q
337*
338 result( 3 ) = zqrt11( m, mnmin, a, lda, tau, work,
339 $ lwork )
340*
341* Print information about the tests that did not pass
342* the threshold.
343*
344 DO 50 k = 1, ntests
345 IF( result( k ).GE.thresh ) THEN
346 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
347 $ CALL alahd( nout, path )
348 WRITE( nout, fmt = 9999 )'ZGEQP3', m, n, nb,
349 $ imode, k, result( k )
350 nfail = nfail + 1
351 END IF
352 50 CONTINUE
353 nrun = nrun + ntests
354*
355 60 CONTINUE
356 70 CONTINUE
357 80 CONTINUE
358 90 CONTINUE
359*
360* Print a summary of the results.
361*
362 CALL alasum( path, nout, nfail, nrun, nerrs )
363*
364 9999 FORMAT( 1x, a, ' M =', i5, ', N =', i5, ', NB =', i4, ', type ',
365 $ i2, ', test ', i2, ', ratio =', g12.5 )
366*
367* End of ZCHKQ3
368*
icopy
subroutine icopy(n, sx, incx, sy, incy)
ICOPY
Definition icopy.f:75
zgeqp3
subroutine zgeqp3(m, n, a, lda, jpvt, tau, work, lwork, rwork, info)
ZGEQP3
Definition zgeqp3.f:159
zqrt11
double precision function zqrt11(m, k, a, lda, tau, work, lwork)
ZQRT11
Definition zqrt11.f:98
zqpt01
double precision function zqpt01(m, n, k, a, af, lda, tau, jpvt, work, lwork)
ZQPT01
Definition zqpt01.f:120
zqrt12
double precision function zqrt12(m, n, a, lda, s, work, lwork, rwork)
ZQRT12
Definition zqrt12.f:97
dlaord
subroutine dlaord(job, n, x, incx)
DLAORD
Definition dlaord.f:73

◆ zchkql()

subroutine zchkql ( logical, dimension( * ) dotype,
integer nm,
integer, dimension( * ) mval,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer, dimension( * ) nxval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) af,
complex*16, dimension( * ) aq,
complex*16, dimension( * ) al,
complex*16, dimension( * ) ac,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nout )

ZCHKQL

Purpose:
!>
!> ZCHKQL tests ZGEQLF, ZUNGQL and ZUNMQL.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB and NX contained in the
!>          vectors NBVAL and NXVAL.  The blocking parameters are used
!>          in pairs (NB,NX).
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NXVAL
!>          NXVAL is INTEGER array, dimension (NNB)
!>          The values of the crossover point NX.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for M or N, used in dimensioning
!>          the work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AQ
!>          AQ is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AL
!>          AL is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AC
!>          AC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 193 of file zchkql.f.

196*
197* -- LAPACK test routine --
198* -- LAPACK is a software package provided by Univ. of Tennessee, --
199* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
200*
201* .. Scalar Arguments ..
202 LOGICAL TSTERR
203 INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
204 DOUBLE PRECISION THRESH
205* ..
206* .. Array Arguments ..
207 LOGICAL DOTYPE( * )
208 INTEGER MVAL( * ), NBVAL( * ), NVAL( * ),
209 $ NXVAL( * )
210 DOUBLE PRECISION RWORK( * )
211 COMPLEX*16 A( * ), AC( * ), AF( * ), AL( * ), AQ( * ),
212 $ B( * ), TAU( * ), WORK( * ), X( * ), XACT( * )
213* ..
214*
215* =====================================================================
216*
217* .. Parameters ..
218 INTEGER NTESTS
219 parameter( ntests = 7 )
220 INTEGER NTYPES
221 parameter( ntypes = 8 )
222 DOUBLE PRECISION ZERO
223 parameter( zero = 0.0d0 )
224* ..
225* .. Local Scalars ..
226 CHARACTER DIST, TYPE
227 CHARACTER*3 PATH
228 INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
229 $ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
230 $ NRUN, NT, NX
231 DOUBLE PRECISION ANORM, CNDNUM
232* ..
233* .. Local Arrays ..
234 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
235 DOUBLE PRECISION RESULT( NTESTS )
236* ..
237* .. External Subroutines ..
238 EXTERNAL alaerh, alahd, alasum, xlaenv, zerrql, zgeqls,
239 $ zget02, zlacpy, zlarhs, zlatb4, zlatms, zqlt01,
240 $ zqlt02, zqlt03
241* ..
242* .. Intrinsic Functions ..
243 INTRINSIC max, min
244* ..
245* .. Scalars in Common ..
246 LOGICAL LERR, OK
247 CHARACTER*32 SRNAMT
248 INTEGER INFOT, NUNIT
249* ..
250* .. Common blocks ..
251 COMMON / infoc / infot, nunit, ok, lerr
252 COMMON / srnamc / srnamt
253* ..
254* .. Data statements ..
255 DATA iseedy / 1988, 1989, 1990, 1991 /
256* ..
257* .. Executable Statements ..
258*
259* Initialize constants and the random number seed.
260*
261 path( 1: 1 ) = 'Zomplex precision'
262 path( 2: 3 ) = 'QL'
263 nrun = 0
264 nfail = 0
265 nerrs = 0
266 DO 10 i = 1, 4
267 iseed( i ) = iseedy( i )
268 10 CONTINUE
269*
270* Test the error exits
271*
272 IF( tsterr )
273 $ CALL zerrql( path, nout )
274 infot = 0
275 CALL xlaenv( 2, 2 )
276*
277 lda = nmax
278 lwork = nmax*max( nmax, nrhs )
279*
280* Do for each value of M in MVAL.
281*
282 DO 70 im = 1, nm
283 m = mval( im )
284*
285* Do for each value of N in NVAL.
286*
287 DO 60 in = 1, nn
288 n = nval( in )
289 minmn = min( m, n )
290 DO 50 imat = 1, ntypes
291*
292* Do the tests only if DOTYPE( IMAT ) is true.
293*
294 IF( .NOT.dotype( imat ) )
295 $ GO TO 50
296*
297* Set up parameters with ZLATB4 and generate a test matrix
298* with ZLATMS.
299*
300 CALL zlatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
301 $ CNDNUM, DIST )
302*
303 srnamt = 'ZLATMS'
304 CALL zlatms( m, n, dist, iseed, TYPE, RWORK, MODE,
305 $ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
306 $ WORK, INFO )
307*
308* Check error code from ZLATMS.
309*
310 IF( info.NE.0 ) THEN
311 CALL alaerh( path, 'ZLATMS', info, 0, ' ', m, n, -1,
312 $ -1, -1, imat, nfail, nerrs, nout )
313 GO TO 50
314 END IF
315*
316* Set some values for K: the first value must be MINMN,
317* corresponding to the call of ZQLT01; other values are
318* used in the calls of ZQLT02, and must not exceed MINMN.
319*
320 kval( 1 ) = minmn
321 kval( 2 ) = 0
322 kval( 3 ) = 1
323 kval( 4 ) = minmn / 2
324 IF( minmn.EQ.0 ) THEN
325 nk = 1
326 ELSE IF( minmn.EQ.1 ) THEN
327 nk = 2
328 ELSE IF( minmn.LE.3 ) THEN
329 nk = 3
330 ELSE
331 nk = 4
332 END IF
333*
334* Do for each value of K in KVAL
335*
336 DO 40 ik = 1, nk
337 k = kval( ik )
338*
339* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
340*
341 DO 30 inb = 1, nnb
342 nb = nbval( inb )
343 CALL xlaenv( 1, nb )
344 nx = nxval( inb )
345 CALL xlaenv( 3, nx )
346 DO i = 1, ntests
347 result( i ) = zero
348 END DO
349 nt = 2
350 IF( ik.EQ.1 ) THEN
351*
352* Test ZGEQLF
353*
354 CALL zqlt01( m, n, a, af, aq, al, lda, tau,
355 $ work, lwork, rwork, result( 1 ) )
356 ELSE IF( m.GE.n ) THEN
357*
358* Test ZUNGQL, using factorization
359* returned by ZQLT01
360*
361 CALL zqlt02( m, n, k, a, af, aq, al, lda, tau,
362 $ work, lwork, rwork, result( 1 ) )
363 END IF
364 IF( m.GE.k ) THEN
365*
366* Test ZUNMQL, using factorization returned
367* by ZQLT01
368*
369 CALL zqlt03( m, n, k, af, ac, al, aq, lda, tau,
370 $ work, lwork, rwork, result( 3 ) )
371 nt = nt + 4
372*
373* If M>=N and K=N, call ZGEQLS to solve a system
374* with NRHS right hand sides and compute the
375* residual.
376*
377 IF( k.EQ.n .AND. inb.EQ.1 ) THEN
378*
379* Generate a solution and set the right
380* hand side.
381*
382 srnamt = 'ZLARHS'
383 CALL zlarhs( path, 'New', 'Full',
384 $ 'No transpose', m, n, 0, 0,
385 $ nrhs, a, lda, xact, lda, b, lda,
386 $ iseed, info )
387*
388 CALL zlacpy( 'Full', m, nrhs, b, lda, x,
389 $ lda )
390 srnamt = 'ZGEQLS'
391 CALL zgeqls( m, n, nrhs, af, lda, tau, x,
392 $ lda, work, lwork, info )
393*
394* Check error code from ZGEQLS.
395*
396 IF( info.NE.0 )
397 $ CALL alaerh( path, 'ZGEQLS', info, 0, ' ',
398 $ m, n, nrhs, -1, nb, imat,
399 $ nfail, nerrs, nout )
400*
401 CALL zget02( 'No transpose', m, n, nrhs, a,
402 $ lda, x( m-n+1 ), lda, b, lda,
403 $ rwork, result( 7 ) )
404 nt = nt + 1
405 END IF
406 END IF
407*
408* Print information about the tests that did not
409* pass the threshold.
410*
411 DO 20 i = 1, nt
412 IF( result( i ).GE.thresh ) THEN
413 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
414 $ CALL alahd( nout, path )
415 WRITE( nout, fmt = 9999 )m, n, k, nb, nx,
416 $ imat, i, result( i )
417 nfail = nfail + 1
418 END IF
419 20 CONTINUE
420 nrun = nrun + nt
421 30 CONTINUE
422 40 CONTINUE
423 50 CONTINUE
424 60 CONTINUE
425 70 CONTINUE
426*
427* Print a summary of the results.
428*
429 CALL alasum( path, nout, nfail, nrun, nerrs )
430*
431 9999 FORMAT( ' M=', i5, ', N=', i5, ', K=', i5, ', NB=', i4, ', NX=',
432 $ i5, ', type ', i2, ', test(', i2, ')=', g12.5 )
433 RETURN
434*
435* End of ZCHKQL
436*
zqlt03
subroutine zqlt03(m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
ZQLT03
Definition zqlt03.f:136
zqlt02
subroutine zqlt02(m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
ZQLT02
Definition zqlt02.f:136
zqlt01
subroutine zqlt01(m, n, a, af, q, l, lda, tau, work, lwork, rwork, result)
ZQLT01
Definition zqlt01.f:126
zerrql
subroutine zerrql(path, nunit)
ZERRQL
Definition zerrql.f:55
zgeqls
subroutine zgeqls(m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
ZGEQLS
Definition zgeqls.f:122

◆ zchkqr()

subroutine zchkqr ( logical, dimension( * ) dotype,
integer nm,
integer, dimension( * ) mval,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer, dimension( * ) nxval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) af,
complex*16, dimension( * ) aq,
complex*16, dimension( * ) ar,
complex*16, dimension( * ) ac,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKQR

Purpose:
!>
!> ZCHKQR tests ZGEQRF, ZUNGQR and ZUNMQR.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB and NX contained in the
!>          vectors NBVAL and NXVAL.  The blocking parameters are used
!>          in pairs (NB,NX).
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NXVAL
!>          NXVAL is INTEGER array, dimension (NNB)
!>          The values of the crossover point NX.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for M or N, used in dimensioning
!>          the work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AQ
!>          AQ is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AR
!>          AR is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AC
!>          AC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 198 of file zchkqr.f.

201*
202* -- LAPACK test routine --
203* -- LAPACK is a software package provided by Univ. of Tennessee, --
204* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
205*
206* .. Scalar Arguments ..
207 LOGICAL TSTERR
208 INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
209 DOUBLE PRECISION THRESH
210* ..
211* .. Array Arguments ..
212 LOGICAL DOTYPE( * )
213 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
214 $ NXVAL( * )
215 DOUBLE PRECISION RWORK( * )
216 COMPLEX*16 A( * ), AC( * ), AF( * ), AQ( * ), AR( * ),
217 $ B( * ), TAU( * ), WORK( * ), X( * ), XACT( * )
218* ..
219*
220* =====================================================================
221*
222* .. Parameters ..
223 INTEGER NTESTS
224 parameter( ntests = 9 )
225 INTEGER NTYPES
226 parameter( ntypes = 8 )
227 DOUBLE PRECISION ZERO
228 parameter( zero = 0.0d0 )
229* ..
230* .. Local Scalars ..
231 CHARACTER DIST, TYPE
232 CHARACTER*3 PATH
233 INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
234 $ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
235 $ NRUN, NT, NX
236 DOUBLE PRECISION ANORM, CNDNUM
237* ..
238* .. Local Arrays ..
239 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
240 DOUBLE PRECISION RESULT( NTESTS )
241* ..
242* .. External Functions ..
243 LOGICAL ZGENND
244 EXTERNAL zgennd
245* ..
246* .. External Subroutines ..
247 EXTERNAL alaerh, alahd, alasum, xlaenv, zerrqr, zgeqrs,
248 $ zget02, zlacpy, zlarhs, zlatb4, zlatms, zqrt01,
249 $ zqrt01p, zqrt02, zqrt03
250* ..
251* .. Intrinsic Functions ..
252 INTRINSIC max, min
253* ..
254* .. Scalars in Common ..
255 LOGICAL LERR, OK
256 CHARACTER*32 SRNAMT
257 INTEGER INFOT, NUNIT
258* ..
259* .. Common blocks ..
260 COMMON / infoc / infot, nunit, ok, lerr
261 COMMON / srnamc / srnamt
262* ..
263* .. Data statements ..
264 DATA iseedy / 1988, 1989, 1990, 1991 /
265* ..
266* .. Executable Statements ..
267*
268* Initialize constants and the random number seed.
269*
270 path( 1: 1 ) = 'Zomplex precision'
271 path( 2: 3 ) = 'QR'
272 nrun = 0
273 nfail = 0
274 nerrs = 0
275 DO 10 i = 1, 4
276 iseed( i ) = iseedy( i )
277 10 CONTINUE
278*
279* Test the error exits
280*
281 IF( tsterr )
282 $ CALL zerrqr( path, nout )
283 infot = 0
284 CALL xlaenv( 2, 2 )
285*
286 lda = nmax
287 lwork = nmax*max( nmax, nrhs )
288*
289* Do for each value of M in MVAL.
290*
291 DO 70 im = 1, nm
292 m = mval( im )
293*
294* Do for each value of N in NVAL.
295*
296 DO 60 in = 1, nn
297 n = nval( in )
298 minmn = min( m, n )
299 DO 50 imat = 1, ntypes
300*
301* Do the tests only if DOTYPE( IMAT ) is true.
302*
303 IF( .NOT.dotype( imat ) )
304 $ GO TO 50
305*
306* Set up parameters with ZLATB4 and generate a test matrix
307* with ZLATMS.
308*
309 CALL zlatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
310 $ CNDNUM, DIST )
311*
312 srnamt = 'ZLATMS'
313 CALL zlatms( m, n, dist, iseed, TYPE, RWORK, MODE,
314 $ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
315 $ WORK, INFO )
316*
317* Check error code from ZLATMS.
318*
319 IF( info.NE.0 ) THEN
320 CALL alaerh( path, 'ZLATMS', info, 0, ' ', m, n, -1,
321 $ -1, -1, imat, nfail, nerrs, nout )
322 GO TO 50
323 END IF
324*
325* Set some values for K: the first value must be MINMN,
326* corresponding to the call of ZQRT01; other values are
327* used in the calls of ZQRT02, and must not exceed MINMN.
328*
329 kval( 1 ) = minmn
330 kval( 2 ) = 0
331 kval( 3 ) = 1
332 kval( 4 ) = minmn / 2
333 IF( minmn.EQ.0 ) THEN
334 nk = 1
335 ELSE IF( minmn.EQ.1 ) THEN
336 nk = 2
337 ELSE IF( minmn.LE.3 ) THEN
338 nk = 3
339 ELSE
340 nk = 4
341 END IF
342*
343* Do for each value of K in KVAL
344*
345 DO 40 ik = 1, nk
346 k = kval( ik )
347*
348* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
349*
350 DO 30 inb = 1, nnb
351 nb = nbval( inb )
352 CALL xlaenv( 1, nb )
353 nx = nxval( inb )
354 CALL xlaenv( 3, nx )
355 DO i = 1, ntests
356 result( i ) = zero
357 END DO
358 nt = 2
359 IF( ik.EQ.1 ) THEN
360*
361* Test ZGEQRF
362*
363 CALL zqrt01( m, n, a, af, aq, ar, lda, tau,
364 $ work, lwork, rwork, result( 1 ) )
365*
366* Test ZGEQRFP
367*
368 CALL zqrt01p( m, n, a, af, aq, ar, lda, tau,
369 $ work, lwork, rwork, result( 8 ) )
370
371 IF( .NOT. zgennd( m, n, af, lda ) )
372 $ result( 9 ) = 2*thresh
373 nt = nt + 1
374 ELSE IF( m.GE.n ) THEN
375*
376* Test ZUNGQR, using factorization
377* returned by ZQRT01
378*
379 CALL zqrt02( m, n, k, a, af, aq, ar, lda, tau,
380 $ work, lwork, rwork, result( 1 ) )
381 END IF
382 IF( m.GE.k ) THEN
383*
384* Test ZUNMQR, using factorization returned
385* by ZQRT01
386*
387 CALL zqrt03( m, n, k, af, ac, ar, aq, lda, tau,
388 $ work, lwork, rwork, result( 3 ) )
389 nt = nt + 4
390*
391* If M>=N and K=N, call ZGEQRS to solve a system
392* with NRHS right hand sides and compute the
393* residual.
394*
395 IF( k.EQ.n .AND. inb.EQ.1 ) THEN
396*
397* Generate a solution and set the right
398* hand side.
399*
400 srnamt = 'ZLARHS'
401 CALL zlarhs( path, 'New', 'Full',
402 $ 'No transpose', m, n, 0, 0,
403 $ nrhs, a, lda, xact, lda, b, lda,
404 $ iseed, info )
405*
406 CALL zlacpy( 'Full', m, nrhs, b, lda, x,
407 $ lda )
408 srnamt = 'ZGEQRS'
409 CALL zgeqrs( m, n, nrhs, af, lda, tau, x,
410 $ lda, work, lwork, info )
411*
412* Check error code from ZGEQRS.
413*
414 IF( info.NE.0 )
415 $ CALL alaerh( path, 'ZGEQRS', info, 0, ' ',
416 $ m, n, nrhs, -1, nb, imat,
417 $ nfail, nerrs, nout )
418*
419 CALL zget02( 'No transpose', m, n, nrhs, a,
420 $ lda, x, lda, b, lda, rwork,
421 $ result( 7 ) )
422 nt = nt + 1
423 END IF
424 END IF
425*
426* Print information about the tests that did not
427* pass the threshold.
428*
429 DO 20 i = 1, ntests
430 IF( result( i ).GE.thresh ) THEN
431 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
432 $ CALL alahd( nout, path )
433 WRITE( nout, fmt = 9999 )m, n, k, nb, nx,
434 $ imat, i, result( i )
435 nfail = nfail + 1
436 END IF
437 20 CONTINUE
438 nrun = nrun + ntests
439 30 CONTINUE
440 40 CONTINUE
441 50 CONTINUE
442 60 CONTINUE
443 70 CONTINUE
444*
445* Print a summary of the results.
446*
447 CALL alasum( path, nout, nfail, nrun, nerrs )
448*
449 9999 FORMAT( ' M=', i5, ', N=', i5, ', K=', i5, ', NB=', i4, ', NX=',
450 $ i5, ', type ', i2, ', test(', i2, ')=', g12.5 )
451 RETURN
452*
453* End of ZCHKQR
454*
zqrt02
subroutine zqrt02(m, n, k, a, af, q, r, lda, tau, work, lwork, rwork, result)
ZQRT02
Definition zqrt02.f:135
zqrt01p
subroutine zqrt01p(m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
ZQRT01P
Definition zqrt01p.f:126
zgeqrs
subroutine zgeqrs(m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
ZGEQRS
Definition zgeqrs.f:121
zgennd
logical function zgennd(m, n, a, lda)
ZGENND
Definition zgennd.f:68
zqrt03
subroutine zqrt03(m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
ZQRT03
Definition zqrt03.f:136
zerrqr
subroutine zerrqr(path, nunit)
ZERRQR
Definition zerrqr.f:55
zqrt01
subroutine zqrt01(m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
ZQRT01
Definition zqrt01.f:126

◆ zchkqrt()

subroutine zchkqrt ( double precision thresh,
logical tsterr,
integer nm,
integer, dimension( * ) mval,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nout )

ZCHKQRT

Purpose:
!>
!> ZCHKQRT tests ZGEQRT and ZGEMQRT.
!>
Parameters
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 99 of file zchkqrt.f.

101 IMPLICIT NONE
102*
103* -- LAPACK test routine --
104* -- LAPACK is a software package provided by Univ. of Tennessee, --
105* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
106*
107* .. Scalar Arguments ..
108 LOGICAL TSTERR
109 INTEGER NM, NN, NNB, NOUT
110 DOUBLE PRECISION THRESH
111* ..
112* .. Array Arguments ..
113 INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
114* ..
115*
116* =====================================================================
117*
118* .. Parameters ..
119 INTEGER NTESTS
120 parameter( ntests = 6 )
121* ..
122* .. Local Scalars ..
123 CHARACTER*3 PATH
124 INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN,
125 $ MINMN
126* ..
127* .. Local Arrays ..
128 DOUBLE PRECISION RESULT( NTESTS )
129* ..
130* .. External Subroutines ..
131 EXTERNAL alaerh, alahd, alasum, zerrqrt, zqrt04
132* ..
133* .. Scalars in Common ..
134 LOGICAL LERR, OK
135 CHARACTER*32 SRNAMT
136 INTEGER INFOT, NUNIT
137* ..
138* .. Common blocks ..
139 COMMON / infoc / infot, nunit, ok, lerr
140 COMMON / srnamc / srnamt
141* ..
142* .. Executable Statements ..
143*
144* Initialize constants
145*
146 path( 1: 1 ) = 'Z'
147 path( 2: 3 ) = 'QT'
148 nrun = 0
149 nfail = 0
150 nerrs = 0
151*
152* Test the error exits
153*
154 IF( tsterr ) CALL zerrqrt( path, nout )
155 infot = 0
156*
157* Do for each value of M in MVAL.
158*
159 DO i = 1, nm
160 m = mval( i )
161*
162* Do for each value of N in NVAL.
163*
164 DO j = 1, nn
165 n = nval( j )
166*
167* Do for each possible value of NB
168*
169 minmn = min( m, n )
170 DO k = 1, nnb
171 nb = nbval( k )
172*
173* Test ZGEQRT and ZGEMQRT
174*
175 IF( (nb.LE.minmn).AND.(nb.GT.0) ) THEN
176 CALL zqrt04( m, n, nb, result )
177*
178* Print information about the tests that did not
179* pass the threshold.
180*
181 DO t = 1, ntests
182 IF( result( t ).GE.thresh ) THEN
183 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
184 $ CALL alahd( nout, path )
185 WRITE( nout, fmt = 9999 )m, n, nb,
186 $ t, result( t )
187 nfail = nfail + 1
188 END IF
189 END DO
190 nrun = nrun + ntests
191 END IF
192 END DO
193 END DO
194 END DO
195*
196* Print a summary of the results.
197*
198 CALL alasum( path, nout, nfail, nrun, nerrs )
199*
200 9999 FORMAT( ' M=', i5, ', N=', i5, ', NB=', i4,
201 $ ' test(', i2, ')=', g12.5 )
202 RETURN
203*
204* End of ZCHKQRT
205*
zerrqrt
subroutine zerrqrt(path, nunit)
ZERRQRT
Definition zerrqrt.f:55
zqrt04
subroutine zqrt04(m, n, nb, result)
ZQRT04
Definition zqrt04.f:73

◆ zchkqrtp()

subroutine zchkqrtp ( double precision thresh,
logical tsterr,
integer nm,
integer, dimension( * ) mval,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nout )

ZCHKQRTP

Purpose:
!>
!> ZCHKQRTP tests ZTPQRT and ZTPMQRT.
!>
Parameters
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 100 of file zchkqrtp.f.

102 IMPLICIT NONE
103*
104* -- LAPACK test routine --
105* -- LAPACK is a software package provided by Univ. of Tennessee, --
106* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
107*
108* .. Scalar Arguments ..
109 LOGICAL TSTERR
110 INTEGER NM, NN, NNB, NOUT
111 DOUBLE PRECISION THRESH
112* ..
113* .. Array Arguments ..
114 INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
115* ..
116*
117* =====================================================================
118*
119* .. Parameters ..
120 INTEGER NTESTS
121 parameter( ntests = 6 )
122* ..
123* .. Local Scalars ..
124 CHARACTER*3 PATH
125 INTEGER I, J, K, T, L, M, N, NB, NFAIL, NERRS, NRUN,
126 $ MINMN
127* ..
128* .. Local Arrays ..
129 DOUBLE PRECISION RESULT( NTESTS )
130* ..
131* .. External Subroutines ..
132 EXTERNAL alaerh, alahd, alasum, zerrqrtp
133* ..
134* .. Scalars in Common ..
135 LOGICAL LERR, OK
136 CHARACTER*32 SRNAMT
137 INTEGER INFOT, NUNIT
138* ..
139* .. Common blocks ..
140 COMMON / infoc / infot, nunit, ok, lerr
141 COMMON / srnamc / srnamt
142* ..
143* .. Executable Statements ..
144*
145* Initialize constants
146*
147 path( 1: 1 ) = 'Z'
148 path( 2: 3 ) = 'QX'
149 nrun = 0
150 nfail = 0
151 nerrs = 0
152*
153* Test the error exits
154*
155 IF( tsterr ) CALL zerrqrtp( path, nout )
156 infot = 0
157*
158* Do for each value of M
159*
160 DO i = 1, nm
161 m = mval( i )
162*
163* Do for each value of N
164*
165 DO j = 1, nn
166 n = nval( j )
167*
168* Do for each value of L
169*
170 minmn = min( m, n )
171 DO l = 0, minmn, max( minmn, 1 )
172*
173* Do for each possible value of NB
174*
175 DO k = 1, nnb
176 nb = nbval( k )
177*
178* Test ZTPQRT and ZTPMQRT
179*
180 IF( (nb.LE.n).AND.(nb.GT.0) ) THEN
181 CALL zqrt05( m, n, l, nb, result )
182*
183* Print information about the tests that did not
184* pass the threshold.
185*
186 DO t = 1, ntests
187 IF( result( t ).GE.thresh ) THEN
188 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
189 $ CALL alahd( nout, path )
190 WRITE( nout, fmt = 9999 )m, n, nb,
191 $ t, result( t )
192 nfail = nfail + 1
193 END IF
194 END DO
195 nrun = nrun + ntests
196 END IF
197 END DO
198 END DO
199 END DO
200 END DO
201*
202* Print a summary of the results.
203*
204 CALL alasum( path, nout, nfail, nrun, nerrs )
205*
206 9999 FORMAT( ' M=', i5, ', N=', i5, ', NB=', i4,
207 $ ' test(', i2, ')=', g12.5 )
208 RETURN
209*
210* End of ZCHKQRTP
211*
zerrqrtp
subroutine zerrqrtp(path, nunit)
ZERRQRTP
Definition zerrqrtp.f:55
zqrt05
subroutine zqrt05(m, n, l, nb, result)
ZQRT05
Definition zqrt05.f:80

◆ zchkrfp()

program zchkrfp

ZCHKRFP

Purpose:
!>
!> ZCHKRFP is the main test program for the COMPLEX*16 linear equation
!> routines with RFP storage format
!>
!> 
!>  MAXIN   INTEGER
!>          The number of different values that can be used for each of
!>          M, N, or NB
!>
!>  MAXRHS  INTEGER
!>          The maximum number of right hand sides
!>
!>  NTYPES  INTEGER
!>
!>  NMAX    INTEGER
!>          The maximum allowable value for N.
!>
!>  NIN     INTEGER
!>          The unit number for input
!>
!>  NOUT    INTEGER
!>          The unit number for output
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 58 of file zchkrfp.f.

◆ zchkrq()

subroutine zchkrq ( logical, dimension( * ) dotype,
integer nm,
integer, dimension( * ) mval,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer, dimension( * ) nxval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) af,
complex*16, dimension( * ) aq,
complex*16, dimension( * ) ar,
complex*16, dimension( * ) ac,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKRQ

Purpose:
!>
!> ZCHKRQ tests ZGERQF, ZUNGRQ and ZUNMRQ.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB and NX contained in the
!>          vectors NBVAL and NXVAL.  The blocking parameters are used
!>          in pairs (NB,NX).
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NXVAL
!>          NXVAL is INTEGER array, dimension (NNB)
!>          The values of the crossover point NX.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for M or N, used in dimensioning
!>          the work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AQ
!>          AQ is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AR
!>          AR is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AC
!>          AC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 198 of file zchkrq.f.

201*
202* -- LAPACK test routine --
203* -- LAPACK is a software package provided by Univ. of Tennessee, --
204* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
205*
206* .. Scalar Arguments ..
207 LOGICAL TSTERR
208 INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
209 DOUBLE PRECISION THRESH
210* ..
211* .. Array Arguments ..
212 LOGICAL DOTYPE( * )
213 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
214 $ NXVAL( * )
215 DOUBLE PRECISION RWORK( * )
216 COMPLEX*16 A( * ), AC( * ), AF( * ), AQ( * ), AR( * ),
217 $ B( * ), TAU( * ), WORK( * ), X( * ), XACT( * )
218* ..
219*
220* =====================================================================
221*
222* .. Parameters ..
223 INTEGER NTESTS
224 parameter( ntests = 7 )
225 INTEGER NTYPES
226 parameter( ntypes = 8 )
227 DOUBLE PRECISION ZERO
228 parameter( zero = 0.0d0 )
229* ..
230* .. Local Scalars ..
231 CHARACTER DIST, TYPE
232 CHARACTER*3 PATH
233 INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
234 $ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
235 $ NRUN, NT, NX
236 DOUBLE PRECISION ANORM, CNDNUM
237* ..
238* .. Local Arrays ..
239 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
240 DOUBLE PRECISION RESULT( NTESTS )
241* ..
242* .. External Subroutines ..
243 EXTERNAL alaerh, alahd, alasum, xlaenv, zerrrq, zgerqs,
244 $ zget02, zlacpy, zlarhs, zlatb4, zlatms, zrqt01,
245 $ zrqt02, zrqt03
246* ..
247* .. Intrinsic Functions ..
248 INTRINSIC max, min
249* ..
250* .. Scalars in Common ..
251 LOGICAL LERR, OK
252 CHARACTER*32 SRNAMT
253 INTEGER INFOT, NUNIT
254* ..
255* .. Common blocks ..
256 COMMON / infoc / infot, nunit, ok, lerr
257 COMMON / srnamc / srnamt
258* ..
259* .. Data statements ..
260 DATA iseedy / 1988, 1989, 1990, 1991 /
261* ..
262* .. Executable Statements ..
263*
264* Initialize constants and the random number seed.
265*
266 path( 1: 1 ) = 'Zomplex precision'
267 path( 2: 3 ) = 'RQ'
268 nrun = 0
269 nfail = 0
270 nerrs = 0
271 DO 10 i = 1, 4
272 iseed( i ) = iseedy( i )
273 10 CONTINUE
274*
275* Test the error exits
276*
277 IF( tsterr )
278 $ CALL zerrrq( path, nout )
279 infot = 0
280 CALL xlaenv( 2, 2 )
281*
282 lda = nmax
283 lwork = nmax*max( nmax, nrhs )
284*
285* Do for each value of M in MVAL.
286*
287 DO 70 im = 1, nm
288 m = mval( im )
289*
290* Do for each value of N in NVAL.
291*
292 DO 60 in = 1, nn
293 n = nval( in )
294 minmn = min( m, n )
295 DO 50 imat = 1, ntypes
296*
297* Do the tests only if DOTYPE( IMAT ) is true.
298*
299 IF( .NOT.dotype( imat ) )
300 $ GO TO 50
301*
302* Set up parameters with ZLATB4 and generate a test matrix
303* with ZLATMS.
304*
305 CALL zlatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
306 $ CNDNUM, DIST )
307*
308 srnamt = 'ZLATMS'
309 CALL zlatms( m, n, dist, iseed, TYPE, RWORK, MODE,
310 $ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
311 $ WORK, INFO )
312*
313* Check error code from ZLATMS.
314*
315 IF( info.NE.0 ) THEN
316 CALL alaerh( path, 'ZLATMS', info, 0, ' ', m, n, -1,
317 $ -1, -1, imat, nfail, nerrs, nout )
318 GO TO 50
319 END IF
320*
321* Set some values for K: the first value must be MINMN,
322* corresponding to the call of ZRQT01; other values are
323* used in the calls of ZRQT02, and must not exceed MINMN.
324*
325 kval( 1 ) = minmn
326 kval( 2 ) = 0
327 kval( 3 ) = 1
328 kval( 4 ) = minmn / 2
329 IF( minmn.EQ.0 ) THEN
330 nk = 1
331 ELSE IF( minmn.EQ.1 ) THEN
332 nk = 2
333 ELSE IF( minmn.LE.3 ) THEN
334 nk = 3
335 ELSE
336 nk = 4
337 END IF
338*
339* Do for each value of K in KVAL
340*
341 DO 40 ik = 1, nk
342 k = kval( ik )
343*
344* Do for each pair of values (NB,NX) in NBVAL and NXVAL.
345*
346 DO 30 inb = 1, nnb
347 nb = nbval( inb )
348 CALL xlaenv( 1, nb )
349 nx = nxval( inb )
350 CALL xlaenv( 3, nx )
351 DO i = 1, ntests
352 result( i ) = zero
353 END DO
354 nt = 2
355 IF( ik.EQ.1 ) THEN
356*
357* Test ZGERQF
358*
359 CALL zrqt01( m, n, a, af, aq, ar, lda, tau,
360 $ work, lwork, rwork, result( 1 ) )
361 ELSE IF( m.LE.n ) THEN
362*
363* Test ZUNGRQ, using factorization
364* returned by ZRQT01
365*
366 CALL zrqt02( m, n, k, a, af, aq, ar, lda, tau,
367 $ work, lwork, rwork, result( 1 ) )
368 END IF
369 IF( m.GE.k ) THEN
370*
371* Test ZUNMRQ, using factorization returned
372* by ZRQT01
373*
374 CALL zrqt03( m, n, k, af, ac, ar, aq, lda, tau,
375 $ work, lwork, rwork, result( 3 ) )
376 nt = nt + 4
377*
378* If M>=N and K=N, call ZGERQS to solve a system
379* with NRHS right hand sides and compute the
380* residual.
381*
382 IF( k.EQ.m .AND. inb.EQ.1 ) THEN
383*
384* Generate a solution and set the right
385* hand side.
386*
387 srnamt = 'ZLARHS'
388 CALL zlarhs( path, 'New', 'Full',
389 $ 'No transpose', m, n, 0, 0,
390 $ nrhs, a, lda, xact, lda, b, lda,
391 $ iseed, info )
392*
393 CALL zlacpy( 'Full', m, nrhs, b, lda,
394 $ x( n-m+1 ), lda )
395 srnamt = 'ZGERQS'
396 CALL zgerqs( m, n, nrhs, af, lda, tau, x,
397 $ lda, work, lwork, info )
398*
399* Check error code from ZGERQS.
400*
401 IF( info.NE.0 )
402 $ CALL alaerh( path, 'ZGERQS', info, 0, ' ',
403 $ m, n, nrhs, -1, nb, imat,
404 $ nfail, nerrs, nout )
405*
406 CALL zget02( 'No transpose', m, n, nrhs, a,
407 $ lda, x, lda, b, lda, rwork,
408 $ result( 7 ) )
409 nt = nt + 1
410 END IF
411 END IF
412*
413* Print information about the tests that did not
414* pass the threshold.
415*
416 DO 20 i = 1, nt
417 IF( result( i ).GE.thresh ) THEN
418 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
419 $ CALL alahd( nout, path )
420 WRITE( nout, fmt = 9999 )m, n, k, nb, nx,
421 $ imat, i, result( i )
422 nfail = nfail + 1
423 END IF
424 20 CONTINUE
425 nrun = nrun + nt
426 30 CONTINUE
427 40 CONTINUE
428 50 CONTINUE
429 60 CONTINUE
430 70 CONTINUE
431*
432* Print a summary of the results.
433*
434 CALL alasum( path, nout, nfail, nrun, nerrs )
435*
436 9999 FORMAT( ' M=', i5, ', N=', i5, ', K=', i5, ', NB=', i4, ', NX=',
437 $ i5, ', type ', i2, ', test(', i2, ')=', g12.5 )
438 RETURN
439*
440* End of ZCHKRQ
441*
zrqt02
subroutine zrqt02(m, n, k, a, af, q, r, lda, tau, work, lwork, rwork, result)
ZRQT02
Definition zrqt02.f:136
zerrrq
subroutine zerrrq(path, nunit)
ZERRRQ
Definition zerrrq.f:55
zrqt03
subroutine zrqt03(m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
ZRQT03
Definition zrqt03.f:136
zgerqs
subroutine zgerqs(m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
ZGERQS
Definition zgerqs.f:122
zrqt01
subroutine zrqt01(m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
ZRQT01
Definition zrqt01.f:126

◆ zchksp()

subroutine zchksp ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKSP

Purpose:
!>
!> ZCHKSP tests ZSPTRF, -TRI, -TRS, -RFS, and -CON
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(2,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array,
!>                                 dimension (NMAX+2*NSMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 161 of file zchksp.f.

164*
165* -- LAPACK test routine --
166* -- LAPACK is a software package provided by Univ. of Tennessee, --
167* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
168*
169* .. Scalar Arguments ..
170 LOGICAL TSTERR
171 INTEGER NMAX, NN, NNS, NOUT
172 DOUBLE PRECISION THRESH
173* ..
174* .. Array Arguments ..
175 LOGICAL DOTYPE( * )
176 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
177 DOUBLE PRECISION RWORK( * )
178 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
179 $ WORK( * ), X( * ), XACT( * )
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 DOUBLE PRECISION ZERO
186 parameter( zero = 0.0d+0 )
187 INTEGER NTYPES
188 parameter( ntypes = 11 )
189 INTEGER NTESTS
190 parameter( ntests = 8 )
191* ..
192* .. Local Scalars ..
193 LOGICAL TRFCON, ZEROT
194 CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE
195 CHARACTER*3 PATH
196 INTEGER I, I1, I2, IMAT, IN, INFO, IOFF, IRHS, IUPLO,
197 $ IZERO, J, K, KL, KU, LDA, MODE, N, NERRS,
198 $ NFAIL, NIMAT, NPP, NRHS, NRUN, NT
199 DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
200* ..
201* .. Local Arrays ..
202 CHARACTER UPLOS( 2 )
203 INTEGER ISEED( 4 ), ISEEDY( 4 )
204 DOUBLE PRECISION RESULT( NTESTS )
205* ..
206* .. External Functions ..
207 LOGICAL LSAME
208 DOUBLE PRECISION DGET06, ZLANSP
209 EXTERNAL lsame, dget06, zlansp
210* ..
211* .. External Subroutines ..
212 EXTERNAL alaerh, alahd, alasum, zcopy, zerrsy, zget04,
213 $ zlacpy, zlarhs, zlatb4, zlatms, zlatsp, zppt05,
214 $ zspcon, zsprfs, zspt01, zspt02, zspt03, zsptrf,
215 $ zsptri, zsptrs
216* ..
217* .. Intrinsic Functions ..
218 INTRINSIC max, min
219* ..
220* .. Scalars in Common ..
221 LOGICAL LERR, OK
222 CHARACTER*32 SRNAMT
223 INTEGER INFOT, NUNIT
224* ..
225* .. Common blocks ..
226 COMMON / infoc / infot, nunit, ok, lerr
227 COMMON / srnamc / srnamt
228* ..
229* .. Data statements ..
230 DATA iseedy / 1988, 1989, 1990, 1991 /
231 DATA uplos / 'U', 'L' /
232* ..
233* .. Executable Statements ..
234*
235* Initialize constants and the random number seed.
236*
237 path( 1: 1 ) = 'Zomplex precision'
238 path( 2: 3 ) = 'SP'
239 nrun = 0
240 nfail = 0
241 nerrs = 0
242 DO 10 i = 1, 4
243 iseed( i ) = iseedy( i )
244 10 CONTINUE
245*
246* Test the error exits
247*
248 IF( tsterr )
249 $ CALL zerrsy( path, nout )
250 infot = 0
251*
252* Do for each value of N in NVAL
253*
254 DO 170 in = 1, nn
255 n = nval( in )
256 lda = max( n, 1 )
257 xtype = 'N'
258 nimat = ntypes
259 IF( n.LE.0 )
260 $ nimat = 1
261*
262 DO 160 imat = 1, nimat
263*
264* Do the tests only if DOTYPE( IMAT ) is true.
265*
266 IF( .NOT.dotype( imat ) )
267 $ GO TO 160
268*
269* Skip types 3, 4, 5, or 6 if the matrix size is too small.
270*
271 zerot = imat.GE.3 .AND. imat.LE.6
272 IF( zerot .AND. n.LT.imat-2 )
273 $ GO TO 160
274*
275* Do first for UPLO = 'U', then for UPLO = 'L'
276*
277 DO 150 iuplo = 1, 2
278 uplo = uplos( iuplo )
279 IF( lsame( uplo, 'U' ) ) THEN
280 packit = 'C'
281 ELSE
282 packit = 'R'
283 END IF
284*
285 IF( imat.NE.ntypes ) THEN
286*
287* Set up parameters with ZLATB4 and generate a test
288* matrix with ZLATMS.
289*
290 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
291 $ MODE, CNDNUM, DIST )
292*
293 srnamt = 'ZLATMS'
294 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
295 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA,
296 $ WORK, INFO )
297*
298* Check error code from ZLATMS.
299*
300 IF( info.NE.0 ) THEN
301 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n,
302 $ -1, -1, -1, imat, nfail, nerrs, nout )
303 GO TO 150
304 END IF
305*
306* For types 3-6, zero one or more rows and columns of
307* the matrix to test that INFO is returned correctly.
308*
309 IF( zerot ) THEN
310 IF( imat.EQ.3 ) THEN
311 izero = 1
312 ELSE IF( imat.EQ.4 ) THEN
313 izero = n
314 ELSE
315 izero = n / 2 + 1
316 END IF
317*
318 IF( imat.LT.6 ) THEN
319*
320* Set row and column IZERO to zero.
321*
322 IF( iuplo.EQ.1 ) THEN
323 ioff = ( izero-1 )*izero / 2
324 DO 20 i = 1, izero - 1
325 a( ioff+i ) = zero
326 20 CONTINUE
327 ioff = ioff + izero
328 DO 30 i = izero, n
329 a( ioff ) = zero
330 ioff = ioff + i
331 30 CONTINUE
332 ELSE
333 ioff = izero
334 DO 40 i = 1, izero - 1
335 a( ioff ) = zero
336 ioff = ioff + n - i
337 40 CONTINUE
338 ioff = ioff - izero
339 DO 50 i = izero, n
340 a( ioff+i ) = zero
341 50 CONTINUE
342 END IF
343 ELSE
344 IF( iuplo.EQ.1 ) THEN
345*
346* Set the first IZERO rows and columns to zero.
347*
348 ioff = 0
349 DO 70 j = 1, n
350 i2 = min( j, izero )
351 DO 60 i = 1, i2
352 a( ioff+i ) = zero
353 60 CONTINUE
354 ioff = ioff + j
355 70 CONTINUE
356 ELSE
357*
358* Set the last IZERO rows and columns to zero.
359*
360 ioff = 0
361 DO 90 j = 1, n
362 i1 = max( j, izero )
363 DO 80 i = i1, n
364 a( ioff+i ) = zero
365 80 CONTINUE
366 ioff = ioff + n - j
367 90 CONTINUE
368 END IF
369 END IF
370 ELSE
371 izero = 0
372 END IF
373 ELSE
374*
375* Use a special block diagonal matrix to test alternate
376* code for the 2 x 2 blocks.
377*
378 CALL zlatsp( uplo, n, a, iseed )
379 END IF
380*
381* Compute the L*D*L' or U*D*U' factorization of the matrix.
382*
383 npp = n*( n+1 ) / 2
384 CALL zcopy( npp, a, 1, afac, 1 )
385 srnamt = 'ZSPTRF'
386 CALL zsptrf( uplo, n, afac, iwork, info )
387*
388* Adjust the expected value of INFO to account for
389* pivoting.
390*
391 k = izero
392 IF( k.GT.0 ) THEN
393 100 CONTINUE
394 IF( iwork( k ).LT.0 ) THEN
395 IF( iwork( k ).NE.-k ) THEN
396 k = -iwork( k )
397 GO TO 100
398 END IF
399 ELSE IF( iwork( k ).NE.k ) THEN
400 k = iwork( k )
401 GO TO 100
402 END IF
403 END IF
404*
405* Check error code from ZSPTRF.
406*
407 IF( info.NE.k )
408 $ CALL alaerh( path, 'ZSPTRF', info, k, uplo, n, n, -1,
409 $ -1, -1, imat, nfail, nerrs, nout )
410 IF( info.NE.0 ) THEN
411 trfcon = .true.
412 ELSE
413 trfcon = .false.
414 END IF
415*
416*+ TEST 1
417* Reconstruct matrix from factors and compute residual.
418*
419 CALL zspt01( uplo, n, a, afac, iwork, ainv, lda, rwork,
420 $ result( 1 ) )
421 nt = 1
422*
423*+ TEST 2
424* Form the inverse and compute the residual.
425*
426 IF( .NOT.trfcon ) THEN
427 CALL zcopy( npp, afac, 1, ainv, 1 )
428 srnamt = 'ZSPTRI'
429 CALL zsptri( uplo, n, ainv, iwork, work, info )
430*
431* Check error code from ZSPTRI.
432*
433 IF( info.NE.0 )
434 $ CALL alaerh( path, 'ZSPTRI', info, 0, uplo, n, n,
435 $ -1, -1, -1, imat, nfail, nerrs, nout )
436*
437 CALL zspt03( uplo, n, a, ainv, work, lda, rwork,
438 $ rcondc, result( 2 ) )
439 nt = 2
440 END IF
441*
442* Print information about the tests that did not pass
443* the threshold.
444*
445 DO 110 k = 1, nt
446 IF( result( k ).GE.thresh ) THEN
447 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
448 $ CALL alahd( nout, path )
449 WRITE( nout, fmt = 9999 )uplo, n, imat, k,
450 $ result( k )
451 nfail = nfail + 1
452 END IF
453 110 CONTINUE
454 nrun = nrun + nt
455*
456* Do only the condition estimate if INFO is not 0.
457*
458 IF( trfcon ) THEN
459 rcondc = zero
460 GO TO 140
461 END IF
462*
463 DO 130 irhs = 1, nns
464 nrhs = nsval( irhs )
465*
466*+ TEST 3
467* Solve and compute residual for A * X = B.
468*
469 srnamt = 'ZLARHS'
470 CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
471 $ nrhs, a, lda, xact, lda, b, lda, iseed,
472 $ info )
473 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
474*
475 srnamt = 'ZSPTRS'
476 CALL zsptrs( uplo, n, nrhs, afac, iwork, x, lda,
477 $ info )
478*
479* Check error code from ZSPTRS.
480*
481 IF( info.NE.0 )
482 $ CALL alaerh( path, 'ZSPTRS', info, 0, uplo, n, n,
483 $ -1, -1, nrhs, imat, nfail, nerrs,
484 $ nout )
485*
486 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
487 CALL zspt02( uplo, n, nrhs, a, x, lda, work, lda,
488 $ rwork, result( 3 ) )
489*
490*+ TEST 4
491* Check solution from generated exact solution.
492*
493 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
494 $ result( 4 ) )
495*
496*+ TESTS 5, 6, and 7
497* Use iterative refinement to improve the solution.
498*
499 srnamt = 'ZSPRFS'
500 CALL zsprfs( uplo, n, nrhs, a, afac, iwork, b, lda, x,
501 $ lda, rwork, rwork( nrhs+1 ), work,
502 $ rwork( 2*nrhs+1 ), info )
503*
504* Check error code from ZSPRFS.
505*
506 IF( info.NE.0 )
507 $ CALL alaerh( path, 'ZSPRFS', info, 0, uplo, n, n,
508 $ -1, -1, nrhs, imat, nfail, nerrs,
509 $ nout )
510*
511 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
512 $ result( 5 ) )
513 CALL zppt05( uplo, n, nrhs, a, b, lda, x, lda, xact,
514 $ lda, rwork, rwork( nrhs+1 ),
515 $ result( 6 ) )
516*
517* Print information about the tests that did not pass
518* the threshold.
519*
520 DO 120 k = 3, 7
521 IF( result( k ).GE.thresh ) THEN
522 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
523 $ CALL alahd( nout, path )
524 WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat,
525 $ k, result( k )
526 nfail = nfail + 1
527 END IF
528 120 CONTINUE
529 nrun = nrun + 5
530 130 CONTINUE
531*
532*+ TEST 8
533* Get an estimate of RCOND = 1/CNDNUM.
534*
535 140 CONTINUE
536 anorm = zlansp( '1', uplo, n, a, rwork )
537 srnamt = 'ZSPCON'
538 CALL zspcon( uplo, n, afac, iwork, anorm, rcond, work,
539 $ info )
540*
541* Check error code from ZSPCON.
542*
543 IF( info.NE.0 )
544 $ CALL alaerh( path, 'ZSPCON', info, 0, uplo, n, n, -1,
545 $ -1, -1, imat, nfail, nerrs, nout )
546*
547 result( 8 ) = dget06( rcond, rcondc )
548*
549* Print the test ratio if it is .GE. THRESH.
550*
551 IF( result( 8 ).GE.thresh ) THEN
552 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
553 $ CALL alahd( nout, path )
554 WRITE( nout, fmt = 9999 )uplo, n, imat, 8,
555 $ result( 8 )
556 nfail = nfail + 1
557 END IF
558 nrun = nrun + 1
559 150 CONTINUE
560 160 CONTINUE
561 170 CONTINUE
562*
563* Print a summary of the results.
564*
565 CALL alasum( path, nout, nfail, nrun, nerrs )
566*
567 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', type ', i2, ', test ',
568 $ i2, ', ratio =', g12.5 )
569 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
570 $ i2, ', test(', i2, ') =', g12.5 )
571 RETURN
572*
573* End of ZCHKSP
574*
zlansp
double precision function zlansp(norm, uplo, n, ap, work)
ZLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlansp.f:115
zsprfs
subroutine zsprfs(uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
ZSPRFS
Definition zsprfs.f:180
zsptri
subroutine zsptri(uplo, n, ap, ipiv, work, info)
ZSPTRI
Definition zsptri.f:109
zsptrs
subroutine zsptrs(uplo, n, nrhs, ap, ipiv, b, ldb, info)
ZSPTRS
Definition zsptrs.f:115
zsptrf
subroutine zsptrf(uplo, n, ap, ipiv, info)
ZSPTRF
Definition zsptrf.f:158
zspcon
subroutine zspcon(uplo, n, ap, ipiv, anorm, rcond, work, info)
ZSPCON
Definition zspcon.f:118
zspt01
subroutine zspt01(uplo, n, a, afac, ipiv, c, ldc, rwork, resid)
ZSPT01
Definition zspt01.f:112
zspt02
subroutine zspt02(uplo, n, nrhs, a, x, ldx, b, ldb, rwork, resid)
ZSPT02
Definition zspt02.f:123
zspt03
subroutine zspt03(uplo, n, a, ainv, work, ldw, rwork, rcond, resid)
ZSPT03
Definition zspt03.f:110
zlatsp
subroutine zlatsp(uplo, n, x, iseed)
ZLATSP
Definition zlatsp.f:84

◆ zchksy()

subroutine zchksy ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKSY

Purpose:
!>
!> ZCHKSY tests ZSYTRF, -TRI2, -TRS, -TRS2,  -RFS, and -CON.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(2,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NSMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 168 of file zchksy.f.

171*
172* -- LAPACK test routine --
173* -- LAPACK is a software package provided by Univ. of Tennessee, --
174* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
175*
176* .. Scalar Arguments ..
177 LOGICAL TSTERR
178 INTEGER NMAX, NN, NNB, NNS, NOUT
179 DOUBLE PRECISION THRESH
180* ..
181* .. Array Arguments ..
182 LOGICAL DOTYPE( * )
183 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
184 DOUBLE PRECISION RWORK( * )
185 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
186 $ WORK( * ), X( * ), XACT( * )
187* ..
188*
189* =====================================================================
190*
191* .. Parameters ..
192 DOUBLE PRECISION ZERO
193 parameter( zero = 0.0d+0 )
194 COMPLEX*16 CZERO
195 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
196 INTEGER NTYPES
197 parameter( ntypes = 11 )
198 INTEGER NTESTS
199 parameter( ntests = 9 )
200* ..
201* .. Local Scalars ..
202 LOGICAL TRFCON, ZEROT
203 CHARACTER DIST, TYPE, UPLO, XTYPE
204 CHARACTER*3 PATH
205 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
206 $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
207 $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
208 DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
209* ..
210* .. Local Arrays ..
211 CHARACTER UPLOS( 2 )
212 INTEGER ISEED( 4 ), ISEEDY( 4 )
213 DOUBLE PRECISION RESULT( NTESTS )
214* ..
215* .. External Functions ..
216 DOUBLE PRECISION DGET06, ZLANSY
217 EXTERNAL dget06, zlansy
218* ..
219* .. External Subroutines ..
220 EXTERNAL alaerh, alahd, alasum, xlaenv, zerrsy, zget04,
221 $ zlacpy, zlarhs, zlatb4, zlatms, zlatsy, zpot05,
222 $ zsycon, zsyrfs, zsyt01, zsyt02, zsyt03, zsytrf,
223 $ zsytri2, zsytrs, zsytrs2
224* ..
225* .. Intrinsic Functions ..
226 INTRINSIC max, min
227* ..
228* .. Scalars in Common ..
229 LOGICAL LERR, OK
230 CHARACTER*32 SRNAMT
231 INTEGER INFOT, NUNIT
232* ..
233* .. Common blocks ..
234 COMMON / infoc / infot, nunit, ok, lerr
235 COMMON / srnamc / srnamt
236* ..
237* .. Data statements ..
238 DATA iseedy / 1988, 1989, 1990, 1991 /
239 DATA uplos / 'U', 'L' /
240* ..
241* .. Executable Statements ..
242*
243* Initialize constants and the random number seed.
244*
245 path( 1: 1 ) = 'Zomplex precision'
246 path( 2: 3 ) = 'SY'
247 nrun = 0
248 nfail = 0
249 nerrs = 0
250 DO 10 i = 1, 4
251 iseed( i ) = iseedy( i )
252 10 CONTINUE
253*
254* Test the error exits
255*
256 IF( tsterr )
257 $ CALL zerrsy( path, nout )
258 infot = 0
259*
260* Set the minimum block size for which the block routine should
261* be used, which will be later returned by ILAENV
262*
263 CALL xlaenv( 2, 2 )
264*
265* Do for each value of N in NVAL
266*
267 DO 180 in = 1, nn
268 n = nval( in )
269 lda = max( n, 1 )
270 xtype = 'N'
271 nimat = ntypes
272 IF( n.LE.0 )
273 $ nimat = 1
274*
275 izero = 0
276*
277* Do for each value of matrix type IMAT
278*
279 DO 170 imat = 1, nimat
280*
281* Do the tests only if DOTYPE( IMAT ) is true.
282*
283 IF( .NOT.dotype( imat ) )
284 $ GO TO 170
285*
286* Skip types 3, 4, 5, or 6 if the matrix size is too small.
287*
288 zerot = imat.GE.3 .AND. imat.LE.6
289 IF( zerot .AND. n.LT.imat-2 )
290 $ GO TO 170
291*
292* Do first for UPLO = 'U', then for UPLO = 'L'
293*
294 DO 160 iuplo = 1, 2
295 uplo = uplos( iuplo )
296*
297* Begin generate test matrix A.
298*
299 IF( imat.NE.ntypes ) THEN
300*
301* Set up parameters with ZLATB4 for the matrix generator
302* based on the type of matrix to be generated.
303*
304 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
305 $ MODE, CNDNUM, DIST )
306*
307* Generate a matrix with ZLATMS.
308*
309 srnamt = 'ZLATMS'
310 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
311 $ CNDNUM, ANORM, KL, KU, 'N', A, LDA, WORK,
312 $ INFO )
313*
314* Check error code from ZLATMS and handle error.
315*
316 IF( info.NE.0 ) THEN
317 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n,
318 $ -1, -1, -1, imat, nfail, nerrs, nout )
319*
320* Skip all tests for this generated matrix
321*
322 GO TO 160
323 END IF
324*
325* For matrix types 3-6, zero one or more rows and
326* columns of the matrix to test that INFO is returned
327* correctly.
328*
329 IF( zerot ) THEN
330 IF( imat.EQ.3 ) THEN
331 izero = 1
332 ELSE IF( imat.EQ.4 ) THEN
333 izero = n
334 ELSE
335 izero = n / 2 + 1
336 END IF
337*
338 IF( imat.LT.6 ) THEN
339*
340* Set row and column IZERO to zero.
341*
342 IF( iuplo.EQ.1 ) THEN
343 ioff = ( izero-1 )*lda
344 DO 20 i = 1, izero - 1
345 a( ioff+i ) = czero
346 20 CONTINUE
347 ioff = ioff + izero
348 DO 30 i = izero, n
349 a( ioff ) = czero
350 ioff = ioff + lda
351 30 CONTINUE
352 ELSE
353 ioff = izero
354 DO 40 i = 1, izero - 1
355 a( ioff ) = czero
356 ioff = ioff + lda
357 40 CONTINUE
358 ioff = ioff - izero
359 DO 50 i = izero, n
360 a( ioff+i ) = czero
361 50 CONTINUE
362 END IF
363 ELSE
364 IF( iuplo.EQ.1 ) THEN
365*
366* Set the first IZERO rows to zero.
367*
368 ioff = 0
369 DO 70 j = 1, n
370 i2 = min( j, izero )
371 DO 60 i = 1, i2
372 a( ioff+i ) = czero
373 60 CONTINUE
374 ioff = ioff + lda
375 70 CONTINUE
376 ELSE
377*
378* Set the last IZERO rows to zero.
379*
380 ioff = 0
381 DO 90 j = 1, n
382 i1 = max( j, izero )
383 DO 80 i = i1, n
384 a( ioff+i ) = czero
385 80 CONTINUE
386 ioff = ioff + lda
387 90 CONTINUE
388 END IF
389 END IF
390 ELSE
391 izero = 0
392 END IF
393*
394 ELSE
395*
396* For matrix kind IMAT = 11, generate special block
397* diagonal matrix to test alternate code
398* for the 2 x 2 blocks.
399*
400 CALL zlatsy( uplo, n, a, lda, iseed )
401*
402 END IF
403*
404* End generate test matrix A.
405*
406*
407* Do for each value of NB in NBVAL
408*
409 DO 150 inb = 1, nnb
410*
411* Set the optimal blocksize, which will be later
412* returned by ILAENV.
413*
414 nb = nbval( inb )
415 CALL xlaenv( 1, nb )
416*
417* Copy the test matrix A into matrix AFAC which
418* will be factorized in place. This is needed to
419* preserve the test matrix A for subsequent tests.
420*
421 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
422*
423* Compute the L*D*L**T or U*D*U**T factorization of the
424* matrix. IWORK stores details of the interchanges and
425* the block structure of D. AINV is a work array for
426* block factorization, LWORK is the length of AINV.
427*
428 lwork = max( 2, nb )*lda
429 srnamt = 'ZSYTRF'
430 CALL zsytrf( uplo, n, afac, lda, iwork, ainv, lwork,
431 $ info )
432*
433* Adjust the expected value of INFO to account for
434* pivoting.
435*
436 k = izero
437 IF( k.GT.0 ) THEN
438 100 CONTINUE
439 IF( iwork( k ).LT.0 ) THEN
440 IF( iwork( k ).NE.-k ) THEN
441 k = -iwork( k )
442 GO TO 100
443 END IF
444 ELSE IF( iwork( k ).NE.k ) THEN
445 k = iwork( k )
446 GO TO 100
447 END IF
448 END IF
449*
450* Check error code from ZSYTRF and handle error.
451*
452 IF( info.NE.k )
453 $ CALL alaerh( path, 'ZSYTRF', info, k, uplo, n, n,
454 $ -1, -1, nb, imat, nfail, nerrs, nout )
455*
456* Set the condition estimate flag if the INFO is not 0.
457*
458 IF( info.NE.0 ) THEN
459 trfcon = .true.
460 ELSE
461 trfcon = .false.
462 END IF
463*
464*+ TEST 1
465* Reconstruct matrix from factors and compute residual.
466*
467 CALL zsyt01( uplo, n, a, lda, afac, lda, iwork, ainv,
468 $ lda, rwork, result( 1 ) )
469 nt = 1
470*
471*+ TEST 2
472* Form the inverse and compute the residual,
473* if the factorization was competed without INFO > 0
474* (i.e. there is no zero rows and columns).
475* Do it only for the first block size.
476*
477 IF( inb.EQ.1 .AND. .NOT.trfcon ) THEN
478 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
479 srnamt = 'ZSYTRI2'
480 lwork = (n+nb+1)*(nb+3)
481 CALL zsytri2( uplo, n, ainv, lda, iwork, work,
482 $ lwork, info )
483*
484* Check error code from ZSYTRI2 and handle error.
485*
486 IF( info.NE.0 )
487 $ CALL alaerh( path, 'ZSYTRI2', info, 0, uplo, n,
488 $ n, -1, -1, -1, imat, nfail, nerrs,
489 $ nout )
490*
491* Compute the residual for a symmetric matrix times
492* its inverse.
493*
494 CALL zsyt03( uplo, n, a, lda, ainv, lda, work, lda,
495 $ rwork, rcondc, result( 2 ) )
496 nt = 2
497 END IF
498*
499* Print information about the tests that did not pass
500* the threshold.
501*
502 DO 110 k = 1, nt
503 IF( result( k ).GE.thresh ) THEN
504 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
505 $ CALL alahd( nout, path )
506 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
507 $ result( k )
508 nfail = nfail + 1
509 END IF
510 110 CONTINUE
511 nrun = nrun + nt
512*
513* Skip the other tests if this is not the first block
514* size.
515*
516 IF( inb.GT.1 )
517 $ GO TO 150
518*
519* Do only the condition estimate if INFO is not 0.
520*
521 IF( trfcon ) THEN
522 rcondc = zero
523 GO TO 140
524 END IF
525*
526* Do for each value of NRHS in NSVAL.
527*
528 DO 130 irhs = 1, nns
529 nrhs = nsval( irhs )
530*
531*+ TEST 3 (Using TRS)
532* Solve and compute residual for A * X = B.
533*
534* Choose a set of NRHS random solution vectors
535* stored in XACT and set up the right hand side B
536*
537 srnamt = 'ZLARHS'
538 CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
539 $ nrhs, a, lda, xact, lda, b, lda,
540 $ iseed, info )
541 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
542*
543 srnamt = 'ZSYTRS'
544 CALL zsytrs( uplo, n, nrhs, afac, lda, iwork, x,
545 $ lda, info )
546*
547* Check error code from ZSYTRS and handle error.
548*
549 IF( info.NE.0 )
550 $ CALL alaerh( path, 'ZSYTRS', info, 0, uplo, n,
551 $ n, -1, -1, nrhs, imat, nfail,
552 $ nerrs, nout )
553*
554 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
555*
556* Compute the residual for the solution
557*
558 CALL zsyt02( uplo, n, nrhs, a, lda, x, lda, work,
559 $ lda, rwork, result( 3 ) )
560*
561*+ TEST 4 (Using TRS2)
562* Solve and compute residual for A * X = B.
563*
564* Choose a set of NRHS random solution vectors
565* stored in XACT and set up the right hand side B
566*
567 srnamt = 'ZLARHS'
568 CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
569 $ nrhs, a, lda, xact, lda, b, lda,
570 $ iseed, info )
571 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
572*
573 srnamt = 'ZSYTRS2'
574 CALL zsytrs2( uplo, n, nrhs, afac, lda, iwork, x,
575 $ lda, work, info )
576*
577* Check error code from ZSYTRS2 and handle error.
578*
579 IF( info.NE.0 )
580 $ CALL alaerh( path, 'ZSYTRS', info, 0, uplo, n,
581 $ n, -1, -1, nrhs, imat, nfail,
582 $ nerrs, nout )
583*
584 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
585*
586* Compute the residual for the solution
587*
588 CALL zsyt02( uplo, n, nrhs, a, lda, x, lda, work,
589 $ lda, rwork, result( 4 ) )
590*
591*
592*+ TEST 5
593* Check solution from generated exact solution.
594*
595 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
596 $ result( 5 ) )
597*
598*+ TESTS 6, 7, and 8
599* Use iterative refinement to improve the solution.
600*
601 srnamt = 'ZSYRFS'
602 CALL zsyrfs( uplo, n, nrhs, a, lda, afac, lda,
603 $ iwork, b, lda, x, lda, rwork,
604 $ rwork( nrhs+1 ), work,
605 $ rwork( 2*nrhs+1 ), info )
606*
607* Check error code from ZSYRFS and handle error.
608*
609 IF( info.NE.0 )
610 $ CALL alaerh( path, 'ZSYRFS', info, 0, uplo, n,
611 $ n, -1, -1, nrhs, imat, nfail,
612 $ nerrs, nout )
613*
614 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
615 $ result( 6 ) )
616 CALL zpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
617 $ xact, lda, rwork, rwork( nrhs+1 ),
618 $ result( 7 ) )
619*
620* Print information about the tests that did not pass
621* the threshold.
622*
623 DO 120 k = 3, 8
624 IF( result( k ).GE.thresh ) THEN
625 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
626 $ CALL alahd( nout, path )
627 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
628 $ imat, k, result( k )
629 nfail = nfail + 1
630 END IF
631 120 CONTINUE
632 nrun = nrun + 6
633*
634* End do for each value of NRHS in NSVAL.
635*
636 130 CONTINUE
637*
638*+ TEST 9
639* Get an estimate of RCOND = 1/CNDNUM.
640*
641 140 CONTINUE
642 anorm = zlansy( '1', uplo, n, a, lda, rwork )
643 srnamt = 'ZSYCON'
644 CALL zsycon( uplo, n, afac, lda, iwork, anorm, rcond,
645 $ work, info )
646*
647* Check error code from ZSYCON and handle error.
648*
649 IF( info.NE.0 )
650 $ CALL alaerh( path, 'ZSYCON', info, 0, uplo, n, n,
651 $ -1, -1, -1, imat, nfail, nerrs, nout )
652*
653* Compute the test ratio to compare values of RCOND
654*
655 result( 9 ) = dget06( rcond, rcondc )
656*
657* Print information about the tests that did not pass
658* the threshold.
659*
660 IF( result( 9 ).GE.thresh ) THEN
661 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
662 $ CALL alahd( nout, path )
663 WRITE( nout, fmt = 9997 )uplo, n, imat, 9,
664 $ result( 9 )
665 nfail = nfail + 1
666 END IF
667 nrun = nrun + 1
668 150 CONTINUE
669 160 CONTINUE
670 170 CONTINUE
671 180 CONTINUE
672*
673* Print a summary of the results.
674*
675 CALL alasum( path, nout, nfail, nrun, nerrs )
676*
677 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
678 $ i2, ', test ', i2, ', ratio =', g12.5 )
679 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
680 $ i2, ', test(', i2, ') =', g12.5 )
681 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
682 $ ', test(', i2, ') =', g12.5 )
683 RETURN
684*
685* End of ZCHKSY
686*
zlansy
double precision function zlansy(norm, uplo, n, a, lda, work)
ZLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlansy.f:123
zsytrs
subroutine zsytrs(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
ZSYTRS
Definition zsytrs.f:120
zsytrf
subroutine zsytrf(uplo, n, a, lda, ipiv, work, lwork, info)
ZSYTRF
Definition zsytrf.f:182
zsyrfs
subroutine zsyrfs(uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
ZSYRFS
Definition zsyrfs.f:192
zsytri2
subroutine zsytri2(uplo, n, a, lda, ipiv, work, lwork, info)
ZSYTRI2
Definition zsytri2.f:127
zsycon
subroutine zsycon(uplo, n, a, lda, ipiv, anorm, rcond, work, info)
ZSYCON
Definition zsycon.f:125
zsytrs2
subroutine zsytrs2(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, info)
ZSYTRS2
Definition zsytrs2.f:132
zsyt03
subroutine zsyt03(uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
ZSYT03
Definition zsyt03.f:126
zlatsy
subroutine zlatsy(uplo, n, x, ldx, iseed)
ZLATSY
Definition zlatsy.f:89
zsyt01
subroutine zsyt01(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
ZSYT01
Definition zsyt01.f:125
zsyt02
subroutine zsyt02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
ZSYT02
Definition zsyt02.f:127

◆ zchksy_aa()

subroutine zchksy_aa ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKSY_AA

Purpose:
!>
!> ZCHKSY_AA tests ZSYTRF_AA, -TRS_AA.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is COMPLEX*16 array, dimension (max(NMAX,2*NSMAX))
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (2*NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 168 of file zchksy_aa.f.

171*
172* -- LAPACK test routine --
173* -- LAPACK is a software package provided by Univ. of Tennessee, --
174* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
175*
176 IMPLICIT NONE
177*
178* .. Scalar Arguments ..
179 LOGICAL TSTERR
180 INTEGER NN, NNB, NNS, NMAX, NOUT
181 DOUBLE PRECISION THRESH
182* ..
183* .. Array Arguments ..
184 LOGICAL DOTYPE( * )
185 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
186 DOUBLE PRECISION RWORK( * )
187 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
188 $ WORK( * ), X( * ), XACT( * )
189* ..
190*
191* =====================================================================
192*
193* .. Parameters ..
194 DOUBLE PRECISION ZERO
195 parameter( zero = 0.0d+0 )
196 COMPLEX*16 CZERO
197 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
198 INTEGER NTYPES
199 parameter( ntypes = 10 )
200 INTEGER NTESTS
201 parameter( ntests = 9 )
202* ..
203* .. Local Scalars ..
204 LOGICAL ZEROT
205 CHARACTER DIST, TYPE, UPLO, XTYPE
206 CHARACTER*3 PATH, MATPATH
207 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
208 $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
209 $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
210 DOUBLE PRECISION ANORM, CNDNUM
211* ..
212* .. Local Arrays ..
213 CHARACTER UPLOS( 2 )
214 INTEGER ISEED( 4 ), ISEEDY( 4 )
215 DOUBLE PRECISION RESULT( NTESTS )
216* ..
217* .. External Subroutines ..
218 EXTERNAL alaerh, alahd, alasum, zerrsy, zlacpy, zlarhs,
219 $ zlatb4, zlatms, zsyt02, zsyt01_aa, zsytrf_aa,
220 $ zsytrs_aa, xlaenv
221* ..
222* .. Intrinsic Functions ..
223 INTRINSIC max, min
224* ..
225* .. Scalars in Common ..
226 LOGICAL LERR, OK
227 CHARACTER*32 SRNAMT
228 INTEGER INFOT, NUNIT
229* ..
230* .. Common blocks ..
231 COMMON / infoc / infot, nunit, ok, lerr
232 COMMON / srnamc / srnamt
233* ..
234* .. Data statements ..
235 DATA iseedy / 1988, 1989, 1990, 1991 /
236 DATA uplos / 'U', 'L' /
237* ..
238* .. Executable Statements ..
239*
240* Initialize constants and the random number seed.
241*
242* Test path
243*
244 path( 1: 1 ) = 'Zomplex precision'
245 path( 2: 3 ) = 'SA'
246*
247* Path to generate matrices
248*
249 matpath( 1: 1 ) = 'Zomplex precision'
250 matpath( 2: 3 ) = 'SY'
251 nrun = 0
252 nfail = 0
253 nerrs = 0
254 DO 10 i = 1, 4
255 iseed( i ) = iseedy( i )
256 10 CONTINUE
257*
258* Test the error exits
259*
260 IF( tsterr )
261 $ CALL zerrsy( path, nout )
262 infot = 0
263*
264* Set the minimum block size for which the block routine should
265* be used, which will be later returned by ILAENV
266*
267 CALL xlaenv( 2, 2 )
268*
269* Do for each value of N in NVAL
270*
271 DO 180 in = 1, nn
272 n = nval( in )
273 IF( n .GT. nmax ) THEN
274 nfail = nfail + 1
275 WRITE(nout, 9995) 'M ', n, nmax
276 GO TO 180
277 END IF
278 lda = max( n, 1 )
279 xtype = 'N'
280 nimat = ntypes
281 IF( n.LE.0 )
282 $ nimat = 1
283*
284 izero = 0
285*
286* Do for each value of matrix type IMAT
287*
288 DO 170 imat = 1, nimat
289*
290* Do the tests only if DOTYPE( IMAT ) is true.
291*
292 IF( .NOT.dotype( imat ) )
293 $ GO TO 170
294*
295* Skip types 3, 4, 5, or 6 if the matrix size is too small.
296*
297 zerot = imat.GE.3 .AND. imat.LE.6
298 IF( zerot .AND. n.LT.imat-2 )
299 $ GO TO 170
300*
301* Do first for UPLO = 'U', then for UPLO = 'L'
302*
303 DO 160 iuplo = 1, 2
304 uplo = uplos( iuplo )
305*
306* Begin generate the test matrix A.
307*
308*
309* Set up parameters with ZLATB4 for the matrix generator
310* based on the type of matrix to be generated.
311*
312 CALL zlatb4( matpath, imat, n, n, TYPE, KL, KU,
313 $ ANORM, MODE, CNDNUM, DIST )
314*
315* Generate a matrix with ZLATMS.
316*
317 srnamt = 'ZLATMS'
318 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
319 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
320 $ INFO )
321*
322* Check error code from ZLATMS and handle error.
323*
324 IF( info.NE.0 ) THEN
325 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n, -1,
326 $ -1, -1, imat, nfail, nerrs, nout )
327*
328* Skip all tests for this generated matrix
329*
330 GO TO 160
331 END IF
332*
333* For matrix types 3-6, zero one or more rows and
334* columns of the matrix to test that INFO is returned
335* correctly.
336*
337 IF( zerot ) THEN
338 IF( imat.EQ.3 ) THEN
339 izero = 1
340 ELSE IF( imat.EQ.4 ) THEN
341 izero = n
342 ELSE
343 izero = n / 2 + 1
344 END IF
345*
346 IF( imat.LT.6 ) THEN
347*
348* Set row and column IZERO to zero.
349*
350 IF( iuplo.EQ.1 ) THEN
351 ioff = ( izero-1 )*lda
352 DO 20 i = 1, izero - 1
353 a( ioff+i ) = czero
354 20 CONTINUE
355 ioff = ioff + izero
356 DO 30 i = izero, n
357 a( ioff ) = czero
358 ioff = ioff + lda
359 30 CONTINUE
360 ELSE
361 ioff = izero
362 DO 40 i = 1, izero - 1
363 a( ioff ) = czero
364 ioff = ioff + lda
365 40 CONTINUE
366 ioff = ioff - izero
367 DO 50 i = izero, n
368 a( ioff+i ) = czero
369 50 CONTINUE
370 END IF
371 ELSE
372 IF( iuplo.EQ.1 ) THEN
373*
374* Set the first IZERO rows and columns to zero.
375*
376 ioff = 0
377 DO 70 j = 1, n
378 i2 = min( j, izero )
379 DO 60 i = 1, i2
380 a( ioff+i ) = czero
381 60 CONTINUE
382 ioff = ioff + lda
383 70 CONTINUE
384 izero = 1
385 ELSE
386*
387* Set the last IZERO rows and columns to zero.
388*
389 ioff = 0
390 DO 90 j = 1, n
391 i1 = max( j, izero )
392 DO 80 i = i1, n
393 a( ioff+i ) = czero
394 80 CONTINUE
395 ioff = ioff + lda
396 90 CONTINUE
397 END IF
398 END IF
399 ELSE
400 izero = 0
401 END IF
402*
403* End generate the test matrix A.
404*
405* Do for each value of NB in NBVAL
406*
407 DO 150 inb = 1, nnb
408*
409* Set the optimal blocksize, which will be later
410* returned by ILAENV.
411*
412 nb = nbval( inb )
413 CALL xlaenv( 1, nb )
414*
415* Copy the test matrix A into matrix AFAC which
416* will be factorized in place. This is needed to
417* preserve the test matrix A for subsequent tests.
418*
419 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
420*
421* Compute the L*D*L**T or U*D*U**T factorization of the
422* matrix. IWORK stores details of the interchanges and
423* the block structure of D. AINV is a work array for
424* block factorization, LWORK is the length of AINV.
425*
426 srnamt = 'ZSYTRF_AA'
427 lwork = max( 1, n*nb + n )
428 CALL zsytrf_aa( uplo, n, afac, lda, iwork, ainv,
429 $ lwork, info )
430*
431* Adjust the expected value of INFO to account for
432* pivoting.
433*
434c IF( IZERO.GT.0 ) THEN
435c J = 1
436c K = IZERO
437c 100 CONTINUE
438c IF( J.EQ.K ) THEN
439c K = IWORK( J )
440c ELSE IF( IWORK( J ).EQ.K ) THEN
441c K = J
442c END IF
443c IF( J.LT.K ) THEN
444c J = J + 1
445c GO TO 100
446c END IF
447c ELSE
448 k = 0
449c END IF
450*
451* Check error code from ZSYTRF and handle error.
452*
453 IF( info.NE.k ) THEN
454 CALL alaerh( path, 'ZSYTRF_AA', info, k, uplo,
455 $ n, n, -1, -1, nb, imat, nfail, nerrs,
456 $ nout )
457 END IF
458*
459*+ TEST 1
460* Reconstruct matrix from factors and compute residual.
461*
462 CALL zsyt01_aa( uplo, n, a, lda, afac, lda, iwork,
463 $ ainv, lda, rwork, result( 1 ) )
464 nt = 1
465*
466*
467* Print information about the tests that did not pass
468* the threshold.
469*
470 DO 110 k = 1, nt
471 IF( result( k ).GE.thresh ) THEN
472 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
473 $ CALL alahd( nout, path )
474 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
475 $ result( k )
476 nfail = nfail + 1
477 END IF
478 110 CONTINUE
479 nrun = nrun + nt
480*
481* Skip solver test if INFO is not 0.
482*
483 IF( info.NE.0 ) THEN
484 GO TO 140
485 END IF
486*
487* Do for each value of NRHS in NSVAL.
488*
489 DO 130 irhs = 1, nns
490 nrhs = nsval( irhs )
491*
492*+ TEST 2 (Using TRS)
493* Solve and compute residual for A * X = B.
494*
495* Choose a set of NRHS random solution vectors
496* stored in XACT and set up the right hand side B
497*
498 srnamt = 'ZLARHS'
499 CALL zlarhs( matpath, xtype, uplo, ' ', n, n,
500 $ kl, ku, nrhs, a, lda, xact, lda,
501 $ b, lda, iseed, info )
502 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
503*
504 srnamt = 'ZSYTRS_AA'
505 lwork = max( 1, 3*n-2 )
506 CALL zsytrs_aa( uplo, n, nrhs, afac, lda,
507 $ iwork, x, lda, work, lwork,
508 $ info )
509*
510* Check error code from ZSYTRS and handle error.
511*
512 IF( info.NE.0 ) THEN
513 IF( izero.EQ.0 ) THEN
514 CALL alaerh( path, 'ZSYTRS_AA', info, 0,
515 $ uplo, n, n, -1, -1, nrhs, imat,
516 $ nfail, nerrs, nout )
517 END IF
518 ELSE
519 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda
520 $ )
521*
522* Compute the residual for the solution
523*
524 CALL zsyt02( uplo, n, nrhs, a, lda, x, lda,
525 $ work, lda, rwork, result( 2 ) )
526*
527*
528* Print information about the tests that did not pass
529* the threshold.
530*
531 DO 120 k = 2, 2
532 IF( result( k ).GE.thresh ) THEN
533 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
534 $ CALL alahd( nout, path )
535 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
536 $ imat, k, result( k )
537 nfail = nfail + 1
538 END IF
539 120 CONTINUE
540 END IF
541 nrun = nrun + 1
542*
543* End do for each value of NRHS in NSVAL.
544*
545 130 CONTINUE
546 140 CONTINUE
547 150 CONTINUE
548 160 CONTINUE
549 170 CONTINUE
550 180 CONTINUE
551*
552* Print a summary of the results.
553*
554 CALL alasum( path, nout, nfail, nrun, nerrs )
555*
556 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
557 $ i2, ', test ', i2, ', ratio =', g12.5 )
558 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
559 $ i2, ', test(', i2, ') =', g12.5 )
560 9995 FORMAT( ' Invalid input value: ', a4, '=', i6, '; must be <=',
561 $ i6 )
562 RETURN
563*
564* End of ZCHKSY_AA
565*
zsytrs_aa
subroutine zsytrs_aa(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
ZSYTRS_AA
Definition zsytrs_aa.f:131
zsytrf_aa
subroutine zsytrf_aa(uplo, n, a, lda, ipiv, work, lwork, info)
ZSYTRF_AA
Definition zsytrf_aa.f:132
zsyt01_aa
subroutine zsyt01_aa(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
ZSYT01
Definition zsyt01_aa.f:124

◆ zchksy_aa_2stage()

subroutine zchksy_aa_2stage ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKSY_AA_2STAGE

Purpose:
!>
!> ZCHKSY_AA_2STAGE tests ZSYTRF_AA_2STAGE, -TRS_AA_2STAGE.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is COMPLEX*16 array, dimension (max(NMAX,2*NSMAX))
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (2*NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 169 of file zchksy_aa_2stage.f.

172*
173* -- LAPACK test routine --
174* -- LAPACK is a software package provided by Univ. of Tennessee, --
175* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176*
177 IMPLICIT NONE
178*
179* .. Scalar Arguments ..
180 LOGICAL TSTERR
181 INTEGER NN, NNB, NNS, NMAX, NOUT
182 DOUBLE PRECISION THRESH
183* ..
184* .. Array Arguments ..
185 LOGICAL DOTYPE( * )
186 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
187 DOUBLE PRECISION RWORK( * )
188 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
189 $ WORK( * ), X( * ), XACT( * )
190* ..
191*
192* =====================================================================
193*
194* .. Parameters ..
195 COMPLEX*16 CZERO
196 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
197 INTEGER NTYPES
198 parameter( ntypes = 10 )
199 INTEGER NTESTS
200 parameter( ntests = 9 )
201* ..
202* .. Local Scalars ..
203 LOGICAL ZEROT
204 CHARACTER DIST, TYPE, UPLO, XTYPE
205 CHARACTER*3 PATH, MATPATH
206 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
207 $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
208 $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
209 DOUBLE PRECISION ANORM, CNDNUM
210* ..
211* .. Local Arrays ..
212 CHARACTER UPLOS( 2 )
213 INTEGER ISEED( 4 ), ISEEDY( 4 )
214 DOUBLE PRECISION RESULT( NTESTS )
215* ..
216* .. External Subroutines ..
217 EXTERNAL alaerh, alahd, alasum, zerrsy, zlacpy, zlarhs,
218 $ zlatb4, zlatms, zsyt02, zsyt01,
219 $ zsytrf_aa_2stage, zsytrs_aa_2stage,
220 $ xlaenv
221* ..
222* .. Intrinsic Functions ..
223 INTRINSIC max, min
224* ..
225* .. Scalars in Common ..
226 LOGICAL LERR, OK
227 CHARACTER*32 SRNAMT
228 INTEGER INFOT, NUNIT
229* ..
230* .. Common blocks ..
231 COMMON / infoc / infot, nunit, ok, lerr
232 COMMON / srnamc / srnamt
233* ..
234* .. Data statements ..
235 DATA iseedy / 1988, 1989, 1990, 1991 /
236 DATA uplos / 'U', 'L' /
237* ..
238* .. Executable Statements ..
239*
240* Initialize constants and the random number seed.
241*
242* Test path
243*
244 path( 1: 1 ) = 'Zomplex precision'
245 path( 2: 3 ) = 'S2'
246*
247* Path to generate matrices
248*
249 matpath( 1: 1 ) = 'Zomplex precision'
250 matpath( 2: 3 ) = 'SY'
251 nrun = 0
252 nfail = 0
253 nerrs = 0
254 DO 10 i = 1, 4
255 iseed( i ) = iseedy( i )
256 10 CONTINUE
257*
258* Test the error exits
259*
260 IF( tsterr )
261 $ CALL zerrsy( path, nout )
262 infot = 0
263*
264* Set the minimum block size for which the block routine should
265* be used, which will be later returned by ILAENV
266*
267 CALL xlaenv( 2, 2 )
268*
269* Do for each value of N in NVAL
270*
271 DO 180 in = 1, nn
272 n = nval( in )
273 IF( n .GT. nmax ) THEN
274 nfail = nfail + 1
275 WRITE(nout, 9995) 'M ', n, nmax
276 GO TO 180
277 END IF
278 lda = max( n, 1 )
279 xtype = 'N'
280 nimat = ntypes
281 IF( n.LE.0 )
282 $ nimat = 1
283*
284 izero = 0
285*
286* Do for each value of matrix type IMAT
287*
288 DO 170 imat = 1, nimat
289*
290* Do the tests only if DOTYPE( IMAT ) is true.
291*
292 IF( .NOT.dotype( imat ) )
293 $ GO TO 170
294*
295* Skip types 3, 4, 5, or 6 if the matrix size is too small.
296*
297 zerot = imat.GE.3 .AND. imat.LE.6
298 IF( zerot .AND. n.LT.imat-2 )
299 $ GO TO 170
300*
301* Do first for UPLO = 'U', then for UPLO = 'L'
302*
303 DO 160 iuplo = 1, 2
304 uplo = uplos( iuplo )
305*
306* Begin generate the test matrix A.
307*
308*
309* Set up parameters with ZLATB4 for the matrix generator
310* based on the type of matrix to be generated.
311*
312 CALL zlatb4( matpath, imat, n, n, TYPE, KL, KU,
313 $ ANORM, MODE, CNDNUM, DIST )
314*
315* Generate a matrix with ZLATMS.
316*
317 srnamt = 'ZLATMS'
318 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
319 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
320 $ INFO )
321*
322* Check error code from ZLATMS and handle error.
323*
324 IF( info.NE.0 ) THEN
325 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n, -1,
326 $ -1, -1, imat, nfail, nerrs, nout )
327*
328* Skip all tests for this generated matrix
329*
330 GO TO 160
331 END IF
332*
333* For matrix types 3-6, zero one or more rows and
334* columns of the matrix to test that INFO is returned
335* correctly.
336*
337 IF( zerot ) THEN
338 IF( imat.EQ.3 ) THEN
339 izero = 1
340 ELSE IF( imat.EQ.4 ) THEN
341 izero = n
342 ELSE
343 izero = n / 2 + 1
344 END IF
345*
346 IF( imat.LT.6 ) THEN
347*
348* Set row and column IZERO to zero.
349*
350 IF( iuplo.EQ.1 ) THEN
351 ioff = ( izero-1 )*lda
352 DO 20 i = 1, izero - 1
353 a( ioff+i ) = czero
354 20 CONTINUE
355 ioff = ioff + izero
356 DO 30 i = izero, n
357 a( ioff ) = czero
358 ioff = ioff + lda
359 30 CONTINUE
360 ELSE
361 ioff = izero
362 DO 40 i = 1, izero - 1
363 a( ioff ) = czero
364 ioff = ioff + lda
365 40 CONTINUE
366 ioff = ioff - izero
367 DO 50 i = izero, n
368 a( ioff+i ) = czero
369 50 CONTINUE
370 END IF
371 ELSE
372 IF( iuplo.EQ.1 ) THEN
373*
374* Set the first IZERO rows and columns to zero.
375*
376 ioff = 0
377 DO 70 j = 1, n
378 i2 = min( j, izero )
379 DO 60 i = 1, i2
380 a( ioff+i ) = czero
381 60 CONTINUE
382 ioff = ioff + lda
383 70 CONTINUE
384 izero = 1
385 ELSE
386*
387* Set the last IZERO rows and columns to zero.
388*
389 ioff = 0
390 DO 90 j = 1, n
391 i1 = max( j, izero )
392 DO 80 i = i1, n
393 a( ioff+i ) = czero
394 80 CONTINUE
395 ioff = ioff + lda
396 90 CONTINUE
397 END IF
398 END IF
399 ELSE
400 izero = 0
401 END IF
402*
403* End generate the test matrix A.
404*
405* Do for each value of NB in NBVAL
406*
407 DO 150 inb = 1, nnb
408*
409* Set the optimal blocksize, which will be later
410* returned by ILAENV.
411*
412 nb = nbval( inb )
413 CALL xlaenv( 1, nb )
414*
415* Copy the test matrix A into matrix AFAC which
416* will be factorized in place. This is needed to
417* preserve the test matrix A for subsequent tests.
418*
419 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
420*
421* Compute the L*D*L**T or U*D*U**T factorization of the
422* matrix. IWORK stores details of the interchanges and
423* the block structure of D. AINV is a work array for
424* block factorization, LWORK is the length of AINV.
425*
426 srnamt = 'ZSYTRF_AA_2STAGE'
427 lwork = min(n*nb, 3*nmax*nmax)
428 CALL zsytrf_aa_2stage( uplo, n, afac, lda,
429 $ ainv, (3*nb+1)*n,
430 $ iwork, iwork( 1+n ),
431 $ work, lwork,
432 $ info )
433*
434* Adjust the expected value of INFO to account for
435* pivoting.
436*
437 IF( izero.GT.0 ) THEN
438 j = 1
439 k = izero
440 100 CONTINUE
441 IF( j.EQ.k ) THEN
442 k = iwork( j )
443 ELSE IF( iwork( j ).EQ.k ) THEN
444 k = j
445 END IF
446 IF( j.LT.k ) THEN
447 j = j + 1
448 GO TO 100
449 END IF
450 ELSE
451 k = 0
452 END IF
453*
454* Check error code from ZSYTRF and handle error.
455*
456 IF( info.NE.k ) THEN
457 CALL alaerh( path, 'ZSYTRF_AA_2STAGE', info, k,
458 $ uplo, n, n, -1, -1, nb, imat, nfail,
459 $ nerrs, nout )
460 END IF
461*
462*+ TEST 1
463* Reconstruct matrix from factors and compute residual.
464*
465c CALL ZSYT01_AA( UPLO, N, A, LDA, AFAC, LDA, IWORK,
466c $ AINV, LDA, RWORK, RESULT( 1 ) )
467c NT = 1
468 nt = 0
469*
470*
471* Print information about the tests that did not pass
472* the threshold.
473*
474 DO 110 k = 1, nt
475 IF( result( k ).GE.thresh ) THEN
476 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
477 $ CALL alahd( nout, path )
478 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
479 $ result( k )
480 nfail = nfail + 1
481 END IF
482 110 CONTINUE
483 nrun = nrun + nt
484*
485* Skip solver test if INFO is not 0.
486*
487 IF( info.NE.0 ) THEN
488 GO TO 140
489 END IF
490*
491* Do for each value of NRHS in NSVAL.
492*
493 DO 130 irhs = 1, nns
494 nrhs = nsval( irhs )
495*
496*+ TEST 2 (Using TRS)
497* Solve and compute residual for A * X = B.
498*
499* Choose a set of NRHS random solution vectors
500* stored in XACT and set up the right hand side B
501*
502 srnamt = 'ZLARHS'
503 CALL zlarhs( matpath, xtype, uplo, ' ', n, n,
504 $ kl, ku, nrhs, a, lda, xact, lda,
505 $ b, lda, iseed, info )
506 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
507*
508 srnamt = 'ZSYTRS_AA_2STAGE'
509 lwork = max( 1, 3*n-2 )
510 CALL zsytrs_aa_2stage( uplo, n, nrhs, afac, lda,
511 $ ainv, (3*nb+1)*n, iwork, iwork( 1+n ),
512 $ x, lda, info )
513*
514* Check error code from ZSYTRS and handle error.
515*
516 IF( info.NE.0 ) THEN
517 IF( izero.EQ.0 ) THEN
518 CALL alaerh( path, 'ZSYTRS_AA_2STAGE',
519 $ info, 0, uplo, n, n, -1, -1,
520 $ nrhs, imat, nfail, nerrs, nout )
521 END IF
522 ELSE
523 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda
524 $ )
525*
526* Compute the residual for the solution
527*
528 CALL zsyt02( uplo, n, nrhs, a, lda, x, lda,
529 $ work, lda, rwork, result( 2 ) )
530*
531*
532* Print information about the tests that did not pass
533* the threshold.
534*
535 DO 120 k = 2, 2
536 IF( result( k ).GE.thresh ) THEN
537 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
538 $ CALL alahd( nout, path )
539 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
540 $ imat, k, result( k )
541 nfail = nfail + 1
542 END IF
543 120 CONTINUE
544 END IF
545 nrun = nrun + 1
546*
547* End do for each value of NRHS in NSVAL.
548*
549 130 CONTINUE
550 140 CONTINUE
551 150 CONTINUE
552 160 CONTINUE
553 170 CONTINUE
554 180 CONTINUE
555*
556* Print a summary of the results.
557*
558 CALL alasum( path, nout, nfail, nrun, nerrs )
559*
560 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
561 $ i2, ', test ', i2, ', ratio =', g12.5 )
562 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
563 $ i2, ', test(', i2, ') =', g12.5 )
564 9995 FORMAT( ' Invalid input value: ', a4, '=', i6, '; must be <=',
565 $ i6 )
566 RETURN
567*
568* End of ZCHKSY_AA_2STAGE
569*
zsytrf_aa_2stage
subroutine zsytrf_aa_2stage(uplo, n, a, lda, tb, ltb, ipiv, ipiv2, work, lwork, info)
ZSYTRF_AA_2STAGE
Definition zsytrf_aa_2stage.f:160
zsytrs_aa_2stage
subroutine zsytrs_aa_2stage(uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, info)
ZSYTRS_AA_2STAGE
Definition zsytrs_aa_2stage.f:139

◆ zchksy_rk()

subroutine zchksy_rk ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) e,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKSY_RK

Purpose:
!>
!> ZCHKSY_RK tests ZSYTRF_RK, -TRI_3, -TRS_3,
!> and -CON_3.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]E
!>          E is COMPLEX*16 array, dimension (NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX))
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (2*NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 174 of file zchksy_rk.f.

177*
178* -- LAPACK test routine --
179* -- LAPACK is a software package provided by Univ. of Tennessee, --
180* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
181*
182* .. Scalar Arguments ..
183 LOGICAL TSTERR
184 INTEGER NMAX, NN, NNB, NNS, NOUT
185 DOUBLE PRECISION THRESH
186* ..
187* .. Array Arguments ..
188 LOGICAL DOTYPE( * )
189 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
190 DOUBLE PRECISION RWORK( * )
191 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
192 $ WORK( * ), X( * ), XACT( * )
193* ..
194*
195* =====================================================================
196*
197* .. Parameters ..
198 DOUBLE PRECISION ZERO, ONE
199 parameter( zero = 0.0d+0, one = 1.0d+0 )
200 DOUBLE PRECISION ONEHALF
201 parameter( onehalf = 0.5d+0 )
202 DOUBLE PRECISION EIGHT, SEVTEN
203 parameter( eight = 8.0d+0, sevten = 17.0d+0 )
204 COMPLEX*16 CZERO
205 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
206 INTEGER NTYPES
207 parameter( ntypes = 11 )
208 INTEGER NTESTS
209 parameter( ntests = 7 )
210* ..
211* .. Local Scalars ..
212 LOGICAL TRFCON, ZEROT
213 CHARACTER DIST, TYPE, UPLO, XTYPE
214 CHARACTER*3 PATH, MATPATH
215 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
216 $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA,
217 $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS,
218 $ NRUN, NT
219 DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, SING_MAX,
220 $ SING_MIN, RCOND, RCONDC
221* ..
222* .. Local Arrays ..
223 CHARACTER UPLOS( 2 )
224 INTEGER ISEED( 4 ), ISEEDY( 4 )
225 DOUBLE PRECISION RESULT( NTESTS )
226 COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 )
227* ..
228* .. External Functions ..
229 DOUBLE PRECISION DGET06, ZLANGE, ZLANSY
230 EXTERNAL dget06, zlange, zlansy
231* ..
232* .. External Subroutines ..
233 EXTERNAL alaerh, alahd, alasum, zerrsy, zgesvd, zget04,
234 $ zlacpy, zlarhs, zlatb4, zlatms, zlatsy, zsyt02,
235 $ zsyt03, zsycon_3, zsyt01_3, zsytrf_rk,
236 $ zsytri_3, zsytrs_3, xlaenv
237* ..
238* .. Intrinsic Functions ..
239 INTRINSIC max, min, sqrt
240* ..
241* .. Scalars in Common ..
242 LOGICAL LERR, OK
243 CHARACTER*32 SRNAMT
244 INTEGER INFOT, NUNIT
245* ..
246* .. Common blocks ..
247 COMMON / infoc / infot, nunit, ok, lerr
248 COMMON / srnamc / srnamt
249* ..
250* .. Data statements ..
251 DATA iseedy / 1988, 1989, 1990, 1991 /
252 DATA uplos / 'U', 'L' /
253* ..
254* .. Executable Statements ..
255*
256* Initialize constants and the random number seed.
257*
258 alpha = ( one+sqrt( sevten ) ) / eight
259*
260* Test path
261*
262 path( 1: 1 ) = 'Zomplex precision'
263 path( 2: 3 ) = 'SK'
264*
265* Path to generate matrices
266*
267 matpath( 1: 1 ) = 'Zomplex precision'
268 matpath( 2: 3 ) = 'SY'
269*
270 nrun = 0
271 nfail = 0
272 nerrs = 0
273 DO 10 i = 1, 4
274 iseed( i ) = iseedy( i )
275 10 CONTINUE
276*
277* Test the error exits
278*
279 IF( tsterr )
280 $ CALL zerrsy( path, nout )
281 infot = 0
282*
283* Set the minimum block size for which the block routine should
284* be used, which will be later returned by ILAENV
285*
286 CALL xlaenv( 2, 2 )
287*
288* Do for each value of N in NVAL
289*
290 DO 270 in = 1, nn
291 n = nval( in )
292 lda = max( n, 1 )
293 xtype = 'N'
294 nimat = ntypes
295 IF( n.LE.0 )
296 $ nimat = 1
297*
298 izero = 0
299*
300* Do for each value of matrix type IMAT
301*
302 DO 260 imat = 1, nimat
303*
304* Do the tests only if DOTYPE( IMAT ) is true.
305*
306 IF( .NOT.dotype( imat ) )
307 $ GO TO 260
308*
309* Skip types 3, 4, 5, or 6 if the matrix size is too small.
310*
311 zerot = imat.GE.3 .AND. imat.LE.6
312 IF( zerot .AND. n.LT.imat-2 )
313 $ GO TO 260
314*
315* Do first for UPLO = 'U', then for UPLO = 'L'
316*
317 DO 250 iuplo = 1, 2
318 uplo = uplos( iuplo )
319*
320* Begin generate test matrix A.
321*
322 IF( imat.NE.ntypes ) THEN
323*
324* Set up parameters with ZLATB4 for the matrix generator
325* based on the type of matrix to be generated.
326*
327 CALL zlatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
328 $ MODE, CNDNUM, DIST )
329*
330* Generate a matrix with ZLATMS.
331*
332 srnamt = 'ZLATMS'
333 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
334 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
335 $ WORK, INFO )
336*
337* Check error code from ZLATMS and handle error.
338*
339 IF( info.NE.0 ) THEN
340 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n,
341 $ -1, -1, -1, imat, nfail, nerrs, nout )
342*
343* Skip all tests for this generated matrix
344*
345 GO TO 250
346 END IF
347*
348* For matrix types 3-6, zero one or more rows and
349* columns of the matrix to test that INFO is returned
350* correctly.
351*
352 IF( zerot ) THEN
353 IF( imat.EQ.3 ) THEN
354 izero = 1
355 ELSE IF( imat.EQ.4 ) THEN
356 izero = n
357 ELSE
358 izero = n / 2 + 1
359 END IF
360*
361 IF( imat.LT.6 ) THEN
362*
363* Set row and column IZERO to zero.
364*
365 IF( iuplo.EQ.1 ) THEN
366 ioff = ( izero-1 )*lda
367 DO 20 i = 1, izero - 1
368 a( ioff+i ) = czero
369 20 CONTINUE
370 ioff = ioff + izero
371 DO 30 i = izero, n
372 a( ioff ) = czero
373 ioff = ioff + lda
374 30 CONTINUE
375 ELSE
376 ioff = izero
377 DO 40 i = 1, izero - 1
378 a( ioff ) = czero
379 ioff = ioff + lda
380 40 CONTINUE
381 ioff = ioff - izero
382 DO 50 i = izero, n
383 a( ioff+i ) = czero
384 50 CONTINUE
385 END IF
386 ELSE
387 IF( iuplo.EQ.1 ) THEN
388*
389* Set the first IZERO rows and columns to zero.
390*
391 ioff = 0
392 DO 70 j = 1, n
393 i2 = min( j, izero )
394 DO 60 i = 1, i2
395 a( ioff+i ) = czero
396 60 CONTINUE
397 ioff = ioff + lda
398 70 CONTINUE
399 ELSE
400*
401* Set the last IZERO rows and columns to zero.
402*
403 ioff = 0
404 DO 90 j = 1, n
405 i1 = max( j, izero )
406 DO 80 i = i1, n
407 a( ioff+i ) = czero
408 80 CONTINUE
409 ioff = ioff + lda
410 90 CONTINUE
411 END IF
412 END IF
413 ELSE
414 izero = 0
415 END IF
416*
417 ELSE
418*
419* For matrix kind IMAT = 11, generate special block
420* diagonal matrix to test alternate code
421* for the 2 x 2 blocks.
422*
423 CALL zlatsy( uplo, n, a, lda, iseed )
424*
425 END IF
426*
427* End generate test matrix A.
428*
429*
430* Do for each value of NB in NBVAL
431*
432 DO 240 inb = 1, nnb
433*
434* Set the optimal blocksize, which will be later
435* returned by ILAENV.
436*
437 nb = nbval( inb )
438 CALL xlaenv( 1, nb )
439*
440* Copy the test matrix A into matrix AFAC which
441* will be factorized in place. This is needed to
442* preserve the test matrix A for subsequent tests.
443*
444 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
445*
446* Compute the L*D*L**T or U*D*U**T factorization of the
447* matrix. IWORK stores details of the interchanges and
448* the block structure of D. AINV is a work array for
449* block factorization, LWORK is the length of AINV.
450*
451 lwork = max( 2, nb )*lda
452 srnamt = 'ZSYTRF_RK'
453 CALL zsytrf_rk( uplo, n, afac, lda, e, iwork, ainv,
454 $ lwork, info )
455*
456* Adjust the expected value of INFO to account for
457* pivoting.
458*
459 k = izero
460 IF( k.GT.0 ) THEN
461 100 CONTINUE
462 IF( iwork( k ).LT.0 ) THEN
463 IF( iwork( k ).NE.-k ) THEN
464 k = -iwork( k )
465 GO TO 100
466 END IF
467 ELSE IF( iwork( k ).NE.k ) THEN
468 k = iwork( k )
469 GO TO 100
470 END IF
471 END IF
472*
473* Check error code from ZSYTRF_RK and handle error.
474*
475 IF( info.NE.k)
476 $ CALL alaerh( path, 'ZSYTRF_RK', info, k,
477 $ uplo, n, n, -1, -1, nb, imat,
478 $ nfail, nerrs, nout )
479*
480* Set the condition estimate flag if the INFO is not 0.
481*
482 IF( info.NE.0 ) THEN
483 trfcon = .true.
484 ELSE
485 trfcon = .false.
486 END IF
487*
488*+ TEST 1
489* Reconstruct matrix from factors and compute residual.
490*
491 CALL zsyt01_3( uplo, n, a, lda, afac, lda, e, iwork,
492 $ ainv, lda, rwork, result( 1 ) )
493 nt = 1
494*
495*+ TEST 2
496* Form the inverse and compute the residual,
497* if the factorization was competed without INFO > 0
498* (i.e. there is no zero rows and columns).
499* Do it only for the first block size.
500*
501 IF( inb.EQ.1 .AND. .NOT.trfcon ) THEN
502 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
503 srnamt = 'ZSYTRI_3'
504*
505* Another reason that we need to compute the inverse
506* is that ZSYT03 produces RCONDC which is used later
507* in TEST6 and TEST7.
508*
509 lwork = (n+nb+1)*(nb+3)
510 CALL zsytri_3( uplo, n, ainv, lda, e, iwork, work,
511 $ lwork, info )
512*
513* Check error code from ZSYTRI_3 and handle error.
514*
515 IF( info.NE.0 )
516 $ CALL alaerh( path, 'ZSYTRI_3', info, -1,
517 $ uplo, n, n, -1, -1, -1, imat,
518 $ nfail, nerrs, nout )
519*
520* Compute the residual for a symmetric matrix times
521* its inverse.
522*
523 CALL zsyt03( uplo, n, a, lda, ainv, lda, work, lda,
524 $ rwork, rcondc, result( 2 ) )
525 nt = 2
526 END IF
527*
528* Print information about the tests that did not pass
529* the threshold.
530*
531 DO 110 k = 1, nt
532 IF( result( k ).GE.thresh ) THEN
533 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
534 $ CALL alahd( nout, path )
535 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
536 $ result( k )
537 nfail = nfail + 1
538 END IF
539 110 CONTINUE
540 nrun = nrun + nt
541*
542*+ TEST 3
543* Compute largest element in U or L
544*
545 result( 3 ) = zero
546 dtemp = zero
547*
548 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) ) /
549 $ ( one-alpha )
550*
551 IF( iuplo.EQ.1 ) THEN
552*
553* Compute largest element in U
554*
555 k = n
556 120 CONTINUE
557 IF( k.LE.1 )
558 $ GO TO 130
559*
560 IF( iwork( k ).GT.zero ) THEN
561*
562* Get max absolute value from elements
563* in column k in in U
564*
565 dtemp = zlange( 'M', k-1, 1,
566 $ afac( ( k-1 )*lda+1 ), lda, rwork )
567 ELSE
568*
569* Get max absolute value from elements
570* in columns k and k-1 in U
571*
572 dtemp = zlange( 'M', k-2, 2,
573 $ afac( ( k-2 )*lda+1 ), lda, rwork )
574 k = k - 1
575*
576 END IF
577*
578* DTEMP should be bounded by CONST
579*
580 dtemp = dtemp - const + thresh
581 IF( dtemp.GT.result( 3 ) )
582 $ result( 3 ) = dtemp
583*
584 k = k - 1
585*
586 GO TO 120
587 130 CONTINUE
588*
589 ELSE
590*
591* Compute largest element in L
592*
593 k = 1
594 140 CONTINUE
595 IF( k.GE.n )
596 $ GO TO 150
597*
598 IF( iwork( k ).GT.zero ) THEN
599*
600* Get max absolute value from elements
601* in column k in in L
602*
603 dtemp = zlange( 'M', n-k, 1,
604 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
605 ELSE
606*
607* Get max absolute value from elements
608* in columns k and k+1 in L
609*
610 dtemp = zlange( 'M', n-k-1, 2,
611 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
612 k = k + 1
613*
614 END IF
615*
616* DTEMP should be bounded by CONST
617*
618 dtemp = dtemp - const + thresh
619 IF( dtemp.GT.result( 3 ) )
620 $ result( 3 ) = dtemp
621*
622 k = k + 1
623*
624 GO TO 140
625 150 CONTINUE
626 END IF
627*
628*
629*+ TEST 4
630* Compute largest 2-Norm (condition number)
631* of 2-by-2 diag blocks
632*
633 result( 4 ) = zero
634 dtemp = zero
635*
636 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) )*
637 $ ( ( one + alpha ) / ( one - alpha ) )
638*
639 IF( iuplo.EQ.1 ) THEN
640*
641* Loop backward for UPLO = 'U'
642*
643 k = n
644 160 CONTINUE
645 IF( k.LE.1 )
646 $ GO TO 170
647*
648 IF( iwork( k ).LT.zero ) THEN
649*
650* Get the two singular values
651* (real and non-negative) of a 2-by-2 block,
652* store them in RWORK array
653*
654 block( 1, 1 ) = afac( ( k-2 )*lda+k-1 )
655 block( 1, 2 ) = e( k )
656 block( 2, 1 ) = block( 1, 2 )
657 block( 2, 2 ) = afac( (k-1)*lda+k )
658*
659 CALL zgesvd( 'N', 'N', 2, 2, block, 2, rwork,
660 $ zdummy, 1, zdummy, 1,
661 $ work, 6, rwork( 3 ), info )
662*
663*
664 sing_max = rwork( 1 )
665 sing_min = rwork( 2 )
666*
667 dtemp = sing_max / sing_min
668*
669* DTEMP should be bounded by CONST
670*
671 dtemp = dtemp - const + thresh
672 IF( dtemp.GT.result( 4 ) )
673 $ result( 4 ) = dtemp
674 k = k - 1
675*
676 END IF
677*
678 k = k - 1
679*
680 GO TO 160
681 170 CONTINUE
682*
683 ELSE
684*
685* Loop forward for UPLO = 'L'
686*
687 k = 1
688 180 CONTINUE
689 IF( k.GE.n )
690 $ GO TO 190
691*
692 IF( iwork( k ).LT.zero ) THEN
693*
694* Get the two singular values
695* (real and non-negative) of a 2-by-2 block,
696* store them in RWORK array
697*
698 block( 1, 1 ) = afac( ( k-1 )*lda+k )
699 block( 2, 1 ) = e( k )
700 block( 1, 2 ) = block( 2, 1 )
701 block( 2, 2 ) = afac( k*lda+k+1 )
702*
703 CALL zgesvd( 'N', 'N', 2, 2, block, 2, rwork,
704 $ zdummy, 1, zdummy, 1,
705 $ work, 6, rwork(3), info )
706*
707 sing_max = rwork( 1 )
708 sing_min = rwork( 2 )
709*
710 dtemp = sing_max / sing_min
711*
712* DTEMP should be bounded by CONST
713*
714 dtemp = dtemp - const + thresh
715 IF( dtemp.GT.result( 4 ) )
716 $ result( 4 ) = dtemp
717 k = k + 1
718*
719 END IF
720*
721 k = k + 1
722*
723 GO TO 180
724 190 CONTINUE
725 END IF
726*
727* Print information about the tests that did not pass
728* the threshold.
729*
730 DO 200 k = 3, 4
731 IF( result( k ).GE.thresh ) THEN
732 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
733 $ CALL alahd( nout, path )
734 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
735 $ result( k )
736 nfail = nfail + 1
737 END IF
738 200 CONTINUE
739 nrun = nrun + 2
740*
741* Skip the other tests if this is not the first block
742* size.
743*
744 IF( inb.GT.1 )
745 $ GO TO 240
746*
747* Do only the condition estimate if INFO is not 0.
748*
749 IF( trfcon ) THEN
750 rcondc = zero
751 GO TO 230
752 END IF
753*
754* Do for each value of NRHS in NSVAL.
755*
756 DO 220 irhs = 1, nns
757 nrhs = nsval( irhs )
758*
759*+ TEST 5 ( Using TRS_3)
760* Solve and compute residual for A * X = B.
761*
762* Choose a set of NRHS random solution vectors
763* stored in XACT and set up the right hand side B
764*
765 srnamt = 'ZLARHS'
766 CALL zlarhs( matpath, xtype, uplo, ' ', n, n,
767 $ kl, ku, nrhs, a, lda, xact, lda,
768 $ b, lda, iseed, info )
769 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
770*
771 srnamt = 'ZSYTRS_3'
772 CALL zsytrs_3( uplo, n, nrhs, afac, lda, e, iwork,
773 $ x, lda, info )
774*
775* Check error code from ZSYTRS_3 and handle error.
776*
777 IF( info.NE.0 )
778 $ CALL alaerh( path, 'ZSYTRS_3', info, 0,
779 $ uplo, n, n, -1, -1, nrhs, imat,
780 $ nfail, nerrs, nout )
781*
782 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
783*
784* Compute the residual for the solution
785*
786 CALL zsyt02( uplo, n, nrhs, a, lda, x, lda, work,
787 $ lda, rwork, result( 5 ) )
788*
789*+ TEST 6
790* Check solution from generated exact solution.
791*
792 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
793 $ result( 6 ) )
794*
795* Print information about the tests that did not pass
796* the threshold.
797*
798 DO 210 k = 5, 6
799 IF( result( k ).GE.thresh ) THEN
800 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
801 $ CALL alahd( nout, path )
802 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
803 $ imat, k, result( k )
804 nfail = nfail + 1
805 END IF
806 210 CONTINUE
807 nrun = nrun + 2
808*
809* End do for each value of NRHS in NSVAL.
810*
811 220 CONTINUE
812*
813*+ TEST 7
814* Get an estimate of RCOND = 1/CNDNUM.
815*
816 230 CONTINUE
817 anorm = zlansy( '1', uplo, n, a, lda, rwork )
818 srnamt = 'ZSYCON_3'
819 CALL zsycon_3( uplo, n, afac, lda, e, iwork, anorm,
820 $ rcond, work, info )
821*
822* Check error code from ZSYCON_3 and handle error.
823*
824 IF( info.NE.0 )
825 $ CALL alaerh( path, 'ZSYCON_3', info, 0,
826 $ uplo, n, n, -1, -1, -1, imat,
827 $ nfail, nerrs, nout )
828*
829* Compute the test ratio to compare values of RCOND
830*
831 result( 7 ) = dget06( rcond, rcondc )
832*
833* Print information about the tests that did not pass
834* the threshold.
835*
836 IF( result( 7 ).GE.thresh ) THEN
837 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
838 $ CALL alahd( nout, path )
839 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
840 $ result( 7 )
841 nfail = nfail + 1
842 END IF
843 nrun = nrun + 1
844 240 CONTINUE
845*
846 250 CONTINUE
847 260 CONTINUE
848 270 CONTINUE
849*
850* Print a summary of the results.
851*
852 CALL alasum( path, nout, nfail, nrun, nerrs )
853*
854 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
855 $ i2, ', test ', i2, ', ratio =', g12.5 )
856 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
857 $ i2, ', test(', i2, ') =', g12.5 )
858 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
859 $ ', test(', i2, ') =', g12.5 )
860 RETURN
861*
862* End of ZCHKSY_RK
863*
zsytrs_3
subroutine zsytrs_3(uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info)
ZSYTRS_3
Definition zsytrs_3.f:165
zsycon_3
subroutine zsycon_3(uplo, n, a, lda, e, ipiv, anorm, rcond, work, info)
ZSYCON_3
Definition zsycon_3.f:166
zsytri_3
subroutine zsytri_3(uplo, n, a, lda, e, ipiv, work, lwork, info)
ZSYTRI_3
Definition zsytri_3.f:170
zsytrf_rk
subroutine zsytrf_rk(uplo, n, a, lda, e, ipiv, work, lwork, info)
ZSYTRF_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch...
Definition zsytrf_rk.f:259
zsyt01_3
subroutine zsyt01_3(uplo, n, a, lda, afac, ldafac, e, ipiv, c, ldc, rwork, resid)
ZSYT01_3
Definition zsyt01_3.f:141

◆ zchksy_rook()

subroutine zchksy_rook ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZCHKSY_ROOK

Purpose:
!>
!> ZCHKSY_ROOK tests ZSYTRF_ROOK, -TRI_ROOK, -TRS_ROOK,
!> and -CON_ROOK.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX))
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (2*NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 169 of file zchksy_rook.f.

172*
173* -- LAPACK test routine --
174* -- LAPACK is a software package provided by Univ. of Tennessee, --
175* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176*
177* .. Scalar Arguments ..
178 LOGICAL TSTERR
179 INTEGER NMAX, NN, NNB, NNS, NOUT
180 DOUBLE PRECISION THRESH
181* ..
182* .. Array Arguments ..
183 LOGICAL DOTYPE( * )
184 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
185 DOUBLE PRECISION RWORK( * )
186 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
187 $ WORK( * ), X( * ), XACT( * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 DOUBLE PRECISION ZERO, ONE
194 parameter( zero = 0.0d+0, one = 1.0d+0 )
195 DOUBLE PRECISION ONEHALF
196 parameter( onehalf = 0.5d+0 )
197 DOUBLE PRECISION EIGHT, SEVTEN
198 parameter( eight = 8.0d+0, sevten = 17.0d+0 )
199 COMPLEX*16 CZERO
200 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
201 INTEGER NTYPES
202 parameter( ntypes = 11 )
203 INTEGER NTESTS
204 parameter( ntests = 7 )
205* ..
206* .. Local Scalars ..
207 LOGICAL TRFCON, ZEROT
208 CHARACTER DIST, TYPE, UPLO, XTYPE
209 CHARACTER*3 PATH, MATPATH
210 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
211 $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
212 $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
213 DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, SING_MAX,
214 $ SING_MIN, RCOND, RCONDC
215* ..
216* .. Local Arrays ..
217 CHARACTER UPLOS( 2 )
218 INTEGER ISEED( 4 ), ISEEDY( 4 )
219 DOUBLE PRECISION RESULT( NTESTS )
220 COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 )
221* ..
222* .. External Functions ..
223 DOUBLE PRECISION DGET06, ZLANGE, ZLANSY
224 EXTERNAL dget06, zlange, zlansy
225* ..
226* .. External Subroutines ..
227 EXTERNAL alaerh, alahd, alasum, zerrsy, zgesvd, zget04,
228 $ zlacpy, zlarhs, zlatb4, zlatms, zlatsy,zsyt02,
229 $ zsyt03, zsycon_rook, zsyt01_rook, zsytrf_rook,
230 $ zsytri_rook, zsytrs_rook, xlaenv
231* ..
232* .. Intrinsic Functions ..
233 INTRINSIC max, min, sqrt
234* ..
235* .. Scalars in Common ..
236 LOGICAL LERR, OK
237 CHARACTER*32 SRNAMT
238 INTEGER INFOT, NUNIT
239* ..
240* .. Common blocks ..
241 COMMON / infoc / infot, nunit, ok, lerr
242 COMMON / srnamc / srnamt
243* ..
244* .. Data statements ..
245 DATA iseedy / 1988, 1989, 1990, 1991 /
246 DATA uplos / 'U', 'L' /
247* ..
248* .. Executable Statements ..
249*
250* Initialize constants and the random number seed.
251*
252 alpha = ( one+sqrt( sevten ) ) / eight
253*
254* Test path
255*
256 path( 1: 1 ) = 'Zomplex precision'
257 path( 2: 3 ) = 'SR'
258*
259* Path to generate matrices
260*
261 matpath( 1: 1 ) = 'Zomplex precision'
262 matpath( 2: 3 ) = 'SY'
263*
264 nrun = 0
265 nfail = 0
266 nerrs = 0
267 DO 10 i = 1, 4
268 iseed( i ) = iseedy( i )
269 10 CONTINUE
270*
271* Test the error exits
272*
273 IF( tsterr )
274 $ CALL zerrsy( path, nout )
275 infot = 0
276*
277* Set the minimum block size for which the block routine should
278* be used, which will be later returned by ILAENV
279*
280 CALL xlaenv( 2, 2 )
281*
282* Do for each value of N in NVAL
283*
284 DO 270 in = 1, nn
285 n = nval( in )
286 lda = max( n, 1 )
287 xtype = 'N'
288 nimat = ntypes
289 IF( n.LE.0 )
290 $ nimat = 1
291*
292 izero = 0
293*
294* Do for each value of matrix type IMAT
295*
296 DO 260 imat = 1, nimat
297*
298* Do the tests only if DOTYPE( IMAT ) is true.
299*
300 IF( .NOT.dotype( imat ) )
301 $ GO TO 260
302*
303* Skip types 3, 4, 5, or 6 if the matrix size is too small.
304*
305 zerot = imat.GE.3 .AND. imat.LE.6
306 IF( zerot .AND. n.LT.imat-2 )
307 $ GO TO 260
308*
309* Do first for UPLO = 'U', then for UPLO = 'L'
310*
311 DO 250 iuplo = 1, 2
312 uplo = uplos( iuplo )
313*
314* Begin generate test matrix A.
315*
316 IF( imat.NE.ntypes ) THEN
317*
318* Set up parameters with ZLATB4 for the matrix generator
319* based on the type of matrix to be generated.
320*
321 CALL zlatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
322 $ MODE, CNDNUM, DIST )
323*
324* Generate a matrix with ZLATMS.
325*
326 srnamt = 'ZLATMS'
327 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
328 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
329 $ WORK, INFO )
330*
331* Check error code from ZLATMS and handle error.
332*
333 IF( info.NE.0 ) THEN
334 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n,
335 $ -1, -1, -1, imat, nfail, nerrs, nout )
336*
337* Skip all tests for this generated matrix
338*
339 GO TO 250
340 END IF
341*
342* For matrix types 3-6, zero one or more rows and
343* columns of the matrix to test that INFO is returned
344* correctly.
345*
346 IF( zerot ) THEN
347 IF( imat.EQ.3 ) THEN
348 izero = 1
349 ELSE IF( imat.EQ.4 ) THEN
350 izero = n
351 ELSE
352 izero = n / 2 + 1
353 END IF
354*
355 IF( imat.LT.6 ) THEN
356*
357* Set row and column IZERO to zero.
358*
359 IF( iuplo.EQ.1 ) THEN
360 ioff = ( izero-1 )*lda
361 DO 20 i = 1, izero - 1
362 a( ioff+i ) = czero
363 20 CONTINUE
364 ioff = ioff + izero
365 DO 30 i = izero, n
366 a( ioff ) = czero
367 ioff = ioff + lda
368 30 CONTINUE
369 ELSE
370 ioff = izero
371 DO 40 i = 1, izero - 1
372 a( ioff ) = czero
373 ioff = ioff + lda
374 40 CONTINUE
375 ioff = ioff - izero
376 DO 50 i = izero, n
377 a( ioff+i ) = czero
378 50 CONTINUE
379 END IF
380 ELSE
381 IF( iuplo.EQ.1 ) THEN
382*
383* Set the first IZERO rows and columns to zero.
384*
385 ioff = 0
386 DO 70 j = 1, n
387 i2 = min( j, izero )
388 DO 60 i = 1, i2
389 a( ioff+i ) = czero
390 60 CONTINUE
391 ioff = ioff + lda
392 70 CONTINUE
393 ELSE
394*
395* Set the last IZERO rows and columns to zero.
396*
397 ioff = 0
398 DO 90 j = 1, n
399 i1 = max( j, izero )
400 DO 80 i = i1, n
401 a( ioff+i ) = czero
402 80 CONTINUE
403 ioff = ioff + lda
404 90 CONTINUE
405 END IF
406 END IF
407 ELSE
408 izero = 0
409 END IF
410*
411 ELSE
412*
413* For matrix kind IMAT = 11, generate special block
414* diagonal matrix to test alternate code
415* for the 2 x 2 blocks.
416*
417 CALL zlatsy( uplo, n, a, lda, iseed )
418*
419 END IF
420*
421* End generate test matrix A.
422*
423*
424* Do for each value of NB in NBVAL
425*
426 DO 240 inb = 1, nnb
427*
428* Set the optimal blocksize, which will be later
429* returned by ILAENV.
430*
431 nb = nbval( inb )
432 CALL xlaenv( 1, nb )
433*
434* Copy the test matrix A into matrix AFAC which
435* will be factorized in place. This is needed to
436* preserve the test matrix A for subsequent tests.
437*
438 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
439*
440* Compute the L*D*L**T or U*D*U**T factorization of the
441* matrix. IWORK stores details of the interchanges and
442* the block structure of D. AINV is a work array for
443* block factorization, LWORK is the length of AINV.
444*
445 lwork = max( 2, nb )*lda
446 srnamt = 'ZSYTRF_ROOK'
447 CALL zsytrf_rook( uplo, n, afac, lda, iwork, ainv,
448 $ lwork, info )
449*
450* Adjust the expected value of INFO to account for
451* pivoting.
452*
453 k = izero
454 IF( k.GT.0 ) THEN
455 100 CONTINUE
456 IF( iwork( k ).LT.0 ) THEN
457 IF( iwork( k ).NE.-k ) THEN
458 k = -iwork( k )
459 GO TO 100
460 END IF
461 ELSE IF( iwork( k ).NE.k ) THEN
462 k = iwork( k )
463 GO TO 100
464 END IF
465 END IF
466*
467* Check error code from ZSYTRF_ROOK and handle error.
468*
469 IF( info.NE.k)
470 $ CALL alaerh( path, 'ZSYTRF_ROOK', info, k,
471 $ uplo, n, n, -1, -1, nb, imat,
472 $ nfail, nerrs, nout )
473*
474* Set the condition estimate flag if the INFO is not 0.
475*
476 IF( info.NE.0 ) THEN
477 trfcon = .true.
478 ELSE
479 trfcon = .false.
480 END IF
481*
482*+ TEST 1
483* Reconstruct matrix from factors and compute residual.
484*
485 CALL zsyt01_rook( uplo, n, a, lda, afac, lda, iwork,
486 $ ainv, lda, rwork, result( 1 ) )
487 nt = 1
488*
489*+ TEST 2
490* Form the inverse and compute the residual,
491* if the factorization was competed without INFO > 0
492* (i.e. there is no zero rows and columns).
493* Do it only for the first block size.
494*
495 IF( inb.EQ.1 .AND. .NOT.trfcon ) THEN
496 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
497 srnamt = 'ZSYTRI_ROOK'
498 CALL zsytri_rook( uplo, n, ainv, lda, iwork, work,
499 $ info )
500*
501* Check error code from ZSYTRI_ROOK and handle error.
502*
503 IF( info.NE.0 )
504 $ CALL alaerh( path, 'ZSYTRI_ROOK', info, -1,
505 $ uplo, n, n, -1, -1, -1, imat,
506 $ nfail, nerrs, nout )
507*
508* Compute the residual for a symmetric matrix times
509* its inverse.
510*
511 CALL zsyt03( uplo, n, a, lda, ainv, lda, work, lda,
512 $ rwork, rcondc, result( 2 ) )
513 nt = 2
514 END IF
515*
516* Print information about the tests that did not pass
517* the threshold.
518*
519 DO 110 k = 1, nt
520 IF( result( k ).GE.thresh ) THEN
521 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
522 $ CALL alahd( nout, path )
523 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
524 $ result( k )
525 nfail = nfail + 1
526 END IF
527 110 CONTINUE
528 nrun = nrun + nt
529*
530*+ TEST 3
531* Compute largest element in U or L
532*
533 result( 3 ) = zero
534 dtemp = zero
535*
536 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) ) /
537 $ ( one-alpha )
538*
539 IF( iuplo.EQ.1 ) THEN
540*
541* Compute largest element in U
542*
543 k = n
544 120 CONTINUE
545 IF( k.LE.1 )
546 $ GO TO 130
547*
548 IF( iwork( k ).GT.zero ) THEN
549*
550* Get max absolute value from elements
551* in column k in in U
552*
553 dtemp = zlange( 'M', k-1, 1,
554 $ afac( ( k-1 )*lda+1 ), lda, rwork )
555 ELSE
556*
557* Get max absolute value from elements
558* in columns k and k-1 in U
559*
560 dtemp = zlange( 'M', k-2, 2,
561 $ afac( ( k-2 )*lda+1 ), lda, rwork )
562 k = k - 1
563*
564 END IF
565*
566* DTEMP should be bounded by CONST
567*
568 dtemp = dtemp - const + thresh
569 IF( dtemp.GT.result( 3 ) )
570 $ result( 3 ) = dtemp
571*
572 k = k - 1
573*
574 GO TO 120
575 130 CONTINUE
576*
577 ELSE
578*
579* Compute largest element in L
580*
581 k = 1
582 140 CONTINUE
583 IF( k.GE.n )
584 $ GO TO 150
585*
586 IF( iwork( k ).GT.zero ) THEN
587*
588* Get max absolute value from elements
589* in column k in in L
590*
591 dtemp = zlange( 'M', n-k, 1,
592 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
593 ELSE
594*
595* Get max absolute value from elements
596* in columns k and k+1 in L
597*
598 dtemp = zlange( 'M', n-k-1, 2,
599 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
600 k = k + 1
601*
602 END IF
603*
604* DTEMP should be bounded by CONST
605*
606 dtemp = dtemp - const + thresh
607 IF( dtemp.GT.result( 3 ) )
608 $ result( 3 ) = dtemp
609*
610 k = k + 1
611*
612 GO TO 140
613 150 CONTINUE
614 END IF
615*
616*
617*+ TEST 4
618* Compute largest 2-Norm (condition number)
619* of 2-by-2 diag blocks
620*
621 result( 4 ) = zero
622 dtemp = zero
623*
624 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) )*
625 $ ( ( one + alpha ) / ( one - alpha ) )
626*
627 IF( iuplo.EQ.1 ) THEN
628*
629* Loop backward for UPLO = 'U'
630*
631 k = n
632 160 CONTINUE
633 IF( k.LE.1 )
634 $ GO TO 170
635*
636 IF( iwork( k ).LT.zero ) THEN
637*
638* Get the two singular values
639* (real and non-negative) of a 2-by-2 block,
640* store them in RWORK array
641*
642 block( 1, 1 ) = afac( ( k-2 )*lda+k-1 )
643 block( 1, 2 ) = afac( (k-1)*lda+k-1 )
644 block( 2, 1 ) = block( 1, 2 )
645 block( 2, 2 ) = afac( (k-1)*lda+k )
646*
647 CALL zgesvd( 'N', 'N', 2, 2, block, 2, rwork,
648 $ zdummy, 1, zdummy, 1,
649 $ work, 6, rwork( 3 ), info )
650*
651*
652 sing_max = rwork( 1 )
653 sing_min = rwork( 2 )
654*
655 dtemp = sing_max / sing_min
656*
657* DTEMP should be bounded by CONST
658*
659 dtemp = dtemp - const + thresh
660 IF( dtemp.GT.result( 4 ) )
661 $ result( 4 ) = dtemp
662 k = k - 1
663*
664 END IF
665*
666 k = k - 1
667*
668 GO TO 160
669 170 CONTINUE
670*
671 ELSE
672*
673* Loop forward for UPLO = 'L'
674*
675 k = 1
676 180 CONTINUE
677 IF( k.GE.n )
678 $ GO TO 190
679*
680 IF( iwork( k ).LT.zero ) THEN
681*
682* Get the two singular values
683* (real and non-negative) of a 2-by-2 block,
684* store them in RWORK array
685*
686 block( 1, 1 ) = afac( ( k-1 )*lda+k )
687 block( 2, 1 ) = afac( ( k-1 )*lda+k+1 )
688 block( 1, 2 ) = block( 2, 1 )
689 block( 2, 2 ) = afac( k*lda+k+1 )
690*
691 CALL zgesvd( 'N', 'N', 2, 2, block, 2, rwork,
692 $ zdummy, 1, zdummy, 1,
693 $ work, 6, rwork(3), info )
694*
695 sing_max = rwork( 1 )
696 sing_min = rwork( 2 )
697*
698 dtemp = sing_max / sing_min
699*
700* DTEMP should be bounded by CONST
701*
702 dtemp = dtemp - const + thresh
703 IF( dtemp.GT.result( 4 ) )
704 $ result( 4 ) = dtemp
705 k = k + 1
706*
707 END IF
708*
709 k = k + 1
710*
711 GO TO 180
712 190 CONTINUE
713 END IF
714*
715* Print information about the tests that did not pass
716* the threshold.
717*
718 DO 200 k = 3, 4
719 IF( result( k ).GE.thresh ) THEN
720 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
721 $ CALL alahd( nout, path )
722 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
723 $ result( k )
724 nfail = nfail + 1
725 END IF
726 200 CONTINUE
727 nrun = nrun + 2
728*
729* Skip the other tests if this is not the first block
730* size.
731*
732 IF( inb.GT.1 )
733 $ GO TO 240
734*
735* Do only the condition estimate if INFO is not 0.
736*
737 IF( trfcon ) THEN
738 rcondc = zero
739 GO TO 230
740 END IF
741*
742* Do for each value of NRHS in NSVAL.
743*
744 DO 220 irhs = 1, nns
745 nrhs = nsval( irhs )
746*
747*+ TEST 5 ( Using TRS_ROOK)
748* Solve and compute residual for A * X = B.
749*
750* Choose a set of NRHS random solution vectors
751* stored in XACT and set up the right hand side B
752*
753 srnamt = 'ZLARHS'
754 CALL zlarhs( matpath, xtype, uplo, ' ', n, n,
755 $ kl, ku, nrhs, a, lda, xact, lda,
756 $ b, lda, iseed, info )
757 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
758*
759 srnamt = 'ZSYTRS_ROOK'
760 CALL zsytrs_rook( uplo, n, nrhs, afac, lda, iwork,
761 $ x, lda, info )
762*
763* Check error code from ZSYTRS_ROOK and handle error.
764*
765 IF( info.NE.0 )
766 $ CALL alaerh( path, 'ZSYTRS_ROOK', info, 0,
767 $ uplo, n, n, -1, -1, nrhs, imat,
768 $ nfail, nerrs, nout )
769*
770 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
771*
772* Compute the residual for the solution
773*
774 CALL zsyt02( uplo, n, nrhs, a, lda, x, lda, work,
775 $ lda, rwork, result( 5 ) )
776*
777*+ TEST 6
778* Check solution from generated exact solution.
779*
780 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
781 $ result( 6 ) )
782*
783* Print information about the tests that did not pass
784* the threshold.
785*
786 DO 210 k = 5, 6
787 IF( result( k ).GE.thresh ) THEN
788 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
789 $ CALL alahd( nout, path )
790 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
791 $ imat, k, result( k )
792 nfail = nfail + 1
793 END IF
794 210 CONTINUE
795 nrun = nrun + 2
796*
797* End do for each value of NRHS in NSVAL.
798*
799 220 CONTINUE
800*
801*+ TEST 7
802* Get an estimate of RCOND = 1/CNDNUM.
803*
804 230 CONTINUE
805 anorm = zlansy( '1', uplo, n, a, lda, rwork )
806 srnamt = 'ZSYCON_ROOK'
807 CALL zsycon_rook( uplo, n, afac, lda, iwork, anorm,
808 $ rcond, work, info )
809*
810* Check error code from ZSYCON_ROOK and handle error.
811*
812 IF( info.NE.0 )
813 $ CALL alaerh( path, 'ZSYCON_ROOK', info, 0,
814 $ uplo, n, n, -1, -1, -1, imat,
815 $ nfail, nerrs, nout )
816*
817* Compute the test ratio to compare values of RCOND
818*
819 result( 7 ) = dget06( rcond, rcondc )
820*
821* Print information about the tests that did not pass
822* the threshold.
823*
824 IF( result( 7 ).GE.thresh ) THEN
825 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
826 $ CALL alahd( nout, path )
827 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
828 $ result( 7 )
829 nfail = nfail + 1
830 END IF
831 nrun = nrun + 1
832 240 CONTINUE
833*
834 250 CONTINUE
835 260 CONTINUE
836 270 CONTINUE
837*
838* Print a summary of the results.
839*
840 CALL alasum( path, nout, nfail, nrun, nerrs )
841*
842 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
843 $ i2, ', test ', i2, ', ratio =', g12.5 )
844 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
845 $ i2, ', test(', i2, ') =', g12.5 )
846 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
847 $ ', test(', i2, ') =', g12.5 )
848 RETURN
849*
850* End of ZCHKSY_ROOK
851*
zsytrf_rook
subroutine zsytrf_rook(uplo, n, a, lda, ipiv, work, lwork, info)
ZSYTRF_ROOK
Definition zsytrf_rook.f:208
zsytri_rook
subroutine zsytri_rook(uplo, n, a, lda, ipiv, work, info)
ZSYTRI_ROOK
Definition zsytri_rook.f:129
zsytrs_rook
subroutine zsytrs_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
ZSYTRS_ROOK
Definition zsytrs_rook.f:136
zsycon_rook
subroutine zsycon_rook(uplo, n, a, lda, ipiv, anorm, rcond, work, info)
ZSYCON_ROOK
Definition zsycon_rook.f:139
zsyt01_rook
subroutine zsyt01_rook(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
ZSYT01_ROOK
Definition zsyt01_rook.f:125

◆ zchktb()

subroutine zchktb ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) ab,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nout )

ZCHKTB

Purpose:
!>
!> ZCHKTB tests ZTBTRS, -RFS, and -CON, and ZLATBS.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The leading dimension of the work arrays.
!>          NMAX >= the maximum value of N in NVAL.
!>
[out]AB
!>          AB is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (max(NMAX,2*NSMAX))
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 147 of file zchktb.f.

149*
150* -- LAPACK test routine --
151* -- LAPACK is a software package provided by Univ. of Tennessee, --
152* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
153*
154* .. Scalar Arguments ..
155 LOGICAL TSTERR
156 INTEGER NMAX, NN, NNS, NOUT
157 DOUBLE PRECISION THRESH
158* ..
159* .. Array Arguments ..
160 LOGICAL DOTYPE( * )
161 INTEGER NSVAL( * ), NVAL( * )
162 DOUBLE PRECISION RWORK( * )
163 COMPLEX*16 AB( * ), AINV( * ), B( * ), WORK( * ), X( * ),
164 $ XACT( * )
165* ..
166*
167* =====================================================================
168*
169* .. Parameters ..
170 INTEGER NTYPE1, NTYPES
171 parameter( ntype1 = 9, ntypes = 17 )
172 INTEGER NTESTS
173 parameter( ntests = 8 )
174 INTEGER NTRAN
175 parameter( ntran = 3 )
176 DOUBLE PRECISION ONE, ZERO
177 parameter( one = 1.0d+0, zero = 0.0d+0 )
178* ..
179* .. Local Scalars ..
180 CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE
181 CHARACTER*3 PATH
182 INTEGER I, IDIAG, IK, IMAT, IN, INFO, IRHS, ITRAN,
183 $ IUPLO, J, K, KD, LDA, LDAB, N, NERRS, NFAIL,
184 $ NIMAT, NIMAT2, NK, NRHS, NRUN
185 DOUBLE PRECISION AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
186 $ SCALE
187* ..
188* .. Local Arrays ..
189 CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
190 INTEGER ISEED( 4 ), ISEEDY( 4 )
191 DOUBLE PRECISION RESULT( NTESTS )
192* ..
193* .. External Functions ..
194 LOGICAL LSAME
195 DOUBLE PRECISION ZLANTB, ZLANTR
196 EXTERNAL lsame, zlantb, zlantr
197* ..
198* .. External Subroutines ..
199 EXTERNAL alaerh, alahd, alasum, zcopy, zerrtr, zget04,
200 $ zlacpy, zlarhs, zlaset, zlatbs, zlattb, ztbcon,
201 $ ztbrfs, ztbsv, ztbt02, ztbt03, ztbt05, ztbt06,
202 $ ztbtrs
203* ..
204* .. Scalars in Common ..
205 LOGICAL LERR, OK
206 CHARACTER*32 SRNAMT
207 INTEGER INFOT, IOUNIT
208* ..
209* .. Common blocks ..
210 COMMON / infoc / infot, iounit, ok, lerr
211 COMMON / srnamc / srnamt
212* ..
213* .. Intrinsic Functions ..
214 INTRINSIC dcmplx, max, min
215* ..
216* .. Data statements ..
217 DATA iseedy / 1988, 1989, 1990, 1991 /
218 DATA uplos / 'U', 'L' / , transs / 'N', 'T', 'C' /
219* ..
220* .. Executable Statements ..
221*
222* Initialize constants and the random number seed.
223*
224 path( 1: 1 ) = 'Zomplex precision'
225 path( 2: 3 ) = 'TB'
226 nrun = 0
227 nfail = 0
228 nerrs = 0
229 DO 10 i = 1, 4
230 iseed( i ) = iseedy( i )
231 10 CONTINUE
232*
233* Test the error exits
234*
235 IF( tsterr )
236 $ CALL zerrtr( path, nout )
237 infot = 0
238*
239 DO 140 in = 1, nn
240*
241* Do for each value of N in NVAL
242*
243 n = nval( in )
244 lda = max( 1, n )
245 xtype = 'N'
246 nimat = ntype1
247 nimat2 = ntypes
248 IF( n.LE.0 ) THEN
249 nimat = 1
250 nimat2 = ntype1 + 1
251 END IF
252*
253 nk = min( n+1, 4 )
254 DO 130 ik = 1, nk
255*
256* Do for KD = 0, N, (3N-1)/4, and (N+1)/4. This order makes
257* it easier to skip redundant values for small values of N.
258*
259 IF( ik.EQ.1 ) THEN
260 kd = 0
261 ELSE IF( ik.EQ.2 ) THEN
262 kd = max( n, 0 )
263 ELSE IF( ik.EQ.3 ) THEN
264 kd = ( 3*n-1 ) / 4
265 ELSE IF( ik.EQ.4 ) THEN
266 kd = ( n+1 ) / 4
267 END IF
268 ldab = kd + 1
269*
270 DO 90 imat = 1, nimat
271*
272* Do the tests only if DOTYPE( IMAT ) is true.
273*
274 IF( .NOT.dotype( imat ) )
275 $ GO TO 90
276*
277 DO 80 iuplo = 1, 2
278*
279* Do first for UPLO = 'U', then for UPLO = 'L'
280*
281 uplo = uplos( iuplo )
282*
283* Call ZLATTB to generate a triangular test matrix.
284*
285 srnamt = 'ZLATTB'
286 CALL zlattb( imat, uplo, 'No transpose', diag, iseed,
287 $ n, kd, ab, ldab, x, work, rwork, info )
288*
289* Set IDIAG = 1 for non-unit matrices, 2 for unit.
290*
291 IF( lsame( diag, 'N' ) ) THEN
292 idiag = 1
293 ELSE
294 idiag = 2
295 END IF
296*
297* Form the inverse of A so we can get a good estimate
298* of RCONDC = 1/(norm(A) * norm(inv(A))).
299*
300 CALL zlaset( 'Full', n, n, dcmplx( zero ),
301 $ dcmplx( one ), ainv, lda )
302 IF( lsame( uplo, 'U' ) ) THEN
303 DO 20 j = 1, n
304 CALL ztbsv( uplo, 'No transpose', diag, j, kd,
305 $ ab, ldab, ainv( ( j-1 )*lda+1 ), 1 )
306 20 CONTINUE
307 ELSE
308 DO 30 j = 1, n
309 CALL ztbsv( uplo, 'No transpose', diag, n-j+1,
310 $ kd, ab( ( j-1 )*ldab+1 ), ldab,
311 $ ainv( ( j-1 )*lda+j ), 1 )
312 30 CONTINUE
313 END IF
314*
315* Compute the 1-norm condition number of A.
316*
317 anorm = zlantb( '1', uplo, diag, n, kd, ab, ldab,
318 $ rwork )
319 ainvnm = zlantr( '1', uplo, diag, n, n, ainv, lda,
320 $ rwork )
321 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
322 rcondo = one
323 ELSE
324 rcondo = ( one / anorm ) / ainvnm
325 END IF
326*
327* Compute the infinity-norm condition number of A.
328*
329 anorm = zlantb( 'I', uplo, diag, n, kd, ab, ldab,
330 $ rwork )
331 ainvnm = zlantr( 'I', uplo, diag, n, n, ainv, lda,
332 $ rwork )
333 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
334 rcondi = one
335 ELSE
336 rcondi = ( one / anorm ) / ainvnm
337 END IF
338*
339 DO 60 irhs = 1, nns
340 nrhs = nsval( irhs )
341 xtype = 'N'
342*
343 DO 50 itran = 1, ntran
344*
345* Do for op(A) = A, A**T, or A**H.
346*
347 trans = transs( itran )
348 IF( itran.EQ.1 ) THEN
349 norm = 'O'
350 rcondc = rcondo
351 ELSE
352 norm = 'I'
353 rcondc = rcondi
354 END IF
355*
356*+ TEST 1
357* Solve and compute residual for op(A)*x = b.
358*
359 srnamt = 'ZLARHS'
360 CALL zlarhs( path, xtype, uplo, trans, n, n, kd,
361 $ idiag, nrhs, ab, ldab, xact, lda,
362 $ b, lda, iseed, info )
363 xtype = 'C'
364 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
365*
366 srnamt = 'ZTBTRS'
367 CALL ztbtrs( uplo, trans, diag, n, kd, nrhs, ab,
368 $ ldab, x, lda, info )
369*
370* Check error code from ZTBTRS.
371*
372 IF( info.NE.0 )
373 $ CALL alaerh( path, 'ZTBTRS', info, 0,
374 $ uplo // trans // diag, n, n, kd,
375 $ kd, nrhs, imat, nfail, nerrs,
376 $ nout )
377*
378 CALL ztbt02( uplo, trans, diag, n, kd, nrhs, ab,
379 $ ldab, x, lda, b, lda, work, rwork,
380 $ result( 1 ) )
381*
382*+ TEST 2
383* Check solution from generated exact solution.
384*
385 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
386 $ result( 2 ) )
387*
388*+ TESTS 3, 4, and 5
389* Use iterative refinement to improve the solution
390* and compute error bounds.
391*
392 srnamt = 'ZTBRFS'
393 CALL ztbrfs( uplo, trans, diag, n, kd, nrhs, ab,
394 $ ldab, b, lda, x, lda, rwork,
395 $ rwork( nrhs+1 ), work,
396 $ rwork( 2*nrhs+1 ), info )
397*
398* Check error code from ZTBRFS.
399*
400 IF( info.NE.0 )
401 $ CALL alaerh( path, 'ZTBRFS', info, 0,
402 $ uplo // trans // diag, n, n, kd,
403 $ kd, nrhs, imat, nfail, nerrs,
404 $ nout )
405*
406 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
407 $ result( 3 ) )
408 CALL ztbt05( uplo, trans, diag, n, kd, nrhs, ab,
409 $ ldab, b, lda, x, lda, xact, lda,
410 $ rwork, rwork( nrhs+1 ),
411 $ result( 4 ) )
412*
413* Print information about the tests that did not
414* pass the threshold.
415*
416 DO 40 k = 1, 5
417 IF( result( k ).GE.thresh ) THEN
418 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
419 $ CALL alahd( nout, path )
420 WRITE( nout, fmt = 9999 )uplo, trans,
421 $ diag, n, kd, nrhs, imat, k, result( k )
422 nfail = nfail + 1
423 END IF
424 40 CONTINUE
425 nrun = nrun + 5
426 50 CONTINUE
427 60 CONTINUE
428*
429*+ TEST 6
430* Get an estimate of RCOND = 1/CNDNUM.
431*
432 DO 70 itran = 1, 2
433 IF( itran.EQ.1 ) THEN
434 norm = 'O'
435 rcondc = rcondo
436 ELSE
437 norm = 'I'
438 rcondc = rcondi
439 END IF
440 srnamt = 'ZTBCON'
441 CALL ztbcon( norm, uplo, diag, n, kd, ab, ldab,
442 $ rcond, work, rwork, info )
443*
444* Check error code from ZTBCON.
445*
446 IF( info.NE.0 )
447 $ CALL alaerh( path, 'ZTBCON', info, 0,
448 $ norm // uplo // diag, n, n, kd, kd,
449 $ -1, imat, nfail, nerrs, nout )
450*
451 CALL ztbt06( rcond, rcondc, uplo, diag, n, kd, ab,
452 $ ldab, rwork, result( 6 ) )
453*
454* Print the test ratio if it is .GE. THRESH.
455*
456 IF( result( 6 ).GE.thresh ) THEN
457 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
458 $ CALL alahd( nout, path )
459 WRITE( nout, fmt = 9998 ) 'ZTBCON', norm, uplo,
460 $ diag, n, kd, imat, 6, result( 6 )
461 nfail = nfail + 1
462 END IF
463 nrun = nrun + 1
464 70 CONTINUE
465 80 CONTINUE
466 90 CONTINUE
467*
468* Use pathological test matrices to test ZLATBS.
469*
470 DO 120 imat = ntype1 + 1, nimat2
471*
472* Do the tests only if DOTYPE( IMAT ) is true.
473*
474 IF( .NOT.dotype( imat ) )
475 $ GO TO 120
476*
477 DO 110 iuplo = 1, 2
478*
479* Do first for UPLO = 'U', then for UPLO = 'L'
480*
481 uplo = uplos( iuplo )
482 DO 100 itran = 1, ntran
483*
484* Do for op(A) = A, A**T, and A**H.
485*
486 trans = transs( itran )
487*
488* Call ZLATTB to generate a triangular test matrix.
489*
490 srnamt = 'ZLATTB'
491 CALL zlattb( imat, uplo, trans, diag, iseed, n, kd,
492 $ ab, ldab, x, work, rwork, info )
493*
494*+ TEST 7
495* Solve the system op(A)*x = b
496*
497 srnamt = 'ZLATBS'
498 CALL zcopy( n, x, 1, b, 1 )
499 CALL zlatbs( uplo, trans, diag, 'N', n, kd, ab,
500 $ ldab, b, scale, rwork, info )
501*
502* Check error code from ZLATBS.
503*
504 IF( info.NE.0 )
505 $ CALL alaerh( path, 'ZLATBS', info, 0,
506 $ uplo // trans // diag // 'N', n, n,
507 $ kd, kd, -1, imat, nfail, nerrs,
508 $ nout )
509*
510 CALL ztbt03( uplo, trans, diag, n, kd, 1, ab, ldab,
511 $ scale, rwork, one, b, lda, x, lda,
512 $ work, result( 7 ) )
513*
514*+ TEST 8
515* Solve op(A)*x = b again with NORMIN = 'Y'.
516*
517 CALL zcopy( n, x, 1, b, 1 )
518 CALL zlatbs( uplo, trans, diag, 'Y', n, kd, ab,
519 $ ldab, b, scale, rwork, info )
520*
521* Check error code from ZLATBS.
522*
523 IF( info.NE.0 )
524 $ CALL alaerh( path, 'ZLATBS', info, 0,
525 $ uplo // trans // diag // 'Y', n, n,
526 $ kd, kd, -1, imat, nfail, nerrs,
527 $ nout )
528*
529 CALL ztbt03( uplo, trans, diag, n, kd, 1, ab, ldab,
530 $ scale, rwork, one, b, lda, x, lda,
531 $ work, result( 8 ) )
532*
533* Print information about the tests that did not pass
534* the threshold.
535*
536 IF( result( 7 ).GE.thresh ) THEN
537 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
538 $ CALL alahd( nout, path )
539 WRITE( nout, fmt = 9997 )'ZLATBS', uplo, trans,
540 $ diag, 'N', n, kd, imat, 7, result( 7 )
541 nfail = nfail + 1
542 END IF
543 IF( result( 8 ).GE.thresh ) THEN
544 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
545 $ CALL alahd( nout, path )
546 WRITE( nout, fmt = 9997 )'ZLATBS', uplo, trans,
547 $ diag, 'Y', n, kd, imat, 8, result( 8 )
548 nfail = nfail + 1
549 END IF
550 nrun = nrun + 2
551 100 CONTINUE
552 110 CONTINUE
553 120 CONTINUE
554 130 CONTINUE
555 140 CONTINUE
556*
557* Print a summary of the results.
558*
559 CALL alasum( path, nout, nfail, nrun, nerrs )
560*
561 9999 FORMAT( ' UPLO=''', a1, ''', TRANS=''', a1, ''',
562 $ DIAG=''', a1, ''', N=', i5, ', KD=', i5, ', NRHS=', i5,
563 $ ', type ', i2, ', test(', i2, ')=', g12.5 )
564 9998 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ''', a1, ''',',
565 $ i5, ',', i5, ', ... ), type ', i2, ', test(', i2, ')=',
566 $ g12.5 )
567 9997 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ''', a1, ''', ''',
568 $ a1, ''',', i5, ',', i5, ', ... ), type ', i2, ', test(',
569 $ i1, ')=', g12.5 )
570 RETURN
571*
572* End of ZCHKTB
573*
zlantr
double precision function zlantr(norm, uplo, diag, m, n, a, lda, work)
ZLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlantr.f:142
zlantb
double precision function zlantb(norm, uplo, diag, n, k, ab, ldab, work)
ZLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlantb.f:141
zlatbs
subroutine zlatbs(uplo, trans, diag, normin, n, kd, ab, ldab, x, scale, cnorm, info)
ZLATBS solves a triangular banded system of equations.
Definition zlatbs.f:243
ztbcon
subroutine ztbcon(norm, uplo, diag, n, kd, ab, ldab, rcond, work, rwork, info)
ZTBCON
Definition ztbcon.f:143
ztbtrs
subroutine ztbtrs(uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, info)
ZTBTRS
Definition ztbtrs.f:146
ztbrfs
subroutine ztbrfs(uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, ferr, berr, work, rwork, info)
ZTBRFS
Definition ztbrfs.f:188
ztbsv
subroutine ztbsv(uplo, trans, diag, n, k, a, lda, x, incx)
ZTBSV
Definition ztbsv.f:189
ztbt05
subroutine ztbt05(uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
ZTBT05
Definition ztbt05.f:189
zlattb
subroutine zlattb(imat, uplo, trans, diag, iseed, n, kd, ab, ldab, b, work, rwork, info)
ZLATTB
Definition zlattb.f:141
ztbt03
subroutine ztbt03(uplo, trans, diag, n, kd, nrhs, ab, ldab, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
ZTBT03
Definition ztbt03.f:177
zerrtr
subroutine zerrtr(path, nunit)
ZERRTR
Definition zerrtr.f:54
ztbt02
subroutine ztbt02(uplo, trans, diag, n, kd, nrhs, ab, ldab, x, ldx, b, ldb, work, rwork, resid)
ZTBT02
Definition ztbt02.f:159
ztbt06
subroutine ztbt06(rcond, rcondc, uplo, diag, n, kd, ab, ldab, rwork, rat)
ZTBT06
Definition ztbt06.f:126

◆ zchktp()

subroutine zchktp ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) ap,
complex*16, dimension( * ) ainvp,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nout )

ZCHKTP

Purpose:
!>
!> ZCHKTP tests ZTPTRI, -TRS, -RFS, and -CON, and ZLATPS
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The leading dimension of the work arrays.  NMAX >= the
!>          maximumm value of N in NVAL.
!>
[out]AP
!>          AP is COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2)
!>
[out]AINVP
!>          AINVP is COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (max(NMAX,2*NSMAX))
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 148 of file zchktp.f.

151*
152* -- LAPACK test routine --
153* -- LAPACK is a software package provided by Univ. of Tennessee, --
154* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
155*
156* .. Scalar Arguments ..
157 LOGICAL TSTERR
158 INTEGER NMAX, NN, NNS, NOUT
159 DOUBLE PRECISION THRESH
160* ..
161* .. Array Arguments ..
162 LOGICAL DOTYPE( * )
163 INTEGER NSVAL( * ), NVAL( * )
164 DOUBLE PRECISION RWORK( * )
165 COMPLEX*16 AINVP( * ), AP( * ), B( * ), WORK( * ), X( * ),
166 $ XACT( * )
167* ..
168*
169* =====================================================================
170*
171* .. Parameters ..
172 INTEGER NTYPE1, NTYPES
173 parameter( ntype1 = 10, ntypes = 18 )
174 INTEGER NTESTS
175 parameter( ntests = 9 )
176 INTEGER NTRAN
177 parameter( ntran = 3 )
178 DOUBLE PRECISION ONE, ZERO
179 parameter( one = 1.0d+0, zero = 0.0d+0 )
180* ..
181* .. Local Scalars ..
182 CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE
183 CHARACTER*3 PATH
184 INTEGER I, IDIAG, IMAT, IN, INFO, IRHS, ITRAN, IUPLO,
185 $ K, LAP, LDA, N, NERRS, NFAIL, NRHS, NRUN
186 DOUBLE PRECISION AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
187 $ SCALE
188* ..
189* .. Local Arrays ..
190 CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
191 INTEGER ISEED( 4 ), ISEEDY( 4 )
192 DOUBLE PRECISION RESULT( NTESTS )
193* ..
194* .. External Functions ..
195 LOGICAL LSAME
196 DOUBLE PRECISION ZLANTP
197 EXTERNAL lsame, zlantp
198* ..
199* .. External Subroutines ..
200 EXTERNAL alaerh, alahd, alasum, zcopy, zerrtr, zget04,
201 $ zlacpy, zlarhs, zlatps, zlattp, ztpcon, ztprfs,
202 $ ztpt01, ztpt02, ztpt03, ztpt05, ztpt06, ztptri,
203 $ ztptrs
204* ..
205* .. Scalars in Common ..
206 LOGICAL LERR, OK
207 CHARACTER*32 SRNAMT
208 INTEGER INFOT, IOUNIT
209* ..
210* .. Common blocks ..
211 COMMON / infoc / infot, iounit, ok, lerr
212 COMMON / srnamc / srnamt
213* ..
214* .. Intrinsic Functions ..
215 INTRINSIC max
216* ..
217* .. Data statements ..
218 DATA iseedy / 1988, 1989, 1990, 1991 /
219 DATA uplos / 'U', 'L' / , transs / 'N', 'T', 'C' /
220* ..
221* .. Executable Statements ..
222*
223* Initialize constants and the random number seed.
224*
225 path( 1: 1 ) = 'Zomplex precision'
226 path( 2: 3 ) = 'TP'
227 nrun = 0
228 nfail = 0
229 nerrs = 0
230 DO 10 i = 1, 4
231 iseed( i ) = iseedy( i )
232 10 CONTINUE
233*
234* Test the error exits
235*
236 IF( tsterr )
237 $ CALL zerrtr( path, nout )
238 infot = 0
239*
240 DO 110 in = 1, nn
241*
242* Do for each value of N in NVAL
243*
244 n = nval( in )
245 lda = max( 1, n )
246 lap = lda*( lda+1 ) / 2
247 xtype = 'N'
248*
249 DO 70 imat = 1, ntype1
250*
251* Do the tests only if DOTYPE( IMAT ) is true.
252*
253 IF( .NOT.dotype( imat ) )
254 $ GO TO 70
255*
256 DO 60 iuplo = 1, 2
257*
258* Do first for UPLO = 'U', then for UPLO = 'L'
259*
260 uplo = uplos( iuplo )
261*
262* Call ZLATTP to generate a triangular test matrix.
263*
264 srnamt = 'ZLATTP'
265 CALL zlattp( imat, uplo, 'No transpose', diag, iseed, n,
266 $ ap, x, work, rwork, info )
267*
268* Set IDIAG = 1 for non-unit matrices, 2 for unit.
269*
270 IF( lsame( diag, 'N' ) ) THEN
271 idiag = 1
272 ELSE
273 idiag = 2
274 END IF
275*
276*+ TEST 1
277* Form the inverse of A.
278*
279 IF( n.GT.0 )
280 $ CALL zcopy( lap, ap, 1, ainvp, 1 )
281 srnamt = 'ZTPTRI'
282 CALL ztptri( uplo, diag, n, ainvp, info )
283*
284* Check error code from ZTPTRI.
285*
286 IF( info.NE.0 )
287 $ CALL alaerh( path, 'ZTPTRI', info, 0, uplo // diag, n,
288 $ n, -1, -1, -1, imat, nfail, nerrs, nout )
289*
290* Compute the infinity-norm condition number of A.
291*
292 anorm = zlantp( 'I', uplo, diag, n, ap, rwork )
293 ainvnm = zlantp( 'I', uplo, diag, n, ainvp, rwork )
294 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
295 rcondi = one
296 ELSE
297 rcondi = ( one / anorm ) / ainvnm
298 END IF
299*
300* Compute the residual for the triangular matrix times its
301* inverse. Also compute the 1-norm condition number of A.
302*
303 CALL ztpt01( uplo, diag, n, ap, ainvp, rcondo, rwork,
304 $ result( 1 ) )
305*
306* Print the test ratio if it is .GE. THRESH.
307*
308 IF( result( 1 ).GE.thresh ) THEN
309 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
310 $ CALL alahd( nout, path )
311 WRITE( nout, fmt = 9999 )uplo, diag, n, imat, 1,
312 $ result( 1 )
313 nfail = nfail + 1
314 END IF
315 nrun = nrun + 1
316*
317 DO 40 irhs = 1, nns
318 nrhs = nsval( irhs )
319 xtype = 'N'
320*
321 DO 30 itran = 1, ntran
322*
323* Do for op(A) = A, A**T, or A**H.
324*
325 trans = transs( itran )
326 IF( itran.EQ.1 ) THEN
327 norm = 'O'
328 rcondc = rcondo
329 ELSE
330 norm = 'I'
331 rcondc = rcondi
332 END IF
333*
334*+ TEST 2
335* Solve and compute residual for op(A)*x = b.
336*
337 srnamt = 'ZLARHS'
338 CALL zlarhs( path, xtype, uplo, trans, n, n, 0,
339 $ idiag, nrhs, ap, lap, xact, lda, b,
340 $ lda, iseed, info )
341 xtype = 'C'
342 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
343*
344 srnamt = 'ZTPTRS'
345 CALL ztptrs( uplo, trans, diag, n, nrhs, ap, x,
346 $ lda, info )
347*
348* Check error code from ZTPTRS.
349*
350 IF( info.NE.0 )
351 $ CALL alaerh( path, 'ZTPTRS', info, 0,
352 $ uplo // trans // diag, n, n, -1,
353 $ -1, -1, imat, nfail, nerrs, nout )
354*
355 CALL ztpt02( uplo, trans, diag, n, nrhs, ap, x,
356 $ lda, b, lda, work, rwork,
357 $ result( 2 ) )
358*
359*+ TEST 3
360* Check solution from generated exact solution.
361*
362 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
363 $ result( 3 ) )
364*
365*+ TESTS 4, 5, and 6
366* Use iterative refinement to improve the solution and
367* compute error bounds.
368*
369 srnamt = 'ZTPRFS'
370 CALL ztprfs( uplo, trans, diag, n, nrhs, ap, b,
371 $ lda, x, lda, rwork, rwork( nrhs+1 ),
372 $ work, rwork( 2*nrhs+1 ), info )
373*
374* Check error code from ZTPRFS.
375*
376 IF( info.NE.0 )
377 $ CALL alaerh( path, 'ZTPRFS', info, 0,
378 $ uplo // trans // diag, n, n, -1,
379 $ -1, nrhs, imat, nfail, nerrs,
380 $ nout )
381*
382 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
383 $ result( 4 ) )
384 CALL ztpt05( uplo, trans, diag, n, nrhs, ap, b,
385 $ lda, x, lda, xact, lda, rwork,
386 $ rwork( nrhs+1 ), result( 5 ) )
387*
388* Print information about the tests that did not pass
389* the threshold.
390*
391 DO 20 k = 2, 6
392 IF( result( k ).GE.thresh ) THEN
393 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
394 $ CALL alahd( nout, path )
395 WRITE( nout, fmt = 9998 )uplo, trans, diag,
396 $ n, nrhs, imat, k, result( k )
397 nfail = nfail + 1
398 END IF
399 20 CONTINUE
400 nrun = nrun + 5
401 30 CONTINUE
402 40 CONTINUE
403*
404*+ TEST 7
405* Get an estimate of RCOND = 1/CNDNUM.
406*
407 DO 50 itran = 1, 2
408 IF( itran.EQ.1 ) THEN
409 norm = 'O'
410 rcondc = rcondo
411 ELSE
412 norm = 'I'
413 rcondc = rcondi
414 END IF
415 srnamt = 'ZTPCON'
416 CALL ztpcon( norm, uplo, diag, n, ap, rcond, work,
417 $ rwork, info )
418*
419* Check error code from ZTPCON.
420*
421 IF( info.NE.0 )
422 $ CALL alaerh( path, 'ZTPCON', info, 0,
423 $ norm // uplo // diag, n, n, -1, -1,
424 $ -1, imat, nfail, nerrs, nout )
425*
426 CALL ztpt06( rcond, rcondc, uplo, diag, n, ap, rwork,
427 $ result( 7 ) )
428*
429* Print the test ratio if it is .GE. THRESH.
430*
431 IF( result( 7 ).GE.thresh ) THEN
432 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
433 $ CALL alahd( nout, path )
434 WRITE( nout, fmt = 9997 ) 'ZTPCON', norm, uplo,
435 $ diag, n, imat, 7, result( 7 )
436 nfail = nfail + 1
437 END IF
438 nrun = nrun + 1
439 50 CONTINUE
440 60 CONTINUE
441 70 CONTINUE
442*
443* Use pathological test matrices to test ZLATPS.
444*
445 DO 100 imat = ntype1 + 1, ntypes
446*
447* Do the tests only if DOTYPE( IMAT ) is true.
448*
449 IF( .NOT.dotype( imat ) )
450 $ GO TO 100
451*
452 DO 90 iuplo = 1, 2
453*
454* Do first for UPLO = 'U', then for UPLO = 'L'
455*
456 uplo = uplos( iuplo )
457 DO 80 itran = 1, ntran
458*
459* Do for op(A) = A, A**T, or A**H.
460*
461 trans = transs( itran )
462*
463* Call ZLATTP to generate a triangular test matrix.
464*
465 srnamt = 'ZLATTP'
466 CALL zlattp( imat, uplo, trans, diag, iseed, n, ap, x,
467 $ work, rwork, info )
468*
469*+ TEST 8
470* Solve the system op(A)*x = b.
471*
472 srnamt = 'ZLATPS'
473 CALL zcopy( n, x, 1, b, 1 )
474 CALL zlatps( uplo, trans, diag, 'N', n, ap, b, scale,
475 $ rwork, info )
476*
477* Check error code from ZLATPS.
478*
479 IF( info.NE.0 )
480 $ CALL alaerh( path, 'ZLATPS', info, 0,
481 $ uplo // trans // diag // 'N', n, n,
482 $ -1, -1, -1, imat, nfail, nerrs, nout )
483*
484 CALL ztpt03( uplo, trans, diag, n, 1, ap, scale,
485 $ rwork, one, b, lda, x, lda, work,
486 $ result( 8 ) )
487*
488*+ TEST 9
489* Solve op(A)*x = b again with NORMIN = 'Y'.
490*
491 CALL zcopy( n, x, 1, b( n+1 ), 1 )
492 CALL zlatps( uplo, trans, diag, 'Y', n, ap, b( n+1 ),
493 $ scale, rwork, info )
494*
495* Check error code from ZLATPS.
496*
497 IF( info.NE.0 )
498 $ CALL alaerh( path, 'ZLATPS', info, 0,
499 $ uplo // trans // diag // 'Y', n, n,
500 $ -1, -1, -1, imat, nfail, nerrs, nout )
501*
502 CALL ztpt03( uplo, trans, diag, n, 1, ap, scale,
503 $ rwork, one, b( n+1 ), lda, x, lda, work,
504 $ result( 9 ) )
505*
506* Print information about the tests that did not pass
507* the threshold.
508*
509 IF( result( 8 ).GE.thresh ) THEN
510 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
511 $ CALL alahd( nout, path )
512 WRITE( nout, fmt = 9996 )'ZLATPS', uplo, trans,
513 $ diag, 'N', n, imat, 8, result( 8 )
514 nfail = nfail + 1
515 END IF
516 IF( result( 9 ).GE.thresh ) THEN
517 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
518 $ CALL alahd( nout, path )
519 WRITE( nout, fmt = 9996 )'ZLATPS', uplo, trans,
520 $ diag, 'Y', n, imat, 9, result( 9 )
521 nfail = nfail + 1
522 END IF
523 nrun = nrun + 2
524 80 CONTINUE
525 90 CONTINUE
526 100 CONTINUE
527 110 CONTINUE
528*
529* Print a summary of the results.
530*
531 CALL alasum( path, nout, nfail, nrun, nerrs )
532*
533 9999 FORMAT( ' UPLO=''', a1, ''', DIAG=''', a1, ''', N=', i5,
534 $ ', type ', i2, ', test(', i2, ')= ', g12.5 )
535 9998 FORMAT( ' UPLO=''', a1, ''', TRANS=''', a1, ''', DIAG=''', a1,
536 $ ''', N=', i5, ''', NRHS=', i5, ', type ', i2, ', test(',
537 $ i2, ')= ', g12.5 )
538 9997 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ''', a1, ''',',
539 $ i5, ', ... ), type ', i2, ', test(', i2, ')=', g12.5 )
540 9996 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ''', a1, ''', ''',
541 $ a1, ''',', i5, ', ... ), type ', i2, ', test(', i2, ')=',
542 $ g12.5 )
543 RETURN
544*
545* End of ZCHKTP
546*
zlantp
double precision function zlantp(norm, uplo, diag, n, ap, work)
ZLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlantp.f:125
zlatps
subroutine zlatps(uplo, trans, diag, normin, n, ap, x, scale, cnorm, info)
ZLATPS solves a triangular system of equations with the matrix held in packed storage.
Definition zlatps.f:231
ztprfs
subroutine ztprfs(uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, ferr, berr, work, rwork, info)
ZTPRFS
Definition ztprfs.f:174
ztptrs
subroutine ztptrs(uplo, trans, diag, n, nrhs, ap, b, ldb, info)
ZTPTRS
Definition ztptrs.f:130
ztptri
subroutine ztptri(uplo, diag, n, ap, info)
ZTPTRI
Definition ztptri.f:117
ztpcon
subroutine ztpcon(norm, uplo, diag, n, ap, rcond, work, rwork, info)
ZTPCON
Definition ztpcon.f:130
zlattp
subroutine zlattp(imat, uplo, trans, diag, iseed, n, ap, b, work, rwork, info)
ZLATTP
Definition zlattp.f:131
ztpt05
subroutine ztpt05(uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
ZTPT05
Definition ztpt05.f:175
ztpt06
subroutine ztpt06(rcond, rcondc, uplo, diag, n, ap, rwork, rat)
ZTPT06
Definition ztpt06.f:112
ztpt02
subroutine ztpt02(uplo, trans, diag, n, nrhs, ap, x, ldx, b, ldb, work, rwork, resid)
ZTPT02
Definition ztpt02.f:147
ztpt03
subroutine ztpt03(uplo, trans, diag, n, nrhs, ap, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
ZTPT03
Definition ztpt03.f:162
ztpt01
subroutine ztpt01(uplo, diag, n, ap, ainvp, rcond, rwork, resid)
ZTPT01
Definition ztpt01.f:109

◆ zchktr()

subroutine zchktr ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nout )

ZCHKTR

Purpose:
!>
!> ZCHKTR tests ZTRTRI, -TRS, -RFS, and -CON, and ZLATRS
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The leading dimension of the work arrays.
!>          NMAX >= the maximum value of N in NVAL.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (max(NMAX,2*NSMAX))
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 160 of file zchktr.f.

163*
164* -- LAPACK test routine --
165* -- LAPACK is a software package provided by Univ. of Tennessee, --
166* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
167*
168* .. Scalar Arguments ..
169 LOGICAL TSTERR
170 INTEGER NMAX, NN, NNB, NNS, NOUT
171 DOUBLE PRECISION THRESH
172* ..
173* .. Array Arguments ..
174 LOGICAL DOTYPE( * )
175 INTEGER NBVAL( * ), NSVAL( * ), NVAL( * )
176 DOUBLE PRECISION RWORK( * )
177 COMPLEX*16 A( * ), AINV( * ), B( * ), WORK( * ), X( * ),
178 $ XACT( * )
179* ..
180*
181* =====================================================================
182*
183* .. Parameters ..
184 INTEGER NTYPE1, NTYPES
185 parameter( ntype1 = 10, ntypes = 18 )
186 INTEGER NTESTS
187 parameter( ntests = 9 )
188 INTEGER NTRAN
189 parameter( ntran = 3 )
190 DOUBLE PRECISION ONE, ZERO
191 parameter( one = 1.0d0, zero = 0.0d0 )
192* ..
193* .. Local Scalars ..
194 CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE
195 CHARACTER*3 PATH
196 INTEGER I, IDIAG, IMAT, IN, INB, INFO, IRHS, ITRAN,
197 $ IUPLO, K, LDA, N, NB, NERRS, NFAIL, NRHS, NRUN
198 DOUBLE PRECISION AINVNM, ANORM, DUMMY, RCOND, RCONDC, RCONDI,
199 $ RCONDO, SCALE
200* ..
201* .. Local Arrays ..
202 CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
203 INTEGER ISEED( 4 ), ISEEDY( 4 )
204 DOUBLE PRECISION RESULT( NTESTS )
205* ..
206* .. External Functions ..
207 LOGICAL LSAME
208 DOUBLE PRECISION ZLANTR
209 EXTERNAL lsame, zlantr
210* ..
211* .. External Subroutines ..
212 EXTERNAL alaerh, alahd, alasum, xlaenv, zcopy, zerrtr,
213 $ zget04, zlacpy, zlarhs, zlatrs, zlattr, ztrcon,
214 $ ztrrfs, ztrt01, ztrt02, ztrt03, ztrt05, ztrt06,
215 $ ztrtri, ztrtrs
216* ..
217* .. Scalars in Common ..
218 LOGICAL LERR, OK
219 CHARACTER*32 SRNAMT
220 INTEGER INFOT, IOUNIT
221* ..
222* .. Common blocks ..
223 COMMON / infoc / infot, iounit, ok, lerr
224 COMMON / srnamc / srnamt
225* ..
226* .. Intrinsic Functions ..
227 INTRINSIC max
228* ..
229* .. Data statements ..
230 DATA iseedy / 1988, 1989, 1990, 1991 /
231 DATA uplos / 'U', 'L' / , transs / 'N', 'T', 'C' /
232* ..
233* .. Executable Statements ..
234*
235* Initialize constants and the random number seed.
236*
237 path( 1: 1 ) = 'Zomplex precision'
238 path( 2: 3 ) = 'TR'
239 nrun = 0
240 nfail = 0
241 nerrs = 0
242 DO 10 i = 1, 4
243 iseed( i ) = iseedy( i )
244 10 CONTINUE
245*
246* Test the error exits
247*
248 IF( tsterr )
249 $ CALL zerrtr( path, nout )
250 infot = 0
251*
252 DO 120 in = 1, nn
253*
254* Do for each value of N in NVAL
255*
256 n = nval( in )
257 lda = max( 1, n )
258 xtype = 'N'
259*
260 DO 80 imat = 1, ntype1
261*
262* Do the tests only if DOTYPE( IMAT ) is true.
263*
264 IF( .NOT.dotype( imat ) )
265 $ GO TO 80
266*
267 DO 70 iuplo = 1, 2
268*
269* Do first for UPLO = 'U', then for UPLO = 'L'
270*
271 uplo = uplos( iuplo )
272*
273* Call ZLATTR to generate a triangular test matrix.
274*
275 srnamt = 'ZLATTR'
276 CALL zlattr( imat, uplo, 'No transpose', diag, iseed, n,
277 $ a, lda, x, work, rwork, info )
278*
279* Set IDIAG = 1 for non-unit matrices, 2 for unit.
280*
281 IF( lsame( diag, 'N' ) ) THEN
282 idiag = 1
283 ELSE
284 idiag = 2
285 END IF
286*
287 DO 60 inb = 1, nnb
288*
289* Do for each blocksize in NBVAL
290*
291 nb = nbval( inb )
292 CALL xlaenv( 1, nb )
293*
294*+ TEST 1
295* Form the inverse of A.
296*
297 CALL zlacpy( uplo, n, n, a, lda, ainv, lda )
298 srnamt = 'ZTRTRI'
299 CALL ztrtri( uplo, diag, n, ainv, lda, info )
300*
301* Check error code from ZTRTRI.
302*
303 IF( info.NE.0 )
304 $ CALL alaerh( path, 'ZTRTRI', info, 0, uplo // diag,
305 $ n, n, -1, -1, nb, imat, nfail, nerrs,
306 $ nout )
307*
308* Compute the infinity-norm condition number of A.
309*
310 anorm = zlantr( 'I', uplo, diag, n, n, a, lda, rwork )
311 ainvnm = zlantr( 'I', uplo, diag, n, n, ainv, lda,
312 $ rwork )
313 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
314 rcondi = one
315 ELSE
316 rcondi = ( one / anorm ) / ainvnm
317 END IF
318*
319* Compute the residual for the triangular matrix times
320* its inverse. Also compute the 1-norm condition number
321* of A.
322*
323 CALL ztrt01( uplo, diag, n, a, lda, ainv, lda, rcondo,
324 $ rwork, result( 1 ) )
325* Print the test ratio if it is .GE. THRESH.
326*
327 IF( result( 1 ).GE.thresh ) THEN
328 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
329 $ CALL alahd( nout, path )
330 WRITE( nout, fmt = 9999 )uplo, diag, n, nb, imat,
331 $ 1, result( 1 )
332 nfail = nfail + 1
333 END IF
334 nrun = nrun + 1
335*
336* Skip remaining tests if not the first block size.
337*
338 IF( inb.NE.1 )
339 $ GO TO 60
340*
341 DO 40 irhs = 1, nns
342 nrhs = nsval( irhs )
343 xtype = 'N'
344*
345 DO 30 itran = 1, ntran
346*
347* Do for op(A) = A, A**T, or A**H.
348*
349 trans = transs( itran )
350 IF( itran.EQ.1 ) THEN
351 norm = 'O'
352 rcondc = rcondo
353 ELSE
354 norm = 'I'
355 rcondc = rcondi
356 END IF
357*
358*+ TEST 2
359* Solve and compute residual for op(A)*x = b.
360*
361 srnamt = 'ZLARHS'
362 CALL zlarhs( path, xtype, uplo, trans, n, n, 0,
363 $ idiag, nrhs, a, lda, xact, lda, b,
364 $ lda, iseed, info )
365 xtype = 'C'
366 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
367*
368 srnamt = 'ZTRTRS'
369 CALL ztrtrs( uplo, trans, diag, n, nrhs, a, lda,
370 $ x, lda, info )
371*
372* Check error code from ZTRTRS.
373*
374 IF( info.NE.0 )
375 $ CALL alaerh( path, 'ZTRTRS', info, 0,
376 $ uplo // trans // diag, n, n, -1,
377 $ -1, nrhs, imat, nfail, nerrs,
378 $ nout )
379*
380* This line is needed on a Sun SPARCstation.
381*
382 IF( n.GT.0 )
383 $ dummy = a( 1 )
384*
385 CALL ztrt02( uplo, trans, diag, n, nrhs, a, lda,
386 $ x, lda, b, lda, work, rwork,
387 $ result( 2 ) )
388*
389*+ TEST 3
390* Check solution from generated exact solution.
391*
392 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
393 $ result( 3 ) )
394*
395*+ TESTS 4, 5, and 6
396* Use iterative refinement to improve the solution
397* and compute error bounds.
398*
399 srnamt = 'ZTRRFS'
400 CALL ztrrfs( uplo, trans, diag, n, nrhs, a, lda,
401 $ b, lda, x, lda, rwork,
402 $ rwork( nrhs+1 ), work,
403 $ rwork( 2*nrhs+1 ), info )
404*
405* Check error code from ZTRRFS.
406*
407 IF( info.NE.0 )
408 $ CALL alaerh( path, 'ZTRRFS', info, 0,
409 $ uplo // trans // diag, n, n, -1,
410 $ -1, nrhs, imat, nfail, nerrs,
411 $ nout )
412*
413 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
414 $ result( 4 ) )
415 CALL ztrt05( uplo, trans, diag, n, nrhs, a, lda,
416 $ b, lda, x, lda, xact, lda, rwork,
417 $ rwork( nrhs+1 ), result( 5 ) )
418*
419* Print information about the tests that did not
420* pass the threshold.
421*
422 DO 20 k = 2, 6
423 IF( result( k ).GE.thresh ) THEN
424 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
425 $ CALL alahd( nout, path )
426 WRITE( nout, fmt = 9998 )uplo, trans,
427 $ diag, n, nrhs, imat, k, result( k )
428 nfail = nfail + 1
429 END IF
430 20 CONTINUE
431 nrun = nrun + 5
432 30 CONTINUE
433 40 CONTINUE
434*
435*+ TEST 7
436* Get an estimate of RCOND = 1/CNDNUM.
437*
438 DO 50 itran = 1, 2
439 IF( itran.EQ.1 ) THEN
440 norm = 'O'
441 rcondc = rcondo
442 ELSE
443 norm = 'I'
444 rcondc = rcondi
445 END IF
446 srnamt = 'ZTRCON'
447 CALL ztrcon( norm, uplo, diag, n, a, lda, rcond,
448 $ work, rwork, info )
449*
450* Check error code from ZTRCON.
451*
452 IF( info.NE.0 )
453 $ CALL alaerh( path, 'ZTRCON', info, 0,
454 $ norm // uplo // diag, n, n, -1, -1,
455 $ -1, imat, nfail, nerrs, nout )
456*
457 CALL ztrt06( rcond, rcondc, uplo, diag, n, a, lda,
458 $ rwork, result( 7 ) )
459*
460* Print the test ratio if it is .GE. THRESH.
461*
462 IF( result( 7 ).GE.thresh ) THEN
463 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
464 $ CALL alahd( nout, path )
465 WRITE( nout, fmt = 9997 )norm, uplo, n, imat,
466 $ 7, result( 7 )
467 nfail = nfail + 1
468 END IF
469 nrun = nrun + 1
470 50 CONTINUE
471 60 CONTINUE
472 70 CONTINUE
473 80 CONTINUE
474*
475* Use pathological test matrices to test ZLATRS.
476*
477 DO 110 imat = ntype1 + 1, ntypes
478*
479* Do the tests only if DOTYPE( IMAT ) is true.
480*
481 IF( .NOT.dotype( imat ) )
482 $ GO TO 110
483*
484 DO 100 iuplo = 1, 2
485*
486* Do first for UPLO = 'U', then for UPLO = 'L'
487*
488 uplo = uplos( iuplo )
489 DO 90 itran = 1, ntran
490*
491* Do for op(A) = A, A**T, and A**H.
492*
493 trans = transs( itran )
494*
495* Call ZLATTR to generate a triangular test matrix.
496*
497 srnamt = 'ZLATTR'
498 CALL zlattr( imat, uplo, trans, diag, iseed, n, a,
499 $ lda, x, work, rwork, info )
500*
501*+ TEST 8
502* Solve the system op(A)*x = b.
503*
504 srnamt = 'ZLATRS'
505 CALL zcopy( n, x, 1, b, 1 )
506 CALL zlatrs( uplo, trans, diag, 'N', n, a, lda, b,
507 $ scale, rwork, info )
508*
509* Check error code from ZLATRS.
510*
511 IF( info.NE.0 )
512 $ CALL alaerh( path, 'ZLATRS', info, 0,
513 $ uplo // trans // diag // 'N', n, n,
514 $ -1, -1, -1, imat, nfail, nerrs, nout )
515*
516 CALL ztrt03( uplo, trans, diag, n, 1, a, lda, scale,
517 $ rwork, one, b, lda, x, lda, work,
518 $ result( 8 ) )
519*
520*+ TEST 9
521* Solve op(A)*X = b again with NORMIN = 'Y'.
522*
523 CALL zcopy( n, x, 1, b( n+1 ), 1 )
524 CALL zlatrs( uplo, trans, diag, 'Y', n, a, lda,
525 $ b( n+1 ), scale, rwork, info )
526*
527* Check error code from ZLATRS.
528*
529 IF( info.NE.0 )
530 $ CALL alaerh( path, 'ZLATRS', info, 0,
531 $ uplo // trans // diag // 'Y', n, n,
532 $ -1, -1, -1, imat, nfail, nerrs, nout )
533*
534 CALL ztrt03( uplo, trans, diag, n, 1, a, lda, scale,
535 $ rwork, one, b( n+1 ), lda, x, lda, work,
536 $ result( 9 ) )
537*
538* Print information about the tests that did not pass
539* the threshold.
540*
541 IF( result( 8 ).GE.thresh ) THEN
542 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
543 $ CALL alahd( nout, path )
544 WRITE( nout, fmt = 9996 )'ZLATRS', uplo, trans,
545 $ diag, 'N', n, imat, 8, result( 8 )
546 nfail = nfail + 1
547 END IF
548 IF( result( 9 ).GE.thresh ) THEN
549 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
550 $ CALL alahd( nout, path )
551 WRITE( nout, fmt = 9996 )'ZLATRS', uplo, trans,
552 $ diag, 'Y', n, imat, 9, result( 9 )
553 nfail = nfail + 1
554 END IF
555 nrun = nrun + 2
556 90 CONTINUE
557 100 CONTINUE
558 110 CONTINUE
559 120 CONTINUE
560*
561* Print a summary of the results.
562*
563 CALL alasum( path, nout, nfail, nrun, nerrs )
564*
565 9999 FORMAT( ' UPLO=''', a1, ''', DIAG=''', a1, ''', N=', i5, ', NB=',
566 $ i4, ', type ', i2, ', test(', i2, ')= ', g12.5 )
567 9998 FORMAT( ' UPLO=''', a1, ''', TRANS=''', a1, ''', DIAG=''', a1,
568 $ ''', N=', i5, ', NB=', i4, ', type ', i2, ',
569 $ test(', i2, ')= ', g12.5 )
570 9997 FORMAT( ' NORM=''', a1, ''', UPLO =''', a1, ''', N=', i5, ',',
571 $ 11x, ' type ', i2, ', test(', i2, ')=', g12.5 )
572 9996 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ''', a1, ''', ''',
573 $ a1, ''',', i5, ', ... ), type ', i2, ', test(', i2, ')=',
574 $ g12.5 )
575 RETURN
576*
577* End of ZCHKTR
578*
zlatrs
subroutine zlatrs(uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info)
ZLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
Definition zlatrs.f:239
ztrcon
subroutine ztrcon(norm, uplo, diag, n, a, lda, rcond, work, rwork, info)
ZTRCON
Definition ztrcon.f:137
ztrtri
subroutine ztrtri(uplo, diag, n, a, lda, info)
ZTRTRI
Definition ztrtri.f:109
ztrrfs
subroutine ztrrfs(uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, ferr, berr, work, rwork, info)
ZTRRFS
Definition ztrrfs.f:182
ztrtrs
subroutine ztrtrs(uplo, trans, diag, n, nrhs, a, lda, b, ldb, info)
ZTRTRS
Definition ztrtrs.f:140
ztrt06
subroutine ztrt06(rcond, rcondc, uplo, diag, n, a, lda, rwork, rat)
ZTRT06
Definition ztrt06.f:122
ztrt02
subroutine ztrt02(uplo, trans, diag, n, nrhs, a, lda, x, ldx, b, ldb, work, rwork, resid)
ZTRT02
Definition ztrt02.f:155
ztrt03
subroutine ztrt03(uplo, trans, diag, n, nrhs, a, lda, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
ZTRT03
Definition ztrt03.f:171
zlattr
subroutine zlattr(imat, uplo, trans, diag, iseed, n, a, lda, b, work, rwork, info)
ZLATTR
Definition zlattr.f:138
ztrt05
subroutine ztrt05(uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
ZTRT05
Definition ztrt05.f:182
ztrt01
subroutine ztrt01(uplo, diag, n, a, lda, ainv, ldainv, rcond, rwork, resid)
ZTRT01
Definition ztrt01.f:125

◆ zchktz()

subroutine zchktz ( logical, dimension( * ) dotype,
integer nm,
integer, dimension( * ) mval,
integer nn,
integer, dimension( * ) nval,
double precision thresh,
logical tsterr,
complex*16, dimension( * ) a,
complex*16, dimension( * ) copya,
double precision, dimension( * ) s,
complex*16, dimension( * ) tau,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nout )

ZCHKTZ

Purpose:
!>
!> ZCHKTZ tests ZTZRZF.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (MMAX*NMAX)
!>          where MMAX is the maximum value of M in MVAL and NMAX is the
!>          maximum value of N in NVAL.
!>
[out]COPYA
!>          COPYA is COMPLEX*16 array, dimension (MMAX*NMAX)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension
!>                      (min(MMAX,NMAX))
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (MMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (MMAX*NMAX + 4*NMAX + MMAX)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (2*NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 135 of file zchktz.f.

137*
138* -- LAPACK test routine --
139* -- LAPACK is a software package provided by Univ. of Tennessee, --
140* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
141*
142* .. Scalar Arguments ..
143 LOGICAL TSTERR
144 INTEGER NM, NN, NOUT
145 DOUBLE PRECISION THRESH
146* ..
147* .. Array Arguments ..
148 LOGICAL DOTYPE( * )
149 INTEGER MVAL( * ), NVAL( * )
150 DOUBLE PRECISION S( * ), RWORK( * )
151 COMPLEX*16 A( * ), COPYA( * ), TAU( * ), WORK( * )
152* ..
153*
154* =====================================================================
155*
156* .. Parameters ..
157 INTEGER NTYPES
158 parameter( ntypes = 3 )
159 INTEGER NTESTS
160 parameter( ntests = 3 )
161 DOUBLE PRECISION ONE, ZERO
162 parameter( one = 1.0d0, zero = 0.0d0 )
163* ..
164* .. Local Scalars ..
165 CHARACTER*3 PATH
166 INTEGER I, IM, IMODE, IN, INFO, K, LDA, LWORK, M,
167 $ MNMIN, MODE, N, NERRS, NFAIL, NRUN
168 DOUBLE PRECISION EPS
169* ..
170* .. Local Arrays ..
171 INTEGER ISEED( 4 ), ISEEDY( 4 )
172 DOUBLE PRECISION RESULT( NTESTS )
173* ..
174* .. External Functions ..
175 DOUBLE PRECISION DLAMCH, ZQRT12, ZRZT01, ZRZT02
176 EXTERNAL dlamch, zqrt12, zrzt01, zrzt02
177* ..
178* .. External Subroutines ..
179 EXTERNAL alahd, alasum, dlaord, zerrtz, zgeqr2, zlacpy,
180 $ zlaset, zlatms, ztzrzf
181* ..
182* .. Intrinsic Functions ..
183 INTRINSIC dcmplx, max, min
184* ..
185* .. Scalars in Common ..
186 LOGICAL LERR, OK
187 CHARACTER*32 SRNAMT
188 INTEGER INFOT, IOUNIT
189* ..
190* .. Common blocks ..
191 COMMON / infoc / infot, iounit, ok, lerr
192 COMMON / srnamc / srnamt
193* ..
194* .. Data statements ..
195 DATA iseedy / 1988, 1989, 1990, 1991 /
196* ..
197* .. Executable Statements ..
198*
199* Initialize constants and the random number seed.
200*
201 path( 1: 1 ) = 'Zomplex precision'
202 path( 2: 3 ) = 'TZ'
203 nrun = 0
204 nfail = 0
205 nerrs = 0
206 DO 10 i = 1, 4
207 iseed( i ) = iseedy( i )
208 10 CONTINUE
209 eps = dlamch( 'Epsilon' )
210*
211* Test the error exits
212*
213 IF( tsterr )
214 $ CALL zerrtz( path, nout )
215 infot = 0
216*
217 DO 70 im = 1, nm
218*
219* Do for each value of M in MVAL.
220*
221 m = mval( im )
222 lda = max( 1, m )
223*
224 DO 60 in = 1, nn
225*
226* Do for each value of N in NVAL for which M .LE. N.
227*
228 n = nval( in )
229 mnmin = min( m, n )
230 lwork = max( 1, n*n+4*m+n )
231*
232 IF( m.LE.n ) THEN
233 DO 50 imode = 1, ntypes
234 IF( .NOT.dotype( imode ) )
235 $ GO TO 50
236*
237* Do for each type of singular value distribution.
238* 0: zero matrix
239* 1: one small singular value
240* 2: exponential distribution
241*
242 mode = imode - 1
243*
244* Test ZTZRQF
245*
246* Generate test matrix of size m by n using
247* singular value distribution indicated by `mode'.
248*
249 IF( mode.EQ.0 ) THEN
250 CALL zlaset( 'Full', m, n, dcmplx( zero ),
251 $ dcmplx( zero ), a, lda )
252 DO 30 i = 1, mnmin
253 s( i ) = zero
254 30 CONTINUE
255 ELSE
256 CALL zlatms( m, n, 'Uniform', iseed,
257 $ 'Nonsymmetric', s, imode,
258 $ one / eps, one, m, n, 'No packing', a,
259 $ lda, work, info )
260 CALL zgeqr2( m, n, a, lda, work, work( mnmin+1 ),
261 $ info )
262 CALL zlaset( 'Lower', m-1, n, dcmplx( zero ),
263 $ dcmplx( zero ), a( 2 ), lda )
264 CALL dlaord( 'Decreasing', mnmin, s, 1 )
265 END IF
266*
267* Save A and its singular values
268*
269 CALL zlacpy( 'All', m, n, a, lda, copya, lda )
270*
271* Call ZTZRZF to reduce the upper trapezoidal matrix to
272* upper triangular form.
273*
274 srnamt = 'ZTZRZF'
275 CALL ztzrzf( m, n, a, lda, tau, work, lwork, info )
276*
277* Compute norm(svd(a) - svd(r))
278*
279 result( 1 ) = zqrt12( m, m, a, lda, s, work,
280 $ lwork, rwork )
281*
282* Compute norm( A - R*Q )
283*
284 result( 2 ) = zrzt01( m, n, copya, a, lda, tau, work,
285 $ lwork )
286*
287* Compute norm(Q'*Q - I).
288*
289 result( 3 ) = zrzt02( m, n, a, lda, tau, work, lwork )
290*
291* Print information about the tests that did not pass
292* the threshold.
293*
294 DO 40 k = 1, ntests
295 IF( result( k ).GE.thresh ) THEN
296 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
297 $ CALL alahd( nout, path )
298 WRITE( nout, fmt = 9999 )m, n, imode, k,
299 $ result( k )
300 nfail = nfail + 1
301 END IF
302 40 CONTINUE
303 nrun = nrun + 3
304 50 CONTINUE
305 END IF
306 60 CONTINUE
307 70 CONTINUE
308*
309* Print a summary of the results.
310*
311 CALL alasum( path, nout, nfail, nrun, nerrs )
312*
313 9999 FORMAT( ' M =', i5, ', N =', i5, ', type ', i2, ', test ', i2,
314 $ ', ratio =', g12.5 )
315*
316* End if ZCHKTZ
317*
zgeqr2
subroutine zgeqr2(m, n, a, lda, tau, work, info)
ZGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
Definition zgeqr2.f:130
ztzrzf
subroutine ztzrzf(m, n, a, lda, tau, work, lwork, info)
ZTZRZF
Definition ztzrzf.f:151
zrzt01
double precision function zrzt01(m, n, a, af, lda, tau, work, lwork)
ZRZT01
Definition zrzt01.f:98
zrzt02
double precision function zrzt02(m, n, af, lda, tau, work, lwork)
ZRZT02
Definition zrzt02.f:91
zerrtz
subroutine zerrtz(path, nunit)
ZERRTZ
Definition zerrtz.f:54

◆ zchkunhr_col()

subroutine zchkunhr_col ( double precision thresh,
logical tsterr,
integer nm,
integer, dimension( * ) mval,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nout )

ZCHKUNHR_COL

Purpose:
!>
!> ZCHKUNHR_COL tests:
!>   1) ZUNGTSQR and ZUNHR_COL using ZLATSQR, ZGEMQRT,
!>   2) ZUNGTSQR_ROW and ZUNHR_COL inside ZGETSQRHRT
!>      (which calls ZLATSQR, ZUNGTSQR_ROW and ZUNHR_COL) using ZGEMQRT.
!> Therefore, ZLATSQR (part of ZGEQR), ZGEMQRT (part of ZGEMQR)
!> have to be tested before this test.
!>
!>
Parameters
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 106 of file zchkunhr_col.f.

108 IMPLICIT NONE
109*
110* -- LAPACK test routine --
111* -- LAPACK is a software package provided by Univ. of Tennessee, --
112* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
113*
114* .. Scalar Arguments ..
115 LOGICAL TSTERR
116 INTEGER NM, NN, NNB, NOUT
117 DOUBLE PRECISION THRESH
118* ..
119* .. Array Arguments ..
120 INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
121* ..
122*
123* =====================================================================
124*
125* .. Parameters ..
126 INTEGER NTESTS
127 parameter( ntests = 6 )
128* ..
129* .. Local Scalars ..
130 CHARACTER(LEN=3) PATH
131 INTEGER I, IMB1, INB1, INB2, J, T, M, N, MB1, NB1,
132 $ NB2, NFAIL, NERRS, NRUN
133*
134* .. Local Arrays ..
135 DOUBLE PRECISION RESULT( NTESTS )
136* ..
137* .. External Subroutines ..
138 EXTERNAL alahd, alasum, zerrunhr_col, zunhr_col01,
139 $ zunhr_col02
140* ..
141* .. Intrinsic Functions ..
142 INTRINSIC max, min
143* ..
144* .. Scalars in Common ..
145 LOGICAL LERR, OK
146 CHARACTER(LEN=32) SRNAMT
147 INTEGER INFOT, NUNIT
148* ..
149* .. Common blocks ..
150 COMMON / infoc / infot, nunit, ok, lerr
151 COMMON / srnamc / srnamt
152* ..
153* .. Executable Statements ..
154*
155* Initialize constants
156*
157 path( 1: 1 ) = 'Z'
158 path( 2: 3 ) = 'HH'
159 nrun = 0
160 nfail = 0
161 nerrs = 0
162*
163* Test the error exits
164*
165 IF( tsterr ) CALL zerrunhr_col( path, nout )
166 infot = 0
167*
168* Do for each value of M in MVAL.
169*
170 DO i = 1, nm
171 m = mval( i )
172*
173* Do for each value of N in NVAL.
174*
175 DO j = 1, nn
176 n = nval( j )
177*
178* Only for M >= N
179*
180 IF ( min( m, n ).GT.0 .AND. m.GE.n ) THEN
181*
182* Do for each possible value of MB1
183*
184 DO imb1 = 1, nnb
185 mb1 = nbval( imb1 )
186*
187* Only for MB1 > N
188*
189 IF ( mb1.GT.n ) THEN
190*
191* Do for each possible value of NB1
192*
193 DO inb1 = 1, nnb
194 nb1 = nbval( inb1 )
195*
196* Do for each possible value of NB2
197*
198 DO inb2 = 1, nnb
199 nb2 = nbval( inb2 )
200*
201 IF( nb1.GT.0 .AND. nb2.GT.0 ) THEN
202*
203* Test ZUNHR_COL
204*
205 CALL zunhr_col01( m, n, mb1, nb1,
206 $ nb2, result )
207*
208* Print information about the tests that did
209* not pass the threshold.
210*
211 DO t = 1, ntests
212 IF( result( t ).GE.thresh ) THEN
213 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
214 $ CALL alahd( nout, path )
215 WRITE( nout, fmt = 9999 ) m, n, mb1,
216 $ nb1, nb2, t, result( t )
217 nfail = nfail + 1
218 END IF
219 END DO
220 nrun = nrun + ntests
221 END IF
222 END DO
223 END DO
224 END IF
225 END DO
226 END IF
227 END DO
228 END DO
229*
230* Do for each value of M in MVAL.
231*
232 DO i = 1, nm
233 m = mval( i )
234*
235* Do for each value of N in NVAL.
236*
237 DO j = 1, nn
238 n = nval( j )
239*
240* Only for M >= N
241*
242 IF ( min( m, n ).GT.0 .AND. m.GE.n ) THEN
243*
244* Do for each possible value of MB1
245*
246 DO imb1 = 1, nnb
247 mb1 = nbval( imb1 )
248*
249* Only for MB1 > N
250*
251 IF ( mb1.GT.n ) THEN
252*
253* Do for each possible value of NB1
254*
255 DO inb1 = 1, nnb
256 nb1 = nbval( inb1 )
257*
258* Do for each possible value of NB2
259*
260 DO inb2 = 1, nnb
261 nb2 = nbval( inb2 )
262*
263 IF( nb1.GT.0 .AND. nb2.GT.0 ) THEN
264*
265* Test ZUNHR_COL
266*
267 CALL zunhr_col02( m, n, mb1, nb1,
268 $ nb2, result )
269*
270* Print information about the tests that did
271* not pass the threshold.
272*
273 DO t = 1, ntests
274 IF( result( t ).GE.thresh ) THEN
275 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
276 $ CALL alahd( nout, path )
277 WRITE( nout, fmt = 9998 ) m, n, mb1,
278 $ nb1, nb2, t, result( t )
279 nfail = nfail + 1
280 END IF
281 END DO
282 nrun = nrun + ntests
283 END IF
284 END DO
285 END DO
286 END IF
287 END DO
288 END IF
289 END DO
290 END DO
291*
292* Print a summary of the results.
293*
294 CALL alasum( path, nout, nfail, nrun, nerrs )
295*
296 9999 FORMAT( 'ZUNGTSQR and ZUNHR_COL: M=', i5, ', N=', i5,
297 $ ', MB1=', i5, ', NB1=', i5, ', NB2=', i5,
298 $ ' test(', i2, ')=', g12.5 )
299 9998 FORMAT( 'ZUNGTSQR_ROW and ZUNHR_COL: M=', i5, ', N=', i5,
300 $ ', MB1=', i5, ', NB1=', i5, ', NB2=', i5,
301 $ ' test(', i2, ')=', g12.5 )
302 RETURN
303*
304* End of ZCHKUNHR_COL
305*
zerrunhr_col
subroutine zerrunhr_col(path, nunit)
ZERRUNHR_COL
Definition zerrunhr_col.f:56
zunhr_col01
subroutine zunhr_col01(m, n, mb1, nb1, nb2, result)
ZUNHR_COL01
Definition zunhr_col01.f:119
zunhr_col02
subroutine zunhr_col02(m, n, mb1, nb1, nb2, result)
ZUNHR_COL02
Definition zunhr_col02.f:120

◆ zdrvab()

subroutine zdrvab ( logical, dimension( * ) dotype,
integer nm,
integer, dimension( * ) mval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
complex, dimension( * ) swork,
integer, dimension( * ) iwork,
integer nout )

ZDRVAB

Purpose:
!>
!> ZDRVAB tests ZCGESV
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for M or N, used in dimensioning
!>          the work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NSMAX*2))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      NMAX
!>
[out]SWORK
!>          SWORK is COMPLEX array, dimension
!>                      (NMAX*(NSMAX+NMAX))
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension
!>                      NMAX
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 149 of file zdrvab.f.

152*
153* -- LAPACK test routine --
154* -- LAPACK is a software package provided by Univ. of Tennessee, --
155* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
156*
157* .. Scalar Arguments ..
158 INTEGER NM, NMAX, NNS, NOUT
159 DOUBLE PRECISION THRESH
160* ..
161* .. Array Arguments ..
162 LOGICAL DOTYPE( * )
163 INTEGER MVAL( * ), NSVAL( * ), IWORK( * )
164 DOUBLE PRECISION RWORK( * )
165 COMPLEX SWORK( * )
166 COMPLEX*16 A( * ), AFAC( * ), B( * ),
167 $ WORK( * ), X( * )
168* ..
169*
170* =====================================================================
171*
172* .. Parameters ..
173 DOUBLE PRECISION ZERO
174 parameter( zero = 0.0d+0 )
175 INTEGER NTYPES
176 parameter( ntypes = 11 )
177 INTEGER NTESTS
178 parameter( ntests = 1 )
179* ..
180* .. Local Scalars ..
181 LOGICAL ZEROT
182 CHARACTER DIST, TRANS, TYPE, XTYPE
183 CHARACTER*3 PATH
184 INTEGER I, IM, IMAT, INFO, IOFF, IRHS,
185 $ IZERO, KL, KU, LDA, M, MODE, N,
186 $ NERRS, NFAIL, NIMAT, NRHS, NRUN
187 DOUBLE PRECISION ANORM, CNDNUM
188* ..
189* .. Local Arrays ..
190 INTEGER ISEED( 4 ), ISEEDY( 4 )
191 DOUBLE PRECISION RESULT( NTESTS )
192* ..
193* .. Local Variables ..
194 INTEGER ITER, KASE
195* ..
196* .. External Subroutines ..
197 EXTERNAL alaerh, alahd, zget08, zlacpy, zlarhs, zlaset,
198 $ zlatb4, zlatms
199* ..
200* .. Intrinsic Functions ..
201 INTRINSIC dcmplx, dble, max, min, sqrt
202* ..
203* .. Scalars in Common ..
204 LOGICAL LERR, OK
205 CHARACTER*32 SRNAMT
206 INTEGER INFOT, NUNIT
207* ..
208* .. Common blocks ..
209 COMMON / infoc / infot, nunit, ok, lerr
210 COMMON / srnamc / srnamt
211* ..
212* .. Data statements ..
213 DATA iseedy / 2006, 2007, 2008, 2009 /
214* ..
215* .. Executable Statements ..
216*
217* Initialize constants and the random number seed.
218*
219 kase = 0
220 path( 1: 1 ) = 'Zomplex precision'
221 path( 2: 3 ) = 'GE'
222 nrun = 0
223 nfail = 0
224 nerrs = 0
225 DO 10 i = 1, 4
226 iseed( i ) = iseedy( i )
227 10 CONTINUE
228*
229 infot = 0
230*
231* Do for each value of M in MVAL
232*
233 DO 120 im = 1, nm
234 m = mval( im )
235 lda = max( 1, m )
236*
237 n = m
238 nimat = ntypes
239 IF( m.LE.0 .OR. n.LE.0 )
240 $ nimat = 1
241*
242 DO 100 imat = 1, nimat
243*
244* Do the tests only if DOTYPE( IMAT ) is true.
245*
246 IF( .NOT.dotype( imat ) )
247 $ GO TO 100
248*
249* Skip types 5, 6, or 7 if the matrix size is too small.
250*
251 zerot = imat.GE.5 .AND. imat.LE.7
252 IF( zerot .AND. n.LT.imat-4 )
253 $ GO TO 100
254*
255* Set up parameters with ZLATB4 and generate a test matrix
256* with ZLATMS.
257*
258 CALL zlatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
259 $ CNDNUM, DIST )
260*
261 srnamt = 'ZLATMS'
262 CALL zlatms( m, n, dist, iseed, TYPE, RWORK, MODE,
263 $ CNDNUM, ANORM, KL, KU, 'No packing', A, LDA,
264 $ WORK, INFO )
265*
266* Check error code from ZLATMS.
267*
268 IF( info.NE.0 ) THEN
269 CALL alaerh( path, 'ZLATMS', info, 0, ' ', m, n, -1,
270 $ -1, -1, imat, nfail, nerrs, nout )
271 GO TO 100
272 END IF
273*
274* For types 5-7, zero one or more columns of the matrix to
275* test that INFO is returned correctly.
276*
277 IF( zerot ) THEN
278 IF( imat.EQ.5 ) THEN
279 izero = 1
280 ELSE IF( imat.EQ.6 ) THEN
281 izero = min( m, n )
282 ELSE
283 izero = min( m, n ) / 2 + 1
284 END IF
285 ioff = ( izero-1 )*lda
286 IF( imat.LT.7 ) THEN
287 DO 20 i = 1, m
288 a( ioff+i ) = zero
289 20 CONTINUE
290 ELSE
291 CALL zlaset( 'Full', m, n-izero+1, dcmplx(zero),
292 $ dcmplx(zero), a( ioff+1 ), lda )
293 END IF
294 ELSE
295 izero = 0
296 END IF
297*
298 DO 60 irhs = 1, nns
299 nrhs = nsval( irhs )
300 xtype = 'N'
301 trans = 'N'
302*
303 srnamt = 'ZLARHS'
304 CALL zlarhs( path, xtype, ' ', trans, n, n, kl,
305 $ ku, nrhs, a, lda, x, lda, b,
306 $ lda, iseed, info )
307*
308 srnamt = 'ZCGESV'
309*
310 kase = kase + 1
311*
312 CALL zlacpy( 'Full', m, n, a, lda, afac, lda )
313*
314 CALL zcgesv( n, nrhs, a, lda, iwork, b, lda, x, lda,
315 $ work, swork, rwork, iter, info)
316*
317 IF (iter.LT.0) THEN
318 CALL zlacpy( 'Full', m, n, afac, lda, a, lda )
319 ENDIF
320*
321* Check error code from ZCGESV. This should be the same as
322* the one of DGETRF.
323*
324 IF( info.NE.izero ) THEN
325*
326 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
327 $ CALL alahd( nout, path )
328 nerrs = nerrs + 1
329*
330 IF( info.NE.izero .AND. izero.NE.0 ) THEN
331 WRITE( nout, fmt = 9988 )'ZCGESV',info,
332 $ izero,m,imat
333 ELSE
334 WRITE( nout, fmt = 9975 )'ZCGESV',info,
335 $ m, imat
336 END IF
337 END IF
338*
339* Skip the remaining test if the matrix is singular.
340*
341 IF( info.NE.0 )
342 $ GO TO 100
343*
344* Check the quality of the solution
345*
346 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
347*
348 CALL zget08( trans, n, n, nrhs, a, lda, x, lda, work,
349 $ lda, rwork, result( 1 ) )
350*
351* Check if the test passes the tesing.
352* Print information about the tests that did not
353* pass the testing.
354*
355* If iterative refinement has been used and claimed to
356* be successful (ITER>0), we want
357* NORMI(B - A*X)/(NORMI(A)*NORMI(X)*EPS*SRQT(N)) < 1
358*
359* If double precision has been used (ITER<0), we want
360* NORMI(B - A*X)/(NORMI(A)*NORMI(X)*EPS) < THRES
361* (Cf. the linear solver testing routines)
362*
363 IF ((thresh.LE.0.0e+00)
364 $ .OR.((iter.GE.0).AND.(n.GT.0)
365 $ .AND.(result(1).GE.sqrt(dble(n))))
366 $ .OR.((iter.LT.0).AND.(result(1).GE.thresh))) THEN
367*
368 IF( nfail.EQ.0 .AND. nerrs.EQ.0 ) THEN
369 WRITE( nout, fmt = 8999 )'DGE'
370 WRITE( nout, fmt = '( '' Matrix types:'' )' )
371 WRITE( nout, fmt = 8979 )
372 WRITE( nout, fmt = '( '' Test ratios:'' )' )
373 WRITE( nout, fmt = 8960 )1
374 WRITE( nout, fmt = '( '' Messages:'' )' )
375 END IF
376*
377 WRITE( nout, fmt = 9998 )trans, n, nrhs,
378 $ imat, 1, result( 1 )
379 nfail = nfail + 1
380 END IF
381 nrun = nrun + 1
382 60 CONTINUE
383 100 CONTINUE
384 120 CONTINUE
385*
386* Print a summary of the results.
387*
388 IF( nfail.GT.0 ) THEN
389 WRITE( nout, fmt = 9996 )'ZCGESV', nfail, nrun
390 ELSE
391 WRITE( nout, fmt = 9995 )'ZCGESV', nrun
392 END IF
393 IF( nerrs.GT.0 ) THEN
394 WRITE( nout, fmt = 9994 )nerrs
395 END IF
396*
397 9998 FORMAT( ' TRANS=''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
398 $ i2, ', test(', i2, ') =', g12.5 )
399 9996 FORMAT( 1x, a6, ': ', i6, ' out of ', i6,
400 $ ' tests failed to pass the threshold' )
401 9995 FORMAT( /1x, 'All tests for ', a6,
402 $ ' routines passed the threshold ( ', i6, ' tests run)' )
403 9994 FORMAT( 6x, i6, ' error messages recorded' )
404*
405* SUBNAM, INFO, INFOE, M, IMAT
406*
407 9988 FORMAT( ' *** ', a6, ' returned with INFO =', i5, ' instead of ',
408 $ i5, / ' ==> M =', i5, ', type ',
409 $ i2 )
410*
411* SUBNAM, INFO, M, IMAT
412*
413 9975 FORMAT( ' *** Error code from ', a6, '=', i5, ' for M=', i5,
414 $ ', type ', i2 )
415 8999 FORMAT( / 1x, a3, ': General dense matrices' )
416 8979 FORMAT( 4x, '1. Diagonal', 24x, '7. Last n/2 columns zero', / 4x,
417 $ '2. Upper triangular', 16x,
418 $ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4x,
419 $ '3. Lower triangular', 16x, '9. Random, CNDNUM = 0.1/EPS',
420 $ / 4x, '4. Random, CNDNUM = 2', 13x,
421 $ '10. Scaled near underflow', / 4x, '5. First column zero',
422 $ 14x, '11. Scaled near overflow', / 4x,
423 $ '6. Last column zero' )
424 8960 FORMAT( 3x, i2, ': norm_1( B - A * X ) / ',
425 $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF',
426 $ / 4x, 'or norm_1( B - A * X ) / ',
427 $ '( norm_1(A) * norm_1(X) * EPS ) > THRES if DGETRF' )
428 RETURN
429*
430* End of ZDRVAB
431*
zcgesv
subroutine zcgesv(n, nrhs, a, lda, ipiv, b, ldb, x, ldx, work, swork, rwork, iter, info)
ZCGESV computes the solution to system of linear equations A * X = B for GE matrices (mixed precision...
Definition zcgesv.f:201
zget08
subroutine zget08(trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
ZGET08
Definition zget08.f:133

◆ zdrvac()

subroutine zdrvac ( logical, dimension( * ) dotype,
integer nm,
integer, dimension( * ) mval,
integer nns,
integer, dimension( * ) nsval,
double precision thresh,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
complex, dimension(*) swork,
integer nout )

ZDRVAC

Purpose:
!>
!> ZDRVAC tests ZCPOSV.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of N contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix dimension N.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (max(2*NMAX,2*NSMAX+NWORK))
!>
[out]SWORK
!>          SWORK is COMPLEX array, dimension
!>                      (NMAX*(NSMAX+NMAX))
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 142 of file zdrvac.f.

145*
146* -- LAPACK test routine --
147* -- LAPACK is a software package provided by Univ. of Tennessee, --
148* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
149*
150* .. Scalar Arguments ..
151 INTEGER NMAX, NM, NNS, NOUT
152 DOUBLE PRECISION THRESH
153* ..
154* .. Array Arguments ..
155 LOGICAL DOTYPE( * )
156 INTEGER MVAL( * ), NSVAL( * )
157 DOUBLE PRECISION RWORK( * )
158 COMPLEX SWORK(*)
159 COMPLEX*16 A( * ), AFAC( * ), B( * ),
160 $ WORK( * ), X( * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 DOUBLE PRECISION ZERO
167 parameter( zero = 0.0d+0 )
168 INTEGER NTYPES
169 parameter( ntypes = 9 )
170 INTEGER NTESTS
171 parameter( ntests = 1 )
172* ..
173* .. Local Scalars ..
174 LOGICAL ZEROT
175 CHARACTER DIST, TYPE, UPLO, XTYPE
176 CHARACTER*3 PATH
177 INTEGER I, IM, IMAT, INFO, IOFF, IRHS, IUPLO,
178 $ IZERO, KL, KU, LDA, MODE, N,
179 $ NERRS, NFAIL, NIMAT, NRHS, NRUN
180 DOUBLE PRECISION ANORM, CNDNUM
181* ..
182* .. Local Arrays ..
183 CHARACTER UPLOS( 2 )
184 INTEGER ISEED( 4 ), ISEEDY( 4 )
185 DOUBLE PRECISION RESULT( NTESTS )
186* ..
187* .. Local Variables ..
188 INTEGER ITER, KASE
189* ..
190* .. External Subroutines ..
191 EXTERNAL alaerh, zlacpy, zlaipd,
192 $ zlarhs, zlatb4, zlatms,
193 $ zpot06, zcposv
194* ..
195* .. Intrinsic Functions ..
196 INTRINSIC dble, max, sqrt
197* ..
198* .. Scalars in Common ..
199 LOGICAL LERR, OK
200 CHARACTER*32 SRNAMT
201 INTEGER INFOT, NUNIT
202* ..
203* .. Common blocks ..
204 COMMON / infoc / infot, nunit, ok, lerr
205 COMMON / srnamc / srnamt
206* ..
207* .. Data statements ..
208 DATA iseedy / 1988, 1989, 1990, 1991 /
209 DATA uplos / 'U', 'L' /
210* ..
211* .. Executable Statements ..
212*
213* Initialize constants and the random number seed.
214*
215 kase = 0
216 path( 1: 1 ) = 'Zomplex precision'
217 path( 2: 3 ) = 'PO'
218 nrun = 0
219 nfail = 0
220 nerrs = 0
221 DO 10 i = 1, 4
222 iseed( i ) = iseedy( i )
223 10 CONTINUE
224*
225 infot = 0
226*
227* Do for each value of N in MVAL
228*
229 DO 120 im = 1, nm
230 n = mval( im )
231 lda = max( n, 1 )
232 nimat = ntypes
233 IF( n.LE.0 )
234 $ nimat = 1
235*
236 DO 110 imat = 1, nimat
237*
238* Do the tests only if DOTYPE( IMAT ) is true.
239*
240 IF( .NOT.dotype( imat ) )
241 $ GO TO 110
242*
243* Skip types 3, 4, or 5 if the matrix size is too small.
244*
245 zerot = imat.GE.3 .AND. imat.LE.5
246 IF( zerot .AND. n.LT.imat-2 )
247 $ GO TO 110
248*
249* Do first for UPLO = 'U', then for UPLO = 'L'
250*
251 DO 100 iuplo = 1, 2
252 uplo = uplos( iuplo )
253*
254* Set up parameters with ZLATB4 and generate a test matrix
255* with ZLATMS.
256*
257 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
258 $ CNDNUM, DIST )
259*
260 srnamt = 'ZLATMS'
261 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
262 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
263 $ INFO )
264*
265* Check error code from ZLATMS.
266*
267 IF( info.NE.0 ) THEN
268 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n, -1,
269 $ -1, -1, imat, nfail, nerrs, nout )
270 GO TO 100
271 END IF
272*
273* For types 3-5, zero one row and column of the matrix to
274* test that INFO is returned correctly.
275*
276 IF( zerot ) THEN
277 IF( imat.EQ.3 ) THEN
278 izero = 1
279 ELSE IF( imat.EQ.4 ) THEN
280 izero = n
281 ELSE
282 izero = n / 2 + 1
283 END IF
284 ioff = ( izero-1 )*lda
285*
286* Set row and column IZERO of A to 0.
287*
288 IF( iuplo.EQ.1 ) THEN
289 DO 20 i = 1, izero - 1
290 a( ioff+i ) = zero
291 20 CONTINUE
292 ioff = ioff + izero
293 DO 30 i = izero, n
294 a( ioff ) = zero
295 ioff = ioff + lda
296 30 CONTINUE
297 ELSE
298 ioff = izero
299 DO 40 i = 1, izero - 1
300 a( ioff ) = zero
301 ioff = ioff + lda
302 40 CONTINUE
303 ioff = ioff - izero
304 DO 50 i = izero, n
305 a( ioff+i ) = zero
306 50 CONTINUE
307 END IF
308 ELSE
309 izero = 0
310 END IF
311*
312* Set the imaginary part of the diagonals.
313*
314 CALL zlaipd( n, a, lda+1, 0 )
315*
316 DO 60 irhs = 1, nns
317 nrhs = nsval( irhs )
318 xtype = 'N'
319*
320* Form an exact solution and set the right hand side.
321*
322 srnamt = 'ZLARHS'
323 CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
324 $ nrhs, a, lda, x, lda, b, lda,
325 $ iseed, info )
326*
327* Compute the L*L' or U'*U factorization of the
328* matrix and solve the system.
329*
330 srnamt = 'ZCPOSV '
331 kase = kase + 1
332*
333 CALL zlacpy( 'All', n, n, a, lda, afac, lda)
334*
335 CALL zcposv( uplo, n, nrhs, afac, lda, b, lda, x, lda,
336 $ work, swork, rwork, iter, info )
337*
338 IF (iter.LT.0) THEN
339 CALL zlacpy( 'All', n, n, a, lda, afac, lda )
340 ENDIF
341*
342* Check error code from ZCPOSV .
343*
344 IF( info.NE.izero ) THEN
345*
346 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
347 $ CALL alahd( nout, path )
348 nerrs = nerrs + 1
349*
350 IF( info.NE.izero .AND. izero.NE.0 ) THEN
351 WRITE( nout, fmt = 9988 )'ZCPOSV',info,izero,n,
352 $ imat
353 ELSE
354 WRITE( nout, fmt = 9975 )'ZCPOSV',info,n,imat
355 END IF
356 END IF
357*
358* Skip the remaining test if the matrix is singular.
359*
360 IF( info.NE.0 )
361 $ GO TO 110
362*
363* Check the quality of the solution
364*
365 CALL zlacpy( 'All', n, nrhs, b, lda, work, lda )
366*
367 CALL zpot06( uplo, n, nrhs, a, lda, x, lda, work,
368 $ lda, rwork, result( 1 ) )
369*
370* Check if the test passes the tesing.
371* Print information about the tests that did not
372* pass the testing.
373*
374* If iterative refinement has been used and claimed to
375* be successful (ITER>0), we want
376* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS*SRQT(N)) < 1
377*
378* If double precision has been used (ITER<0), we want
379* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS) < THRES
380* (Cf. the linear solver testing routines)
381*
382 IF ((thresh.LE.0.0e+00)
383 $ .OR.((iter.GE.0).AND.(n.GT.0)
384 $ .AND.(result(1).GE.sqrt(dble(n))))
385 $ .OR.((iter.LT.0).AND.(result(1).GE.thresh))) THEN
386*
387 IF( nfail.EQ.0 .AND. nerrs.EQ.0 ) THEN
388 WRITE( nout, fmt = 8999 )'ZPO'
389 WRITE( nout, fmt = '( '' Matrix types:'' )' )
390 WRITE( nout, fmt = 8979 )
391 WRITE( nout, fmt = '( '' Test ratios:'' )' )
392 WRITE( nout, fmt = 8960 )1
393 WRITE( nout, fmt = '( '' Messages:'' )' )
394 END IF
395*
396 WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat, 1,
397 $ result( 1 )
398*
399 nfail = nfail + 1
400*
401 END IF
402*
403 nrun = nrun + 1
404*
405 60 CONTINUE
406 100 CONTINUE
407 110 CONTINUE
408 120 CONTINUE
409*
410* Print a summary of the results.
411*
412 IF( nfail.GT.0 ) THEN
413 WRITE( nout, fmt = 9996 )'ZCPOSV', nfail, nrun
414 ELSE
415 WRITE( nout, fmt = 9995 )'ZCPOSV', nrun
416 END IF
417 IF( nerrs.GT.0 ) THEN
418 WRITE( nout, fmt = 9994 )nerrs
419 END IF
420*
421 9998 FORMAT( ' UPLO=''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
422 $ i2, ', test(', i2, ') =', g12.5 )
423 9996 FORMAT( 1x, a6, ': ', i6, ' out of ', i6,
424 $ ' tests failed to pass the threshold' )
425 9995 FORMAT( /1x, 'All tests for ', a6,
426 $ ' routines passed the threshold ( ', i6, ' tests run)' )
427 9994 FORMAT( 6x, i6, ' error messages recorded' )
428*
429* SUBNAM, INFO, INFOE, N, IMAT
430*
431 9988 FORMAT( ' *** ', a6, ' returned with INFO =', i5, ' instead of ',
432 $ i5, / ' ==> N =', i5, ', type ',
433 $ i2 )
434*
435* SUBNAM, INFO, N, IMAT
436*
437 9975 FORMAT( ' *** Error code from ', a6, '=', i5, ' for M=', i5,
438 $ ', type ', i2 )
439 8999 FORMAT( / 1x, a3, ': positive definite dense matrices' )
440 8979 FORMAT( 4x, '1. Diagonal', 24x, '7. Last n/2 columns zero', / 4x,
441 $ '2. Upper triangular', 16x,
442 $ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4x,
443 $ '3. Lower triangular', 16x, '9. Random, CNDNUM = 0.1/EPS',
444 $ / 4x, '4. Random, CNDNUM = 2', 13x,
445 $ '10. Scaled near underflow', / 4x, '5. First column zero',
446 $ 14x, '11. Scaled near overflow', / 4x,
447 $ '6. Last column zero' )
448 8960 FORMAT( 3x, i2, ': norm_1( B - A * X ) / ',
449 $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF',
450 $ / 4x, 'or norm_1( B - A * X ) / ',
451 $ '( norm_1(A) * norm_1(X) * EPS ) > THRES if ZPOTRF' )
452
453 RETURN
454*
455* End of ZDRVAC
456*
zcposv
subroutine zcposv(uplo, n, nrhs, a, lda, b, ldb, x, ldx, work, swork, rwork, iter, info)
ZCPOSV computes the solution to system of linear equations A * X = B for PO matrices
Definition zcposv.f:209
zpot06
subroutine zpot06(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
ZPOT06
Definition zpot06.f:127

◆ zdrvgb()

subroutine zdrvgb ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
complex*16, dimension( * ) a,
integer la,
complex*16, dimension( * ) afb,
integer lafb,
complex*16, dimension( * ) asav,
complex*16, dimension( * ) b,
complex*16, dimension( * ) bsav,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
double precision, dimension( * ) s,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZDRVGB

ZDRVGBX

Purpose:
!>
!> ZDRVGB tests the driver routines ZGBSV and -SVX.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LA)
!>
[in]LA
!>          LA is INTEGER
!>          The length of the array A.  LA >= (2*NMAX-1)*NMAX
!>          where NMAX is the largest entry in NVAL.
!>
[out]AFB
!>          AFB is COMPLEX*16 array, dimension (LAFB)
!>
[in]LAFB
!>          LAFB is INTEGER
!>          The length of the array AFB.  LAFB >= (3*NMAX-2)*NMAX
!>          where NMAX is the largest entry in NVAL.
!>
[out]ASAV
!>          ASAV is COMPLEX*16 array, dimension (LA)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (2*NMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NRHS,NMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (NMAX+2*NRHS)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Purpose:
!>
!> ZDRVGB tests the driver routines ZGBSV, -SVX, and -SVXX.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise zdrvgb.f defines this subroutine.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LA)
!>
[in]LA
!>          LA is INTEGER
!>          The length of the array A.  LA >= (2*NMAX-1)*NMAX
!>          where NMAX is the largest entry in NVAL.
!>
[out]AFB
!>          AFB is COMPLEX*16 array, dimension (LAFB)
!>
[in]LAFB
!>          LAFB is INTEGER
!>          The length of the array AFB.  LAFB >= (3*NMAX-2)*NMAX
!>          where NMAX is the largest entry in NVAL.
!>
[out]ASAV
!>          ASAV is COMPLEX*16 array, dimension (LA)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (2*NMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NRHS,NMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (max(2*NMAX,NMAX+2*NRHS))
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 169 of file zdrvgb.f.

172*
173* -- LAPACK test routine --
174* -- LAPACK is a software package provided by Univ. of Tennessee, --
175* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176*
177* .. Scalar Arguments ..
178 LOGICAL TSTERR
179 INTEGER LA, LAFB, NN, NOUT, NRHS
180 DOUBLE PRECISION THRESH
181* ..
182* .. Array Arguments ..
183 LOGICAL DOTYPE( * )
184 INTEGER IWORK( * ), NVAL( * )
185 DOUBLE PRECISION RWORK( * ), S( * )
186 COMPLEX*16 A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
187 $ WORK( * ), X( * ), XACT( * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 DOUBLE PRECISION ONE, ZERO
194 parameter( one = 1.0d+0, zero = 0.0d+0 )
195 INTEGER NTYPES
196 parameter( ntypes = 8 )
197 INTEGER NTESTS
198 parameter( ntests = 7 )
199 INTEGER NTRAN
200 parameter( ntran = 3 )
201* ..
202* .. Local Scalars ..
203 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
204 CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
205 CHARACTER*3 PATH
206 INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN,
207 $ INFO, IOFF, ITRAN, IZERO, J, K, K1, KL, KU,
208 $ LDA, LDAFB, LDB, MODE, N, NB, NBMIN, NERRS,
209 $ NFACT, NFAIL, NIMAT, NKL, NKU, NRUN, NT
210 DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV,
211 $ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO,
212 $ ROLDC, ROLDI, ROLDO, ROWCND, RPVGRW
213* ..
214* .. Local Arrays ..
215 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
216 INTEGER ISEED( 4 ), ISEEDY( 4 )
217 DOUBLE PRECISION RDUM( 1 ), RESULT( NTESTS )
218* ..
219* .. External Functions ..
220 LOGICAL LSAME
221 DOUBLE PRECISION DGET06, DLAMCH, ZLANGB, ZLANGE, ZLANTB
222 EXTERNAL lsame, dget06, dlamch, zlangb, zlange, zlantb
223* ..
224* .. External Subroutines ..
225 EXTERNAL aladhd, alaerh, alasvm, xlaenv, zerrvx, zgbequ,
226 $ zgbsv, zgbsvx, zgbt01, zgbt02, zgbt05, zgbtrf,
227 $ zgbtrs, zget04, zlacpy, zlaqgb, zlarhs, zlaset,
228 $ zlatb4, zlatms
229* ..
230* .. Intrinsic Functions ..
231 INTRINSIC abs, dcmplx, max, min
232* ..
233* .. Scalars in Common ..
234 LOGICAL LERR, OK
235 CHARACTER*32 SRNAMT
236 INTEGER INFOT, NUNIT
237* ..
238* .. Common blocks ..
239 COMMON / infoc / infot, nunit, ok, lerr
240 COMMON / srnamc / srnamt
241* ..
242* .. Data statements ..
243 DATA iseedy / 1988, 1989, 1990, 1991 /
244 DATA transs / 'N', 'T', 'C' /
245 DATA facts / 'F', 'N', 'E' /
246 DATA equeds / 'N', 'R', 'C', 'B' /
247* ..
248* .. Executable Statements ..
249*
250* Initialize constants and the random number seed.
251*
252 path( 1: 1 ) = 'Zomplex precision'
253 path( 2: 3 ) = 'GB'
254 nrun = 0
255 nfail = 0
256 nerrs = 0
257 DO 10 i = 1, 4
258 iseed( i ) = iseedy( i )
259 10 CONTINUE
260*
261* Test the error exits
262*
263 IF( tsterr )
264 $ CALL zerrvx( path, nout )
265 infot = 0
266*
267* Set the block size and minimum block size for testing.
268*
269 nb = 1
270 nbmin = 2
271 CALL xlaenv( 1, nb )
272 CALL xlaenv( 2, nbmin )
273*
274* Do for each value of N in NVAL
275*
276 DO 150 in = 1, nn
277 n = nval( in )
278 ldb = max( n, 1 )
279 xtype = 'N'
280*
281* Set limits on the number of loop iterations.
282*
283 nkl = max( 1, min( n, 4 ) )
284 IF( n.EQ.0 )
285 $ nkl = 1
286 nku = nkl
287 nimat = ntypes
288 IF( n.LE.0 )
289 $ nimat = 1
290*
291 DO 140 ikl = 1, nkl
292*
293* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes
294* it easier to skip redundant values for small values of N.
295*
296 IF( ikl.EQ.1 ) THEN
297 kl = 0
298 ELSE IF( ikl.EQ.2 ) THEN
299 kl = max( n-1, 0 )
300 ELSE IF( ikl.EQ.3 ) THEN
301 kl = ( 3*n-1 ) / 4
302 ELSE IF( ikl.EQ.4 ) THEN
303 kl = ( n+1 ) / 4
304 END IF
305 DO 130 iku = 1, nku
306*
307* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order
308* makes it easier to skip redundant values for small
309* values of N.
310*
311 IF( iku.EQ.1 ) THEN
312 ku = 0
313 ELSE IF( iku.EQ.2 ) THEN
314 ku = max( n-1, 0 )
315 ELSE IF( iku.EQ.3 ) THEN
316 ku = ( 3*n-1 ) / 4
317 ELSE IF( iku.EQ.4 ) THEN
318 ku = ( n+1 ) / 4
319 END IF
320*
321* Check that A and AFB are big enough to generate this
322* matrix.
323*
324 lda = kl + ku + 1
325 ldafb = 2*kl + ku + 1
326 IF( lda*n.GT.la .OR. ldafb*n.GT.lafb ) THEN
327 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
328 $ CALL aladhd( nout, path )
329 IF( lda*n.GT.la ) THEN
330 WRITE( nout, fmt = 9999 )la, n, kl, ku,
331 $ n*( kl+ku+1 )
332 nerrs = nerrs + 1
333 END IF
334 IF( ldafb*n.GT.lafb ) THEN
335 WRITE( nout, fmt = 9998 )lafb, n, kl, ku,
336 $ n*( 2*kl+ku+1 )
337 nerrs = nerrs + 1
338 END IF
339 GO TO 130
340 END IF
341*
342 DO 120 imat = 1, nimat
343*
344* Do the tests only if DOTYPE( IMAT ) is true.
345*
346 IF( .NOT.dotype( imat ) )
347 $ GO TO 120
348*
349* Skip types 2, 3, or 4 if the matrix is too small.
350*
351 zerot = imat.GE.2 .AND. imat.LE.4
352 IF( zerot .AND. n.LT.imat-1 )
353 $ GO TO 120
354*
355* Set up parameters with ZLATB4 and generate a
356* test matrix with ZLATMS.
357*
358 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
359 $ MODE, CNDNUM, DIST )
360 rcondc = one / cndnum
361*
362 srnamt = 'ZLATMS'
363 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
364 $ CNDNUM, ANORM, KL, KU, 'Z', A, LDA, WORK,
365 $ INFO )
366*
367* Check the error code from ZLATMS.
368*
369 IF( info.NE.0 ) THEN
370 CALL alaerh( path, 'ZLATMS', info, 0, ' ', n, n,
371 $ kl, ku, -1, imat, nfail, nerrs, nout )
372 GO TO 120
373 END IF
374*
375* For types 2, 3, and 4, zero one or more columns of
376* the matrix to test that INFO is returned correctly.
377*
378 izero = 0
379 IF( zerot ) THEN
380 IF( imat.EQ.2 ) THEN
381 izero = 1
382 ELSE IF( imat.EQ.3 ) THEN
383 izero = n
384 ELSE
385 izero = n / 2 + 1
386 END IF
387 ioff = ( izero-1 )*lda
388 IF( imat.LT.4 ) THEN
389 i1 = max( 1, ku+2-izero )
390 i2 = min( kl+ku+1, ku+1+( n-izero ) )
391 DO 20 i = i1, i2
392 a( ioff+i ) = zero
393 20 CONTINUE
394 ELSE
395 DO 40 j = izero, n
396 DO 30 i = max( 1, ku+2-j ),
397 $ min( kl+ku+1, ku+1+( n-j ) )
398 a( ioff+i ) = zero
399 30 CONTINUE
400 ioff = ioff + lda
401 40 CONTINUE
402 END IF
403 END IF
404*
405* Save a copy of the matrix A in ASAV.
406*
407 CALL zlacpy( 'Full', kl+ku+1, n, a, lda, asav, lda )
408*
409 DO 110 iequed = 1, 4
410 equed = equeds( iequed )
411 IF( iequed.EQ.1 ) THEN
412 nfact = 3
413 ELSE
414 nfact = 1
415 END IF
416*
417 DO 100 ifact = 1, nfact
418 fact = facts( ifact )
419 prefac = lsame( fact, 'F' )
420 nofact = lsame( fact, 'N' )
421 equil = lsame( fact, 'E' )
422*
423 IF( zerot ) THEN
424 IF( prefac )
425 $ GO TO 100
426 rcondo = zero
427 rcondi = zero
428*
429 ELSE IF( .NOT.nofact ) THEN
430*
431* Compute the condition number for comparison
432* with the value returned by DGESVX (FACT =
433* 'N' reuses the condition number from the
434* previous iteration with FACT = 'F').
435*
436 CALL zlacpy( 'Full', kl+ku+1, n, asav, lda,
437 $ afb( kl+1 ), ldafb )
438 IF( equil .OR. iequed.GT.1 ) THEN
439*
440* Compute row and column scale factors to
441* equilibrate the matrix A.
442*
443 CALL zgbequ( n, n, kl, ku, afb( kl+1 ),
444 $ ldafb, s, s( n+1 ), rowcnd,
445 $ colcnd, amax, info )
446 IF( info.EQ.0 .AND. n.GT.0 ) THEN
447 IF( lsame( equed, 'R' ) ) THEN
448 rowcnd = zero
449 colcnd = one
450 ELSE IF( lsame( equed, 'C' ) ) THEN
451 rowcnd = one
452 colcnd = zero
453 ELSE IF( lsame( equed, 'B' ) ) THEN
454 rowcnd = zero
455 colcnd = zero
456 END IF
457*
458* Equilibrate the matrix.
459*
460 CALL zlaqgb( n, n, kl, ku, afb( kl+1 ),
461 $ ldafb, s, s( n+1 ),
462 $ rowcnd, colcnd, amax,
463 $ equed )
464 END IF
465 END IF
466*
467* Save the condition number of the
468* non-equilibrated system for use in ZGET04.
469*
470 IF( equil ) THEN
471 roldo = rcondo
472 roldi = rcondi
473 END IF
474*
475* Compute the 1-norm and infinity-norm of A.
476*
477 anormo = zlangb( '1', n, kl, ku, afb( kl+1 ),
478 $ ldafb, rwork )
479 anormi = zlangb( 'I', n, kl, ku, afb( kl+1 ),
480 $ ldafb, rwork )
481*
482* Factor the matrix A.
483*
484 CALL zgbtrf( n, n, kl, ku, afb, ldafb, iwork,
485 $ info )
486*
487* Form the inverse of A.
488*
489 CALL zlaset( 'Full', n, n, dcmplx( zero ),
490 $ dcmplx( one ), work, ldb )
491 srnamt = 'ZGBTRS'
492 CALL zgbtrs( 'No transpose', n, kl, ku, n,
493 $ afb, ldafb, iwork, work, ldb,
494 $ info )
495*
496* Compute the 1-norm condition number of A.
497*
498 ainvnm = zlange( '1', n, n, work, ldb,
499 $ rwork )
500 IF( anormo.LE.zero .OR. ainvnm.LE.zero ) THEN
501 rcondo = one
502 ELSE
503 rcondo = ( one / anormo ) / ainvnm
504 END IF
505*
506* Compute the infinity-norm condition number
507* of A.
508*
509 ainvnm = zlange( 'I', n, n, work, ldb,
510 $ rwork )
511 IF( anormi.LE.zero .OR. ainvnm.LE.zero ) THEN
512 rcondi = one
513 ELSE
514 rcondi = ( one / anormi ) / ainvnm
515 END IF
516 END IF
517*
518 DO 90 itran = 1, ntran
519*
520* Do for each value of TRANS.
521*
522 trans = transs( itran )
523 IF( itran.EQ.1 ) THEN
524 rcondc = rcondo
525 ELSE
526 rcondc = rcondi
527 END IF
528*
529* Restore the matrix A.
530*
531 CALL zlacpy( 'Full', kl+ku+1, n, asav, lda,
532 $ a, lda )
533*
534* Form an exact solution and set the right hand
535* side.
536*
537 srnamt = 'ZLARHS'
538 CALL zlarhs( path, xtype, 'Full', trans, n,
539 $ n, kl, ku, nrhs, a, lda, xact,
540 $ ldb, b, ldb, iseed, info )
541 xtype = 'C'
542 CALL zlacpy( 'Full', n, nrhs, b, ldb, bsav,
543 $ ldb )
544*
545 IF( nofact .AND. itran.EQ.1 ) THEN
546*
547* --- Test ZGBSV ---
548*
549* Compute the LU factorization of the matrix
550* and solve the system.
551*
552 CALL zlacpy( 'Full', kl+ku+1, n, a, lda,
553 $ afb( kl+1 ), ldafb )
554 CALL zlacpy( 'Full', n, nrhs, b, ldb, x,
555 $ ldb )
556*
557 srnamt = 'ZGBSV '
558 CALL zgbsv( n, kl, ku, nrhs, afb, ldafb,
559 $ iwork, x, ldb, info )
560*
561* Check error code from ZGBSV .
562*
563 IF( info.NE.izero )
564 $ CALL alaerh( path, 'ZGBSV ', info,
565 $ izero, ' ', n, n, kl, ku,
566 $ nrhs, imat, nfail, nerrs,
567 $ nout )
568*
569* Reconstruct matrix from factors and
570* compute residual.
571*
572 CALL zgbt01( n, n, kl, ku, a, lda, afb,
573 $ ldafb, iwork, work,
574 $ result( 1 ) )
575 nt = 1
576 IF( izero.EQ.0 ) THEN
577*
578* Compute residual of the computed
579* solution.
580*
581 CALL zlacpy( 'Full', n, nrhs, b, ldb,
582 $ work, ldb )
583 CALL zgbt02( 'No transpose', n, n, kl,
584 $ ku, nrhs, a, lda, x, ldb,
585 $ work, ldb, rwork,
586 $ result( 2 ) )
587*
588* Check solution from generated exact
589* solution.
590*
591 CALL zget04( n, nrhs, x, ldb, xact,
592 $ ldb, rcondc, result( 3 ) )
593 nt = 3
594 END IF
595*
596* Print information about the tests that did
597* not pass the threshold.
598*
599 DO 50 k = 1, nt
600 IF( result( k ).GE.thresh ) THEN
601 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
602 $ CALL aladhd( nout, path )
603 WRITE( nout, fmt = 9997 )'ZGBSV ',
604 $ n, kl, ku, imat, k, result( k )
605 nfail = nfail + 1
606 END IF
607 50 CONTINUE
608 nrun = nrun + nt
609 END IF
610*
611* --- Test ZGBSVX ---
612*
613 IF( .NOT.prefac )
614 $ CALL zlaset( 'Full', 2*kl+ku+1, n,
615 $ dcmplx( zero ),
616 $ dcmplx( zero ), afb, ldafb )
617 CALL zlaset( 'Full', n, nrhs, dcmplx( zero ),
618 $ dcmplx( zero ), x, ldb )
619 IF( iequed.GT.1 .AND. n.GT.0 ) THEN
620*
621* Equilibrate the matrix if FACT = 'F' and
622* EQUED = 'R', 'C', or 'B'.
623*
624 CALL zlaqgb( n, n, kl, ku, a, lda, s,
625 $ s( n+1 ), rowcnd, colcnd,
626 $ amax, equed )
627 END IF
628*
629* Solve the system and compute the condition
630* number and error bounds using ZGBSVX.
631*
632 srnamt = 'ZGBSVX'
633 CALL zgbsvx( fact, trans, n, kl, ku, nrhs, a,
634 $ lda, afb, ldafb, iwork, equed,
635 $ s, s( ldb+1 ), b, ldb, x, ldb,
636 $ rcond, rwork, rwork( nrhs+1 ),
637 $ work, rwork( 2*nrhs+1 ), info )
638*
639* Check the error code from ZGBSVX.
640*
641 IF( info.NE.izero )
642 $ CALL alaerh( path, 'ZGBSVX', info, izero,
643 $ fact // trans, n, n, kl, ku,
644 $ nrhs, imat, nfail, nerrs,
645 $ nout )
646* Compare RWORK(2*NRHS+1) from ZGBSVX with the
647* computed reciprocal pivot growth RPVGRW
648*
649 IF( info.NE.0 .AND. info.LE.n) THEN
650 anrmpv = zero
651 DO 70 j = 1, info
652 DO 60 i = max( ku+2-j, 1 ),
653 $ min( n+ku+1-j, kl+ku+1 )
654 anrmpv = max( anrmpv,
655 $ abs( a( i+( j-1 )*lda ) ) )
656 60 CONTINUE
657 70 CONTINUE
658 rpvgrw = zlantb( 'M', 'U', 'N', info,
659 $ min( info-1, kl+ku ),
660 $ afb( max( 1, kl+ku+2-info ) ),
661 $ ldafb, rdum )
662 IF( rpvgrw.EQ.zero ) THEN
663 rpvgrw = one
664 ELSE
665 rpvgrw = anrmpv / rpvgrw
666 END IF
667 ELSE
668 rpvgrw = zlantb( 'M', 'U', 'N', n, kl+ku,
669 $ afb, ldafb, rdum )
670 IF( rpvgrw.EQ.zero ) THEN
671 rpvgrw = one
672 ELSE
673 rpvgrw = zlangb( 'M', n, kl, ku, a,
674 $ lda, rdum ) / rpvgrw
675 END IF
676 END IF
677 result( 7 ) = abs( rpvgrw-rwork( 2*nrhs+1 ) )
678 $ / max( rwork( 2*nrhs+1 ),
679 $ rpvgrw ) / dlamch( 'E' )
680*
681 IF( .NOT.prefac ) THEN
682*
683* Reconstruct matrix from factors and
684* compute residual.
685*
686 CALL zgbt01( n, n, kl, ku, a, lda, afb,
687 $ ldafb, iwork, work,
688 $ result( 1 ) )
689 k1 = 1
690 ELSE
691 k1 = 2
692 END IF
693*
694 IF( info.EQ.0 ) THEN
695 trfcon = .false.
696*
697* Compute residual of the computed solution.
698*
699 CALL zlacpy( 'Full', n, nrhs, bsav, ldb,
700 $ work, ldb )
701 CALL zgbt02( trans, n, n, kl, ku, nrhs,
702 $ asav, lda, x, ldb, work, ldb,
703 $ rwork( 2*nrhs+1 ),
704 $ result( 2 ) )
705*
706* Check solution from generated exact
707* solution.
708*
709 IF( nofact .OR. ( prefac .AND.
710 $ lsame( equed, 'N' ) ) ) THEN
711 CALL zget04( n, nrhs, x, ldb, xact,
712 $ ldb, rcondc, result( 3 ) )
713 ELSE
714 IF( itran.EQ.1 ) THEN
715 roldc = roldo
716 ELSE
717 roldc = roldi
718 END IF
719 CALL zget04( n, nrhs, x, ldb, xact,
720 $ ldb, roldc, result( 3 ) )
721 END IF
722*
723* Check the error bounds from iterative
724* refinement.
725*
726 CALL zgbt05( trans, n, kl, ku, nrhs, asav,
727 $ lda, bsav, ldb, x, ldb, xact,
728 $ ldb, rwork, rwork( nrhs+1 ),
729 $ result( 4 ) )
730 ELSE
731 trfcon = .true.
732 END IF
733*
734* Compare RCOND from ZGBSVX with the computed
735* value in RCONDC.
736*
737 result( 6 ) = dget06( rcond, rcondc )
738*
739* Print information about the tests that did
740* not pass the threshold.
741*
742 IF( .NOT.trfcon ) THEN
743 DO 80 k = k1, ntests
744 IF( result( k ).GE.thresh ) THEN
745 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
746 $ CALL aladhd( nout, path )
747 IF( prefac ) THEN
748 WRITE( nout, fmt = 9995 )
749 $ 'ZGBSVX', fact, trans, n, kl,
750 $ ku, equed, imat, k,
751 $ result( k )
752 ELSE
753 WRITE( nout, fmt = 9996 )
754 $ 'ZGBSVX', fact, trans, n, kl,
755 $ ku, imat, k, result( k )
756 END IF
757 nfail = nfail + 1
758 END IF
759 80 CONTINUE
760 nrun = nrun + ntests - k1 + 1
761 ELSE
762 IF( result( 1 ).GE.thresh .AND. .NOT.
763 $ prefac ) THEN
764 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
765 $ CALL aladhd( nout, path )
766 IF( prefac ) THEN
767 WRITE( nout, fmt = 9995 )'ZGBSVX',
768 $ fact, trans, n, kl, ku, equed,
769 $ imat, 1, result( 1 )
770 ELSE
771 WRITE( nout, fmt = 9996 )'ZGBSVX',
772 $ fact, trans, n, kl, ku, imat, 1,
773 $ result( 1 )
774 END IF
775 nfail = nfail + 1
776 nrun = nrun + 1
777 END IF
778 IF( result( 6 ).GE.thresh ) THEN
779 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
780 $ CALL aladhd( nout, path )
781 IF( prefac ) THEN
782 WRITE( nout, fmt = 9995 )'ZGBSVX',
783 $ fact, trans, n, kl, ku, equed,
784 $ imat, 6, result( 6 )
785 ELSE
786 WRITE( nout, fmt = 9996 )'ZGBSVX',
787 $ fact, trans, n, kl, ku, imat, 6,
788 $ result( 6 )
789 END IF
790 nfail = nfail + 1
791 nrun = nrun + 1
792 END IF
793 IF( result( 7 ).GE.thresh ) THEN
794 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
795 $ CALL aladhd( nout, path )
796 IF( prefac ) THEN
797 WRITE( nout, fmt = 9995 )'ZGBSVX',
798 $ fact, trans, n, kl, ku, equed,
799 $ imat, 7, result( 7 )
800 ELSE
801 WRITE( nout, fmt = 9996 )'ZGBSVX',
802 $ fact, trans, n, kl, ku, imat, 7,
803 $ result( 7 )
804 END IF
805 nfail = nfail + 1
806 nrun = nrun + 1
807 END IF
808 END IF
809 90 CONTINUE
810 100 CONTINUE
811 110 CONTINUE
812 120 CONTINUE
813 130 CONTINUE
814 140 CONTINUE
815 150 CONTINUE
816*
817* Print a summary of the results.
818*
819 CALL alasvm( path, nout, nfail, nrun, nerrs )
820*
821 9999 FORMAT( ' *** In ZDRVGB, LA=', i5, ' is too small for N=', i5,
822 $ ', KU=', i5, ', KL=', i5, / ' ==> Increase LA to at least ',
823 $ i5 )
824 9998 FORMAT( ' *** In ZDRVGB, LAFB=', i5, ' is too small for N=', i5,
825 $ ', KU=', i5, ', KL=', i5, /
826 $ ' ==> Increase LAFB to at least ', i5 )
827 9997 FORMAT( 1x, a, ', N=', i5, ', KL=', i5, ', KU=', i5, ', type ',
828 $ i1, ', test(', i1, ')=', g12.5 )
829 9996 FORMAT( 1x, a, '( ''', a1, ''',''', a1, ''',', i5, ',', i5, ',',
830 $ i5, ',...), type ', i1, ', test(', i1, ')=', g12.5 )
831 9995 FORMAT( 1x, a, '( ''', a1, ''',''', a1, ''',', i5, ',', i5, ',',
832 $ i5, ',...), EQUED=''', a1, ''', type ', i1, ', test(', i1,
833 $ ')=', g12.5 )
834*
835 RETURN
836*
837* End of ZDRVGB
838*
alasvm
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
Definition alasvm.f:73
aladhd
subroutine aladhd(iounit, path)
ALADHD
Definition aladhd.f:90
zlaqgb
subroutine zlaqgb(m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, equed)
ZLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ.
Definition zlaqgb.f:160
zgbsvx
subroutine zgbsvx(fact, trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, equed, r, c, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
ZGBSVX computes the solution to system of linear equations A * X = B for GB matrices
Definition zgbsvx.f:370
zgbsv
subroutine zgbsv(n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
ZGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver)
Definition zgbsv.f:162
zerrvx
subroutine zerrvx(path, nunit)
ZERRVX
Definition zerrvx.f:55

◆ zdrvge()

subroutine zdrvge ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) asav,
complex*16, dimension( * ) b,
complex*16, dimension( * ) bsav,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
double precision, dimension( * ) s,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZDRVGE

ZDRVGEX

Purpose:
!>
!> ZDRVGE tests the driver routines ZGESV and -SVX.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]ASAV
!>          ASAV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (2*NMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (2*NRHS+NMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Purpose:
!>
!> ZDRVGE tests the driver routines ZGESV, -SVX, and -SVXX.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise zdrvge.f defines this subroutine.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]ASAV
!>          ASAV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (2*NMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (2*NRHS+NMAX)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 161 of file zdrvge.f.

164*
165* -- LAPACK test routine --
166* -- LAPACK is a software package provided by Univ. of Tennessee, --
167* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
168*
169* .. Scalar Arguments ..
170 LOGICAL TSTERR
171 INTEGER NMAX, NN, NOUT, NRHS
172 DOUBLE PRECISION THRESH
173* ..
174* .. Array Arguments ..
175 LOGICAL DOTYPE( * )
176 INTEGER IWORK( * ), NVAL( * )
177 DOUBLE PRECISION RWORK( * ), S( * )
178 COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ),
179 $ BSAV( * ), WORK( * ), X( * ), XACT( * )
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 DOUBLE PRECISION ONE, ZERO
186 parameter( one = 1.0d+0, zero = 0.0d+0 )
187 INTEGER NTYPES
188 parameter( ntypes = 11 )
189 INTEGER NTESTS
190 parameter( ntests = 7 )
191 INTEGER NTRAN
192 parameter( ntran = 3 )
193* ..
194* .. Local Scalars ..
195 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
196 CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
197 CHARACTER*3 PATH
198 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, ITRAN,
199 $ IZERO, K, K1, KL, KU, LDA, LWORK, MODE, N, NB,
200 $ NBMIN, NERRS, NFACT, NFAIL, NIMAT, NRUN, NT
201 DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, CNDNUM,
202 $ COLCND, RCOND, RCONDC, RCONDI, RCONDO, ROLDC,
203 $ ROLDI, ROLDO, ROWCND, RPVGRW
204* ..
205* .. Local Arrays ..
206 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
207 INTEGER ISEED( 4 ), ISEEDY( 4 )
208 DOUBLE PRECISION RDUM( 1 ), RESULT( NTESTS )
209* ..
210* .. External Functions ..
211 LOGICAL LSAME
212 DOUBLE PRECISION DGET06, DLAMCH, ZLANGE, ZLANTR
213 EXTERNAL lsame, dget06, dlamch, zlange, zlantr
214* ..
215* .. External Subroutines ..
216 EXTERNAL aladhd, alaerh, alasvm, xlaenv, zerrvx, zgeequ,
217 $ zgesv, zgesvx, zget01, zget02, zget04, zget07,
218 $ zgetrf, zgetri, zlacpy, zlaqge, zlarhs, zlaset,
219 $ zlatb4, zlatms
220* ..
221* .. Intrinsic Functions ..
222 INTRINSIC abs, dcmplx, max
223* ..
224* .. Scalars in Common ..
225 LOGICAL LERR, OK
226 CHARACTER*32 SRNAMT
227 INTEGER INFOT, NUNIT
228* ..
229* .. Common blocks ..
230 COMMON / infoc / infot, nunit, ok, lerr
231 COMMON / srnamc / srnamt
232* ..
233* .. Data statements ..
234 DATA iseedy / 1988, 1989, 1990, 1991 /
235 DATA transs / 'N', 'T', 'C' /
236 DATA facts / 'F', 'N', 'E' /
237 DATA equeds / 'N', 'R', 'C', 'B' /
238* ..
239* .. Executable Statements ..
240*
241* Initialize constants and the random number seed.
242*
243 path( 1: 1 ) = 'Zomplex precision'
244 path( 2: 3 ) = 'GE'
245 nrun = 0
246 nfail = 0
247 nerrs = 0
248 DO 10 i = 1, 4
249 iseed( i ) = iseedy( i )
250 10 CONTINUE
251*
252* Test the error exits
253*
254 IF( tsterr )
255 $ CALL zerrvx( path, nout )
256 infot = 0
257*
258* Set the block size and minimum block size for testing.
259*
260 nb = 1
261 nbmin = 2
262 CALL xlaenv( 1, nb )
263 CALL xlaenv( 2, nbmin )
264*
265* Do for each value of N in NVAL
266*
267 DO 90 in = 1, nn
268 n = nval( in )
269 lda = max( n, 1 )
270 xtype = 'N'
271 nimat = ntypes
272 IF( n.LE.0 )
273 $ nimat = 1
274*
275 DO 80 imat = 1, nimat
276*
277* Do the tests only if DOTYPE( IMAT ) is true.
278*
279 IF( .NOT.dotype( imat ) )
280 $ GO TO 80
281*
282* Skip types 5, 6, or 7 if the matrix size is too small.
283*
284 zerot = imat.GE.5 .AND. imat.LE.7
285 IF( zerot .AND. n.LT.imat-4 )
286 $ GO TO 80
287*
288* Set up parameters with ZLATB4 and generate a test matrix
289* with ZLATMS.
290*
291 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
292 $ CNDNUM, DIST )
293 rcondc = one / cndnum
294*
295 srnamt = 'ZLATMS'
296 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE, CNDNUM,
297 $ ANORM, KL, KU, 'No packing', A, LDA, WORK,
298 $ INFO )
299*
300* Check error code from ZLATMS.
301*
302 IF( info.NE.0 ) THEN
303 CALL alaerh( path, 'ZLATMS', info, 0, ' ', n, n, -1, -1,
304 $ -1, imat, nfail, nerrs, nout )
305 GO TO 80
306 END IF
307*
308* For types 5-7, zero one or more columns of the matrix to
309* test that INFO is returned correctly.
310*
311 IF( zerot ) THEN
312 IF( imat.EQ.5 ) THEN
313 izero = 1
314 ELSE IF( imat.EQ.6 ) THEN
315 izero = n
316 ELSE
317 izero = n / 2 + 1
318 END IF
319 ioff = ( izero-1 )*lda
320 IF( imat.LT.7 ) THEN
321 DO 20 i = 1, n
322 a( ioff+i ) = zero
323 20 CONTINUE
324 ELSE
325 CALL zlaset( 'Full', n, n-izero+1, dcmplx( zero ),
326 $ dcmplx( zero ), a( ioff+1 ), lda )
327 END IF
328 ELSE
329 izero = 0
330 END IF
331*
332* Save a copy of the matrix A in ASAV.
333*
334 CALL zlacpy( 'Full', n, n, a, lda, asav, lda )
335*
336 DO 70 iequed = 1, 4
337 equed = equeds( iequed )
338 IF( iequed.EQ.1 ) THEN
339 nfact = 3
340 ELSE
341 nfact = 1
342 END IF
343*
344 DO 60 ifact = 1, nfact
345 fact = facts( ifact )
346 prefac = lsame( fact, 'F' )
347 nofact = lsame( fact, 'N' )
348 equil = lsame( fact, 'E' )
349*
350 IF( zerot ) THEN
351 IF( prefac )
352 $ GO TO 60
353 rcondo = zero
354 rcondi = zero
355*
356 ELSE IF( .NOT.nofact ) THEN
357*
358* Compute the condition number for comparison with
359* the value returned by ZGESVX (FACT = 'N' reuses
360* the condition number from the previous iteration
361* with FACT = 'F').
362*
363 CALL zlacpy( 'Full', n, n, asav, lda, afac, lda )
364 IF( equil .OR. iequed.GT.1 ) THEN
365*
366* Compute row and column scale factors to
367* equilibrate the matrix A.
368*
369 CALL zgeequ( n, n, afac, lda, s, s( n+1 ),
370 $ rowcnd, colcnd, amax, info )
371 IF( info.EQ.0 .AND. n.GT.0 ) THEN
372 IF( lsame( equed, 'R' ) ) THEN
373 rowcnd = zero
374 colcnd = one
375 ELSE IF( lsame( equed, 'C' ) ) THEN
376 rowcnd = one
377 colcnd = zero
378 ELSE IF( lsame( equed, 'B' ) ) THEN
379 rowcnd = zero
380 colcnd = zero
381 END IF
382*
383* Equilibrate the matrix.
384*
385 CALL zlaqge( n, n, afac, lda, s, s( n+1 ),
386 $ rowcnd, colcnd, amax, equed )
387 END IF
388 END IF
389*
390* Save the condition number of the non-equilibrated
391* system for use in ZGET04.
392*
393 IF( equil ) THEN
394 roldo = rcondo
395 roldi = rcondi
396 END IF
397*
398* Compute the 1-norm and infinity-norm of A.
399*
400 anormo = zlange( '1', n, n, afac, lda, rwork )
401 anormi = zlange( 'I', n, n, afac, lda, rwork )
402*
403* Factor the matrix A.
404*
405 srnamt = 'ZGETRF'
406 CALL zgetrf( n, n, afac, lda, iwork, info )
407*
408* Form the inverse of A.
409*
410 CALL zlacpy( 'Full', n, n, afac, lda, a, lda )
411 lwork = nmax*max( 3, nrhs )
412 srnamt = 'ZGETRI'
413 CALL zgetri( n, a, lda, iwork, work, lwork, info )
414*
415* Compute the 1-norm condition number of A.
416*
417 ainvnm = zlange( '1', n, n, a, lda, rwork )
418 IF( anormo.LE.zero .OR. ainvnm.LE.zero ) THEN
419 rcondo = one
420 ELSE
421 rcondo = ( one / anormo ) / ainvnm
422 END IF
423*
424* Compute the infinity-norm condition number of A.
425*
426 ainvnm = zlange( 'I', n, n, a, lda, rwork )
427 IF( anormi.LE.zero .OR. ainvnm.LE.zero ) THEN
428 rcondi = one
429 ELSE
430 rcondi = ( one / anormi ) / ainvnm
431 END IF
432 END IF
433*
434 DO 50 itran = 1, ntran
435*
436* Do for each value of TRANS.
437*
438 trans = transs( itran )
439 IF( itran.EQ.1 ) THEN
440 rcondc = rcondo
441 ELSE
442 rcondc = rcondi
443 END IF
444*
445* Restore the matrix A.
446*
447 CALL zlacpy( 'Full', n, n, asav, lda, a, lda )
448*
449* Form an exact solution and set the right hand side.
450*
451 srnamt = 'ZLARHS'
452 CALL zlarhs( path, xtype, 'Full', trans, n, n, kl,
453 $ ku, nrhs, a, lda, xact, lda, b, lda,
454 $ iseed, info )
455 xtype = 'C'
456 CALL zlacpy( 'Full', n, nrhs, b, lda, bsav, lda )
457*
458 IF( nofact .AND. itran.EQ.1 ) THEN
459*
460* --- Test ZGESV ---
461*
462* Compute the LU factorization of the matrix and
463* solve the system.
464*
465 CALL zlacpy( 'Full', n, n, a, lda, afac, lda )
466 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
467*
468 srnamt = 'ZGESV '
469 CALL zgesv( n, nrhs, afac, lda, iwork, x, lda,
470 $ info )
471*
472* Check error code from ZGESV .
473*
474 IF( info.NE.izero )
475 $ CALL alaerh( path, 'ZGESV ', info, izero,
476 $ ' ', n, n, -1, -1, nrhs, imat,
477 $ nfail, nerrs, nout )
478*
479* Reconstruct matrix from factors and compute
480* residual.
481*
482 CALL zget01( n, n, a, lda, afac, lda, iwork,
483 $ rwork, result( 1 ) )
484 nt = 1
485 IF( izero.EQ.0 ) THEN
486*
487* Compute residual of the computed solution.
488*
489 CALL zlacpy( 'Full', n, nrhs, b, lda, work,
490 $ lda )
491 CALL zget02( 'No transpose', n, n, nrhs, a,
492 $ lda, x, lda, work, lda, rwork,
493 $ result( 2 ) )
494*
495* Check solution from generated exact solution.
496*
497 CALL zget04( n, nrhs, x, lda, xact, lda,
498 $ rcondc, result( 3 ) )
499 nt = 3
500 END IF
501*
502* Print information about the tests that did not
503* pass the threshold.
504*
505 DO 30 k = 1, nt
506 IF( result( k ).GE.thresh ) THEN
507 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
508 $ CALL aladhd( nout, path )
509 WRITE( nout, fmt = 9999 )'ZGESV ', n,
510 $ imat, k, result( k )
511 nfail = nfail + 1
512 END IF
513 30 CONTINUE
514 nrun = nrun + nt
515 END IF
516*
517* --- Test ZGESVX ---
518*
519 IF( .NOT.prefac )
520 $ CALL zlaset( 'Full', n, n, dcmplx( zero ),
521 $ dcmplx( zero ), afac, lda )
522 CALL zlaset( 'Full', n, nrhs, dcmplx( zero ),
523 $ dcmplx( zero ), x, lda )
524 IF( iequed.GT.1 .AND. n.GT.0 ) THEN
525*
526* Equilibrate the matrix if FACT = 'F' and
527* EQUED = 'R', 'C', or 'B'.
528*
529 CALL zlaqge( n, n, a, lda, s, s( n+1 ), rowcnd,
530 $ colcnd, amax, equed )
531 END IF
532*
533* Solve the system and compute the condition number
534* and error bounds using ZGESVX.
535*
536 srnamt = 'ZGESVX'
537 CALL zgesvx( fact, trans, n, nrhs, a, lda, afac,
538 $ lda, iwork, equed, s, s( n+1 ), b,
539 $ lda, x, lda, rcond, rwork,
540 $ rwork( nrhs+1 ), work,
541 $ rwork( 2*nrhs+1 ), info )
542*
543* Check the error code from ZGESVX.
544*
545 IF( info.NE.izero )
546 $ CALL alaerh( path, 'ZGESVX', info, izero,
547 $ fact // trans, n, n, -1, -1, nrhs,
548 $ imat, nfail, nerrs, nout )
549*
550* Compare RWORK(2*NRHS+1) from ZGESVX with the
551* computed reciprocal pivot growth factor RPVGRW
552*
553 IF( info.NE.0 .AND. info.LE.n) THEN
554 rpvgrw = zlantr( 'M', 'U', 'N', info, info,
555 $ afac, lda, rdum )
556 IF( rpvgrw.EQ.zero ) THEN
557 rpvgrw = one
558 ELSE
559 rpvgrw = zlange( 'M', n, info, a, lda,
560 $ rdum ) / rpvgrw
561 END IF
562 ELSE
563 rpvgrw = zlantr( 'M', 'U', 'N', n, n, afac, lda,
564 $ rdum )
565 IF( rpvgrw.EQ.zero ) THEN
566 rpvgrw = one
567 ELSE
568 rpvgrw = zlange( 'M', n, n, a, lda, rdum ) /
569 $ rpvgrw
570 END IF
571 END IF
572 result( 7 ) = abs( rpvgrw-rwork( 2*nrhs+1 ) ) /
573 $ max( rwork( 2*nrhs+1 ), rpvgrw ) /
574 $ dlamch( 'E' )
575*
576 IF( .NOT.prefac ) THEN
577*
578* Reconstruct matrix from factors and compute
579* residual.
580*
581 CALL zget01( n, n, a, lda, afac, lda, iwork,
582 $ rwork( 2*nrhs+1 ), result( 1 ) )
583 k1 = 1
584 ELSE
585 k1 = 2
586 END IF
587*
588 IF( info.EQ.0 ) THEN
589 trfcon = .false.
590*
591* Compute residual of the computed solution.
592*
593 CALL zlacpy( 'Full', n, nrhs, bsav, lda, work,
594 $ lda )
595 CALL zget02( trans, n, n, nrhs, asav, lda, x,
596 $ lda, work, lda, rwork( 2*nrhs+1 ),
597 $ result( 2 ) )
598*
599* Check solution from generated exact solution.
600*
601 IF( nofact .OR. ( prefac .AND. lsame( equed,
602 $ 'N' ) ) ) THEN
603 CALL zget04( n, nrhs, x, lda, xact, lda,
604 $ rcondc, result( 3 ) )
605 ELSE
606 IF( itran.EQ.1 ) THEN
607 roldc = roldo
608 ELSE
609 roldc = roldi
610 END IF
611 CALL zget04( n, nrhs, x, lda, xact, lda,
612 $ roldc, result( 3 ) )
613 END IF
614*
615* Check the error bounds from iterative
616* refinement.
617*
618 CALL zget07( trans, n, nrhs, asav, lda, b, lda,
619 $ x, lda, xact, lda, rwork, .true.,
620 $ rwork( nrhs+1 ), result( 4 ) )
621 ELSE
622 trfcon = .true.
623 END IF
624*
625* Compare RCOND from ZGESVX with the computed value
626* in RCONDC.
627*
628 result( 6 ) = dget06( rcond, rcondc )
629*
630* Print information about the tests that did not pass
631* the threshold.
632*
633 IF( .NOT.trfcon ) THEN
634 DO 40 k = k1, ntests
635 IF( result( k ).GE.thresh ) THEN
636 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
637 $ CALL aladhd( nout, path )
638 IF( prefac ) THEN
639 WRITE( nout, fmt = 9997 )'ZGESVX',
640 $ fact, trans, n, equed, imat, k,
641 $ result( k )
642 ELSE
643 WRITE( nout, fmt = 9998 )'ZGESVX',
644 $ fact, trans, n, imat, k, result( k )
645 END IF
646 nfail = nfail + 1
647 END IF
648 40 CONTINUE
649 nrun = nrun + ntests - k1 + 1
650 ELSE
651 IF( result( 1 ).GE.thresh .AND. .NOT.prefac )
652 $ THEN
653 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
654 $ CALL aladhd( nout, path )
655 IF( prefac ) THEN
656 WRITE( nout, fmt = 9997 )'ZGESVX', fact,
657 $ trans, n, equed, imat, 1, result( 1 )
658 ELSE
659 WRITE( nout, fmt = 9998 )'ZGESVX', fact,
660 $ trans, n, imat, 1, result( 1 )
661 END IF
662 nfail = nfail + 1
663 nrun = nrun + 1
664 END IF
665 IF( result( 6 ).GE.thresh ) THEN
666 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
667 $ CALL aladhd( nout, path )
668 IF( prefac ) THEN
669 WRITE( nout, fmt = 9997 )'ZGESVX', fact,
670 $ trans, n, equed, imat, 6, result( 6 )
671 ELSE
672 WRITE( nout, fmt = 9998 )'ZGESVX', fact,
673 $ trans, n, imat, 6, result( 6 )
674 END IF
675 nfail = nfail + 1
676 nrun = nrun + 1
677 END IF
678 IF( result( 7 ).GE.thresh ) THEN
679 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
680 $ CALL aladhd( nout, path )
681 IF( prefac ) THEN
682 WRITE( nout, fmt = 9997 )'ZGESVX', fact,
683 $ trans, n, equed, imat, 7, result( 7 )
684 ELSE
685 WRITE( nout, fmt = 9998 )'ZGESVX', fact,
686 $ trans, n, imat, 7, result( 7 )
687 END IF
688 nfail = nfail + 1
689 nrun = nrun + 1
690 END IF
691*
692 END IF
693*
694 50 CONTINUE
695 60 CONTINUE
696 70 CONTINUE
697 80 CONTINUE
698 90 CONTINUE
699*
700* Print a summary of the results.
701*
702 CALL alasvm( path, nout, nfail, nrun, nerrs )
703*
704 9999 FORMAT( 1x, a, ', N =', i5, ', type ', i2, ', test(', i2, ') =',
705 $ g12.5 )
706 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', TRANS=''', a1, ''', N=', i5,
707 $ ', type ', i2, ', test(', i1, ')=', g12.5 )
708 9997 FORMAT( 1x, a, ', FACT=''', a1, ''', TRANS=''', a1, ''', N=', i5,
709 $ ', EQUED=''', a1, ''', type ', i2, ', test(', i1, ')=',
710 $ g12.5 )
711 RETURN
712*
713* End of ZDRVGE
714*
zlaqge
subroutine zlaqge(m, n, a, lda, r, c, rowcnd, colcnd, amax, equed)
ZLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sgeequ.
Definition zlaqge.f:143
zgesv
subroutine zgesv(n, nrhs, a, lda, ipiv, b, ldb, info)
ZGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver)
Definition zgesv.f:122
zgesvx
subroutine zgesvx(fact, trans, n, nrhs, a, lda, af, ldaf, ipiv, equed, r, c, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
ZGESVX computes the solution to system of linear equations A * X = B for GE matrices
Definition zgesvx.f:350

◆ zdrvgt()

subroutine zdrvgt ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
complex*16, dimension( * ) a,
complex*16, dimension( * ) af,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZDRVGT

Purpose:
!>
!> ZDRVGT tests ZGTSV and -SVX.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, NRHS >= 0.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*4)
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (NMAX*4)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (2*NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 137 of file zdrvgt.f.

139*
140* -- LAPACK test routine --
141* -- LAPACK is a software package provided by Univ. of Tennessee, --
142* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
143*
144* .. Scalar Arguments ..
145 LOGICAL TSTERR
146 INTEGER NN, NOUT, NRHS
147 DOUBLE PRECISION THRESH
148* ..
149* .. Array Arguments ..
150 LOGICAL DOTYPE( * )
151 INTEGER IWORK( * ), NVAL( * )
152 DOUBLE PRECISION RWORK( * )
153 COMPLEX*16 A( * ), AF( * ), B( * ), WORK( * ), X( * ),
154 $ XACT( * )
155* ..
156*
157* =====================================================================
158*
159* .. Parameters ..
160 DOUBLE PRECISION ONE, ZERO
161 parameter( one = 1.0d+0, zero = 0.0d+0 )
162 INTEGER NTYPES
163 parameter( ntypes = 12 )
164 INTEGER NTESTS
165 parameter( ntests = 6 )
166* ..
167* .. Local Scalars ..
168 LOGICAL TRFCON, ZEROT
169 CHARACTER DIST, FACT, TRANS, TYPE
170 CHARACTER*3 PATH
171 INTEGER I, IFACT, IMAT, IN, INFO, ITRAN, IX, IZERO, J,
172 $ K, K1, KL, KOFF, KU, LDA, M, MODE, N, NERRS,
173 $ NFAIL, NIMAT, NRUN, NT
174 DOUBLE PRECISION AINVNM, ANORM, ANORMI, ANORMO, COND, RCOND,
175 $ RCONDC, RCONDI, RCONDO
176* ..
177* .. Local Arrays ..
178 CHARACTER TRANSS( 3 )
179 INTEGER ISEED( 4 ), ISEEDY( 4 )
180 DOUBLE PRECISION RESULT( NTESTS ), Z( 3 )
181* ..
182* .. External Functions ..
183 DOUBLE PRECISION DGET06, DZASUM, ZLANGT
184 EXTERNAL dget06, dzasum, zlangt
185* ..
186* .. External Subroutines ..
187 EXTERNAL aladhd, alaerh, alasvm, zcopy, zdscal, zerrvx,
188 $ zget04, zgtsv, zgtsvx, zgtt01, zgtt02, zgtt05,
189 $ zgttrf, zgttrs, zlacpy, zlagtm, zlarnv, zlaset,
190 $ zlatb4, zlatms
191* ..
192* .. Intrinsic Functions ..
193 INTRINSIC dcmplx, max
194* ..
195* .. Scalars in Common ..
196 LOGICAL LERR, OK
197 CHARACTER*32 SRNAMT
198 INTEGER INFOT, NUNIT
199* ..
200* .. Common blocks ..
201 COMMON / infoc / infot, nunit, ok, lerr
202 COMMON / srnamc / srnamt
203* ..
204* .. Data statements ..
205 DATA iseedy / 0, 0, 0, 1 / , transs / 'N', 'T',
206 $ 'C' /
207* ..
208* .. Executable Statements ..
209*
210 path( 1: 1 ) = 'Zomplex precision'
211 path( 2: 3 ) = 'GT'
212 nrun = 0
213 nfail = 0
214 nerrs = 0
215 DO 10 i = 1, 4
216 iseed( i ) = iseedy( i )
217 10 CONTINUE
218*
219* Test the error exits
220*
221 IF( tsterr )
222 $ CALL zerrvx( path, nout )
223 infot = 0
224*
225 DO 140 in = 1, nn
226*
227* Do for each value of N in NVAL.
228*
229 n = nval( in )
230 m = max( n-1, 0 )
231 lda = max( 1, n )
232 nimat = ntypes
233 IF( n.LE.0 )
234 $ nimat = 1
235*
236 DO 130 imat = 1, nimat
237*
238* Do the tests only if DOTYPE( IMAT ) is true.
239*
240 IF( .NOT.dotype( imat ) )
241 $ GO TO 130
242*
243* Set up parameters with ZLATB4.
244*
245 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
246 $ COND, DIST )
247*
248 zerot = imat.GE.8 .AND. imat.LE.10
249 IF( imat.LE.6 ) THEN
250*
251* Types 1-6: generate matrices of known condition number.
252*
253 koff = max( 2-ku, 3-max( 1, n ) )
254 srnamt = 'ZLATMS'
255 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE, COND,
256 $ ANORM, KL, KU, 'Z', AF( KOFF ), 3, WORK,
257 $ INFO )
258*
259* Check the error code from ZLATMS.
260*
261 IF( info.NE.0 ) THEN
262 CALL alaerh( path, 'ZLATMS', info, 0, ' ', n, n, kl,
263 $ ku, -1, imat, nfail, nerrs, nout )
264 GO TO 130
265 END IF
266 izero = 0
267*
268 IF( n.GT.1 ) THEN
269 CALL zcopy( n-1, af( 4 ), 3, a, 1 )
270 CALL zcopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
271 END IF
272 CALL zcopy( n, af( 2 ), 3, a( m+1 ), 1 )
273 ELSE
274*
275* Types 7-12: generate tridiagonal matrices with
276* unknown condition numbers.
277*
278 IF( .NOT.zerot .OR. .NOT.dotype( 7 ) ) THEN
279*
280* Generate a matrix with elements from [-1,1].
281*
282 CALL zlarnv( 2, iseed, n+2*m, a )
283 IF( anorm.NE.one )
284 $ CALL zdscal( n+2*m, anorm, a, 1 )
285 ELSE IF( izero.GT.0 ) THEN
286*
287* Reuse the last matrix by copying back the zeroed out
288* elements.
289*
290 IF( izero.EQ.1 ) THEN
291 a( n ) = z( 2 )
292 IF( n.GT.1 )
293 $ a( 1 ) = z( 3 )
294 ELSE IF( izero.EQ.n ) THEN
295 a( 3*n-2 ) = z( 1 )
296 a( 2*n-1 ) = z( 2 )
297 ELSE
298 a( 2*n-2+izero ) = z( 1 )
299 a( n-1+izero ) = z( 2 )
300 a( izero ) = z( 3 )
301 END IF
302 END IF
303*
304* If IMAT > 7, set one column of the matrix to 0.
305*
306 IF( .NOT.zerot ) THEN
307 izero = 0
308 ELSE IF( imat.EQ.8 ) THEN
309 izero = 1
310 z( 2 ) = a( n )
311 a( n ) = zero
312 IF( n.GT.1 ) THEN
313 z( 3 ) = a( 1 )
314 a( 1 ) = zero
315 END IF
316 ELSE IF( imat.EQ.9 ) THEN
317 izero = n
318 z( 1 ) = a( 3*n-2 )
319 z( 2 ) = a( 2*n-1 )
320 a( 3*n-2 ) = zero
321 a( 2*n-1 ) = zero
322 ELSE
323 izero = ( n+1 ) / 2
324 DO 20 i = izero, n - 1
325 a( 2*n-2+i ) = zero
326 a( n-1+i ) = zero
327 a( i ) = zero
328 20 CONTINUE
329 a( 3*n-2 ) = zero
330 a( 2*n-1 ) = zero
331 END IF
332 END IF
333*
334 DO 120 ifact = 1, 2
335 IF( ifact.EQ.1 ) THEN
336 fact = 'F'
337 ELSE
338 fact = 'N'
339 END IF
340*
341* Compute the condition number for comparison with
342* the value returned by ZGTSVX.
343*
344 IF( zerot ) THEN
345 IF( ifact.EQ.1 )
346 $ GO TO 120
347 rcondo = zero
348 rcondi = zero
349*
350 ELSE IF( ifact.EQ.1 ) THEN
351 CALL zcopy( n+2*m, a, 1, af, 1 )
352*
353* Compute the 1-norm and infinity-norm of A.
354*
355 anormo = zlangt( '1', n, a, a( m+1 ), a( n+m+1 ) )
356 anormi = zlangt( 'I', n, a, a( m+1 ), a( n+m+1 ) )
357*
358* Factor the matrix A.
359*
360 CALL zgttrf( n, af, af( m+1 ), af( n+m+1 ),
361 $ af( n+2*m+1 ), iwork, info )
362*
363* Use ZGTTRS to solve for one column at a time of
364* inv(A), computing the maximum column sum as we go.
365*
366 ainvnm = zero
367 DO 40 i = 1, n
368 DO 30 j = 1, n
369 x( j ) = zero
370 30 CONTINUE
371 x( i ) = one
372 CALL zgttrs( 'No transpose', n, 1, af, af( m+1 ),
373 $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
374 $ lda, info )
375 ainvnm = max( ainvnm, dzasum( n, x, 1 ) )
376 40 CONTINUE
377*
378* Compute the 1-norm condition number of A.
379*
380 IF( anormo.LE.zero .OR. ainvnm.LE.zero ) THEN
381 rcondo = one
382 ELSE
383 rcondo = ( one / anormo ) / ainvnm
384 END IF
385*
386* Use ZGTTRS to solve for one column at a time of
387* inv(A'), computing the maximum column sum as we go.
388*
389 ainvnm = zero
390 DO 60 i = 1, n
391 DO 50 j = 1, n
392 x( j ) = zero
393 50 CONTINUE
394 x( i ) = one
395 CALL zgttrs( 'Conjugate transpose', n, 1, af,
396 $ af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
397 $ iwork, x, lda, info )
398 ainvnm = max( ainvnm, dzasum( n, x, 1 ) )
399 60 CONTINUE
400*
401* Compute the infinity-norm condition number of A.
402*
403 IF( anormi.LE.zero .OR. ainvnm.LE.zero ) THEN
404 rcondi = one
405 ELSE
406 rcondi = ( one / anormi ) / ainvnm
407 END IF
408 END IF
409*
410 DO 110 itran = 1, 3
411 trans = transs( itran )
412 IF( itran.EQ.1 ) THEN
413 rcondc = rcondo
414 ELSE
415 rcondc = rcondi
416 END IF
417*
418* Generate NRHS random solution vectors.
419*
420 ix = 1
421 DO 70 j = 1, nrhs
422 CALL zlarnv( 2, iseed, n, xact( ix ) )
423 ix = ix + lda
424 70 CONTINUE
425*
426* Set the right hand side.
427*
428 CALL zlagtm( trans, n, nrhs, one, a, a( m+1 ),
429 $ a( n+m+1 ), xact, lda, zero, b, lda )
430*
431 IF( ifact.EQ.2 .AND. itran.EQ.1 ) THEN
432*
433* --- Test ZGTSV ---
434*
435* Solve the system using Gaussian elimination with
436* partial pivoting.
437*
438 CALL zcopy( n+2*m, a, 1, af, 1 )
439 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
440*
441 srnamt = 'ZGTSV '
442 CALL zgtsv( n, nrhs, af, af( m+1 ), af( n+m+1 ), x,
443 $ lda, info )
444*
445* Check error code from ZGTSV .
446*
447 IF( info.NE.izero )
448 $ CALL alaerh( path, 'ZGTSV ', info, izero, ' ',
449 $ n, n, 1, 1, nrhs, imat, nfail,
450 $ nerrs, nout )
451 nt = 1
452 IF( izero.EQ.0 ) THEN
453*
454* Check residual of computed solution.
455*
456 CALL zlacpy( 'Full', n, nrhs, b, lda, work,
457 $ lda )
458 CALL zgtt02( trans, n, nrhs, a, a( m+1 ),
459 $ a( n+m+1 ), x, lda, work, lda,
460 $ result( 2 ) )
461*
462* Check solution from generated exact solution.
463*
464 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
465 $ result( 3 ) )
466 nt = 3
467 END IF
468*
469* Print information about the tests that did not pass
470* the threshold.
471*
472 DO 80 k = 2, nt
473 IF( result( k ).GE.thresh ) THEN
474 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
475 $ CALL aladhd( nout, path )
476 WRITE( nout, fmt = 9999 )'ZGTSV ', n, imat,
477 $ k, result( k )
478 nfail = nfail + 1
479 END IF
480 80 CONTINUE
481 nrun = nrun + nt - 1
482 END IF
483*
484* --- Test ZGTSVX ---
485*
486 IF( ifact.GT.1 ) THEN
487*
488* Initialize AF to zero.
489*
490 DO 90 i = 1, 3*n - 2
491 af( i ) = zero
492 90 CONTINUE
493 END IF
494 CALL zlaset( 'Full', n, nrhs, dcmplx( zero ),
495 $ dcmplx( zero ), x, lda )
496*
497* Solve the system and compute the condition number and
498* error bounds using ZGTSVX.
499*
500 srnamt = 'ZGTSVX'
501 CALL zgtsvx( fact, trans, n, nrhs, a, a( m+1 ),
502 $ a( n+m+1 ), af, af( m+1 ), af( n+m+1 ),
503 $ af( n+2*m+1 ), iwork, b, lda, x, lda,
504 $ rcond, rwork, rwork( nrhs+1 ), work,
505 $ rwork( 2*nrhs+1 ), info )
506*
507* Check the error code from ZGTSVX.
508*
509 IF( info.NE.izero )
510 $ CALL alaerh( path, 'ZGTSVX', info, izero,
511 $ fact // trans, n, n, 1, 1, nrhs, imat,
512 $ nfail, nerrs, nout )
513*
514 IF( ifact.GE.2 ) THEN
515*
516* Reconstruct matrix from factors and compute
517* residual.
518*
519 CALL zgtt01( n, a, a( m+1 ), a( n+m+1 ), af,
520 $ af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
521 $ iwork, work, lda, rwork, result( 1 ) )
522 k1 = 1
523 ELSE
524 k1 = 2
525 END IF
526*
527 IF( info.EQ.0 ) THEN
528 trfcon = .false.
529*
530* Check residual of computed solution.
531*
532 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
533 CALL zgtt02( trans, n, nrhs, a, a( m+1 ),
534 $ a( n+m+1 ), x, lda, work, lda,
535 $ result( 2 ) )
536*
537* Check solution from generated exact solution.
538*
539 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
540 $ result( 3 ) )
541*
542* Check the error bounds from iterative refinement.
543*
544 CALL zgtt05( trans, n, nrhs, a, a( m+1 ),
545 $ a( n+m+1 ), b, lda, x, lda, xact, lda,
546 $ rwork, rwork( nrhs+1 ), result( 4 ) )
547 nt = 5
548 END IF
549*
550* Print information about the tests that did not pass
551* the threshold.
552*
553 DO 100 k = k1, nt
554 IF( result( k ).GE.thresh ) THEN
555 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
556 $ CALL aladhd( nout, path )
557 WRITE( nout, fmt = 9998 )'ZGTSVX', fact, trans,
558 $ n, imat, k, result( k )
559 nfail = nfail + 1
560 END IF
561 100 CONTINUE
562*
563* Check the reciprocal of the condition number.
564*
565 result( 6 ) = dget06( rcond, rcondc )
566 IF( result( 6 ).GE.thresh ) THEN
567 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
568 $ CALL aladhd( nout, path )
569 WRITE( nout, fmt = 9998 )'ZGTSVX', fact, trans, n,
570 $ imat, k, result( k )
571 nfail = nfail + 1
572 END IF
573 nrun = nrun + nt - k1 + 2
574*
575 110 CONTINUE
576 120 CONTINUE
577 130 CONTINUE
578 140 CONTINUE
579*
580* Print a summary of the results.
581*
582 CALL alasvm( path, nout, nfail, nrun, nerrs )
583*
584 9999 FORMAT( 1x, a, ', N =', i5, ', type ', i2, ', test ', i2,
585 $ ', ratio = ', g12.5 )
586 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', TRANS=''', a1, ''', N =',
587 $ i5, ', type ', i2, ', test ', i2, ', ratio = ', g12.5 )
588 RETURN
589*
590* End of ZDRVGT
591*
zgtsv
subroutine zgtsv(n, nrhs, dl, d, du, b, ldb, info)
ZGTSV computes the solution to system of linear equations A * X = B for GT matrices
Definition zgtsv.f:124
zgtsvx
subroutine zgtsvx(fact, trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
ZGTSVX computes the solution to system of linear equations A * X = B for GT matrices
Definition zgtsvx.f:294

◆ zdrvhe()

subroutine zdrvhe ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZDRVHE

ZDRVHEX

Purpose:
!>
!> ZDRVHE tests the driver routines ZHESV and -SVX.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Purpose:
!>
!> ZDRVHE tests the driver routines ZHESV, -SVX, and -SVXX.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise zdrvhe.f defines this subroutine.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (2*NMAX+2*NRHS)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 150 of file zdrvhe.f.

153*
154* -- LAPACK test routine --
155* -- LAPACK is a software package provided by Univ. of Tennessee, --
156* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
157*
158* .. Scalar Arguments ..
159 LOGICAL TSTERR
160 INTEGER NMAX, NN, NOUT, NRHS
161 DOUBLE PRECISION THRESH
162* ..
163* .. Array Arguments ..
164 LOGICAL DOTYPE( * )
165 INTEGER IWORK( * ), NVAL( * )
166 DOUBLE PRECISION RWORK( * )
167 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
168 $ WORK( * ), X( * ), XACT( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 DOUBLE PRECISION ONE, ZERO
175 parameter( one = 1.0d+0, zero = 0.0d+0 )
176 INTEGER NTYPES, NTESTS
177 parameter( ntypes = 10, ntests = 6 )
178 INTEGER NFACT
179 parameter( nfact = 2 )
180* ..
181* .. Local Scalars ..
182 LOGICAL ZEROT
183 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
184 CHARACTER*3 PATH
185 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
186 $ IZERO, J, K, K1, KL, KU, LDA, LWORK, MODE, N,
187 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
188 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC
189* ..
190* .. Local Arrays ..
191 CHARACTER FACTS( NFACT ), UPLOS( 2 )
192 INTEGER ISEED( 4 ), ISEEDY( 4 )
193 DOUBLE PRECISION RESULT( NTESTS )
194* ..
195* .. External Functions ..
196 DOUBLE PRECISION DGET06, ZLANHE
197 EXTERNAL dget06, zlanhe
198* ..
199* .. External Subroutines ..
200 EXTERNAL aladhd, alaerh, alasvm, xlaenv, zerrvx, zget04,
201 $ zhesv, zhesvx, zhet01, zhetrf, zhetri2, zlacpy,
202 $ zlaipd, zlarhs, zlaset, zlatb4, zlatms, zpot02,
203 $ zpot05
204* ..
205* .. Scalars in Common ..
206 LOGICAL LERR, OK
207 CHARACTER*32 SRNAMT
208 INTEGER INFOT, NUNIT
209* ..
210* .. Common blocks ..
211 COMMON / infoc / infot, nunit, ok, lerr
212 COMMON / srnamc / srnamt
213* ..
214* .. Intrinsic Functions ..
215 INTRINSIC dcmplx, max, min
216* ..
217* .. Data statements ..
218 DATA iseedy / 1988, 1989, 1990, 1991 /
219 DATA uplos / 'U', 'L' / , facts / 'F', 'N' /
220* ..
221* .. Executable Statements ..
222*
223* Initialize constants and the random number seed.
224*
225 path( 1: 1 ) = 'Zomplex precision'
226 path( 2: 3 ) = 'HE'
227 nrun = 0
228 nfail = 0
229 nerrs = 0
230 DO 10 i = 1, 4
231 iseed( i ) = iseedy( i )
232 10 CONTINUE
233 lwork = max( 2*nmax, nmax*nrhs )
234*
235* Test the error exits
236*
237 IF( tsterr )
238 $ CALL zerrvx( path, nout )
239 infot = 0
240*
241* Set the block size and minimum block size for testing.
242*
243 nb = 1
244 nbmin = 2
245 CALL xlaenv( 1, nb )
246 CALL xlaenv( 2, nbmin )
247*
248* Do for each value of N in NVAL
249*
250 DO 180 in = 1, nn
251 n = nval( in )
252 lda = max( n, 1 )
253 xtype = 'N'
254 nimat = ntypes
255 IF( n.LE.0 )
256 $ nimat = 1
257*
258 DO 170 imat = 1, nimat
259*
260* Do the tests only if DOTYPE( IMAT ) is true.
261*
262 IF( .NOT.dotype( imat ) )
263 $ GO TO 170
264*
265* Skip types 3, 4, 5, or 6 if the matrix size is too small.
266*
267 zerot = imat.GE.3 .AND. imat.LE.6
268 IF( zerot .AND. n.LT.imat-2 )
269 $ GO TO 170
270*
271* Do first for UPLO = 'U', then for UPLO = 'L'
272*
273 DO 160 iuplo = 1, 2
274 uplo = uplos( iuplo )
275*
276* Set up parameters with ZLATB4 and generate a test matrix
277* with ZLATMS.
278*
279 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
280 $ CNDNUM, DIST )
281*
282 srnamt = 'ZLATMS'
283 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
284 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
285 $ INFO )
286*
287* Check error code from ZLATMS.
288*
289 IF( info.NE.0 ) THEN
290 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n, -1,
291 $ -1, -1, imat, nfail, nerrs, nout )
292 GO TO 160
293 END IF
294*
295* For types 3-6, zero one or more rows and columns of the
296* matrix to test that INFO is returned correctly.
297*
298 IF( zerot ) THEN
299 IF( imat.EQ.3 ) THEN
300 izero = 1
301 ELSE IF( imat.EQ.4 ) THEN
302 izero = n
303 ELSE
304 izero = n / 2 + 1
305 END IF
306*
307 IF( imat.LT.6 ) THEN
308*
309* Set row and column IZERO to zero.
310*
311 IF( iuplo.EQ.1 ) THEN
312 ioff = ( izero-1 )*lda
313 DO 20 i = 1, izero - 1
314 a( ioff+i ) = zero
315 20 CONTINUE
316 ioff = ioff + izero
317 DO 30 i = izero, n
318 a( ioff ) = zero
319 ioff = ioff + lda
320 30 CONTINUE
321 ELSE
322 ioff = izero
323 DO 40 i = 1, izero - 1
324 a( ioff ) = zero
325 ioff = ioff + lda
326 40 CONTINUE
327 ioff = ioff - izero
328 DO 50 i = izero, n
329 a( ioff+i ) = zero
330 50 CONTINUE
331 END IF
332 ELSE
333 ioff = 0
334 IF( iuplo.EQ.1 ) THEN
335*
336* Set the first IZERO rows and columns to zero.
337*
338 DO 70 j = 1, n
339 i2 = min( j, izero )
340 DO 60 i = 1, i2
341 a( ioff+i ) = zero
342 60 CONTINUE
343 ioff = ioff + lda
344 70 CONTINUE
345 ELSE
346*
347* Set the last IZERO rows and columns to zero.
348*
349 DO 90 j = 1, n
350 i1 = max( j, izero )
351 DO 80 i = i1, n
352 a( ioff+i ) = zero
353 80 CONTINUE
354 ioff = ioff + lda
355 90 CONTINUE
356 END IF
357 END IF
358 ELSE
359 izero = 0
360 END IF
361*
362* Set the imaginary part of the diagonals.
363*
364 CALL zlaipd( n, a, lda+1, 0 )
365*
366 DO 150 ifact = 1, nfact
367*
368* Do first for FACT = 'F', then for other values.
369*
370 fact = facts( ifact )
371*
372* Compute the condition number for comparison with
373* the value returned by ZHESVX.
374*
375 IF( zerot ) THEN
376 IF( ifact.EQ.1 )
377 $ GO TO 150
378 rcondc = zero
379*
380 ELSE IF( ifact.EQ.1 ) THEN
381*
382* Compute the 1-norm of A.
383*
384 anorm = zlanhe( '1', uplo, n, a, lda, rwork )
385*
386* Factor the matrix A.
387*
388 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
389 CALL zhetrf( uplo, n, afac, lda, iwork, work,
390 $ lwork, info )
391*
392* Compute inv(A) and take its norm.
393*
394 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
395 lwork = (n+nb+1)*(nb+3)
396 CALL zhetri2( uplo, n, ainv, lda, iwork, work,
397 $ lwork, info )
398 ainvnm = zlanhe( '1', uplo, n, ainv, lda, rwork )
399*
400* Compute the 1-norm condition number of A.
401*
402 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
403 rcondc = one
404 ELSE
405 rcondc = ( one / anorm ) / ainvnm
406 END IF
407 END IF
408*
409* Form an exact solution and set the right hand side.
410*
411 srnamt = 'ZLARHS'
412 CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
413 $ nrhs, a, lda, xact, lda, b, lda, iseed,
414 $ info )
415 xtype = 'C'
416*
417* --- Test ZHESV ---
418*
419 IF( ifact.EQ.2 ) THEN
420 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
421 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
422*
423* Factor the matrix and solve the system using ZHESV.
424*
425 srnamt = 'ZHESV '
426 CALL zhesv( uplo, n, nrhs, afac, lda, iwork, x,
427 $ lda, work, lwork, info )
428*
429* Adjust the expected value of INFO to account for
430* pivoting.
431*
432 k = izero
433 IF( k.GT.0 ) THEN
434 100 CONTINUE
435 IF( iwork( k ).LT.0 ) THEN
436 IF( iwork( k ).NE.-k ) THEN
437 k = -iwork( k )
438 GO TO 100
439 END IF
440 ELSE IF( iwork( k ).NE.k ) THEN
441 k = iwork( k )
442 GO TO 100
443 END IF
444 END IF
445*
446* Check error code from ZHESV .
447*
448 IF( info.NE.k ) THEN
449 CALL alaerh( path, 'ZHESV ', info, k, uplo, n,
450 $ n, -1, -1, nrhs, imat, nfail,
451 $ nerrs, nout )
452 GO TO 120
453 ELSE IF( info.NE.0 ) THEN
454 GO TO 120
455 END IF
456*
457* Reconstruct matrix from factors and compute
458* residual.
459*
460 CALL zhet01( uplo, n, a, lda, afac, lda, iwork,
461 $ ainv, lda, rwork, result( 1 ) )
462*
463* Compute residual of the computed solution.
464*
465 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
466 CALL zpot02( uplo, n, nrhs, a, lda, x, lda, work,
467 $ lda, rwork, result( 2 ) )
468*
469* Check solution from generated exact solution.
470*
471 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
472 $ result( 3 ) )
473 nt = 3
474*
475* Print information about the tests that did not pass
476* the threshold.
477*
478 DO 110 k = 1, nt
479 IF( result( k ).GE.thresh ) THEN
480 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
481 $ CALL aladhd( nout, path )
482 WRITE( nout, fmt = 9999 )'ZHESV ', uplo, n,
483 $ imat, k, result( k )
484 nfail = nfail + 1
485 END IF
486 110 CONTINUE
487 nrun = nrun + nt
488 120 CONTINUE
489 END IF
490*
491* --- Test ZHESVX ---
492*
493 IF( ifact.EQ.2 )
494 $ CALL zlaset( uplo, n, n, dcmplx( zero ),
495 $ dcmplx( zero ), afac, lda )
496 CALL zlaset( 'Full', n, nrhs, dcmplx( zero ),
497 $ dcmplx( zero ), x, lda )
498*
499* Solve the system and compute the condition number and
500* error bounds using ZHESVX.
501*
502 srnamt = 'ZHESVX'
503 CALL zhesvx( fact, uplo, n, nrhs, a, lda, afac, lda,
504 $ iwork, b, lda, x, lda, rcond, rwork,
505 $ rwork( nrhs+1 ), work, lwork,
506 $ rwork( 2*nrhs+1 ), info )
507*
508* Adjust the expected value of INFO to account for
509* pivoting.
510*
511 k = izero
512 IF( k.GT.0 ) THEN
513 130 CONTINUE
514 IF( iwork( k ).LT.0 ) THEN
515 IF( iwork( k ).NE.-k ) THEN
516 k = -iwork( k )
517 GO TO 130
518 END IF
519 ELSE IF( iwork( k ).NE.k ) THEN
520 k = iwork( k )
521 GO TO 130
522 END IF
523 END IF
524*
525* Check the error code from ZHESVX.
526*
527 IF( info.NE.k ) THEN
528 CALL alaerh( path, 'ZHESVX', info, k, fact // uplo,
529 $ n, n, -1, -1, nrhs, imat, nfail,
530 $ nerrs, nout )
531 GO TO 150
532 END IF
533*
534 IF( info.EQ.0 ) THEN
535 IF( ifact.GE.2 ) THEN
536*
537* Reconstruct matrix from factors and compute
538* residual.
539*
540 CALL zhet01( uplo, n, a, lda, afac, lda, iwork,
541 $ ainv, lda, rwork( 2*nrhs+1 ),
542 $ result( 1 ) )
543 k1 = 1
544 ELSE
545 k1 = 2
546 END IF
547*
548* Compute residual of the computed solution.
549*
550 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
551 CALL zpot02( uplo, n, nrhs, a, lda, x, lda, work,
552 $ lda, rwork( 2*nrhs+1 ), result( 2 ) )
553*
554* Check solution from generated exact solution.
555*
556 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
557 $ result( 3 ) )
558*
559* Check the error bounds from iterative refinement.
560*
561 CALL zpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
562 $ xact, lda, rwork, rwork( nrhs+1 ),
563 $ result( 4 ) )
564 ELSE
565 k1 = 6
566 END IF
567*
568* Compare RCOND from ZHESVX with the computed value
569* in RCONDC.
570*
571 result( 6 ) = dget06( rcond, rcondc )
572*
573* Print information about the tests that did not pass
574* the threshold.
575*
576 DO 140 k = k1, 6
577 IF( result( k ).GE.thresh ) THEN
578 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
579 $ CALL aladhd( nout, path )
580 WRITE( nout, fmt = 9998 )'ZHESVX', fact, uplo,
581 $ n, imat, k, result( k )
582 nfail = nfail + 1
583 END IF
584 140 CONTINUE
585 nrun = nrun + 7 - k1
586*
587 150 CONTINUE
588*
589 160 CONTINUE
590 170 CONTINUE
591 180 CONTINUE
592*
593* Print a summary of the results.
594*
595 CALL alasvm( path, nout, nfail, nrun, nerrs )
596*
597 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
598 $ ', test ', i2, ', ratio =', g12.5 )
599 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N =', i5,
600 $ ', type ', i2, ', test ', i2, ', ratio =', g12.5 )
601 RETURN
602*
603* End of ZDRVHE
604*
zhesvx
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
Definition zhesvx.f:285
zhesv
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
Definition zhesv.f:171

◆ zdrvhe_aa()

subroutine zdrvhe_aa ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZDRVHE_AA

Purpose:
!>
!> ZDRVHE_AA tests the driver routine ZHESV_AA.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 150 of file zdrvhe_aa.f.

153*
154* -- LAPACK test routine --
155* -- LAPACK is a software package provided by Univ. of Tennessee, --
156* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
157*
158* .. Scalar Arguments ..
159 LOGICAL TSTERR
160 INTEGER NMAX, NN, NOUT, NRHS
161 DOUBLE PRECISION THRESH
162* ..
163* .. Array Arguments ..
164 LOGICAL DOTYPE( * )
165 INTEGER IWORK( * ), NVAL( * )
166 DOUBLE PRECISION RWORK( * )
167 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
168 $ WORK( * ), X( * ), XACT( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 DOUBLE PRECISION ONE, ZERO
175 parameter( one = 1.0d+0, zero = 0.0d+0 )
176 INTEGER NTYPES, NTESTS
177 parameter( ntypes = 10, ntests = 3 )
178 INTEGER NFACT
179 parameter( nfact = 2 )
180* ..
181* .. Local Scalars ..
182 LOGICAL ZEROT
183 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
184 CHARACTER*3 MATPATH, PATH
185 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
186 $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
187 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
188 DOUBLE PRECISION ANORM, CNDNUM
189* ..
190* .. Local Arrays ..
191 CHARACTER FACTS( NFACT ), UPLOS( 2 )
192 INTEGER ISEED( 4 ), ISEEDY( 4 )
193 DOUBLE PRECISION RESULT( NTESTS )
194* ..
195* .. External Functions ..
196 DOUBLE PRECISION DGET06, ZLANHE
197 EXTERNAL dget06, zlanhe
198* ..
199* .. External Subroutines ..
200 EXTERNAL aladhd, alaerh, alasvm, xlaenv, zerrvx, zget04,
201 $ zhesv_aa, zhet01_aa, zhetrf_aa,
202 $ zhetri2, zlacpy, zlaipd, zlarhs, zlatb4,
203 $ zlatms, zpot02
204* ..
205* .. Scalars in Common ..
206 LOGICAL LERR, OK
207 CHARACTER*32 SRNAMT
208 INTEGER INFOT, NUNIT
209* ..
210* .. Common blocks ..
211 COMMON / infoc / infot, nunit, ok, lerr
212 COMMON / srnamc / srnamt
213* ..
214* .. Intrinsic Functions ..
215 INTRINSIC dcmplx, max, min
216* ..
217* .. Data statements ..
218 DATA iseedy / 1988, 1989, 1990, 1991 /
219 DATA uplos / 'U', 'L' / , facts / 'F', 'N' /
220* ..
221* .. Executable Statements ..
222*
223* Initialize constants and the random number seed.
224*
225* Test path
226*
227 path( 1: 1 ) = 'Zomplex precision'
228 path( 2: 3 ) = 'HA'
229*
230* Path to generate matrices
231*
232 matpath( 1: 1 ) = 'Zomplex precision'
233 matpath( 2: 3 ) = 'HE'
234*
235 nrun = 0
236 nfail = 0
237 nerrs = 0
238 DO 10 i = 1, 4
239 iseed( i ) = iseedy( i )
240 10 CONTINUE
241*
242* Test the error exits
243*
244 IF( tsterr )
245 $ CALL zerrvx( path, nout )
246 infot = 0
247*
248* Set the block size and minimum block size for testing.
249*
250 nb = 1
251 nbmin = 2
252 CALL xlaenv( 1, nb )
253 CALL xlaenv( 2, nbmin )
254*
255* Do for each value of N in NVAL
256*
257 DO 180 in = 1, nn
258 n = nval( in )
259 lwork = max( 3*n-2, n*(1+nb) )
260 lwork = max( lwork, 1 )
261 lda = max( n, 1 )
262 xtype = 'N'
263 nimat = ntypes
264 IF( n.LE.0 )
265 $ nimat = 1
266*
267 DO 170 imat = 1, nimat
268*
269* Do the tests only if DOTYPE( IMAT ) is true.
270*
271 IF( .NOT.dotype( imat ) )
272 $ GO TO 170
273*
274* Skip types 3, 4, 5, or 6 if the matrix size is too small.
275*
276 zerot = imat.GE.3 .AND. imat.LE.6
277 IF( zerot .AND. n.LT.imat-2 )
278 $ GO TO 170
279*
280* Do first for UPLO = 'U', then for UPLO = 'L'
281*
282 DO 160 iuplo = 1, 2
283 uplo = uplos( iuplo )
284*
285* Begin generate the test matrix A.
286*
287* Set up parameters with ZLATB4 and generate a test matrix
288* with ZLATMS.
289*
290 CALL zlatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
291 $ MODE, CNDNUM, DIST )
292*
293 srnamt = 'ZLATMS'
294 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
295 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
296 $ INFO )
297*
298* Check error code from ZLATMS.
299*
300 IF( info.NE.0 ) THEN
301 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n, -1,
302 $ -1, -1, imat, nfail, nerrs, nout )
303 GO TO 160
304 END IF
305*
306* For types 3-6, zero one or more rows and columns of the
307* matrix to test that INFO is returned correctly.
308*
309 IF( zerot ) THEN
310 IF( imat.EQ.3 ) THEN
311 izero = 1
312 ELSE IF( imat.EQ.4 ) THEN
313 izero = n
314 ELSE
315 izero = n / 2 + 1
316 END IF
317*
318 IF( imat.LT.6 ) THEN
319*
320* Set row and column IZERO to zero.
321*
322 IF( iuplo.EQ.1 ) THEN
323 ioff = ( izero-1 )*lda
324 DO 20 i = 1, izero - 1
325 a( ioff+i ) = zero
326 20 CONTINUE
327 ioff = ioff + izero
328 DO 30 i = izero, n
329 a( ioff ) = zero
330 ioff = ioff + lda
331 30 CONTINUE
332 ELSE
333 ioff = izero
334 DO 40 i = 1, izero - 1
335 a( ioff ) = zero
336 ioff = ioff + lda
337 40 CONTINUE
338 ioff = ioff - izero
339 DO 50 i = izero, n
340 a( ioff+i ) = zero
341 50 CONTINUE
342 END IF
343 ELSE
344 ioff = 0
345 IF( iuplo.EQ.1 ) THEN
346*
347* Set the first IZERO rows and columns to zero.
348*
349 DO 70 j = 1, n
350 i2 = min( j, izero )
351 DO 60 i = 1, i2
352 a( ioff+i ) = zero
353 60 CONTINUE
354 ioff = ioff + lda
355 70 CONTINUE
356 izero = 1
357 ELSE
358*
359* Set the last IZERO rows and columns to zero.
360*
361 DO 90 j = 1, n
362 i1 = max( j, izero )
363 DO 80 i = i1, n
364 a( ioff+i ) = zero
365 80 CONTINUE
366 ioff = ioff + lda
367 90 CONTINUE
368 END IF
369 END IF
370 ELSE
371 izero = 0
372 END IF
373*
374* Set the imaginary part of the diagonals.
375*
376 CALL zlaipd( n, a, lda+1, 0 )
377*
378 DO 150 ifact = 1, nfact
379*
380* Do first for FACT = 'F', then for other values.
381*
382 fact = facts( ifact )
383*
384* Form an exact solution and set the right hand side.
385*
386 srnamt = 'ZLARHS'
387 CALL zlarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
388 $ nrhs, a, lda, xact, lda, b, lda, iseed,
389 $ info )
390 xtype = 'C'
391*
392* --- Test ZHESV_AA ---
393*
394 IF( ifact.EQ.2 ) THEN
395 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
396 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
397*
398* Factor the matrix and solve the system using ZHESV.
399*
400 srnamt = 'ZHESV_AA '
401 CALL zhesv_aa( uplo, n, nrhs, afac, lda, iwork,
402 $ x, lda, work, lwork, info )
403*
404* Adjust the expected value of INFO to account for
405* pivoting.
406*
407 IF( izero.GT.0 ) THEN
408 j = 1
409 k = izero
410 100 CONTINUE
411 IF( j.EQ.k ) THEN
412 k = iwork( j )
413 ELSE IF( iwork( j ).EQ.k ) THEN
414 k = j
415 END IF
416 IF( j.LT.k ) THEN
417 j = j + 1
418 GO TO 100
419 END IF
420 ELSE
421 k = 0
422 END IF
423*
424* Check error code from ZHESV .
425*
426 IF( info.NE.k ) THEN
427 CALL alaerh( path, 'ZHESV_AA', info, k, uplo, n,
428 $ n, -1, -1, nrhs, imat, nfail,
429 $ nerrs, nout )
430 GO TO 120
431 ELSE IF( info.NE.0 ) THEN
432 GO TO 120
433 END IF
434*
435* Reconstruct matrix from factors and compute
436* residual.
437*
438 CALL zhet01_aa( uplo, n, a, lda, afac, lda,
439 $ iwork, ainv, lda, rwork,
440 $ result( 1 ) )
441*
442* Compute residual of the computed solution.
443*
444 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
445 CALL zpot02( uplo, n, nrhs, a, lda, x, lda, work,
446 $ lda, rwork, result( 2 ) )
447 nt = 2
448*
449* Print information about the tests that did not pass
450* the threshold.
451*
452 DO 110 k = 1, nt
453 IF( result( k ).GE.thresh ) THEN
454 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
455 $ CALL aladhd( nout, path )
456 WRITE( nout, fmt = 9999 )'ZHESV_AA', uplo, n,
457 $ imat, k, result( k )
458 nfail = nfail + 1
459 END IF
460 110 CONTINUE
461 nrun = nrun + nt
462 120 CONTINUE
463 END IF
464*
465 150 CONTINUE
466*
467 160 CONTINUE
468 170 CONTINUE
469 180 CONTINUE
470*
471* Print a summary of the results.
472*
473 CALL alasvm( path, nout, nfail, nrun, nerrs )
474*
475 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
476 $ ', test ', i2, ', ratio =', g12.5 )
477 RETURN
478*
479* End of ZDRVHE_AA
480*
zhesv_aa
subroutine zhesv_aa(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
ZHESV_AA computes the solution to system of linear equations A * X = B for HE matrices
Definition zhesv_aa.f:162

◆ zdrvhe_aa_2stage()

subroutine zdrvhe_aa_2stage ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZDRVHE_AA_2STAGE

Purpose:
!>
!> ZDRVHE_AA_2STAGE tests the driver routine ZHESV_AA_2STAGE.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 151 of file zdrvhe_aa_2stage.f.

155*
156* -- LAPACK test routine --
157* -- LAPACK is a software package provided by Univ. of Tennessee, --
158* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
159*
160* .. Scalar Arguments ..
161 LOGICAL TSTERR
162 INTEGER NMAX, NN, NOUT, NRHS
163 DOUBLE PRECISION THRESH
164* ..
165* .. Array Arguments ..
166 LOGICAL DOTYPE( * )
167 INTEGER IWORK( * ), NVAL( * )
168 DOUBLE PRECISION RWORK( * )
169 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
170 $ WORK( * ), X( * ), XACT( * )
171* ..
172*
173* =====================================================================
174*
175* .. Parameters ..
176 DOUBLE PRECISION ONE, ZERO
177 parameter( one = 1.0d+0, zero = 0.0d+0 )
178 INTEGER NTYPES, NTESTS
179 parameter( ntypes = 10, ntests = 3 )
180 INTEGER NFACT
181 parameter( nfact = 2 )
182* ..
183* .. Local Scalars ..
184 LOGICAL ZEROT
185 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
186 CHARACTER*3 MATPATH, PATH
187 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
188 $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
189 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
190 DOUBLE PRECISION ANORM, CNDNUM
191* ..
192* .. Local Arrays ..
193 CHARACTER FACTS( NFACT ), UPLOS( 2 )
194 INTEGER ISEED( 4 ), ISEEDY( 4 )
195 DOUBLE PRECISION RESULT( NTESTS )
196* ..
197* .. External Functions ..
198 DOUBLE PRECISION DGET06, ZLANHE
199 EXTERNAL dget06, zlanhe
200* ..
201* .. External Subroutines ..
202 EXTERNAL aladhd, alaerh, alasvm, xlaenv, zerrvx,
203 $ zget04, zlacpy, zlarhs, zlatb4, zlatms,
204 $ zhesv_aa_2stage, zhet01_aa, zpot02,
205 $ zhetrf_aa_2stage
206* ..
207* .. Scalars in Common ..
208 LOGICAL LERR, OK
209 CHARACTER*32 SRNAMT
210 INTEGER INFOT, NUNIT
211* ..
212* .. Common blocks ..
213 COMMON / infoc / infot, nunit, ok, lerr
214 COMMON / srnamc / srnamt
215* ..
216* .. Intrinsic Functions ..
217 INTRINSIC dcmplx, max, min
218* ..
219* .. Data statements ..
220 DATA iseedy / 1988, 1989, 1990, 1991 /
221 DATA uplos / 'U', 'L' / , facts / 'F', 'N' /
222* ..
223* .. Executable Statements ..
224*
225* Initialize constants and the random number seed.
226*
227* Test path
228*
229 path( 1: 1 ) = 'Zomplex precision'
230 path( 2: 3 ) = 'H2'
231*
232* Path to generate matrices
233*
234 matpath( 1: 1 ) = 'Zomplex precision'
235 matpath( 2: 3 ) = 'HE'
236*
237 nrun = 0
238 nfail = 0
239 nerrs = 0
240 DO 10 i = 1, 4
241 iseed( i ) = iseedy( i )
242 10 CONTINUE
243*
244* Test the error exits
245*
246 IF( tsterr )
247 $ CALL zerrvx( path, nout )
248 infot = 0
249*
250* Set the block size and minimum block size for testing.
251*
252 nb = 1
253 nbmin = 2
254 CALL xlaenv( 1, nb )
255 CALL xlaenv( 2, nbmin )
256*
257* Do for each value of N in NVAL
258*
259 DO 180 in = 1, nn
260 n = nval( in )
261 lda = max( n, 1 )
262 xtype = 'N'
263 nimat = ntypes
264 IF( n.LE.0 )
265 $ nimat = 1
266*
267 DO 170 imat = 1, nimat
268*
269* Do the tests only if DOTYPE( IMAT ) is true.
270*
271 IF( .NOT.dotype( imat ) )
272 $ GO TO 170
273*
274* Skip types 3, 4, 5, or 6 if the matrix size is too small.
275*
276 zerot = imat.GE.3 .AND. imat.LE.6
277 IF( zerot .AND. n.LT.imat-2 )
278 $ GO TO 170
279*
280* Do first for UPLO = 'U', then for UPLO = 'L'
281*
282 DO 160 iuplo = 1, 2
283 uplo = uplos( iuplo )
284*
285* Begin generate the test matrix A.
286*
287* Set up parameters with ZLATB4 for the matrix generator
288* based on the type of matrix to be generated.
289*
290 CALL zlatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
291 $ MODE, CNDNUM, DIST )
292*
293* Generate a matrix with ZLATMS.
294*
295 srnamt = 'ZLATMS'
296 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
297 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
298 $ WORK, INFO )
299*
300* Check error code from ZLATMS and handle error.
301*
302 IF( info.NE.0 ) THEN
303 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n,
304 $ -1, -1, -1, imat, nfail, nerrs, nout )
305 GO TO 160
306 END IF
307*
308* For types 3-6, zero one or more rows and columns of
309* the matrix to test that INFO is returned correctly.
310*
311 IF( zerot ) THEN
312 IF( imat.EQ.3 ) THEN
313 izero = 1
314 ELSE IF( imat.EQ.4 ) THEN
315 izero = n
316 ELSE
317 izero = n / 2 + 1
318 END IF
319*
320 IF( imat.LT.6 ) THEN
321*
322* Set row and column IZERO to zero.
323*
324 IF( iuplo.EQ.1 ) THEN
325 ioff = ( izero-1 )*lda
326 DO 20 i = 1, izero - 1
327 a( ioff+i ) = zero
328 20 CONTINUE
329 ioff = ioff + izero
330 DO 30 i = izero, n
331 a( ioff ) = zero
332 ioff = ioff + lda
333 30 CONTINUE
334 ELSE
335 ioff = izero
336 DO 40 i = 1, izero - 1
337 a( ioff ) = zero
338 ioff = ioff + lda
339 40 CONTINUE
340 ioff = ioff - izero
341 DO 50 i = izero, n
342 a( ioff+i ) = zero
343 50 CONTINUE
344 END IF
345 ELSE
346 ioff = 0
347 IF( iuplo.EQ.1 ) THEN
348*
349* Set the first IZERO rows and columns to zero.
350*
351 DO 70 j = 1, n
352 i2 = min( j, izero )
353 DO 60 i = 1, i2
354 a( ioff+i ) = zero
355 60 CONTINUE
356 ioff = ioff + lda
357 70 CONTINUE
358 izero = 1
359 ELSE
360*
361* Set the first IZERO rows and columns to zero.
362*
363 ioff = 0
364 DO 90 j = 1, n
365 i1 = max( j, izero )
366 DO 80 i = i1, n
367 a( ioff+i ) = zero
368 80 CONTINUE
369 ioff = ioff + lda
370 90 CONTINUE
371 END IF
372 END IF
373 ELSE
374 izero = 0
375 END IF
376*
377* End generate the test matrix A.
378*
379*
380 DO 150 ifact = 1, nfact
381*
382* Do first for FACT = 'F', then for other values.
383*
384 fact = facts( ifact )
385*
386* Form an exact solution and set the right hand side.
387*
388 srnamt = 'ZLARHS'
389 CALL zlarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
390 $ nrhs, a, lda, xact, lda, b, lda, iseed,
391 $ info )
392 xtype = 'C'
393*
394* --- Test ZHESV_AA_2STAGE ---
395*
396 IF( ifact.EQ.2 ) THEN
397 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
398 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
399*
400* Factor the matrix and solve the system using ZHESV_AA.
401*
402 srnamt = 'ZHESV_AA_2STAGE '
403 lwork = min(n*nb, 3*nmax*nmax)
404 CALL zhesv_aa_2stage( uplo, n, nrhs, afac, lda,
405 $ ainv, (3*nb+1)*n,
406 $ iwork, iwork( 1+n ),
407 $ x, lda, work, lwork, info )
408*
409* Adjust the expected value of INFO to account for
410* pivoting.
411*
412 IF( izero.GT.0 ) THEN
413 j = 1
414 k = izero
415 100 CONTINUE
416 IF( j.EQ.k ) THEN
417 k = iwork( j )
418 ELSE IF( iwork( j ).EQ.k ) THEN
419 k = j
420 END IF
421 IF( j.LT.k ) THEN
422 j = j + 1
423 GO TO 100
424 END IF
425 ELSE
426 k = 0
427 END IF
428*
429* Check error code from ZHESV_AA .
430*
431 IF( info.NE.k ) THEN
432 CALL alaerh( path, 'ZHESV_AA', info, k,
433 $ uplo, n, n, -1, -1, nrhs,
434 $ imat, nfail, nerrs, nout )
435 GO TO 120
436 ELSE IF( info.NE.0 ) THEN
437 GO TO 120
438 END IF
439*
440* Compute residual of the computed solution.
441*
442 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
443 CALL zpot02( uplo, n, nrhs, a, lda, x, lda, work,
444 $ lda, rwork, result( 1 ) )
445*
446* Reconstruct matrix from factors and compute
447* residual.
448*
449* NEED TO CREATE ZHET01_AA_2STAGE
450* CALL ZHET01_AA( UPLO, N, A, LDA, AFAC, LDA,
451* $ IWORK, AINV, LDA, RWORK,
452* $ RESULT( 2 ) )
453* NT = 2
454 nt = 1
455*
456* Print information about the tests that did not pass
457* the threshold.
458*
459 DO 110 k = 1, nt
460 IF( result( k ).GE.thresh ) THEN
461 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
462 $ CALL aladhd( nout, path )
463 WRITE( nout, fmt = 9999 )'ZHESV_AA_2STAGE',
464 $ uplo, n, imat, k, result( k )
465 nfail = nfail + 1
466 END IF
467 110 CONTINUE
468 nrun = nrun + nt
469 120 CONTINUE
470 END IF
471*
472 150 CONTINUE
473*
474 160 CONTINUE
475 170 CONTINUE
476 180 CONTINUE
477*
478* Print a summary of the results.
479*
480 CALL alasvm( path, nout, nfail, nrun, nerrs )
481*
482 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
483 $ ', test ', i2, ', ratio =', g12.5 )
484 RETURN
485*
486* End of ZDRVHE_AA_2STAGE
487*
zhesv_aa_2stage
subroutine zhesv_aa_2stage(uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, work, lwork, info)
ZHESV_AA_2STAGE computes the solution to system of linear equations A * X = B for HE matrices
Definition zhesv_aa_2stage.f:187

◆ zdrvhe_rk()

subroutine zdrvhe_rk ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) e,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZDRVHE_RK

Purpose:
!>
!> ZDRVHE_RK tests the driver routines ZHESV_RK.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]E
!>          E is COMPLEX*16 array, dimension (NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 155 of file zdrvhe_rk.f.

158*
159* -- LAPACK test routine --
160* -- LAPACK is a software package provided by Univ. of Tennessee, --
161* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
162*
163* .. Scalar Arguments ..
164 LOGICAL TSTERR
165 INTEGER NMAX, NN, NOUT, NRHS
166 DOUBLE PRECISION THRESH
167* ..
168* .. Array Arguments ..
169 LOGICAL DOTYPE( * )
170 INTEGER IWORK( * ), NVAL( * )
171 DOUBLE PRECISION RWORK( * )
172 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
173 $ WORK( * ), X( * ), XACT( * )
174* ..
175*
176* =====================================================================
177*
178* .. Parameters ..
179 DOUBLE PRECISION ONE, ZERO
180 parameter( one = 1.0d+0, zero = 0.0d+0 )
181 INTEGER NTYPES, NTESTS
182 parameter( ntypes = 10, ntests = 3 )
183 INTEGER NFACT
184 parameter( nfact = 2 )
185* ..
186* .. Local Scalars ..
187 LOGICAL ZEROT
188 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
189 CHARACTER*3 MATPATH, PATH
190 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
191 $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
192 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
193 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC
194* ..
195* .. Local Arrays ..
196 CHARACTER FACTS( NFACT ), UPLOS( 2 )
197 INTEGER ISEED( 4 ), ISEEDY( 4 )
198 DOUBLE PRECISION RESULT( NTESTS )
199
200* ..
201* .. External Functions ..
202 DOUBLE PRECISION ZLANHE
203 EXTERNAL zlanhe
204* ..
205* .. External Subroutines ..
206 EXTERNAL aladhd, alaerh, alasvm, xlaenv, zerrvx,
207 $ zget04, zlacpy, zlarhs, zlatb4, zlatms,
208 $ zhesv_rk, zhet01_3, zpot02, zhetrf_rk, zhetri_3
209* ..
210* .. Scalars in Common ..
211 LOGICAL LERR, OK
212 CHARACTER*32 SRNAMT
213 INTEGER INFOT, NUNIT
214* ..
215* .. Common blocks ..
216 COMMON / infoc / infot, nunit, ok, lerr
217 COMMON / srnamc / srnamt
218* ..
219* .. Intrinsic Functions ..
220 INTRINSIC max, min
221* ..
222* .. Data statements ..
223 DATA iseedy / 1988, 1989, 1990, 1991 /
224 DATA uplos / 'U', 'L' / , facts / 'F', 'N' /
225* ..
226* .. Executable Statements ..
227*
228* Initialize constants and the random number seed.
229*
230* Test path
231*
232 path( 1: 1 ) = 'Zomplex precision'
233 path( 2: 3 ) = 'HK'
234*
235* Path to generate matrices
236*
237 matpath( 1: 1 ) = 'Zomplex precision'
238 matpath( 2: 3 ) = 'HE'
239*
240 nrun = 0
241 nfail = 0
242 nerrs = 0
243 DO 10 i = 1, 4
244 iseed( i ) = iseedy( i )
245 10 CONTINUE
246 lwork = max( 2*nmax, nmax*nrhs )
247*
248* Test the error exits
249*
250 IF( tsterr )
251 $ CALL zerrvx( path, nout )
252 infot = 0
253*
254* Set the block size and minimum block size for which the block
255* routine should be used, which will be later returned by ILAENV.
256*
257 nb = 1
258 nbmin = 2
259 CALL xlaenv( 1, nb )
260 CALL xlaenv( 2, nbmin )
261*
262* Do for each value of N in NVAL
263*
264 DO 180 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 170 imat = 1, nimat
273*
274* Do the tests only if DOTYPE( IMAT ) is true.
275*
276 IF( .NOT.dotype( imat ) )
277 $ GO TO 170
278*
279* Skip types 3, 4, 5, or 6 if the matrix size is too small.
280*
281 zerot = imat.GE.3 .AND. imat.LE.6
282 IF( zerot .AND. n.LT.imat-2 )
283 $ GO TO 170
284*
285* Do first for UPLO = 'U', then for UPLO = 'L'
286*
287 DO 160 iuplo = 1, 2
288 uplo = uplos( iuplo )
289*
290* Begin generate the test matrix A.
291*
292* Set up parameters with ZLATB4 for the matrix generator
293* based on the type of matrix to be generated.
294*
295 CALL zlatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
296 $ MODE, CNDNUM, DIST )
297*
298* Generate a matrix with ZLATMS.
299*
300 srnamt = 'ZLATMS'
301 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
302 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
303 $ WORK, INFO )
304*
305* Check error code from ZLATMS and handle error.
306*
307 IF( info.NE.0 ) THEN
308 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n,
309 $ -1, -1, -1, imat, nfail, nerrs, nout )
310 GO TO 160
311 END IF
312*
313* For types 3-6, zero one or more rows and columns of
314* the matrix to test that INFO is returned correctly.
315*
316 IF( zerot ) THEN
317 IF( imat.EQ.3 ) THEN
318 izero = 1
319 ELSE IF( imat.EQ.4 ) THEN
320 izero = n
321 ELSE
322 izero = n / 2 + 1
323 END IF
324*
325 IF( imat.LT.6 ) THEN
326*
327* Set row and column IZERO to zero.
328*
329 IF( iuplo.EQ.1 ) THEN
330 ioff = ( izero-1 )*lda
331 DO 20 i = 1, izero - 1
332 a( ioff+i ) = zero
333 20 CONTINUE
334 ioff = ioff + izero
335 DO 30 i = izero, n
336 a( ioff ) = zero
337 ioff = ioff + lda
338 30 CONTINUE
339 ELSE
340 ioff = izero
341 DO 40 i = 1, izero - 1
342 a( ioff ) = zero
343 ioff = ioff + lda
344 40 CONTINUE
345 ioff = ioff - izero
346 DO 50 i = izero, n
347 a( ioff+i ) = zero
348 50 CONTINUE
349 END IF
350 ELSE
351 IF( iuplo.EQ.1 ) THEN
352*
353* Set the first IZERO rows and columns to zero.
354*
355 ioff = 0
356 DO 70 j = 1, n
357 i2 = min( j, izero )
358 DO 60 i = 1, i2
359 a( ioff+i ) = zero
360 60 CONTINUE
361 ioff = ioff + lda
362 70 CONTINUE
363 ELSE
364*
365* Set the first IZERO rows and columns to zero.
366*
367 ioff = 0
368 DO 90 j = 1, n
369 i1 = max( j, izero )
370 DO 80 i = i1, n
371 a( ioff+i ) = zero
372 80 CONTINUE
373 ioff = ioff + lda
374 90 CONTINUE
375 END IF
376 END IF
377 ELSE
378 izero = 0
379 END IF
380*
381* End generate the test matrix A.
382*
383*
384 DO 150 ifact = 1, nfact
385*
386* Do first for FACT = 'F', then for other values.
387*
388 fact = facts( ifact )
389*
390* Compute the condition number
391*
392 IF( zerot ) THEN
393 IF( ifact.EQ.1 )
394 $ GO TO 150
395 rcondc = zero
396*
397 ELSE IF( ifact.EQ.1 ) THEN
398*
399* Compute the 1-norm of A.
400*
401 anorm = zlanhe( '1', uplo, n, a, lda, rwork )
402*
403* Factor the matrix A.
404*
405
406 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
407 CALL zhetrf_rk( uplo, n, afac, lda, e, iwork, work,
408 $ lwork, info )
409*
410* Compute inv(A) and take its norm.
411*
412 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
413 lwork = (n+nb+1)*(nb+3)
414*
415* We need to compute the inverse to compute
416* RCONDC that is used later in TEST3.
417*
418 CALL zhetri_3( uplo, n, ainv, lda, e, iwork,
419 $ work, lwork, info )
420 ainvnm = zlanhe( '1', uplo, n, ainv, lda, rwork )
421*
422* Compute the 1-norm condition number of A.
423*
424 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
425 rcondc = one
426 ELSE
427 rcondc = ( one / anorm ) / ainvnm
428 END IF
429 END IF
430*
431* Form an exact solution and set the right hand side.
432*
433 srnamt = 'ZLARHS'
434 CALL zlarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
435 $ nrhs, a, lda, xact, lda, b, lda, iseed,
436 $ info )
437 xtype = 'C'
438*
439* --- Test ZHESV_RK ---
440*
441 IF( ifact.EQ.2 ) THEN
442 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
443 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
444*
445* Factor the matrix and solve the system using
446* ZHESV_RK.
447*
448 srnamt = 'ZHESV_RK'
449 CALL zhesv_rk( uplo, n, nrhs, afac, lda, e, iwork,
450 $ x, lda, work, lwork, info )
451*
452* Adjust the expected value of INFO to account for
453* pivoting.
454*
455 k = izero
456 IF( k.GT.0 ) THEN
457 100 CONTINUE
458 IF( iwork( k ).LT.0 ) THEN
459 IF( iwork( k ).NE.-k ) THEN
460 k = -iwork( k )
461 GO TO 100
462 END IF
463 ELSE IF( iwork( k ).NE.k ) THEN
464 k = iwork( k )
465 GO TO 100
466 END IF
467 END IF
468*
469* Check error code from ZHESV_RK and handle error.
470*
471 IF( info.NE.k ) THEN
472 CALL alaerh( path, 'ZHESV_RK', info, k, uplo,
473 $ n, n, -1, -1, nrhs, imat, nfail,
474 $ nerrs, nout )
475 GO TO 120
476 ELSE IF( info.NE.0 ) THEN
477 GO TO 120
478 END IF
479*
480*+ TEST 1 Reconstruct matrix from factors and compute
481* residual.
482*
483 CALL zhet01_3( uplo, n, a, lda, afac, lda, e,
484 $ iwork, ainv, lda, rwork,
485 $ result( 1 ) )
486*
487*+ TEST 2 Compute residual of the computed solution.
488*
489 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
490 CALL zpot02( uplo, n, nrhs, a, lda, x, lda, work,
491 $ lda, rwork, result( 2 ) )
492*
493*+ TEST 3
494* Check solution from generated exact solution.
495*
496 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
497 $ result( 3 ) )
498 nt = 3
499*
500* Print information about the tests that did not pass
501* the threshold.
502*
503 DO 110 k = 1, nt
504 IF( result( k ).GE.thresh ) THEN
505 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
506 $ CALL aladhd( nout, path )
507 WRITE( nout, fmt = 9999 )'ZHESV_RK', uplo,
508 $ n, imat, k, result( k )
509 nfail = nfail + 1
510 END IF
511 110 CONTINUE
512 nrun = nrun + nt
513 120 CONTINUE
514 END IF
515*
516 150 CONTINUE
517*
518 160 CONTINUE
519 170 CONTINUE
520 180 CONTINUE
521*
522* Print a summary of the results.
523*
524 CALL alasvm( path, nout, nfail, nrun, nerrs )
525*
526 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
527 $ ', test ', i2, ', ratio =', g12.5 )
528 RETURN
529*
530* End of ZDRVHE_RK
531*
zhesv_rk
subroutine zhesv_rk(uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work, lwork, info)
ZHESV_RK computes the solution to system of linear equations A * X = B for SY matrices
Definition zhesv_rk.f:228

◆ zdrvhe_rook()

subroutine zdrvhe_rook ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZDRVHE_ROOK

Purpose:
!>
!> ZDRVHE_ROOK tests the driver routines ZHESV_ROOK.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 150 of file zdrvhe_rook.f.

153*
154* -- LAPACK test routine --
155* -- LAPACK is a software package provided by Univ. of Tennessee, --
156* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
157*
158* .. Scalar Arguments ..
159 LOGICAL TSTERR
160 INTEGER NMAX, NN, NOUT, NRHS
161 DOUBLE PRECISION THRESH
162* ..
163* .. Array Arguments ..
164 LOGICAL DOTYPE( * )
165 INTEGER IWORK( * ), NVAL( * )
166 DOUBLE PRECISION RWORK( * )
167 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
168 $ WORK( * ), X( * ), XACT( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 DOUBLE PRECISION ONE, ZERO
175 parameter( one = 1.0d+0, zero = 0.0d+0 )
176 INTEGER NTYPES, NTESTS
177 parameter( ntypes = 10, ntests = 3 )
178 INTEGER NFACT
179 parameter( nfact = 2 )
180* ..
181* .. Local Scalars ..
182 LOGICAL ZEROT
183 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
184 CHARACTER*3 MATPATH, PATH
185 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
186 $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
187 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
188 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC
189* ..
190* .. Local Arrays ..
191 CHARACTER FACTS( NFACT ), UPLOS( 2 )
192 INTEGER ISEED( 4 ), ISEEDY( 4 )
193 DOUBLE PRECISION RESULT( NTESTS )
194
195* ..
196* .. External Functions ..
197 DOUBLE PRECISION ZLANHE
198 EXTERNAL zlanhe
199* ..
200* .. External Subroutines ..
201 EXTERNAL aladhd, alaerh, alasvm, xlaenv, zerrvx,
202 $ zget04, zlacpy, zlarhs, zlatb4, zlatms,
203 $ zhesv_rook, zhet01_rook, zpot02,
204 $ zhetrf_rook, zhetri_rook
205* ..
206* .. Scalars in Common ..
207 LOGICAL LERR, OK
208 CHARACTER*32 SRNAMT
209 INTEGER INFOT, NUNIT
210* ..
211* .. Common blocks ..
212 COMMON / infoc / infot, nunit, ok, lerr
213 COMMON / srnamc / srnamt
214* ..
215* .. Intrinsic Functions ..
216 INTRINSIC max, min
217* ..
218* .. Data statements ..
219 DATA iseedy / 1988, 1989, 1990, 1991 /
220 DATA uplos / 'U', 'L' / , facts / 'F', 'N' /
221* ..
222* .. Executable Statements ..
223*
224* Initialize constants and the random number seed.
225*
226* Test path
227*
228 path( 1: 1 ) = 'Zomplex precision'
229 path( 2: 3 ) = 'HR'
230*
231* Path to generate matrices
232*
233 matpath( 1: 1 ) = 'Zomplex precision'
234 matpath( 2: 3 ) = 'HE'
235*
236 nrun = 0
237 nfail = 0
238 nerrs = 0
239 DO 10 i = 1, 4
240 iseed( i ) = iseedy( i )
241 10 CONTINUE
242 lwork = max( 2*nmax, nmax*nrhs )
243*
244* Test the error exits
245*
246 IF( tsterr )
247 $ CALL zerrvx( path, nout )
248 infot = 0
249*
250* Set the block size and minimum block size for which the block
251* routine should be used, which will be later returned by ILAENV.
252*
253 nb = 1
254 nbmin = 2
255 CALL xlaenv( 1, nb )
256 CALL xlaenv( 2, nbmin )
257*
258* Do for each value of N in NVAL
259*
260 DO 180 in = 1, nn
261 n = nval( in )
262 lda = max( n, 1 )
263 xtype = 'N'
264 nimat = ntypes
265 IF( n.LE.0 )
266 $ nimat = 1
267*
268 DO 170 imat = 1, nimat
269*
270* Do the tests only if DOTYPE( IMAT ) is true.
271*
272 IF( .NOT.dotype( imat ) )
273 $ GO TO 170
274*
275* Skip types 3, 4, 5, or 6 if the matrix size is too small.
276*
277 zerot = imat.GE.3 .AND. imat.LE.6
278 IF( zerot .AND. n.LT.imat-2 )
279 $ GO TO 170
280*
281* Do first for UPLO = 'U', then for UPLO = 'L'
282*
283 DO 160 iuplo = 1, 2
284 uplo = uplos( iuplo )
285*
286* Begin generate the test matrix A.
287*
288* Set up parameters with ZLATB4 for the matrix generator
289* based on the type of matrix to be generated.
290*
291 CALL zlatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
292 $ MODE, CNDNUM, DIST )
293*
294* Generate a matrix with ZLATMS.
295*
296 srnamt = 'ZLATMS'
297 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
298 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
299 $ WORK, INFO )
300*
301* Check error code from ZLATMS and handle error.
302*
303 IF( info.NE.0 ) THEN
304 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n,
305 $ -1, -1, -1, imat, nfail, nerrs, nout )
306 GO TO 160
307 END IF
308*
309* For types 3-6, zero one or more rows and columns of
310* the matrix to test that INFO is returned correctly.
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*
321 IF( imat.LT.6 ) THEN
322*
323* Set row and column IZERO to zero.
324*
325 IF( iuplo.EQ.1 ) THEN
326 ioff = ( izero-1 )*lda
327 DO 20 i = 1, izero - 1
328 a( ioff+i ) = zero
329 20 CONTINUE
330 ioff = ioff + izero
331 DO 30 i = izero, n
332 a( ioff ) = zero
333 ioff = ioff + lda
334 30 CONTINUE
335 ELSE
336 ioff = izero
337 DO 40 i = 1, izero - 1
338 a( ioff ) = zero
339 ioff = ioff + lda
340 40 CONTINUE
341 ioff = ioff - izero
342 DO 50 i = izero, n
343 a( ioff+i ) = zero
344 50 CONTINUE
345 END IF
346 ELSE
347 IF( iuplo.EQ.1 ) THEN
348*
349* Set the first IZERO rows and columns to zero.
350*
351 ioff = 0
352 DO 70 j = 1, n
353 i2 = min( j, izero )
354 DO 60 i = 1, i2
355 a( ioff+i ) = zero
356 60 CONTINUE
357 ioff = ioff + lda
358 70 CONTINUE
359 ELSE
360*
361* Set the first IZERO rows and columns to zero.
362*
363 ioff = 0
364 DO 90 j = 1, n
365 i1 = max( j, izero )
366 DO 80 i = i1, n
367 a( ioff+i ) = zero
368 80 CONTINUE
369 ioff = ioff + lda
370 90 CONTINUE
371 END IF
372 END IF
373 ELSE
374 izero = 0
375 END IF
376*
377* End generate the test matrix A.
378*
379*
380 DO 150 ifact = 1, nfact
381*
382* Do first for FACT = 'F', then for other values.
383*
384 fact = facts( ifact )
385*
386* Compute the condition number for comparison with
387* the value returned by ZHESVX_ROOK.
388*
389 IF( zerot ) THEN
390 IF( ifact.EQ.1 )
391 $ GO TO 150
392 rcondc = zero
393*
394 ELSE IF( ifact.EQ.1 ) THEN
395*
396* Compute the 1-norm of A.
397*
398 anorm = zlanhe( '1', uplo, n, a, lda, rwork )
399*
400* Factor the matrix A.
401*
402
403 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
404 CALL zhetrf_rook( uplo, n, afac, lda, iwork, work,
405 $ lwork, info )
406*
407* Compute inv(A) and take its norm.
408*
409 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
410 lwork = (n+nb+1)*(nb+3)
411 CALL zhetri_rook( uplo, n, ainv, lda, iwork,
412 $ work, info )
413 ainvnm = zlanhe( '1', uplo, n, ainv, lda, rwork )
414*
415* Compute the 1-norm condition number of A.
416*
417 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
418 rcondc = one
419 ELSE
420 rcondc = ( one / anorm ) / ainvnm
421 END IF
422 END IF
423*
424* Form an exact solution and set the right hand side.
425*
426 srnamt = 'ZLARHS'
427 CALL zlarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
428 $ nrhs, a, lda, xact, lda, b, lda, iseed,
429 $ info )
430 xtype = 'C'
431*
432* --- Test ZHESV_ROOK ---
433*
434 IF( ifact.EQ.2 ) THEN
435 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
436 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
437*
438* Factor the matrix and solve the system using
439* ZHESV_ROOK.
440*
441 srnamt = 'ZHESV_ROOK'
442 CALL zhesv_rook( uplo, n, nrhs, afac, lda, iwork,
443 $ x, lda, work, lwork, info )
444*
445* Adjust the expected value of INFO to account for
446* pivoting.
447*
448 k = izero
449 IF( k.GT.0 ) THEN
450 100 CONTINUE
451 IF( iwork( k ).LT.0 ) THEN
452 IF( iwork( k ).NE.-k ) THEN
453 k = -iwork( k )
454 GO TO 100
455 END IF
456 ELSE IF( iwork( k ).NE.k ) THEN
457 k = iwork( k )
458 GO TO 100
459 END IF
460 END IF
461*
462* Check error code from ZHESV_ROOK and handle error.
463*
464 IF( info.NE.k ) THEN
465 CALL alaerh( path, 'ZHESV_ROOK', info, k, uplo,
466 $ n, n, -1, -1, nrhs, imat, nfail,
467 $ nerrs, nout )
468 GO TO 120
469 ELSE IF( info.NE.0 ) THEN
470 GO TO 120
471 END IF
472*
473*+ TEST 1 Reconstruct matrix from factors and compute
474* residual.
475*
476 CALL zhet01_rook( uplo, n, a, lda, afac, lda,
477 $ iwork, ainv, lda, rwork,
478 $ result( 1 ) )
479*
480*+ TEST 2 Compute residual of the computed solution.
481*
482 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
483 CALL zpot02( uplo, n, nrhs, a, lda, x, lda, work,
484 $ lda, rwork, result( 2 ) )
485*
486*+ TEST 3
487* Check solution from generated exact solution.
488*
489 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
490 $ result( 3 ) )
491 nt = 3
492*
493* Print information about the tests that did not pass
494* the threshold.
495*
496 DO 110 k = 1, nt
497 IF( result( k ).GE.thresh ) THEN
498 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
499 $ CALL aladhd( nout, path )
500 WRITE( nout, fmt = 9999 )'ZHESV_ROOK', uplo,
501 $ n, imat, k, result( k )
502 nfail = nfail + 1
503 END IF
504 110 CONTINUE
505 nrun = nrun + nt
506 120 CONTINUE
507 END IF
508*
509 150 CONTINUE
510*
511 160 CONTINUE
512 170 CONTINUE
513 180 CONTINUE
514*
515* Print a summary of the results.
516*
517 CALL alasvm( path, nout, nfail, nrun, nerrs )
518*
519 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
520 $ ', test ', i2, ', ratio =', g12.5 )
521 RETURN
522*
523* End of ZDRVHE_ROOK
524*
zhesv_rook
subroutine zhesv_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
ZHESV_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using the ...
Definition zhesv_rook.f:205

◆ zdrvhp()

subroutine zdrvhp ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZDRVHP

Purpose:
!>
!> ZDRVHP tests the driver routines ZHPSV and -SVX.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 154 of file zdrvhp.f.

157*
158* -- LAPACK test routine --
159* -- LAPACK is a software package provided by Univ. of Tennessee, --
160* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
161*
162* .. Scalar Arguments ..
163 LOGICAL TSTERR
164 INTEGER NMAX, NN, NOUT, NRHS
165 DOUBLE PRECISION THRESH
166* ..
167* .. Array Arguments ..
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* .. Parameters ..
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* .. Local Scalars ..
186 LOGICAL ZEROT
187 CHARACTER DIST, FACT, PACKIT, 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, MODE, N, NB,
191 $ NBMIN, NERRS, NFAIL, NIMAT, NPP, NRUN, NT
192 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC
193* ..
194* .. Local Arrays ..
195 CHARACTER FACTS( NFACT )
196 INTEGER ISEED( 4 ), ISEEDY( 4 )
197 DOUBLE PRECISION RESULT( NTESTS )
198* ..
199* .. External Functions ..
200 DOUBLE PRECISION DGET06, ZLANHP
201 EXTERNAL dget06, zlanhp
202* ..
203* .. External Subroutines ..
204 EXTERNAL aladhd, alaerh, alasvm, xlaenv, zcopy, zerrvx,
205 $ zget04, zhpsv, zhpsvx, zhpt01, zhptrf, zhptri,
206 $ zlacpy, zlaipd, zlarhs, zlaset, zlatb4, zlatms,
207 $ zppt02, zppt05
208* ..
209* .. Scalars in Common ..
210 LOGICAL LERR, OK
211 CHARACTER*32 SRNAMT
212 INTEGER INFOT, NUNIT
213* ..
214* .. Common blocks ..
215 COMMON / infoc / infot, nunit, ok, lerr
216 COMMON / srnamc / srnamt
217* ..
218* .. Intrinsic Functions ..
219 INTRINSIC dcmplx, max, min
220* ..
221* .. Data statements ..
222 DATA iseedy / 1988, 1989, 1990, 1991 /
223 DATA facts / 'F', 'N' /
224* ..
225* .. Executable Statements ..
226*
227* Initialize constants and the random number seed.
228*
229 path( 1: 1 ) = 'Z'
230 path( 2: 3 ) = 'HP'
231 nrun = 0
232 nfail = 0
233 nerrs = 0
234 DO 10 i = 1, 4
235 iseed( i ) = iseedy( i )
236 10 CONTINUE
237*
238* Test the error exits
239*
240 IF( tsterr )
241 $ CALL zerrvx( path, nout )
242 infot = 0
243*
244* Set the block size and minimum block size for testing.
245*
246 nb = 1
247 nbmin = 2
248 CALL xlaenv( 1, nb )
249 CALL xlaenv( 2, nbmin )
250*
251* Do for each value of N in NVAL
252*
253 DO 180 in = 1, nn
254 n = nval( in )
255 lda = max( n, 1 )
256 npp = n*( n+1 ) / 2
257 xtype = 'N'
258 nimat = ntypes
259 IF( n.LE.0 )
260 $ nimat = 1
261*
262 DO 170 imat = 1, nimat
263*
264* Do the tests only if DOTYPE( IMAT ) is true.
265*
266 IF( .NOT.dotype( imat ) )
267 $ GO TO 170
268*
269* Skip types 3, 4, 5, or 6 if the matrix size is too small.
270*
271 zerot = imat.GE.3 .AND. imat.LE.6
272 IF( zerot .AND. n.LT.imat-2 )
273 $ GO TO 170
274*
275* Do first for UPLO = 'U', then for UPLO = 'L'
276*
277 DO 160 iuplo = 1, 2
278 IF( iuplo.EQ.1 ) THEN
279 uplo = 'U'
280 packit = 'C'
281 ELSE
282 uplo = 'L'
283 packit = 'R'
284 END IF
285*
286* Set up parameters with ZLATB4 and generate a test matrix
287* with ZLATMS.
288*
289 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
290 $ CNDNUM, DIST )
291*
292 srnamt = 'ZLATMS'
293 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
294 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
295 $ INFO )
296*
297* Check error code from ZLATMS.
298*
299 IF( info.NE.0 ) THEN
300 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n, -1,
301 $ -1, -1, imat, nfail, nerrs, nout )
302 GO TO 160
303 END IF
304*
305* For types 3-6, zero one or more rows and columns of the
306* matrix to test that INFO is returned correctly.
307*
308 IF( zerot ) THEN
309 IF( imat.EQ.3 ) THEN
310 izero = 1
311 ELSE IF( imat.EQ.4 ) THEN
312 izero = n
313 ELSE
314 izero = n / 2 + 1
315 END IF
316*
317 IF( imat.LT.6 ) THEN
318*
319* Set row and column IZERO to zero.
320*
321 IF( iuplo.EQ.1 ) THEN
322 ioff = ( izero-1 )*izero / 2
323 DO 20 i = 1, izero - 1
324 a( ioff+i ) = zero
325 20 CONTINUE
326 ioff = ioff + izero
327 DO 30 i = izero, n
328 a( ioff ) = zero
329 ioff = ioff + i
330 30 CONTINUE
331 ELSE
332 ioff = izero
333 DO 40 i = 1, izero - 1
334 a( ioff ) = zero
335 ioff = ioff + n - i
336 40 CONTINUE
337 ioff = ioff - izero
338 DO 50 i = izero, n
339 a( ioff+i ) = zero
340 50 CONTINUE
341 END IF
342 ELSE
343 ioff = 0
344 IF( iuplo.EQ.1 ) THEN
345*
346* Set the first IZERO rows and columns to zero.
347*
348 DO 70 j = 1, n
349 i2 = min( j, izero )
350 DO 60 i = 1, i2
351 a( ioff+i ) = zero
352 60 CONTINUE
353 ioff = ioff + j
354 70 CONTINUE
355 ELSE
356*
357* Set the last IZERO rows and columns to zero.
358*
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 + n - j
365 90 CONTINUE
366 END IF
367 END IF
368 ELSE
369 izero = 0
370 END IF
371*
372* Set the imaginary part of the diagonals.
373*
374 IF( iuplo.EQ.1 ) THEN
375 CALL zlaipd( n, a, 2, 1 )
376 ELSE
377 CALL zlaipd( n, a, n, -1 )
378 END IF
379*
380 DO 150 ifact = 1, nfact
381*
382* Do first for FACT = 'F', then for other values.
383*
384 fact = facts( ifact )
385*
386* Compute the condition number for comparison with
387* the value returned by ZHPSVX.
388*
389 IF( zerot ) THEN
390 IF( ifact.EQ.1 )
391 $ GO TO 150
392 rcondc = zero
393*
394 ELSE IF( ifact.EQ.1 ) THEN
395*
396* Compute the 1-norm of A.
397*
398 anorm = zlanhp( '1', uplo, n, a, rwork )
399*
400* Factor the matrix A.
401*
402 CALL zcopy( npp, a, 1, afac, 1 )
403 CALL zhptrf( uplo, n, afac, iwork, info )
404*
405* Compute inv(A) and take its norm.
406*
407 CALL zcopy( npp, afac, 1, ainv, 1 )
408 CALL zhptri( uplo, n, ainv, iwork, work, info )
409 ainvnm = zlanhp( '1', uplo, n, ainv, rwork )
410*
411* Compute the 1-norm condition number of A.
412*
413 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
414 rcondc = one
415 ELSE
416 rcondc = ( one / anorm ) / ainvnm
417 END IF
418 END IF
419*
420* Form an exact solution and set the right hand side.
421*
422 srnamt = 'ZLARHS'
423 CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
424 $ nrhs, a, lda, xact, lda, b, lda, iseed,
425 $ info )
426 xtype = 'C'
427*
428* --- Test ZHPSV ---
429*
430 IF( ifact.EQ.2 ) THEN
431 CALL zcopy( npp, a, 1, afac, 1 )
432 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
433*
434* Factor the matrix and solve the system using ZHPSV.
435*
436 srnamt = 'ZHPSV '
437 CALL zhpsv( uplo, n, nrhs, afac, iwork, x, lda,
438 $ info )
439*
440* Adjust the expected value of INFO to account for
441* pivoting.
442*
443 k = izero
444 IF( k.GT.0 ) THEN
445 100 CONTINUE
446 IF( iwork( k ).LT.0 ) THEN
447 IF( iwork( k ).NE.-k ) THEN
448 k = -iwork( k )
449 GO TO 100
450 END IF
451 ELSE IF( iwork( k ).NE.k ) THEN
452 k = iwork( k )
453 GO TO 100
454 END IF
455 END IF
456*
457* Check error code from ZHPSV .
458*
459 IF( info.NE.k ) THEN
460 CALL alaerh( path, 'ZHPSV ', info, k, uplo, n,
461 $ n, -1, -1, nrhs, imat, nfail,
462 $ nerrs, nout )
463 GO TO 120
464 ELSE IF( info.NE.0 ) THEN
465 GO TO 120
466 END IF
467*
468* Reconstruct matrix from factors and compute
469* residual.
470*
471 CALL zhpt01( uplo, n, a, afac, iwork, ainv, lda,
472 $ rwork, result( 1 ) )
473*
474* Compute residual of the computed solution.
475*
476 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
477 CALL zppt02( uplo, n, nrhs, a, x, lda, work, lda,
478 $ rwork, result( 2 ) )
479*
480* Check solution from generated exact solution.
481*
482 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
483 $ result( 3 ) )
484 nt = 3
485*
486* Print information about the tests that did not pass
487* the threshold.
488*
489 DO 110 k = 1, nt
490 IF( result( k ).GE.thresh ) THEN
491 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
492 $ CALL aladhd( nout, path )
493 WRITE( nout, fmt = 9999 )'ZHPSV ', uplo, n,
494 $ imat, k, result( k )
495 nfail = nfail + 1
496 END IF
497 110 CONTINUE
498 nrun = nrun + nt
499 120 CONTINUE
500 END IF
501*
502* --- Test ZHPSVX ---
503*
504 IF( ifact.EQ.2 .AND. npp.GT.0 )
505 $ CALL zlaset( 'Full', npp, 1, dcmplx( zero ),
506 $ dcmplx( zero ), afac, npp )
507 CALL zlaset( 'Full', n, nrhs, dcmplx( zero ),
508 $ dcmplx( zero ), x, lda )
509*
510* Solve the system and compute the condition number and
511* error bounds using ZHPSVX.
512*
513 srnamt = 'ZHPSVX'
514 CALL zhpsvx( fact, uplo, n, nrhs, a, afac, iwork, b,
515 $ lda, x, lda, rcond, rwork,
516 $ rwork( nrhs+1 ), work, rwork( 2*nrhs+1 ),
517 $ info )
518*
519* Adjust the expected value of INFO to account for
520* pivoting.
521*
522 k = izero
523 IF( k.GT.0 ) THEN
524 130 CONTINUE
525 IF( iwork( k ).LT.0 ) THEN
526 IF( iwork( k ).NE.-k ) THEN
527 k = -iwork( k )
528 GO TO 130
529 END IF
530 ELSE IF( iwork( k ).NE.k ) THEN
531 k = iwork( k )
532 GO TO 130
533 END IF
534 END IF
535*
536* Check the error code from ZHPSVX.
537*
538 IF( info.NE.k ) THEN
539 CALL alaerh( path, 'ZHPSVX', info, k, fact // uplo,
540 $ n, n, -1, -1, nrhs, imat, nfail,
541 $ nerrs, nout )
542 GO TO 150
543 END IF
544*
545 IF( info.EQ.0 ) THEN
546 IF( ifact.GE.2 ) THEN
547*
548* Reconstruct matrix from factors and compute
549* residual.
550*
551 CALL zhpt01( uplo, n, a, afac, iwork, ainv, lda,
552 $ rwork( 2*nrhs+1 ), result( 1 ) )
553 k1 = 1
554 ELSE
555 k1 = 2
556 END IF
557*
558* Compute residual of the computed solution.
559*
560 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
561 CALL zppt02( uplo, n, nrhs, a, x, lda, work, lda,
562 $ rwork( 2*nrhs+1 ), result( 2 ) )
563*
564* Check solution from generated exact solution.
565*
566 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
567 $ result( 3 ) )
568*
569* Check the error bounds from iterative refinement.
570*
571 CALL zppt05( uplo, n, nrhs, a, b, lda, x, lda,
572 $ xact, lda, rwork, rwork( nrhs+1 ),
573 $ result( 4 ) )
574 ELSE
575 k1 = 6
576 END IF
577*
578* Compare RCOND from ZHPSVX with the computed value
579* in RCONDC.
580*
581 result( 6 ) = dget06( rcond, rcondc )
582*
583* Print information about the tests that did not pass
584* the threshold.
585*
586 DO 140 k = k1, 6
587 IF( result( k ).GE.thresh ) THEN
588 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
589 $ CALL aladhd( nout, path )
590 WRITE( nout, fmt = 9998 )'ZHPSVX', fact, uplo,
591 $ n, imat, k, result( k )
592 nfail = nfail + 1
593 END IF
594 140 CONTINUE
595 nrun = nrun + 7 - k1
596*
597 150 CONTINUE
598*
599 160 CONTINUE
600 170 CONTINUE
601 180 CONTINUE
602*
603* Print a summary of the results.
604*
605 CALL alasvm( path, nout, nfail, nrun, nerrs )
606*
607 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
608 $ ', test ', i2, ', ratio =', g12.5 )
609 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N =', i5,
610 $ ', type ', i2, ', test ', i2, ', ratio =', g12.5 )
611 RETURN
612*
613* End of ZDRVHP
614*
zhpsvx
subroutine zhpsvx(fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
ZHPSVX computes the solution to system of linear equations A * X = B for OTHER matrices
Definition zhpsvx.f:277
zhpsv
subroutine zhpsv(uplo, n, nrhs, ap, ipiv, b, ldb, info)
ZHPSV computes the solution to system of linear equations A * X = B for OTHER matrices
Definition zhpsv.f:162

◆ zdrvls()

subroutine zdrvls ( logical, dimension( * ) dotype,
integer nm,
integer, dimension( * ) mval,
integer nn,
integer, dimension( * ) nval,
integer nns,
integer, dimension( * ) nsval,
integer nnb,
integer, dimension( * ) nbval,
integer, dimension( * ) nxval,
double precision thresh,
logical tsterr,
complex*16, dimension( * ) a,
complex*16, dimension( * ) copya,
complex*16, dimension( * ) b,
complex*16, dimension( * ) copyb,
complex*16, dimension( * ) c,
double precision, dimension( * ) s,
double precision, dimension( * ) copys,
integer nout )

ZDRVLS

Purpose:
!>
!> ZDRVLS tests the least squares driver routines ZGELS, ZGETSLS, ZGELSS, ZGELSY
!> and ZGELSD.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>          The matrix of type j is generated as follows:
!>          j=1: A = U*D*V where U and V are random unitary matrices
!>               and D has random entries (> 0.1) taken from a uniform
!>               distribution (0,1). A is full rank.
!>          j=2: The same of 1, but A is scaled up.
!>          j=3: The same of 1, but A is scaled down.
!>          j=4: A = U*D*V where U and V are random unitary matrices
!>               and D has 3*min(M,N)/4 random entries (> 0.1) taken
!>               from a uniform distribution (0,1) and the remaining
!>               entries set to 0. A is rank-deficient.
!>          j=5: The same of 4, but A is scaled up.
!>          j=6: The same of 5, but A is scaled down.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB and NX contained in the
!>          vectors NBVAL and NXVAL.  The blocking parameters are used
!>          in pairs (NB,NX).
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NXVAL
!>          NXVAL is INTEGER array, dimension (NNB)
!>          The values of the crossover point NX.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (MMAX*NMAX)
!>          where MMAX is the maximum value of M in MVAL and NMAX is the
!>          maximum value of N in NVAL.
!>
[out]COPYA
!>          COPYA is COMPLEX*16 array, dimension (MMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (MMAX*NSMAX)
!>          where MMAX is the maximum value of M in MVAL and NSMAX is the
!>          maximum value of NRHS in NSVAL.
!>
[out]COPYB
!>          COPYB is COMPLEX*16 array, dimension (MMAX*NSMAX)
!>
[out]C
!>          C is COMPLEX*16 array, dimension (MMAX*NSMAX)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension
!>                      (min(MMAX,NMAX))
!>
[out]COPYS
!>          COPYS is DOUBLE PRECISION array, dimension
!>                      (min(MMAX,NMAX))
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 189 of file zdrvls.f.

192*
193* -- LAPACK test routine --
194* -- LAPACK is a software package provided by Univ. of Tennessee, --
195* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
196*
197* .. Scalar Arguments ..
198 LOGICAL TSTERR
199 INTEGER NM, NN, NNB, NNS, NOUT
200 DOUBLE PRECISION THRESH
201* ..
202* .. Array Arguments ..
203 LOGICAL DOTYPE( * )
204 INTEGER MVAL( * ), NBVAL( * ), NSVAL( * ),
205 $ NVAL( * ), NXVAL( * )
206 DOUBLE PRECISION COPYS( * ), S( * )
207 COMPLEX*16 A( * ), B( * ), C( * ), COPYA( * ), COPYB( * )
208* ..
209*
210* =====================================================================
211*
212* .. Parameters ..
213 INTEGER NTESTS
214 parameter( ntests = 16 )
215 INTEGER SMLSIZ
216 parameter( smlsiz = 25 )
217 DOUBLE PRECISION ONE, ZERO
218 parameter( one = 1.0d+0, zero = 0.0d+0 )
219 COMPLEX*16 CONE, CZERO
220 parameter( cone = ( 1.0d+0, 0.0d+0 ),
221 $ czero = ( 0.0d+0, 0.0d+0 ) )
222* ..
223* .. Local Scalars ..
224 CHARACTER TRANS
225 CHARACTER*3 PATH
226 INTEGER CRANK, I, IM, IMB, IN, INB, INFO, INS, IRANK,
227 $ ISCALE, ITRAN, ITYPE, J, K, LDA, LDB, LDWORK,
228 $ LWLSY, LWORK, M, MNMIN, N, NB, NCOLS, NERRS,
229 $ NFAIL, NRHS, NROWS, NRUN, RANK, MB,
230 $ MMAX, NMAX, NSMAX, LIWORK, LRWORK,
231 $ LWORK_ZGELS, LWORK_ZGETSLS, LWORK_ZGELSS,
232 $ LWORK_ZGELSY, LWORK_ZGELSD,
233 $ LRWORK_ZGELSY, LRWORK_ZGELSS, LRWORK_ZGELSD
234 DOUBLE PRECISION EPS, NORMA, NORMB, RCOND
235* ..
236* .. Local Arrays ..
237 INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ( 1 )
238 DOUBLE PRECISION RESULT( NTESTS ), RWQ( 1 )
239 COMPLEX*16 WQ( 1 )
240* ..
241* .. Allocatable Arrays ..
242 COMPLEX*16, ALLOCATABLE :: WORK (:)
243 DOUBLE PRECISION, ALLOCATABLE :: RWORK (:), WORK2 (:)
244 INTEGER, ALLOCATABLE :: IWORK (:)
245* ..
246* .. External Functions ..
247 DOUBLE PRECISION DASUM, DLAMCH, ZQRT12, ZQRT14, ZQRT17
248 EXTERNAL dasum, dlamch, zqrt12, zqrt14, zqrt17
249* ..
250* .. External Subroutines ..
251 EXTERNAL alaerh, alahd, alasvm, daxpy, dlasrt, xlaenv,
252 $ zdscal, zerrls, zgels, zgelsd, zgelss,
253 $ zgelsy, zgemm, zlacpy, zlarnv, zqrt13, zqrt15,
254 $ zqrt16, zgetsls
255* ..
256* .. Intrinsic Functions ..
257 INTRINSIC dble, max, min, int, sqrt
258* ..
259* .. Scalars in Common ..
260 LOGICAL LERR, OK
261 CHARACTER*32 SRNAMT
262 INTEGER INFOT, IOUNIT
263* ..
264* .. Common blocks ..
265 COMMON / infoc / infot, iounit, ok, lerr
266 COMMON / srnamc / srnamt
267* ..
268* .. Data statements ..
269 DATA iseedy / 1988, 1989, 1990, 1991 /
270* ..
271* .. Executable Statements ..
272*
273* Initialize constants and the random number seed.
274*
275 path( 1: 1 ) = 'Zomplex precision'
276 path( 2: 3 ) = 'LS'
277 nrun = 0
278 nfail = 0
279 nerrs = 0
280 DO 10 i = 1, 4
281 iseed( i ) = iseedy( i )
282 10 CONTINUE
283 eps = dlamch( 'Epsilon' )
284*
285* Threshold for rank estimation
286*
287 rcond = sqrt( eps ) - ( sqrt( eps )-eps ) / 2
288*
289* Test the error exits
290*
291 CALL xlaenv( 9, smlsiz )
292 IF( tsterr )
293 $ CALL zerrls( path, nout )
294*
295* Print the header if NM = 0 or NN = 0 and THRESH = 0.
296*
297 IF( ( nm.EQ.0 .OR. nn.EQ.0 ) .AND. thresh.EQ.zero )
298 $ CALL alahd( nout, path )
299 infot = 0
300*
301* Compute maximal workspace needed for all routines
302*
303 nmax = 0
304 mmax = 0
305 nsmax = 0
306 DO i = 1, nm
307 IF ( mval( i ).GT.mmax ) THEN
308 mmax = mval( i )
309 END IF
310 ENDDO
311 DO i = 1, nn
312 IF ( nval( i ).GT.nmax ) THEN
313 nmax = nval( i )
314 END IF
315 ENDDO
316 DO i = 1, nns
317 IF ( nsval( i ).GT.nsmax ) THEN
318 nsmax = nsval( i )
319 END IF
320 ENDDO
321 m = mmax
322 n = nmax
323 nrhs = nsmax
324 mnmin = max( min( m, n ), 1 )
325*
326* Compute workspace needed for routines
327* ZQRT14, ZQRT17 (two side cases), ZQRT15 and ZQRT12
328*
329 lwork = max( 1, ( m+n )*nrhs,
330 $ ( n+nrhs )*( m+2 ), ( m+nrhs )*( n+2 ),
331 $ max( m+mnmin, nrhs*mnmin,2*n+m ),
332 $ max( m*n+4*mnmin+max(m,n), m*n+2*mnmin+4*n ) )
333 lrwork = 1
334 liwork = 1
335*
336* Iterate through all test cases and compute necessary workspace
337* sizes for ?GELS, ?GETSLS, ?GELSY, ?GELSS and ?GELSD routines.
338*
339 DO im = 1, nm
340 m = mval( im )
341 lda = max( 1, m )
342 DO in = 1, nn
343 n = nval( in )
344 mnmin = max(min( m, n ),1)
345 ldb = max( 1, m, n )
346 DO ins = 1, nns
347 nrhs = nsval( ins )
348 DO irank = 1, 2
349 DO iscale = 1, 3
350 itype = ( irank-1 )*3 + iscale
351 IF( dotype( itype ) ) THEN
352 IF( irank.EQ.1 ) THEN
353 DO itran = 1, 2
354 IF( itran.EQ.1 ) THEN
355 trans = 'N'
356 ELSE
357 trans = 'C'
358 END IF
359*
360* Compute workspace needed for ZGELS
361 CALL zgels( trans, m, n, nrhs, a, lda,
362 $ b, ldb, wq, -1, info )
363 lwork_zgels = int( wq( 1 ) )
364* Compute workspace needed for ZGETSLS
365 CALL zgetsls( trans, m, n, nrhs, a, lda,
366 $ b, ldb, wq, -1, info )
367 lwork_zgetsls = int( wq( 1 ) )
368 ENDDO
369 END IF
370* Compute workspace needed for ZGELSY
371 CALL zgelsy( m, n, nrhs, a, lda, b, ldb, iwq,
372 $ rcond, crank, wq, -1, rwq, info )
373 lwork_zgelsy = int( wq( 1 ) )
374 lrwork_zgelsy = 2*n
375* Compute workspace needed for ZGELSS
376 CALL zgelss( m, n, nrhs, a, lda, b, ldb, s,
377 $ rcond, crank, wq, -1 , rwq,
378 $ info )
379 lwork_zgelss = int( wq( 1 ) )
380 lrwork_zgelss = 5*mnmin
381* Compute workspace needed for ZGELSD
382 CALL zgelsd( m, n, nrhs, a, lda, b, ldb, s,
383 $ rcond, crank, wq, -1, rwq, iwq,
384 $ info )
385 lwork_zgelsd = int( wq( 1 ) )
386 lrwork_zgelsd = int( rwq( 1 ) )
387* Compute LIWORK workspace needed for ZGELSY and ZGELSD
388 liwork = max( liwork, n, iwq( 1 ) )
389* Compute LRWORK workspace needed for ZGELSY, ZGELSS and ZGELSD
390 lrwork = max( lrwork, lrwork_zgelsy,
391 $ lrwork_zgelss, lrwork_zgelsd )
392* Compute LWORK workspace needed for all functions
393 lwork = max( lwork, lwork_zgels, lwork_zgetsls,
394 $ lwork_zgelsy, lwork_zgelss,
395 $ lwork_zgelsd )
396 END IF
397 ENDDO
398 ENDDO
399 ENDDO
400 ENDDO
401 ENDDO
402*
403 lwlsy = lwork
404*
405 ALLOCATE( work( lwork ) )
406 ALLOCATE( work2( 2 * lwork ) )
407 ALLOCATE( iwork( liwork ) )
408 ALLOCATE( rwork( lrwork ) )
409*
410 DO 140 im = 1, nm
411 m = mval( im )
412 lda = max( 1, m )
413*
414 DO 130 in = 1, nn
415 n = nval( in )
416 mnmin = max(min( m, n ),1)
417 ldb = max( 1, m, n )
418 mb = (mnmin+1)
419*
420 DO 120 ins = 1, nns
421 nrhs = nsval( ins )
422*
423 DO 110 irank = 1, 2
424 DO 100 iscale = 1, 3
425 itype = ( irank-1 )*3 + iscale
426 IF( .NOT.dotype( itype ) )
427 $ GO TO 100
428*
429 IF( irank.EQ.1 ) THEN
430*
431* Test ZGELS
432*
433* Generate a matrix of scaling type ISCALE
434*
435 CALL zqrt13( iscale, m, n, copya, lda, norma,
436 $ iseed )
437 DO 40 inb = 1, nnb
438 nb = nbval( inb )
439 CALL xlaenv( 1, nb )
440 CALL xlaenv( 3, nxval( inb ) )
441*
442 DO 30 itran = 1, 2
443 IF( itran.EQ.1 ) THEN
444 trans = 'N'
445 nrows = m
446 ncols = n
447 ELSE
448 trans = 'C'
449 nrows = n
450 ncols = m
451 END IF
452 ldwork = max( 1, ncols )
453*
454* Set up a consistent rhs
455*
456 IF( ncols.GT.0 ) THEN
457 CALL zlarnv( 2, iseed, ncols*nrhs,
458 $ work )
459 CALL zdscal( ncols*nrhs,
460 $ one / dble( ncols ), work,
461 $ 1 )
462 END IF
463 CALL zgemm( trans, 'No transpose', nrows,
464 $ nrhs, ncols, cone, copya, lda,
465 $ work, ldwork, czero, b, ldb )
466 CALL zlacpy( 'Full', nrows, nrhs, b, ldb,
467 $ copyb, ldb )
468*
469* Solve LS or overdetermined system
470*
471 IF( m.GT.0 .AND. n.GT.0 ) THEN
472 CALL zlacpy( 'Full', m, n, copya, lda,
473 $ a, lda )
474 CALL zlacpy( 'Full', nrows, nrhs,
475 $ copyb, ldb, b, ldb )
476 END IF
477 srnamt = 'ZGELS '
478 CALL zgels( trans, m, n, nrhs, a, lda, b,
479 $ ldb, work, lwork, info )
480*
481 IF( info.NE.0 )
482 $ CALL alaerh( path, 'ZGELS ', info, 0,
483 $ trans, m, n, nrhs, -1, nb,
484 $ itype, nfail, nerrs,
485 $ nout )
486*
487* Check correctness of results
488*
489 ldwork = max( 1, nrows )
490 IF( nrows.GT.0 .AND. nrhs.GT.0 )
491 $ CALL zlacpy( 'Full', nrows, nrhs,
492 $ copyb, ldb, c, ldb )
493 CALL zqrt16( trans, m, n, nrhs, copya,
494 $ lda, b, ldb, c, ldb, rwork,
495 $ result( 1 ) )
496*
497 IF( ( itran.EQ.1 .AND. m.GE.n ) .OR.
498 $ ( itran.EQ.2 .AND. m.LT.n ) ) THEN
499*
500* Solving LS system
501*
502 result( 2 ) = zqrt17( trans, 1, m, n,
503 $ nrhs, copya, lda, b, ldb,
504 $ copyb, ldb, c, work,
505 $ lwork )
506 ELSE
507*
508* Solving overdetermined system
509*
510 result( 2 ) = zqrt14( trans, m, n,
511 $ nrhs, copya, lda, b, ldb,
512 $ work, lwork )
513 END IF
514*
515* Print information about the tests that
516* did not pass the threshold.
517*
518 DO 20 k = 1, 2
519 IF( result( k ).GE.thresh ) THEN
520 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
521 $ CALL alahd( nout, path )
522 WRITE( nout, fmt = 9999 )trans, m,
523 $ n, nrhs, nb, itype, k,
524 $ result( k )
525 nfail = nfail + 1
526 END IF
527 20 CONTINUE
528 nrun = nrun + 2
529 30 CONTINUE
530 40 CONTINUE
531*
532*
533* Test ZGETSLS
534*
535* Generate a matrix of scaling type ISCALE
536*
537 CALL zqrt13( iscale, m, n, copya, lda, norma,
538 $ iseed )
539 DO 65 inb = 1, nnb
540 mb = nbval( inb )
541 CALL xlaenv( 1, mb )
542 DO 62 imb = 1, nnb
543 nb = nbval( imb )
544 CALL xlaenv( 2, nb )
545*
546 DO 60 itran = 1, 2
547 IF( itran.EQ.1 ) THEN
548 trans = 'N'
549 nrows = m
550 ncols = n
551 ELSE
552 trans = 'C'
553 nrows = n
554 ncols = m
555 END IF
556 ldwork = max( 1, ncols )
557*
558* Set up a consistent rhs
559*
560 IF( ncols.GT.0 ) THEN
561 CALL zlarnv( 2, iseed, ncols*nrhs,
562 $ work )
563 CALL zscal( ncols*nrhs,
564 $ cone / dble( ncols ), work,
565 $ 1 )
566 END IF
567 CALL zgemm( trans, 'No transpose', nrows,
568 $ nrhs, ncols, cone, copya, lda,
569 $ work, ldwork, czero, b, ldb )
570 CALL zlacpy( 'Full', nrows, nrhs, b, ldb,
571 $ copyb, ldb )
572*
573* Solve LS or overdetermined system
574*
575 IF( m.GT.0 .AND. n.GT.0 ) THEN
576 CALL zlacpy( 'Full', m, n, copya, lda,
577 $ a, lda )
578 CALL zlacpy( 'Full', nrows, nrhs,
579 $ copyb, ldb, b, ldb )
580 END IF
581 srnamt = 'ZGETSLS '
582 CALL zgetsls( trans, m, n, nrhs, a,
583 $ lda, b, ldb, work, lwork, info )
584 IF( info.NE.0 )
585 $ CALL alaerh( path, 'ZGETSLS ', info, 0,
586 $ trans, m, n, nrhs, -1, nb,
587 $ itype, nfail, nerrs,
588 $ nout )
589*
590* Check correctness of results
591*
592 ldwork = max( 1, nrows )
593 IF( nrows.GT.0 .AND. nrhs.GT.0 )
594 $ CALL zlacpy( 'Full', nrows, nrhs,
595 $ copyb, ldb, c, ldb )
596 CALL zqrt16( trans, m, n, nrhs, copya,
597 $ lda, b, ldb, c, ldb, work2,
598 $ result( 15 ) )
599*
600 IF( ( itran.EQ.1 .AND. m.GE.n ) .OR.
601 $ ( itran.EQ.2 .AND. m.LT.n ) ) THEN
602*
603* Solving LS system
604*
605 result( 16 ) = zqrt17( trans, 1, m, n,
606 $ nrhs, copya, lda, b, ldb,
607 $ copyb, ldb, c, work,
608 $ lwork )
609 ELSE
610*
611* Solving overdetermined system
612*
613 result( 16 ) = zqrt14( trans, m, n,
614 $ nrhs, copya, lda, b, ldb,
615 $ work, lwork )
616 END IF
617*
618* Print information about the tests that
619* did not pass the threshold.
620*
621 DO 50 k = 15, 16
622 IF( result( k ).GE.thresh ) THEN
623 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
624 $ CALL alahd( nout, path )
625 WRITE( nout, fmt = 9997 )trans, m,
626 $ n, nrhs, mb, nb, itype, k,
627 $ result( k )
628 nfail = nfail + 1
629 END IF
630 50 CONTINUE
631 nrun = nrun + 2
632 60 CONTINUE
633 62 CONTINUE
634 65 CONTINUE
635 END IF
636*
637* Generate a matrix of scaling type ISCALE and rank
638* type IRANK.
639*
640 CALL zqrt15( iscale, irank, m, n, nrhs, copya, lda,
641 $ copyb, ldb, copys, rank, norma, normb,
642 $ iseed, work, lwork )
643*
644* workspace used: MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
645*
646 ldwork = max( 1, m )
647*
648* Loop for testing different block sizes.
649*
650 DO 90 inb = 1, nnb
651 nb = nbval( inb )
652 CALL xlaenv( 1, nb )
653 CALL xlaenv( 3, nxval( inb ) )
654*
655* Test ZGELSY
656*
657* ZGELSY: Compute the minimum-norm solution
658* X to min( norm( A * X - B ) )
659* using the rank-revealing orthogonal
660* factorization.
661*
662 CALL zlacpy( 'Full', m, n, copya, lda, a, lda )
663 CALL zlacpy( 'Full', m, nrhs, copyb, ldb, b,
664 $ ldb )
665*
666* Initialize vector IWORK.
667*
668 DO 70 j = 1, n
669 iwork( j ) = 0
670 70 CONTINUE
671*
672 srnamt = 'ZGELSY'
673 CALL zgelsy( m, n, nrhs, a, lda, b, ldb, iwork,
674 $ rcond, crank, work, lwlsy, rwork,
675 $ info )
676 IF( info.NE.0 )
677 $ CALL alaerh( path, 'ZGELSY', info, 0, ' ', m,
678 $ n, nrhs, -1, nb, itype, nfail,
679 $ nerrs, nout )
680*
681* workspace used: 2*MNMIN+NB*NB+NB*MAX(N,NRHS)
682*
683* Test 3: Compute relative error in svd
684* workspace: M*N + 4*MIN(M,N) + MAX(M,N)
685*
686 result( 3 ) = zqrt12( crank, crank, a, lda,
687 $ copys, work, lwork, rwork )
688*
689* Test 4: Compute error in solution
690* workspace: M*NRHS + M
691*
692 CALL zlacpy( 'Full', m, nrhs, copyb, ldb, work,
693 $ ldwork )
694 CALL zqrt16( 'No transpose', m, n, nrhs, copya,
695 $ lda, b, ldb, work, ldwork, rwork,
696 $ result( 4 ) )
697*
698* Test 5: Check norm of r'*A
699* workspace: NRHS*(M+N)
700*
701 result( 5 ) = zero
702 IF( m.GT.crank )
703 $ result( 5 ) = zqrt17( 'No transpose', 1, m,
704 $ n, nrhs, copya, lda, b, ldb,
705 $ copyb, ldb, c, work, lwork )
706*
707* Test 6: Check if x is in the rowspace of A
708* workspace: (M+NRHS)*(N+2)
709*
710 result( 6 ) = zero
711*
712 IF( n.GT.crank )
713 $ result( 6 ) = zqrt14( 'No transpose', m, n,
714 $ nrhs, copya, lda, b, ldb,
715 $ work, lwork )
716*
717* Test ZGELSS
718*
719* ZGELSS: Compute the minimum-norm solution
720* X to min( norm( A * X - B ) )
721* using the SVD.
722*
723 CALL zlacpy( 'Full', m, n, copya, lda, a, lda )
724 CALL zlacpy( 'Full', m, nrhs, copyb, ldb, b,
725 $ ldb )
726 srnamt = 'ZGELSS'
727 CALL zgelss( m, n, nrhs, a, lda, b, ldb, s,
728 $ rcond, crank, work, lwork, rwork,
729 $ info )
730*
731 IF( info.NE.0 )
732 $ CALL alaerh( path, 'ZGELSS', info, 0, ' ', m,
733 $ n, nrhs, -1, nb, itype, nfail,
734 $ nerrs, nout )
735*
736* workspace used: 3*min(m,n) +
737* max(2*min(m,n),nrhs,max(m,n))
738*
739* Test 7: Compute relative error in svd
740*
741 IF( rank.GT.0 ) THEN
742 CALL daxpy( mnmin, -one, copys, 1, s, 1 )
743 result( 7 ) = dasum( mnmin, s, 1 ) /
744 $ dasum( mnmin, copys, 1 ) /
745 $ ( eps*dble( mnmin ) )
746 ELSE
747 result( 7 ) = zero
748 END IF
749*
750* Test 8: Compute error in solution
751*
752 CALL zlacpy( 'Full', m, nrhs, copyb, ldb, work,
753 $ ldwork )
754 CALL zqrt16( 'No transpose', m, n, nrhs, copya,
755 $ lda, b, ldb, work, ldwork, rwork,
756 $ result( 8 ) )
757*
758* Test 9: Check norm of r'*A
759*
760 result( 9 ) = zero
761 IF( m.GT.crank )
762 $ result( 9 ) = zqrt17( 'No transpose', 1, m,
763 $ n, nrhs, copya, lda, b, ldb,
764 $ copyb, ldb, c, work, lwork )
765*
766* Test 10: Check if x is in the rowspace of A
767*
768 result( 10 ) = zero
769 IF( n.GT.crank )
770 $ result( 10 ) = zqrt14( 'No transpose', m, n,
771 $ nrhs, copya, lda, b, ldb,
772 $ work, lwork )
773*
774* Test ZGELSD
775*
776* ZGELSD: Compute the minimum-norm solution X
777* to min( norm( A * X - B ) ) using a
778* divide and conquer SVD.
779*
780 CALL xlaenv( 9, 25 )
781*
782 CALL zlacpy( 'Full', m, n, copya, lda, a, lda )
783 CALL zlacpy( 'Full', m, nrhs, copyb, ldb, b,
784 $ ldb )
785*
786 srnamt = 'ZGELSD'
787 CALL zgelsd( m, n, nrhs, a, lda, b, ldb, s,
788 $ rcond, crank, work, lwork, rwork,
789 $ iwork, info )
790 IF( info.NE.0 )
791 $ CALL alaerh( path, 'ZGELSD', info, 0, ' ', m,
792 $ n, nrhs, -1, nb, itype, nfail,
793 $ nerrs, nout )
794*
795* Test 11: Compute relative error in svd
796*
797 IF( rank.GT.0 ) THEN
798 CALL daxpy( mnmin, -one, copys, 1, s, 1 )
799 result( 11 ) = dasum( mnmin, s, 1 ) /
800 $ dasum( mnmin, copys, 1 ) /
801 $ ( eps*dble( mnmin ) )
802 ELSE
803 result( 11 ) = zero
804 END IF
805*
806* Test 12: Compute error in solution
807*
808 CALL zlacpy( 'Full', m, nrhs, copyb, ldb, work,
809 $ ldwork )
810 CALL zqrt16( 'No transpose', m, n, nrhs, copya,
811 $ lda, b, ldb, work, ldwork, rwork,
812 $ result( 12 ) )
813*
814* Test 13: Check norm of r'*A
815*
816 result( 13 ) = zero
817 IF( m.GT.crank )
818 $ result( 13 ) = zqrt17( 'No transpose', 1, m,
819 $ n, nrhs, copya, lda, b, ldb,
820 $ copyb, ldb, c, work, lwork )
821*
822* Test 14: Check if x is in the rowspace of A
823*
824 result( 14 ) = zero
825 IF( n.GT.crank )
826 $ result( 14 ) = zqrt14( 'No transpose', m, n,
827 $ nrhs, copya, lda, b, ldb,
828 $ work, lwork )
829*
830* Print information about the tests that did not
831* pass the threshold.
832*
833 DO 80 k = 3, 14
834 IF( result( k ).GE.thresh ) THEN
835 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
836 $ CALL alahd( nout, path )
837 WRITE( nout, fmt = 9998 )m, n, nrhs, nb,
838 $ itype, k, result( k )
839 nfail = nfail + 1
840 END IF
841 80 CONTINUE
842 nrun = nrun + 12
843*
844 90 CONTINUE
845 100 CONTINUE
846 110 CONTINUE
847 120 CONTINUE
848 130 CONTINUE
849 140 CONTINUE
850*
851* Print a summary of the results.
852*
853 CALL alasvm( path, nout, nfail, nrun, nerrs )
854*
855 9999 FORMAT( ' TRANS=''', a1, ''', M=', i5, ', N=', i5, ', NRHS=', i4,
856 $ ', NB=', i4, ', type', i2, ', test(', i2, ')=', g12.5 )
857 9998 FORMAT( ' M=', i5, ', N=', i5, ', NRHS=', i4, ', NB=', i4,
858 $ ', type', i2, ', test(', i2, ')=', g12.5 )
859 9997 FORMAT( ' TRANS=''', a1,' M=', i5, ', N=', i5, ', NRHS=', i4,
860 $ ', MB=', i4,', NB=', i4,', type', i2,
861 $ ', test(', i2, ')=', g12.5 )
862*
863 DEALLOCATE( work )
864 DEALLOCATE( iwork )
865 DEALLOCATE( rwork )
866 RETURN
867*
868* End of ZDRVLS
869*
dlasrt
subroutine dlasrt(id, n, d, info)
DLASRT sorts numbers in increasing or decreasing order.
Definition dlasrt.f:88
zgelsy
subroutine zgelsy(m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank, work, lwork, rwork, info)
ZGELSY solves overdetermined or underdetermined systems for GE matrices
Definition zgelsy.f:210
zgelss
subroutine zgelss(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, work, lwork, rwork, info)
ZGELSS solves overdetermined or underdetermined systems for GE matrices
Definition zgelss.f:178
zgels
subroutine zgels(trans, m, n, nrhs, a, lda, b, ldb, work, lwork, info)
ZGELS solves overdetermined or underdetermined systems for GE matrices
Definition zgels.f:182
zgelsd
subroutine zgelsd(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, work, lwork, rwork, iwork, info)
ZGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices
Definition zgelsd.f:225
zgetsls
subroutine zgetsls(trans, m, n, nrhs, a, lda, b, ldb, work, lwork, info)
ZGETSLS
Definition zgetsls.f:162
zscal
subroutine zscal(n, za, zx, incx)
ZSCAL
Definition zscal.f:78
zgemm
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
Definition zgemm.f:187
zqrt17
double precision function zqrt17(trans, iresid, m, n, nrhs, a, lda, x, ldx, b, ldb, c, work, lwork)
ZQRT17
Definition zqrt17.f:153
zqrt13
subroutine zqrt13(scale, m, n, a, lda, norma, iseed)
ZQRT13
Definition zqrt13.f:91
zqrt14
double precision function zqrt14(trans, m, n, nrhs, a, lda, x, ldx, work, lwork)
ZQRT14
Definition zqrt14.f:116
zerrls
subroutine zerrls(path, nunit)
ZERRLS
Definition zerrls.f:55
zqrt15
subroutine zqrt15(scale, rksel, m, n, nrhs, a, lda, b, ldb, s, rank, norma, normb, iseed, work, lwork)
ZQRT15
Definition zqrt15.f:149
zqrt16
subroutine zqrt16(trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
ZQRT16
Definition zqrt16.f:133
dasum
double precision function dasum(n, dx, incx)
DASUM
Definition dasum.f:71
daxpy
subroutine daxpy(n, da, dx, incx, dy, incy)
DAXPY
Definition daxpy.f:89

◆ zdrvpb()

subroutine zdrvpb ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) asav,
complex*16, dimension( * ) b,
complex*16, dimension( * ) bsav,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
double precision, dimension( * ) s,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nout )

ZDRVPB

Purpose:
!>
!> ZDRVPB tests the driver routines ZPBSV and -SVX.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]ASAV
!>          ASAV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 156 of file zdrvpb.f.

159*
160* -- LAPACK test routine --
161* -- LAPACK is a software package provided by Univ. of Tennessee, --
162* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
163*
164* .. Scalar Arguments ..
165 LOGICAL TSTERR
166 INTEGER NMAX, NN, NOUT, NRHS
167 DOUBLE PRECISION THRESH
168* ..
169* .. Array Arguments ..
170 LOGICAL DOTYPE( * )
171 INTEGER NVAL( * )
172 DOUBLE PRECISION RWORK( * ), S( * )
173 COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ),
174 $ BSAV( * ), WORK( * ), X( * ), XACT( * )
175* ..
176*
177* =====================================================================
178*
179* .. Parameters ..
180 DOUBLE PRECISION ONE, ZERO
181 parameter( one = 1.0d+0, zero = 0.0d+0 )
182 INTEGER NTYPES, NTESTS
183 parameter( ntypes = 8, ntests = 6 )
184 INTEGER NBW
185 parameter( nbw = 4 )
186* ..
187* .. Local Scalars ..
188 LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
189 CHARACTER DIST, EQUED, FACT, PACKIT, TYPE, UPLO, XTYPE
190 CHARACTER*3 PATH
191 INTEGER I, I1, I2, IEQUED, IFACT, IKD, IMAT, IN, INFO,
192 $ IOFF, IUPLO, IW, IZERO, K, K1, KD, KL, KOFF,
193 $ KU, LDA, LDAB, MODE, N, NB, NBMIN, NERRS,
194 $ NFACT, NFAIL, NIMAT, NKD, NRUN, NT
195 DOUBLE PRECISION AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
196 $ ROLDC, SCOND
197* ..
198* .. Local Arrays ..
199 CHARACTER EQUEDS( 2 ), FACTS( 3 )
200 INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW )
201 DOUBLE PRECISION RESULT( NTESTS )
202* ..
203* .. External Functions ..
204 LOGICAL LSAME
205 DOUBLE PRECISION DGET06, ZLANGE, ZLANHB
206 EXTERNAL lsame, dget06, zlange, zlanhb
207* ..
208* .. External Subroutines ..
209 EXTERNAL aladhd, alaerh, alasvm, xlaenv, zcopy, zerrvx,
210 $ zget04, zlacpy, zlaipd, zlaqhb, zlarhs, zlaset,
211 $ zlatb4, zlatms, zpbequ, zpbsv, zpbsvx, zpbt01,
212 $ zpbt02, zpbt05, zpbtrf, zpbtrs, zswap
213* ..
214* .. Intrinsic Functions ..
215 INTRINSIC dcmplx, max, min
216* ..
217* .. Scalars in Common ..
218 LOGICAL LERR, OK
219 CHARACTER*32 SRNAMT
220 INTEGER INFOT, NUNIT
221* ..
222* .. Common blocks ..
223 COMMON / infoc / infot, nunit, ok, lerr
224 COMMON / srnamc / srnamt
225* ..
226* .. Data statements ..
227 DATA iseedy / 1988, 1989, 1990, 1991 /
228 DATA facts / 'F', 'N', 'E' / , equeds / 'N', 'Y' /
229* ..
230* .. Executable Statements ..
231*
232* Initialize constants and the random number seed.
233*
234 path( 1: 1 ) = 'Zomplex precision'
235 path( 2: 3 ) = 'PB'
236 nrun = 0
237 nfail = 0
238 nerrs = 0
239 DO 10 i = 1, 4
240 iseed( i ) = iseedy( i )
241 10 CONTINUE
242*
243* Test the error exits
244*
245 IF( tsterr )
246 $ CALL zerrvx( path, nout )
247 infot = 0
248 kdval( 1 ) = 0
249*
250* Set the block size and minimum block size for testing.
251*
252 nb = 1
253 nbmin = 2
254 CALL xlaenv( 1, nb )
255 CALL xlaenv( 2, nbmin )
256*
257* Do for each value of N in NVAL
258*
259 DO 110 in = 1, nn
260 n = nval( in )
261 lda = max( n, 1 )
262 xtype = 'N'
263*
264* Set limits on the number of loop iterations.
265*
266 nkd = max( 1, min( n, 4 ) )
267 nimat = ntypes
268 IF( n.EQ.0 )
269 $ nimat = 1
270*
271 kdval( 2 ) = n + ( n+1 ) / 4
272 kdval( 3 ) = ( 3*n-1 ) / 4
273 kdval( 4 ) = ( n+1 ) / 4
274*
275 DO 100 ikd = 1, nkd
276*
277* Do for KD = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This order
278* makes it easier to skip redundant values for small values
279* of N.
280*
281 kd = kdval( ikd )
282 ldab = kd + 1
283*
284* Do first for UPLO = 'U', then for UPLO = 'L'
285*
286 DO 90 iuplo = 1, 2
287 koff = 1
288 IF( iuplo.EQ.1 ) THEN
289 uplo = 'U'
290 packit = 'Q'
291 koff = max( 1, kd+2-n )
292 ELSE
293 uplo = 'L'
294 packit = 'B'
295 END IF
296*
297 DO 80 imat = 1, nimat
298*
299* Do the tests only if DOTYPE( IMAT ) is true.
300*
301 IF( .NOT.dotype( imat ) )
302 $ GO TO 80
303*
304* Skip types 2, 3, or 4 if the matrix size is too small.
305*
306 zerot = imat.GE.2 .AND. imat.LE.4
307 IF( zerot .AND. n.LT.imat-1 )
308 $ GO TO 80
309*
310 IF( .NOT.zerot .OR. .NOT.dotype( 1 ) ) THEN
311*
312* Set up parameters with ZLATB4 and generate a test
313* matrix with ZLATMS.
314*
315 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
316 $ MODE, CNDNUM, DIST )
317*
318 srnamt = 'ZLATMS'
319 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
320 $ CNDNUM, ANORM, KD, KD, PACKIT,
321 $ A( KOFF ), LDAB, WORK, INFO )
322*
323* Check error code from ZLATMS.
324*
325 IF( info.NE.0 ) THEN
326 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n,
327 $ n, -1, -1, -1, imat, nfail, nerrs,
328 $ nout )
329 GO TO 80
330 END IF
331 ELSE IF( izero.GT.0 ) THEN
332*
333* Use the same matrix for types 3 and 4 as for type
334* 2 by copying back the zeroed out column,
335*
336 iw = 2*lda + 1
337 IF( iuplo.EQ.1 ) THEN
338 ioff = ( izero-1 )*ldab + kd + 1
339 CALL zcopy( izero-i1, work( iw ), 1,
340 $ a( ioff-izero+i1 ), 1 )
341 iw = iw + izero - i1
342 CALL zcopy( i2-izero+1, work( iw ), 1,
343 $ a( ioff ), max( ldab-1, 1 ) )
344 ELSE
345 ioff = ( i1-1 )*ldab + 1
346 CALL zcopy( izero-i1, work( iw ), 1,
347 $ a( ioff+izero-i1 ),
348 $ max( ldab-1, 1 ) )
349 ioff = ( izero-1 )*ldab + 1
350 iw = iw + izero - i1
351 CALL zcopy( i2-izero+1, work( iw ), 1,
352 $ a( ioff ), 1 )
353 END IF
354 END IF
355*
356* For types 2-4, zero one row and column of the matrix
357* to test that INFO is returned correctly.
358*
359 izero = 0
360 IF( zerot ) THEN
361 IF( imat.EQ.2 ) THEN
362 izero = 1
363 ELSE IF( imat.EQ.3 ) THEN
364 izero = n
365 ELSE
366 izero = n / 2 + 1
367 END IF
368*
369* Save the zeroed out row and column in WORK(*,3)
370*
371 iw = 2*lda
372 DO 20 i = 1, min( 2*kd+1, n )
373 work( iw+i ) = zero
374 20 CONTINUE
375 iw = iw + 1
376 i1 = max( izero-kd, 1 )
377 i2 = min( izero+kd, n )
378*
379 IF( iuplo.EQ.1 ) THEN
380 ioff = ( izero-1 )*ldab + kd + 1
381 CALL zswap( izero-i1, a( ioff-izero+i1 ), 1,
382 $ work( iw ), 1 )
383 iw = iw + izero - i1
384 CALL zswap( i2-izero+1, a( ioff ),
385 $ max( ldab-1, 1 ), work( iw ), 1 )
386 ELSE
387 ioff = ( i1-1 )*ldab + 1
388 CALL zswap( izero-i1, a( ioff+izero-i1 ),
389 $ max( ldab-1, 1 ), work( iw ), 1 )
390 ioff = ( izero-1 )*ldab + 1
391 iw = iw + izero - i1
392 CALL zswap( i2-izero+1, a( ioff ), 1,
393 $ work( iw ), 1 )
394 END IF
395 END IF
396*
397* Set the imaginary part of the diagonals.
398*
399 IF( iuplo.EQ.1 ) THEN
400 CALL zlaipd( n, a( kd+1 ), ldab, 0 )
401 ELSE
402 CALL zlaipd( n, a( 1 ), ldab, 0 )
403 END IF
404*
405* Save a copy of the matrix A in ASAV.
406*
407 CALL zlacpy( 'Full', kd+1, n, a, ldab, asav, ldab )
408*
409 DO 70 iequed = 1, 2
410 equed = equeds( iequed )
411 IF( iequed.EQ.1 ) THEN
412 nfact = 3
413 ELSE
414 nfact = 1
415 END IF
416*
417 DO 60 ifact = 1, nfact
418 fact = facts( ifact )
419 prefac = lsame( fact, 'F' )
420 nofact = lsame( fact, 'N' )
421 equil = lsame( fact, 'E' )
422*
423 IF( zerot ) THEN
424 IF( prefac )
425 $ GO TO 60
426 rcondc = zero
427*
428 ELSE IF( .NOT.lsame( fact, 'N' ) ) THEN
429*
430* Compute the condition number for comparison
431* with the value returned by ZPBSVX (FACT =
432* 'N' reuses the condition number from the
433* previous iteration with FACT = 'F').
434*
435 CALL zlacpy( 'Full', kd+1, n, asav, ldab,
436 $ afac, ldab )
437 IF( equil .OR. iequed.GT.1 ) THEN
438*
439* Compute row and column scale factors to
440* equilibrate the matrix A.
441*
442 CALL zpbequ( uplo, n, kd, afac, ldab, s,
443 $ scond, amax, info )
444 IF( info.EQ.0 .AND. n.GT.0 ) THEN
445 IF( iequed.GT.1 )
446 $ scond = zero
447*
448* Equilibrate the matrix.
449*
450 CALL zlaqhb( uplo, n, kd, afac, ldab,
451 $ s, scond, amax, equed )
452 END IF
453 END IF
454*
455* Save the condition number of the
456* non-equilibrated system for use in ZGET04.
457*
458 IF( equil )
459 $ roldc = rcondc
460*
461* Compute the 1-norm of A.
462*
463 anorm = zlanhb( '1', uplo, n, kd, afac, ldab,
464 $ rwork )
465*
466* Factor the matrix A.
467*
468 CALL zpbtrf( uplo, n, kd, afac, ldab, info )
469*
470* Form the inverse of A.
471*
472 CALL zlaset( 'Full', n, n, dcmplx( zero ),
473 $ dcmplx( one ), a, lda )
474 srnamt = 'ZPBTRS'
475 CALL zpbtrs( uplo, n, kd, n, afac, ldab, a,
476 $ lda, info )
477*
478* Compute the 1-norm condition number of A.
479*
480 ainvnm = zlange( '1', n, n, a, lda, rwork )
481 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
482 rcondc = one
483 ELSE
484 rcondc = ( one / anorm ) / ainvnm
485 END IF
486 END IF
487*
488* Restore the matrix A.
489*
490 CALL zlacpy( 'Full', kd+1, n, asav, ldab, a,
491 $ ldab )
492*
493* Form an exact solution and set the right hand
494* side.
495*
496 srnamt = 'ZLARHS'
497 CALL zlarhs( path, xtype, uplo, ' ', n, n, kd,
498 $ kd, nrhs, a, ldab, xact, lda, b,
499 $ lda, iseed, info )
500 xtype = 'C'
501 CALL zlacpy( 'Full', n, nrhs, b, lda, bsav,
502 $ lda )
503*
504 IF( nofact ) THEN
505*
506* --- Test ZPBSV ---
507*
508* Compute the L*L' or U'*U factorization of the
509* matrix and solve the system.
510*
511 CALL zlacpy( 'Full', kd+1, n, a, ldab, afac,
512 $ ldab )
513 CALL zlacpy( 'Full', n, nrhs, b, lda, x,
514 $ lda )
515*
516 srnamt = 'ZPBSV '
517 CALL zpbsv( uplo, n, kd, nrhs, afac, ldab, x,
518 $ lda, info )
519*
520* Check error code from ZPBSV .
521*
522 IF( info.NE.izero ) THEN
523 CALL alaerh( path, 'ZPBSV ', info, izero,
524 $ uplo, n, n, kd, kd, nrhs,
525 $ imat, nfail, nerrs, nout )
526 GO TO 40
527 ELSE IF( info.NE.0 ) THEN
528 GO TO 40
529 END IF
530*
531* Reconstruct matrix from factors and compute
532* residual.
533*
534 CALL zpbt01( uplo, n, kd, a, ldab, afac,
535 $ ldab, rwork, result( 1 ) )
536*
537* Compute residual of the computed solution.
538*
539 CALL zlacpy( 'Full', n, nrhs, b, lda, work,
540 $ lda )
541 CALL zpbt02( uplo, n, kd, nrhs, a, ldab, x,
542 $ lda, work, lda, rwork,
543 $ result( 2 ) )
544*
545* Check solution from generated exact solution.
546*
547 CALL zget04( n, nrhs, x, lda, xact, lda,
548 $ rcondc, result( 3 ) )
549 nt = 3
550*
551* Print information about the tests that did
552* not pass the threshold.
553*
554 DO 30 k = 1, nt
555 IF( result( k ).GE.thresh ) THEN
556 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
557 $ CALL aladhd( nout, path )
558 WRITE( nout, fmt = 9999 )'ZPBSV ',
559 $ uplo, n, kd, imat, k, result( k )
560 nfail = nfail + 1
561 END IF
562 30 CONTINUE
563 nrun = nrun + nt
564 40 CONTINUE
565 END IF
566*
567* --- Test ZPBSVX ---
568*
569 IF( .NOT.prefac )
570 $ CALL zlaset( 'Full', kd+1, n, dcmplx( zero ),
571 $ dcmplx( zero ), afac, ldab )
572 CALL zlaset( 'Full', n, nrhs, dcmplx( zero ),
573 $ dcmplx( zero ), x, lda )
574 IF( iequed.GT.1 .AND. n.GT.0 ) THEN
575*
576* Equilibrate the matrix if FACT='F' and
577* EQUED='Y'
578*
579 CALL zlaqhb( uplo, n, kd, a, ldab, s, scond,
580 $ amax, equed )
581 END IF
582*
583* Solve the system and compute the condition
584* number and error bounds using ZPBSVX.
585*
586 srnamt = 'ZPBSVX'
587 CALL zpbsvx( fact, uplo, n, kd, nrhs, a, ldab,
588 $ afac, ldab, equed, s, b, lda, x,
589 $ lda, rcond, rwork, rwork( nrhs+1 ),
590 $ work, rwork( 2*nrhs+1 ), info )
591*
592* Check the error code from ZPBSVX.
593*
594 IF( info.NE.izero ) THEN
595 CALL alaerh( path, 'ZPBSVX', info, izero,
596 $ fact // uplo, n, n, kd, kd,
597 $ nrhs, imat, nfail, nerrs, nout )
598 GO TO 60
599 END IF
600*
601 IF( info.EQ.0 ) THEN
602 IF( .NOT.prefac ) THEN
603*
604* Reconstruct matrix from factors and
605* compute residual.
606*
607 CALL zpbt01( uplo, n, kd, a, ldab, afac,
608 $ ldab, rwork( 2*nrhs+1 ),
609 $ result( 1 ) )
610 k1 = 1
611 ELSE
612 k1 = 2
613 END IF
614*
615* Compute residual of the computed solution.
616*
617 CALL zlacpy( 'Full', n, nrhs, bsav, lda,
618 $ work, lda )
619 CALL zpbt02( uplo, n, kd, nrhs, asav, ldab,
620 $ x, lda, work, lda,
621 $ rwork( 2*nrhs+1 ), result( 2 ) )
622*
623* Check solution from generated exact solution.
624*
625 IF( nofact .OR. ( prefac .AND. lsame( equed,
626 $ 'N' ) ) ) THEN
627 CALL zget04( n, nrhs, x, lda, xact, lda,
628 $ rcondc, result( 3 ) )
629 ELSE
630 CALL zget04( n, nrhs, x, lda, xact, lda,
631 $ roldc, result( 3 ) )
632 END IF
633*
634* Check the error bounds from iterative
635* refinement.
636*
637 CALL zpbt05( uplo, n, kd, nrhs, asav, ldab,
638 $ b, lda, x, lda, xact, lda,
639 $ rwork, rwork( nrhs+1 ),
640 $ result( 4 ) )
641 ELSE
642 k1 = 6
643 END IF
644*
645* Compare RCOND from ZPBSVX with the computed
646* value in RCONDC.
647*
648 result( 6 ) = dget06( rcond, rcondc )
649*
650* Print information about the tests that did not
651* pass the threshold.
652*
653 DO 50 k = k1, 6
654 IF( result( k ).GE.thresh ) THEN
655 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
656 $ CALL aladhd( nout, path )
657 IF( prefac ) THEN
658 WRITE( nout, fmt = 9997 )'ZPBSVX',
659 $ fact, uplo, n, kd, equed, imat, k,
660 $ result( k )
661 ELSE
662 WRITE( nout, fmt = 9998 )'ZPBSVX',
663 $ fact, uplo, n, kd, imat, k,
664 $ result( k )
665 END IF
666 nfail = nfail + 1
667 END IF
668 50 CONTINUE
669 nrun = nrun + 7 - k1
670 60 CONTINUE
671 70 CONTINUE
672 80 CONTINUE
673 90 CONTINUE
674 100 CONTINUE
675 110 CONTINUE
676*
677* Print a summary of the results.
678*
679 CALL alasvm( path, nout, nfail, nrun, nerrs )
680*
681 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', KD =', i5,
682 $ ', type ', i1, ', test(', i1, ')=', g12.5 )
683 9998 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ', i5, ', ', i5,
684 $ ', ... ), type ', i1, ', test(', i1, ')=', g12.5 )
685 9997 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ', i5, ', ', i5,
686 $ ', ... ), EQUED=''', a1, ''', type ', i1, ', test(', i1,
687 $ ')=', g12.5 )
688 RETURN
689*
690* End of ZDRVPB
691*
zlaqhb
subroutine zlaqhb(uplo, n, kd, ab, ldab, s, scond, amax, equed)
ZLAQHB scales a Hermitian band matrix, using scaling factors computed by cpbequ.
Definition zlaqhb.f:141
zpbsv
subroutine zpbsv(uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
ZPBSV computes the solution to system of linear equations A * X = B for OTHER matrices
Definition zpbsv.f:164
zpbsvx
subroutine zpbsvx(fact, uplo, n, kd, nrhs, ab, ldab, afb, ldafb, equed, s, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
ZPBSVX computes the solution to system of linear equations A * X = B for OTHER matrices
Definition zpbsvx.f:342

◆ zdrvpo()

subroutine zdrvpo ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) asav,
complex*16, dimension( * ) b,
complex*16, dimension( * ) bsav,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
double precision, dimension( * ) s,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nout )

ZDRVPO

ZDRVPOX

Purpose:
!>
!> ZDRVPO tests the driver routines ZPOSV and -SVX.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]ASAV
!>          ASAV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Purpose:
!>
!> ZDRVPO tests the driver routines ZPOSV, -SVX, and -SVXX.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise zdrvpo.f defines this subroutine.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]ASAV
!>          ASAV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 156 of file zdrvpo.f.

159*
160* -- LAPACK test routine --
161* -- LAPACK is a software package provided by Univ. of Tennessee, --
162* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
163*
164* .. Scalar Arguments ..
165 LOGICAL TSTERR
166 INTEGER NMAX, NN, NOUT, NRHS
167 DOUBLE PRECISION THRESH
168* ..
169* .. Array Arguments ..
170 LOGICAL DOTYPE( * )
171 INTEGER NVAL( * )
172 DOUBLE PRECISION RWORK( * ), S( * )
173 COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ),
174 $ BSAV( * ), WORK( * ), X( * ), XACT( * )
175* ..
176*
177* =====================================================================
178*
179* .. Parameters ..
180 DOUBLE PRECISION ONE, ZERO
181 parameter( one = 1.0d+0, zero = 0.0d+0 )
182 INTEGER NTYPES
183 parameter( ntypes = 9 )
184 INTEGER NTESTS
185 parameter( ntests = 6 )
186* ..
187* .. Local Scalars ..
188 LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
189 CHARACTER DIST, EQUED, FACT, TYPE, UPLO, XTYPE
190 CHARACTER*3 PATH
191 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
192 $ IZERO, K, K1, KL, KU, LDA, MODE, N, NB, NBMIN,
193 $ NERRS, NFACT, NFAIL, NIMAT, NRUN, NT
194 DOUBLE PRECISION AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
195 $ ROLDC, SCOND
196* ..
197* .. Local Arrays ..
198 CHARACTER EQUEDS( 2 ), FACTS( 3 ), UPLOS( 2 )
199 INTEGER ISEED( 4 ), ISEEDY( 4 )
200 DOUBLE PRECISION RESULT( NTESTS )
201* ..
202* .. External Functions ..
203 LOGICAL LSAME
204 DOUBLE PRECISION DGET06, ZLANHE
205 EXTERNAL lsame, dget06, zlanhe
206* ..
207* .. External Subroutines ..
208 EXTERNAL aladhd, alaerh, alasvm, xlaenv, zerrvx, zget04,
209 $ zlacpy, zlaipd, zlaqhe, zlarhs, zlaset, zlatb4,
210 $ zlatms, zpoequ, zposv, zposvx, zpot01, zpot02,
211 $ zpot05, zpotrf, zpotri
212* ..
213* .. Scalars in Common ..
214 LOGICAL LERR, OK
215 CHARACTER*32 SRNAMT
216 INTEGER INFOT, NUNIT
217* ..
218* .. Common blocks ..
219 COMMON / infoc / infot, nunit, ok, lerr
220 COMMON / srnamc / srnamt
221* ..
222* .. Intrinsic Functions ..
223 INTRINSIC dcmplx, max
224* ..
225* .. Data statements ..
226 DATA iseedy / 1988, 1989, 1990, 1991 /
227 DATA uplos / 'U', 'L' /
228 DATA facts / 'F', 'N', 'E' /
229 DATA equeds / 'N', 'Y' /
230* ..
231* .. Executable Statements ..
232*
233* Initialize constants and the random number seed.
234*
235 path( 1: 1 ) = 'Zomplex precision'
236 path( 2: 3 ) = 'PO'
237 nrun = 0
238 nfail = 0
239 nerrs = 0
240 DO 10 i = 1, 4
241 iseed( i ) = iseedy( i )
242 10 CONTINUE
243*
244* Test the error exits
245*
246 IF( tsterr )
247 $ CALL zerrvx( path, nout )
248 infot = 0
249*
250* Set the block size and minimum block size for testing.
251*
252 nb = 1
253 nbmin = 2
254 CALL xlaenv( 1, nb )
255 CALL xlaenv( 2, nbmin )
256*
257* Do for each value of N in NVAL
258*
259 DO 130 in = 1, nn
260 n = nval( in )
261 lda = max( n, 1 )
262 xtype = 'N'
263 nimat = ntypes
264 IF( n.LE.0 )
265 $ nimat = 1
266*
267 DO 120 imat = 1, nimat
268*
269* Do the tests only if DOTYPE( IMAT ) is true.
270*
271 IF( .NOT.dotype( imat ) )
272 $ GO TO 120
273*
274* Skip types 3, 4, or 5 if the matrix size is too small.
275*
276 zerot = imat.GE.3 .AND. imat.LE.5
277 IF( zerot .AND. n.LT.imat-2 )
278 $ GO TO 120
279*
280* Do first for UPLO = 'U', then for UPLO = 'L'
281*
282 DO 110 iuplo = 1, 2
283 uplo = uplos( iuplo )
284*
285* Set up parameters with ZLATB4 and generate a test matrix
286* with ZLATMS.
287*
288 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
289 $ CNDNUM, DIST )
290*
291 srnamt = 'ZLATMS'
292 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
293 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
294 $ INFO )
295*
296* Check error code from ZLATMS.
297*
298 IF( info.NE.0 ) THEN
299 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n, -1,
300 $ -1, -1, imat, nfail, nerrs, nout )
301 GO TO 110
302 END IF
303*
304* For types 3-5, zero one row and column of the matrix to
305* test that INFO is returned correctly.
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 ioff = ( izero-1 )*lda
316*
317* Set row and column IZERO of A to 0.
318*
319 IF( iuplo.EQ.1 ) THEN
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 izero = 0
341 END IF
342*
343* Set the imaginary part of the diagonals.
344*
345 CALL zlaipd( n, a, lda+1, 0 )
346*
347* Save a copy of the matrix A in ASAV.
348*
349 CALL zlacpy( uplo, n, n, a, lda, asav, lda )
350*
351 DO 100 iequed = 1, 2
352 equed = equeds( iequed )
353 IF( iequed.EQ.1 ) THEN
354 nfact = 3
355 ELSE
356 nfact = 1
357 END IF
358*
359 DO 90 ifact = 1, nfact
360 fact = facts( ifact )
361 prefac = lsame( fact, 'F' )
362 nofact = lsame( fact, 'N' )
363 equil = lsame( fact, 'E' )
364*
365 IF( zerot ) THEN
366 IF( prefac )
367 $ GO TO 90
368 rcondc = zero
369*
370 ELSE IF( .NOT.lsame( fact, 'N' ) ) THEN
371*
372* Compute the condition number for comparison with
373* the value returned by ZPOSVX (FACT = 'N' reuses
374* the condition number from the previous iteration
375* with FACT = 'F').
376*
377 CALL zlacpy( uplo, n, n, asav, lda, afac, lda )
378 IF( equil .OR. iequed.GT.1 ) THEN
379*
380* Compute row and column scale factors to
381* equilibrate the matrix A.
382*
383 CALL zpoequ( n, afac, lda, s, scond, amax,
384 $ info )
385 IF( info.EQ.0 .AND. n.GT.0 ) THEN
386 IF( iequed.GT.1 )
387 $ scond = zero
388*
389* Equilibrate the matrix.
390*
391 CALL zlaqhe( uplo, n, afac, lda, s, scond,
392 $ amax, equed )
393 END IF
394 END IF
395*
396* Save the condition number of the
397* non-equilibrated system for use in ZGET04.
398*
399 IF( equil )
400 $ roldc = rcondc
401*
402* Compute the 1-norm of A.
403*
404 anorm = zlanhe( '1', uplo, n, afac, lda, rwork )
405*
406* Factor the matrix A.
407*
408 CALL zpotrf( uplo, n, afac, lda, info )
409*
410* Form the inverse of A.
411*
412 CALL zlacpy( uplo, n, n, afac, lda, a, lda )
413 CALL zpotri( uplo, n, a, lda, info )
414*
415* Compute the 1-norm condition number of A.
416*
417 ainvnm = zlanhe( '1', uplo, n, a, lda, rwork )
418 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
419 rcondc = one
420 ELSE
421 rcondc = ( one / anorm ) / ainvnm
422 END IF
423 END IF
424*
425* Restore the matrix A.
426*
427 CALL zlacpy( uplo, n, n, asav, lda, a, lda )
428*
429* Form an exact solution and set the right hand side.
430*
431 srnamt = 'ZLARHS'
432 CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
433 $ nrhs, a, lda, xact, lda, b, lda,
434 $ iseed, info )
435 xtype = 'C'
436 CALL zlacpy( 'Full', n, nrhs, b, lda, bsav, lda )
437*
438 IF( nofact ) THEN
439*
440* --- Test ZPOSV ---
441*
442* Compute the L*L' or U'*U factorization of the
443* matrix and solve the system.
444*
445 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
446 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
447*
448 srnamt = 'ZPOSV '
449 CALL zposv( uplo, n, nrhs, afac, lda, x, lda,
450 $ info )
451*
452* Check error code from ZPOSV .
453*
454 IF( info.NE.izero ) THEN
455 CALL alaerh( path, 'ZPOSV ', info, izero,
456 $ uplo, n, n, -1, -1, nrhs, imat,
457 $ nfail, nerrs, nout )
458 GO TO 70
459 ELSE IF( info.NE.0 ) THEN
460 GO TO 70
461 END IF
462*
463* Reconstruct matrix from factors and compute
464* residual.
465*
466 CALL zpot01( uplo, n, a, lda, afac, lda, rwork,
467 $ result( 1 ) )
468*
469* Compute residual of the computed solution.
470*
471 CALL zlacpy( 'Full', n, nrhs, b, lda, work,
472 $ lda )
473 CALL zpot02( uplo, n, nrhs, a, lda, x, lda,
474 $ work, lda, rwork, result( 2 ) )
475*
476* Check solution from generated exact solution.
477*
478 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
479 $ result( 3 ) )
480 nt = 3
481*
482* Print information about the tests that did not
483* pass the threshold.
484*
485 DO 60 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 )'ZPOSV ', uplo,
490 $ n, imat, k, result( k )
491 nfail = nfail + 1
492 END IF
493 60 CONTINUE
494 nrun = nrun + nt
495 70 CONTINUE
496 END IF
497*
498* --- Test ZPOSVX ---
499*
500 IF( .NOT.prefac )
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 IF( iequed.GT.1 .AND. n.GT.0 ) THEN
506*
507* Equilibrate the matrix if FACT='F' and
508* EQUED='Y'.
509*
510 CALL zlaqhe( uplo, n, a, lda, s, scond, amax,
511 $ equed )
512 END IF
513*
514* Solve the system and compute the condition number
515* and error bounds using ZPOSVX.
516*
517 srnamt = 'ZPOSVX'
518 CALL zposvx( fact, uplo, n, nrhs, a, lda, afac,
519 $ lda, equed, s, b, lda, x, lda, rcond,
520 $ rwork, rwork( nrhs+1 ), work,
521 $ rwork( 2*nrhs+1 ), info )
522*
523* Check the error code from ZPOSVX.
524*
525 IF( info.NE.izero ) THEN
526 CALL alaerh( path, 'ZPOSVX', info, izero,
527 $ fact // uplo, n, n, -1, -1, nrhs,
528 $ imat, nfail, nerrs, nout )
529 GO TO 90
530 END IF
531*
532 IF( info.EQ.0 ) THEN
533 IF( .NOT.prefac ) THEN
534*
535* Reconstruct matrix from factors and compute
536* residual.
537*
538 CALL zpot01( uplo, n, a, lda, afac, lda,
539 $ rwork( 2*nrhs+1 ), result( 1 ) )
540 k1 = 1
541 ELSE
542 k1 = 2
543 END IF
544*
545* Compute residual of the computed solution.
546*
547 CALL zlacpy( 'Full', n, nrhs, bsav, lda, work,
548 $ lda )
549 CALL zpot02( uplo, n, nrhs, asav, lda, x, lda,
550 $ work, lda, rwork( 2*nrhs+1 ),
551 $ result( 2 ) )
552*
553* Check solution from generated exact solution.
554*
555 IF( nofact .OR. ( prefac .AND. lsame( equed,
556 $ 'N' ) ) ) THEN
557 CALL zget04( n, nrhs, x, lda, xact, lda,
558 $ rcondc, result( 3 ) )
559 ELSE
560 CALL zget04( n, nrhs, x, lda, xact, lda,
561 $ roldc, result( 3 ) )
562 END IF
563*
564* Check the error bounds from iterative
565* refinement.
566*
567 CALL zpot05( uplo, n, nrhs, asav, lda, b, lda,
568 $ x, lda, xact, lda, rwork,
569 $ rwork( nrhs+1 ), result( 4 ) )
570 ELSE
571 k1 = 6
572 END IF
573*
574* Compare RCOND from ZPOSVX with the computed value
575* in RCONDC.
576*
577 result( 6 ) = dget06( rcond, rcondc )
578*
579* Print information about the tests that did not pass
580* the threshold.
581*
582 DO 80 k = k1, 6
583 IF( result( k ).GE.thresh ) THEN
584 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
585 $ CALL aladhd( nout, path )
586 IF( prefac ) THEN
587 WRITE( nout, fmt = 9997 )'ZPOSVX', fact,
588 $ uplo, n, equed, imat, k, result( k )
589 ELSE
590 WRITE( nout, fmt = 9998 )'ZPOSVX', fact,
591 $ uplo, n, imat, k, result( k )
592 END IF
593 nfail = nfail + 1
594 END IF
595 80 CONTINUE
596 nrun = nrun + 7 - k1
597 90 CONTINUE
598 100 CONTINUE
599 110 CONTINUE
600 120 CONTINUE
601 130 CONTINUE
602*
603* Print a summary of the results.
604*
605 CALL alasvm( path, nout, nfail, nrun, nerrs )
606*
607 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i1,
608 $ ', test(', i1, ')=', g12.5 )
609 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N=', i5,
610 $ ', type ', i1, ', test(', i1, ')=', g12.5 )
611 9997 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N=', i5,
612 $ ', EQUED=''', a1, ''', type ', i1, ', test(', i1, ') =',
613 $ g12.5 )
614 RETURN
615*
616* End of ZDRVPO
617*
zlaqhe
subroutine zlaqhe(uplo, n, a, lda, s, scond, amax, equed)
ZLAQHE scales a Hermitian matrix.
Definition zlaqhe.f:134
zposv
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
Definition zposv.f:130
zposvx
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
Definition zposvx.f:306

◆ zdrvpp()

subroutine zdrvpp ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) asav,
complex*16, dimension( * ) b,
complex*16, dimension( * ) bsav,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
double precision, dimension( * ) s,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nout )

ZDRVPP

Purpose:
!>
!> ZDRVPP tests the driver routines ZPPSV and -SVX.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2)
!>
[out]ASAV
!>          ASAV is COMPLEX*16 array, dimension (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 156 of file zdrvpp.f.

159*
160* -- LAPACK test routine --
161* -- LAPACK is a software package provided by Univ. of Tennessee, --
162* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
163*
164* .. Scalar Arguments ..
165 LOGICAL TSTERR
166 INTEGER NMAX, NN, NOUT, NRHS
167 DOUBLE PRECISION THRESH
168* ..
169* .. Array Arguments ..
170 LOGICAL DOTYPE( * )
171 INTEGER NVAL( * )
172 DOUBLE PRECISION RWORK( * ), S( * )
173 COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ),
174 $ BSAV( * ), WORK( * ), X( * ), XACT( * )
175* ..
176*
177* =====================================================================
178*
179* .. Parameters ..
180 DOUBLE PRECISION ONE, ZERO
181 parameter( one = 1.0d+0, zero = 0.0d+0 )
182 INTEGER NTYPES
183 parameter( ntypes = 9 )
184 INTEGER NTESTS
185 parameter( ntests = 6 )
186* ..
187* .. Local Scalars ..
188 LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
189 CHARACTER DIST, EQUED, FACT, PACKIT, TYPE, UPLO, XTYPE
190 CHARACTER*3 PATH
191 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
192 $ IZERO, K, K1, KL, KU, LDA, MODE, N, NERRS,
193 $ NFACT, NFAIL, NIMAT, NPP, NRUN, NT
194 DOUBLE PRECISION AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
195 $ ROLDC, SCOND
196* ..
197* .. Local Arrays ..
198 CHARACTER EQUEDS( 2 ), FACTS( 3 ), PACKS( 2 ), UPLOS( 2 )
199 INTEGER ISEED( 4 ), ISEEDY( 4 )
200 DOUBLE PRECISION RESULT( NTESTS )
201* ..
202* .. External Functions ..
203 LOGICAL LSAME
204 DOUBLE PRECISION DGET06, ZLANHP
205 EXTERNAL lsame, dget06, zlanhp
206* ..
207* .. External Subroutines ..
208 EXTERNAL aladhd, alaerh, alasvm, zcopy, zerrvx, zget04,
209 $ zlacpy, zlaipd, zlaqhp, zlarhs, zlaset, zlatb4,
210 $ zlatms, zppequ, zppsv, zppsvx, zppt01, zppt02,
211 $ zppt05, zpptrf, zpptri
212* ..
213* .. Scalars in Common ..
214 LOGICAL LERR, OK
215 CHARACTER*32 SRNAMT
216 INTEGER INFOT, NUNIT
217* ..
218* .. Common blocks ..
219 COMMON / infoc / infot, nunit, ok, lerr
220 COMMON / srnamc / srnamt
221* ..
222* .. Intrinsic Functions ..
223 INTRINSIC dcmplx, max
224* ..
225* .. Data statements ..
226 DATA iseedy / 1988, 1989, 1990, 1991 /
227 DATA uplos / 'U', 'L' / , facts / 'F', 'N', 'E' / ,
228 $ packs / 'C', 'R' / , equeds / 'N', 'Y' /
229* ..
230* .. Executable Statements ..
231*
232* Initialize constants and the random number seed.
233*
234 path( 1: 1 ) = 'Zomplex precision'
235 path( 2: 3 ) = 'PP'
236 nrun = 0
237 nfail = 0
238 nerrs = 0
239 DO 10 i = 1, 4
240 iseed( i ) = iseedy( i )
241 10 CONTINUE
242*
243* Test the error exits
244*
245 IF( tsterr )
246 $ CALL zerrvx( path, nout )
247 infot = 0
248*
249* Do for each value of N in NVAL
250*
251 DO 140 in = 1, nn
252 n = nval( in )
253 lda = max( n, 1 )
254 npp = n*( n+1 ) / 2
255 xtype = 'N'
256 nimat = ntypes
257 IF( n.LE.0 )
258 $ nimat = 1
259*
260 DO 130 imat = 1, nimat
261*
262* Do the tests only if DOTYPE( IMAT ) is true.
263*
264 IF( .NOT.dotype( imat ) )
265 $ GO TO 130
266*
267* Skip types 3, 4, or 5 if the matrix size is too small.
268*
269 zerot = imat.GE.3 .AND. imat.LE.5
270 IF( zerot .AND. n.LT.imat-2 )
271 $ GO TO 130
272*
273* Do first for UPLO = 'U', then for UPLO = 'L'
274*
275 DO 120 iuplo = 1, 2
276 uplo = uplos( iuplo )
277 packit = packs( iuplo )
278*
279* Set up parameters with ZLATB4 and generate a test matrix
280* with ZLATMS.
281*
282 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
283 $ CNDNUM, DIST )
284 rcondc = one / cndnum
285*
286 srnamt = 'ZLATMS'
287 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
288 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
289 $ INFO )
290*
291* Check error code from ZLATMS.
292*
293 IF( info.NE.0 ) THEN
294 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n, -1,
295 $ -1, -1, imat, nfail, nerrs, nout )
296 GO TO 120
297 END IF
298*
299* For types 3-5, zero one row and column of the matrix to
300* test that INFO is returned correctly.
301*
302 IF( zerot ) THEN
303 IF( imat.EQ.3 ) THEN
304 izero = 1
305 ELSE IF( imat.EQ.4 ) THEN
306 izero = n
307 ELSE
308 izero = n / 2 + 1
309 END IF
310*
311* Set row and column IZERO of A to 0.
312*
313 IF( iuplo.EQ.1 ) THEN
314 ioff = ( izero-1 )*izero / 2
315 DO 20 i = 1, izero - 1
316 a( ioff+i ) = zero
317 20 CONTINUE
318 ioff = ioff + izero
319 DO 30 i = izero, n
320 a( ioff ) = zero
321 ioff = ioff + i
322 30 CONTINUE
323 ELSE
324 ioff = izero
325 DO 40 i = 1, izero - 1
326 a( ioff ) = zero
327 ioff = ioff + n - i
328 40 CONTINUE
329 ioff = ioff - izero
330 DO 50 i = izero, n
331 a( ioff+i ) = zero
332 50 CONTINUE
333 END IF
334 ELSE
335 izero = 0
336 END IF
337*
338* Set the imaginary part of the diagonals.
339*
340 IF( iuplo.EQ.1 ) THEN
341 CALL zlaipd( n, a, 2, 1 )
342 ELSE
343 CALL zlaipd( n, a, n, -1 )
344 END IF
345*
346* Save a copy of the matrix A in ASAV.
347*
348 CALL zcopy( npp, a, 1, asav, 1 )
349*
350 DO 110 iequed = 1, 2
351 equed = equeds( iequed )
352 IF( iequed.EQ.1 ) THEN
353 nfact = 3
354 ELSE
355 nfact = 1
356 END IF
357*
358 DO 100 ifact = 1, nfact
359 fact = facts( ifact )
360 prefac = lsame( fact, 'F' )
361 nofact = lsame( fact, 'N' )
362 equil = lsame( fact, 'E' )
363*
364 IF( zerot ) THEN
365 IF( prefac )
366 $ GO TO 100
367 rcondc = zero
368*
369 ELSE IF( .NOT.lsame( fact, 'N' ) ) THEN
370*
371* Compute the condition number for comparison with
372* the value returned by ZPPSVX (FACT = 'N' reuses
373* the condition number from the previous iteration
374* with FACT = 'F').
375*
376 CALL zcopy( npp, asav, 1, afac, 1 )
377 IF( equil .OR. iequed.GT.1 ) THEN
378*
379* Compute row and column scale factors to
380* equilibrate the matrix A.
381*
382 CALL zppequ( uplo, n, afac, s, scond, amax,
383 $ info )
384 IF( info.EQ.0 .AND. n.GT.0 ) THEN
385 IF( iequed.GT.1 )
386 $ scond = zero
387*
388* Equilibrate the matrix.
389*
390 CALL zlaqhp( uplo, n, afac, s, scond,
391 $ amax, equed )
392 END IF
393 END IF
394*
395* Save the condition number of the
396* non-equilibrated system for use in ZGET04.
397*
398 IF( equil )
399 $ roldc = rcondc
400*
401* Compute the 1-norm of A.
402*
403 anorm = zlanhp( '1', uplo, n, afac, rwork )
404*
405* Factor the matrix A.
406*
407 CALL zpptrf( uplo, n, afac, info )
408*
409* Form the inverse of A.
410*
411 CALL zcopy( npp, afac, 1, a, 1 )
412 CALL zpptri( uplo, n, a, info )
413*
414* Compute the 1-norm condition number of A.
415*
416 ainvnm = zlanhp( '1', uplo, n, a, rwork )
417 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
418 rcondc = one
419 ELSE
420 rcondc = ( one / anorm ) / ainvnm
421 END IF
422 END IF
423*
424* Restore the matrix A.
425*
426 CALL zcopy( npp, asav, 1, a, 1 )
427*
428* Form an exact solution and set the right hand side.
429*
430 srnamt = 'ZLARHS'
431 CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
432 $ nrhs, a, lda, xact, lda, b, lda,
433 $ iseed, info )
434 xtype = 'C'
435 CALL zlacpy( 'Full', n, nrhs, b, lda, bsav, lda )
436*
437 IF( nofact ) THEN
438*
439* --- Test ZPPSV ---
440*
441* Compute the L*L' or U'*U factorization of the
442* matrix and solve the system.
443*
444 CALL zcopy( npp, a, 1, afac, 1 )
445 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
446*
447 srnamt = 'ZPPSV '
448 CALL zppsv( uplo, n, nrhs, afac, x, lda, info )
449*
450* Check error code from ZPPSV .
451*
452 IF( info.NE.izero ) THEN
453 CALL alaerh( path, 'ZPPSV ', info, izero,
454 $ uplo, n, n, -1, -1, nrhs, imat,
455 $ nfail, nerrs, nout )
456 GO TO 70
457 ELSE IF( info.NE.0 ) THEN
458 GO TO 70
459 END IF
460*
461* Reconstruct matrix from factors and compute
462* residual.
463*
464 CALL zppt01( uplo, n, a, afac, rwork,
465 $ result( 1 ) )
466*
467* Compute residual of the computed solution.
468*
469 CALL zlacpy( 'Full', n, nrhs, b, lda, work,
470 $ lda )
471 CALL zppt02( uplo, n, nrhs, a, x, lda, work,
472 $ lda, rwork, result( 2 ) )
473*
474* Check solution from generated exact solution.
475*
476 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
477 $ result( 3 ) )
478 nt = 3
479*
480* Print information about the tests that did not
481* pass the threshold.
482*
483 DO 60 k = 1, nt
484 IF( result( k ).GE.thresh ) THEN
485 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
486 $ CALL aladhd( nout, path )
487 WRITE( nout, fmt = 9999 )'ZPPSV ', uplo,
488 $ n, imat, k, result( k )
489 nfail = nfail + 1
490 END IF
491 60 CONTINUE
492 nrun = nrun + nt
493 70 CONTINUE
494 END IF
495*
496* --- Test ZPPSVX ---
497*
498 IF( .NOT.prefac .AND. npp.GT.0 )
499 $ CALL zlaset( 'Full', npp, 1, dcmplx( zero ),
500 $ dcmplx( zero ), afac, npp )
501 CALL zlaset( 'Full', n, nrhs, dcmplx( zero ),
502 $ dcmplx( zero ), x, lda )
503 IF( iequed.GT.1 .AND. n.GT.0 ) THEN
504*
505* Equilibrate the matrix if FACT='F' and
506* EQUED='Y'.
507*
508 CALL zlaqhp( uplo, n, a, s, scond, amax, equed )
509 END IF
510*
511* Solve the system and compute the condition number
512* and error bounds using ZPPSVX.
513*
514 srnamt = 'ZPPSVX'
515 CALL zppsvx( fact, uplo, n, nrhs, a, afac, equed,
516 $ s, b, lda, x, lda, rcond, rwork,
517 $ rwork( nrhs+1 ), work,
518 $ rwork( 2*nrhs+1 ), info )
519*
520* Check the error code from ZPPSVX.
521*
522 IF( info.NE.izero ) THEN
523 CALL alaerh( path, 'ZPPSVX', info, izero,
524 $ fact // uplo, n, n, -1, -1, nrhs,
525 $ imat, nfail, nerrs, nout )
526 GO TO 90
527 END IF
528*
529 IF( info.EQ.0 ) THEN
530 IF( .NOT.prefac ) THEN
531*
532* Reconstruct matrix from factors and compute
533* residual.
534*
535 CALL zppt01( uplo, n, a, afac,
536 $ rwork( 2*nrhs+1 ), result( 1 ) )
537 k1 = 1
538 ELSE
539 k1 = 2
540 END IF
541*
542* Compute residual of the computed solution.
543*
544 CALL zlacpy( 'Full', n, nrhs, bsav, lda, work,
545 $ lda )
546 CALL zppt02( uplo, n, nrhs, asav, x, lda, work,
547 $ lda, rwork( 2*nrhs+1 ),
548 $ result( 2 ) )
549*
550* Check solution from generated exact solution.
551*
552 IF( nofact .OR. ( prefac .AND. lsame( equed,
553 $ 'N' ) ) ) THEN
554 CALL zget04( n, nrhs, x, lda, xact, lda,
555 $ rcondc, result( 3 ) )
556 ELSE
557 CALL zget04( n, nrhs, x, lda, xact, lda,
558 $ roldc, result( 3 ) )
559 END IF
560*
561* Check the error bounds from iterative
562* refinement.
563*
564 CALL zppt05( uplo, n, nrhs, asav, b, lda, x,
565 $ lda, xact, lda, rwork,
566 $ rwork( nrhs+1 ), result( 4 ) )
567 ELSE
568 k1 = 6
569 END IF
570*
571* Compare RCOND from ZPPSVX with the computed value
572* in RCONDC.
573*
574 result( 6 ) = dget06( rcond, rcondc )
575*
576* Print information about the tests that did not pass
577* the threshold.
578*
579 DO 80 k = k1, 6
580 IF( result( k ).GE.thresh ) THEN
581 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
582 $ CALL aladhd( nout, path )
583 IF( prefac ) THEN
584 WRITE( nout, fmt = 9997 )'ZPPSVX', fact,
585 $ uplo, n, equed, imat, k, result( k )
586 ELSE
587 WRITE( nout, fmt = 9998 )'ZPPSVX', fact,
588 $ uplo, n, imat, k, result( k )
589 END IF
590 nfail = nfail + 1
591 END IF
592 80 CONTINUE
593 nrun = nrun + 7 - k1
594 90 CONTINUE
595 100 CONTINUE
596 110 CONTINUE
597 120 CONTINUE
598 130 CONTINUE
599 140 CONTINUE
600*
601* Print a summary of the results.
602*
603 CALL alasvm( path, nout, nfail, nrun, nerrs )
604*
605 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i1,
606 $ ', test(', i1, ')=', g12.5 )
607 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N=', i5,
608 $ ', type ', i1, ', test(', i1, ')=', g12.5 )
609 9997 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N=', i5,
610 $ ', EQUED=''', a1, ''', type ', i1, ', test(', i1, ')=',
611 $ g12.5 )
612 RETURN
613*
614* End of ZDRVPP
615*
zlaqhp
subroutine zlaqhp(uplo, n, ap, s, scond, amax, equed)
ZLAQHP scales a Hermitian matrix stored in packed form.
Definition zlaqhp.f:126
zppsvx
subroutine zppsvx(fact, uplo, n, nrhs, ap, afp, equed, s, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
ZPPSVX computes the solution to system of linear equations A * X = B for OTHER matrices
Definition zppsvx.f:311
zppsv
subroutine zppsv(uplo, n, nrhs, ap, b, ldb, info)
ZPPSV computes the solution to system of linear equations A * X = B for OTHER matrices
Definition zppsv.f:144

◆ zdrvpt()

subroutine zdrvpt ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
complex*16, dimension( * ) a,
double precision, dimension( * ) d,
complex*16, dimension( * ) e,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer nout )

ZDRVPT

Purpose:
!>
!> ZDRVPT tests ZPTSV and -SVX.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*2)
!>
[out]D
!>          D is DOUBLE PRECISION array, dimension (NMAX*2)
!>
[out]E
!>          E is COMPLEX*16 array, dimension (NMAX*2)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(3,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 138 of file zdrvpt.f.

140*
141* -- LAPACK test routine --
142* -- LAPACK is a software package provided by Univ. of Tennessee, --
143* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
144*
145* .. Scalar Arguments ..
146 LOGICAL TSTERR
147 INTEGER NN, NOUT, NRHS
148 DOUBLE PRECISION THRESH
149* ..
150* .. Array Arguments ..
151 LOGICAL DOTYPE( * )
152 INTEGER NVAL( * )
153 DOUBLE PRECISION D( * ), RWORK( * )
154 COMPLEX*16 A( * ), B( * ), E( * ), WORK( * ), X( * ),
155 $ XACT( * )
156* ..
157*
158* =====================================================================
159*
160* .. Parameters ..
161 DOUBLE PRECISION ONE, ZERO
162 parameter( one = 1.0d+0, zero = 0.0d+0 )
163 INTEGER NTYPES
164 parameter( ntypes = 12 )
165 INTEGER NTESTS
166 parameter( ntests = 6 )
167* ..
168* .. Local Scalars ..
169 LOGICAL ZEROT
170 CHARACTER DIST, FACT, TYPE
171 CHARACTER*3 PATH
172 INTEGER I, IA, IFACT, IMAT, IN, INFO, IX, IZERO, J, K,
173 $ K1, KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT,
174 $ NRUN, NT
175 DOUBLE PRECISION AINVNM, ANORM, COND, DMAX, RCOND, RCONDC
176* ..
177* .. Local Arrays ..
178 INTEGER ISEED( 4 ), ISEEDY( 4 )
179 DOUBLE PRECISION RESULT( NTESTS ), Z( 3 )
180* ..
181* .. External Functions ..
182 INTEGER IDAMAX
183 DOUBLE PRECISION DGET06, DZASUM, ZLANHT
184 EXTERNAL idamax, dget06, dzasum, zlanht
185* ..
186* .. External Subroutines ..
187 EXTERNAL aladhd, alaerh, alasvm, dcopy, dlarnv, dscal,
188 $ zcopy, zdscal, zerrvx, zget04, zlacpy, zlaptm,
189 $ zlarnv, zlaset, zlatb4, zlatms, zptsv, zptsvx,
190 $ zptt01, zptt02, zptt05, zpttrf, zpttrs
191* ..
192* .. Intrinsic Functions ..
193 INTRINSIC abs, dcmplx, max
194* ..
195* .. Scalars in Common ..
196 LOGICAL LERR, OK
197 CHARACTER*32 SRNAMT
198 INTEGER INFOT, NUNIT
199* ..
200* .. Common blocks ..
201 COMMON / infoc / infot, nunit, ok, lerr
202 COMMON / srnamc / srnamt
203* ..
204* .. Data statements ..
205 DATA iseedy / 0, 0, 0, 1 /
206* ..
207* .. Executable Statements ..
208*
209 path( 1: 1 ) = 'Zomplex precision'
210 path( 2: 3 ) = 'PT'
211 nrun = 0
212 nfail = 0
213 nerrs = 0
214 DO 10 i = 1, 4
215 iseed( i ) = iseedy( i )
216 10 CONTINUE
217*
218* Test the error exits
219*
220 IF( tsterr )
221 $ CALL zerrvx( path, nout )
222 infot = 0
223*
224 DO 120 in = 1, nn
225*
226* Do for each value of N in NVAL.
227*
228 n = nval( in )
229 lda = max( 1, n )
230 nimat = ntypes
231 IF( n.LE.0 )
232 $ nimat = 1
233*
234 DO 110 imat = 1, nimat
235*
236* Do the tests only if DOTYPE( IMAT ) is true.
237*
238 IF( n.GT.0 .AND. .NOT.dotype( imat ) )
239 $ GO TO 110
240*
241* Set up parameters with ZLATB4.
242*
243 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
244 $ COND, DIST )
245*
246 zerot = imat.GE.8 .AND. imat.LE.10
247 IF( imat.LE.6 ) THEN
248*
249* Type 1-6: generate a symmetric tridiagonal matrix of
250* known condition number in lower triangular band storage.
251*
252 srnamt = 'ZLATMS'
253 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE, COND,
254 $ ANORM, KL, KU, 'B', A, 2, WORK, INFO )
255*
256* Check the error code from ZLATMS.
257*
258 IF( info.NE.0 ) THEN
259 CALL alaerh( path, 'ZLATMS', info, 0, ' ', n, n, kl,
260 $ ku, -1, imat, nfail, nerrs, nout )
261 GO TO 110
262 END IF
263 izero = 0
264*
265* Copy the matrix to D and E.
266*
267 ia = 1
268 DO 20 i = 1, n - 1
269 d( i ) = a( ia )
270 e( i ) = a( ia+1 )
271 ia = ia + 2
272 20 CONTINUE
273 IF( n.GT.0 )
274 $ d( n ) = a( ia )
275 ELSE
276*
277* Type 7-12: generate a diagonally dominant matrix with
278* unknown condition number in the vectors D and E.
279*
280 IF( .NOT.zerot .OR. .NOT.dotype( 7 ) ) THEN
281*
282* Let D and E have values from [-1,1].
283*
284 CALL dlarnv( 2, iseed, n, d )
285 CALL zlarnv( 2, iseed, n-1, e )
286*
287* Make the tridiagonal matrix diagonally dominant.
288*
289 IF( n.EQ.1 ) THEN
290 d( 1 ) = abs( d( 1 ) )
291 ELSE
292 d( 1 ) = abs( d( 1 ) ) + abs( e( 1 ) )
293 d( n ) = abs( d( n ) ) + abs( e( n-1 ) )
294 DO 30 i = 2, n - 1
295 d( i ) = abs( d( i ) ) + abs( e( i ) ) +
296 $ abs( e( i-1 ) )
297 30 CONTINUE
298 END IF
299*
300* Scale D and E so the maximum element is ANORM.
301*
302 ix = idamax( n, d, 1 )
303 dmax = d( ix )
304 CALL dscal( n, anorm / dmax, d, 1 )
305 IF( n.GT.1 )
306 $ CALL zdscal( n-1, anorm / dmax, e, 1 )
307*
308 ELSE IF( izero.GT.0 ) THEN
309*
310* Reuse the last matrix by copying back the zeroed out
311* elements.
312*
313 IF( izero.EQ.1 ) THEN
314 d( 1 ) = z( 2 )
315 IF( n.GT.1 )
316 $ e( 1 ) = z( 3 )
317 ELSE IF( izero.EQ.n ) THEN
318 e( n-1 ) = z( 1 )
319 d( n ) = z( 2 )
320 ELSE
321 e( izero-1 ) = z( 1 )
322 d( izero ) = z( 2 )
323 e( izero ) = z( 3 )
324 END IF
325 END IF
326*
327* For types 8-10, set one row and column of the matrix to
328* zero.
329*
330 izero = 0
331 IF( imat.EQ.8 ) THEN
332 izero = 1
333 z( 2 ) = d( 1 )
334 d( 1 ) = zero
335 IF( n.GT.1 ) THEN
336 z( 3 ) = e( 1 )
337 e( 1 ) = zero
338 END IF
339 ELSE IF( imat.EQ.9 ) THEN
340 izero = n
341 IF( n.GT.1 ) THEN
342 z( 1 ) = e( n-1 )
343 e( n-1 ) = zero
344 END IF
345 z( 2 ) = d( n )
346 d( n ) = zero
347 ELSE IF( imat.EQ.10 ) THEN
348 izero = ( n+1 ) / 2
349 IF( izero.GT.1 ) THEN
350 z( 1 ) = e( izero-1 )
351 e( izero-1 ) = zero
352 z( 3 ) = e( izero )
353 e( izero ) = zero
354 END IF
355 z( 2 ) = d( izero )
356 d( izero ) = zero
357 END IF
358 END IF
359*
360* Generate NRHS random solution vectors.
361*
362 ix = 1
363 DO 40 j = 1, nrhs
364 CALL zlarnv( 2, iseed, n, xact( ix ) )
365 ix = ix + lda
366 40 CONTINUE
367*
368* Set the right hand side.
369*
370 CALL zlaptm( 'Lower', n, nrhs, one, d, e, xact, lda, zero,
371 $ b, lda )
372*
373 DO 100 ifact = 1, 2
374 IF( ifact.EQ.1 ) THEN
375 fact = 'F'
376 ELSE
377 fact = 'N'
378 END IF
379*
380* Compute the condition number for comparison with
381* the value returned by ZPTSVX.
382*
383 IF( zerot ) THEN
384 IF( ifact.EQ.1 )
385 $ GO TO 100
386 rcondc = zero
387*
388 ELSE IF( ifact.EQ.1 ) THEN
389*
390* Compute the 1-norm of A.
391*
392 anorm = zlanht( '1', n, d, e )
393*
394 CALL dcopy( n, d, 1, d( n+1 ), 1 )
395 IF( n.GT.1 )
396 $ CALL zcopy( n-1, e, 1, e( n+1 ), 1 )
397*
398* Factor the matrix A.
399*
400 CALL zpttrf( n, d( n+1 ), e( n+1 ), info )
401*
402* Use ZPTTRS to solve for one column at a time of
403* inv(A), computing the maximum column sum as we go.
404*
405 ainvnm = zero
406 DO 60 i = 1, n
407 DO 50 j = 1, n
408 x( j ) = zero
409 50 CONTINUE
410 x( i ) = one
411 CALL zpttrs( 'Lower', n, 1, d( n+1 ), e( n+1 ), x,
412 $ lda, info )
413 ainvnm = max( ainvnm, dzasum( n, x, 1 ) )
414 60 CONTINUE
415*
416* Compute the 1-norm condition number of A.
417*
418 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
419 rcondc = one
420 ELSE
421 rcondc = ( one / anorm ) / ainvnm
422 END IF
423 END IF
424*
425 IF( ifact.EQ.2 ) THEN
426*
427* --- Test ZPTSV --
428*
429 CALL dcopy( n, d, 1, d( n+1 ), 1 )
430 IF( n.GT.1 )
431 $ CALL zcopy( n-1, e, 1, e( n+1 ), 1 )
432 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
433*
434* Factor A as L*D*L' and solve the system A*X = B.
435*
436 srnamt = 'ZPTSV '
437 CALL zptsv( n, nrhs, d( n+1 ), e( n+1 ), x, lda,
438 $ info )
439*
440* Check error code from ZPTSV .
441*
442 IF( info.NE.izero )
443 $ CALL alaerh( path, 'ZPTSV ', info, izero, ' ', n,
444 $ n, 1, 1, nrhs, imat, nfail, nerrs,
445 $ nout )
446 nt = 0
447 IF( izero.EQ.0 ) THEN
448*
449* Check the factorization by computing the ratio
450* norm(L*D*L' - A) / (n * norm(A) * EPS )
451*
452 CALL zptt01( n, d, e, d( n+1 ), e( n+1 ), work,
453 $ result( 1 ) )
454*
455* Compute the residual in the solution.
456*
457 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
458 CALL zptt02( 'Lower', n, nrhs, d, e, x, lda, work,
459 $ lda, result( 2 ) )
460*
461* Check solution from generated exact solution.
462*
463 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
464 $ result( 3 ) )
465 nt = 3
466 END IF
467*
468* Print information about the tests that did not pass
469* the threshold.
470*
471 DO 70 k = 1, nt
472 IF( result( k ).GE.thresh ) THEN
473 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
474 $ CALL aladhd( nout, path )
475 WRITE( nout, fmt = 9999 )'ZPTSV ', n, imat, k,
476 $ result( k )
477 nfail = nfail + 1
478 END IF
479 70 CONTINUE
480 nrun = nrun + nt
481 END IF
482*
483* --- Test ZPTSVX ---
484*
485 IF( ifact.GT.1 ) THEN
486*
487* Initialize D( N+1:2*N ) and E( N+1:2*N ) to zero.
488*
489 DO 80 i = 1, n - 1
490 d( n+i ) = zero
491 e( n+i ) = zero
492 80 CONTINUE
493 IF( n.GT.0 )
494 $ d( n+n ) = zero
495 END IF
496*
497 CALL zlaset( 'Full', n, nrhs, dcmplx( zero ),
498 $ dcmplx( zero ), x, lda )
499*
500* Solve the system and compute the condition number and
501* error bounds using ZPTSVX.
502*
503 srnamt = 'ZPTSVX'
504 CALL zptsvx( fact, n, nrhs, d, e, d( n+1 ), e( n+1 ), b,
505 $ lda, x, lda, rcond, rwork, rwork( nrhs+1 ),
506 $ work, rwork( 2*nrhs+1 ), info )
507*
508* Check the error code from ZPTSVX.
509*
510 IF( info.NE.izero )
511 $ CALL alaerh( path, 'ZPTSVX', info, izero, fact, n, n,
512 $ 1, 1, nrhs, imat, nfail, nerrs, nout )
513 IF( izero.EQ.0 ) THEN
514 IF( ifact.EQ.2 ) THEN
515*
516* Check the factorization by computing the ratio
517* norm(L*D*L' - A) / (n * norm(A) * EPS )
518*
519 k1 = 1
520 CALL zptt01( n, d, e, d( n+1 ), e( n+1 ), work,
521 $ result( 1 ) )
522 ELSE
523 k1 = 2
524 END IF
525*
526* Compute the residual in the solution.
527*
528 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
529 CALL zptt02( 'Lower', n, nrhs, d, e, x, lda, work,
530 $ lda, result( 2 ) )
531*
532* Check solution from generated exact solution.
533*
534 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
535 $ result( 3 ) )
536*
537* Check error bounds from iterative refinement.
538*
539 CALL zptt05( n, nrhs, d, e, b, lda, x, lda, xact, lda,
540 $ rwork, rwork( nrhs+1 ), result( 4 ) )
541 ELSE
542 k1 = 6
543 END IF
544*
545* Check the reciprocal of the condition number.
546*
547 result( 6 ) = dget06( rcond, rcondc )
548*
549* Print information about the tests that did not pass
550* the threshold.
551*
552 DO 90 k = k1, 6
553 IF( result( k ).GE.thresh ) THEN
554 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
555 $ CALL aladhd( nout, path )
556 WRITE( nout, fmt = 9998 )'ZPTSVX', fact, n, imat,
557 $ k, result( k )
558 nfail = nfail + 1
559 END IF
560 90 CONTINUE
561 nrun = nrun + 7 - k1
562 100 CONTINUE
563 110 CONTINUE
564 120 CONTINUE
565*
566* Print a summary of the results.
567*
568 CALL alasvm( path, nout, nfail, nrun, nerrs )
569*
570 9999 FORMAT( 1x, a, ', N =', i5, ', type ', i2, ', test ', i2,
571 $ ', ratio = ', g12.5 )
572 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', N =', i5, ', type ', i2,
573 $ ', test ', i2, ', ratio = ', g12.5 )
574 RETURN
575*
576* End of ZDRVPT
577*
zptsvx
subroutine zptsvx(fact, n, nrhs, d, e, df, ef, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
ZPTSVX computes the solution to system of linear equations A * X = B for PT matrices
Definition zptsvx.f:234
zptsv
subroutine zptsv(n, nrhs, d, e, b, ldb, info)
ZPTSV computes the solution to system of linear equations A * X = B for PT matrices
Definition zptsv.f:115

◆ zdrvrf1()

subroutine zdrvrf1 ( integer nout,
integer nn,
integer, dimension( nn ) nval,
double precision thresh,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) arf,
double precision, dimension( * ) work )

ZDRVRF1

Purpose:
!>
!> ZDRVRF1 tests the LAPACK RFP routines:
!>     ZLANHF.F
!>
Parameters
[in]NOUT
!>          NOUT is INTEGER
!>                The unit number for output.
!>
[in]NN
!>          NN is INTEGER
!>                The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>                The values of the matrix dimension N.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>                The threshold value for the test ratios.  A result is
!>                included in the output file if RESULT >= THRESH.  To have
!>                every test ratio printed, use THRESH = 0.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA,NMAX)
!>
[in]LDA
!>          LDA is INTEGER
!>                The leading dimension of the array A.  LDA >= max(1,NMAX).
!>
[out]ARF
!>          ARF is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension ( NMAX )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 94 of file zdrvrf1.f.

95*
96* -- LAPACK test routine --
97* -- LAPACK is a software package provided by Univ. of Tennessee, --
98* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
99*
100* .. Scalar Arguments ..
101 INTEGER LDA, NN, NOUT
102 DOUBLE PRECISION THRESH
103* ..
104* .. Array Arguments ..
105 INTEGER NVAL( NN )
106 DOUBLE PRECISION WORK( * )
107 COMPLEX*16 A( LDA, * ), ARF( * )
108* ..
109*
110* =====================================================================
111* ..
112* .. Parameters ..
113 DOUBLE PRECISION ONE
114 parameter( one = 1.0d+0 )
115 INTEGER NTESTS
116 parameter( ntests = 1 )
117* ..
118* .. Local Scalars ..
119 CHARACTER UPLO, CFORM, NORM
120 INTEGER I, IFORM, IIN, IIT, INFO, INORM, IUPLO, J, N,
121 + NERRS, NFAIL, NRUN
122 DOUBLE PRECISION EPS, LARGE, NORMA, NORMARF, SMALL
123* ..
124* .. Local Arrays ..
125 CHARACTER UPLOS( 2 ), FORMS( 2 ), NORMS( 4 )
126 INTEGER ISEED( 4 ), ISEEDY( 4 )
127 DOUBLE PRECISION RESULT( NTESTS )
128* ..
129* .. External Functions ..
130 COMPLEX*16 ZLARND
131 DOUBLE PRECISION DLAMCH, ZLANHE, ZLANHF
132 EXTERNAL dlamch, zlarnd, zlanhe, zlanhf
133* ..
134* .. External Subroutines ..
135 EXTERNAL ztrttf
136* ..
137* .. Scalars in Common ..
138 CHARACTER*32 SRNAMT
139* ..
140* .. Common blocks ..
141 COMMON / srnamc / srnamt
142* ..
143* .. Data statements ..
144 DATA iseedy / 1988, 1989, 1990, 1991 /
145 DATA uplos / 'U', 'L' /
146 DATA forms / 'N', 'C' /
147 DATA norms / 'M', '1', 'I', 'F' /
148* ..
149* .. Executable Statements ..
150*
151* Initialize constants and the random number seed.
152*
153 nrun = 0
154 nfail = 0
155 nerrs = 0
156 info = 0
157 DO 10 i = 1, 4
158 iseed( i ) = iseedy( i )
159 10 CONTINUE
160*
161 eps = dlamch( 'Precision' )
162 small = dlamch( 'Safe minimum' )
163 large = one / small
164 small = small * lda * lda
165 large = large / lda / lda
166*
167 DO 130 iin = 1, nn
168*
169 n = nval( iin )
170*
171 DO 120 iit = 1, 3
172* Nothing to do for N=0
173 IF ( n .EQ. 0 ) EXIT
174*
175* IIT = 1 : random matrix
176* IIT = 2 : random matrix scaled near underflow
177* IIT = 3 : random matrix scaled near overflow
178*
179 DO j = 1, n
180 DO i = 1, n
181 a( i, j) = zlarnd( 4, iseed )
182 END DO
183 END DO
184*
185 IF ( iit.EQ.2 ) THEN
186 DO j = 1, n
187 DO i = 1, n
188 a( i, j) = a( i, j ) * large
189 END DO
190 END DO
191 END IF
192*
193 IF ( iit.EQ.3 ) THEN
194 DO j = 1, n
195 DO i = 1, n
196 a( i, j) = a( i, j) * small
197 END DO
198 END DO
199 END IF
200*
201* Do first for UPLO = 'U', then for UPLO = 'L'
202*
203 DO 110 iuplo = 1, 2
204*
205 uplo = uplos( iuplo )
206*
207* Do first for CFORM = 'N', then for CFORM = 'C'
208*
209 DO 100 iform = 1, 2
210*
211 cform = forms( iform )
212*
213 srnamt = 'ZTRTTF'
214 CALL ztrttf( cform, uplo, n, a, lda, arf, info )
215*
216* Check error code from ZTRTTF
217*
218 IF( info.NE.0 ) THEN
219 IF( nfail.EQ.0 .AND. nerrs.EQ.0 ) THEN
220 WRITE( nout, * )
221 WRITE( nout, fmt = 9999 )
222 END IF
223 WRITE( nout, fmt = 9998 ) srnamt, uplo, cform, n
224 nerrs = nerrs + 1
225 GO TO 100
226 END IF
227*
228 DO 90 inorm = 1, 4
229*
230* Check all four norms: 'M', '1', 'I', 'F'
231*
232 norm = norms( inorm )
233 normarf = zlanhf( norm, cform, uplo, n, arf, work )
234 norma = zlanhe( norm, uplo, n, a, lda, work )
235*
236 result(1) = ( norma - normarf ) / norma / eps
237 nrun = nrun + 1
238*
239 IF( result(1).GE.thresh ) THEN
240 IF( nfail.EQ.0 .AND. nerrs.EQ.0 ) THEN
241 WRITE( nout, * )
242 WRITE( nout, fmt = 9999 )
243 END IF
244 WRITE( nout, fmt = 9997 ) 'ZLANHF',
245 + n, iit, uplo, cform, norm, result(1)
246 nfail = nfail + 1
247 END IF
248 90 CONTINUE
249 100 CONTINUE
250 110 CONTINUE
251 120 CONTINUE
252 130 CONTINUE
253*
254* Print a summary of the results.
255*
256 IF ( nfail.EQ.0 ) THEN
257 WRITE( nout, fmt = 9996 ) 'ZLANHF', nrun
258 ELSE
259 WRITE( nout, fmt = 9995 ) 'ZLANHF', nfail, nrun
260 END IF
261 IF ( nerrs.NE.0 ) THEN
262 WRITE( nout, fmt = 9994 ) nerrs, 'ZLANHF'
263 END IF
264*
265 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing ZLANHF
266 + ***')
267 9998 FORMAT( 1x, ' Error in ',a6,' with UPLO=''',a1,''', FORM=''',
268 + a1,''', N=',i5)
269 9997 FORMAT( 1x, ' Failure in ',a6,' N=',i5,' TYPE=',i5,' UPLO=''',
270 + a1, ''', FORM =''',a1,''', NORM=''',a1,''', test=',g12.5)
271 9996 FORMAT( 1x, 'All tests for ',a6,' auxiliary routine passed the ',
272 + 'threshold ( ',i5,' tests run)')
273 9995 FORMAT( 1x, a6, ' auxiliary routine:',i5,' out of ',i5,
274 + ' tests failed to pass the threshold')
275 9994 FORMAT( 26x, i5,' error message recorded (',a6,')')
276*
277 RETURN
278*
279* End of ZDRVRF1
280*
zlanhf
double precision function zlanhf(norm, transr, uplo, n, a, work)
ZLANHF returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlanhf.f:246
ztrttf
subroutine ztrttf(transr, uplo, n, a, lda, arf, info)
ZTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed f...
Definition ztrttf.f:216
zlarnd
complex *16 function zlarnd(idist, iseed)
ZLARND
Definition zlarnd.f:75

◆ zdrvrf2()

subroutine zdrvrf2 ( integer nout,
integer nn,
integer, dimension( nn ) nval,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) arf,
complex*16, dimension(*) ap,
complex*16, dimension( lda, * ) asav )

ZDRVRF2

Purpose:
!>
!> ZDRVRF2 tests the LAPACK RFP conversion routines.
!>
Parameters
[in]NOUT
!>          NOUT is INTEGER
!>                The unit number for output.
!>
[in]NN
!>          NN is INTEGER
!>                The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>                The values of the matrix dimension N.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA,NMAX)
!>
[in]LDA
!>          LDA is INTEGER
!>                The leading dimension of the array A.  LDA >= max(1,NMAX).
!>
[out]ARF
!>          ARF is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2).
!>
[out]AP
!>          AP is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2).
!>
[out]ASAV
!>          ASAV is COMPLEX*16 array, dimension (LDA,NMAX)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 88 of file zdrvrf2.f.

89*
90* -- LAPACK test routine --
91* -- LAPACK is a software package provided by Univ. of Tennessee, --
92* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
93*
94* .. Scalar Arguments ..
95 INTEGER LDA, NN, NOUT
96* ..
97* .. Array Arguments ..
98 INTEGER NVAL( NN )
99 COMPLEX*16 A( LDA, * ), ARF( * ), AP(*), ASAV( LDA, * )
100* ..
101*
102* =====================================================================
103* ..
104* .. Local Scalars ..
105 LOGICAL LOWER, OK1, OK2
106 CHARACTER UPLO, CFORM
107 INTEGER I, IFORM, IIN, INFO, IUPLO, J, N,
108 + NERRS, NRUN
109* ..
110* .. Local Arrays ..
111 CHARACTER UPLOS( 2 ), FORMS( 2 )
112 INTEGER ISEED( 4 ), ISEEDY( 4 )
113* ..
114* .. External Functions ..
115 COMPLEX*16 ZLARND
116 EXTERNAL zlarnd
117* ..
118* .. External Subroutines ..
119 EXTERNAL ztfttr, ztfttp, ztrttf, ztrttp, ztpttr, ztpttf
120* ..
121* .. Scalars in Common ..
122 CHARACTER*32 SRNAMT
123* ..
124* .. Common blocks ..
125 COMMON / srnamc / srnamt
126* ..
127* .. Data statements ..
128 DATA iseedy / 1988, 1989, 1990, 1991 /
129 DATA uplos / 'U', 'L' /
130 DATA forms / 'N', 'C' /
131* ..
132* .. Executable Statements ..
133*
134* Initialize constants and the random number seed.
135*
136 nrun = 0
137 nerrs = 0
138 info = 0
139 DO 10 i = 1, 4
140 iseed( i ) = iseedy( i )
141 10 CONTINUE
142*
143 DO 120 iin = 1, nn
144*
145 n = nval( iin )
146*
147* Do first for UPLO = 'U', then for UPLO = 'L'
148*
149 DO 110 iuplo = 1, 2
150*
151 uplo = uplos( iuplo )
152 lower = .true.
153 IF ( iuplo.EQ.1 ) lower = .false.
154*
155* Do first for CFORM = 'N', then for CFORM = 'C'
156*
157 DO 100 iform = 1, 2
158*
159 cform = forms( iform )
160*
161 nrun = nrun + 1
162*
163 DO j = 1, n
164 DO i = 1, n
165 a( i, j) = zlarnd( 4, iseed )
166 END DO
167 END DO
168*
169 srnamt = 'ZTRTTF'
170 CALL ztrttf( cform, uplo, n, a, lda, arf, info )
171*
172 srnamt = 'ZTFTTP'
173 CALL ztfttp( cform, uplo, n, arf, ap, info )
174*
175 srnamt = 'ZTPTTR'
176 CALL ztpttr( uplo, n, ap, asav, lda, info )
177*
178 ok1 = .true.
179 IF ( lower ) THEN
180 DO j = 1, n
181 DO i = j, n
182 IF ( a(i,j).NE.asav(i,j) ) THEN
183 ok1 = .false.
184 END IF
185 END DO
186 END DO
187 ELSE
188 DO j = 1, n
189 DO i = 1, j
190 IF ( a(i,j).NE.asav(i,j) ) THEN
191 ok1 = .false.
192 END IF
193 END DO
194 END DO
195 END IF
196*
197 nrun = nrun + 1
198*
199 srnamt = 'ZTRTTP'
200 CALL ztrttp( uplo, n, a, lda, ap, info )
201*
202 srnamt = 'ZTPTTF'
203 CALL ztpttf( cform, uplo, n, ap, arf, info )
204*
205 srnamt = 'ZTFTTR'
206 CALL ztfttr( cform, uplo, n, arf, asav, lda, info )
207*
208 ok2 = .true.
209 IF ( lower ) THEN
210 DO j = 1, n
211 DO i = j, n
212 IF ( a(i,j).NE.asav(i,j) ) THEN
213 ok2 = .false.
214 END IF
215 END DO
216 END DO
217 ELSE
218 DO j = 1, n
219 DO i = 1, j
220 IF ( a(i,j).NE.asav(i,j) ) THEN
221 ok2 = .false.
222 END IF
223 END DO
224 END DO
225 END IF
226*
227 IF (( .NOT.ok1 ).OR.( .NOT.ok2 )) THEN
228 IF( nerrs.EQ.0 ) THEN
229 WRITE( nout, * )
230 WRITE( nout, fmt = 9999 )
231 END IF
232 WRITE( nout, fmt = 9998 ) n, uplo, cform
233 nerrs = nerrs + 1
234 END IF
235*
236 100 CONTINUE
237 110 CONTINUE
238 120 CONTINUE
239*
240* Print a summary of the results.
241*
242 IF ( nerrs.EQ.0 ) THEN
243 WRITE( nout, fmt = 9997 ) nrun
244 ELSE
245 WRITE( nout, fmt = 9996 ) nerrs, nrun
246 END IF
247*
248 9999 FORMAT( 1x, ' *** Error(s) while testing the RFP conversion',
249 + ' routines ***')
250 9998 FORMAT( 1x, ' Error in RFP,conversion routines N=',i5,
251 + ' UPLO=''', a1, ''', FORM =''',a1,'''')
252 9997 FORMAT( 1x, 'All tests for the RFP conversion routines passed (',
253 + i5,' tests run)')
254 9996 FORMAT( 1x, 'RFP conversion routines:',i5,' out of ',i5,
255 + ' error message recorded')
256*
257 RETURN
258*
259* End of ZDRVRF2
260*
ztpttr
subroutine ztpttr(uplo, n, ap, a, lda, info)
ZTPTTR copies a triangular matrix from the standard packed format (TP) to the standard full format (T...
Definition ztpttr.f:104
ztfttp
subroutine ztfttp(transr, uplo, n, arf, ap, info)
ZTFTTP copies a triangular matrix from the rectangular full packed format (TF) to the standard packed...
Definition ztfttp.f:208
ztrttp
subroutine ztrttp(uplo, n, a, lda, ap, info)
ZTRTTP copies a triangular matrix from the standard full format (TR) to the standard packed format (T...
Definition ztrttp.f:104
ztpttf
subroutine ztpttf(transr, uplo, n, ap, arf, info)
ZTPTTF copies a triangular matrix from the standard packed format (TP) to the rectangular full packed...
Definition ztpttf.f:207
ztfttr
subroutine ztfttr(transr, uplo, n, arf, a, lda, info)
ZTFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full f...
Definition ztfttr.f:216

◆ zdrvrf3()

subroutine zdrvrf3 ( integer nout,
integer nn,
integer, dimension( nn ) nval,
double precision thresh,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) arf,
complex*16, dimension( lda, * ) b1,
complex*16, dimension( lda, * ) b2,
double precision, dimension( * ) d_work_zlange,
complex*16, dimension( * ) z_work_zgeqrf,
complex*16, dimension( * ) tau )

ZDRVRF3

Purpose:
!>
!> ZDRVRF3 tests the LAPACK RFP routines:
!>     ZTFSM
!>
Parameters
[in]NOUT
!>          NOUT is INTEGER
!>                The unit number for output.
!>
[in]NN
!>          NN is INTEGER
!>                The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>                The values of the matrix dimension N.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>                The threshold value for the test ratios.  A result is
!>                included in the output file if RESULT >= THRESH.  To have
!>                every test ratio printed, use THRESH = 0.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA,NMAX)
!>
[in]LDA
!>          LDA is INTEGER
!>                The leading dimension of the array A.  LDA >= max(1,NMAX).
!>
[out]ARF
!>          ARF is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2).
!>
[out]B1
!>          B1 is COMPLEX*16 array, dimension (LDA,NMAX)
!>
[out]B2
!>          B2 is COMPLEX*16 array, dimension (LDA,NMAX)
!>
[out]D_WORK_ZLANGE
!>          D_WORK_ZLANGE is DOUBLE PRECISION array, dimension (NMAX)
!>
[out]Z_WORK_ZGEQRF
!>          Z_WORK_ZGEQRF is COMPLEX*16 array, dimension (NMAX)
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (NMAX)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 117 of file zdrvrf3.f.

119*
120* -- LAPACK test routine --
121* -- LAPACK is a software package provided by Univ. of Tennessee, --
122* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
123*
124* .. Scalar Arguments ..
125 INTEGER LDA, NN, NOUT
126 DOUBLE PRECISION THRESH
127* ..
128* .. Array Arguments ..
129 INTEGER NVAL( NN )
130 DOUBLE PRECISION D_WORK_ZLANGE( * )
131 COMPLEX*16 A( LDA, * ), ARF( * ), B1( LDA, * ),
132 + B2( LDA, * )
133 COMPLEX*16 Z_WORK_ZGEQRF( * ), TAU( * )
134* ..
135*
136* =====================================================================
137* ..
138* .. Parameters ..
139 COMPLEX*16 ZERO, ONE
140 parameter( zero = ( 0.0d+0, 0.0d+0 ) ,
141 + one = ( 1.0d+0, 0.0d+0 ) )
142 INTEGER NTESTS
143 parameter( ntests = 1 )
144* ..
145* .. Local Scalars ..
146 CHARACTER UPLO, CFORM, DIAG, TRANS, SIDE
147 INTEGER I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA,
148 + NFAIL, NRUN, ISIDE, IDIAG, IALPHA, ITRANS
149 COMPLEX*16 ALPHA
150 DOUBLE PRECISION EPS
151* ..
152* .. Local Arrays ..
153 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ),
154 + DIAGS( 2 ), SIDES( 2 )
155 INTEGER ISEED( 4 ), ISEEDY( 4 )
156 DOUBLE PRECISION RESULT( NTESTS )
157* ..
158* .. External Functions ..
159 DOUBLE PRECISION DLAMCH, ZLANGE
160 COMPLEX*16 ZLARND
161 EXTERNAL dlamch, zlarnd, zlange
162* ..
163* .. External Subroutines ..
164 EXTERNAL ztrttf, zgeqrf, zgeqlf, ztfsm, ztrsm
165* ..
166* .. Intrinsic Functions ..
167 INTRINSIC max, sqrt
168* ..
169* .. Scalars in Common ..
170 CHARACTER*32 SRNAMT
171* ..
172* .. Common blocks ..
173 COMMON / srnamc / srnamt
174* ..
175* .. Data statements ..
176 DATA iseedy / 1988, 1989, 1990, 1991 /
177 DATA uplos / 'U', 'L' /
178 DATA forms / 'N', 'C' /
179 DATA sides / 'L', 'R' /
180 DATA transs / 'N', 'C' /
181 DATA diags / 'N', 'U' /
182* ..
183* .. Executable Statements ..
184*
185* Initialize constants and the random number seed.
186*
187 nrun = 0
188 nfail = 0
189 info = 0
190 DO 10 i = 1, 4
191 iseed( i ) = iseedy( i )
192 10 CONTINUE
193 eps = dlamch( 'Precision' )
194*
195 DO 170 iim = 1, nn
196*
197 m = nval( iim )
198*
199 DO 160 iin = 1, nn
200*
201 n = nval( iin )
202*
203 DO 150 iform = 1, 2
204*
205 cform = forms( iform )
206*
207 DO 140 iuplo = 1, 2
208*
209 uplo = uplos( iuplo )
210*
211 DO 130 iside = 1, 2
212*
213 side = sides( iside )
214*
215 DO 120 itrans = 1, 2
216*
217 trans = transs( itrans )
218*
219 DO 110 idiag = 1, 2
220*
221 diag = diags( idiag )
222*
223 DO 100 ialpha = 1, 3
224*
225 IF ( ialpha.EQ. 1) THEN
226 alpha = zero
227 ELSE IF ( ialpha.EQ. 2) THEN
228 alpha = one
229 ELSE
230 alpha = zlarnd( 4, iseed )
231 END IF
232*
233* All the parameters are set:
234* CFORM, SIDE, UPLO, TRANS, DIAG, M, N,
235* and ALPHA
236* READY TO TEST!
237*
238 nrun = nrun + 1
239*
240 IF ( iside.EQ.1 ) THEN
241*
242* The case ISIDE.EQ.1 is when SIDE.EQ.'L'
243* -> A is M-by-M ( B is M-by-N )
244*
245 na = m
246*
247 ELSE
248*
249* The case ISIDE.EQ.2 is when SIDE.EQ.'R'
250* -> A is N-by-N ( B is M-by-N )
251*
252 na = n
253*
254 END IF
255*
256* Generate A our NA--by--NA triangular
257* matrix.
258* Our test is based on forward error so we
259* do want A to be well conditioned! To get
260* a well-conditioned triangular matrix, we
261* take the R factor of the QR/LQ factorization
262* of a random matrix.
263*
264 DO j = 1, na
265 DO i = 1, na
266 a( i, j) = zlarnd( 4, iseed )
267 END DO
268 END DO
269*
270 IF ( iuplo.EQ.1 ) THEN
271*
272* The case IUPLO.EQ.1 is when SIDE.EQ.'U'
273* -> QR factorization.
274*
275 srnamt = 'ZGEQRF'
276 CALL zgeqrf( na, na, a, lda, tau,
277 + z_work_zgeqrf, lda,
278 + info )
279 ELSE
280*
281* The case IUPLO.EQ.2 is when SIDE.EQ.'L'
282* -> QL factorization.
283*
284 srnamt = 'ZGELQF'
285 CALL zgelqf( na, na, a, lda, tau,
286 + z_work_zgeqrf, lda,
287 + info )
288 END IF
289*
290* After the QR factorization, the diagonal
291* of A is made of real numbers, we multiply
292* by a random complex number of absolute
293* value 1.0E+00.
294*
295 DO j = 1, na
296 a( j, j) = a(j,j) * zlarnd( 5, iseed )
297 END DO
298*
299* Store a copy of A in RFP format (in ARF).
300*
301 srnamt = 'ZTRTTF'
302 CALL ztrttf( cform, uplo, na, a, lda, arf,
303 + info )
304*
305* Generate B1 our M--by--N right-hand side
306* and store a copy in B2.
307*
308 DO j = 1, n
309 DO i = 1, m
310 b1( i, j) = zlarnd( 4, iseed )
311 b2( i, j) = b1( i, j)
312 END DO
313 END DO
314*
315* Solve op( A ) X = B or X op( A ) = B
316* with ZTRSM
317*
318 srnamt = 'ZTRSM'
319 CALL ztrsm( side, uplo, trans, diag, m, n,
320 + alpha, a, lda, b1, lda )
321*
322* Solve op( A ) X = B or X op( A ) = B
323* with ZTFSM
324*
325 srnamt = 'ZTFSM'
326 CALL ztfsm( cform, side, uplo, trans,
327 + diag, m, n, alpha, arf, b2,
328 + lda )
329*
330* Check that the result agrees.
331*
332 DO j = 1, n
333 DO i = 1, m
334 b1( i, j) = b2( i, j ) - b1( i, j )
335 END DO
336 END DO
337*
338 result(1) = zlange( 'I', m, n, b1, lda,
339 + d_work_zlange )
340*
341 result(1) = result(1) / sqrt( eps )
342 + / max( max( m, n), 1 )
343*
344 IF( result(1).GE.thresh ) THEN
345 IF( nfail.EQ.0 ) THEN
346 WRITE( nout, * )
347 WRITE( nout, fmt = 9999 )
348 END IF
349 WRITE( nout, fmt = 9997 ) 'ZTFSM',
350 + cform, side, uplo, trans, diag, m,
351 + n, result(1)
352 nfail = nfail + 1
353 END IF
354*
355 100 CONTINUE
356 110 CONTINUE
357 120 CONTINUE
358 130 CONTINUE
359 140 CONTINUE
360 150 CONTINUE
361 160 CONTINUE
362 170 CONTINUE
363*
364* Print a summary of the results.
365*
366 IF ( nfail.EQ.0 ) THEN
367 WRITE( nout, fmt = 9996 ) 'ZTFSM', nrun
368 ELSE
369 WRITE( nout, fmt = 9995 ) 'ZTFSM', nfail, nrun
370 END IF
371*
372 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing ZTFSM
373 + ***')
374 9997 FORMAT( 1x, ' Failure in ',a5,', CFORM=''',a1,''',',
375 + ' SIDE=''',a1,''',',' UPLO=''',a1,''',',' TRANS=''',a1,''',',
376 + ' DIAG=''',a1,''',',' M=',i3,', N =', i3,', test=',g12.5)
377 9996 FORMAT( 1x, 'All tests for ',a5,' auxiliary routine passed the ',
378 + 'threshold ( ',i5,' tests run)')
379 9995 FORMAT( 1x, a6, ' auxiliary routine:',i5,' out of ',i5,
380 + ' tests failed to pass the threshold')
381*
382 RETURN
383*
384* End of ZDRVRF3
385*
zgelqf
subroutine zgelqf(m, n, a, lda, tau, work, lwork, info)
ZGELQF
Definition zgelqf.f:143
zgeqlf
subroutine zgeqlf(m, n, a, lda, tau, work, lwork, info)
ZGEQLF
Definition zgeqlf.f:138
ztfsm
subroutine ztfsm(transr, side, uplo, trans, diag, m, n, alpha, a, b, ldb)
ZTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
Definition ztfsm.f:298
ztrsm
subroutine ztrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRSM
Definition ztrsm.f:180
zgeqrf
subroutine zgeqrf(m, n, a, lda, tau, work, lwork, info)
ZGEQRF VARIANT: left-looking Level 3 BLAS of the algorithm.
Definition zgeqrf.f:151

◆ zdrvrf4()

subroutine zdrvrf4 ( integer nout,
integer nn,
integer, dimension( nn ) nval,
double precision thresh,
complex*16, dimension( ldc, * ) c1,
complex*16, dimension( ldc, *) c2,
integer ldc,
complex*16, dimension( * ) crf,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) d_work_zlange )

ZDRVRF4

Purpose:
!>
!> ZDRVRF4 tests the LAPACK RFP routines:
!>     ZHFRK
!>
Parameters
[in]NOUT
!>          NOUT is INTEGER
!>                The unit number for output.
!>
[in]NN
!>          NN is INTEGER
!>                The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>                The values of the matrix dimension N.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>                The threshold value for the test ratios.  A result is
!>                included in the output file if RESULT >= THRESH.  To have
!>                every test ratio printed, use THRESH = 0.
!>
[out]C1
!>          C1 is COMPLEX*16 array, dimension (LDC,NMAX)
!>
[out]C2
!>          C2 is COMPLEX*16 array, dimension (LDC,NMAX)
!>
[in]LDC
!>          LDC is INTEGER
!>                The leading dimension of the array A.  LDA >= max(1,NMAX).
!>
[out]CRF
!>          CRF is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2).
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA,NMAX)
!>
[in]LDA
!>          LDA is INTEGER
!>                The leading dimension of the array A.  LDA >= max(1,NMAX).
!>
[out]D_WORK_ZLANGE
!>          D_WORK_ZLANGE is DOUBLE PRECISION array, dimension (NMAX)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 112 of file zdrvrf4.f.

114*
115* -- LAPACK test routine --
116* -- LAPACK is a software package provided by Univ. of Tennessee, --
117* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
118*
119* .. Scalar Arguments ..
120 INTEGER LDA, LDC, NN, NOUT
121 DOUBLE PRECISION THRESH
122* ..
123* .. Array Arguments ..
124 INTEGER NVAL( NN )
125 DOUBLE PRECISION D_WORK_ZLANGE( * )
126 COMPLEX*16 A( LDA, * ), C1( LDC, * ), C2( LDC, *),
127 + CRF( * )
128* ..
129*
130* =====================================================================
131* ..
132* .. Parameters ..
133 DOUBLE PRECISION ZERO, ONE
134 parameter( zero = 0.0d+0, one = 1.0d+0 )
135 INTEGER NTESTS
136 parameter( ntests = 1 )
137* ..
138* .. Local Scalars ..
139 CHARACTER UPLO, CFORM, TRANS
140 INTEGER I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N,
141 + NFAIL, NRUN, IALPHA, ITRANS
142 DOUBLE PRECISION ALPHA, BETA, EPS, NORMA, NORMC
143* ..
144* .. Local Arrays ..
145 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 )
146 INTEGER ISEED( 4 ), ISEEDY( 4 )
147 DOUBLE PRECISION RESULT( NTESTS )
148* ..
149* .. External Functions ..
150 DOUBLE PRECISION DLAMCH, DLARND, ZLANGE
151 COMPLEX*16 ZLARND
152 EXTERNAL dlamch, dlarnd, zlange, zlarnd
153* ..
154* .. External Subroutines ..
155 EXTERNAL zherk, zhfrk, ztfttr, ztrttf
156* ..
157* .. Intrinsic Functions ..
158 INTRINSIC dabs, max
159* ..
160* .. Scalars in Common ..
161 CHARACTER*32 SRNAMT
162* ..
163* .. Common blocks ..
164 COMMON / srnamc / srnamt
165* ..
166* .. Data statements ..
167 DATA iseedy / 1988, 1989, 1990, 1991 /
168 DATA uplos / 'U', 'L' /
169 DATA forms / 'N', 'C' /
170 DATA transs / 'N', 'C' /
171* ..
172* .. Executable Statements ..
173*
174* Initialize constants and the random number seed.
175*
176 nrun = 0
177 nfail = 0
178 info = 0
179 DO 10 i = 1, 4
180 iseed( i ) = iseedy( i )
181 10 CONTINUE
182 eps = dlamch( 'Precision' )
183*
184 DO 150 iin = 1, nn
185*
186 n = nval( iin )
187*
188 DO 140 iik = 1, nn
189*
190 k = nval( iin )
191*
192 DO 130 iform = 1, 2
193*
194 cform = forms( iform )
195*
196 DO 120 iuplo = 1, 2
197*
198 uplo = uplos( iuplo )
199*
200 DO 110 itrans = 1, 2
201*
202 trans = transs( itrans )
203*
204 DO 100 ialpha = 1, 4
205*
206 IF ( ialpha.EQ. 1) THEN
207 alpha = zero
208 beta = zero
209 ELSE IF ( ialpha.EQ. 2) THEN
210 alpha = one
211 beta = zero
212 ELSE IF ( ialpha.EQ. 3) THEN
213 alpha = zero
214 beta = one
215 ELSE
216 alpha = dlarnd( 2, iseed )
217 beta = dlarnd( 2, iseed )
218 END IF
219*
220* All the parameters are set:
221* CFORM, UPLO, TRANS, M, N,
222* ALPHA, and BETA
223* READY TO TEST!
224*
225 nrun = nrun + 1
226*
227 IF ( itrans.EQ.1 ) THEN
228*
229* In this case we are NOTRANS, so A is N-by-K
230*
231 DO j = 1, k
232 DO i = 1, n
233 a( i, j) = zlarnd( 4, iseed )
234 END DO
235 END DO
236*
237 norma = zlange( 'I', n, k, a, lda,
238 + d_work_zlange )
239*
240 ELSE
241*
242* In this case we are TRANS, so A is K-by-N
243*
244 DO j = 1,n
245 DO i = 1, k
246 a( i, j) = zlarnd( 4, iseed )
247 END DO
248 END DO
249*
250 norma = zlange( 'I', k, n, a, lda,
251 + d_work_zlange )
252*
253 END IF
254*
255*
256* Generate C1 our N--by--N Hermitian matrix.
257* Make sure C2 has the same upper/lower part,
258* (the one that we do not touch), so
259* copy the initial C1 in C2 in it.
260*
261 DO j = 1, n
262 DO i = 1, n
263 c1( i, j) = zlarnd( 4, iseed )
264 c2(i,j) = c1(i,j)
265 END DO
266 END DO
267*
268* (See comment later on for why we use ZLANGE and
269* not ZLANHE for C1.)
270*
271 normc = zlange( 'I', n, n, c1, ldc,
272 + d_work_zlange )
273*
274 srnamt = 'ZTRTTF'
275 CALL ztrttf( cform, uplo, n, c1, ldc, crf,
276 + info )
277*
278* call zherk the BLAS routine -> gives C1
279*
280 srnamt = 'ZHERK '
281 CALL zherk( uplo, trans, n, k, alpha, a, lda,
282 + beta, c1, ldc )
283*
284* call zhfrk the RFP routine -> gives CRF
285*
286 srnamt = 'ZHFRK '
287 CALL zhfrk( cform, uplo, trans, n, k, alpha, a,
288 + lda, beta, crf )
289*
290* convert CRF in full format -> gives C2
291*
292 srnamt = 'ZTFTTR'
293 CALL ztfttr( cform, uplo, n, crf, c2, ldc,
294 + info )
295*
296* compare C1 and C2
297*
298 DO j = 1, n
299 DO i = 1, n
300 c1(i,j) = c1(i,j)-c2(i,j)
301 END DO
302 END DO
303*
304* Yes, C1 is Hermitian so we could call ZLANHE,
305* but we want to check the upper part that is
306* supposed to be unchanged and the diagonal that
307* is supposed to be real -> ZLANGE
308*
309 result(1) = zlange( 'I', n, n, c1, ldc,
310 + d_work_zlange )
311 result(1) = result(1)
312 + / max( dabs( alpha ) * norma * norma
313 + + dabs( beta ) * normc, one )
314 + / max( n , 1 ) / eps
315*
316 IF( result(1).GE.thresh ) THEN
317 IF( nfail.EQ.0 ) THEN
318 WRITE( nout, * )
319 WRITE( nout, fmt = 9999 )
320 END IF
321 WRITE( nout, fmt = 9997 ) 'ZHFRK',
322 + cform, uplo, trans, n, k, result(1)
323 nfail = nfail + 1
324 END IF
325*
326 100 CONTINUE
327 110 CONTINUE
328 120 CONTINUE
329 130 CONTINUE
330 140 CONTINUE
331 150 CONTINUE
332*
333* Print a summary of the results.
334*
335 IF ( nfail.EQ.0 ) THEN
336 WRITE( nout, fmt = 9996 ) 'ZHFRK', nrun
337 ELSE
338 WRITE( nout, fmt = 9995 ) 'ZHFRK', nfail, nrun
339 END IF
340*
341 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing ZHFRK
342 + ***')
343 9997 FORMAT( 1x, ' Failure in ',a5,', CFORM=''',a1,''',',
344 + ' UPLO=''',a1,''',',' TRANS=''',a1,''',', ' N=',i3,', K =', i3,
345 + ', test=',g12.5)
346 9996 FORMAT( 1x, 'All tests for ',a5,' auxiliary routine passed the ',
347 + 'threshold ( ',i6,' tests run)')
348 9995 FORMAT( 1x, a6, ' auxiliary routine: ',i6,' out of ',i6,
349 + ' tests failed to pass the threshold')
350*
351 RETURN
352*
353* End of ZDRVRF4
354*
zhfrk
subroutine zhfrk(transr, uplo, trans, n, k, alpha, a, lda, beta, c)
ZHFRK performs a Hermitian rank-k operation for matrix in RFP format.
Definition zhfrk.f:168
zherk
subroutine zherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
ZHERK
Definition zherk.f:173
dlarnd
double precision function dlarnd(idist, iseed)
DLARND
Definition dlarnd.f:73

◆ zdrvrfp()

subroutine zdrvrfp ( integer nout,
integer nn,
integer, dimension( nn ) nval,
integer nns,
integer, dimension( nns ) nsval,
integer nnt,
integer, dimension( nnt ) ntval,
double precision thresh,
complex*16, dimension( * ) a,
complex*16, dimension( * ) asav,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) bsav,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) x,
complex*16, dimension( * ) arf,
complex*16, dimension( * ) arfinv,
complex*16, dimension( * ) z_work_zlatms,
complex*16, dimension( * ) z_work_zpot02,
complex*16, dimension( * ) z_work_zpot03,
double precision, dimension( * ) d_work_zlatms,
double precision, dimension( * ) d_work_zlanhe,
double precision, dimension( * ) d_work_zpot01,
double precision, dimension( * ) d_work_zpot02,
double precision, dimension( * ) d_work_zpot03 )

ZDRVRFP

Purpose:
!>
!> ZDRVRFP tests the LAPACK RFP routines:
!>     ZPFTRF, ZPFTRS, and ZPFTRI.
!>
!> This testing routine follow the same tests as ZDRVPO (test for the full
!> format Symmetric Positive Definite solver).
!>
!> The tests are performed in Full Format, conversion back and forth from
!> full format to RFP format are performed using the routines ZTRTTF and
!> ZTFTTR.
!>
!> First, a specific matrix A of size N is created. There is nine types of
!> different matrixes possible.
!>  1. Diagonal                        6. Random, CNDNUM = sqrt(0.1/EPS)
!>  2. Random, CNDNUM = 2              7. Random, CNDNUM = 0.1/EPS
!> *3. First row and column zero       8. Scaled near underflow
!> *4. Last row and column zero        9. Scaled near overflow
!> *5. Middle row and column zero
!> (* - tests error exits from ZPFTRF, no test ratios are computed)
!> A solution XACT of size N-by-NRHS is created and the associated right
!> hand side B as well. Then ZPFTRF is called to compute L (or U), the
!> Cholesky factor of A. Then L (or U) is used to solve the linear system
!> of equations AX = B. This gives X. Then L (or U) is used to compute the
!> inverse of A, AINV. The following four tests are then performed:
!> (1) norm( L*L' - A ) / ( N * norm(A) * EPS ) or
!>     norm( U'*U - A ) / ( N * norm(A) * EPS ),
!> (2) norm(B - A*X) / ( norm(A) * norm(X) * EPS ),
!> (3) norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ),
!> (4) ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ),
!> where EPS is the machine precision, RCOND the condition number of A, and
!> norm( . ) the 1-norm for (1,2,3) and the inf-norm for (4).
!> Errors occur when INFO parameter is not as expected. Failures occur when
!> a test ratios is greater than THRES.
!>
Parameters
[in]NOUT
!>          NOUT is INTEGER
!>                The unit number for output.
!>
[in]NN
!>          NN is INTEGER
!>                The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>                The values of the matrix dimension N.
!>
[in]NNS
!>          NNS is INTEGER
!>                The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>                The values of the number of right-hand sides NRHS.
!>
[in]NNT
!>          NNT is INTEGER
!>                The number of values of MATRIX TYPE contained in the vector NTVAL.
!>
[in]NTVAL
!>          NTVAL is INTEGER array, dimension (NNT)
!>                The values of matrix type (between 0 and 9 for PO/PP/PF matrices).
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>                The threshold value for the test ratios.  A result is
!>                included in the output file if RESULT >= THRESH.  To have
!>                every test ratio printed, use THRESH = 0.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]ASAV
!>          ASAV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*MAXRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX*16 array, dimension (NMAX*MAXRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*MAXRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*MAXRHS)
!>
[out]ARF
!>          ARF is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2)
!>
[out]ARFINV
!>          ARFINV is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2)
!>
[out]Z_WORK_ZLATMS
!>          Z_WORK_ZLATMS is COMPLEX*16 array, dimension ( 3*NMAX )
!>
[out]Z_WORK_ZPOT02
!>          Z_WORK_ZPOT02 is COMPLEX*16 array, dimension ( NMAX*MAXRHS )
!>
[out]Z_WORK_ZPOT03
!>          Z_WORK_ZPOT03 is COMPLEX*16 array, dimension ( NMAX*NMAX )
!>
[out]D_WORK_ZLATMS
!>          D_WORK_ZLATMS is DOUBLE PRECISION array, dimension ( NMAX )
!>
[out]D_WORK_ZLANHE
!>          D_WORK_ZLANHE is DOUBLE PRECISION array, dimension ( NMAX )
!>
[out]D_WORK_ZPOT01
!>          D_WORK_ZPOT01 is DOUBLE PRECISION array, dimension ( NMAX )
!>
[out]D_WORK_ZPOT02
!>          D_WORK_ZPOT02 is DOUBLE PRECISION array, dimension ( NMAX )
!>
[out]D_WORK_ZPOT03
!>          D_WORK_ZPOT03 is DOUBLE PRECISION array, dimension ( NMAX )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 238 of file zdrvrfp.f.

244*
245* -- LAPACK test routine --
246* -- LAPACK is a software package provided by Univ. of Tennessee, --
247* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
248*
249* .. Scalar Arguments ..
250 INTEGER NN, NNS, NNT, NOUT
251 DOUBLE PRECISION THRESH
252* ..
253* .. Array Arguments ..
254 INTEGER NVAL( NN ), NSVAL( NNS ), NTVAL( NNT )
255 COMPLEX*16 A( * )
256 COMPLEX*16 AINV( * )
257 COMPLEX*16 ASAV( * )
258 COMPLEX*16 B( * )
259 COMPLEX*16 BSAV( * )
260 COMPLEX*16 AFAC( * )
261 COMPLEX*16 ARF( * )
262 COMPLEX*16 ARFINV( * )
263 COMPLEX*16 XACT( * )
264 COMPLEX*16 X( * )
265 COMPLEX*16 Z_WORK_ZLATMS( * )
266 COMPLEX*16 Z_WORK_ZPOT02( * )
267 COMPLEX*16 Z_WORK_ZPOT03( * )
268 DOUBLE PRECISION D_WORK_ZLATMS( * )
269 DOUBLE PRECISION D_WORK_ZLANHE( * )
270 DOUBLE PRECISION D_WORK_ZPOT01( * )
271 DOUBLE PRECISION D_WORK_ZPOT02( * )
272 DOUBLE PRECISION D_WORK_ZPOT03( * )
273* ..
274*
275* =====================================================================
276*
277* .. Parameters ..
278 DOUBLE PRECISION ONE, ZERO
279 parameter( one = 1.0d+0, zero = 0.0d+0 )
280 INTEGER NTESTS
281 parameter( ntests = 4 )
282* ..
283* .. Local Scalars ..
284 LOGICAL ZEROT
285 INTEGER I, INFO, IUPLO, LDA, LDB, IMAT, NERRS, NFAIL,
286 + NRHS, NRUN, IZERO, IOFF, K, NT, N, IFORM, IIN,
287 + IIT, IIS
288 CHARACTER DIST, CTYPE, UPLO, CFORM
289 INTEGER KL, KU, MODE
290 DOUBLE PRECISION ANORM, AINVNM, CNDNUM, RCONDC
291* ..
292* .. Local Arrays ..
293 CHARACTER UPLOS( 2 ), FORMS( 2 )
294 INTEGER ISEED( 4 ), ISEEDY( 4 )
295 DOUBLE PRECISION RESULT( NTESTS )
296* ..
297* .. External Functions ..
298 DOUBLE PRECISION ZLANHE
299 EXTERNAL zlanhe
300* ..
301* .. External Subroutines ..
302 EXTERNAL aladhd, alaerh, alasvm, zget04, ztfttr, zlacpy,
303 + zlaipd, zlarhs, zlatb4, zlatms, zpftri, zpftrf,
304 + zpftrs, zpot01, zpot02, zpot03, zpotri, zpotrf,
305 + ztrttf
306* ..
307* .. Scalars in Common ..
308 CHARACTER*32 SRNAMT
309* ..
310* .. Common blocks ..
311 COMMON / srnamc / srnamt
312* ..
313* .. Data statements ..
314 DATA iseedy / 1988, 1989, 1990, 1991 /
315 DATA uplos / 'U', 'L' /
316 DATA forms / 'N', 'C' /
317* ..
318* .. Executable Statements ..
319*
320* Initialize constants and the random number seed.
321*
322 nrun = 0
323 nfail = 0
324 nerrs = 0
325 DO 10 i = 1, 4
326 iseed( i ) = iseedy( i )
327 10 CONTINUE
328*
329 DO 130 iin = 1, nn
330*
331 n = nval( iin )
332 lda = max( n, 1 )
333 ldb = max( n, 1 )
334*
335 DO 980 iis = 1, nns
336*
337 nrhs = nsval( iis )
338*
339 DO 120 iit = 1, nnt
340*
341 imat = ntval( iit )
342*
343* If N.EQ.0, only consider the first type
344*
345 IF( n.EQ.0 .AND. iit.GE.1 ) GO TO 120
346*
347* Skip types 3, 4, or 5 if the matrix size is too small.
348*
349 IF( imat.EQ.4 .AND. n.LE.1 ) GO TO 120
350 IF( imat.EQ.5 .AND. n.LE.2 ) GO TO 120
351*
352* Do first for UPLO = 'U', then for UPLO = 'L'
353*
354 DO 110 iuplo = 1, 2
355 uplo = uplos( iuplo )
356*
357* Do first for CFORM = 'N', then for CFORM = 'C'
358*
359 DO 100 iform = 1, 2
360 cform = forms( iform )
361*
362* Set up parameters with ZLATB4 and generate a test
363* matrix with ZLATMS.
364*
365 CALL zlatb4( 'ZPO', imat, n, n, ctype, kl, ku,
366 + anorm, mode, cndnum, dist )
367*
368 srnamt = 'ZLATMS'
369 CALL zlatms( n, n, dist, iseed, ctype,
370 + d_work_zlatms,
371 + mode, cndnum, anorm, kl, ku, uplo, a,
372 + lda, z_work_zlatms, info )
373*
374* Check error code from ZLATMS.
375*
376 IF( info.NE.0 ) THEN
377 CALL alaerh( 'ZPF', 'ZLATMS', info, 0, uplo, n,
378 + n, -1, -1, -1, iit, nfail, nerrs,
379 + nout )
380 GO TO 100
381 END IF
382*
383* For types 3-5, zero one row and column of the matrix to
384* test that INFO is returned correctly.
385*
386 zerot = imat.GE.3 .AND. imat.LE.5
387 IF( zerot ) THEN
388 IF( iit.EQ.3 ) THEN
389 izero = 1
390 ELSE IF( iit.EQ.4 ) THEN
391 izero = n
392 ELSE
393 izero = n / 2 + 1
394 END IF
395 ioff = ( izero-1 )*lda
396*
397* Set row and column IZERO of A to 0.
398*
399 IF( iuplo.EQ.1 ) THEN
400 DO 20 i = 1, izero - 1
401 a( ioff+i ) = zero
402 20 CONTINUE
403 ioff = ioff + izero
404 DO 30 i = izero, n
405 a( ioff ) = zero
406 ioff = ioff + lda
407 30 CONTINUE
408 ELSE
409 ioff = izero
410 DO 40 i = 1, izero - 1
411 a( ioff ) = zero
412 ioff = ioff + lda
413 40 CONTINUE
414 ioff = ioff - izero
415 DO 50 i = izero, n
416 a( ioff+i ) = zero
417 50 CONTINUE
418 END IF
419 ELSE
420 izero = 0
421 END IF
422*
423* Set the imaginary part of the diagonals.
424*
425 CALL zlaipd( n, a, lda+1, 0 )
426*
427* Save a copy of the matrix A in ASAV.
428*
429 CALL zlacpy( uplo, n, n, a, lda, asav, lda )
430*
431* Compute the condition number of A (RCONDC).
432*
433 IF( zerot ) THEN
434 rcondc = zero
435 ELSE
436*
437* Compute the 1-norm of A.
438*
439 anorm = zlanhe( '1', uplo, n, a, lda,
440 + d_work_zlanhe )
441*
442* Factor the matrix A.
443*
444 CALL zpotrf( uplo, n, a, lda, info )
445*
446* Form the inverse of A.
447*
448 CALL zpotri( uplo, n, a, lda, info )
449
450 IF ( n .NE. 0 ) THEN
451*
452* Compute the 1-norm condition number of A.
453*
454 ainvnm = zlanhe( '1', uplo, n, a, lda,
455 + d_work_zlanhe )
456 rcondc = ( one / anorm ) / ainvnm
457*
458* Restore the matrix A.
459*
460 CALL zlacpy( uplo, n, n, asav, lda, a, lda )
461 END IF
462*
463 END IF
464*
465* Form an exact solution and set the right hand side.
466*
467 srnamt = 'ZLARHS'
468 CALL zlarhs( 'ZPO', 'N', uplo, ' ', n, n, kl, ku,
469 + nrhs, a, lda, xact, lda, b, lda,
470 + iseed, info )
471 CALL zlacpy( 'Full', n, nrhs, b, lda, bsav, lda )
472*
473* Compute the L*L' or U'*U factorization of the
474* matrix and solve the system.
475*
476 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
477 CALL zlacpy( 'Full', n, nrhs, b, ldb, x, ldb )
478*
479 srnamt = 'ZTRTTF'
480 CALL ztrttf( cform, uplo, n, afac, lda, arf, info )
481 srnamt = 'ZPFTRF'
482 CALL zpftrf( cform, uplo, n, arf, info )
483*
484* Check error code from ZPFTRF.
485*
486 IF( info.NE.izero ) THEN
487*
488* LANGOU: there is a small hick here: IZERO should
489* always be INFO however if INFO is ZERO, ALAERH does not
490* complain.
491*
492 CALL alaerh( 'ZPF', 'ZPFSV ', info, izero,
493 + uplo, n, n, -1, -1, nrhs, iit,
494 + nfail, nerrs, nout )
495 GO TO 100
496 END IF
497*
498* Skip the tests if INFO is not 0.
499*
500 IF( info.NE.0 ) THEN
501 GO TO 100
502 END IF
503*
504 srnamt = 'ZPFTRS'
505 CALL zpftrs( cform, uplo, n, nrhs, arf, x, ldb,
506 + info )
507*
508 srnamt = 'ZTFTTR'
509 CALL ztfttr( cform, uplo, n, arf, afac, lda, info )
510*
511* Reconstruct matrix from factors and compute
512* residual.
513*
514 CALL zlacpy( uplo, n, n, afac, lda, asav, lda )
515 CALL zpot01( uplo, n, a, lda, afac, lda,
516 + d_work_zpot01, result( 1 ) )
517 CALL zlacpy( uplo, n, n, asav, lda, afac, lda )
518*
519* Form the inverse and compute the residual.
520*
521 IF(mod(n,2).EQ.0)THEN
522 CALL zlacpy( 'A', n+1, n/2, arf, n+1, arfinv,
523 + n+1 )
524 ELSE
525 CALL zlacpy( 'A', n, (n+1)/2, arf, n, arfinv,
526 + n )
527 END IF
528*
529 srnamt = 'ZPFTRI'
530 CALL zpftri( cform, uplo, n, arfinv , info )
531*
532 srnamt = 'ZTFTTR'
533 CALL ztfttr( cform, uplo, n, arfinv, ainv, lda,
534 + info )
535*
536* Check error code from ZPFTRI.
537*
538 IF( info.NE.0 )
539 + CALL alaerh( 'ZPO', 'ZPFTRI', info, 0, uplo, n,
540 + n, -1, -1, -1, imat, nfail, nerrs,
541 + nout )
542*
543 CALL zpot03( uplo, n, a, lda, ainv, lda,
544 + z_work_zpot03, lda, d_work_zpot03,
545 + rcondc, result( 2 ) )
546*
547* Compute residual of the computed solution.
548*
549 CALL zlacpy( 'Full', n, nrhs, b, lda,
550 + z_work_zpot02, lda )
551 CALL zpot02( uplo, n, nrhs, a, lda, x, lda,
552 + z_work_zpot02, lda, d_work_zpot02,
553 + result( 3 ) )
554*
555* Check solution from generated exact solution.
556*
557 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
558 + result( 4 ) )
559 nt = 4
560*
561* Print information about the tests that did not
562* pass the threshold.
563*
564 DO 60 k = 1, nt
565 IF( result( k ).GE.thresh ) THEN
566 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
567 + CALL aladhd( nout, 'ZPF' )
568 WRITE( nout, fmt = 9999 )'ZPFSV ', uplo,
569 + n, iit, k, result( k )
570 nfail = nfail + 1
571 END IF
572 60 CONTINUE
573 nrun = nrun + nt
574 100 CONTINUE
575 110 CONTINUE
576 120 CONTINUE
577 980 CONTINUE
578 130 CONTINUE
579*
580* Print a summary of the results.
581*
582 CALL alasvm( 'ZPF', nout, nfail, nrun, nerrs )
583*
584 9999 FORMAT( 1x, a6, ', UPLO=''', a1, ''', N =', i5, ', type ', i1,
585 + ', test(', i1, ')=', g12.5 )
586*
587 RETURN
588*
589* End of ZDRVRFP
590*
zpftri
subroutine zpftri(transr, uplo, n, a, info)
ZPFTRI
Definition zpftri.f:212
zpftrs
subroutine zpftrs(transr, uplo, n, nrhs, a, b, ldb, info)
ZPFTRS
Definition zpftrs.f:220
zpftrf
subroutine zpftrf(transr, uplo, n, a, info)
ZPFTRF
Definition zpftrf.f:211

◆ zdrvsp()

subroutine zdrvsp ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZDRVSP

Purpose:
!>
!> ZDRVSP tests the driver routines ZSPSV and -SVX.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 154 of file zdrvsp.f.

157*
158* -- LAPACK test routine --
159* -- LAPACK is a software package provided by Univ. of Tennessee, --
160* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
161*
162* .. Scalar Arguments ..
163 LOGICAL TSTERR
164 INTEGER NMAX, NN, NOUT, NRHS
165 DOUBLE PRECISION THRESH
166* ..
167* .. Array Arguments ..
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* .. Parameters ..
178 DOUBLE PRECISION ONE, ZERO
179 parameter( one = 1.0d+0, zero = 0.0d+0 )
180 INTEGER NTYPES, NTESTS
181 parameter( ntypes = 11, ntests = 6 )
182 INTEGER NFACT
183 parameter( nfact = 2 )
184* ..
185* .. Local Scalars ..
186 LOGICAL ZEROT
187 CHARACTER DIST, FACT, PACKIT, 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, MODE, N, NB,
191 $ NBMIN, NERRS, NFAIL, NIMAT, NPP, NRUN, NT
192 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC
193* ..
194* .. Local Arrays ..
195 CHARACTER FACTS( NFACT )
196 INTEGER ISEED( 4 ), ISEEDY( 4 )
197 DOUBLE PRECISION RESULT( NTESTS )
198* ..
199* .. External Functions ..
200 DOUBLE PRECISION DGET06, ZLANSP
201 EXTERNAL dget06, zlansp
202* ..
203* .. External Subroutines ..
204 EXTERNAL aladhd, alaerh, alasvm, xlaenv, zcopy, zerrvx,
205 $ zget04, zlacpy, zlarhs, zlaset, zlatb4, zlatms,
206 $ zlatsp, zppt05, zspsv, zspsvx, zspt01, zspt02,
207 $ zsptrf, zsptri
208* ..
209* .. Scalars in Common ..
210 LOGICAL LERR, OK
211 CHARACTER*32 SRNAMT
212 INTEGER INFOT, NUNIT
213* ..
214* .. Common blocks ..
215 COMMON / infoc / infot, nunit, ok, lerr
216 COMMON / srnamc / srnamt
217* ..
218* .. Intrinsic Functions ..
219 INTRINSIC dcmplx, max, min
220* ..
221* .. Data statements ..
222 DATA iseedy / 1988, 1989, 1990, 1991 /
223 DATA facts / 'F', 'N' /
224* ..
225* .. Executable Statements ..
226*
227* Initialize constants and the random number seed.
228*
229 path( 1: 1 ) = 'Zomplex precision'
230 path( 2: 3 ) = 'SP'
231 nrun = 0
232 nfail = 0
233 nerrs = 0
234 DO 10 i = 1, 4
235 iseed( i ) = iseedy( i )
236 10 CONTINUE
237*
238* Test the error exits
239*
240 IF( tsterr )
241 $ CALL zerrvx( path, nout )
242 infot = 0
243*
244* Set the block size and minimum block size for testing.
245*
246 nb = 1
247 nbmin = 2
248 CALL xlaenv( 1, nb )
249 CALL xlaenv( 2, nbmin )
250*
251* Do for each value of N in NVAL
252*
253 DO 180 in = 1, nn
254 n = nval( in )
255 lda = max( n, 1 )
256 npp = n*( n+1 ) / 2
257 xtype = 'N'
258 nimat = ntypes
259 IF( n.LE.0 )
260 $ nimat = 1
261*
262 DO 170 imat = 1, nimat
263*
264* Do the tests only if DOTYPE( IMAT ) is true.
265*
266 IF( .NOT.dotype( imat ) )
267 $ GO TO 170
268*
269* Skip types 3, 4, 5, or 6 if the matrix size is too small.
270*
271 zerot = imat.GE.3 .AND. imat.LE.6
272 IF( zerot .AND. n.LT.imat-2 )
273 $ GO TO 170
274*
275* Do first for UPLO = 'U', then for UPLO = 'L'
276*
277 DO 160 iuplo = 1, 2
278 IF( iuplo.EQ.1 ) THEN
279 uplo = 'U'
280 packit = 'C'
281 ELSE
282 uplo = 'L'
283 packit = 'R'
284 END IF
285*
286 IF( imat.NE.ntypes ) THEN
287*
288* Set up parameters with ZLATB4 and generate a test
289* matrix with ZLATMS.
290*
291 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
292 $ MODE, CNDNUM, DIST )
293*
294 srnamt = 'ZLATMS'
295 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
296 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA,
297 $ WORK, INFO )
298*
299* Check error code from ZLATMS.
300*
301 IF( info.NE.0 ) THEN
302 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n,
303 $ -1, -1, -1, imat, nfail, nerrs, nout )
304 GO TO 160
305 END IF
306*
307* For types 3-6, zero one or more rows and columns of
308* the matrix to test that INFO is returned correctly.
309*
310 IF( zerot ) THEN
311 IF( imat.EQ.3 ) THEN
312 izero = 1
313 ELSE IF( imat.EQ.4 ) THEN
314 izero = n
315 ELSE
316 izero = n / 2 + 1
317 END IF
318*
319 IF( imat.LT.6 ) THEN
320*
321* Set row and column IZERO to zero.
322*
323 IF( iuplo.EQ.1 ) THEN
324 ioff = ( izero-1 )*izero / 2
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 + i
332 30 CONTINUE
333 ELSE
334 ioff = izero
335 DO 40 i = 1, izero - 1
336 a( ioff ) = zero
337 ioff = ioff + n - i
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 IF( iuplo.EQ.1 ) THEN
346*
347* Set the first IZERO rows and columns to zero.
348*
349 ioff = 0
350 DO 70 j = 1, n
351 i2 = min( j, izero )
352 DO 60 i = 1, i2
353 a( ioff+i ) = zero
354 60 CONTINUE
355 ioff = ioff + j
356 70 CONTINUE
357 ELSE
358*
359* Set the last IZERO rows and columns to zero.
360*
361 ioff = 0
362 DO 90 j = 1, n
363 i1 = max( j, izero )
364 DO 80 i = i1, n
365 a( ioff+i ) = zero
366 80 CONTINUE
367 ioff = ioff + n - j
368 90 CONTINUE
369 END IF
370 END IF
371 ELSE
372 izero = 0
373 END IF
374 ELSE
375*
376* Use a special block diagonal matrix to test alternate
377* code for the 2-by-2 blocks.
378*
379 CALL zlatsp( uplo, n, a, iseed )
380 END IF
381*
382 DO 150 ifact = 1, nfact
383*
384* Do first for FACT = 'F', then for other values.
385*
386 fact = facts( ifact )
387*
388* Compute the condition number for comparison with
389* the value returned by ZSPSVX.
390*
391 IF( zerot ) THEN
392 IF( ifact.EQ.1 )
393 $ GO TO 150
394 rcondc = zero
395*
396 ELSE IF( ifact.EQ.1 ) THEN
397*
398* Compute the 1-norm of A.
399*
400 anorm = zlansp( '1', uplo, n, a, rwork )
401*
402* Factor the matrix A.
403*
404 CALL zcopy( npp, a, 1, afac, 1 )
405 CALL zsptrf( uplo, n, afac, iwork, info )
406*
407* Compute inv(A) and take its norm.
408*
409 CALL zcopy( npp, afac, 1, ainv, 1 )
410 CALL zsptri( uplo, n, ainv, iwork, work, info )
411 ainvnm = zlansp( '1', uplo, n, ainv, rwork )
412*
413* Compute the 1-norm condition number of A.
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* Form an exact solution and set the right hand side.
423*
424 srnamt = 'ZLARHS'
425 CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
426 $ nrhs, a, lda, xact, lda, b, lda, iseed,
427 $ info )
428 xtype = 'C'
429*
430* --- Test ZSPSV ---
431*
432 IF( ifact.EQ.2 ) THEN
433 CALL zcopy( npp, a, 1, afac, 1 )
434 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
435*
436* Factor the matrix and solve the system using ZSPSV.
437*
438 srnamt = 'ZSPSV '
439 CALL zspsv( uplo, n, nrhs, afac, iwork, x, lda,
440 $ info )
441*
442* Adjust the expected value of INFO to account for
443* pivoting.
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* Check error code from ZSPSV .
460*
461 IF( info.NE.k ) THEN
462 CALL alaerh( path, 'ZSPSV ', 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* Reconstruct matrix from factors and compute
471* residual.
472*
473 CALL zspt01( uplo, n, a, afac, iwork, ainv, lda,
474 $ rwork, result( 1 ) )
475*
476* Compute residual of the computed solution.
477*
478 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
479 CALL zspt02( uplo, n, nrhs, a, x, lda, work, lda,
480 $ rwork, result( 2 ) )
481*
482* Check solution from generated exact solution.
483*
484 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
485 $ result( 3 ) )
486 nt = 3
487*
488* Print information about the tests that did not pass
489* the threshold.
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 )'ZSPSV ', 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* --- Test ZSPSVX ---
505*
506 IF( ifact.EQ.2 .AND. npp.GT.0 )
507 $ CALL zlaset( 'Full', npp, 1, dcmplx( zero ),
508 $ dcmplx( zero ), afac, npp )
509 CALL zlaset( 'Full', n, nrhs, dcmplx( zero ),
510 $ dcmplx( zero ), x, lda )
511*
512* Solve the system and compute the condition number and
513* error bounds using ZSPSVX.
514*
515 srnamt = 'ZSPSVX'
516 CALL zspsvx( fact, uplo, n, nrhs, a, afac, iwork, b,
517 $ lda, x, lda, rcond, rwork,
518 $ rwork( nrhs+1 ), work, rwork( 2*nrhs+1 ),
519 $ info )
520*
521* Adjust the expected value of INFO to account for
522* pivoting.
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* Check the error code from ZSPSVX.
539*
540 IF( info.NE.k ) THEN
541 CALL alaerh( path, 'ZSPSVX', 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* Reconstruct matrix from factors and compute
551* residual.
552*
553 CALL zspt01( uplo, n, a, afac, iwork, ainv, lda,
554 $ rwork( 2*nrhs+1 ), result( 1 ) )
555 k1 = 1
556 ELSE
557 k1 = 2
558 END IF
559*
560* Compute residual of the computed solution.
561*
562 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
563 CALL zspt02( uplo, n, nrhs, a, x, lda, work, lda,
564 $ rwork( 2*nrhs+1 ), result( 2 ) )
565*
566* Check solution from generated exact solution.
567*
568 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
569 $ result( 3 ) )
570*
571* Check the error bounds from iterative refinement.
572*
573 CALL zppt05( uplo, n, nrhs, a, b, lda, x, lda,
574 $ xact, lda, rwork, rwork( nrhs+1 ),
575 $ result( 4 ) )
576 ELSE
577 k1 = 6
578 END IF
579*
580* Compare RCOND from ZSPSVX with the computed value
581* in RCONDC.
582*
583 result( 6 ) = dget06( rcond, rcondc )
584*
585* Print information about the tests that did not pass
586* the threshold.
587*
588 DO 140 k = k1, 6
589 IF( result( k ).GE.thresh ) THEN
590 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
591 $ CALL aladhd( nout, path )
592 WRITE( nout, fmt = 9998 )'ZSPSVX', fact, uplo,
593 $ n, imat, k, result( k )
594 nfail = nfail + 1
595 END IF
596 140 CONTINUE
597 nrun = nrun + 7 - k1
598*
599 150 CONTINUE
600*
601 160 CONTINUE
602 170 CONTINUE
603 180 CONTINUE
604*
605* Print a summary of the results.
606*
607 CALL alasvm( path, nout, nfail, nrun, nerrs )
608*
609 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
610 $ ', test ', i2, ', ratio =', g12.5 )
611 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N =', i5,
612 $ ', type ', i2, ', test ', i2, ', ratio =', g12.5 )
613 RETURN
614*
615* End of ZDRVSP
616*
zspsv
subroutine zspsv(uplo, n, nrhs, ap, ipiv, b, ldb, info)
ZSPSV computes the solution to system of linear equations A * X = B for OTHER matrices
Definition zspsv.f:162
zspsvx
subroutine zspsvx(fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
ZSPSVX computes the solution to system of linear equations A * X = B for OTHER matrices
Definition zspsvx.f:277

◆ zdrvsy()

subroutine zdrvsy ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZDRVSY

ZDRVSYX

Purpose:
!>
!> ZDRVSY tests the driver routines ZSYSV and -SVX.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Purpose:
!>
!> ZDRVSY tests the driver routines ZSYSV, -SVX, and -SVXX.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise zdrvsy.f defines this subroutine.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension
!>                      (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (2*NMAX+2*NRHS)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 150 of file zdrvsy.f.

153*
154* -- LAPACK test routine --
155* -- LAPACK is a software package provided by Univ. of Tennessee, --
156* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
157*
158* .. Scalar Arguments ..
159 LOGICAL TSTERR
160 INTEGER NMAX, NN, NOUT, NRHS
161 DOUBLE PRECISION THRESH
162* ..
163* .. Array Arguments ..
164 LOGICAL DOTYPE( * )
165 INTEGER IWORK( * ), NVAL( * )
166 DOUBLE PRECISION RWORK( * )
167 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
168 $ WORK( * ), X( * ), XACT( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 DOUBLE PRECISION ONE, ZERO
175 parameter( one = 1.0d+0, zero = 0.0d+0 )
176 INTEGER NTYPES, NTESTS
177 parameter( ntypes = 11, ntests = 6 )
178 INTEGER NFACT
179 parameter( nfact = 2 )
180* ..
181* .. Local Scalars ..
182 LOGICAL ZEROT
183 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
184 CHARACTER*3 PATH
185 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
186 $ IZERO, J, K, K1, KL, KU, LDA, LWORK, MODE, N,
187 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
188 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCOND, RCONDC
189* ..
190* .. Local Arrays ..
191 CHARACTER FACTS( NFACT ), UPLOS( 2 )
192 INTEGER ISEED( 4 ), ISEEDY( 4 )
193 DOUBLE PRECISION RESULT( NTESTS )
194* ..
195* .. External Functions ..
196 DOUBLE PRECISION DGET06, ZLANSY
197 EXTERNAL dget06, zlansy
198* ..
199* .. External Subroutines ..
200 EXTERNAL aladhd, alaerh, alasvm, xlaenv, zerrvx, zget04,
201 $ zlacpy, zlarhs, zlaset, zlatb4, zlatms, zlatsy,
202 $ zpot05, zsysv, zsysvx, zsyt01, zsyt02, zsytrf,
203 $ zsytri2
204* ..
205* .. Scalars in Common ..
206 LOGICAL LERR, OK
207 CHARACTER*32 SRNAMT
208 INTEGER INFOT, NUNIT
209* ..
210* .. Common blocks ..
211 COMMON / infoc / infot, nunit, ok, lerr
212 COMMON / srnamc / srnamt
213* ..
214* .. Intrinsic Functions ..
215 INTRINSIC dcmplx, max, min
216* ..
217* .. Data statements ..
218 DATA iseedy / 1988, 1989, 1990, 1991 /
219 DATA uplos / 'U', 'L' / , facts / 'F', 'N' /
220* ..
221* .. Executable Statements ..
222*
223* Initialize constants and the random number seed.
224*
225 path( 1: 1 ) = 'Zomplex precision'
226 path( 2: 3 ) = 'SY'
227 nrun = 0
228 nfail = 0
229 nerrs = 0
230 DO 10 i = 1, 4
231 iseed( i ) = iseedy( i )
232 10 CONTINUE
233 lwork = max( 2*nmax, nmax*nrhs )
234*
235* Test the error exits
236*
237 IF( tsterr )
238 $ CALL zerrvx( path, nout )
239 infot = 0
240*
241* Set the block size and minimum block size for testing.
242*
243 nb = 1
244 nbmin = 2
245 CALL xlaenv( 1, nb )
246 CALL xlaenv( 2, nbmin )
247*
248* Do for each value of N in NVAL
249*
250 DO 180 in = 1, nn
251 n = nval( in )
252 lda = max( n, 1 )
253 xtype = 'N'
254 nimat = ntypes
255 IF( n.LE.0 )
256 $ nimat = 1
257*
258 DO 170 imat = 1, nimat
259*
260* Do the tests only if DOTYPE( IMAT ) is true.
261*
262 IF( .NOT.dotype( imat ) )
263 $ GO TO 170
264*
265* Skip types 3, 4, 5, or 6 if the matrix size is too small.
266*
267 zerot = imat.GE.3 .AND. imat.LE.6
268 IF( zerot .AND. n.LT.imat-2 )
269 $ GO TO 170
270*
271* Do first for UPLO = 'U', then for UPLO = 'L'
272*
273 DO 160 iuplo = 1, 2
274 uplo = uplos( iuplo )
275*
276 IF( imat.NE.ntypes ) THEN
277*
278* Set up parameters with ZLATB4 and generate a test
279* matrix with ZLATMS.
280*
281 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
282 $ MODE, CNDNUM, DIST )
283*
284 srnamt = 'ZLATMS'
285 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
286 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
287 $ WORK, INFO )
288*
289* Check error code from ZLATMS.
290*
291 IF( info.NE.0 ) THEN
292 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n,
293 $ -1, -1, -1, imat, nfail, nerrs, nout )
294 GO TO 160
295 END IF
296*
297* For types 3-6, zero one or more rows and columns of
298* the matrix to test that INFO is returned correctly.
299*
300 IF( zerot ) THEN
301 IF( imat.EQ.3 ) THEN
302 izero = 1
303 ELSE IF( imat.EQ.4 ) THEN
304 izero = n
305 ELSE
306 izero = n / 2 + 1
307 END IF
308*
309 IF( imat.LT.6 ) THEN
310*
311* Set row and column IZERO to zero.
312*
313 IF( iuplo.EQ.1 ) THEN
314 ioff = ( izero-1 )*lda
315 DO 20 i = 1, izero - 1
316 a( ioff+i ) = zero
317 20 CONTINUE
318 ioff = ioff + izero
319 DO 30 i = izero, n
320 a( ioff ) = zero
321 ioff = ioff + lda
322 30 CONTINUE
323 ELSE
324 ioff = izero
325 DO 40 i = 1, izero - 1
326 a( ioff ) = zero
327 ioff = ioff + lda
328 40 CONTINUE
329 ioff = ioff - izero
330 DO 50 i = izero, n
331 a( ioff+i ) = zero
332 50 CONTINUE
333 END IF
334 ELSE
335 IF( iuplo.EQ.1 ) THEN
336*
337* Set the first IZERO rows to zero.
338*
339 ioff = 0
340 DO 70 j = 1, n
341 i2 = min( j, izero )
342 DO 60 i = 1, i2
343 a( ioff+i ) = zero
344 60 CONTINUE
345 ioff = ioff + lda
346 70 CONTINUE
347 ELSE
348*
349* Set the last IZERO rows to zero.
350*
351 ioff = 0
352 DO 90 j = 1, n
353 i1 = max( j, izero )
354 DO 80 i = i1, n
355 a( ioff+i ) = zero
356 80 CONTINUE
357 ioff = ioff + lda
358 90 CONTINUE
359 END IF
360 END IF
361 ELSE
362 izero = 0
363 END IF
364 ELSE
365*
366* IMAT = NTYPES: Use a special block diagonal matrix to
367* test alternate code for the 2-by-2 blocks.
368*
369 CALL zlatsy( uplo, n, a, lda, iseed )
370 END IF
371*
372 DO 150 ifact = 1, nfact
373*
374* Do first for FACT = 'F', then for other values.
375*
376 fact = facts( ifact )
377*
378* Compute the condition number for comparison with
379* the value returned by ZSYSVX.
380*
381 IF( zerot ) THEN
382 IF( ifact.EQ.1 )
383 $ GO TO 150
384 rcondc = zero
385*
386 ELSE IF( ifact.EQ.1 ) THEN
387*
388* Compute the 1-norm of A.
389*
390 anorm = zlansy( '1', uplo, n, a, lda, rwork )
391*
392* Factor the matrix A.
393*
394 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
395 CALL zsytrf( uplo, n, afac, lda, iwork, work,
396 $ lwork, info )
397*
398* Compute inv(A) and take its norm.
399*
400 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
401 lwork = (n+nb+1)*(nb+3)
402 CALL zsytri2( uplo, n, ainv, lda, iwork, work,
403 $ lwork, info )
404 ainvnm = zlansy( '1', uplo, n, ainv, lda, rwork )
405*
406* Compute the 1-norm condition number of A.
407*
408 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
409 rcondc = one
410 ELSE
411 rcondc = ( one / anorm ) / ainvnm
412 END IF
413 END IF
414*
415* Form an exact solution and set the right hand side.
416*
417 srnamt = 'ZLARHS'
418 CALL zlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
419 $ nrhs, a, lda, xact, lda, b, lda, iseed,
420 $ info )
421 xtype = 'C'
422*
423* --- Test ZSYSV ---
424*
425 IF( ifact.EQ.2 ) THEN
426 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
427 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
428*
429* Factor the matrix and solve the system using ZSYSV.
430*
431 srnamt = 'ZSYSV '
432 CALL zsysv( uplo, n, nrhs, afac, lda, iwork, x,
433 $ lda, work, lwork, info )
434*
435* Adjust the expected value of INFO to account for
436* pivoting.
437*
438 k = izero
439 IF( k.GT.0 ) THEN
440 100 CONTINUE
441 IF( iwork( k ).LT.0 ) THEN
442 IF( iwork( k ).NE.-k ) THEN
443 k = -iwork( k )
444 GO TO 100
445 END IF
446 ELSE IF( iwork( k ).NE.k ) THEN
447 k = iwork( k )
448 GO TO 100
449 END IF
450 END IF
451*
452* Check error code from ZSYSV .
453*
454 IF( info.NE.k ) THEN
455 CALL alaerh( path, 'ZSYSV ', info, k, uplo, n,
456 $ n, -1, -1, nrhs, imat, nfail,
457 $ nerrs, nout )
458 GO TO 120
459 ELSE IF( info.NE.0 ) THEN
460 GO TO 120
461 END IF
462*
463* Reconstruct matrix from factors and compute
464* residual.
465*
466 CALL zsyt01( uplo, n, a, lda, afac, lda, iwork,
467 $ ainv, lda, rwork, result( 1 ) )
468*
469* Compute residual of the computed solution.
470*
471 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
472 CALL zsyt02( uplo, n, nrhs, a, lda, x, lda, work,
473 $ lda, rwork, result( 2 ) )
474*
475* Check solution from generated exact solution.
476*
477 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
478 $ result( 3 ) )
479 nt = 3
480*
481* Print information about the tests that did not pass
482* the threshold.
483*
484 DO 110 k = 1, nt
485 IF( result( k ).GE.thresh ) THEN
486 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
487 $ CALL aladhd( nout, path )
488 WRITE( nout, fmt = 9999 )'ZSYSV ', uplo, n,
489 $ imat, k, result( k )
490 nfail = nfail + 1
491 END IF
492 110 CONTINUE
493 nrun = nrun + nt
494 120 CONTINUE
495 END IF
496*
497* --- Test ZSYSVX ---
498*
499 IF( ifact.EQ.2 )
500 $ CALL zlaset( uplo, n, n, dcmplx( zero ),
501 $ dcmplx( zero ), afac, lda )
502 CALL zlaset( 'Full', n, nrhs, dcmplx( zero ),
503 $ dcmplx( zero ), x, lda )
504*
505* Solve the system and compute the condition number and
506* error bounds using ZSYSVX.
507*
508 srnamt = 'ZSYSVX'
509 CALL zsysvx( fact, uplo, n, nrhs, a, lda, afac, lda,
510 $ iwork, b, lda, x, lda, rcond, rwork,
511 $ rwork( nrhs+1 ), work, lwork,
512 $ rwork( 2*nrhs+1 ), info )
513*
514* Adjust the expected value of INFO to account for
515* pivoting.
516*
517 k = izero
518 IF( k.GT.0 ) THEN
519 130 CONTINUE
520 IF( iwork( k ).LT.0 ) THEN
521 IF( iwork( k ).NE.-k ) THEN
522 k = -iwork( k )
523 GO TO 130
524 END IF
525 ELSE IF( iwork( k ).NE.k ) THEN
526 k = iwork( k )
527 GO TO 130
528 END IF
529 END IF
530*
531* Check the error code from ZSYSVX.
532*
533 IF( info.NE.k ) THEN
534 CALL alaerh( path, 'ZSYSVX', info, k, fact // uplo,
535 $ n, n, -1, -1, nrhs, imat, nfail,
536 $ nerrs, nout )
537 GO TO 150
538 END IF
539*
540 IF( info.EQ.0 ) THEN
541 IF( ifact.GE.2 ) THEN
542*
543* Reconstruct matrix from factors and compute
544* residual.
545*
546 CALL zsyt01( uplo, n, a, lda, afac, lda, iwork,
547 $ ainv, lda, rwork( 2*nrhs+1 ),
548 $ result( 1 ) )
549 k1 = 1
550 ELSE
551 k1 = 2
552 END IF
553*
554* Compute residual of the computed solution.
555*
556 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
557 CALL zsyt02( uplo, n, nrhs, a, lda, x, lda, work,
558 $ lda, rwork( 2*nrhs+1 ), result( 2 ) )
559*
560* Check solution from generated exact solution.
561*
562 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
563 $ result( 3 ) )
564*
565* Check the error bounds from iterative refinement.
566*
567 CALL zpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
568 $ xact, lda, rwork, rwork( nrhs+1 ),
569 $ result( 4 ) )
570 ELSE
571 k1 = 6
572 END IF
573*
574* Compare RCOND from ZSYSVX with the computed value
575* in RCONDC.
576*
577 result( 6 ) = dget06( rcond, rcondc )
578*
579* Print information about the tests that did not pass
580* the threshold.
581*
582 DO 140 k = k1, 6
583 IF( result( k ).GE.thresh ) THEN
584 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
585 $ CALL aladhd( nout, path )
586 WRITE( nout, fmt = 9998 )'ZSYSVX', fact, uplo,
587 $ n, imat, k, result( k )
588 nfail = nfail + 1
589 END IF
590 140 CONTINUE
591 nrun = nrun + 7 - k1
592*
593 150 CONTINUE
594*
595 160 CONTINUE
596 170 CONTINUE
597 180 CONTINUE
598*
599* Print a summary of the results.
600*
601 CALL alasvm( path, nout, nfail, nrun, nerrs )
602*
603 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
604 $ ', test ', i2, ', ratio =', g12.5 )
605 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N =', i5,
606 $ ', type ', i2, ', test ', i2, ', ratio =', g12.5 )
607 RETURN
608*
609* End of ZDRVSY
610*
zsysvx
subroutine zsysvx(fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, lwork, rwork, info)
ZSYSVX computes the solution to system of linear equations A * X = B for SY matrices
Definition zsysvx.f:285
zsysv
subroutine zsysv(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
ZSYSV computes the solution to system of linear equations A * X = B for SY matrices
Definition zsysv.f:171

◆ zdrvsy_aa()

subroutine zdrvsy_aa ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZDRVSY_AA

Purpose:
!>
!> ZDRVSY_AA tests the driver routine ZSYSV_AA.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is COMPLEX*16
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is COMPLEX*16 array, dimension (NMAX+2*NRHS)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (2*NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 150 of file zdrvsy_aa.f.

153*
154* -- LAPACK test routine --
155* -- LAPACK is a software package provided by Univ. of Tennessee, --
156* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
157*
158* .. Scalar Arguments ..
159 LOGICAL TSTERR
160 INTEGER NMAX, NN, NOUT, NRHS
161 DOUBLE PRECISION THRESH
162* ..
163* .. Array Arguments ..
164 LOGICAL DOTYPE( * )
165 INTEGER IWORK( * ), NVAL( * )
166 DOUBLE PRECISION RWORK( * )
167 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
168 $ WORK( * ), X( * ), XACT( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 DOUBLE PRECISION ZERO
175 parameter( zero = 0.0d+0 )
176 COMPLEX*16 CZERO
177 parameter( czero = 0.0e+0 )
178 INTEGER NTYPES, NTESTS
179 parameter( ntypes = 10, ntests = 3 )
180 INTEGER NFACT
181 parameter( nfact = 2 )
182* ..
183* .. Local Scalars ..
184 LOGICAL ZEROT
185 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
186 CHARACTER*3 MATPATH, PATH
187 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
188 $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
189 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
190 DOUBLE PRECISION ANORM, CNDNUM
191* ..
192* .. Local Arrays ..
193 CHARACTER FACTS( NFACT ), UPLOS( 2 )
194 INTEGER ISEED( 4 ), ISEEDY( 4 )
195 DOUBLE PRECISION RESULT( NTESTS )
196* ..
197* .. External Functions ..
198 DOUBLE PRECISION DGET06, ZLANSY
199 EXTERNAL dget06, zlansy
200* ..
201* .. External Subroutines ..
202 EXTERNAL aladhd, alaerh, alasvm, zerrvx, zget04, zlacpy,
203 $ zlarhs, zlaset, zlatb4, zlatms, zsyt02,
204 $ zsysv_aa, zsyt01_aa, zsytrf_aa, xlaenv
205* ..
206* .. Scalars in Common ..
207 LOGICAL LERR, OK
208 CHARACTER*32 SRNAMT
209 INTEGER INFOT, NUNIT
210* ..
211* .. Common blocks ..
212 COMMON / infoc / infot, nunit, ok, lerr
213 COMMON / srnamc / srnamt
214* ..
215* .. Intrinsic Functions ..
216 INTRINSIC max, min
217* ..
218* .. Data statements ..
219 DATA iseedy / 1988, 1989, 1990, 1991 /
220 DATA uplos / 'U', 'L' / , facts / 'F', 'N' /
221* ..
222* .. Executable Statements ..
223*
224* Initialize constants and the random number seed.
225*
226* Test path
227*
228 path( 1: 1 ) = 'Zomplex precision'
229 path( 2: 3 ) = 'SA'
230*
231* Path to generate matrices
232*
233 matpath( 1: 1 ) = 'Zomplex precision'
234 matpath( 2: 3 ) = 'SY'
235*
236 nrun = 0
237 nfail = 0
238 nerrs = 0
239 DO 10 i = 1, 4
240 iseed( i ) = iseedy( i )
241 10 CONTINUE
242*
243* Test the error exits
244*
245 IF( tsterr )
246 $ CALL zerrvx( path, nout )
247 infot = 0
248*
249* Set the block size and minimum block size for testing.
250*
251 nb = 1
252 nbmin = 2
253 CALL xlaenv( 1, nb )
254 CALL xlaenv( 2, nbmin )
255*
256* Do for each value of N in NVAL
257*
258 DO 180 in = 1, nn
259 n = nval( in )
260 lwork = max( 3*n-2, n*(1+nb) )
261 lwork = max( lwork, 1 )
262 lda = max( n, 1 )
263 xtype = 'N'
264 nimat = ntypes
265 IF( n.LE.0 )
266 $ nimat = 1
267*
268 DO 170 imat = 1, nimat
269*
270* Do the tests only if DOTYPE( IMAT ) is true.
271*
272 IF( .NOT.dotype( imat ) )
273 $ GO TO 170
274*
275* Skip types 3, 4, 5, or 6 if the matrix size is too small.
276*
277 zerot = imat.GE.3 .AND. imat.LE.6
278 IF( zerot .AND. n.LT.imat-2 )
279 $ GO TO 170
280*
281* Do first for UPLO = 'U', then for UPLO = 'L'
282*
283 DO 160 iuplo = 1, 2
284 uplo = uplos( iuplo )
285*
286* Set up parameters with ZLATB4 and generate a test matrix
287* with ZLATMS.
288*
289 CALL zlatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
290 $ MODE, CNDNUM, DIST )
291*
292 srnamt = 'ZLATMS'
293 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
294 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
295 $ INFO )
296*
297* Check error code from ZLATMS.
298*
299 IF( info.NE.0 ) THEN
300 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n, -1,
301 $ -1, -1, imat, nfail, nerrs, nout )
302 GO TO 160
303 END IF
304*
305* For types 3-6, zero one or more rows and columns of the
306* matrix to test that INFO is returned correctly.
307*
308 IF( zerot ) THEN
309 IF( imat.EQ.3 ) THEN
310 izero = 1
311 ELSE IF( imat.EQ.4 ) THEN
312 izero = n
313 ELSE
314 izero = n / 2 + 1
315 END IF
316*
317 IF( imat.LT.6 ) THEN
318*
319* Set row and column IZERO to zero.
320*
321 IF( iuplo.EQ.1 ) THEN
322 ioff = ( izero-1 )*lda
323 DO 20 i = 1, izero - 1
324 a( ioff+i ) = czero
325 20 CONTINUE
326 ioff = ioff + izero
327 DO 30 i = izero, n
328 a( ioff ) = czero
329 ioff = ioff + lda
330 30 CONTINUE
331 ELSE
332 ioff = izero
333 DO 40 i = 1, izero - 1
334 a( ioff ) = czero
335 ioff = ioff + lda
336 40 CONTINUE
337 ioff = ioff - izero
338 DO 50 i = izero, n
339 a( ioff+i ) = czero
340 50 CONTINUE
341 END IF
342 ELSE
343 ioff = 0
344 IF( iuplo.EQ.1 ) THEN
345*
346* Set the first IZERO rows and columns to zero.
347*
348 DO 70 j = 1, n
349 i2 = min( j, izero )
350 DO 60 i = 1, i2
351 a( ioff+i ) = czero
352 60 CONTINUE
353 ioff = ioff + lda
354 70 CONTINUE
355 izero = 1
356 ELSE
357*
358* Set the last IZERO rows and columns to zero.
359*
360 DO 90 j = 1, n
361 i1 = max( j, izero )
362 DO 80 i = i1, n
363 a( ioff+i ) = czero
364 80 CONTINUE
365 ioff = ioff + lda
366 90 CONTINUE
367 END IF
368 END IF
369 ELSE
370 izero = 0
371 END IF
372*
373 DO 150 ifact = 1, nfact
374*
375* Do first for FACT = 'F', then for other values.
376*
377 fact = facts( ifact )
378*
379* Form an exact solution and set the right hand side.
380*
381 srnamt = 'ZLARHS'
382 CALL zlarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
383 $ nrhs, a, lda, xact, lda, b, lda, iseed,
384 $ info )
385 xtype = 'C'
386*
387* --- Test ZSYSV_AA ---
388*
389 IF( ifact.EQ.2 ) THEN
390 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
391 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
392*
393* Factor the matrix and solve the system using ZSYSV_AA.
394*
395 srnamt = 'ZSYSV_AA'
396 CALL zsysv_aa( uplo, n, nrhs, afac, lda, iwork,
397 $ x, lda, work, lwork, info )
398*
399* Adjust the expected value of INFO to account for
400* pivoting.
401*
402 IF( izero.GT.0 ) THEN
403 j = 1
404 k = izero
405 100 CONTINUE
406 IF( j.EQ.k ) THEN
407 k = iwork( j )
408 ELSE IF( iwork( j ).EQ.k ) THEN
409 k = j
410 END IF
411 IF( j.LT.k ) THEN
412 j = j + 1
413 GO TO 100
414 END IF
415 ELSE
416 k = 0
417 END IF
418*
419* Check error code from ZSYSV_AA .
420*
421 IF( info.NE.k ) THEN
422 CALL alaerh( path, 'ZSYSV_AA ', info, k,
423 $ uplo, n, n, -1, -1, nrhs,
424 $ imat, nfail, nerrs, nout )
425 GO TO 120
426 ELSE IF( info.NE.0 ) THEN
427 GO TO 120
428 END IF
429*
430* Reconstruct matrix from factors and compute
431* residual.
432*
433 CALL zsyt01_aa( uplo, n, a, lda, afac, lda,
434 $ iwork, ainv, lda, rwork,
435 $ result( 1 ) )
436*
437* Compute residual of the computed solution.
438*
439 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
440 CALL zsyt02( uplo, n, nrhs, a, lda, x, lda, work,
441 $ lda, rwork, result( 2 ) )
442 nt = 2
443*
444* Print information about the tests that did not pass
445* the threshold.
446*
447 DO 110 k = 1, nt
448 IF( result( k ).GE.thresh ) THEN
449 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
450 $ CALL aladhd( nout, path )
451 WRITE( nout, fmt = 9999 )'ZSYSV_AA ',
452 $ uplo, n, imat, k, result( k )
453 nfail = nfail + 1
454 END IF
455 110 CONTINUE
456 nrun = nrun + nt
457 120 CONTINUE
458 END IF
459*
460 150 CONTINUE
461*
462 160 CONTINUE
463 170 CONTINUE
464 180 CONTINUE
465*
466* Print a summary of the results.
467*
468 CALL alasvm( path, nout, nfail, nrun, nerrs )
469*
470 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
471 $ ', test ', i2, ', ratio =', g12.5 )
472 RETURN
473*
474* End of ZDRVSY_AA
475*
zsysv_aa
subroutine zsysv_aa(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
ZSYSV_AA computes the solution to system of linear equations A * X = B for SY matrices
Definition zsysv_aa.f:162

◆ zdrvsy_aa_2stage()

subroutine zdrvsy_aa_2stage ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZDRVSY_AA_2STAGE

Purpose:
!>
!> ZDRVSY_AA_2STAGE tests the driver routine ZSYSV_AA_2STAGE.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is COMPLEX*16 array, dimension (NMAX+2*NRHS)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 151 of file zdrvsy_aa_2stage.f.

155*
156* -- LAPACK test routine --
157* -- LAPACK is a software package provided by Univ. of Tennessee, --
158* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
159*
160* .. Scalar Arguments ..
161 LOGICAL TSTERR
162 INTEGER NMAX, NN, NOUT, NRHS
163 DOUBLE PRECISION THRESH
164* ..
165* .. Array Arguments ..
166 LOGICAL DOTYPE( * )
167 INTEGER IWORK( * ), NVAL( * )
168 DOUBLE PRECISION RWORK( * )
169 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
170 $ WORK( * ), X( * ), XACT( * )
171* ..
172*
173* =====================================================================
174*
175* .. Parameters ..
176 DOUBLE PRECISION ZERO
177 parameter( zero = 0.0d+0 )
178 COMPLEX*16 CZERO
179 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
180 INTEGER NTYPES, NTESTS
181 parameter( ntypes = 10, ntests = 3 )
182 INTEGER NFACT
183 parameter( nfact = 2 )
184* ..
185* .. Local Scalars ..
186 LOGICAL ZEROT
187 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
188 CHARACTER*3 MATPATH, PATH
189 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
190 $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
191 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
192 DOUBLE PRECISION ANORM, CNDNUM
193* ..
194* .. Local Arrays ..
195 CHARACTER FACTS( NFACT ), UPLOS( 2 )
196 INTEGER ISEED( 4 ), ISEEDY( 4 )
197 DOUBLE PRECISION RESULT( NTESTS )
198* ..
199* .. External Functions ..
200 DOUBLE PRECISION DGET06, ZLANSY
201 EXTERNAL dget06, zlansy
202* ..
203* .. External Subroutines ..
204 EXTERNAL aladhd, alaerh, alasvm, xlaenv, zerrvx,
205 $ zget04, zlacpy, zlarhs, zlatb4, zlatms,
206 $ zsysv_aa_2stage, zsyt01_aa, zsyt02,
207 $ zsytrf_aa_2stage
208* ..
209* .. Scalars in Common ..
210 LOGICAL LERR, OK
211 CHARACTER*32 SRNAMT
212 INTEGER INFOT, NUNIT
213* ..
214* .. Common blocks ..
215 COMMON / infoc / infot, nunit, ok, lerr
216 COMMON / srnamc / srnamt
217* ..
218* .. Intrinsic Functions ..
219 INTRINSIC cmplx, max, min
220* ..
221* .. Data statements ..
222 DATA iseedy / 1988, 1989, 1990, 1991 /
223 DATA uplos / 'U', 'L' / , facts / 'F', 'N' /
224* ..
225* .. Executable Statements ..
226*
227* Initialize constants and the random number seed.
228*
229* Test path
230*
231 path( 1: 1 ) = 'Zomplex precision'
232 path( 2: 3 ) = 'H2'
233*
234* Path to generate matrices
235*
236 matpath( 1: 1 ) = 'Zomplex precision'
237 matpath( 2: 3 ) = 'SY'
238*
239 nrun = 0
240 nfail = 0
241 nerrs = 0
242 DO 10 i = 1, 4
243 iseed( i ) = iseedy( i )
244 10 CONTINUE
245*
246* Test the error exits
247*
248 IF( tsterr )
249 $ CALL zerrvx( path, nout )
250 infot = 0
251*
252* Set the block size and minimum block size for testing.
253*
254 nb = 1
255 nbmin = 2
256 CALL xlaenv( 1, nb )
257 CALL xlaenv( 2, nbmin )
258*
259* Do for each value of N in NVAL
260*
261 DO 180 in = 1, nn
262 n = nval( in )
263 lda = max( n, 1 )
264 xtype = 'N'
265 nimat = ntypes
266 IF( n.LE.0 )
267 $ nimat = 1
268*
269 DO 170 imat = 1, nimat
270*
271* Do the tests only if DOTYPE( IMAT ) is true.
272*
273 IF( .NOT.dotype( imat ) )
274 $ GO TO 170
275*
276* Skip types 3, 4, 5, or 6 if the matrix size is too small.
277*
278 zerot = imat.GE.3 .AND. imat.LE.6
279 IF( zerot .AND. n.LT.imat-2 )
280 $ GO TO 170
281*
282* Do first for UPLO = 'U', then for UPLO = 'L'
283*
284 DO 160 iuplo = 1, 2
285 uplo = uplos( iuplo )
286*
287* Begin generate the test matrix A.
288*
289* Set up parameters with ZLATB4 for the matrix generator
290* based on the type of matrix to be generated.
291*
292 CALL zlatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
293 $ MODE, CNDNUM, DIST )
294*
295* Generate a matrix with ZLATMS.
296*
297 srnamt = 'ZLATMS'
298 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
299 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
300 $ WORK, INFO )
301*
302* Check error code from ZLATMS and handle error.
303*
304 IF( info.NE.0 ) THEN
305 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n,
306 $ -1, -1, -1, imat, nfail, nerrs, nout )
307 GO TO 160
308 END IF
309*
310* For types 3-6, zero one or more rows and columns of
311* the matrix to test that INFO is returned correctly.
312*
313 IF( zerot ) THEN
314 IF( imat.EQ.3 ) THEN
315 izero = 1
316 ELSE IF( imat.EQ.4 ) THEN
317 izero = n
318 ELSE
319 izero = n / 2 + 1
320 END IF
321*
322 IF( imat.LT.6 ) THEN
323*
324* Set row and column IZERO to zero.
325*
326 IF( iuplo.EQ.1 ) THEN
327 ioff = ( izero-1 )*lda
328 DO 20 i = 1, izero - 1
329 a( ioff+i ) = czero
330 20 CONTINUE
331 ioff = ioff + izero
332 DO 30 i = izero, n
333 a( ioff ) = czero
334 ioff = ioff + lda
335 30 CONTINUE
336 ELSE
337 ioff = izero
338 DO 40 i = 1, izero - 1
339 a( ioff ) = czero
340 ioff = ioff + lda
341 40 CONTINUE
342 ioff = ioff - izero
343 DO 50 i = izero, n
344 a( ioff+i ) = czero
345 50 CONTINUE
346 END IF
347 ELSE
348 ioff = 0
349 IF( iuplo.EQ.1 ) THEN
350*
351* Set the first IZERO rows and columns to zero.
352*
353 DO 70 j = 1, n
354 i2 = min( j, izero )
355 DO 60 i = 1, i2
356 a( ioff+i ) = czero
357 60 CONTINUE
358 ioff = ioff + lda
359 70 CONTINUE
360 izero = 1
361 ELSE
362*
363* Set the first IZERO rows and columns to zero.
364*
365 ioff = 0
366 DO 90 j = 1, n
367 i1 = max( j, izero )
368 DO 80 i = i1, n
369 a( ioff+i ) = czero
370 80 CONTINUE
371 ioff = ioff + lda
372 90 CONTINUE
373 END IF
374 END IF
375 ELSE
376 izero = 0
377 END IF
378*
379* End generate the test matrix A.
380*
381*
382 DO 150 ifact = 1, nfact
383*
384* Do first for FACT = 'F', then for other values.
385*
386 fact = facts( ifact )
387*
388* Form an exact solution and set the right hand side.
389*
390 srnamt = 'ZLARHS'
391 CALL zlarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
392 $ nrhs, a, lda, xact, lda, b, lda, iseed,
393 $ info )
394 xtype = 'C'
395*
396* --- Test ZSYSV_AA_2STAGE ---
397*
398 IF( ifact.EQ.2 ) THEN
399 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
400 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
401*
402* Factor the matrix and solve the system using ZSYSV_AA.
403*
404 srnamt = 'ZSYSV_AA_2STAGE '
405 lwork = min(n*nb, 3*nmax*nmax)
406 CALL zsysv_aa_2stage( uplo, n, nrhs, afac, lda,
407 $ ainv, (3*nb+1)*n,
408 $ iwork, iwork( 1+n ),
409 $ x, lda, work, lwork, info )
410*
411* Adjust the expected value of INFO to account for
412* pivoting.
413*
414 IF( izero.GT.0 ) THEN
415 j = 1
416 k = izero
417 100 CONTINUE
418 IF( j.EQ.k ) THEN
419 k = iwork( j )
420 ELSE IF( iwork( j ).EQ.k ) THEN
421 k = j
422 END IF
423 IF( j.LT.k ) THEN
424 j = j + 1
425 GO TO 100
426 END IF
427 ELSE
428 k = 0
429 END IF
430*
431* Check error code from ZSYSV_AA_2STAGE .
432*
433 IF( info.NE.k ) THEN
434 CALL alaerh( path, 'ZSYSV_AA_2STAGE', info, k,
435 $ uplo, n, n, -1, -1, nrhs,
436 $ imat, nfail, nerrs, nout )
437 GO TO 120
438 ELSE IF( info.NE.0 ) THEN
439 GO TO 120
440 END IF
441*
442* Compute residual of the computed solution.
443*
444 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
445 CALL zsyt02( uplo, n, nrhs, a, lda, x, lda, work,
446 $ lda, rwork, result( 1 ) )
447*
448* Reconstruct matrix from factors and compute
449* residual.
450*
451c CALL ZSY01_AA( UPLO, N, A, LDA, AFAC, LDA,
452c $ IWORK, AINV, LDA, RWORK,
453c $ RESULT( 2 ) )
454c NT = 2
455 nt = 1
456*
457* Print information about the tests that did not pass
458* the threshold.
459*
460 DO 110 k = 1, nt
461 IF( result( k ).GE.thresh ) THEN
462 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
463 $ CALL aladhd( nout, path )
464 WRITE( nout, fmt = 9999 )'ZSYSV_AA_2STAGE ',
465 $ uplo, n, imat, k, result( k )
466 nfail = nfail + 1
467 END IF
468 110 CONTINUE
469 nrun = nrun + nt
470 120 CONTINUE
471 END IF
472*
473 150 CONTINUE
474*
475 160 CONTINUE
476 170 CONTINUE
477 180 CONTINUE
478*
479* Print a summary of the results.
480*
481 CALL alasvm( path, nout, nfail, nrun, nerrs )
482*
483 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
484 $ ', test ', i2, ', ratio =', g12.5 )
485 RETURN
486*
487* End of ZDRVSY_AA_2STAGE
488*
cmplx
float cmplx[2]
Definition pblas.h:136
zsysv_aa_2stage
subroutine zsysv_aa_2stage(uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, work, lwork, info)
ZSYSV_AA_2STAGE computes the solution to system of linear equations A * X = B for SY matrices
Definition zsysv_aa_2stage.f:186

◆ zdrvsy_rk()

subroutine zdrvsy_rk ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) e,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZDRVSY_RK

Purpose:
!>
!> ZDRVSY_RK tests the driver routines ZSYSV_RK.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]E
!>          E is COMPLEX*16 array, dimension (NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 155 of file zdrvsy_rk.f.

158*
159* -- LAPACK test routine --
160* -- LAPACK is a software package provided by Univ. of Tennessee, --
161* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
162*
163* .. Scalar Arguments ..
164 LOGICAL TSTERR
165 INTEGER NMAX, NN, NOUT, NRHS
166 DOUBLE PRECISION THRESH
167* ..
168* .. Array Arguments ..
169 LOGICAL DOTYPE( * )
170 INTEGER IWORK( * ), NVAL( * )
171 DOUBLE PRECISION RWORK( * )
172 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
173 $ WORK( * ), X( * ), XACT( * )
174* ..
175*
176* =====================================================================
177*
178* .. Parameters ..
179 DOUBLE PRECISION ONE, ZERO
180 parameter( one = 1.0d+0, zero = 0.0d+0 )
181 INTEGER NTYPES, NTESTS
182 parameter( ntypes = 11, ntests = 3 )
183 INTEGER NFACT
184 parameter( nfact = 2 )
185* ..
186* .. Local Scalars ..
187 LOGICAL ZEROT
188 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
189 CHARACTER*3 MATPATH, PATH
190 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
191 $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
192 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
193 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC
194* ..
195* .. Local Arrays ..
196 CHARACTER FACTS( NFACT ), UPLOS( 2 )
197 INTEGER ISEED( 4 ), ISEEDY( 4 )
198 DOUBLE PRECISION RESULT( NTESTS )
199
200* ..
201* .. External Functions ..
202 DOUBLE PRECISION ZLANSY
203 EXTERNAL zlansy
204* ..
205* .. External Subroutines ..
206 EXTERNAL aladhd, alaerh, alasvm, xlaenv, zerrvx, zget04,
207 $ zlacpy, zlarhs, zlatb4, zlatms, zlatsy,
208 $ zsysv_rk, zsyt01_3, zsyt02, zsytrf_rk, zsytri_3
209* ..
210* .. Scalars in Common ..
211 LOGICAL LERR, OK
212 CHARACTER*32 SRNAMT
213 INTEGER INFOT, NUNIT
214* ..
215* .. Common blocks ..
216 COMMON / infoc / infot, nunit, ok, lerr
217 COMMON / srnamc / srnamt
218* ..
219* .. Intrinsic Functions ..
220 INTRINSIC max, min
221* ..
222* .. Data statements ..
223 DATA iseedy / 1988, 1989, 1990, 1991 /
224 DATA uplos / 'U', 'L' / , facts / 'F', 'N' /
225* ..
226* .. Executable Statements ..
227*
228* Initialize constants and the random number seed.
229*
230* Test path
231*
232 path( 1: 1 ) = 'Zomplex precision'
233 path( 2: 3 ) = 'SK'
234*
235* Path to generate matrices
236*
237 matpath( 1: 1 ) = 'Zomplex precision'
238 matpath( 2: 3 ) = 'SY'
239*
240 nrun = 0
241 nfail = 0
242 nerrs = 0
243 DO 10 i = 1, 4
244 iseed( i ) = iseedy( i )
245 10 CONTINUE
246 lwork = max( 2*nmax, nmax*nrhs )
247*
248* Test the error exits
249*
250 IF( tsterr )
251 $ CALL zerrvx( path, nout )
252 infot = 0
253*
254* Set the block size and minimum block size for which the block
255* routine should be used, which will be later returned by ILAENV.
256*
257 nb = 1
258 nbmin = 2
259 CALL xlaenv( 1, nb )
260 CALL xlaenv( 2, nbmin )
261*
262* Do for each value of N in NVAL
263*
264 DO 180 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 170 imat = 1, nimat
273*
274* Do the tests only if DOTYPE( IMAT ) is true.
275*
276 IF( .NOT.dotype( imat ) )
277 $ GO TO 170
278*
279* Skip types 3, 4, 5, or 6 if the matrix size is too small.
280*
281 zerot = imat.GE.3 .AND. imat.LE.6
282 IF( zerot .AND. n.LT.imat-2 )
283 $ GO TO 170
284*
285* Do first for UPLO = 'U', then for UPLO = 'L'
286*
287 DO 160 iuplo = 1, 2
288 uplo = uplos( iuplo )
289*
290 IF( imat.NE.ntypes ) THEN
291*
292* Begin generate the test matrix A.
293*
294* Set up parameters with ZLATB4 for the matrix generator
295* based on the type of matrix to be generated.
296*
297 CALL zlatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
298 $ MODE, CNDNUM, DIST )
299*
300* Generate a matrix with ZLATMS.
301*
302 srnamt = 'ZLATMS'
303 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
304 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
305 $ WORK, INFO )
306*
307* Check error code from DLATMS and handle error.
308*
309 IF( info.NE.0 ) THEN
310 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n,
311 $ -1, -1, -1, imat, nfail, nerrs, nout )
312 GO TO 160
313 END IF
314*
315* For types 3-6, zero one or more rows and columns of
316* the matrix to test that INFO is returned correctly.
317*
318 IF( zerot ) THEN
319 IF( imat.EQ.3 ) THEN
320 izero = 1
321 ELSE IF( imat.EQ.4 ) THEN
322 izero = n
323 ELSE
324 izero = n / 2 + 1
325 END IF
326*
327 IF( imat.LT.6 ) THEN
328*
329* Set row and column IZERO to zero.
330*
331 IF( iuplo.EQ.1 ) THEN
332 ioff = ( izero-1 )*lda
333 DO 20 i = 1, izero - 1
334 a( ioff+i ) = zero
335 20 CONTINUE
336 ioff = ioff + izero
337 DO 30 i = izero, n
338 a( ioff ) = zero
339 ioff = ioff + lda
340 30 CONTINUE
341 ELSE
342 ioff = izero
343 DO 40 i = 1, izero - 1
344 a( ioff ) = zero
345 ioff = ioff + lda
346 40 CONTINUE
347 ioff = ioff - izero
348 DO 50 i = izero, n
349 a( ioff+i ) = zero
350 50 CONTINUE
351 END IF
352 ELSE
353 IF( iuplo.EQ.1 ) THEN
354*
355* Set the first IZERO rows and columns to zero.
356*
357 ioff = 0
358 DO 70 j = 1, n
359 i2 = min( j, izero )
360 DO 60 i = 1, i2
361 a( ioff+i ) = zero
362 60 CONTINUE
363 ioff = ioff + lda
364 70 CONTINUE
365 ELSE
366*
367* Set the first IZERO rows and columns to zero.
368*
369 ioff = 0
370 DO 90 j = 1, n
371 i1 = max( j, izero )
372 DO 80 i = i1, n
373 a( ioff+i ) = zero
374 80 CONTINUE
375 ioff = ioff + lda
376 90 CONTINUE
377 END IF
378 END IF
379 ELSE
380 izero = 0
381 END IF
382 ELSE
383*
384* IMAT = NTYPES: Use a special block diagonal matrix to
385* test alternate code for the 2-by-2 blocks.
386*
387 CALL zlatsy( uplo, n, a, lda, iseed )
388 END IF
389*
390 DO 150 ifact = 1, nfact
391*
392* Do first for FACT = 'F', then for other values.
393*
394 fact = facts( ifact )
395*
396* Compute the condition number for comparison with
397* the value returned by ZSYSVX_ROOK.
398*
399 IF( zerot ) THEN
400 IF( ifact.EQ.1 )
401 $ GO TO 150
402 rcondc = zero
403*
404 ELSE IF( ifact.EQ.1 ) THEN
405*
406* Compute the 1-norm of A.
407*
408 anorm = zlansy( '1', uplo, n, a, lda, rwork )
409*
410* Factor the matrix A.
411*
412
413 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
414 CALL zsytrf_rk( uplo, n, afac, lda, e, iwork, ainv,
415 $ lwork, info )
416*
417* Compute inv(A) and take its norm.
418*
419 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
420 lwork = (n+nb+1)*(nb+3)
421*
422* We need to compute the inverse to compute
423* RCONDC that is used later in TEST3.
424*
425 CALL zsytri_3( uplo, n, ainv, lda, e, iwork,
426 $ work, lwork, info )
427 ainvnm = zlansy( '1', uplo, n, ainv, lda, rwork )
428*
429* Compute the 1-norm condition number of A.
430*
431 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
432 rcondc = one
433 ELSE
434 rcondc = ( one / anorm ) / ainvnm
435 END IF
436 END IF
437*
438* Form an exact solution and set the right hand side.
439*
440 srnamt = 'ZLARHS'
441 CALL zlarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
442 $ nrhs, a, lda, xact, lda, b, lda, iseed,
443 $ info )
444 xtype = 'C'
445*
446* --- Test ZSYSV_RK ---
447*
448 IF( ifact.EQ.2 ) THEN
449 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
450 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
451*
452* Factor the matrix and solve the system using
453* ZSYSV_RK.
454*
455 srnamt = 'ZSYSV_RK'
456 CALL zsysv_rk( uplo, n, nrhs, afac, lda, e, iwork,
457 $ x, lda, work, lwork, info )
458*
459* Adjust the expected value of INFO to account for
460* pivoting.
461*
462 k = izero
463 IF( k.GT.0 ) THEN
464 100 CONTINUE
465 IF( iwork( k ).LT.0 ) THEN
466 IF( iwork( k ).NE.-k ) THEN
467 k = -iwork( k )
468 GO TO 100
469 END IF
470 ELSE IF( iwork( k ).NE.k ) THEN
471 k = iwork( k )
472 GO TO 100
473 END IF
474 END IF
475*
476* Check error code from ZSYSV_RK and handle error.
477*
478 IF( info.NE.k ) THEN
479 CALL alaerh( path, 'ZSYSV_RK', info, k, uplo,
480 $ n, n, -1, -1, nrhs, imat, nfail,
481 $ nerrs, nout )
482 GO TO 120
483 ELSE IF( info.NE.0 ) THEN
484 GO TO 120
485 END IF
486*
487*+ TEST 1 Reconstruct matrix from factors and compute
488* residual.
489*
490 CALL zsyt01_3( uplo, n, a, lda, afac, lda, e,
491 $ iwork, ainv, lda, rwork,
492 $ result( 1 ) )
493*
494*+ TEST 2 Compute residual of the computed solution.
495*
496 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
497 CALL zsyt02( uplo, n, nrhs, a, lda, x, lda, work,
498 $ lda, rwork, result( 2 ) )
499*
500*+ TEST 3
501* Check solution from generated exact solution.
502*
503 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
504 $ result( 3 ) )
505 nt = 3
506*
507* Print information about the tests that did not pass
508* the threshold.
509*
510 DO 110 k = 1, nt
511 IF( result( k ).GE.thresh ) THEN
512 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
513 $ CALL aladhd( nout, path )
514 WRITE( nout, fmt = 9999 )'ZSYSV_RK', uplo,
515 $ n, imat, k, result( k )
516 nfail = nfail + 1
517 END IF
518 110 CONTINUE
519 nrun = nrun + nt
520 120 CONTINUE
521 END IF
522*
523 150 CONTINUE
524*
525 160 CONTINUE
526 170 CONTINUE
527 180 CONTINUE
528*
529* Print a summary of the results.
530*
531 CALL alasvm( path, nout, nfail, nrun, nerrs )
532*
533 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
534 $ ', test ', i2, ', ratio =', g12.5 )
535 RETURN
536*
537* End of ZDRVSY_RK
538*
zsysv_rk
subroutine zsysv_rk(uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work, lwork, info)
ZSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices
Definition zsysv_rk.f:228

◆ zdrvsy_rook()

subroutine zdrvsy_rook ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
double precision thresh,
logical tsterr,
integer nmax,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
complex*16, dimension( * ) ainv,
complex*16, dimension( * ) b,
complex*16, dimension( * ) x,
complex*16, dimension( * ) xact,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

ZDRVSY_ROOK

Purpose:
!>
!> ZDRVSY_ROOK tests the driver routines ZSYSV_ROOK.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (NMAX)
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 150 of file zdrvsy_rook.f.

153*
154* -- LAPACK test routine --
155* -- LAPACK is a software package provided by Univ. of Tennessee, --
156* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
157*
158* .. Scalar Arguments ..
159 LOGICAL TSTERR
160 INTEGER NMAX, NN, NOUT, NRHS
161 DOUBLE PRECISION THRESH
162* ..
163* .. Array Arguments ..
164 LOGICAL DOTYPE( * )
165 INTEGER IWORK( * ), NVAL( * )
166 DOUBLE PRECISION RWORK( * )
167 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
168 $ WORK( * ), X( * ), XACT( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 DOUBLE PRECISION ONE, ZERO
175 parameter( one = 1.0d+0, zero = 0.0d+0 )
176 INTEGER NTYPES, NTESTS
177 parameter( ntypes = 11, ntests = 3 )
178 INTEGER NFACT
179 parameter( nfact = 2 )
180* ..
181* .. Local Scalars ..
182 LOGICAL ZEROT
183 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
184 CHARACTER*3 MATPATH, PATH
185 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
186 $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
187 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
188 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC
189* ..
190* .. Local Arrays ..
191 CHARACTER FACTS( NFACT ), UPLOS( 2 )
192 INTEGER ISEED( 4 ), ISEEDY( 4 )
193 DOUBLE PRECISION RESULT( NTESTS )
194
195* ..
196* .. External Functions ..
197 DOUBLE PRECISION ZLANSY
198 EXTERNAL zlansy
199* ..
200* .. External Subroutines ..
201 EXTERNAL aladhd, alaerh, alasvm, xlaenv, zerrvx, zget04,
202 $ zlacpy, zlarhs, zlaset, zlatb4, zlatms, zlatsy,
203 $ zpot05, zsysv_rook, zsyt01_rook, zsyt02,
204 $ zsytrf_rook, zsytri_rook
205* ..
206* .. Scalars in Common ..
207 LOGICAL LERR, OK
208 CHARACTER*32 SRNAMT
209 INTEGER INFOT, NUNIT
210* ..
211* .. Common blocks ..
212 COMMON / infoc / infot, nunit, ok, lerr
213 COMMON / srnamc / srnamt
214* ..
215* .. Intrinsic Functions ..
216 INTRINSIC max, min
217* ..
218* .. Data statements ..
219 DATA iseedy / 1988, 1989, 1990, 1991 /
220 DATA uplos / 'U', 'L' / , facts / 'F', 'N' /
221* ..
222* .. Executable Statements ..
223*
224* Initialize constants and the random number seed.
225*
226* Test path
227*
228 path( 1: 1 ) = 'Zomplex precision'
229 path( 2: 3 ) = 'SR'
230*
231* Path to generate matrices
232*
233 matpath( 1: 1 ) = 'Zomplex precision'
234 matpath( 2: 3 ) = 'SY'
235*
236 nrun = 0
237 nfail = 0
238 nerrs = 0
239 DO 10 i = 1, 4
240 iseed( i ) = iseedy( i )
241 10 CONTINUE
242 lwork = max( 2*nmax, nmax*nrhs )
243*
244* Test the error exits
245*
246 IF( tsterr )
247 $ CALL zerrvx( path, nout )
248 infot = 0
249*
250* Set the block size and minimum block size for which the block
251* routine should be used, which will be later returned by ILAENV.
252*
253 nb = 1
254 nbmin = 2
255 CALL xlaenv( 1, nb )
256 CALL xlaenv( 2, nbmin )
257*
258* Do for each value of N in NVAL
259*
260 DO 180 in = 1, nn
261 n = nval( in )
262 lda = max( n, 1 )
263 xtype = 'N'
264 nimat = ntypes
265 IF( n.LE.0 )
266 $ nimat = 1
267*
268 DO 170 imat = 1, nimat
269*
270* Do the tests only if DOTYPE( IMAT ) is true.
271*
272 IF( .NOT.dotype( imat ) )
273 $ GO TO 170
274*
275* Skip types 3, 4, 5, or 6 if the matrix size is too small.
276*
277 zerot = imat.GE.3 .AND. imat.LE.6
278 IF( zerot .AND. n.LT.imat-2 )
279 $ GO TO 170
280*
281* Do first for UPLO = 'U', then for UPLO = 'L'
282*
283 DO 160 iuplo = 1, 2
284 uplo = uplos( iuplo )
285*
286 IF( imat.NE.ntypes ) THEN
287*
288* Begin generate the test matrix A.
289*
290* Set up parameters with ZLATB4 for the matrix generator
291* based on the type of matrix to be generated.
292*
293 CALL zlatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
294 $ MODE, CNDNUM, DIST )
295*
296* Generate a matrix with ZLATMS.
297*
298 srnamt = 'ZLATMS'
299 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
300 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
301 $ WORK, INFO )
302*
303* Check error code from DLATMS and handle error.
304*
305 IF( info.NE.0 ) THEN
306 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n,
307 $ -1, -1, -1, imat, nfail, nerrs, nout )
308 GO TO 160
309 END IF
310*
311* For types 3-6, zero one or more rows and columns of
312* the matrix to test that INFO is returned correctly.
313*
314 IF( zerot ) THEN
315 IF( imat.EQ.3 ) THEN
316 izero = 1
317 ELSE IF( imat.EQ.4 ) THEN
318 izero = n
319 ELSE
320 izero = n / 2 + 1
321 END IF
322*
323 IF( imat.LT.6 ) THEN
324*
325* Set row and column IZERO to zero.
326*
327 IF( iuplo.EQ.1 ) THEN
328 ioff = ( izero-1 )*lda
329 DO 20 i = 1, izero - 1
330 a( ioff+i ) = zero
331 20 CONTINUE
332 ioff = ioff + izero
333 DO 30 i = izero, n
334 a( ioff ) = zero
335 ioff = ioff + lda
336 30 CONTINUE
337 ELSE
338 ioff = izero
339 DO 40 i = 1, izero - 1
340 a( ioff ) = zero
341 ioff = ioff + lda
342 40 CONTINUE
343 ioff = ioff - izero
344 DO 50 i = izero, n
345 a( ioff+i ) = zero
346 50 CONTINUE
347 END IF
348 ELSE
349 IF( iuplo.EQ.1 ) THEN
350*
351* Set the first IZERO rows and columns to zero.
352*
353 ioff = 0
354 DO 70 j = 1, n
355 i2 = min( j, izero )
356 DO 60 i = 1, i2
357 a( ioff+i ) = zero
358 60 CONTINUE
359 ioff = ioff + lda
360 70 CONTINUE
361 ELSE
362*
363* Set the first IZERO rows and columns to zero.
364*
365 ioff = 0
366 DO 90 j = 1, n
367 i1 = max( j, izero )
368 DO 80 i = i1, n
369 a( ioff+i ) = zero
370 80 CONTINUE
371 ioff = ioff + lda
372 90 CONTINUE
373 END IF
374 END IF
375 ELSE
376 izero = 0
377 END IF
378 ELSE
379*
380* IMAT = NTYPES: Use a special block diagonal matrix to
381* test alternate code for the 2-by-2 blocks.
382*
383 CALL zlatsy( uplo, n, a, lda, iseed )
384 END IF
385*
386 DO 150 ifact = 1, nfact
387*
388* Do first for FACT = 'F', then for other values.
389*
390 fact = facts( ifact )
391*
392* Compute the condition number for comparison with
393* the value returned by ZSYSVX_ROOK.
394*
395 IF( zerot ) THEN
396 IF( ifact.EQ.1 )
397 $ GO TO 150
398 rcondc = zero
399*
400 ELSE IF( ifact.EQ.1 ) THEN
401*
402* Compute the 1-norm of A.
403*
404 anorm = zlansy( '1', uplo, n, a, lda, rwork )
405*
406* Factor the matrix A.
407*
408
409 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
410 CALL zsytrf_rook( uplo, n, afac, lda, iwork, work,
411 $ lwork, info )
412*
413* Compute inv(A) and take its norm.
414*
415 CALL zlacpy( uplo, n, n, afac, lda, ainv, lda )
416 lwork = (n+nb+1)*(nb+3)
417 CALL zsytri_rook( uplo, n, ainv, lda, iwork,
418 $ work, info )
419 ainvnm = zlansy( '1', uplo, n, ainv, lda, rwork )
420*
421* Compute the 1-norm condition number of A.
422*
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* Form an exact solution and set the right hand side.
431*
432 srnamt = 'ZLARHS'
433 CALL zlarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
434 $ nrhs, a, lda, xact, lda, b, lda, iseed,
435 $ info )
436 xtype = 'C'
437*
438* --- Test ZSYSV_ROOK ---
439*
440 IF( ifact.EQ.2 ) THEN
441 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
442 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
443*
444* Factor the matrix and solve the system using
445* ZSYSV_ROOK.
446*
447 srnamt = 'ZSYSV_ROOK'
448 CALL zsysv_rook( uplo, n, nrhs, afac, lda, iwork,
449 $ x, lda, work, lwork, info )
450*
451* Adjust the expected value of INFO to account for
452* pivoting.
453*
454 k = izero
455 IF( k.GT.0 ) THEN
456 100 CONTINUE
457 IF( iwork( k ).LT.0 ) THEN
458 IF( iwork( k ).NE.-k ) THEN
459 k = -iwork( k )
460 GO TO 100
461 END IF
462 ELSE IF( iwork( k ).NE.k ) THEN
463 k = iwork( k )
464 GO TO 100
465 END IF
466 END IF
467*
468* Check error code from ZSYSV_ROOK and handle error.
469*
470 IF( info.NE.k ) THEN
471 CALL alaerh( path, 'ZSYSV_ROOK', info, k, uplo,
472 $ n, n, -1, -1, nrhs, imat, nfail,
473 $ nerrs, nout )
474 GO TO 120
475 ELSE IF( info.NE.0 ) THEN
476 GO TO 120
477 END IF
478*
479*+ TEST 1 Reconstruct matrix from factors and compute
480* residual.
481*
482 CALL zsyt01_rook( uplo, n, a, lda, afac, lda,
483 $ iwork, ainv, lda, rwork,
484 $ result( 1 ) )
485*
486*+ TEST 2 Compute residual of the computed solution.
487*
488 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
489 CALL zsyt02( uplo, n, nrhs, a, lda, x, lda, work,
490 $ lda, rwork, result( 2 ) )
491*
492*+ TEST 3
493* Check solution from generated exact solution.
494*
495 CALL zget04( n, nrhs, x, lda, xact, lda, rcondc,
496 $ result( 3 ) )
497 nt = 3
498*
499* Print information about the tests that did not pass
500* the threshold.
501*
502 DO 110 k = 1, nt
503 IF( result( k ).GE.thresh ) THEN
504 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
505 $ CALL aladhd( nout, path )
506 WRITE( nout, fmt = 9999 )'ZSYSV_ROOK', uplo,
507 $ n, imat, k, result( k )
508 nfail = nfail + 1
509 END IF
510 110 CONTINUE
511 nrun = nrun + nt
512 120 CONTINUE
513 END IF
514*
515 150 CONTINUE
516*
517 160 CONTINUE
518 170 CONTINUE
519 180 CONTINUE
520*
521* Print a summary of the results.
522*
523 CALL alasvm( path, nout, nfail, nrun, nerrs )
524*
525 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
526 $ ', test ', i2, ', ratio =', g12.5 )
527 RETURN
528*
529* End of ZDRVSY_ROOK
530*
zsysv_rook
subroutine zsysv_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
ZSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices
Definition zsysv_rook.f:204

◆ zebchvxx()

subroutine zebchvxx ( double precision thresh,
character*3 path )

ZEBCHVXX

Purpose: 

!>
!>  ZEBCHVXX will run Z**SVXX on a series of Hilbert matrices and then
!>  compare the error bounds returned by Z**SVXX to see if the returned
!>  answer indeed falls within those bounds.
!>
!>  Eight test ratios will be computed.  The tests will pass if they are .LT.
!>  THRESH.  There are two cases that are determined by 1 / (SQRT( N ) * EPS).
!>  If that value is .LE. to the component wise reciprocal condition number,
!>  it uses the guaranteed case, other wise it uses the unguaranteed case.
!>
!>  Test ratios:
!>     Let Xc be X_computed and Xt be X_truth.
!>     The norm used is the infinity norm.
!>
!>     Let A be the guaranteed case and B be the unguaranteed case.
!>
!>       1. Normwise guaranteed forward error bound.
!>       A: norm ( abs( Xc - Xt ) / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ) and
!>          ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N),10) * EPS.
!>          If these conditions are met, the test ratio is set to be
!>          ERRBND( *, nwise_i, bnd_i ) / MAX(SQRT(N), 10).  Otherwise it is 1/EPS.
!>       B: For this case, CGESVXX should just return 1.  If it is less than
!>          one, treat it the same as in 1A.  Otherwise it fails. (Set test
!>          ratio to ERRBND( *, nwise_i, bnd_i ) * THRESH?)
!>
!>       2. Componentwise guaranteed forward error bound.
!>       A: norm ( abs( Xc(j) - Xt(j) ) ) / norm (Xt(j)) .LE. ERRBND( *, cwise_i, bnd_i )
!>          for all j .AND. ERRBND( *, cwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS.
!>          If these conditions are met, the test ratio is set to be
!>          ERRBND( *, cwise_i, bnd_i ) / MAX(SQRT(N), 10).  Otherwise it is 1/EPS.
!>       B: Same as normwise test ratio.
!>
!>       3. Backwards error.
!>       A: The test ratio is set to BERR/EPS.
!>       B: Same test ratio.
!>
!>       4. Reciprocal condition number.
!>       A: A condition number is computed with Xt and compared with the one
!>          returned from CGESVXX.  Let RCONDc be the RCOND returned by CGESVXX
!>          and RCONDt be the RCOND from the truth value.  Test ratio is set to
!>          MAX(RCONDc/RCONDt, RCONDt/RCONDc).
!>       B: Test ratio is set to 1 / (EPS * RCONDc).
!>
!>       5. Reciprocal normwise condition number.
!>       A: The test ratio is set to
!>          MAX(ERRBND( *, nwise_i, cond_i ) / NCOND, NCOND / ERRBND( *, nwise_i, cond_i )).
!>       B: Test ratio is set to 1 / (EPS * ERRBND( *, nwise_i, cond_i )).
!>
!>       6. Reciprocal componentwise condition number.
!>       A: Test ratio is set to
!>          MAX(ERRBND( *, cwise_i, cond_i ) / CCOND, CCOND / ERRBND( *, cwise_i, cond_i )).
!>       B: Test ratio is set to 1 / (EPS * ERRBND( *, cwise_i, cond_i )).
!>
!>     .. Parameters ..
!>     NMAX is determined by the largest number in the inverse of the hilbert
!>     matrix.  Precision is exhausted when the largest entry in it is greater
!>     than 2 to the power of the number of bits in the fraction of the data
!>     type used plus one, which is 24 for single precision.
!>     NMAX should be 6 for single and 11 for double.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 95 of file zebchvxx.f.

96 IMPLICIT NONE
97* .. Scalar Arguments ..
98 DOUBLE PRECISION THRESH
99 CHARACTER*3 PATH
100
101 INTEGER NMAX, NPARAMS, NERRBND, NTESTS, KL, KU
102 parameter(nmax = 10, nparams = 2, nerrbnd = 3,
103 $ ntests = 6)
104
105* .. Local Scalars ..
106 INTEGER N, NRHS, INFO, I ,J, k, NFAIL, LDA,
107 $ N_AUX_TESTS, LDAB, LDAFB
108 CHARACTER FACT, TRANS, UPLO, EQUED
109 CHARACTER*2 C2
110 CHARACTER(3) NGUAR, CGUAR
111 LOGICAL printed_guide
112 DOUBLE PRECISION NCOND, CCOND, M, NORMDIF, NORMT, RCOND,
113 $ RNORM, RINORM, SUMR, SUMRI, EPS,
114 $ BERR(NMAX), RPVGRW, ORCOND,
115 $ CWISE_ERR, NWISE_ERR, CWISE_BND, NWISE_BND,
116 $ CWISE_RCOND, NWISE_RCOND,
117 $ CONDTHRESH, ERRTHRESH
118 COMPLEX*16 ZDUM
119
120* .. Local Arrays ..
121 DOUBLE PRECISION TSTRAT(NTESTS), RINV(NMAX), PARAMS(NPARAMS),
122 $ S(NMAX),R(NMAX),C(NMAX),RWORK(3*NMAX),
123 $ DIFF(NMAX, NMAX),
124 $ ERRBND_N(NMAX*3), ERRBND_C(NMAX*3)
125 INTEGER IPIV(NMAX)
126 COMPLEX*16 A(NMAX,NMAX),INVHILB(NMAX,NMAX),X(NMAX,NMAX),
127 $ WORK(NMAX*3*5), AF(NMAX, NMAX),B(NMAX, NMAX),
128 $ ACOPY(NMAX, NMAX),
129 $ AB( (NMAX-1)+(NMAX-1)+1, NMAX ),
130 $ ABCOPY( (NMAX-1)+(NMAX-1)+1, NMAX ),
131 $ AFB( 2*(NMAX-1)+(NMAX-1)+1, NMAX )
132
133* .. External Functions ..
134 DOUBLE PRECISION DLAMCH
135
136* .. External Subroutines ..
137 EXTERNAL zlahilb, zgesvxx, zposvxx, zsysvxx,
138 $ zgbsvxx, zlacpy, lsamen
139 LOGICAL LSAMEN
140
141* .. Intrinsic Functions ..
142 INTRINSIC sqrt, max, abs, dble, dimag
143
144* .. Statement Functions ..
145 DOUBLE PRECISION CABS1
146
147* .. Statement Function Definitions ..
148 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
149
150* .. Parameters ..
151 INTEGER NWISE_I, CWISE_I
152 parameter(nwise_i = 1, cwise_i = 1)
153 INTEGER BND_I, COND_I
154 parameter(bnd_i = 2, cond_i = 3)
155
156* Create the loop to test out the Hilbert matrices
157
158 fact = 'E'
159 uplo = 'U'
160 trans = 'N'
161 equed = 'N'
162 eps = dlamch('Epsilon')
163 nfail = 0
164 n_aux_tests = 0
165 lda = nmax
166 ldab = (nmax-1)+(nmax-1)+1
167 ldafb = 2*(nmax-1)+(nmax-1)+1
168 c2 = path( 2: 3 )
169
170* Main loop to test the different Hilbert Matrices.
171
172 printed_guide = .false.
173
174 DO n = 1 , nmax
175 params(1) = -1
176 params(2) = -1
177
178 kl = n-1
179 ku = n-1
180 nrhs = n
181 m = max(sqrt(dble(n)), 10.0d+0)
182
183* Generate the Hilbert matrix, its inverse, and the
184* right hand side, all scaled by the LCM(1,..,2N-1).
185 CALL zlahilb(n, n, a, lda, invhilb, lda, b,
186 $ lda, work, info, path)
187
188* Copy A into ACOPY.
189 CALL zlacpy('ALL', n, n, a, nmax, acopy, nmax)
190
191* Store A in band format for GB tests
192 DO j = 1, n
193 DO i = 1, kl+ku+1
194 ab( i, j ) = (0.0d+0,0.0d+0)
195 END DO
196 END DO
197 DO j = 1, n
198 DO i = max( 1, j-ku ), min( n, j+kl )
199 ab( ku+1+i-j, j ) = a( i, j )
200 END DO
201 END DO
202
203* Copy AB into ABCOPY.
204 DO j = 1, n
205 DO i = 1, kl+ku+1
206 abcopy( i, j ) = (0.0d+0,0.0d+0)
207 END DO
208 END DO
209 CALL zlacpy('ALL', kl+ku+1, n, ab, ldab, abcopy, ldab)
210
211* Call Z**SVXX with default PARAMS and N_ERR_BND = 3.
212 IF ( lsamen( 2, c2, 'SY' ) ) THEN
213 CALL zsysvxx(fact, uplo, n, nrhs, acopy, lda, af, lda,
214 $ ipiv, equed, s, b, lda, x, lda, orcond,
215 $ rpvgrw, berr, nerrbnd, errbnd_n, errbnd_c, nparams,
216 $ params, work, rwork, info)
217 ELSE IF ( lsamen( 2, c2, 'PO' ) ) THEN
218 CALL zposvxx(fact, uplo, n, nrhs, acopy, lda, af, lda,
219 $ equed, s, b, lda, x, lda, orcond,
220 $ rpvgrw, berr, nerrbnd, errbnd_n, errbnd_c, nparams,
221 $ params, work, rwork, info)
222 ELSE IF ( lsamen( 2, c2, 'HE' ) ) THEN
223 CALL zhesvxx(fact, uplo, n, nrhs, acopy, lda, af, lda,
224 $ ipiv, equed, s, b, lda, x, lda, orcond,
225 $ rpvgrw, berr, nerrbnd, errbnd_n, errbnd_c, nparams,
226 $ params, work, rwork, info)
227 ELSE IF ( lsamen( 2, c2, 'GB' ) ) THEN
228 CALL zgbsvxx(fact, trans, n, kl, ku, nrhs, abcopy,
229 $ ldab, afb, ldafb, ipiv, equed, r, c, b,
230 $ lda, x, lda, orcond, rpvgrw, berr, nerrbnd,
231 $ errbnd_n, errbnd_c, nparams, params, work, rwork,
232 $ info)
233 ELSE
234 CALL zgesvxx(fact, trans, n, nrhs, acopy, lda, af, lda,
235 $ ipiv, equed, r, c, b, lda, x, lda, orcond,
236 $ rpvgrw, berr, nerrbnd, errbnd_n, errbnd_c, nparams,
237 $ params, work, rwork, info)
238 END IF
239
240 n_aux_tests = n_aux_tests + 1
241 IF (orcond .LT. eps) THEN
242! Either factorization failed or the matrix is flagged, and 1 <=
243! INFO <= N+1. We don't decide based on rcond anymore.
244! IF (INFO .EQ. 0 .OR. INFO .GT. N+1) THEN
245! NFAIL = NFAIL + 1
246! WRITE (*, FMT=8000) N, INFO, ORCOND, RCOND
247! END IF
248 ELSE
249! Either everything succeeded (INFO == 0) or some solution failed
250! to converge (INFO > N+1).
251 IF (info .GT. 0 .AND. info .LE. n+1) THEN
252 nfail = nfail + 1
253 WRITE (*, fmt=8000) c2, n, info, orcond, rcond
254 END IF
255 END IF
256
257* Calculating the difference between Z**SVXX's X and the true X.
258 DO i = 1,n
259 DO j =1,nrhs
260 diff(i,j) = x(i,j) - invhilb(i,j)
261 END DO
262 END DO
263
264* Calculating the RCOND
265 rnorm = 0
266 rinorm = 0
267 IF ( lsamen( 2, c2, 'PO' ) .OR. lsamen( 2, c2, 'SY' ) .OR.
268 $ lsamen( 2, c2, 'HE' ) ) THEN
269 DO i = 1, n
270 sumr = 0
271 sumri = 0
272 DO j = 1, n
273 sumr = sumr + s(i) * cabs1(a(i,j)) * s(j)
274 sumri = sumri + cabs1(invhilb(i, j)) / (s(j) * s(i))
275 END DO
276 rnorm = max(rnorm,sumr)
277 rinorm = max(rinorm,sumri)
278 END DO
279 ELSE IF ( lsamen( 2, c2, 'GE' ) .OR. lsamen( 2, c2, 'GB' ) )
280 $ THEN
281 DO i = 1, n
282 sumr = 0
283 sumri = 0
284 DO j = 1, n
285 sumr = sumr + r(i) * cabs1(a(i,j)) * c(j)
286 sumri = sumri + cabs1(invhilb(i, j)) / (r(j) * c(i))
287 END DO
288 rnorm = max(rnorm,sumr)
289 rinorm = max(rinorm,sumri)
290 END DO
291 END IF
292
293 rnorm = rnorm / cabs1(a(1, 1))
294 rcond = 1.0d+0/(rnorm * rinorm)
295
296* Calculating the R for normwise rcond.
297 DO i = 1, n
298 rinv(i) = 0.0d+0
299 END DO
300 DO j = 1, n
301 DO i = 1, n
302 rinv(i) = rinv(i) + cabs1(a(i,j))
303 END DO
304 END DO
305
306* Calculating the Normwise rcond.
307 rinorm = 0.0d+0
308 DO i = 1, n
309 sumri = 0.0d+0
310 DO j = 1, n
311 sumri = sumri + cabs1(invhilb(i,j) * rinv(j))
312 END DO
313 rinorm = max(rinorm, sumri)
314 END DO
315
316! invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm
317! by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix)
318 ncond = cabs1(a(1,1)) / rinorm
319
320 condthresh = m * eps
321 errthresh = m * eps
322
323 DO k = 1, nrhs
324 normt = 0.0d+0
325 normdif = 0.0d+0
326 cwise_err = 0.0d+0
327 DO i = 1, n
328 normt = max(cabs1(invhilb(i, k)), normt)
329 normdif = max(cabs1(x(i,k) - invhilb(i,k)), normdif)
330 IF (invhilb(i,k) .NE. 0.0d+0) THEN
331 cwise_err = max(cabs1(x(i,k) - invhilb(i,k))
332 $ /cabs1(invhilb(i,k)), cwise_err)
333 ELSE IF (x(i, k) .NE. 0.0d+0) THEN
334 cwise_err = dlamch('OVERFLOW')
335 END IF
336 END DO
337 IF (normt .NE. 0.0d+0) THEN
338 nwise_err = normdif / normt
339 ELSE IF (normdif .NE. 0.0d+0) THEN
340 nwise_err = dlamch('OVERFLOW')
341 ELSE
342 nwise_err = 0.0d+0
343 ENDIF
344
345 DO i = 1, n
346 rinv(i) = 0.0d+0
347 END DO
348 DO j = 1, n
349 DO i = 1, n
350 rinv(i) = rinv(i) + cabs1(a(i, j) * invhilb(j, k))
351 END DO
352 END DO
353 rinorm = 0.0d+0
354 DO i = 1, n
355 sumri = 0.0d+0
356 DO j = 1, n
357 sumri = sumri
358 $ + cabs1(invhilb(i, j) * rinv(j) / invhilb(i, k))
359 END DO
360 rinorm = max(rinorm, sumri)
361 END DO
362! invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm
363! by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix)
364 ccond = cabs1(a(1,1))/rinorm
365
366! Forward error bound tests
367 nwise_bnd = errbnd_n(k + (bnd_i-1)*nrhs)
368 cwise_bnd = errbnd_c(k + (bnd_i-1)*nrhs)
369 nwise_rcond = errbnd_n(k + (cond_i-1)*nrhs)
370 cwise_rcond = errbnd_c(k + (cond_i-1)*nrhs)
371! write (*,*) 'nwise : ', n, k, ncond, nwise_rcond,
372! $ condthresh, ncond.ge.condthresh
373! write (*,*) 'nwise2: ', k, nwise_bnd, nwise_err, errthresh
374 IF (ncond .GE. condthresh) THEN
375 nguar = 'YES'
376 IF (nwise_bnd .GT. errthresh) THEN
377 tstrat(1) = 1/(2.0d+0*eps)
378 ELSE
379 IF (nwise_bnd .NE. 0.0d+0) THEN
380 tstrat(1) = nwise_err / nwise_bnd
381 ELSE IF (nwise_err .NE. 0.0d+0) THEN
382 tstrat(1) = 1/(16.0*eps)
383 ELSE
384 tstrat(1) = 0.0d+0
385 END IF
386 IF (tstrat(1) .GT. 1.0d+0) THEN
387 tstrat(1) = 1/(4.0d+0*eps)
388 END IF
389 END IF
390 ELSE
391 nguar = 'NO'
392 IF (nwise_bnd .LT. 1.0d+0) THEN
393 tstrat(1) = 1/(8.0d+0*eps)
394 ELSE
395 tstrat(1) = 1.0d+0
396 END IF
397 END IF
398! write (*,*) 'cwise : ', n, k, ccond, cwise_rcond,
399! $ condthresh, ccond.ge.condthresh
400! write (*,*) 'cwise2: ', k, cwise_bnd, cwise_err, errthresh
401 IF (ccond .GE. condthresh) THEN
402 cguar = 'YES'
403 IF (cwise_bnd .GT. errthresh) THEN
404 tstrat(2) = 1/(2.0d+0*eps)
405 ELSE
406 IF (cwise_bnd .NE. 0.0d+0) THEN
407 tstrat(2) = cwise_err / cwise_bnd
408 ELSE IF (cwise_err .NE. 0.0d+0) THEN
409 tstrat(2) = 1/(16.0d+0*eps)
410 ELSE
411 tstrat(2) = 0.0d+0
412 END IF
413 IF (tstrat(2) .GT. 1.0d+0) tstrat(2) = 1/(4.0d+0*eps)
414 END IF
415 ELSE
416 cguar = 'NO'
417 IF (cwise_bnd .LT. 1.0d+0) THEN
418 tstrat(2) = 1/(8.0d+0*eps)
419 ELSE
420 tstrat(2) = 1.0d+0
421 END IF
422 END IF
423
424! Backwards error test
425 tstrat(3) = berr(k)/eps
426
427! Condition number tests
428 tstrat(4) = rcond / orcond
429 IF (rcond .GE. condthresh .AND. tstrat(4) .LT. 1.0d+0)
430 $ tstrat(4) = 1.0d+0 / tstrat(4)
431
432 tstrat(5) = ncond / nwise_rcond
433 IF (ncond .GE. condthresh .AND. tstrat(5) .LT. 1.0d+0)
434 $ tstrat(5) = 1.0d+0 / tstrat(5)
435
436 tstrat(6) = ccond / nwise_rcond
437 IF (ccond .GE. condthresh .AND. tstrat(6) .LT. 1.0d+0)
438 $ tstrat(6) = 1.0d+0 / tstrat(6)
439
440 DO i = 1, ntests
441 IF (tstrat(i) .GT. thresh) THEN
442 IF (.NOT.printed_guide) THEN
443 WRITE(*,*)
444 WRITE( *, 9996) 1
445 WRITE( *, 9995) 2
446 WRITE( *, 9994) 3
447 WRITE( *, 9993) 4
448 WRITE( *, 9992) 5
449 WRITE( *, 9991) 6
450 WRITE( *, 9990) 7
451 WRITE( *, 9989) 8
452 WRITE(*,*)
453 printed_guide = .true.
454 END IF
455 WRITE( *, 9999) c2, n, k, nguar, cguar, i, tstrat(i)
456 nfail = nfail + 1
457 END IF
458 END DO
459 END DO
460
461c$$$ WRITE(*,*)
462c$$$ WRITE(*,*) 'Normwise Error Bounds'
463c$$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,nwise_i,bnd_i)
464c$$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,nwise_i,cond_i)
465c$$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,nwise_i,rawbnd_i)
466c$$$ WRITE(*,*)
467c$$$ WRITE(*,*) 'Componentwise Error Bounds'
468c$$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,cwise_i,bnd_i)
469c$$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,cwise_i,cond_i)
470c$$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,cwise_i,rawbnd_i)
471c$$$ print *, 'Info: ', info
472c$$$ WRITE(*,*)
473* WRITE(*,*) 'TSTRAT: ',TSTRAT
474
475 END DO
476
477 WRITE(*,*)
478 IF( nfail .GT. 0 ) THEN
479 WRITE(*,9998) c2, nfail, ntests*n+n_aux_tests
480 ELSE
481 WRITE(*,9997) c2
482 END IF
483 9999 FORMAT( ' Z', a2, 'SVXX: N =', i2, ', RHS = ', i2,
484 $ ', NWISE GUAR. = ', a, ', CWISE GUAR. = ', a,
485 $ ' test(',i1,') =', g12.5 )
486 9998 FORMAT( ' Z', a2, 'SVXX: ', i6, ' out of ', i6,
487 $ ' tests failed to pass the threshold' )
488 9997 FORMAT( ' Z', a2, 'SVXX passed the tests of error bounds' )
489* Test ratios.
490 9996 FORMAT( 3x, i2, ': Normwise guaranteed forward error', / 5x,
491 $ 'Guaranteed case: if norm ( abs( Xc - Xt )',
492 $ .LE.' / norm ( Xt ) ERRBND( *, nwise_i, bnd_i ), then',
493 $ / 5x,
494 $ .LE.'ERRBND( *, nwise_i, bnd_i ) MAX(SQRT(N), 10) * EPS')
495 9995 FORMAT( 3x, i2, ': Componentwise guaranteed forward error' )
496 9994 FORMAT( 3x, i2, ': Backwards error' )
497 9993 FORMAT( 3x, i2, ': Reciprocal condition number' )
498 9992 FORMAT( 3x, i2, ': Reciprocal normwise condition number' )
499 9991 FORMAT( 3x, i2, ': Raw normwise error estimate' )
500 9990 FORMAT( 3x, i2, ': Reciprocal componentwise condition number' )
501 9989 FORMAT( 3x, i2, ': Raw componentwise error estimate' )
502
503 8000 FORMAT( ' Z', a2, 'SVXX: N =', i2, ', INFO = ', i3,
504 $ ', ORCOND = ', g12.5, ', real RCOND = ', g12.5 )
505*
506* End of ZEBCHVXX
507*
lsamen
logical function lsamen(n, ca, cb)
LSAMEN
Definition lsamen.f:74
zgbsvxx
subroutine zgbsvxx(fact, trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, equed, r, c, b, ldb, x, ldx, rcond, rpvgrw, berr, n_err_bnds, err_bnds_norm, err_bnds_comp, nparams, params, work, rwork, info)
ZGBSVXX computes the solution to system of linear equations A * X = B for GB matrices
Definition zgbsvxx.f:560
zgesvxx
subroutine zgesvxx(fact, trans, n, nrhs, a, lda, af, ldaf, ipiv, equed, r, c, b, ldb, x, ldx, rcond, rpvgrw, berr, n_err_bnds, err_bnds_norm, err_bnds_comp, nparams, params, work, rwork, info)
ZGESVXX computes the solution to system of linear equations A * X = B for GE matrices
Definition zgesvxx.f:540
zhesvxx
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
Definition zhesvxx.f:506
zposvxx
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
Definition zposvxx.f:493
zsysvxx
subroutine zsysvxx(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)
ZSYSVXX computes the solution to system of linear equations A * X = B for SY matrices
Definition zsysvxx.f:506
zlahilb
subroutine zlahilb(n, nrhs, a, lda, x, ldx, b, ldb, work, info, path)
ZLAHILB
Definition zlahilb.f:134

◆ zerrab()

subroutine zerrab ( integer nunit)

ZERRAB

Purpose:
!>
!> DERRAB tests the error exits for ZCGESV.
!>
Parameters
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 46 of file zerrab.f.

47*
48* -- LAPACK test routine --
49* -- LAPACK is a software package provided by Univ. of Tennessee, --
50* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
51*
52* .. Scalar Arguments ..
53 INTEGER NUNIT
54* ..
55*
56* =====================================================================
57*
58* .. Parameters ..
59 INTEGER NMAX
60 parameter( nmax = 4 )
61* ..
62* .. Local Scalars ..
63 INTEGER I, INFO, ITER, J
64* ..
65* .. Local Arrays ..
66 INTEGER IP( NMAX )
67 COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
68 $ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ),
69 $ W( 2*NMAX ), X( NMAX )
70 COMPLEX*16 WORK(1)
71 COMPLEX SWORK(1)
72 DOUBLE PRECISION RWORK(1)
73* ..
74* .. External Functions ..
75* ..
76* .. External Subroutines ..
77 EXTERNAL chkxer, zcgesv
78* ..
79* .. Scalars in Common ..
80 LOGICAL LERR, OK
81 CHARACTER*32 SRNAMT
82 INTEGER INFOT, NOUT
83* ..
84* .. Common blocks ..
85 COMMON / infoc / infot, nout, ok, lerr
86 COMMON / srnamc / srnamt
87* ..
88* .. Intrinsic Functions ..
89 INTRINSIC dble
90* ..
91* .. Executable Statements ..
92*
93 nout = nunit
94 WRITE( nout, fmt = * )
95*
96* Set the variables to innocuous values.
97*
98 DO 20 j = 1, nmax
99 DO 10 i = 1, nmax
100 a( i, j ) = 1.d0 / dble( i+j )
101 af( i, j ) = 1.d0 / dble( i+j )
102 10 CONTINUE
103 b( j ) = 0.d0
104 r1( j ) = 0.d0
105 r2( j ) = 0.d0
106 w( j ) = 0.d0
107 x( j ) = 0.d0
108 c( j ) = 0.d0
109 r( j ) = 0.d0
110 ip( j ) = j
111 20 CONTINUE
112 ok = .true.
113*
114 srnamt = 'ZCGESV'
115 infot = 1
116 CALL zcgesv(-1,0,a,1,ip,b,1,x,1,work,swork,rwork,iter,info)
117 CALL chkxer( 'ZCGESV', infot, nout, lerr, ok )
118 infot = 2
119 CALL zcgesv(0,-1,a,1,ip,b,1,x,1,work,swork,rwork,iter,info)
120 CALL chkxer( 'ZCGESV', infot, nout, lerr, ok )
121 infot = 4
122 CALL zcgesv(2,1,a,1,ip,b,2,x,2,work,swork,rwork,iter,info)
123 CALL chkxer( 'ZCGESV', infot, nout, lerr, ok )
124 infot = 7
125 CALL zcgesv(2,1,a,2,ip,b,1,x,2,work,swork,rwork,iter,info)
126 CALL chkxer( 'ZCGESV', infot, nout, lerr, ok )
127 infot = 9
128 CALL zcgesv(2,1,a,2,ip,b,2,x,1,work,swork,rwork,iter,info)
129 CALL chkxer( 'ZCGESV', infot, nout, lerr, ok )
130*
131* Print a summary line.
132*
133 IF( ok ) THEN
134 WRITE( nout, fmt = 9999 )'ZCGESV'
135 ELSE
136 WRITE( nout, fmt = 9998 )'ZCGESV'
137 END IF
138*
139 9999 FORMAT( 1x, a6, ' drivers passed the tests of the error exits' )
140 9998 FORMAT( ' *** ', a6, ' drivers failed the tests of the error ',
141 $ 'exits ***' )
142*
143 RETURN
144*
145* End of ZERRAB
146*
chkxer
subroutine chkxer(srnamt, infot, nout, lerr, ok)
Definition cblat2.f:3196

◆ zerrac()

subroutine zerrac ( integer nunit)

ZERRAC

Purpose:
!>
!> ZERRPX tests the error exits for ZCPOSV.
!>
Parameters
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 46 of file zerrac.f.

47*
48* -- LAPACK test routine --
49* -- LAPACK is a software package provided by Univ. of Tennessee, --
50* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
51*
52* .. Scalar Arguments ..
53 INTEGER NUNIT
54* ..
55*
56* =====================================================================
57*
58* .. Parameters ..
59 INTEGER NMAX
60 parameter( nmax = 4 )
61* ..
62* .. Local Scalars ..
63 INTEGER I, INFO, ITER, J
64* ..
65* .. Local Arrays ..
66 COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
67 $ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ),
68 $ W( 2*NMAX ), X( NMAX )
69 DOUBLE PRECISION RWORK( NMAX )
70 COMPLEX*16 WORK(NMAX*NMAX)
71 COMPLEX SWORK(NMAX*NMAX)
72* ..
73* .. External Subroutines ..
74 EXTERNAL chkxer, zcposv
75* ..
76* .. Scalars in Common ..
77 LOGICAL LERR, OK
78 CHARACTER*32 SRNAMT
79 INTEGER INFOT, NOUT
80* ..
81* .. Common blocks ..
82 COMMON / infoc / infot, nout, ok, lerr
83 COMMON / srnamc / srnamt
84* ..
85* .. Intrinsic Functions ..
86 INTRINSIC dble
87* ..
88* .. Executable Statements ..
89*
90 nout = nunit
91 WRITE( nout, fmt = * )
92*
93* Set the variables to innocuous values.
94*
95 DO 20 j = 1, nmax
96 DO 10 i = 1, nmax
97 a( i, j ) = 1.d0 / dble( i+j )
98 af( i, j ) = 1.d0 / dble( i+j )
99 10 CONTINUE
100 b( j ) = 0.d0
101 r1( j ) = 0.d0
102 r2( j ) = 0.d0
103 w( j ) = 0.d0
104 x( j ) = 0.d0
105 c( j ) = 0.d0
106 r( j ) = 0.d0
107 20 CONTINUE
108 ok = .true.
109*
110 srnamt = 'ZCPOSV'
111 infot = 1
112 CALL zcposv('/',0,0,a,1,b,1,x,1,work,swork,rwork,iter,info)
113 CALL chkxer( 'ZCPOSV', infot, nout, lerr, ok )
114 infot = 2
115 CALL zcposv('U',-1,0,a,1,b,1,x,1,work,swork,rwork,iter,info)
116 CALL chkxer( 'ZCPOSV', infot, nout, lerr, ok )
117 infot = 3
118 CALL zcposv('U',0,-1,a,1,b,1,x,1,work,swork,rwork,iter,info)
119 CALL chkxer( 'ZCPOSV', infot, nout, lerr, ok )
120 infot = 5
121 CALL zcposv('U',2,1,a,1,b,2,x,2,work,swork,rwork,iter,info)
122 CALL chkxer( 'ZCPOSV', infot, nout, lerr, ok )
123 infot = 7
124 CALL zcposv('U',2,1,a,2,b,1,x,2,work,swork,rwork,iter,info)
125 CALL chkxer( 'ZCPOSV', infot, nout, lerr, ok )
126 infot = 9
127 CALL zcposv('U',2,1,a,2,b,2,x,1,work,swork,rwork,iter,info)
128 CALL chkxer( 'ZCPOSV', infot, nout, lerr, ok )
129*
130* Print a summary line.
131*
132 IF( ok ) THEN
133 WRITE( nout, fmt = 9999 )'ZCPOSV'
134 ELSE
135 WRITE( nout, fmt = 9998 )'ZCPOSV'
136 END IF
137*
138 9999 FORMAT( 1x, a6, ' drivers passed the tests of the error exits' )
139 9998 FORMAT( ' *** ', a6, ' drivers failed the tests of the error ',
140 $ 'exits ***' )
141*
142 RETURN
143*
144* End of ZERRAC
145*

◆ zerrge()

subroutine zerrge ( character*3 path,
integer nunit )

ZERRGE

ZERRGEX

Purpose:
!>
!> ZERRGE tests the error exits for the COMPLEX*16 routines
!> for general matrices.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Purpose:
!>
!> ZERRGE tests the error exits for the COMPLEX*16 routines
!> for general matrices.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise zerrge.f defines this subroutine.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 54 of file zerrge.f.

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX
69 parameter( nmax = 4 )
70* ..
71* .. Local Scalars ..
72 CHARACTER*2 C2
73 INTEGER I, INFO, J
74 DOUBLE PRECISION ANRM, CCOND, RCOND
75* ..
76* .. Local Arrays ..
77 INTEGER IP( NMAX )
78 DOUBLE PRECISION R( NMAX ), R1( NMAX ), R2( NMAX )
79 COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
80 $ W( 2*NMAX ), X( NMAX )
81* ..
82* .. External Functions ..
83 LOGICAL LSAMEN
84 EXTERNAL lsamen
85* ..
86* .. External Subroutines ..
87 EXTERNAL alaesm, chkxer, zgbcon, zgbequ, zgbrfs, zgbtf2,
88 $ zgbtrf, zgbtrs, zgecon, zgeequ, zgerfs, zgetf2,
89 $ zgetrf, zgetri, zgetrs
90* ..
91* .. Scalars in Common ..
92 LOGICAL LERR, OK
93 CHARACTER*32 SRNAMT
94 INTEGER INFOT, NOUT
95* ..
96* .. Common blocks ..
97 COMMON / infoc / infot, nout, ok, lerr
98 COMMON / srnamc / srnamt
99* ..
100* .. Intrinsic Functions ..
101 INTRINSIC dble, dcmplx
102* ..
103* .. Executable Statements ..
104*
105 nout = nunit
106 WRITE( nout, fmt = * )
107 c2 = path( 2: 3 )
108*
109* Set the variables to innocuous values.
110*
111 DO 20 j = 1, nmax
112 DO 10 i = 1, nmax
113 a( i, j ) = dcmplx( 1.d0 / dble( i+j ),
114 $ -1.d0 / dble( i+j ) )
115 af( i, j ) = dcmplx( 1.d0 / dble( i+j ),
116 $ -1.d0 / dble( i+j ) )
117 10 CONTINUE
118 b( j ) = 0.d0
119 r1( j ) = 0.d0
120 r2( j ) = 0.d0
121 w( j ) = 0.d0
122 x( j ) = 0.d0
123 ip( j ) = j
124 20 CONTINUE
125 ok = .true.
126*
127* Test error exits of the routines that use the LU decomposition
128* of a general matrix.
129*
130 IF( lsamen( 2, c2, 'GE' ) ) THEN
131*
132* ZGETRF
133*
134 srnamt = 'ZGETRF'
135 infot = 1
136 CALL zgetrf( -1, 0, a, 1, ip, info )
137 CALL chkxer( 'ZGETRF', infot, nout, lerr, ok )
138 infot = 2
139 CALL zgetrf( 0, -1, a, 1, ip, info )
140 CALL chkxer( 'ZGETRF', infot, nout, lerr, ok )
141 infot = 4
142 CALL zgetrf( 2, 1, a, 1, ip, info )
143 CALL chkxer( 'ZGETRF', infot, nout, lerr, ok )
144*
145* ZGETF2
146*
147 srnamt = 'ZGETF2'
148 infot = 1
149 CALL zgetf2( -1, 0, a, 1, ip, info )
150 CALL chkxer( 'ZGETF2', infot, nout, lerr, ok )
151 infot = 2
152 CALL zgetf2( 0, -1, a, 1, ip, info )
153 CALL chkxer( 'ZGETF2', infot, nout, lerr, ok )
154 infot = 4
155 CALL zgetf2( 2, 1, a, 1, ip, info )
156 CALL chkxer( 'ZGETF2', infot, nout, lerr, ok )
157*
158* ZGETRI
159*
160 srnamt = 'ZGETRI'
161 infot = 1
162 CALL zgetri( -1, a, 1, ip, w, 1, info )
163 CALL chkxer( 'ZGETRI', infot, nout, lerr, ok )
164 infot = 3
165 CALL zgetri( 2, a, 1, ip, w, 2, info )
166 CALL chkxer( 'ZGETRI', infot, nout, lerr, ok )
167 infot = 6
168 CALL zgetri( 2, a, 2, ip, w, 1, info )
169 CALL chkxer( 'ZGETRI', infot, nout, lerr, ok )
170*
171* ZGETRS
172*
173 srnamt = 'ZGETRS'
174 infot = 1
175 CALL zgetrs( '/', 0, 0, a, 1, ip, b, 1, info )
176 CALL chkxer( 'ZGETRS', infot, nout, lerr, ok )
177 infot = 2
178 CALL zgetrs( 'N', -1, 0, a, 1, ip, b, 1, info )
179 CALL chkxer( 'ZGETRS', infot, nout, lerr, ok )
180 infot = 3
181 CALL zgetrs( 'N', 0, -1, a, 1, ip, b, 1, info )
182 CALL chkxer( 'ZGETRS', infot, nout, lerr, ok )
183 infot = 5
184 CALL zgetrs( 'N', 2, 1, a, 1, ip, b, 2, info )
185 CALL chkxer( 'ZGETRS', infot, nout, lerr, ok )
186 infot = 8
187 CALL zgetrs( 'N', 2, 1, a, 2, ip, b, 1, info )
188 CALL chkxer( 'ZGETRS', infot, nout, lerr, ok )
189*
190* ZGERFS
191*
192 srnamt = 'ZGERFS'
193 infot = 1
194 CALL zgerfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
195 $ r, info )
196 CALL chkxer( 'ZGERFS', infot, nout, lerr, ok )
197 infot = 2
198 CALL zgerfs( 'N', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
199 $ w, r, info )
200 CALL chkxer( 'ZGERFS', infot, nout, lerr, ok )
201 infot = 3
202 CALL zgerfs( 'N', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
203 $ w, r, info )
204 CALL chkxer( 'ZGERFS', infot, nout, lerr, ok )
205 infot = 5
206 CALL zgerfs( 'N', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
207 $ r, info )
208 CALL chkxer( 'ZGERFS', infot, nout, lerr, ok )
209 infot = 7
210 CALL zgerfs( 'N', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
211 $ r, info )
212 CALL chkxer( 'ZGERFS', infot, nout, lerr, ok )
213 infot = 10
214 CALL zgerfs( 'N', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
215 $ r, info )
216 CALL chkxer( 'ZGERFS', infot, nout, lerr, ok )
217 infot = 12
218 CALL zgerfs( 'N', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
219 $ r, info )
220 CALL chkxer( 'ZGERFS', infot, nout, lerr, ok )
221*
222* ZGECON
223*
224 srnamt = 'ZGECON'
225 infot = 1
226 CALL zgecon( '/', 0, a, 1, anrm, rcond, w, r, info )
227 CALL chkxer( 'ZGECON', infot, nout, lerr, ok )
228 infot = 2
229 CALL zgecon( '1', -1, a, 1, anrm, rcond, w, r, info )
230 CALL chkxer( 'ZGECON', infot, nout, lerr, ok )
231 infot = 4
232 CALL zgecon( '1', 2, a, 1, anrm, rcond, w, r, info )
233 CALL chkxer( 'ZGECON', infot, nout, lerr, ok )
234*
235* ZGEEQU
236*
237 srnamt = 'ZGEEQU'
238 infot = 1
239 CALL zgeequ( -1, 0, a, 1, r1, r2, rcond, ccond, anrm, info )
240 CALL chkxer( 'ZGEEQU', infot, nout, lerr, ok )
241 infot = 2
242 CALL zgeequ( 0, -1, a, 1, r1, r2, rcond, ccond, anrm, info )
243 CALL chkxer( 'ZGEEQU', infot, nout, lerr, ok )
244 infot = 4
245 CALL zgeequ( 2, 2, a, 1, r1, r2, rcond, ccond, anrm, info )
246 CALL chkxer( 'ZGEEQU', infot, nout, lerr, ok )
247*
248* Test error exits of the routines that use the LU decomposition
249* of a general band matrix.
250*
251 ELSE IF( lsamen( 2, c2, 'GB' ) ) THEN
252*
253* ZGBTRF
254*
255 srnamt = 'ZGBTRF'
256 infot = 1
257 CALL zgbtrf( -1, 0, 0, 0, a, 1, ip, info )
258 CALL chkxer( 'ZGBTRF', infot, nout, lerr, ok )
259 infot = 2
260 CALL zgbtrf( 0, -1, 0, 0, a, 1, ip, info )
261 CALL chkxer( 'ZGBTRF', infot, nout, lerr, ok )
262 infot = 3
263 CALL zgbtrf( 1, 1, -1, 0, a, 1, ip, info )
264 CALL chkxer( 'ZGBTRF', infot, nout, lerr, ok )
265 infot = 4
266 CALL zgbtrf( 1, 1, 0, -1, a, 1, ip, info )
267 CALL chkxer( 'ZGBTRF', infot, nout, lerr, ok )
268 infot = 6
269 CALL zgbtrf( 2, 2, 1, 1, a, 3, ip, info )
270 CALL chkxer( 'ZGBTRF', infot, nout, lerr, ok )
271*
272* ZGBTF2
273*
274 srnamt = 'ZGBTF2'
275 infot = 1
276 CALL zgbtf2( -1, 0, 0, 0, a, 1, ip, info )
277 CALL chkxer( 'ZGBTF2', infot, nout, lerr, ok )
278 infot = 2
279 CALL zgbtf2( 0, -1, 0, 0, a, 1, ip, info )
280 CALL chkxer( 'ZGBTF2', infot, nout, lerr, ok )
281 infot = 3
282 CALL zgbtf2( 1, 1, -1, 0, a, 1, ip, info )
283 CALL chkxer( 'ZGBTF2', infot, nout, lerr, ok )
284 infot = 4
285 CALL zgbtf2( 1, 1, 0, -1, a, 1, ip, info )
286 CALL chkxer( 'ZGBTF2', infot, nout, lerr, ok )
287 infot = 6
288 CALL zgbtf2( 2, 2, 1, 1, a, 3, ip, info )
289 CALL chkxer( 'ZGBTF2', infot, nout, lerr, ok )
290*
291* ZGBTRS
292*
293 srnamt = 'ZGBTRS'
294 infot = 1
295 CALL zgbtrs( '/', 0, 0, 0, 1, a, 1, ip, b, 1, info )
296 CALL chkxer( 'ZGBTRS', infot, nout, lerr, ok )
297 infot = 2
298 CALL zgbtrs( 'N', -1, 0, 0, 1, a, 1, ip, b, 1, info )
299 CALL chkxer( 'ZGBTRS', infot, nout, lerr, ok )
300 infot = 3
301 CALL zgbtrs( 'N', 1, -1, 0, 1, a, 1, ip, b, 1, info )
302 CALL chkxer( 'ZGBTRS', infot, nout, lerr, ok )
303 infot = 4
304 CALL zgbtrs( 'N', 1, 0, -1, 1, a, 1, ip, b, 1, info )
305 CALL chkxer( 'ZGBTRS', infot, nout, lerr, ok )
306 infot = 5
307 CALL zgbtrs( 'N', 1, 0, 0, -1, a, 1, ip, b, 1, info )
308 CALL chkxer( 'ZGBTRS', infot, nout, lerr, ok )
309 infot = 7
310 CALL zgbtrs( 'N', 2, 1, 1, 1, a, 3, ip, b, 2, info )
311 CALL chkxer( 'ZGBTRS', infot, nout, lerr, ok )
312 infot = 10
313 CALL zgbtrs( 'N', 2, 0, 0, 1, a, 1, ip, b, 1, info )
314 CALL chkxer( 'ZGBTRS', infot, nout, lerr, ok )
315*
316* ZGBRFS
317*
318 srnamt = 'ZGBRFS'
319 infot = 1
320 CALL zgbrfs( '/', 0, 0, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
321 $ r2, w, r, info )
322 CALL chkxer( 'ZGBRFS', infot, nout, lerr, ok )
323 infot = 2
324 CALL zgbrfs( 'N', -1, 0, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
325 $ r2, w, r, info )
326 CALL chkxer( 'ZGBRFS', infot, nout, lerr, ok )
327 infot = 3
328 CALL zgbrfs( 'N', 1, -1, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
329 $ r2, w, r, info )
330 CALL chkxer( 'ZGBRFS', infot, nout, lerr, ok )
331 infot = 4
332 CALL zgbrfs( 'N', 1, 0, -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
333 $ r2, w, r, info )
334 CALL chkxer( 'ZGBRFS', infot, nout, lerr, ok )
335 infot = 5
336 CALL zgbrfs( 'N', 1, 0, 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1,
337 $ r2, w, r, info )
338 CALL chkxer( 'ZGBRFS', infot, nout, lerr, ok )
339 infot = 7
340 CALL zgbrfs( 'N', 2, 1, 1, 1, a, 2, af, 4, ip, b, 2, x, 2, r1,
341 $ r2, w, r, info )
342 CALL chkxer( 'ZGBRFS', infot, nout, lerr, ok )
343 infot = 9
344 CALL zgbrfs( 'N', 2, 1, 1, 1, a, 3, af, 3, ip, b, 2, x, 2, r1,
345 $ r2, w, r, info )
346 CALL chkxer( 'ZGBRFS', infot, nout, lerr, ok )
347 infot = 12
348 CALL zgbrfs( 'N', 2, 0, 0, 1, a, 1, af, 1, ip, b, 1, x, 2, r1,
349 $ r2, w, r, info )
350 CALL chkxer( 'ZGBRFS', infot, nout, lerr, ok )
351 infot = 14
352 CALL zgbrfs( 'N', 2, 0, 0, 1, a, 1, af, 1, ip, b, 2, x, 1, r1,
353 $ r2, w, r, info )
354 CALL chkxer( 'ZGBRFS', infot, nout, lerr, ok )
355*
356* ZGBCON
357*
358 srnamt = 'ZGBCON'
359 infot = 1
360 CALL zgbcon( '/', 0, 0, 0, a, 1, ip, anrm, rcond, w, r, info )
361 CALL chkxer( 'ZGBCON', infot, nout, lerr, ok )
362 infot = 2
363 CALL zgbcon( '1', -1, 0, 0, a, 1, ip, anrm, rcond, w, r, info )
364 CALL chkxer( 'ZGBCON', infot, nout, lerr, ok )
365 infot = 3
366 CALL zgbcon( '1', 1, -1, 0, a, 1, ip, anrm, rcond, w, r, info )
367 CALL chkxer( 'ZGBCON', infot, nout, lerr, ok )
368 infot = 4
369 CALL zgbcon( '1', 1, 0, -1, a, 1, ip, anrm, rcond, w, r, info )
370 CALL chkxer( 'ZGBCON', infot, nout, lerr, ok )
371 infot = 6
372 CALL zgbcon( '1', 2, 1, 1, a, 3, ip, anrm, rcond, w, r, info )
373 CALL chkxer( 'ZGBCON', infot, nout, lerr, ok )
374*
375* ZGBEQU
376*
377 srnamt = 'ZGBEQU'
378 infot = 1
379 CALL zgbequ( -1, 0, 0, 0, a, 1, r1, r2, rcond, ccond, anrm,
380 $ info )
381 CALL chkxer( 'ZGBEQU', infot, nout, lerr, ok )
382 infot = 2
383 CALL zgbequ( 0, -1, 0, 0, a, 1, r1, r2, rcond, ccond, anrm,
384 $ info )
385 CALL chkxer( 'ZGBEQU', infot, nout, lerr, ok )
386 infot = 3
387 CALL zgbequ( 1, 1, -1, 0, a, 1, r1, r2, rcond, ccond, anrm,
388 $ info )
389 CALL chkxer( 'ZGBEQU', infot, nout, lerr, ok )
390 infot = 4
391 CALL zgbequ( 1, 1, 0, -1, a, 1, r1, r2, rcond, ccond, anrm,
392 $ info )
393 CALL chkxer( 'ZGBEQU', infot, nout, lerr, ok )
394 infot = 6
395 CALL zgbequ( 2, 2, 1, 1, a, 2, r1, r2, rcond, ccond, anrm,
396 $ info )
397 CALL chkxer( 'ZGBEQU', infot, nout, lerr, ok )
398 END IF
399*
400* Print a summary line.
401*
402 CALL alaesm( path, ok, nout )
403*
404 RETURN
405*
406* End of ZERRGE
407*
alaesm
subroutine alaesm(path, ok, nout)
ALAESM
Definition alaesm.f:63
zgbtf2
subroutine zgbtf2(m, n, kl, ku, ab, ldab, ipiv, info)
ZGBTF2 computes the LU factorization of a general band matrix using the unblocked version of the algo...
Definition zgbtf2.f:145
zgetf2
subroutine zgetf2(m, n, a, lda, ipiv, info)
ZGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row inter...
Definition zgetf2.f:108

◆ zerrgt()

subroutine zerrgt ( character*3 path,
integer nunit )

ZERRGT

Purpose:
!>
!> ZERRGT tests the error exits for the COMPLEX*16 tridiagonal
!> routines.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 54 of file zerrgt.f.

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX
69 parameter( nmax = 2 )
70* ..
71* .. Local Scalars ..
72 CHARACTER*2 C2
73 INTEGER I, INFO
74 DOUBLE PRECISION ANORM, RCOND
75* ..
76* .. Local Arrays ..
77 INTEGER IP( NMAX )
78 DOUBLE PRECISION D( NMAX ), DF( NMAX ), R1( NMAX ), R2( NMAX ),
79 $ RW( NMAX )
80 COMPLEX*16 B( NMAX ), DL( NMAX ), DLF( NMAX ), DU( NMAX ),
81 $ DU2( NMAX ), DUF( NMAX ), E( NMAX ),
82 $ EF( NMAX ), W( NMAX ), X( NMAX )
83* ..
84* .. External Functions ..
85 LOGICAL LSAMEN
86 EXTERNAL lsamen
87* ..
88* .. External Subroutines ..
89 EXTERNAL alaesm, chkxer, zgtcon, zgtrfs, zgttrf, zgttrs,
90 $ zptcon, zptrfs, zpttrf, zpttrs
91* ..
92* .. Scalars in Common ..
93 LOGICAL LERR, OK
94 CHARACTER*32 SRNAMT
95 INTEGER INFOT, NOUT
96* ..
97* .. Common blocks ..
98 COMMON / infoc / infot, nout, ok, lerr
99 COMMON / srnamc / srnamt
100* ..
101* .. Executable Statements ..
102*
103 nout = nunit
104 WRITE( nout, fmt = * )
105 c2 = path( 2: 3 )
106 DO 10 i = 1, nmax
107 d( i ) = 1.d0
108 e( i ) = 2.d0
109 dl( i ) = 3.d0
110 du( i ) = 4.d0
111 10 CONTINUE
112 anorm = 1.0d0
113 ok = .true.
114*
115 IF( lsamen( 2, c2, 'GT' ) ) THEN
116*
117* Test error exits for the general tridiagonal routines.
118*
119* ZGTTRF
120*
121 srnamt = 'ZGTTRF'
122 infot = 1
123 CALL zgttrf( -1, dl, e, du, du2, ip, info )
124 CALL chkxer( 'ZGTTRF', infot, nout, lerr, ok )
125*
126* ZGTTRS
127*
128 srnamt = 'ZGTTRS'
129 infot = 1
130 CALL zgttrs( '/', 0, 0, dl, e, du, du2, ip, x, 1, info )
131 CALL chkxer( 'ZGTTRS', infot, nout, lerr, ok )
132 infot = 2
133 CALL zgttrs( 'N', -1, 0, dl, e, du, du2, ip, x, 1, info )
134 CALL chkxer( 'ZGTTRS', infot, nout, lerr, ok )
135 infot = 3
136 CALL zgttrs( 'N', 0, -1, dl, e, du, du2, ip, x, 1, info )
137 CALL chkxer( 'ZGTTRS', infot, nout, lerr, ok )
138 infot = 10
139 CALL zgttrs( 'N', 2, 1, dl, e, du, du2, ip, x, 1, info )
140 CALL chkxer( 'ZGTTRS', infot, nout, lerr, ok )
141*
142* ZGTRFS
143*
144 srnamt = 'ZGTRFS'
145 infot = 1
146 CALL zgtrfs( '/', 0, 0, dl, e, du, dlf, ef, duf, du2, ip, b, 1,
147 $ x, 1, r1, r2, w, rw, info )
148 CALL chkxer( 'ZGTRFS', infot, nout, lerr, ok )
149 infot = 2
150 CALL zgtrfs( 'N', -1, 0, dl, e, du, dlf, ef, duf, du2, ip, b,
151 $ 1, x, 1, r1, r2, w, rw, info )
152 CALL chkxer( 'ZGTRFS', infot, nout, lerr, ok )
153 infot = 3
154 CALL zgtrfs( 'N', 0, -1, dl, e, du, dlf, ef, duf, du2, ip, b,
155 $ 1, x, 1, r1, r2, w, rw, info )
156 CALL chkxer( 'ZGTRFS', infot, nout, lerr, ok )
157 infot = 13
158 CALL zgtrfs( 'N', 2, 1, dl, e, du, dlf, ef, duf, du2, ip, b, 1,
159 $ x, 2, r1, r2, w, rw, info )
160 CALL chkxer( 'ZGTRFS', infot, nout, lerr, ok )
161 infot = 15
162 CALL zgtrfs( 'N', 2, 1, dl, e, du, dlf, ef, duf, du2, ip, b, 2,
163 $ x, 1, r1, r2, w, rw, info )
164 CALL chkxer( 'ZGTRFS', infot, nout, lerr, ok )
165*
166* ZGTCON
167*
168 srnamt = 'ZGTCON'
169 infot = 1
170 CALL zgtcon( '/', 0, dl, e, du, du2, ip, anorm, rcond, w,
171 $ info )
172 CALL chkxer( 'ZGTCON', infot, nout, lerr, ok )
173 infot = 2
174 CALL zgtcon( 'I', -1, dl, e, du, du2, ip, anorm, rcond, w,
175 $ info )
176 CALL chkxer( 'ZGTCON', infot, nout, lerr, ok )
177 infot = 8
178 CALL zgtcon( 'I', 0, dl, e, du, du2, ip, -anorm, rcond, w,
179 $ info )
180 CALL chkxer( 'ZGTCON', infot, nout, lerr, ok )
181*
182 ELSE IF( lsamen( 2, c2, 'PT' ) ) THEN
183*
184* Test error exits for the positive definite tridiagonal
185* routines.
186*
187* ZPTTRF
188*
189 srnamt = 'ZPTTRF'
190 infot = 1
191 CALL zpttrf( -1, d, e, info )
192 CALL chkxer( 'ZPTTRF', infot, nout, lerr, ok )
193*
194* ZPTTRS
195*
196 srnamt = 'ZPTTRS'
197 infot = 1
198 CALL zpttrs( '/', 1, 0, d, e, x, 1, info )
199 CALL chkxer( 'ZPTTRS', infot, nout, lerr, ok )
200 infot = 2
201 CALL zpttrs( 'U', -1, 0, d, e, x, 1, info )
202 CALL chkxer( 'ZPTTRS', infot, nout, lerr, ok )
203 infot = 3
204 CALL zpttrs( 'U', 0, -1, d, e, x, 1, info )
205 CALL chkxer( 'ZPTTRS', infot, nout, lerr, ok )
206 infot = 7
207 CALL zpttrs( 'U', 2, 1, d, e, x, 1, info )
208 CALL chkxer( 'ZPTTRS', infot, nout, lerr, ok )
209*
210* ZPTRFS
211*
212 srnamt = 'ZPTRFS'
213 infot = 1
214 CALL zptrfs( '/', 1, 0, d, e, df, ef, b, 1, x, 1, r1, r2, w,
215 $ rw, info )
216 CALL chkxer( 'ZPTRFS', infot, nout, lerr, ok )
217 infot = 2
218 CALL zptrfs( 'U', -1, 0, d, e, df, ef, b, 1, x, 1, r1, r2, w,
219 $ rw, info )
220 CALL chkxer( 'ZPTRFS', infot, nout, lerr, ok )
221 infot = 3
222 CALL zptrfs( 'U', 0, -1, d, e, df, ef, b, 1, x, 1, r1, r2, w,
223 $ rw, info )
224 CALL chkxer( 'ZPTRFS', infot, nout, lerr, ok )
225 infot = 9
226 CALL zptrfs( 'U', 2, 1, d, e, df, ef, b, 1, x, 2, r1, r2, w,
227 $ rw, info )
228 CALL chkxer( 'ZPTRFS', infot, nout, lerr, ok )
229 infot = 11
230 CALL zptrfs( 'U', 2, 1, d, e, df, ef, b, 2, x, 1, r1, r2, w,
231 $ rw, info )
232 CALL chkxer( 'ZPTRFS', infot, nout, lerr, ok )
233*
234* ZPTCON
235*
236 srnamt = 'ZPTCON'
237 infot = 1
238 CALL zptcon( -1, d, e, anorm, rcond, rw, info )
239 CALL chkxer( 'ZPTCON', infot, nout, lerr, ok )
240 infot = 4
241 CALL zptcon( 0, d, e, -anorm, rcond, rw, info )
242 CALL chkxer( 'ZPTCON', infot, nout, lerr, ok )
243 END IF
244*
245* Print a summary line.
246*
247 CALL alaesm( path, ok, nout )
248*
249 RETURN
250*
251* End of ZERRGT
252*

◆ zerrhe()

subroutine zerrhe ( character*3 path,
integer nunit )

ZERRHE

ZERRHEX

Purpose:
!>
!> ZERRHE tests the error exits for the COMPLEX*16 routines
!> for Hermitian indefinite matrices.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Purpose:
!>
!> ZERRHE tests the error exits for the COMPLEX*16 routines
!> for Hermitian indefinite matrices.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise zerrhe.f defines this subroutine.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 54 of file zerrhe.f.

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67*
68* .. Parameters ..
69 INTEGER NMAX
70 parameter( nmax = 4 )
71* ..
72* .. Local Scalars ..
73 CHARACTER*2 C2
74 INTEGER I, INFO, J
75 DOUBLE PRECISION ANRM, RCOND
76* ..
77* .. Local Arrays ..
78 INTEGER IP( NMAX )
79 DOUBLE PRECISION R( NMAX ), R1( NMAX ), R2( NMAX )
80 COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
81 $ E( NMAX ), W( 2*NMAX ), X( NMAX )
82* ..
83* .. External Functions ..
84 LOGICAL LSAMEN
85 EXTERNAL lsamen
86* ..
87* .. External Subroutines ..
88 EXTERNAL alaesm, chkxer, zhecon, zhecon_3, zhecon_rook,
89 $ zherfs, zhetf2, zhetf2_rk, zhetf2_rook, zhetrf,
90 $ zhetrf_rk, zhetrf_rook, zhetrf_aa,
91 $ zhetrf_aa_2stage, zhetri,
92 $ zhetri_3, zhetri_3x, zhetri_rook, zhetri2,
93 $ zhetri2x, zhetrs, zhetrs_3, zhetrs_rook,
94 $ zhetrs_aa, zhetrs_aa_2stage, zhpcon, zhprfs,
95 $ zhptrf, zhptri, zhptrs
96* ..
97* .. Scalars in Common ..
98 LOGICAL LERR, OK
99 CHARACTER*32 SRNAMT
100 INTEGER INFOT, NOUT
101* ..
102* .. Common blocks ..
103 COMMON / infoc / infot, nout, ok, lerr
104 COMMON / srnamc / srnamt
105* ..
106* .. Intrinsic Functions ..
107 INTRINSIC dble, dcmplx
108* ..
109* .. Executable Statements ..
110*
111 nout = nunit
112 WRITE( nout, fmt = * )
113 c2 = path( 2: 3 )
114*
115* Set the variables to innocuous values.
116*
117 DO 20 j = 1, nmax
118 DO 10 i = 1, nmax
119 a( i, j ) = dcmplx( 1.d0 / dble( i+j ),
120 $ -1.d0 / dble( i+j ) )
121 af( i, j ) = dcmplx( 1.d0 / dble( i+j ),
122 $ -1.d0 / dble( i+j ) )
123 10 CONTINUE
124 b( j ) = 0.d0
125 e( j ) = 0.d0
126 r1( j ) = 0.d0
127 r2( j ) = 0.d0
128 w( j ) = 0.d0
129 x( j ) = 0.d0
130 ip( j ) = j
131 20 CONTINUE
132 anrm = 1.0d0
133 ok = .true.
134*
135 IF( lsamen( 2, c2, 'HE' ) ) THEN
136*
137* Test error exits of the routines that use factorization
138* of a Hermitian indefinite matrix with patrial
139* (Bunch-Kaufman) diagonal pivoting method.
140*
141* ZHETRF
142*
143 srnamt = 'ZHETRF'
144 infot = 1
145 CALL zhetrf( '/', 0, a, 1, ip, w, 1, info )
146 CALL chkxer( 'ZHETRF', infot, nout, lerr, ok )
147 infot = 2
148 CALL zhetrf( 'U', -1, a, 1, ip, w, 1, info )
149 CALL chkxer( 'ZHETRF', infot, nout, lerr, ok )
150 infot = 4
151 CALL zhetrf( 'U', 2, a, 1, ip, w, 4, info )
152 CALL chkxer( 'ZHETRF', infot, nout, lerr, ok )
153 infot = 7
154 CALL zhetrf( 'U', 0, a, 1, ip, w, 0, info )
155 CALL chkxer( 'ZHETRF', infot, nout, lerr, ok )
156 infot = 7
157 CALL zhetrf( 'U', 0, a, 1, ip, w, -2, info )
158 CALL chkxer( 'ZHETRF', infot, nout, lerr, ok )
159*
160* ZHETF2
161*
162 srnamt = 'ZHETF2'
163 infot = 1
164 CALL zhetf2( '/', 0, a, 1, ip, info )
165 CALL chkxer( 'ZHETF2', infot, nout, lerr, ok )
166 infot = 2
167 CALL zhetf2( 'U', -1, a, 1, ip, info )
168 CALL chkxer( 'ZHETF2', infot, nout, lerr, ok )
169 infot = 4
170 CALL zhetf2( 'U', 2, a, 1, ip, info )
171 CALL chkxer( 'ZHETF2', infot, nout, lerr, ok )
172*
173* ZHETRI
174*
175 srnamt = 'ZHETRI'
176 infot = 1
177 CALL zhetri( '/', 0, a, 1, ip, w, info )
178 CALL chkxer( 'ZHETRI', infot, nout, lerr, ok )
179 infot = 2
180 CALL zhetri( 'U', -1, a, 1, ip, w, info )
181 CALL chkxer( 'ZHETRI', infot, nout, lerr, ok )
182 infot = 4
183 CALL zhetri( 'U', 2, a, 1, ip, w, info )
184 CALL chkxer( 'ZHETRI', infot, nout, lerr, ok )
185*
186* ZHETRI2
187*
188 srnamt = 'ZHETRI2'
189 infot = 1
190 CALL zhetri2( '/', 0, a, 1, ip, w, 1, info )
191 CALL chkxer( 'ZHETRI2', infot, nout, lerr, ok )
192 infot = 2
193 CALL zhetri2( 'U', -1, a, 1, ip, w, 1, info )
194 CALL chkxer( 'ZHETRI2', infot, nout, lerr, ok )
195 infot = 4
196 CALL zhetri2( 'U', 2, a, 1, ip, w, 1, info )
197 CALL chkxer( 'ZHETRI2', infot, nout, lerr, ok )
198*
199* ZHETRI2X
200*
201 srnamt = 'ZHETRI2X'
202 infot = 1
203 CALL zhetri2x( '/', 0, a, 1, ip, w, 1, info )
204 CALL chkxer( 'ZHETRI2X', infot, nout, lerr, ok )
205 infot = 2
206 CALL zhetri2x( 'U', -1, a, 1, ip, w, 1, info )
207 CALL chkxer( 'ZHETRI2X', infot, nout, lerr, ok )
208 infot = 4
209 CALL zhetri2x( 'U', 2, a, 1, ip, w, 1, info )
210 CALL chkxer( 'ZHETRI2X', infot, nout, lerr, ok )
211*
212* ZHETRS
213*
214 srnamt = 'ZHETRS'
215 infot = 1
216 CALL zhetrs( '/', 0, 0, a, 1, ip, b, 1, info )
217 CALL chkxer( 'ZHETRS', infot, nout, lerr, ok )
218 infot = 2
219 CALL zhetrs( 'U', -1, 0, a, 1, ip, b, 1, info )
220 CALL chkxer( 'ZHETRS', infot, nout, lerr, ok )
221 infot = 3
222 CALL zhetrs( 'U', 0, -1, a, 1, ip, b, 1, info )
223 CALL chkxer( 'ZHETRS', infot, nout, lerr, ok )
224 infot = 5
225 CALL zhetrs( 'U', 2, 1, a, 1, ip, b, 2, info )
226 CALL chkxer( 'ZHETRS', infot, nout, lerr, ok )
227 infot = 8
228 CALL zhetrs( 'U', 2, 1, a, 2, ip, b, 1, info )
229 CALL chkxer( 'ZHETRS', infot, nout, lerr, ok )
230*
231* ZHERFS
232*
233 srnamt = 'ZHERFS'
234 infot = 1
235 CALL zherfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
236 $ r, info )
237 CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
238 infot = 2
239 CALL zherfs( 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
240 $ w, r, info )
241 CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
242 infot = 3
243 CALL zherfs( 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
244 $ w, r, info )
245 CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
246 infot = 5
247 CALL zherfs( 'U', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
248 $ r, info )
249 CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
250 infot = 7
251 CALL zherfs( 'U', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
252 $ r, info )
253 CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
254 infot = 10
255 CALL zherfs( 'U', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
256 $ r, info )
257 CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
258 infot = 12
259 CALL zherfs( 'U', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
260 $ r, info )
261 CALL chkxer( 'ZHERFS', infot, nout, lerr, ok )
262*
263* ZHECON
264*
265 srnamt = 'ZHECON'
266 infot = 1
267 CALL zhecon( '/', 0, a, 1, ip, anrm, rcond, w, info )
268 CALL chkxer( 'ZHECON', infot, nout, lerr, ok )
269 infot = 2
270 CALL zhecon( 'U', -1, a, 1, ip, anrm, rcond, w, info )
271 CALL chkxer( 'ZHECON', infot, nout, lerr, ok )
272 infot = 4
273 CALL zhecon( 'U', 2, a, 1, ip, anrm, rcond, w, info )
274 CALL chkxer( 'ZHECON', infot, nout, lerr, ok )
275 infot = 6
276 CALL zhecon( 'U', 1, a, 1, ip, -anrm, rcond, w, info )
277 CALL chkxer( 'ZHECON', infot, nout, lerr, ok )
278*
279 ELSE IF( lsamen( 2, c2, 'HR' ) ) THEN
280*
281* Test error exits of the routines that use factorization
282* of a Hermitian indefinite matrix with rook
283* (bounded Bunch-Kaufman) diagonal pivoting method.
284*
285* ZHETRF_ROOK
286*
287 srnamt = 'ZHETRF_ROOK'
288 infot = 1
289 CALL zhetrf_rook( '/', 0, a, 1, ip, w, 1, info )
290 CALL chkxer( 'ZHETRF_ROOK', infot, nout, lerr, ok )
291 infot = 2
292 CALL zhetrf_rook( 'U', -1, a, 1, ip, w, 1, info )
293 CALL chkxer( 'ZHETRF_ROOK', infot, nout, lerr, ok )
294 infot = 4
295 CALL zhetrf_rook( 'U', 2, a, 1, ip, w, 4, info )
296 CALL chkxer( 'ZHETRF_ROOK', infot, nout, lerr, ok )
297 infot = 7
298 CALL zhetrf_rook( 'U', 0, a, 1, ip, w, 0, info )
299 CALL chkxer( 'ZHETRF_ROOK', infot, nout, lerr, ok )
300 infot = 7
301 CALL zhetrf_rook( 'U', 0, a, 1, ip, w, -2, info )
302 CALL chkxer( 'ZHETRF_ROOK', infot, nout, lerr, ok )
303*
304* ZHETF2_ROOK
305*
306 srnamt = 'ZHETF2_ROOK'
307 infot = 1
308 CALL zhetf2_rook( '/', 0, a, 1, ip, info )
309 CALL chkxer( 'ZHETF2_ROOK', infot, nout, lerr, ok )
310 infot = 2
311 CALL zhetf2_rook( 'U', -1, a, 1, ip, info )
312 CALL chkxer( 'ZHETF2_ROOK', infot, nout, lerr, ok )
313 infot = 4
314 CALL zhetf2_rook( 'U', 2, a, 1, ip, info )
315 CALL chkxer( 'ZHETF2_ROOK', infot, nout, lerr, ok )
316*
317* ZHETRI_ROOK
318*
319 srnamt = 'ZHETRI_ROOK'
320 infot = 1
321 CALL zhetri_rook( '/', 0, a, 1, ip, w, info )
322 CALL chkxer( 'ZHETRI_ROOK', infot, nout, lerr, ok )
323 infot = 2
324 CALL zhetri_rook( 'U', -1, a, 1, ip, w, info )
325 CALL chkxer( 'ZHETRI_ROOK', infot, nout, lerr, ok )
326 infot = 4
327 CALL zhetri_rook( 'U', 2, a, 1, ip, w, info )
328 CALL chkxer( 'ZHETRI_ROOK', infot, nout, lerr, ok )
329*
330* ZHETRS_ROOK
331*
332 srnamt = 'ZHETRS_ROOK'
333 infot = 1
334 CALL zhetrs_rook( '/', 0, 0, a, 1, ip, b, 1, info )
335 CALL chkxer( 'ZHETRS_ROOK', infot, nout, lerr, ok )
336 infot = 2
337 CALL zhetrs_rook( 'U', -1, 0, a, 1, ip, b, 1, info )
338 CALL chkxer( 'ZHETRS_ROOK', infot, nout, lerr, ok )
339 infot = 3
340 CALL zhetrs_rook( 'U', 0, -1, a, 1, ip, b, 1, info )
341 CALL chkxer( 'ZHETRS_ROOK', infot, nout, lerr, ok )
342 infot = 5
343 CALL zhetrs_rook( 'U', 2, 1, a, 1, ip, b, 2, info )
344 CALL chkxer( 'ZHETRS_ROOK', infot, nout, lerr, ok )
345 infot = 8
346 CALL zhetrs_rook( 'U', 2, 1, a, 2, ip, b, 1, info )
347 CALL chkxer( 'ZHETRS_ROOK', infot, nout, lerr, ok )
348*
349* ZHECON_ROOK
350*
351 srnamt = 'ZHECON_ROOK'
352 infot = 1
353 CALL zhecon_rook( '/', 0, a, 1, ip, anrm, rcond, w, info )
354 CALL chkxer( 'ZHECON_ROOK', infot, nout, lerr, ok )
355 infot = 2
356 CALL zhecon_rook( 'U', -1, a, 1, ip, anrm, rcond, w, info )
357 CALL chkxer( 'ZHECON_ROOK', infot, nout, lerr, ok )
358 infot = 4
359 CALL zhecon_rook( 'U', 2, a, 1, ip, anrm, rcond, w, info )
360 CALL chkxer( 'ZHECON_ROOK', infot, nout, lerr, ok )
361 infot = 6
362 CALL zhecon_rook( 'U', 1, a, 1, ip, -anrm, rcond, w, info )
363 CALL chkxer( 'ZHECON_ROOK', infot, nout, lerr, ok )
364*
365 ELSE IF( lsamen( 2, c2, 'HK' ) ) THEN
366*
367* Test error exits of the routines that use factorization
368* of a symmetric indefinite matrix with rook
369* (bounded Bunch-Kaufman) pivoting with the new storage
370* format for factors L ( or U) and D.
371*
372* L (or U) is stored in A, diagonal of D is stored on the
373* diagonal of A, subdiagonal of D is stored in a separate array E.
374*
375* ZHETRF_RK
376*
377 srnamt = 'ZHETRF_RK'
378 infot = 1
379 CALL zhetrf_rk( '/', 0, a, 1, e, ip, w, 1, info )
380 CALL chkxer( 'ZHETRF_RK', infot, nout, lerr, ok )
381 infot = 2
382 CALL zhetrf_rk( 'U', -1, a, 1, e, ip, w, 1, info )
383 CALL chkxer( 'ZHETRF_RK', infot, nout, lerr, ok )
384 infot = 4
385 CALL zhetrf_rk( 'U', 2, a, 1, e, ip, w, 4, info )
386 CALL chkxer( 'ZHETRF_RK', infot, nout, lerr, ok )
387 infot = 8
388 CALL zhetrf_rk( 'U', 0, a, 1, e, ip, w, 0, info )
389 CALL chkxer( 'ZHETRF_RK', infot, nout, lerr, ok )
390 infot = 8
391 CALL zhetrf_rk( 'U', 0, a, 1, e, ip, w, -2, info )
392 CALL chkxer( 'ZHETRF_RK', infot, nout, lerr, ok )
393*
394* ZHETF2_RK
395*
396 srnamt = 'ZHETF2_RK'
397 infot = 1
398 CALL zhetf2_rk( '/', 0, a, 1, e, ip, info )
399 CALL chkxer( 'ZHETF2_RK', infot, nout, lerr, ok )
400 infot = 2
401 CALL zhetf2_rk( 'U', -1, a, 1, e, ip, info )
402 CALL chkxer( 'ZHETF2_RK', infot, nout, lerr, ok )
403 infot = 4
404 CALL zhetf2_rk( 'U', 2, a, 1, e, ip, info )
405 CALL chkxer( 'ZHETF2_RK', infot, nout, lerr, ok )
406*
407* ZHETRI_3
408*
409 srnamt = 'ZHETRI_3'
410 infot = 1
411 CALL zhetri_3( '/', 0, a, 1, e, ip, w, 1, info )
412 CALL chkxer( 'ZHETRI_3', infot, nout, lerr, ok )
413 infot = 2
414 CALL zhetri_3( 'U', -1, a, 1, e, ip, w, 1, info )
415 CALL chkxer( 'ZHETRI_3', infot, nout, lerr, ok )
416 infot = 4
417 CALL zhetri_3( 'U', 2, a, 1, e, ip, w, 1, info )
418 CALL chkxer( 'ZHETRI_3', infot, nout, lerr, ok )
419 infot = 8
420 CALL zhetri_3( 'U', 0, a, 1, e, ip, w, 0, info )
421 CALL chkxer( 'ZHETRI_3', infot, nout, lerr, ok )
422 infot = 8
423 CALL zhetri_3( 'U', 0, a, 1, e, ip, w, -2, info )
424 CALL chkxer( 'ZHETRI_3', infot, nout, lerr, ok )
425*
426* ZHETRI_3X
427*
428 srnamt = 'ZHETRI_3X'
429 infot = 1
430 CALL zhetri_3x( '/', 0, a, 1, e, ip, w, 1, info )
431 CALL chkxer( 'ZHETRI_3X', infot, nout, lerr, ok )
432 infot = 2
433 CALL zhetri_3x( 'U', -1, a, 1, e, ip, w, 1, info )
434 CALL chkxer( 'ZHETRI_3X', infot, nout, lerr, ok )
435 infot = 4
436 CALL zhetri_3x( 'U', 2, a, 1, e, ip, w, 1, info )
437 CALL chkxer( 'ZHETRI_3X', infot, nout, lerr, ok )
438*
439* ZHETRS_3
440*
441 srnamt = 'ZHETRS_3'
442 infot = 1
443 CALL zhetrs_3( '/', 0, 0, a, 1, e, ip, b, 1, info )
444 CALL chkxer( 'ZHETRS_3', infot, nout, lerr, ok )
445 infot = 2
446 CALL zhetrs_3( 'U', -1, 0, a, 1, e, ip, b, 1, info )
447 CALL chkxer( 'ZHETRS_3', infot, nout, lerr, ok )
448 infot = 3
449 CALL zhetrs_3( 'U', 0, -1, a, 1, e, ip, b, 1, info )
450 CALL chkxer( 'ZHETRS_3', infot, nout, lerr, ok )
451 infot = 5
452 CALL zhetrs_3( 'U', 2, 1, a, 1, e, ip, b, 2, info )
453 CALL chkxer( 'ZHETRS_3', infot, nout, lerr, ok )
454 infot = 9
455 CALL zhetrs_3( 'U', 2, 1, a, 2, e, ip, b, 1, info )
456 CALL chkxer( 'ZHETRS_3', infot, nout, lerr, ok )
457*
458* ZHECON_3
459*
460 srnamt = 'ZHECON_3'
461 infot = 1
462 CALL zhecon_3( '/', 0, a, 1, e, ip, anrm, rcond, w, info )
463 CALL chkxer( 'ZHECON_3', infot, nout, lerr, ok )
464 infot = 2
465 CALL zhecon_3( 'U', -1, a, 1, e, ip, anrm, rcond, w, info )
466 CALL chkxer( 'ZHECON_3', infot, nout, lerr, ok )
467 infot = 4
468 CALL zhecon_3( 'U', 2, a, 1, e, ip, anrm, rcond, w, info )
469 CALL chkxer( 'ZHECON_3', infot, nout, lerr, ok )
470 infot = 7
471 CALL zhecon_3( 'U', 1, a, 1, e, ip, -1.0d0, rcond, w, info)
472 CALL chkxer( 'ZHECON_3', infot, nout, lerr, ok )
473*
474* Test error exits of the routines that use factorization
475* of a Hermitian indefinite matrix with Aasen's algorithm.
476*
477 ELSE IF( lsamen( 2, c2, 'HA' ) ) THEN
478*
479* ZHETRF_AA
480*
481 srnamt = 'ZHETRF_AA'
482 infot = 1
483 CALL zhetrf_aa( '/', 0, a, 1, ip, w, 1, info )
484 CALL chkxer( 'ZHETRF_AA', infot, nout, lerr, ok )
485 infot = 2
486 CALL zhetrf_aa( 'U', -1, a, 1, ip, w, 1, info )
487 CALL chkxer( 'ZHETRF_AA', infot, nout, lerr, ok )
488 infot = 4
489 CALL zhetrf_aa( 'U', 2, a, 1, ip, w, 4, info )
490 CALL chkxer( 'ZHETRF_AA', infot, nout, lerr, ok )
491 infot = 7
492 CALL zhetrf_aa( 'U', 0, a, 1, ip, w, 0, info )
493 CALL chkxer( 'ZHETRF_AA', infot, nout, lerr, ok )
494 infot = 7
495 CALL zhetrf_aa( 'U', 0, a, 1, ip, w, -2, info )
496 CALL chkxer( 'ZHETRF_AA', infot, nout, lerr, ok )
497*
498* ZHETRS_AA
499*
500 srnamt = 'ZHETRS_AA'
501 infot = 1
502 CALL zhetrs_aa( '/', 0, 0, a, 1, ip, b, 1, w, 1, info )
503 CALL chkxer( 'ZHETRS_AA', infot, nout, lerr, ok )
504 infot = 2
505 CALL zhetrs_aa( 'U', -1, 0, a, 1, ip, b, 1, w, 1, info )
506 CALL chkxer( 'ZHETRS_AA', infot, nout, lerr, ok )
507 infot = 3
508 CALL zhetrs_aa( 'U', 0, -1, a, 1, ip, b, 1, w, 1, info )
509 CALL chkxer( 'ZHETRS_AA', infot, nout, lerr, ok )
510 infot = 5
511 CALL zhetrs_aa( 'U', 2, 1, a, 1, ip, b, 2, w, 1, info )
512 CALL chkxer( 'ZHETRS_AA', infot, nout, lerr, ok )
513 infot = 8
514 CALL zhetrs_aa( 'U', 2, 1, a, 2, ip, b, 1, w, 1, info )
515 CALL chkxer( 'ZHETRS_AA', infot, nout, lerr, ok )
516 infot = 10
517 CALL zhetrs_aa( 'U', 0, 1, a, 1, ip, b, 1, w, 0, info )
518 CALL chkxer( 'ZHETRS_AA', infot, nout, lerr, ok )
519 infot = 10
520 CALL zhetrs_aa( 'U', 0, 1, a, 1, ip, b, 1, w, -2, info )
521 CALL chkxer( 'ZHETRS_AA', infot, nout, lerr, ok )
522*
523 ELSE IF( lsamen( 2, c2, 'S2' ) ) THEN
524*
525* Test error exits of the routines that use factorization
526* of a symmetric indefinite matrix with Aasen's algorithm.
527*
528* ZHETRF_AA_2STAGE
529*
530 srnamt = 'ZHETRF_AA_2STAGE'
531 infot = 1
532 CALL zhetrf_aa_2stage( '/', 0, a, 1, a, 1, ip, ip, w, 1,
533 $ info )
534 CALL chkxer( 'ZHETRF_AA_2STAGE', infot, nout, lerr, ok )
535 infot = 2
536 CALL zhetrf_aa_2stage( 'U', -1, a, 1, a, 1, ip, ip, w, 1,
537 $ info )
538 CALL chkxer( 'ZHETRF_AA_2STAGE', infot, nout, lerr, ok )
539 infot = 4
540 CALL zhetrf_aa_2stage( 'U', 2, a, 1, a, 2, ip, ip, w, 1,
541 $ info )
542 CALL chkxer( 'ZHETRF_AA_2STAGE', infot, nout, lerr, ok )
543 infot = 6
544 CALL zhetrf_aa_2stage( 'U', 2, a, 2, a, 1, ip, ip, w, 1,
545 $ info )
546 CALL chkxer( 'ZHETRF_AA_2STAGE', infot, nout, lerr, ok )
547 infot = 10
548 CALL zhetrf_aa_2stage( 'U', 2, a, 2, a, 8, ip, ip, w, 0,
549 $ info )
550 CALL chkxer( 'ZHETRF_AA_2STAGE', infot, nout, lerr, ok )
551*
552* ZHETRS_AA_2STAGE
553*
554 srnamt = 'ZHETRS_AA_2STAGE'
555 infot = 1
556 CALL zhetrs_aa_2stage( '/', 0, 0, a, 1, a, 1, ip, ip,
557 $ b, 1, info )
558 CALL chkxer( 'ZHETRS_AA_2STAGE', infot, nout, lerr, ok )
559 infot = 2
560 CALL zhetrs_aa_2stage( 'U', -1, 0, a, 1, a, 1, ip, ip,
561 $ b, 1, info )
562 CALL chkxer( 'ZHETRS_AA_2STAGE', infot, nout, lerr, ok )
563 infot = 3
564 CALL zhetrs_aa_2stage( 'U', 0, -1, a, 1, a, 1, ip, ip,
565 $ b, 1, info )
566 CALL chkxer( 'ZHETRS_AA_2STAGE', infot, nout, lerr, ok )
567 infot = 5
568 CALL zhetrs_aa_2stage( 'U', 2, 1, a, 1, a, 1, ip, ip,
569 $ b, 1, info )
570 CALL chkxer( 'ZHETRS_AA_2STAGE', infot, nout, lerr, ok )
571 infot = 7
572 CALL zhetrs_aa_2stage( 'U', 2, 1, a, 2, a, 1, ip, ip,
573 $ b, 1, info )
574 CALL chkxer( 'ZHETRS_AA_2STAGE', infot, nout, lerr, ok )
575 infot = 11
576 CALL zhetrs_aa_2stage( 'U', 2, 1, a, 2, a, 8, ip, ip,
577 $ b, 1, info )
578 CALL chkxer( 'ZHETRS_AA_STAGE', infot, nout, lerr, ok )
579*
580 ELSE IF( lsamen( 2, c2, 'HP' ) ) THEN
581*
582* Test error exits of the routines that use factorization
583* of a Hermitian indefinite packed matrix with patrial
584* (Bunch-Kaufman) diagonal pivoting method.
585*
586* ZHPTRF
587*
588 srnamt = 'ZHPTRF'
589 infot = 1
590 CALL zhptrf( '/', 0, a, ip, info )
591 CALL chkxer( 'ZHPTRF', infot, nout, lerr, ok )
592 infot = 2
593 CALL zhptrf( 'U', -1, a, ip, info )
594 CALL chkxer( 'ZHPTRF', infot, nout, lerr, ok )
595*
596* ZHPTRI
597*
598 srnamt = 'ZHPTRI'
599 infot = 1
600 CALL zhptri( '/', 0, a, ip, w, info )
601 CALL chkxer( 'ZHPTRI', infot, nout, lerr, ok )
602 infot = 2
603 CALL zhptri( 'U', -1, a, ip, w, info )
604 CALL chkxer( 'ZHPTRI', infot, nout, lerr, ok )
605*
606* ZHPTRS
607*
608 srnamt = 'ZHPTRS'
609 infot = 1
610 CALL zhptrs( '/', 0, 0, a, ip, b, 1, info )
611 CALL chkxer( 'ZHPTRS', infot, nout, lerr, ok )
612 infot = 2
613 CALL zhptrs( 'U', -1, 0, a, ip, b, 1, info )
614 CALL chkxer( 'ZHPTRS', infot, nout, lerr, ok )
615 infot = 3
616 CALL zhptrs( 'U', 0, -1, a, ip, b, 1, info )
617 CALL chkxer( 'ZHPTRS', infot, nout, lerr, ok )
618 infot = 7
619 CALL zhptrs( 'U', 2, 1, a, ip, b, 1, info )
620 CALL chkxer( 'ZHPTRS', infot, nout, lerr, ok )
621*
622* ZHPRFS
623*
624 srnamt = 'ZHPRFS'
625 infot = 1
626 CALL zhprfs( '/', 0, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
627 $ info )
628 CALL chkxer( 'ZHPRFS', infot, nout, lerr, ok )
629 infot = 2
630 CALL zhprfs( 'U', -1, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
631 $ info )
632 CALL chkxer( 'ZHPRFS', infot, nout, lerr, ok )
633 infot = 3
634 CALL zhprfs( 'U', 0, -1, a, af, ip, b, 1, x, 1, r1, r2, w, r,
635 $ info )
636 CALL chkxer( 'ZHPRFS', infot, nout, lerr, ok )
637 infot = 8
638 CALL zhprfs( 'U', 2, 1, a, af, ip, b, 1, x, 2, r1, r2, w, r,
639 $ info )
640 CALL chkxer( 'ZHPRFS', infot, nout, lerr, ok )
641 infot = 10
642 CALL zhprfs( 'U', 2, 1, a, af, ip, b, 2, x, 1, r1, r2, w, r,
643 $ info )
644 CALL chkxer( 'ZHPRFS', infot, nout, lerr, ok )
645*
646* ZHPCON
647*
648 srnamt = 'ZHPCON'
649 infot = 1
650 CALL zhpcon( '/', 0, a, ip, anrm, rcond, w, info )
651 CALL chkxer( 'ZHPCON', infot, nout, lerr, ok )
652 infot = 2
653 CALL zhpcon( 'U', -1, a, ip, anrm, rcond, w, info )
654 CALL chkxer( 'ZHPCON', infot, nout, lerr, ok )
655 infot = 5
656 CALL zhpcon( 'U', 1, a, ip, -anrm, rcond, w, info )
657 CALL chkxer( 'ZHPCON', infot, nout, lerr, ok )
658 END IF
659*
660* Print a summary line.
661*
662 CALL alaesm( path, ok, nout )
663*
664 RETURN
665*
666* End of ZERRHE
667*
zhetri_3x
subroutine zhetri_3x(uplo, n, a, lda, e, ipiv, work, nb, info)
ZHETRI_3X
Definition zhetri_3x.f:159
zhetf2_rook
subroutine zhetf2_rook(uplo, n, a, lda, ipiv, info)
ZHETF2_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bun...
Definition zhetf2_rook.f:194
zhetf2
subroutine zhetf2(uplo, n, a, lda, ipiv, info)
ZHETF2 computes the factorization of a complex Hermitian matrix, using the diagonal pivoting method (...
Definition zhetf2.f:191
zhetri
subroutine zhetri(uplo, n, a, lda, ipiv, work, info)
ZHETRI
Definition zhetri.f:114
zhetf2_rk
subroutine zhetf2_rk(uplo, n, a, lda, e, ipiv, info)
ZHETF2_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch...
Definition zhetf2_rk.f:241
zhetri2x
subroutine zhetri2x(uplo, n, a, lda, ipiv, work, nb, info)
ZHETRI2X
Definition zhetri2x.f:120

◆ zerrlq()

subroutine zerrlq ( character*3 path,
integer nunit )

ZERRLQ

Purpose:
!>
!> ZERRLQ tests the error exits for the COMPLEX*16 routines
!> that use the LQ decomposition of a general matrix.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 54 of file zerrlq.f.

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX
69 parameter( nmax = 2 )
70* ..
71* .. Local Scalars ..
72 INTEGER I, INFO, J
73* ..
74* .. Local Arrays ..
75 COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
76 $ W( NMAX ), X( NMAX )
77* ..
78* .. External Subroutines ..
79 EXTERNAL alaesm, chkxer, zgelq2, zgelqf, zgelqs, zungl2,
80 $ zunglq, zunml2, zunmlq
81* ..
82* .. Scalars in Common ..
83 LOGICAL LERR, OK
84 CHARACTER*32 SRNAMT
85 INTEGER INFOT, NOUT
86* ..
87* .. Common blocks ..
88 COMMON / infoc / infot, nout, ok, lerr
89 COMMON / srnamc / srnamt
90* ..
91* .. Intrinsic Functions ..
92 INTRINSIC dble, dcmplx
93* ..
94* .. Executable Statements ..
95*
96 nout = nunit
97 WRITE( nout, fmt = * )
98*
99* Set the variables to innocuous values.
100*
101 DO 20 j = 1, nmax
102 DO 10 i = 1, nmax
103 a( i, j ) = dcmplx( 1.d0 / dble( i+j ),
104 $ -1.d0 / dble( i+j ) )
105 af( i, j ) = dcmplx( 1.d0 / dble( i+j ),
106 $ -1.d0 / dble( i+j ) )
107 10 CONTINUE
108 b( j ) = 0.d0
109 w( j ) = 0.d0
110 x( j ) = 0.d0
111 20 CONTINUE
112 ok = .true.
113*
114* Error exits for LQ factorization
115*
116* ZGELQF
117*
118 srnamt = 'ZGELQF'
119 infot = 1
120 CALL zgelqf( -1, 0, a, 1, b, w, 1, info )
121 CALL chkxer( 'ZGELQF', infot, nout, lerr, ok )
122 infot = 2
123 CALL zgelqf( 0, -1, a, 1, b, w, 1, info )
124 CALL chkxer( 'ZGELQF', infot, nout, lerr, ok )
125 infot = 4
126 CALL zgelqf( 2, 1, a, 1, b, w, 2, info )
127 CALL chkxer( 'ZGELQF', infot, nout, lerr, ok )
128 infot = 7
129 CALL zgelqf( 2, 1, a, 2, b, w, 1, info )
130 CALL chkxer( 'ZGELQF', infot, nout, lerr, ok )
131*
132* ZGELQ2
133*
134 srnamt = 'ZGELQ2'
135 infot = 1
136 CALL zgelq2( -1, 0, a, 1, b, w, info )
137 CALL chkxer( 'ZGELQ2', infot, nout, lerr, ok )
138 infot = 2
139 CALL zgelq2( 0, -1, a, 1, b, w, info )
140 CALL chkxer( 'ZGELQ2', infot, nout, lerr, ok )
141 infot = 4
142 CALL zgelq2( 2, 1, a, 1, b, w, info )
143 CALL chkxer( 'ZGELQ2', infot, nout, lerr, ok )
144*
145* ZGELQS
146*
147 srnamt = 'ZGELQS'
148 infot = 1
149 CALL zgelqs( -1, 0, 0, a, 1, x, b, 1, w, 1, info )
150 CALL chkxer( 'ZGELQS', infot, nout, lerr, ok )
151 infot = 2
152 CALL zgelqs( 0, -1, 0, a, 1, x, b, 1, w, 1, info )
153 CALL chkxer( 'ZGELQS', infot, nout, lerr, ok )
154 infot = 2
155 CALL zgelqs( 2, 1, 0, a, 2, x, b, 1, w, 1, info )
156 CALL chkxer( 'ZGELQS', infot, nout, lerr, ok )
157 infot = 3
158 CALL zgelqs( 0, 0, -1, a, 1, x, b, 1, w, 1, info )
159 CALL chkxer( 'ZGELQS', infot, nout, lerr, ok )
160 infot = 5
161 CALL zgelqs( 2, 2, 0, a, 1, x, b, 2, w, 1, info )
162 CALL chkxer( 'ZGELQS', infot, nout, lerr, ok )
163 infot = 8
164 CALL zgelqs( 1, 2, 0, a, 1, x, b, 1, w, 1, info )
165 CALL chkxer( 'ZGELQS', infot, nout, lerr, ok )
166 infot = 10
167 CALL zgelqs( 1, 1, 2, a, 1, x, b, 1, w, 1, info )
168 CALL chkxer( 'ZGELQS', infot, nout, lerr, ok )
169*
170* ZUNGLQ
171*
172 srnamt = 'ZUNGLQ'
173 infot = 1
174 CALL zunglq( -1, 0, 0, a, 1, x, w, 1, info )
175 CALL chkxer( 'ZUNGLQ', infot, nout, lerr, ok )
176 infot = 2
177 CALL zunglq( 0, -1, 0, a, 1, x, w, 1, info )
178 CALL chkxer( 'ZUNGLQ', infot, nout, lerr, ok )
179 infot = 2
180 CALL zunglq( 2, 1, 0, a, 2, x, w, 2, info )
181 CALL chkxer( 'ZUNGLQ', infot, nout, lerr, ok )
182 infot = 3
183 CALL zunglq( 0, 0, -1, a, 1, x, w, 1, info )
184 CALL chkxer( 'ZUNGLQ', infot, nout, lerr, ok )
185 infot = 3
186 CALL zunglq( 1, 1, 2, a, 1, x, w, 1, info )
187 CALL chkxer( 'ZUNGLQ', infot, nout, lerr, ok )
188 infot = 5
189 CALL zunglq( 2, 2, 0, a, 1, x, w, 2, info )
190 CALL chkxer( 'ZUNGLQ', infot, nout, lerr, ok )
191 infot = 8
192 CALL zunglq( 2, 2, 0, a, 2, x, w, 1, info )
193 CALL chkxer( 'ZUNGLQ', infot, nout, lerr, ok )
194*
195* ZUNGL2
196*
197 srnamt = 'ZUNGL2'
198 infot = 1
199 CALL zungl2( -1, 0, 0, a, 1, x, w, info )
200 CALL chkxer( 'ZUNGL2', infot, nout, lerr, ok )
201 infot = 2
202 CALL zungl2( 0, -1, 0, a, 1, x, w, info )
203 CALL chkxer( 'ZUNGL2', infot, nout, lerr, ok )
204 infot = 2
205 CALL zungl2( 2, 1, 0, a, 2, x, w, info )
206 CALL chkxer( 'ZUNGL2', infot, nout, lerr, ok )
207 infot = 3
208 CALL zungl2( 0, 0, -1, a, 1, x, w, info )
209 CALL chkxer( 'ZUNGL2', infot, nout, lerr, ok )
210 infot = 3
211 CALL zungl2( 1, 1, 2, a, 1, x, w, info )
212 CALL chkxer( 'ZUNGL2', infot, nout, lerr, ok )
213 infot = 5
214 CALL zungl2( 2, 2, 0, a, 1, x, w, info )
215 CALL chkxer( 'ZUNGL2', infot, nout, lerr, ok )
216*
217* ZUNMLQ
218*
219 srnamt = 'ZUNMLQ'
220 infot = 1
221 CALL zunmlq( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
222 CALL chkxer( 'ZUNMLQ', infot, nout, lerr, ok )
223 infot = 2
224 CALL zunmlq( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
225 CALL chkxer( 'ZUNMLQ', infot, nout, lerr, ok )
226 infot = 3
227 CALL zunmlq( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, 1, info )
228 CALL chkxer( 'ZUNMLQ', infot, nout, lerr, ok )
229 infot = 4
230 CALL zunmlq( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, 1, info )
231 CALL chkxer( 'ZUNMLQ', infot, nout, lerr, ok )
232 infot = 5
233 CALL zunmlq( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, 1, info )
234 CALL chkxer( 'ZUNMLQ', infot, nout, lerr, ok )
235 infot = 5
236 CALL zunmlq( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, 1, info )
237 CALL chkxer( 'ZUNMLQ', infot, nout, lerr, ok )
238 infot = 5
239 CALL zunmlq( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, 1, info )
240 CALL chkxer( 'ZUNMLQ', infot, nout, lerr, ok )
241 infot = 7
242 CALL zunmlq( 'L', 'N', 2, 0, 2, a, 1, x, af, 2, w, 1, info )
243 CALL chkxer( 'ZUNMLQ', infot, nout, lerr, ok )
244 infot = 7
245 CALL zunmlq( 'R', 'N', 0, 2, 2, a, 1, x, af, 1, w, 1, info )
246 CALL chkxer( 'ZUNMLQ', infot, nout, lerr, ok )
247 infot = 10
248 CALL zunmlq( 'L', 'N', 2, 1, 0, a, 2, x, af, 1, w, 1, info )
249 CALL chkxer( 'ZUNMLQ', infot, nout, lerr, ok )
250 infot = 12
251 CALL zunmlq( 'L', 'N', 1, 2, 0, a, 1, x, af, 1, w, 1, info )
252 CALL chkxer( 'ZUNMLQ', infot, nout, lerr, ok )
253 infot = 12
254 CALL zunmlq( 'R', 'N', 2, 1, 0, a, 1, x, af, 2, w, 1, info )
255 CALL chkxer( 'ZUNMLQ', infot, nout, lerr, ok )
256*
257* ZUNML2
258*
259 srnamt = 'ZUNML2'
260 infot = 1
261 CALL zunml2( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, info )
262 CALL chkxer( 'ZUNML2', infot, nout, lerr, ok )
263 infot = 2
264 CALL zunml2( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, info )
265 CALL chkxer( 'ZUNML2', infot, nout, lerr, ok )
266 infot = 3
267 CALL zunml2( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, info )
268 CALL chkxer( 'ZUNML2', infot, nout, lerr, ok )
269 infot = 4
270 CALL zunml2( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, info )
271 CALL chkxer( 'ZUNML2', infot, nout, lerr, ok )
272 infot = 5
273 CALL zunml2( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, info )
274 CALL chkxer( 'ZUNML2', infot, nout, lerr, ok )
275 infot = 5
276 CALL zunml2( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, info )
277 CALL chkxer( 'ZUNML2', infot, nout, lerr, ok )
278 infot = 5
279 CALL zunml2( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, info )
280 CALL chkxer( 'ZUNML2', infot, nout, lerr, ok )
281 infot = 7
282 CALL zunml2( 'L', 'N', 2, 1, 2, a, 1, x, af, 2, w, info )
283 CALL chkxer( 'ZUNML2', infot, nout, lerr, ok )
284 infot = 7
285 CALL zunml2( 'R', 'N', 1, 2, 2, a, 1, x, af, 1, w, info )
286 CALL chkxer( 'ZUNML2', infot, nout, lerr, ok )
287 infot = 10
288 CALL zunml2( 'L', 'N', 2, 1, 0, a, 2, x, af, 1, w, info )
289 CALL chkxer( 'ZUNML2', infot, nout, lerr, ok )
290*
291* Print a summary line.
292*
293 CALL alaesm( path, ok, nout )
294*
295 RETURN
296*
297* End of ZERRLQ
298*
zgelq2
subroutine zgelq2(m, n, a, lda, tau, work, info)
ZGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.
Definition zgelq2.f:129
zunmlq
subroutine zunmlq(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
ZUNMLQ
Definition zunmlq.f:167
zungl2
subroutine zungl2(m, n, k, a, lda, tau, work, info)
ZUNGL2 generates all or part of the unitary matrix Q from an LQ factorization determined by cgelqf (u...
Definition zungl2.f:113
zunglq
subroutine zunglq(m, n, k, a, lda, tau, work, lwork, info)
ZUNGLQ
Definition zunglq.f:127
zunml2
subroutine zunml2(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
ZUNML2 multiplies a general matrix by the unitary matrix from a LQ factorization determined by cgelqf...
Definition zunml2.f:159

◆ zerrls()

subroutine zerrls ( character*3 path,
integer nunit )

ZERRLS

Purpose:
!>
!> ZERRLS tests the error exits for the COMPLEX*16 least squares
!> driver routines (ZGELS, CGELSS, CGELSY, CGELSD).
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 54 of file zerrls.f.

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX
69 parameter( nmax = 2 )
70* ..
71* .. Local Scalars ..
72 CHARACTER*2 C2
73 INTEGER INFO, IRNK
74 DOUBLE PRECISION RCOND
75* ..
76* .. Local Arrays ..
77 INTEGER IP( NMAX )
78 DOUBLE PRECISION RW( NMAX ), S( NMAX )
79 COMPLEX*16 A( NMAX, NMAX ), B( NMAX, NMAX ), W( NMAX )
80* ..
81* .. External Functions ..
82 LOGICAL LSAMEN
83 EXTERNAL lsamen
84* ..
85* .. External Subroutines ..
86 EXTERNAL alaesm, chkxer, zgels, zgelsd, zgelss, zgelsy
87* ..
88* .. Scalars in Common ..
89 LOGICAL LERR, OK
90 CHARACTER*32 SRNAMT
91 INTEGER INFOT, NOUT
92* ..
93* .. Common blocks ..
94 COMMON / infoc / infot, nout, ok, lerr
95 COMMON / srnamc / srnamt
96* ..
97* .. Executable Statements ..
98*
99 nout = nunit
100 c2 = path( 2: 3 )
101 a( 1, 1 ) = ( 1.0d+0, 0.0d+0 )
102 a( 1, 2 ) = ( 2.0d+0, 0.0d+0 )
103 a( 2, 2 ) = ( 3.0d+0, 0.0d+0 )
104 a( 2, 1 ) = ( 4.0d+0, 0.0d+0 )
105 ok = .true.
106 WRITE( nout, fmt = * )
107*
108* Test error exits for the least squares driver routines.
109*
110 IF( lsamen( 2, c2, 'LS' ) ) THEN
111*
112* ZGELS
113*
114 srnamt = 'ZGELS '
115 infot = 1
116 CALL zgels( '/', 0, 0, 0, a, 1, b, 1, w, 1, info )
117 CALL chkxer( 'ZGELS ', infot, nout, lerr, ok )
118 infot = 2
119 CALL zgels( 'N', -1, 0, 0, a, 1, b, 1, w, 1, info )
120 CALL chkxer( 'ZGELS ', infot, nout, lerr, ok )
121 infot = 3
122 CALL zgels( 'N', 0, -1, 0, a, 1, b, 1, w, 1, info )
123 CALL chkxer( 'ZGELS ', infot, nout, lerr, ok )
124 infot = 4
125 CALL zgels( 'N', 0, 0, -1, a, 1, b, 1, w, 1, info )
126 CALL chkxer( 'ZGELS ', infot, nout, lerr, ok )
127 infot = 6
128 CALL zgels( 'N', 2, 0, 0, a, 1, b, 2, w, 2, info )
129 CALL chkxer( 'ZGELS ', infot, nout, lerr, ok )
130 infot = 8
131 CALL zgels( 'N', 2, 0, 0, a, 2, b, 1, w, 2, info )
132 CALL chkxer( 'ZGELS ', infot, nout, lerr, ok )
133 infot = 10
134 CALL zgels( 'N', 1, 1, 0, a, 1, b, 1, w, 1, info )
135 CALL chkxer( 'ZGELS ', infot, nout, lerr, ok )
136*
137* ZGELSS
138*
139 srnamt = 'ZGELSS'
140 infot = 1
141 CALL zgelss( -1, 0, 0, a, 1, b, 1, s, rcond, irnk, w, 1, rw,
142 $ info )
143 CALL chkxer( 'ZGELSS', infot, nout, lerr, ok )
144 infot = 2
145 CALL zgelss( 0, -1, 0, a, 1, b, 1, s, rcond, irnk, w, 1, rw,
146 $ info )
147 CALL chkxer( 'ZGELSS', infot, nout, lerr, ok )
148 infot = 3
149 CALL zgelss( 0, 0, -1, a, 1, b, 1, s, rcond, irnk, w, 1, rw,
150 $ info )
151 CALL chkxer( 'ZGELSS', infot, nout, lerr, ok )
152 infot = 5
153 CALL zgelss( 2, 0, 0, a, 1, b, 2, s, rcond, irnk, w, 2, rw,
154 $ info )
155 CALL chkxer( 'ZGELSS', infot, nout, lerr, ok )
156 infot = 7
157 CALL zgelss( 2, 0, 0, a, 2, b, 1, s, rcond, irnk, w, 2, rw,
158 $ info )
159 CALL chkxer( 'ZGELSS', infot, nout, lerr, ok )
160*
161* ZGELSY
162*
163 srnamt = 'ZGELSY'
164 infot = 1
165 CALL zgelsy( -1, 0, 0, a, 1, b, 1, ip, rcond, irnk, w, 10, rw,
166 $ info )
167 CALL chkxer( 'ZGELSY', infot, nout, lerr, ok )
168 infot = 2
169 CALL zgelsy( 0, -1, 0, a, 1, b, 1, ip, rcond, irnk, w, 10, rw,
170 $ info )
171 CALL chkxer( 'ZGELSY', infot, nout, lerr, ok )
172 infot = 3
173 CALL zgelsy( 0, 0, -1, a, 1, b, 1, ip, rcond, irnk, w, 10, rw,
174 $ info )
175 CALL chkxer( 'ZGELSY', infot, nout, lerr, ok )
176 infot = 5
177 CALL zgelsy( 2, 0, 0, a, 1, b, 2, ip, rcond, irnk, w, 10, rw,
178 $ info )
179 CALL chkxer( 'ZGELSY', infot, nout, lerr, ok )
180 infot = 7
181 CALL zgelsy( 2, 0, 0, a, 2, b, 1, ip, rcond, irnk, w, 10, rw,
182 $ info )
183 CALL chkxer( 'ZGELSY', infot, nout, lerr, ok )
184 infot = 12
185 CALL zgelsy( 0, 3, 0, a, 1, b, 3, ip, rcond, irnk, w, 1, rw,
186 $ info )
187 CALL chkxer( 'ZGELSY', infot, nout, lerr, ok )
188*
189* ZGELSD
190*
191 srnamt = 'ZGELSD'
192 infot = 1
193 CALL zgelsd( -1, 0, 0, a, 1, b, 1, s, rcond, irnk, w, 10, rw,
194 $ ip, info )
195 CALL chkxer( 'ZGELSD', infot, nout, lerr, ok )
196 infot = 2
197 CALL zgelsd( 0, -1, 0, a, 1, b, 1, s, rcond, irnk, w, 10, rw,
198 $ ip, info )
199 CALL chkxer( 'ZGELSD', infot, nout, lerr, ok )
200 infot = 3
201 CALL zgelsd( 0, 0, -1, a, 1, b, 1, s, rcond, irnk, w, 10, rw,
202 $ ip, info )
203 CALL chkxer( 'ZGELSD', infot, nout, lerr, ok )
204 infot = 5
205 CALL zgelsd( 2, 0, 0, a, 1, b, 2, s, rcond, irnk, w, 10, rw,
206 $ ip, info )
207 CALL chkxer( 'ZGELSD', infot, nout, lerr, ok )
208 infot = 7
209 CALL zgelsd( 2, 0, 0, a, 2, b, 1, s, rcond, irnk, w, 10, rw,
210 $ ip, info )
211 CALL chkxer( 'ZGELSD', infot, nout, lerr, ok )
212 infot = 12
213 CALL zgelsd( 2, 2, 1, a, 2, b, 2, s, rcond, irnk, w, 1, rw, ip,
214 $ info )
215 CALL chkxer( 'ZGELSD', infot, nout, lerr, ok )
216 END IF
217*
218* Print a summary line.
219*
220 CALL alaesm( path, ok, nout )
221*
222 RETURN
223*
224* End of ZERRLS
225*

◆ zerrpo()

subroutine zerrpo ( character*3 path,
integer nunit )

ZERRPO

ZERRPOX

Purpose:
!>
!> ZERRPO tests the error exits for the COMPLEX*16 routines
!> for Hermitian positive definite matrices.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Purpose:
!>
!> ZERRPO tests the error exits for the COMPLEX*16 routines
!> for Hermitian positive definite matrices.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise zerrpo.f defines this subroutine.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 54 of file zerrpo.f.

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX
69 parameter( nmax = 4 )
70* ..
71* .. Local Scalars ..
72 CHARACTER*2 C2
73 INTEGER I, INFO, J
74 DOUBLE PRECISION ANRM, RCOND
75* ..
76* .. Local Arrays ..
77 DOUBLE PRECISION R( NMAX ), R1( NMAX ), R2( NMAX )
78 COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
79 $ W( 2*NMAX ), X( NMAX )
80* ..
81* .. External Functions ..
82 LOGICAL LSAMEN
83 EXTERNAL lsamen
84* ..
85* .. External Subroutines ..
86 EXTERNAL alaesm, chkxer, zpbcon, zpbequ, zpbrfs, zpbtf2,
87 $ zpbtrf, zpbtrs, zpocon, zpoequ, zporfs, zpotf2,
88 $ zpotrf, zpotri, zpotrs, zppcon, zppequ, zpprfs,
89 $ zpptrf, zpptri, zpptrs
90* ..
91* .. Scalars in Common ..
92 LOGICAL LERR, OK
93 CHARACTER*32 SRNAMT
94 INTEGER INFOT, NOUT
95* ..
96* .. Common blocks ..
97 COMMON / infoc / infot, nout, ok, lerr
98 COMMON / srnamc / srnamt
99* ..
100* .. Intrinsic Functions ..
101 INTRINSIC dble, dcmplx
102* ..
103* .. Executable Statements ..
104*
105 nout = nunit
106 WRITE( nout, fmt = * )
107 c2 = path( 2: 3 )
108*
109* Set the variables to innocuous values.
110*
111 DO 20 j = 1, nmax
112 DO 10 i = 1, nmax
113 a( i, j ) = dcmplx( 1.d0 / dble( i+j ),
114 $ -1.d0 / dble( i+j ) )
115 af( i, j ) = dcmplx( 1.d0 / dble( i+j ),
116 $ -1.d0 / dble( i+j ) )
117 10 CONTINUE
118 b( j ) = 0.d0
119 r1( j ) = 0.d0
120 r2( j ) = 0.d0
121 w( j ) = 0.d0
122 x( j ) = 0.d0
123 20 CONTINUE
124 anrm = 1.d0
125 ok = .true.
126*
127* Test error exits of the routines that use the Cholesky
128* decomposition of a Hermitian positive definite matrix.
129*
130 IF( lsamen( 2, c2, 'PO' ) ) THEN
131*
132* ZPOTRF
133*
134 srnamt = 'ZPOTRF'
135 infot = 1
136 CALL zpotrf( '/', 0, a, 1, info )
137 CALL chkxer( 'ZPOTRF', infot, nout, lerr, ok )
138 infot = 2
139 CALL zpotrf( 'U', -1, a, 1, info )
140 CALL chkxer( 'ZPOTRF', infot, nout, lerr, ok )
141 infot = 4
142 CALL zpotrf( 'U', 2, a, 1, info )
143 CALL chkxer( 'ZPOTRF', infot, nout, lerr, ok )
144*
145* ZPOTF2
146*
147 srnamt = 'ZPOTF2'
148 infot = 1
149 CALL zpotf2( '/', 0, a, 1, info )
150 CALL chkxer( 'ZPOTF2', infot, nout, lerr, ok )
151 infot = 2
152 CALL zpotf2( 'U', -1, a, 1, info )
153 CALL chkxer( 'ZPOTF2', infot, nout, lerr, ok )
154 infot = 4
155 CALL zpotf2( 'U', 2, a, 1, info )
156 CALL chkxer( 'ZPOTF2', infot, nout, lerr, ok )
157*
158* ZPOTRI
159*
160 srnamt = 'ZPOTRI'
161 infot = 1
162 CALL zpotri( '/', 0, a, 1, info )
163 CALL chkxer( 'ZPOTRI', infot, nout, lerr, ok )
164 infot = 2
165 CALL zpotri( 'U', -1, a, 1, info )
166 CALL chkxer( 'ZPOTRI', infot, nout, lerr, ok )
167 infot = 4
168 CALL zpotri( 'U', 2, a, 1, info )
169 CALL chkxer( 'ZPOTRI', infot, nout, lerr, ok )
170*
171* ZPOTRS
172*
173 srnamt = 'ZPOTRS'
174 infot = 1
175 CALL zpotrs( '/', 0, 0, a, 1, b, 1, info )
176 CALL chkxer( 'ZPOTRS', infot, nout, lerr, ok )
177 infot = 2
178 CALL zpotrs( 'U', -1, 0, a, 1, b, 1, info )
179 CALL chkxer( 'ZPOTRS', infot, nout, lerr, ok )
180 infot = 3
181 CALL zpotrs( 'U', 0, -1, a, 1, b, 1, info )
182 CALL chkxer( 'ZPOTRS', infot, nout, lerr, ok )
183 infot = 5
184 CALL zpotrs( 'U', 2, 1, a, 1, b, 2, info )
185 CALL chkxer( 'ZPOTRS', infot, nout, lerr, ok )
186 infot = 7
187 CALL zpotrs( 'U', 2, 1, a, 2, b, 1, info )
188 CALL chkxer( 'ZPOTRS', infot, nout, lerr, ok )
189*
190* ZPORFS
191*
192 srnamt = 'ZPORFS'
193 infot = 1
194 CALL zporfs( '/', 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w, r,
195 $ info )
196 CALL chkxer( 'ZPORFS', infot, nout, lerr, ok )
197 infot = 2
198 CALL zporfs( 'U', -1, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w, r,
199 $ info )
200 CALL chkxer( 'ZPORFS', infot, nout, lerr, ok )
201 infot = 3
202 CALL zporfs( 'U', 0, -1, a, 1, af, 1, b, 1, x, 1, r1, r2, w, r,
203 $ info )
204 CALL chkxer( 'ZPORFS', infot, nout, lerr, ok )
205 infot = 5
206 CALL zporfs( 'U', 2, 1, a, 1, af, 2, b, 2, x, 2, r1, r2, w, r,
207 $ info )
208 CALL chkxer( 'ZPORFS', infot, nout, lerr, ok )
209 infot = 7
210 CALL zporfs( 'U', 2, 1, a, 2, af, 1, b, 2, x, 2, r1, r2, w, r,
211 $ info )
212 CALL chkxer( 'ZPORFS', infot, nout, lerr, ok )
213 infot = 9
214 CALL zporfs( 'U', 2, 1, a, 2, af, 2, b, 1, x, 2, r1, r2, w, r,
215 $ info )
216 CALL chkxer( 'ZPORFS', infot, nout, lerr, ok )
217 infot = 11
218 CALL zporfs( 'U', 2, 1, a, 2, af, 2, b, 2, x, 1, r1, r2, w, r,
219 $ info )
220 CALL chkxer( 'ZPORFS', infot, nout, lerr, ok )
221*
222* ZPOCON
223*
224 srnamt = 'ZPOCON'
225 infot = 1
226 CALL zpocon( '/', 0, a, 1, anrm, rcond, w, r, info )
227 CALL chkxer( 'ZPOCON', infot, nout, lerr, ok )
228 infot = 2
229 CALL zpocon( 'U', -1, a, 1, anrm, rcond, w, r, info )
230 CALL chkxer( 'ZPOCON', infot, nout, lerr, ok )
231 infot = 4
232 CALL zpocon( 'U', 2, a, 1, anrm, rcond, w, r, info )
233 CALL chkxer( 'ZPOCON', infot, nout, lerr, ok )
234 infot = 5
235 CALL zpocon( 'U', 1, a, 1, -anrm, rcond, w, r, info )
236 CALL chkxer( 'ZPOCON', infot, nout, lerr, ok )
237*
238* ZPOEQU
239*
240 srnamt = 'ZPOEQU'
241 infot = 1
242 CALL zpoequ( -1, a, 1, r1, rcond, anrm, info )
243 CALL chkxer( 'ZPOEQU', infot, nout, lerr, ok )
244 infot = 3
245 CALL zpoequ( 2, a, 1, r1, rcond, anrm, info )
246 CALL chkxer( 'ZPOEQU', infot, nout, lerr, ok )
247*
248* Test error exits of the routines that use the Cholesky
249* decomposition of a Hermitian positive definite packed matrix.
250*
251 ELSE IF( lsamen( 2, c2, 'PP' ) ) THEN
252*
253* ZPPTRF
254*
255 srnamt = 'ZPPTRF'
256 infot = 1
257 CALL zpptrf( '/', 0, a, info )
258 CALL chkxer( 'ZPPTRF', infot, nout, lerr, ok )
259 infot = 2
260 CALL zpptrf( 'U', -1, a, info )
261 CALL chkxer( 'ZPPTRF', infot, nout, lerr, ok )
262*
263* ZPPTRI
264*
265 srnamt = 'ZPPTRI'
266 infot = 1
267 CALL zpptri( '/', 0, a, info )
268 CALL chkxer( 'ZPPTRI', infot, nout, lerr, ok )
269 infot = 2
270 CALL zpptri( 'U', -1, a, info )
271 CALL chkxer( 'ZPPTRI', infot, nout, lerr, ok )
272*
273* ZPPTRS
274*
275 srnamt = 'ZPPTRS'
276 infot = 1
277 CALL zpptrs( '/', 0, 0, a, b, 1, info )
278 CALL chkxer( 'ZPPTRS', infot, nout, lerr, ok )
279 infot = 2
280 CALL zpptrs( 'U', -1, 0, a, b, 1, info )
281 CALL chkxer( 'ZPPTRS', infot, nout, lerr, ok )
282 infot = 3
283 CALL zpptrs( 'U', 0, -1, a, b, 1, info )
284 CALL chkxer( 'ZPPTRS', infot, nout, lerr, ok )
285 infot = 6
286 CALL zpptrs( 'U', 2, 1, a, b, 1, info )
287 CALL chkxer( 'ZPPTRS', infot, nout, lerr, ok )
288*
289* ZPPRFS
290*
291 srnamt = 'ZPPRFS'
292 infot = 1
293 CALL zpprfs( '/', 0, 0, a, af, b, 1, x, 1, r1, r2, w, r, info )
294 CALL chkxer( 'ZPPRFS', infot, nout, lerr, ok )
295 infot = 2
296 CALL zpprfs( 'U', -1, 0, a, af, b, 1, x, 1, r1, r2, w, r,
297 $ info )
298 CALL chkxer( 'ZPPRFS', infot, nout, lerr, ok )
299 infot = 3
300 CALL zpprfs( 'U', 0, -1, a, af, b, 1, x, 1, r1, r2, w, r,
301 $ info )
302 CALL chkxer( 'ZPPRFS', infot, nout, lerr, ok )
303 infot = 7
304 CALL zpprfs( 'U', 2, 1, a, af, b, 1, x, 2, r1, r2, w, r, info )
305 CALL chkxer( 'ZPPRFS', infot, nout, lerr, ok )
306 infot = 9
307 CALL zpprfs( 'U', 2, 1, a, af, b, 2, x, 1, r1, r2, w, r, info )
308 CALL chkxer( 'ZPPRFS', infot, nout, lerr, ok )
309*
310* ZPPCON
311*
312 srnamt = 'ZPPCON'
313 infot = 1
314 CALL zppcon( '/', 0, a, anrm, rcond, w, r, info )
315 CALL chkxer( 'ZPPCON', infot, nout, lerr, ok )
316 infot = 2
317 CALL zppcon( 'U', -1, a, anrm, rcond, w, r, info )
318 CALL chkxer( 'ZPPCON', infot, nout, lerr, ok )
319 infot = 4
320 CALL zppcon( 'U', 1, a, -anrm, rcond, w, r, info )
321 CALL chkxer( 'ZPPCON', infot, nout, lerr, ok )
322*
323* ZPPEQU
324*
325 srnamt = 'ZPPEQU'
326 infot = 1
327 CALL zppequ( '/', 0, a, r1, rcond, anrm, info )
328 CALL chkxer( 'ZPPEQU', infot, nout, lerr, ok )
329 infot = 2
330 CALL zppequ( 'U', -1, a, r1, rcond, anrm, info )
331 CALL chkxer( 'ZPPEQU', infot, nout, lerr, ok )
332*
333* Test error exits of the routines that use the Cholesky
334* decomposition of a Hermitian positive definite band matrix.
335*
336 ELSE IF( lsamen( 2, c2, 'PB' ) ) THEN
337*
338* ZPBTRF
339*
340 srnamt = 'ZPBTRF'
341 infot = 1
342 CALL zpbtrf( '/', 0, 0, a, 1, info )
343 CALL chkxer( 'ZPBTRF', infot, nout, lerr, ok )
344 infot = 2
345 CALL zpbtrf( 'U', -1, 0, a, 1, info )
346 CALL chkxer( 'ZPBTRF', infot, nout, lerr, ok )
347 infot = 3
348 CALL zpbtrf( 'U', 1, -1, a, 1, info )
349 CALL chkxer( 'ZPBTRF', infot, nout, lerr, ok )
350 infot = 5
351 CALL zpbtrf( 'U', 2, 1, a, 1, info )
352 CALL chkxer( 'ZPBTRF', infot, nout, lerr, ok )
353*
354* ZPBTF2
355*
356 srnamt = 'ZPBTF2'
357 infot = 1
358 CALL zpbtf2( '/', 0, 0, a, 1, info )
359 CALL chkxer( 'ZPBTF2', infot, nout, lerr, ok )
360 infot = 2
361 CALL zpbtf2( 'U', -1, 0, a, 1, info )
362 CALL chkxer( 'ZPBTF2', infot, nout, lerr, ok )
363 infot = 3
364 CALL zpbtf2( 'U', 1, -1, a, 1, info )
365 CALL chkxer( 'ZPBTF2', infot, nout, lerr, ok )
366 infot = 5
367 CALL zpbtf2( 'U', 2, 1, a, 1, info )
368 CALL chkxer( 'ZPBTF2', infot, nout, lerr, ok )
369*
370* ZPBTRS
371*
372 srnamt = 'ZPBTRS'
373 infot = 1
374 CALL zpbtrs( '/', 0, 0, 0, a, 1, b, 1, info )
375 CALL chkxer( 'ZPBTRS', infot, nout, lerr, ok )
376 infot = 2
377 CALL zpbtrs( 'U', -1, 0, 0, a, 1, b, 1, info )
378 CALL chkxer( 'ZPBTRS', infot, nout, lerr, ok )
379 infot = 3
380 CALL zpbtrs( 'U', 1, -1, 0, a, 1, b, 1, info )
381 CALL chkxer( 'ZPBTRS', infot, nout, lerr, ok )
382 infot = 4
383 CALL zpbtrs( 'U', 0, 0, -1, a, 1, b, 1, info )
384 CALL chkxer( 'ZPBTRS', infot, nout, lerr, ok )
385 infot = 6
386 CALL zpbtrs( 'U', 2, 1, 1, a, 1, b, 1, info )
387 CALL chkxer( 'ZPBTRS', infot, nout, lerr, ok )
388 infot = 8
389 CALL zpbtrs( 'U', 2, 0, 1, a, 1, b, 1, info )
390 CALL chkxer( 'ZPBTRS', infot, nout, lerr, ok )
391*
392* ZPBRFS
393*
394 srnamt = 'ZPBRFS'
395 infot = 1
396 CALL zpbrfs( '/', 0, 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
397 $ r, info )
398 CALL chkxer( 'ZPBRFS', infot, nout, lerr, ok )
399 infot = 2
400 CALL zpbrfs( 'U', -1, 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
401 $ r, info )
402 CALL chkxer( 'ZPBRFS', infot, nout, lerr, ok )
403 infot = 3
404 CALL zpbrfs( 'U', 1, -1, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
405 $ r, info )
406 CALL chkxer( 'ZPBRFS', infot, nout, lerr, ok )
407 infot = 4
408 CALL zpbrfs( 'U', 0, 0, -1, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
409 $ r, info )
410 CALL chkxer( 'ZPBRFS', infot, nout, lerr, ok )
411 infot = 6
412 CALL zpbrfs( 'U', 2, 1, 1, a, 1, af, 2, b, 2, x, 2, r1, r2, w,
413 $ r, info )
414 CALL chkxer( 'ZPBRFS', infot, nout, lerr, ok )
415 infot = 8
416 CALL zpbrfs( 'U', 2, 1, 1, a, 2, af, 1, b, 2, x, 2, r1, r2, w,
417 $ r, info )
418 CALL chkxer( 'ZPBRFS', infot, nout, lerr, ok )
419 infot = 10
420 CALL zpbrfs( 'U', 2, 0, 1, a, 1, af, 1, b, 1, x, 2, r1, r2, w,
421 $ r, info )
422 CALL chkxer( 'ZPBRFS', infot, nout, lerr, ok )
423 infot = 12
424 CALL zpbrfs( 'U', 2, 0, 1, a, 1, af, 1, b, 2, x, 1, r1, r2, w,
425 $ r, info )
426 CALL chkxer( 'ZPBRFS', infot, nout, lerr, ok )
427*
428* ZPBCON
429*
430 srnamt = 'ZPBCON'
431 infot = 1
432 CALL zpbcon( '/', 0, 0, a, 1, anrm, rcond, w, r, info )
433 CALL chkxer( 'ZPBCON', infot, nout, lerr, ok )
434 infot = 2
435 CALL zpbcon( 'U', -1, 0, a, 1, anrm, rcond, w, r, info )
436 CALL chkxer( 'ZPBCON', infot, nout, lerr, ok )
437 infot = 3
438 CALL zpbcon( 'U', 1, -1, a, 1, anrm, rcond, w, r, info )
439 CALL chkxer( 'ZPBCON', infot, nout, lerr, ok )
440 infot = 5
441 CALL zpbcon( 'U', 2, 1, a, 1, anrm, rcond, w, r, info )
442 CALL chkxer( 'ZPBCON', infot, nout, lerr, ok )
443 infot = 6
444 CALL zpbcon( 'U', 1, 0, a, 1, -anrm, rcond, w, r, info )
445 CALL chkxer( 'ZPBCON', infot, nout, lerr, ok )
446*
447* ZPBEQU
448*
449 srnamt = 'ZPBEQU'
450 infot = 1
451 CALL zpbequ( '/', 0, 0, a, 1, r1, rcond, anrm, info )
452 CALL chkxer( 'ZPBEQU', infot, nout, lerr, ok )
453 infot = 2
454 CALL zpbequ( 'U', -1, 0, a, 1, r1, rcond, anrm, info )
455 CALL chkxer( 'ZPBEQU', infot, nout, lerr, ok )
456 infot = 3
457 CALL zpbequ( 'U', 1, -1, a, 1, r1, rcond, anrm, info )
458 CALL chkxer( 'ZPBEQU', infot, nout, lerr, ok )
459 infot = 5
460 CALL zpbequ( 'U', 2, 1, a, 1, r1, rcond, anrm, info )
461 CALL chkxer( 'ZPBEQU', infot, nout, lerr, ok )
462 END IF
463*
464* Print a summary line.
465*
466 CALL alaesm( path, ok, nout )
467*
468 RETURN
469*
470* End of ZERRPO
471*
zpbtf2
subroutine zpbtf2(uplo, n, kd, ab, ldab, info)
ZPBTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite band matrix (un...
Definition zpbtf2.f:142
zpotf2
subroutine zpotf2(uplo, n, a, lda, info)
ZPOTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite matrix (unblock...
Definition zpotf2.f:109

◆ zerrps()

subroutine zerrps ( character*3 path,
integer nunit )

ZERRPS

Purpose:
!>
!> ZERRPS tests the error exits for the COMPLEX routines
!> for ZPSTRF.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 54 of file zerrps.f.

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 INTEGER NUNIT
62 CHARACTER*3 PATH
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX
69 parameter( nmax = 4 )
70* ..
71* .. Local Scalars ..
72 INTEGER I, INFO, J, RANK
73* ..
74* .. Local Arrays ..
75 COMPLEX*16 A( NMAX, NMAX )
76 DOUBLE PRECISION RWORK( 2*NMAX )
77 INTEGER PIV( NMAX )
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, zpstf2, zpstrf
81* ..
82* .. Scalars in Common ..
83 INTEGER INFOT, NOUT
84 LOGICAL LERR, OK
85 CHARACTER*32 SRNAMT
86* ..
87* .. Common blocks ..
88 COMMON / infoc / infot, nout, ok, lerr
89 COMMON / srnamc / srnamt
90* ..
91* .. Intrinsic Functions ..
92 INTRINSIC dble
93* ..
94* .. Executable Statements ..
95*
96 nout = nunit
97 WRITE( nout, fmt = * )
98*
99* Set the variables to innocuous values.
100*
101 DO 110 j = 1, nmax
102 DO 100 i = 1, nmax
103 a( i, j ) = 1.d0 / dble( i+j )
104*
105 100 CONTINUE
106 piv( j ) = j
107 rwork( j ) = 0.d0
108 rwork( nmax+j ) = 0.d0
109*
110 110 CONTINUE
111 ok = .true.
112*
113*
114* Test error exits of the routines that use the Cholesky
115* decomposition of an Hermitian positive semidefinite matrix.
116*
117* ZPSTRF
118*
119 srnamt = 'ZPSTRF'
120 infot = 1
121 CALL zpstrf( '/', 0, a, 1, piv, rank, -1.d0, rwork, info )
122 CALL chkxer( 'ZPSTRF', infot, nout, lerr, ok )
123 infot = 2
124 CALL zpstrf( 'U', -1, a, 1, piv, rank, -1.d0, rwork, info )
125 CALL chkxer( 'ZPSTRF', infot, nout, lerr, ok )
126 infot = 4
127 CALL zpstrf( 'U', 2, a, 1, piv, rank, -1.d0, rwork, info )
128 CALL chkxer( 'ZPSTRF', infot, nout, lerr, ok )
129*
130* ZPSTF2
131*
132 srnamt = 'ZPSTF2'
133 infot = 1
134 CALL zpstf2( '/', 0, a, 1, piv, rank, -1.d0, rwork, info )
135 CALL chkxer( 'ZPSTF2', infot, nout, lerr, ok )
136 infot = 2
137 CALL zpstf2( 'U', -1, a, 1, piv, rank, -1.d0, rwork, info )
138 CALL chkxer( 'ZPSTF2', infot, nout, lerr, ok )
139 infot = 4
140 CALL zpstf2( 'U', 2, a, 1, piv, rank, -1.d0, rwork, info )
141 CALL chkxer( 'ZPSTF2', infot, nout, lerr, ok )
142*
143*
144* Print a summary line.
145*
146 CALL alaesm( path, ok, nout )
147*
148 RETURN
149*
150* End of ZERRPS
151*
zpstf2
subroutine zpstf2(uplo, n, a, lda, piv, rank, tol, work, info)
ZPSTF2 computes the Cholesky factorization with complete pivoting of a complex Hermitian positive sem...
Definition zpstf2.f:142

◆ zerrql()

subroutine zerrql ( character*3 path,
integer nunit )

ZERRQL

Purpose:
!>
!> ZERRQL tests the error exits for the COMPLEX*16 routines
!> that use the QL decomposition of a general matrix.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 54 of file zerrql.f.

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX
69 parameter( nmax = 2 )
70* ..
71* .. Local Scalars ..
72 INTEGER I, INFO, J
73* ..
74* .. Local Arrays ..
75 COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
76 $ W( NMAX ), X( NMAX )
77* ..
78* .. External Subroutines ..
79 EXTERNAL alaesm, chkxer, zgeql2, zgeqlf, zgeqls, zung2l,
80 $ zungql, zunm2l, zunmql
81* ..
82* .. Scalars in Common ..
83 LOGICAL LERR, OK
84 CHARACTER*32 SRNAMT
85 INTEGER INFOT, NOUT
86* ..
87* .. Common blocks ..
88 COMMON / infoc / infot, nout, ok, lerr
89 COMMON / srnamc / srnamt
90* ..
91* .. Intrinsic Functions ..
92 INTRINSIC dble, dcmplx
93* ..
94* .. Executable Statements ..
95*
96 nout = nunit
97 WRITE( nout, fmt = * )
98*
99* Set the variables to innocuous values.
100*
101 DO 20 j = 1, nmax
102 DO 10 i = 1, nmax
103 a( i, j ) = dcmplx( 1.d0 / dble( i+j ),
104 $ -1.d0 / dble( i+j ) )
105 af( i, j ) = dcmplx( 1.d0 / dble( i+j ),
106 $ -1.d0 / dble( i+j ) )
107 10 CONTINUE
108 b( j ) = 0.d0
109 w( j ) = 0.d0
110 x( j ) = 0.d0
111 20 CONTINUE
112 ok = .true.
113*
114* Error exits for QL factorization
115*
116* ZGEQLF
117*
118 srnamt = 'ZGEQLF'
119 infot = 1
120 CALL zgeqlf( -1, 0, a, 1, b, w, 1, info )
121 CALL chkxer( 'ZGEQLF', infot, nout, lerr, ok )
122 infot = 2
123 CALL zgeqlf( 0, -1, a, 1, b, w, 1, info )
124 CALL chkxer( 'ZGEQLF', infot, nout, lerr, ok )
125 infot = 4
126 CALL zgeqlf( 2, 1, a, 1, b, w, 1, info )
127 CALL chkxer( 'ZGEQLF', infot, nout, lerr, ok )
128 infot = 7
129 CALL zgeqlf( 1, 2, a, 1, b, w, 1, info )
130 CALL chkxer( 'ZGEQLF', infot, nout, lerr, ok )
131*
132* ZGEQL2
133*
134 srnamt = 'ZGEQL2'
135 infot = 1
136 CALL zgeql2( -1, 0, a, 1, b, w, info )
137 CALL chkxer( 'ZGEQL2', infot, nout, lerr, ok )
138 infot = 2
139 CALL zgeql2( 0, -1, a, 1, b, w, info )
140 CALL chkxer( 'ZGEQL2', infot, nout, lerr, ok )
141 infot = 4
142 CALL zgeql2( 2, 1, a, 1, b, w, info )
143 CALL chkxer( 'ZGEQL2', infot, nout, lerr, ok )
144*
145* ZGEQLS
146*
147 srnamt = 'ZGEQLS'
148 infot = 1
149 CALL zgeqls( -1, 0, 0, a, 1, x, b, 1, w, 1, info )
150 CALL chkxer( 'ZGEQLS', infot, nout, lerr, ok )
151 infot = 2
152 CALL zgeqls( 0, -1, 0, a, 1, x, b, 1, w, 1, info )
153 CALL chkxer( 'ZGEQLS', infot, nout, lerr, ok )
154 infot = 2
155 CALL zgeqls( 1, 2, 0, a, 1, x, b, 1, w, 1, info )
156 CALL chkxer( 'ZGEQLS', infot, nout, lerr, ok )
157 infot = 3
158 CALL zgeqls( 0, 0, -1, a, 1, x, b, 1, w, 1, info )
159 CALL chkxer( 'ZGEQLS', infot, nout, lerr, ok )
160 infot = 5
161 CALL zgeqls( 2, 1, 0, a, 1, x, b, 2, w, 1, info )
162 CALL chkxer( 'ZGEQLS', infot, nout, lerr, ok )
163 infot = 8
164 CALL zgeqls( 2, 1, 0, a, 2, x, b, 1, w, 1, info )
165 CALL chkxer( 'ZGEQLS', infot, nout, lerr, ok )
166 infot = 10
167 CALL zgeqls( 1, 1, 2, a, 1, x, b, 1, w, 1, info )
168 CALL chkxer( 'ZGEQLS', infot, nout, lerr, ok )
169*
170* ZUNGQL
171*
172 srnamt = 'ZUNGQL'
173 infot = 1
174 CALL zungql( -1, 0, 0, a, 1, x, w, 1, info )
175 CALL chkxer( 'ZUNGQL', infot, nout, lerr, ok )
176 infot = 2
177 CALL zungql( 0, -1, 0, a, 1, x, w, 1, info )
178 CALL chkxer( 'ZUNGQL', infot, nout, lerr, ok )
179 infot = 2
180 CALL zungql( 1, 2, 0, a, 1, x, w, 2, info )
181 CALL chkxer( 'ZUNGQL', infot, nout, lerr, ok )
182 infot = 3
183 CALL zungql( 0, 0, -1, a, 1, x, w, 1, info )
184 CALL chkxer( 'ZUNGQL', infot, nout, lerr, ok )
185 infot = 3
186 CALL zungql( 1, 1, 2, a, 1, x, w, 1, info )
187 CALL chkxer( 'ZUNGQL', infot, nout, lerr, ok )
188 infot = 5
189 CALL zungql( 2, 1, 0, a, 1, x, w, 1, info )
190 CALL chkxer( 'ZUNGQL', infot, nout, lerr, ok )
191 infot = 8
192 CALL zungql( 2, 2, 0, a, 2, x, w, 1, info )
193 CALL chkxer( 'ZUNGQL', infot, nout, lerr, ok )
194*
195* ZUNG2L
196*
197 srnamt = 'ZUNG2L'
198 infot = 1
199 CALL zung2l( -1, 0, 0, a, 1, x, w, info )
200 CALL chkxer( 'ZUNG2L', infot, nout, lerr, ok )
201 infot = 2
202 CALL zung2l( 0, -1, 0, a, 1, x, w, info )
203 CALL chkxer( 'ZUNG2L', infot, nout, lerr, ok )
204 infot = 2
205 CALL zung2l( 1, 2, 0, a, 1, x, w, info )
206 CALL chkxer( 'ZUNG2L', infot, nout, lerr, ok )
207 infot = 3
208 CALL zung2l( 0, 0, -1, a, 1, x, w, info )
209 CALL chkxer( 'ZUNG2L', infot, nout, lerr, ok )
210 infot = 3
211 CALL zung2l( 2, 1, 2, a, 2, x, w, info )
212 CALL chkxer( 'ZUNG2L', infot, nout, lerr, ok )
213 infot = 5
214 CALL zung2l( 2, 1, 0, a, 1, x, w, info )
215 CALL chkxer( 'ZUNG2L', infot, nout, lerr, ok )
216*
217* ZUNMQL
218*
219 srnamt = 'ZUNMQL'
220 infot = 1
221 CALL zunmql( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
222 CALL chkxer( 'ZUNMQL', infot, nout, lerr, ok )
223 infot = 2
224 CALL zunmql( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
225 CALL chkxer( 'ZUNMQL', infot, nout, lerr, ok )
226 infot = 3
227 CALL zunmql( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, 1, info )
228 CALL chkxer( 'ZUNMQL', infot, nout, lerr, ok )
229 infot = 4
230 CALL zunmql( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, 1, info )
231 CALL chkxer( 'ZUNMQL', infot, nout, lerr, ok )
232 infot = 5
233 CALL zunmql( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, 1, info )
234 CALL chkxer( 'ZUNMQL', infot, nout, lerr, ok )
235 infot = 5
236 CALL zunmql( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, 1, info )
237 CALL chkxer( 'ZUNMQL', infot, nout, lerr, ok )
238 infot = 5
239 CALL zunmql( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, 1, info )
240 CALL chkxer( 'ZUNMQL', infot, nout, lerr, ok )
241 infot = 7
242 CALL zunmql( 'L', 'N', 2, 1, 0, a, 1, x, af, 2, w, 1, info )
243 CALL chkxer( 'ZUNMQL', infot, nout, lerr, ok )
244 infot = 7
245 CALL zunmql( 'R', 'N', 1, 2, 0, a, 1, x, af, 1, w, 1, info )
246 CALL chkxer( 'ZUNMQL', infot, nout, lerr, ok )
247 infot = 10
248 CALL zunmql( 'L', 'N', 2, 1, 0, a, 2, x, af, 1, w, 1, info )
249 CALL chkxer( 'ZUNMQL', infot, nout, lerr, ok )
250 infot = 12
251 CALL zunmql( 'L', 'N', 1, 2, 0, a, 1, x, af, 1, w, 1, info )
252 CALL chkxer( 'ZUNMQL', infot, nout, lerr, ok )
253 infot = 12
254 CALL zunmql( 'R', 'N', 2, 1, 0, a, 1, x, af, 2, w, 1, info )
255 CALL chkxer( 'ZUNMQL', infot, nout, lerr, ok )
256*
257* ZUNM2L
258*
259 srnamt = 'ZUNM2L'
260 infot = 1
261 CALL zunm2l( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, info )
262 CALL chkxer( 'ZUNM2L', infot, nout, lerr, ok )
263 infot = 2
264 CALL zunm2l( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, info )
265 CALL chkxer( 'ZUNM2L', infot, nout, lerr, ok )
266 infot = 3
267 CALL zunm2l( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, info )
268 CALL chkxer( 'ZUNM2L', infot, nout, lerr, ok )
269 infot = 4
270 CALL zunm2l( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, info )
271 CALL chkxer( 'ZUNM2L', infot, nout, lerr, ok )
272 infot = 5
273 CALL zunm2l( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, info )
274 CALL chkxer( 'ZUNM2L', infot, nout, lerr, ok )
275 infot = 5
276 CALL zunm2l( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, info )
277 CALL chkxer( 'ZUNM2L', infot, nout, lerr, ok )
278 infot = 5
279 CALL zunm2l( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, info )
280 CALL chkxer( 'ZUNM2L', infot, nout, lerr, ok )
281 infot = 7
282 CALL zunm2l( 'L', 'N', 2, 1, 0, a, 1, x, af, 2, w, info )
283 CALL chkxer( 'ZUNM2L', infot, nout, lerr, ok )
284 infot = 7
285 CALL zunm2l( 'R', 'N', 1, 2, 0, a, 1, x, af, 1, w, info )
286 CALL chkxer( 'ZUNM2L', infot, nout, lerr, ok )
287 infot = 10
288 CALL zunm2l( 'L', 'N', 2, 1, 0, a, 2, x, af, 1, w, info )
289 CALL chkxer( 'ZUNM2L', infot, nout, lerr, ok )
290*
291* Print a summary line.
292*
293 CALL alaesm( path, ok, nout )
294*
295 RETURN
296*
297* End of ZERRQL
298*
zgeql2
subroutine zgeql2(m, n, a, lda, tau, work, info)
ZGEQL2 computes the QL factorization of a general rectangular matrix using an unblocked algorithm.
Definition zgeql2.f:123
zung2l
subroutine zung2l(m, n, k, a, lda, tau, work, info)
ZUNG2L generates all or part of the unitary matrix Q from a QL factorization determined by cgeqlf (un...
Definition zung2l.f:114
zungql
subroutine zungql(m, n, k, a, lda, tau, work, lwork, info)
ZUNGQL
Definition zungql.f:128
zunmql
subroutine zunmql(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
ZUNMQL
Definition zunmql.f:167
zunm2l
subroutine zunm2l(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
ZUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by cgeqlf...
Definition zunm2l.f:159

◆ zerrqp()

subroutine zerrqp ( character*3 path,
integer nunit )

ZERRQP

Purpose:
!>
!> ZERRQP tests the error exits for ZGEQP3.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 53 of file zerrqp.f.

54*
55* -- LAPACK test routine --
56* -- LAPACK is a software package provided by Univ. of Tennessee, --
57* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
58*
59* .. Scalar Arguments ..
60 CHARACTER*3 PATH
61 INTEGER NUNIT
62* ..
63*
64* =====================================================================
65*
66* .. Parameters ..
67 INTEGER NMAX
68 parameter( nmax = 3 )
69* ..
70* .. Local Scalars ..
71 CHARACTER*2 C2
72 INTEGER INFO, LW
73* ..
74* .. Local Arrays ..
75 INTEGER IP( NMAX )
76 DOUBLE PRECISION RW( 2*NMAX )
77 COMPLEX*16 A( NMAX, NMAX ), TAU( NMAX ),
78 $ W( 2*NMAX+3*NMAX )
79* ..
80* .. External Functions ..
81 LOGICAL LSAMEN
82 EXTERNAL lsamen
83* ..
84* .. External Subroutines ..
85 EXTERNAL alaesm, chkxer, zgeqp3
86* ..
87* .. Scalars in Common ..
88 LOGICAL LERR, OK
89 CHARACTER*32 SRNAMT
90 INTEGER INFOT, NOUT
91* ..
92* .. Common blocks ..
93 COMMON / infoc / infot, nout, ok, lerr
94 COMMON / srnamc / srnamt
95* ..
96* .. Intrinsic Functions ..
97 INTRINSIC dcmplx
98* ..
99* .. Executable Statements ..
100*
101 nout = nunit
102 c2 = path( 2: 3 )
103 lw = nmax + 1
104 a( 1, 1 ) = dcmplx( 1.0d+0, -1.0d+0 )
105 a( 1, 2 ) = dcmplx( 2.0d+0, -2.0d+0 )
106 a( 2, 2 ) = dcmplx( 3.0d+0, -3.0d+0 )
107 a( 2, 1 ) = dcmplx( 4.0d+0, -4.0d+0 )
108 ok = .true.
109 WRITE( nout, fmt = * )
110*
111* Test error exits for QR factorization with pivoting
112*
113 IF( lsamen( 2, c2, 'QP' ) ) THEN
114*
115* ZGEQP3
116*
117 srnamt = 'ZGEQP3'
118 infot = 1
119 CALL zgeqp3( -1, 0, a, 1, ip, tau, w, lw, rw, info )
120 CALL chkxer( 'ZGEQP3', infot, nout, lerr, ok )
121 infot = 2
122 CALL zgeqp3( 1, -1, a, 1, ip, tau, w, lw, rw, info )
123 CALL chkxer( 'ZGEQP3', infot, nout, lerr, ok )
124 infot = 4
125 CALL zgeqp3( 2, 3, a, 1, ip, tau, w, lw, rw, info )
126 CALL chkxer( 'ZGEQP3', infot, nout, lerr, ok )
127 infot = 8
128 CALL zgeqp3( 2, 2, a, 2, ip, tau, w, lw-10, rw, info )
129 CALL chkxer( 'ZGEQP3', infot, nout, lerr, ok )
130 END IF
131*
132* Print a summary line.
133*
134 CALL alaesm( path, ok, nout )
135*
136 RETURN
137*
138* End of ZERRQP
139*

◆ zerrqr()

subroutine zerrqr ( character*3 path,
integer nunit )

ZERRQR

Purpose:
!>
!> ZERRQR tests the error exits for the COMPLEX*16 routines
!> that use the QR decomposition of a general matrix.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 54 of file zerrqr.f.

55*
56* -- LAPACK test routine (--
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX
69 parameter( nmax = 2 )
70* ..
71* .. Local Scalars ..
72 INTEGER I, INFO, J
73* ..
74* .. Local Arrays ..
75 COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
76 $ W( NMAX ), X( NMAX )
77* ..
78* .. External Subroutines ..
79 EXTERNAL alaesm, chkxer, zgeqr2, zgeqr2p, zgeqrf,
80 $ zgeqrfp, zgeqrs, zung2r, zungqr, zunm2r,
81 $ zunmqr
82* ..
83* .. Scalars in Common ..
84 LOGICAL LERR, OK
85 CHARACTER*32 SRNAMT
86 INTEGER INFOT, NOUT
87* ..
88* .. Common blocks ..
89 COMMON / infoc / infot, nout, ok, lerr
90 COMMON / srnamc / srnamt
91* ..
92* .. Intrinsic Functions ..
93 INTRINSIC dble, dcmplx
94* ..
95* .. Executable Statements ..
96*
97 nout = nunit
98 WRITE( nout, fmt = * )
99*
100* Set the variables to innocuous values.
101*
102 DO 20 j = 1, nmax
103 DO 10 i = 1, nmax
104 a( i, j ) = dcmplx( 1.d0 / dble( i+j ),
105 $ -1.d0 / dble( i+j ) )
106 af( i, j ) = dcmplx( 1.d0 / dble( i+j ),
107 $ -1.d0 / dble( i+j ) )
108 10 CONTINUE
109 b( j ) = 0.d0
110 w( j ) = 0.d0
111 x( j ) = 0.d0
112 20 CONTINUE
113 ok = .true.
114*
115* Error exits for QR factorization
116*
117* ZGEQRF
118*
119 srnamt = 'ZGEQRF'
120 infot = 1
121 CALL zgeqrf( -1, 0, a, 1, b, w, 1, info )
122 CALL chkxer( 'ZGEQRF', infot, nout, lerr, ok )
123 infot = 2
124 CALL zgeqrf( 0, -1, a, 1, b, w, 1, info )
125 CALL chkxer( 'ZGEQRF', infot, nout, lerr, ok )
126 infot = 4
127 CALL zgeqrf( 2, 1, a, 1, b, w, 1, info )
128 CALL chkxer( 'ZGEQRF', infot, nout, lerr, ok )
129 infot = 7
130 CALL zgeqrf( 1, 2, a, 1, b, w, 1, info )
131 CALL chkxer( 'ZGEQRF', infot, nout, lerr, ok )
132*
133* ZGEQRFP
134*
135 srnamt = 'ZGEQRFP'
136 infot = 1
137 CALL zgeqrfp( -1, 0, a, 1, b, w, 1, info )
138 CALL chkxer( 'ZGEQRFP', infot, nout, lerr, ok )
139 infot = 2
140 CALL zgeqrfp( 0, -1, a, 1, b, w, 1, info )
141 CALL chkxer( 'ZGEQRFP', infot, nout, lerr, ok )
142 infot = 4
143 CALL zgeqrfp( 2, 1, a, 1, b, w, 1, info )
144 CALL chkxer( 'ZGEQRFP', infot, nout, lerr, ok )
145 infot = 7
146 CALL zgeqrfp( 1, 2, a, 1, b, w, 1, info )
147 CALL chkxer( 'ZGEQRFP', infot, nout, lerr, ok )
148*
149* ZGEQR2
150*
151 srnamt = 'ZGEQR2'
152 infot = 1
153 CALL zgeqr2( -1, 0, a, 1, b, w, info )
154 CALL chkxer( 'ZGEQR2', infot, nout, lerr, ok )
155 infot = 2
156 CALL zgeqr2( 0, -1, a, 1, b, w, info )
157 CALL chkxer( 'ZGEQR2', infot, nout, lerr, ok )
158 infot = 4
159 CALL zgeqr2( 2, 1, a, 1, b, w, info )
160 CALL chkxer( 'ZGEQR2', infot, nout, lerr, ok )
161*
162* ZGEQR2P
163*
164 srnamt = 'ZGEQR2P'
165 infot = 1
166 CALL zgeqr2p( -1, 0, a, 1, b, w, info )
167 CALL chkxer( 'ZGEQR2P', infot, nout, lerr, ok )
168 infot = 2
169 CALL zgeqr2p( 0, -1, a, 1, b, w, info )
170 CALL chkxer( 'ZGEQR2P', infot, nout, lerr, ok )
171 infot = 4
172 CALL zgeqr2p( 2, 1, a, 1, b, w, info )
173 CALL chkxer( 'ZGEQR2P', infot, nout, lerr, ok )
174*
175* ZGEQRS
176*
177 srnamt = 'ZGEQRS'
178 infot = 1
179 CALL zgeqrs( -1, 0, 0, a, 1, x, b, 1, w, 1, info )
180 CALL chkxer( 'ZGEQRS', infot, nout, lerr, ok )
181 infot = 2
182 CALL zgeqrs( 0, -1, 0, a, 1, x, b, 1, w, 1, info )
183 CALL chkxer( 'ZGEQRS', infot, nout, lerr, ok )
184 infot = 2
185 CALL zgeqrs( 1, 2, 0, a, 2, x, b, 2, w, 1, info )
186 CALL chkxer( 'ZGEQRS', infot, nout, lerr, ok )
187 infot = 3
188 CALL zgeqrs( 0, 0, -1, a, 1, x, b, 1, w, 1, info )
189 CALL chkxer( 'ZGEQRS', infot, nout, lerr, ok )
190 infot = 5
191 CALL zgeqrs( 2, 1, 0, a, 1, x, b, 2, w, 1, info )
192 CALL chkxer( 'ZGEQRS', infot, nout, lerr, ok )
193 infot = 8
194 CALL zgeqrs( 2, 1, 0, a, 2, x, b, 1, w, 1, info )
195 CALL chkxer( 'ZGEQRS', infot, nout, lerr, ok )
196 infot = 10
197 CALL zgeqrs( 1, 1, 2, a, 1, x, b, 1, w, 1, info )
198 CALL chkxer( 'ZGEQRS', infot, nout, lerr, ok )
199*
200* ZUNGQR
201*
202 srnamt = 'ZUNGQR'
203 infot = 1
204 CALL zungqr( -1, 0, 0, a, 1, x, w, 1, info )
205 CALL chkxer( 'ZUNGQR', infot, nout, lerr, ok )
206 infot = 2
207 CALL zungqr( 0, -1, 0, a, 1, x, w, 1, info )
208 CALL chkxer( 'ZUNGQR', infot, nout, lerr, ok )
209 infot = 2
210 CALL zungqr( 1, 2, 0, a, 1, x, w, 2, info )
211 CALL chkxer( 'ZUNGQR', infot, nout, lerr, ok )
212 infot = 3
213 CALL zungqr( 0, 0, -1, a, 1, x, w, 1, info )
214 CALL chkxer( 'ZUNGQR', infot, nout, lerr, ok )
215 infot = 3
216 CALL zungqr( 1, 1, 2, a, 1, x, w, 1, info )
217 CALL chkxer( 'ZUNGQR', infot, nout, lerr, ok )
218 infot = 5
219 CALL zungqr( 2, 2, 0, a, 1, x, w, 2, info )
220 CALL chkxer( 'ZUNGQR', infot, nout, lerr, ok )
221 infot = 8
222 CALL zungqr( 2, 2, 0, a, 2, x, w, 1, info )
223 CALL chkxer( 'ZUNGQR', infot, nout, lerr, ok )
224*
225* ZUNG2R
226*
227 srnamt = 'ZUNG2R'
228 infot = 1
229 CALL zung2r( -1, 0, 0, a, 1, x, w, info )
230 CALL chkxer( 'ZUNG2R', infot, nout, lerr, ok )
231 infot = 2
232 CALL zung2r( 0, -1, 0, a, 1, x, w, info )
233 CALL chkxer( 'ZUNG2R', infot, nout, lerr, ok )
234 infot = 2
235 CALL zung2r( 1, 2, 0, a, 1, x, w, info )
236 CALL chkxer( 'ZUNG2R', infot, nout, lerr, ok )
237 infot = 3
238 CALL zung2r( 0, 0, -1, a, 1, x, w, info )
239 CALL chkxer( 'ZUNG2R', infot, nout, lerr, ok )
240 infot = 3
241 CALL zung2r( 2, 1, 2, a, 2, x, w, info )
242 CALL chkxer( 'ZUNG2R', infot, nout, lerr, ok )
243 infot = 5
244 CALL zung2r( 2, 1, 0, a, 1, x, w, info )
245 CALL chkxer( 'ZUNG2R', infot, nout, lerr, ok )
246*
247* ZUNMQR
248*
249 srnamt = 'ZUNMQR'
250 infot = 1
251 CALL zunmqr( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
252 CALL chkxer( 'ZUNMQR', infot, nout, lerr, ok )
253 infot = 2
254 CALL zunmqr( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
255 CALL chkxer( 'ZUNMQR', infot, nout, lerr, ok )
256 infot = 3
257 CALL zunmqr( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, 1, info )
258 CALL chkxer( 'ZUNMQR', infot, nout, lerr, ok )
259 infot = 4
260 CALL zunmqr( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, 1, info )
261 CALL chkxer( 'ZUNMQR', infot, nout, lerr, ok )
262 infot = 5
263 CALL zunmqr( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, 1, info )
264 CALL chkxer( 'ZUNMQR', infot, nout, lerr, ok )
265 infot = 5
266 CALL zunmqr( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, 1, info )
267 CALL chkxer( 'ZUNMQR', infot, nout, lerr, ok )
268 infot = 5
269 CALL zunmqr( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, 1, info )
270 CALL chkxer( 'ZUNMQR', infot, nout, lerr, ok )
271 infot = 7
272 CALL zunmqr( 'L', 'N', 2, 1, 0, a, 1, x, af, 2, w, 1, info )
273 CALL chkxer( 'ZUNMQR', infot, nout, lerr, ok )
274 infot = 7
275 CALL zunmqr( 'R', 'N', 1, 2, 0, a, 1, x, af, 1, w, 1, info )
276 CALL chkxer( 'ZUNMQR', infot, nout, lerr, ok )
277 infot = 10
278 CALL zunmqr( 'L', 'N', 2, 1, 0, a, 2, x, af, 1, w, 1, info )
279 CALL chkxer( 'ZUNMQR', infot, nout, lerr, ok )
280 infot = 12
281 CALL zunmqr( 'L', 'N', 1, 2, 0, a, 1, x, af, 1, w, 1, info )
282 CALL chkxer( 'ZUNMQR', infot, nout, lerr, ok )
283 infot = 12
284 CALL zunmqr( 'R', 'N', 2, 1, 0, a, 1, x, af, 2, w, 1, info )
285 CALL chkxer( 'ZUNMQR', infot, nout, lerr, ok )
286*
287* ZUNM2R
288*
289 srnamt = 'ZUNM2R'
290 infot = 1
291 CALL zunm2r( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, info )
292 CALL chkxer( 'ZUNM2R', infot, nout, lerr, ok )
293 infot = 2
294 CALL zunm2r( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, info )
295 CALL chkxer( 'ZUNM2R', infot, nout, lerr, ok )
296 infot = 3
297 CALL zunm2r( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, info )
298 CALL chkxer( 'ZUNM2R', infot, nout, lerr, ok )
299 infot = 4
300 CALL zunm2r( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, info )
301 CALL chkxer( 'ZUNM2R', infot, nout, lerr, ok )
302 infot = 5
303 CALL zunm2r( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, info )
304 CALL chkxer( 'ZUNM2R', infot, nout, lerr, ok )
305 infot = 5
306 CALL zunm2r( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, info )
307 CALL chkxer( 'ZUNM2R', infot, nout, lerr, ok )
308 infot = 5
309 CALL zunm2r( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, info )
310 CALL chkxer( 'ZUNM2R', infot, nout, lerr, ok )
311 infot = 7
312 CALL zunm2r( 'L', 'N', 2, 1, 0, a, 1, x, af, 2, w, info )
313 CALL chkxer( 'ZUNM2R', infot, nout, lerr, ok )
314 infot = 7
315 CALL zunm2r( 'R', 'N', 1, 2, 0, a, 1, x, af, 1, w, info )
316 CALL chkxer( 'ZUNM2R', infot, nout, lerr, ok )
317 infot = 10
318 CALL zunm2r( 'L', 'N', 2, 1, 0, a, 2, x, af, 1, w, info )
319 CALL chkxer( 'ZUNM2R', infot, nout, lerr, ok )
320*
321* Print a summary line.
322*
323 CALL alaesm( path, ok, nout )
324*
325 RETURN
326*
327* End of ZERRQR
328*
zgeqrfp
subroutine zgeqrfp(m, n, a, lda, tau, work, lwork, info)
ZGEQRFP
Definition zgeqrfp.f:149
zgeqr2p
subroutine zgeqr2p(m, n, a, lda, tau, work, info)
ZGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagonal elem...
Definition zgeqr2p.f:134
zunm2r
subroutine zunm2r(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf...
Definition zunm2r.f:159
zunmqr
subroutine zunmqr(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
ZUNMQR
Definition zunmqr.f:167
zungqr
subroutine zungqr(m, n, k, a, lda, tau, work, lwork, info)
ZUNGQR
Definition zungqr.f:128
zung2r
subroutine zung2r(m, n, k, a, lda, tau, work, info)
ZUNG2R
Definition zung2r.f:114

◆ zerrqrt()

subroutine zerrqrt ( character*3 path,
integer nunit )

ZERRQRT

Purpose:
!>
!> ZERRQRT tests the error exits for the COMPLEX*16 routines
!> that use the QRT decomposition of a general matrix.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 54 of file zerrqrt.f.

55 IMPLICIT NONE
56*
57* -- LAPACK test routine --
58* -- LAPACK is a software package provided by Univ. of Tennessee, --
59* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
60*
61* .. Scalar Arguments ..
62 CHARACTER*3 PATH
63 INTEGER NUNIT
64* ..
65*
66* =====================================================================
67*
68* .. Parameters ..
69 INTEGER NMAX
70 parameter( nmax = 2 )
71* ..
72* .. Local Scalars ..
73 INTEGER I, INFO, J
74* ..
75* .. Local Arrays ..
76 COMPLEX*16 A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
77 $ C( NMAX, NMAX )
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, zgeqrt2, zgeqrt3, zgeqrt,
81 $ zgemqrt
82* ..
83* .. Scalars in Common ..
84 LOGICAL LERR, OK
85 CHARACTER*32 SRNAMT
86 INTEGER INFOT, NOUT
87* ..
88* .. Common blocks ..
89 COMMON / infoc / infot, nout, ok, lerr
90 COMMON / srnamc / srnamt
91* ..
92* .. Intrinsic Functions ..
93 INTRINSIC dble, dcmplx
94* ..
95* .. Executable Statements ..
96*
97 nout = nunit
98 WRITE( nout, fmt = * )
99*
100* Set the variables to innocuous values.
101*
102 DO j = 1, nmax
103 DO i = 1, nmax
104 a( i, j ) = 1.d0 / dcmplx( dble( i+j ), 0.d0 )
105 c( i, j ) = 1.d0 / dcmplx( dble( i+j ), 0.d0 )
106 t( i, j ) = 1.d0 / dcmplx( dble( i+j ), 0.d0 )
107 END DO
108 w( j ) = 0.d0
109 END DO
110 ok = .true.
111*
112* Error exits for QRT factorization
113*
114* ZGEQRT
115*
116 srnamt = 'ZGEQRT'
117 infot = 1
118 CALL zgeqrt( -1, 0, 1, a, 1, t, 1, w, info )
119 CALL chkxer( 'ZGEQRT', infot, nout, lerr, ok )
120 infot = 2
121 CALL zgeqrt( 0, -1, 1, a, 1, t, 1, w, info )
122 CALL chkxer( 'ZGEQRT', infot, nout, lerr, ok )
123 infot = 3
124 CALL zgeqrt( 0, 0, 0, a, 1, t, 1, w, info )
125 CALL chkxer( 'ZGEQRT', infot, nout, lerr, ok )
126 infot = 5
127 CALL zgeqrt( 2, 1, 1, a, 1, t, 1, w, info )
128 CALL chkxer( 'ZGEQRT', infot, nout, lerr, ok )
129 infot = 7
130 CALL zgeqrt( 2, 2, 2, a, 2, t, 1, w, info )
131 CALL chkxer( 'ZGEQRT', infot, nout, lerr, ok )
132*
133* ZGEQRT2
134*
135 srnamt = 'ZGEQRT2'
136 infot = 1
137 CALL zgeqrt2( -1, 0, a, 1, t, 1, info )
138 CALL chkxer( 'ZGEQRT2', infot, nout, lerr, ok )
139 infot = 2
140 CALL zgeqrt2( 0, -1, a, 1, t, 1, info )
141 CALL chkxer( 'ZGEQRT2', infot, nout, lerr, ok )
142 infot = 4
143 CALL zgeqrt2( 2, 1, a, 1, t, 1, info )
144 CALL chkxer( 'ZGEQRT2', infot, nout, lerr, ok )
145 infot = 6
146 CALL zgeqrt2( 2, 2, a, 2, t, 1, info )
147 CALL chkxer( 'ZGEQRT2', infot, nout, lerr, ok )
148*
149* ZGEQRT3
150*
151 srnamt = 'ZGEQRT3'
152 infot = 1
153 CALL zgeqrt3( -1, 0, a, 1, t, 1, info )
154 CALL chkxer( 'ZGEQRT3', infot, nout, lerr, ok )
155 infot = 2
156 CALL zgeqrt3( 0, -1, a, 1, t, 1, info )
157 CALL chkxer( 'ZGEQRT3', infot, nout, lerr, ok )
158 infot = 4
159 CALL zgeqrt3( 2, 1, a, 1, t, 1, info )
160 CALL chkxer( 'ZGEQRT3', infot, nout, lerr, ok )
161 infot = 6
162 CALL zgeqrt3( 2, 2, a, 2, t, 1, info )
163 CALL chkxer( 'ZGEQRT3', infot, nout, lerr, ok )
164*
165* ZGEMQRT
166*
167 srnamt = 'ZGEMQRT'
168 infot = 1
169 CALL zgemqrt( '/', 'N', 0, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
170 CALL chkxer( 'ZGEMQRT', infot, nout, lerr, ok )
171 infot = 2
172 CALL zgemqrt( 'L', '/', 0, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
173 CALL chkxer( 'ZGEMQRT', infot, nout, lerr, ok )
174 infot = 3
175 CALL zgemqrt( 'L', 'N', -1, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
176 CALL chkxer( 'ZGEMQRT', infot, nout, lerr, ok )
177 infot = 4
178 CALL zgemqrt( 'L', 'N', 0, -1, 0, 1, a, 1, t, 1, c, 1, w, info )
179 CALL chkxer( 'ZGEMQRT', infot, nout, lerr, ok )
180 infot = 5
181 CALL zgemqrt( 'L', 'N', 0, 0, -1, 1, a, 1, t, 1, c, 1, w, info )
182 CALL chkxer( 'ZGEMQRT', infot, nout, lerr, ok )
183 infot = 5
184 CALL zgemqrt( 'R', 'N', 0, 0, -1, 1, a, 1, t, 1, c, 1, w, info )
185 CALL chkxer( 'ZGEMQRT', infot, nout, lerr, ok )
186 infot = 6
187 CALL zgemqrt( 'L', 'N', 0, 0, 0, 0, a, 1, t, 1, c, 1, w, info )
188 CALL chkxer( 'ZGEMQRT', infot, nout, lerr, ok )
189 infot = 8
190 CALL zgemqrt( 'R', 'N', 1, 2, 1, 1, a, 1, t, 1, c, 1, w, info )
191 CALL chkxer( 'ZGEMQRT', infot, nout, lerr, ok )
192 infot = 8
193 CALL zgemqrt( 'L', 'N', 2, 1, 1, 1, a, 1, t, 1, c, 1, w, info )
194 CALL chkxer( 'ZGEMQRT', infot, nout, lerr, ok )
195 infot = 10
196 CALL zgemqrt( 'R', 'N', 1, 1, 1, 1, a, 1, t, 0, c, 1, w, info )
197 CALL chkxer( 'ZGEMQRT', infot, nout, lerr, ok )
198 infot = 12
199 CALL zgemqrt( 'L', 'N', 1, 1, 1, 1, a, 1, t, 1, c, 0, w, info )
200 CALL chkxer( 'ZGEMQRT', infot, nout, lerr, ok )
201*
202* Print a summary line.
203*
204 CALL alaesm( path, ok, nout )
205*
206 RETURN
207*
208* End of ZERRQRT
209*
zgeqrt3
recursive subroutine zgeqrt3(m, n, a, lda, t, ldt, info)
ZGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact...
Definition zgeqrt3.f:132
zgeqrt
subroutine zgeqrt(m, n, nb, a, lda, t, ldt, work, info)
ZGEQRT
Definition zgeqrt.f:141
zgemqrt
subroutine zgemqrt(side, trans, m, n, k, nb, v, ldv, t, ldt, c, ldc, work, info)
ZGEMQRT
Definition zgemqrt.f:168
zgeqrt2
subroutine zgeqrt2(m, n, a, lda, t, ldt, info)
ZGEQRT2 computes a QR factorization of a general real or complex matrix using the compact WY represen...
Definition zgeqrt2.f:127

◆ zerrqrtp()

subroutine zerrqrtp ( character*3 path,
integer nunit )

ZERRQRTP

Purpose:
!>
!> ZERRQRTP tests the error exits for the COMPLEX*16 routines
!> that use the QRT decomposition of a triangular-pentagonal matrix.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 54 of file zerrqrtp.f.

55 IMPLICIT NONE
56*
57* -- LAPACK test routine --
58* -- LAPACK is a software package provided by Univ. of Tennessee, --
59* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
60*
61* .. Scalar Arguments ..
62 CHARACTER*3 PATH
63 INTEGER NUNIT
64* ..
65*
66* =====================================================================
67*
68* .. Parameters ..
69 INTEGER NMAX
70 parameter( nmax = 2 )
71* ..
72* .. Local Scalars ..
73 INTEGER I, INFO, J
74* ..
75* .. Local Arrays ..
76 COMPLEX*16 A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
77 $ B( NMAX, NMAX ), C( NMAX, NMAX )
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, ztpqrt2, ztpqrt,
81 $ ztpmqrt
82* ..
83* .. Scalars in Common ..
84 LOGICAL LERR, OK
85 CHARACTER*32 SRNAMT
86 INTEGER INFOT, NOUT
87* ..
88* .. Common blocks ..
89 COMMON / infoc / infot, nout, ok, lerr
90 COMMON / srnamc / srnamt
91* ..
92* .. Intrinsic Functions ..
93 INTRINSIC dble, dcmplx
94* ..
95* .. Executable Statements ..
96*
97 nout = nunit
98 WRITE( nout, fmt = * )
99*
100* Set the variables to innocuous values.
101*
102 DO j = 1, nmax
103 DO i = 1, nmax
104 a( i, j ) = 1.d0 / dcmplx(dble( i+j ),0.d0)
105 c( i, j ) = 1.d0 / dcmplx(dble( i+j ),0.d0)
106 t( i, j ) = 1.d0 / dcmplx(dble( i+j ),0.d0)
107 END DO
108 w( j ) = dcmplx(0.d0,0.d0)
109 END DO
110 ok = .true.
111*
112* Error exits for TPQRT factorization
113*
114* ZTPQRT
115*
116 srnamt = 'ZTPQRT'
117 infot = 1
118 CALL ztpqrt( -1, 1, 0, 1, a, 1, b, 1, t, 1, w, info )
119 CALL chkxer( 'ZTPQRT', infot, nout, lerr, ok )
120 infot = 2
121 CALL ztpqrt( 1, -1, 0, 1, a, 1, b, 1, t, 1, w, info )
122 CALL chkxer( 'ZTPQRT', infot, nout, lerr, ok )
123 infot = 3
124 CALL ztpqrt( 0, 1, -1, 1, a, 1, b, 1, t, 1, w, info )
125 CALL chkxer( 'ZTPQRT', infot, nout, lerr, ok )
126 infot = 3
127 CALL ztpqrt( 0, 1, 1, 1, a, 1, b, 1, t, 1, w, info )
128 CALL chkxer( 'ZTPQRT', infot, nout, lerr, ok )
129 infot = 4
130 CALL ztpqrt( 0, 1, 0, 0, a, 1, b, 1, t, 1, w, info )
131 CALL chkxer( 'ZTPQRT', infot, nout, lerr, ok )
132 infot = 4
133 CALL ztpqrt( 0, 1, 0, 2, a, 1, b, 1, t, 1, w, info )
134 CALL chkxer( 'ZTPQRT', infot, nout, lerr, ok )
135 infot = 6
136 CALL ztpqrt( 1, 2, 0, 2, a, 1, b, 1, t, 1, w, info )
137 CALL chkxer( 'ZTPQRT', infot, nout, lerr, ok )
138 infot = 8
139 CALL ztpqrt( 2, 1, 0, 1, a, 1, b, 1, t, 1, w, info )
140 CALL chkxer( 'ZTPQRT', infot, nout, lerr, ok )
141 infot = 10
142 CALL ztpqrt( 2, 2, 1, 2, a, 2, b, 2, t, 1, w, info )
143 CALL chkxer( 'ZTPQRT', infot, nout, lerr, ok )
144*
145* ZTPQRT2
146*
147 srnamt = 'ZTPQRT2'
148 infot = 1
149 CALL ztpqrt2( -1, 0, 0, a, 1, b, 1, t, 1, info )
150 CALL chkxer( 'ZTPQRT2', infot, nout, lerr, ok )
151 infot = 2
152 CALL ztpqrt2( 0, -1, 0, a, 1, b, 1, t, 1, info )
153 CALL chkxer( 'ZTPQRT2', infot, nout, lerr, ok )
154 infot = 3
155 CALL ztpqrt2( 0, 0, -1, a, 1, b, 1, t, 1, info )
156 CALL chkxer( 'ZTPQRT2', infot, nout, lerr, ok )
157 infot = 5
158 CALL ztpqrt2( 2, 2, 0, a, 1, b, 2, t, 2, info )
159 CALL chkxer( 'ZTPQRT2', infot, nout, lerr, ok )
160 infot = 7
161 CALL ztpqrt2( 2, 2, 0, a, 2, b, 1, t, 2, info )
162 CALL chkxer( 'ZTPQRT2', infot, nout, lerr, ok )
163 infot = 9
164 CALL ztpqrt2( 2, 2, 0, a, 2, b, 2, t, 1, info )
165 CALL chkxer( 'ZTPQRT2', infot, nout, lerr, ok )
166*
167* ZTPMQRT
168*
169 srnamt = 'ZTPMQRT'
170 infot = 1
171 CALL ztpmqrt( '/', 'N', 0, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
172 $ w, info )
173 CALL chkxer( 'ZTPMQRT', infot, nout, lerr, ok )
174 infot = 2
175 CALL ztpmqrt( 'L', '/', 0, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
176 $ w, info )
177 CALL chkxer( 'ZTPMQRT', infot, nout, lerr, ok )
178 infot = 3
179 CALL ztpmqrt( 'L', 'N', -1, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
180 $ w, info )
181 CALL chkxer( 'ZTPMQRT', infot, nout, lerr, ok )
182 infot = 4
183 CALL ztpmqrt( 'L', 'N', 0, -1, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
184 $ w, info )
185 CALL chkxer( 'ZTPMQRT', infot, nout, lerr, ok )
186 infot = 5
187 CALL ztpmqrt( 'L', 'N', 0, 0, -1, 0, 1, a, 1, t, 1, b, 1, c, 1,
188 $ w, info )
189 infot = 6
190 CALL ztpmqrt( 'L', 'N', 0, 0, 0, -1, 1, a, 1, t, 1, b, 1, c, 1,
191 $ w, info )
192 CALL chkxer( 'ZTPMQRT', infot, nout, lerr, ok )
193 infot = 7
194 CALL ztpmqrt( 'L', 'N', 0, 0, 0, 0, 0, a, 1, t, 1, b, 1, c, 1,
195 $ w, info )
196 CALL chkxer( 'ZTPMQRT', infot, nout, lerr, ok )
197 infot = 9
198 CALL ztpmqrt( 'R', 'N', 1, 2, 1, 1, 1, a, 1, t, 1, b, 1, c, 1,
199 $ w, info )
200 CALL chkxer( 'ZTPMQRT', infot, nout, lerr, ok )
201 infot = 9
202 CALL ztpmqrt( 'L', 'N', 2, 1, 1, 1, 1, a, 1, t, 1, b, 1, c, 1,
203 $ w, info )
204 CALL chkxer( 'ZTPMQRT', infot, nout, lerr, ok )
205 infot = 11
206 CALL ztpmqrt( 'R', 'N', 1, 1, 1, 1, 1, a, 1, t, 0, b, 1, c, 1,
207 $ w, info )
208 CALL chkxer( 'ZTPMQRT', infot, nout, lerr, ok )
209 infot = 13
210 CALL ztpmqrt( 'L', 'N', 1, 1, 1, 1, 1, a, 1, t, 1, b, 0, c, 1,
211 $ w, info )
212 CALL chkxer( 'ZTPMQRT', infot, nout, lerr, ok )
213 infot = 15
214 CALL ztpmqrt( 'L', 'N', 1, 1, 1, 1, 1, a, 1, t, 1, b, 1, c, 0,
215 $ w, info )
216 CALL chkxer( 'ZTPMQRT', infot, nout, lerr, ok )
217*
218* Print a summary line.
219*
220 CALL alaesm( path, ok, nout )
221*
222 RETURN
223*
224* End of ZERRQRTP
225*
ztpmqrt
subroutine ztpmqrt(side, trans, m, n, k, l, nb, v, ldv, t, ldt, a, lda, b, ldb, work, info)
ZTPMQRT
Definition ztpmqrt.f:216
ztpqrt
subroutine ztpqrt(m, n, l, nb, a, lda, b, ldb, t, ldt, work, info)
ZTPQRT
Definition ztpqrt.f:189
ztpqrt2
subroutine ztpqrt2(m, n, l, a, lda, b, ldb, t, ldt, info)
ZTPQRT2 computes a QR factorization of a real or complex "triangular-pentagonal" matrix,...
Definition ztpqrt2.f:173

◆ zerrrfp()

subroutine zerrrfp ( integer nunit)

ZERRRFP

Purpose:
!>
!> ZERRRFP tests the error exits for the COMPLEX*16 driver routines
!> for solving linear systems of equations.
!>
!> ZDRVRFP tests the COMPLEX*16 LAPACK RFP routines:
!>     ZTFSM, ZTFTRI, ZHFRK, ZTFTTP, ZTFTTR, ZPFTRF, ZPFTRS, ZTPTTF,
!>     ZTPTTR, ZTRTTF, and ZTRTTP
!>
Parameters
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 51 of file zerrrfp.f.

52*
53* -- LAPACK test routine --
54* -- LAPACK is a software package provided by Univ. of Tennessee, --
55* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
56*
57* .. Scalar Arguments ..
58 INTEGER NUNIT
59* ..
60*
61* =====================================================================
62*
63* ..
64* .. Local Scalars ..
65 INTEGER INFO
66 DOUBLE PRECISION ALPHA, BETA
67 COMPLEX*16 CALPHA
68* ..
69* .. Local Arrays ..
70 COMPLEX*16 A( 1, 1), B( 1, 1)
71* ..
72* .. External Subroutines ..
73 EXTERNAL chkxer, ztfsm, ztftri, zhfrk, ztfttp, ztfttr,
74 + zpftri, zpftrf, zpftrs, ztpttf, ztpttr, ztrttf,
75 + ztrttp
76* ..
77* .. Scalars in Common ..
78 LOGICAL LERR, OK
79 CHARACTER*32 SRNAMT
80 INTEGER INFOT, NOUT
81* ..
82* .. Intrinsic Functions ..
83 INTRINSIC dcmplx
84* ..
85* .. Common blocks ..
86 COMMON / infoc / infot, nout, ok, lerr
87 COMMON / srnamc / srnamt
88* ..
89* .. Executable Statements ..
90*
91 nout = nunit
92 ok = .true.
93 a( 1, 1 ) = dcmplx( 1.0d0 , 1.0d0 )
94 b( 1, 1 ) = dcmplx( 1.0d0 , 1.0d0 )
95 alpha = 1.0d0
96 calpha = dcmplx( 1.0d0 , 1.0d0 )
97 beta = 1.0d0
98*
99 srnamt = 'ZPFTRF'
100 infot = 1
101 CALL zpftrf( '/', 'U', 0, a, info )
102 CALL chkxer( 'ZPFTRF', infot, nout, lerr, ok )
103 infot = 2
104 CALL zpftrf( 'N', '/', 0, a, info )
105 CALL chkxer( 'ZPFTRF', infot, nout, lerr, ok )
106 infot = 3
107 CALL zpftrf( 'N', 'U', -1, a, info )
108 CALL chkxer( 'ZPFTRF', infot, nout, lerr, ok )
109*
110 srnamt = 'ZPFTRS'
111 infot = 1
112 CALL zpftrs( '/', 'U', 0, 0, a, b, 1, info )
113 CALL chkxer( 'ZPFTRS', infot, nout, lerr, ok )
114 infot = 2
115 CALL zpftrs( 'N', '/', 0, 0, a, b, 1, info )
116 CALL chkxer( 'ZPFTRS', infot, nout, lerr, ok )
117 infot = 3
118 CALL zpftrs( 'N', 'U', -1, 0, a, b, 1, info )
119 CALL chkxer( 'ZPFTRS', infot, nout, lerr, ok )
120 infot = 4
121 CALL zpftrs( 'N', 'U', 0, -1, a, b, 1, info )
122 CALL chkxer( 'ZPFTRS', infot, nout, lerr, ok )
123 infot = 7
124 CALL zpftrs( 'N', 'U', 0, 0, a, b, 0, info )
125 CALL chkxer( 'ZPFTRS', infot, nout, lerr, ok )
126*
127 srnamt = 'ZPFTRI'
128 infot = 1
129 CALL zpftri( '/', 'U', 0, a, info )
130 CALL chkxer( 'ZPFTRI', infot, nout, lerr, ok )
131 infot = 2
132 CALL zpftri( 'N', '/', 0, a, info )
133 CALL chkxer( 'ZPFTRI', infot, nout, lerr, ok )
134 infot = 3
135 CALL zpftri( 'N', 'U', -1, a, info )
136 CALL chkxer( 'ZPFTRI', infot, nout, lerr, ok )
137*
138 srnamt = 'ZTFSM '
139 infot = 1
140 CALL ztfsm( '/', 'L', 'U', 'C', 'U', 0, 0, calpha, a, b, 1 )
141 CALL chkxer( 'ZTFSM ', infot, nout, lerr, ok )
142 infot = 2
143 CALL ztfsm( 'N', '/', 'U', 'C', 'U', 0, 0, calpha, a, b, 1 )
144 CALL chkxer( 'ZTFSM ', infot, nout, lerr, ok )
145 infot = 3
146 CALL ztfsm( 'N', 'L', '/', 'C', 'U', 0, 0, calpha, a, b, 1 )
147 CALL chkxer( 'ZTFSM ', infot, nout, lerr, ok )
148 infot = 4
149 CALL ztfsm( 'N', 'L', 'U', '/', 'U', 0, 0, calpha, a, b, 1 )
150 CALL chkxer( 'ZTFSM ', infot, nout, lerr, ok )
151 infot = 5
152 CALL ztfsm( 'N', 'L', 'U', 'C', '/', 0, 0, calpha, a, b, 1 )
153 CALL chkxer( 'ZTFSM ', infot, nout, lerr, ok )
154 infot = 6
155 CALL ztfsm( 'N', 'L', 'U', 'C', 'U', -1, 0, calpha, a, b, 1 )
156 CALL chkxer( 'ZTFSM ', infot, nout, lerr, ok )
157 infot = 7
158 CALL ztfsm( 'N', 'L', 'U', 'C', 'U', 0, -1, calpha, a, b, 1 )
159 CALL chkxer( 'ZTFSM ', infot, nout, lerr, ok )
160 infot = 11
161 CALL ztfsm( 'N', 'L', 'U', 'C', 'U', 0, 0, calpha, a, b, 0 )
162 CALL chkxer( 'ZTFSM ', infot, nout, lerr, ok )
163*
164 srnamt = 'ZTFTRI'
165 infot = 1
166 CALL ztftri( '/', 'L', 'N', 0, a, info )
167 CALL chkxer( 'ZTFTRI', infot, nout, lerr, ok )
168 infot = 2
169 CALL ztftri( 'N', '/', 'N', 0, a, info )
170 CALL chkxer( 'ZTFTRI', infot, nout, lerr, ok )
171 infot = 3
172 CALL ztftri( 'N', 'L', '/', 0, a, info )
173 CALL chkxer( 'ZTFTRI', infot, nout, lerr, ok )
174 infot = 4
175 CALL ztftri( 'N', 'L', 'N', -1, a, info )
176 CALL chkxer( 'ZTFTRI', infot, nout, lerr, ok )
177*
178 srnamt = 'ZTFTTR'
179 infot = 1
180 CALL ztfttr( '/', 'U', 0, a, b, 1, info )
181 CALL chkxer( 'ZTFTTR', infot, nout, lerr, ok )
182 infot = 2
183 CALL ztfttr( 'N', '/', 0, a, b, 1, info )
184 CALL chkxer( 'ZTFTTR', infot, nout, lerr, ok )
185 infot = 3
186 CALL ztfttr( 'N', 'U', -1, a, b, 1, info )
187 CALL chkxer( 'ZTFTTR', infot, nout, lerr, ok )
188 infot = 6
189 CALL ztfttr( 'N', 'U', 0, a, b, 0, info )
190 CALL chkxer( 'ZTFTTR', infot, nout, lerr, ok )
191*
192 srnamt = 'ZTRTTF'
193 infot = 1
194 CALL ztrttf( '/', 'U', 0, a, 1, b, info )
195 CALL chkxer( 'ZTRTTF', infot, nout, lerr, ok )
196 infot = 2
197 CALL ztrttf( 'N', '/', 0, a, 1, b, info )
198 CALL chkxer( 'ZTRTTF', infot, nout, lerr, ok )
199 infot = 3
200 CALL ztrttf( 'N', 'U', -1, a, 1, b, info )
201 CALL chkxer( 'ZTRTTF', infot, nout, lerr, ok )
202 infot = 5
203 CALL ztrttf( 'N', 'U', 0, a, 0, b, info )
204 CALL chkxer( 'ZTRTTF', infot, nout, lerr, ok )
205*
206 srnamt = 'ZTFTTP'
207 infot = 1
208 CALL ztfttp( '/', 'U', 0, a, b, info )
209 CALL chkxer( 'ZTFTTP', infot, nout, lerr, ok )
210 infot = 2
211 CALL ztfttp( 'N', '/', 0, a, b, info )
212 CALL chkxer( 'ZTFTTP', infot, nout, lerr, ok )
213 infot = 3
214 CALL ztfttp( 'N', 'U', -1, a, b, info )
215 CALL chkxer( 'ZTFTTP', infot, nout, lerr, ok )
216*
217 srnamt = 'ZTPTTF'
218 infot = 1
219 CALL ztpttf( '/', 'U', 0, a, b, info )
220 CALL chkxer( 'ZTPTTF', infot, nout, lerr, ok )
221 infot = 2
222 CALL ztpttf( 'N', '/', 0, a, b, info )
223 CALL chkxer( 'ZTPTTF', infot, nout, lerr, ok )
224 infot = 3
225 CALL ztpttf( 'N', 'U', -1, a, b, info )
226 CALL chkxer( 'ZTPTTF', infot, nout, lerr, ok )
227*
228 srnamt = 'ZTRTTP'
229 infot = 1
230 CALL ztrttp( '/', 0, a, 1, b, info )
231 CALL chkxer( 'ZTRTTP', infot, nout, lerr, ok )
232 infot = 2
233 CALL ztrttp( 'U', -1, a, 1, b, info )
234 CALL chkxer( 'ZTRTTP', infot, nout, lerr, ok )
235 infot = 4
236 CALL ztrttp( 'U', 0, a, 0, b, info )
237 CALL chkxer( 'ZTRTTP', infot, nout, lerr, ok )
238*
239 srnamt = 'ZTPTTR'
240 infot = 1
241 CALL ztpttr( '/', 0, a, b, 1, info )
242 CALL chkxer( 'ZTPTTR', infot, nout, lerr, ok )
243 infot = 2
244 CALL ztpttr( 'U', -1, a, b, 1, info )
245 CALL chkxer( 'ZTPTTR', infot, nout, lerr, ok )
246 infot = 5
247 CALL ztpttr( 'U', 0, a, b, 0, info )
248 CALL chkxer( 'ZTPTTR', infot, nout, lerr, ok )
249*
250 srnamt = 'ZHFRK '
251 infot = 1
252 CALL zhfrk( '/', 'U', 'N', 0, 0, alpha, a, 1, beta, b )
253 CALL chkxer( 'ZHFRK ', infot, nout, lerr, ok )
254 infot = 2
255 CALL zhfrk( 'N', '/', 'N', 0, 0, alpha, a, 1, beta, b )
256 CALL chkxer( 'ZHFRK ', infot, nout, lerr, ok )
257 infot = 3
258 CALL zhfrk( 'N', 'U', '/', 0, 0, alpha, a, 1, beta, b )
259 CALL chkxer( 'ZHFRK ', infot, nout, lerr, ok )
260 infot = 4
261 CALL zhfrk( 'N', 'U', 'N', -1, 0, alpha, a, 1, beta, b )
262 CALL chkxer( 'ZHFRK ', infot, nout, lerr, ok )
263 infot = 5
264 CALL zhfrk( 'N', 'U', 'N', 0, -1, alpha, a, 1, beta, b )
265 CALL chkxer( 'ZHFRK ', infot, nout, lerr, ok )
266 infot = 8
267 CALL zhfrk( 'N', 'U', 'N', 0, 0, alpha, a, 0, beta, b )
268 CALL chkxer( 'ZHFRK ', infot, nout, lerr, ok )
269*
270* Print a summary line.
271*
272 IF( ok ) THEN
273 WRITE( nout, fmt = 9999 )
274 ELSE
275 WRITE( nout, fmt = 9998 )
276 END IF
277*
278 9999 FORMAT( 1x, 'COMPLEX*16 RFP routines passed the tests of the ',
279 $ 'error exits' )
280 9998 FORMAT( ' *** RFP routines failed the tests of the error ',
281 $ 'exits ***' )
282 RETURN
283*
284* End of ZERRRFP
285*
ztftri
subroutine ztftri(transr, uplo, diag, n, a, info)
ZTFTRI
Definition ztftri.f:221

◆ zerrrq()

subroutine zerrrq ( character*3 path,
integer nunit )

ZERRRQ

Purpose:
!>
!> ZERRRQ tests the error exits for the COMPLEX*16 routines
!> that use the RQ decomposition of a general matrix.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 54 of file zerrrq.f.

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX
69 parameter( nmax = 2 )
70* ..
71* .. Local Scalars ..
72 INTEGER I, INFO, J
73* ..
74* .. Local Arrays ..
75 COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
76 $ W( NMAX ), X( NMAX )
77* ..
78* .. External Subroutines ..
79 EXTERNAL alaesm, chkxer, zgerq2, zgerqf, zgerqs, zungr2,
80 $ zungrq, zunmr2, zunmrq
81* ..
82* .. Scalars in Common ..
83 LOGICAL LERR, OK
84 CHARACTER*32 SRNAMT
85 INTEGER INFOT, NOUT
86* ..
87* .. Common blocks ..
88 COMMON / infoc / infot, nout, ok, lerr
89 COMMON / srnamc / srnamt
90* ..
91* .. Intrinsic Functions ..
92 INTRINSIC dble, dcmplx
93* ..
94* .. Executable Statements ..
95*
96 nout = nunit
97 WRITE( nout, fmt = * )
98*
99* Set the variables to innocuous values.
100*
101 DO 20 j = 1, nmax
102 DO 10 i = 1, nmax
103 a( i, j ) = dcmplx( 1.d0 / dble( i+j ),
104 $ -1.d0 / dble( i+j ) )
105 af( i, j ) = dcmplx( 1.d0 / dble( i+j ),
106 $ -1.d0 / dble( i+j ) )
107 10 CONTINUE
108 b( j ) = 0.d0
109 w( j ) = 0.d0
110 x( j ) = 0.d0
111 20 CONTINUE
112 ok = .true.
113*
114* Error exits for RQ factorization
115*
116* ZGERQF
117*
118 srnamt = 'ZGERQF'
119 infot = 1
120 CALL zgerqf( -1, 0, a, 1, b, w, 1, info )
121 CALL chkxer( 'ZGERQF', infot, nout, lerr, ok )
122 infot = 2
123 CALL zgerqf( 0, -1, a, 1, b, w, 1, info )
124 CALL chkxer( 'ZGERQF', infot, nout, lerr, ok )
125 infot = 4
126 CALL zgerqf( 2, 1, a, 1, b, w, 2, info )
127 CALL chkxer( 'ZGERQF', infot, nout, lerr, ok )
128 infot = 7
129 CALL zgerqf( 2, 1, a, 2, b, w, 1, info )
130 CALL chkxer( 'ZGERQF', infot, nout, lerr, ok )
131*
132* ZGERQ2
133*
134 srnamt = 'ZGERQ2'
135 infot = 1
136 CALL zgerq2( -1, 0, a, 1, b, w, info )
137 CALL chkxer( 'ZGERQ2', infot, nout, lerr, ok )
138 infot = 2
139 CALL zgerq2( 0, -1, a, 1, b, w, info )
140 CALL chkxer( 'ZGERQ2', infot, nout, lerr, ok )
141 infot = 4
142 CALL zgerq2( 2, 1, a, 1, b, w, info )
143 CALL chkxer( 'ZGERQ2', infot, nout, lerr, ok )
144*
145* ZGERQS
146*
147 srnamt = 'ZGERQS'
148 infot = 1
149 CALL zgerqs( -1, 0, 0, a, 1, x, b, 1, w, 1, info )
150 CALL chkxer( 'ZGERQS', infot, nout, lerr, ok )
151 infot = 2
152 CALL zgerqs( 0, -1, 0, a, 1, x, b, 1, w, 1, info )
153 CALL chkxer( 'ZGERQS', infot, nout, lerr, ok )
154 infot = 2
155 CALL zgerqs( 2, 1, 0, a, 2, x, b, 1, w, 1, info )
156 CALL chkxer( 'ZGERQS', infot, nout, lerr, ok )
157 infot = 3
158 CALL zgerqs( 0, 0, -1, a, 1, x, b, 1, w, 1, info )
159 CALL chkxer( 'ZGERQS', infot, nout, lerr, ok )
160 infot = 5
161 CALL zgerqs( 2, 2, 0, a, 1, x, b, 2, w, 1, info )
162 CALL chkxer( 'ZGERQS', infot, nout, lerr, ok )
163 infot = 8
164 CALL zgerqs( 2, 2, 0, a, 2, x, b, 1, w, 1, info )
165 CALL chkxer( 'ZGERQS', infot, nout, lerr, ok )
166 infot = 10
167 CALL zgerqs( 1, 1, 2, a, 1, x, b, 1, w, 1, info )
168 CALL chkxer( 'ZGERQS', infot, nout, lerr, ok )
169*
170* ZUNGRQ
171*
172 srnamt = 'ZUNGRQ'
173 infot = 1
174 CALL zungrq( -1, 0, 0, a, 1, x, w, 1, info )
175 CALL chkxer( 'ZUNGRQ', infot, nout, lerr, ok )
176 infot = 2
177 CALL zungrq( 0, -1, 0, a, 1, x, w, 1, info )
178 CALL chkxer( 'ZUNGRQ', infot, nout, lerr, ok )
179 infot = 2
180 CALL zungrq( 2, 1, 0, a, 2, x, w, 2, info )
181 CALL chkxer( 'ZUNGRQ', infot, nout, lerr, ok )
182 infot = 3
183 CALL zungrq( 0, 0, -1, a, 1, x, w, 1, info )
184 CALL chkxer( 'ZUNGRQ', infot, nout, lerr, ok )
185 infot = 3
186 CALL zungrq( 1, 2, 2, a, 1, x, w, 1, info )
187 CALL chkxer( 'ZUNGRQ', infot, nout, lerr, ok )
188 infot = 5
189 CALL zungrq( 2, 2, 0, a, 1, x, w, 2, info )
190 CALL chkxer( 'ZUNGRQ', infot, nout, lerr, ok )
191 infot = 8
192 CALL zungrq( 2, 2, 0, a, 2, x, w, 1, info )
193 CALL chkxer( 'ZUNGRQ', infot, nout, lerr, ok )
194*
195* ZUNGR2
196*
197 srnamt = 'ZUNGR2'
198 infot = 1
199 CALL zungr2( -1, 0, 0, a, 1, x, w, info )
200 CALL chkxer( 'ZUNGR2', infot, nout, lerr, ok )
201 infot = 2
202 CALL zungr2( 0, -1, 0, a, 1, x, w, info )
203 CALL chkxer( 'ZUNGR2', infot, nout, lerr, ok )
204 infot = 2
205 CALL zungr2( 2, 1, 0, a, 2, x, w, info )
206 CALL chkxer( 'ZUNGR2', infot, nout, lerr, ok )
207 infot = 3
208 CALL zungr2( 0, 0, -1, a, 1, x, w, info )
209 CALL chkxer( 'ZUNGR2', infot, nout, lerr, ok )
210 infot = 3
211 CALL zungr2( 1, 2, 2, a, 2, x, w, info )
212 CALL chkxer( 'ZUNGR2', infot, nout, lerr, ok )
213 infot = 5
214 CALL zungr2( 2, 2, 0, a, 1, x, w, info )
215 CALL chkxer( 'ZUNGR2', infot, nout, lerr, ok )
216*
217* ZUNMRQ
218*
219 srnamt = 'ZUNMRQ'
220 infot = 1
221 CALL zunmrq( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
222 CALL chkxer( 'ZUNMRQ', infot, nout, lerr, ok )
223 infot = 2
224 CALL zunmrq( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
225 CALL chkxer( 'ZUNMRQ', infot, nout, lerr, ok )
226 infot = 3
227 CALL zunmrq( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, 1, info )
228 CALL chkxer( 'ZUNMRQ', infot, nout, lerr, ok )
229 infot = 4
230 CALL zunmrq( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, 1, info )
231 CALL chkxer( 'ZUNMRQ', infot, nout, lerr, ok )
232 infot = 5
233 CALL zunmrq( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, 1, info )
234 CALL chkxer( 'ZUNMRQ', infot, nout, lerr, ok )
235 infot = 5
236 CALL zunmrq( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, 1, info )
237 CALL chkxer( 'ZUNMRQ', infot, nout, lerr, ok )
238 infot = 5
239 CALL zunmrq( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, 1, info )
240 CALL chkxer( 'ZUNMRQ', infot, nout, lerr, ok )
241 infot = 7
242 CALL zunmrq( 'L', 'N', 2, 1, 2, a, 1, x, af, 2, w, 1, info )
243 CALL chkxer( 'ZUNMRQ', infot, nout, lerr, ok )
244 infot = 7
245 CALL zunmrq( 'R', 'N', 1, 2, 2, a, 1, x, af, 1, w, 1, info )
246 CALL chkxer( 'ZUNMRQ', infot, nout, lerr, ok )
247 infot = 10
248 CALL zunmrq( 'L', 'N', 2, 1, 0, a, 1, x, af, 1, w, 1, info )
249 CALL chkxer( 'ZUNMRQ', infot, nout, lerr, ok )
250 infot = 12
251 CALL zunmrq( 'L', 'N', 1, 2, 0, a, 1, x, af, 1, w, 1, info )
252 CALL chkxer( 'ZUNMRQ', infot, nout, lerr, ok )
253 infot = 12
254 CALL zunmrq( 'R', 'N', 2, 1, 0, a, 1, x, af, 2, w, 1, info )
255 CALL chkxer( 'ZUNMRQ', infot, nout, lerr, ok )
256*
257* ZUNMR2
258*
259 srnamt = 'ZUNMR2'
260 infot = 1
261 CALL zunmr2( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, info )
262 CALL chkxer( 'ZUNMR2', infot, nout, lerr, ok )
263 infot = 2
264 CALL zunmr2( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, info )
265 CALL chkxer( 'ZUNMR2', infot, nout, lerr, ok )
266 infot = 3
267 CALL zunmr2( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, info )
268 CALL chkxer( 'ZUNMR2', infot, nout, lerr, ok )
269 infot = 4
270 CALL zunmr2( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, info )
271 CALL chkxer( 'ZUNMR2', infot, nout, lerr, ok )
272 infot = 5
273 CALL zunmr2( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, info )
274 CALL chkxer( 'ZUNMR2', infot, nout, lerr, ok )
275 infot = 5
276 CALL zunmr2( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, info )
277 CALL chkxer( 'ZUNMR2', infot, nout, lerr, ok )
278 infot = 5
279 CALL zunmr2( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, info )
280 CALL chkxer( 'ZUNMR2', infot, nout, lerr, ok )
281 infot = 7
282 CALL zunmr2( 'L', 'N', 2, 1, 2, a, 1, x, af, 2, w, info )
283 CALL chkxer( 'ZUNMR2', infot, nout, lerr, ok )
284 infot = 7
285 CALL zunmr2( 'R', 'N', 1, 2, 2, a, 1, x, af, 1, w, info )
286 CALL chkxer( 'ZUNMR2', infot, nout, lerr, ok )
287 infot = 10
288 CALL zunmr2( 'L', 'N', 2, 1, 0, a, 1, x, af, 1, w, info )
289 CALL chkxer( 'ZUNMR2', infot, nout, lerr, ok )
290*
291* Print a summary line.
292*
293 CALL alaesm( path, ok, nout )
294*
295 RETURN
296*
297* End of ZERRRQ
298*
zgerq2
subroutine zgerq2(m, n, a, lda, tau, work, info)
ZGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm.
Definition zgerq2.f:123
zgerqf
subroutine zgerqf(m, n, a, lda, tau, work, lwork, info)
ZGERQF
Definition zgerqf.f:139
zungrq
subroutine zungrq(m, n, k, a, lda, tau, work, lwork, info)
ZUNGRQ
Definition zungrq.f:128
zungr2
subroutine zungr2(m, n, k, a, lda, tau, work, info)
ZUNGR2 generates all or part of the unitary matrix Q from an RQ factorization determined by cgerqf (u...
Definition zungr2.f:114
zunmr2
subroutine zunmr2(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
ZUNMR2 multiplies a general matrix by the unitary matrix from a RQ factorization determined by cgerqf...
Definition zunmr2.f:159
zunmrq
subroutine zunmrq(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
ZUNMRQ
Definition zunmrq.f:167

◆ zerrsy()

subroutine zerrsy ( character*3 path,
integer nunit )

ZERRSY

ZERRSYX

Purpose:
!>
!> ZERRSY tests the error exits for the COMPLEX*16 routines
!> for symmetric indefinite matrices.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Purpose:
!>
!> ZERRSY tests the error exits for the COMPLEX*16 routines
!> for symmetric indefinite matrices.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise zerrsy.f defines this subroutine.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 54 of file zerrsy.f.

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX
69 parameter( nmax = 4 )
70* ..
71* .. Local Scalars ..
72 CHARACTER*2 C2
73 INTEGER I, INFO, J
74 DOUBLE PRECISION ANRM, RCOND
75* ..
76* .. Local Arrays ..
77 INTEGER IP( NMAX )
78 DOUBLE PRECISION R( NMAX ), R1( NMAX ), R2( NMAX )
79 COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
80 $ E( NMAX ), W( 2*NMAX ), X( NMAX )
81* ..
82* .. External Functions ..
83 LOGICAL LSAMEN
84 EXTERNAL lsamen
85* ..
86* .. External Subroutines ..
87 EXTERNAL alaesm, chkxer, zspcon, zsprfs, zsptrf, zsptri,
88 $ zsptrs, zsycon, zsycon_3, zsycon_rook, zsyrfs,
89 $ zsytf2, zsytf2_rk, zsytf2_rook, zsytrf,
90 $ zsytrf_rk, zsytrf_rook, zsytri, zsytri_3,
91 $ zsytri_3x, zsytri_rook, zsytri2, zsytri2x,
92 $ zsytrs, zsytrs_3, zsytrs_rook
93* ..
94* .. Scalars in Common ..
95 LOGICAL LERR, OK
96 CHARACTER*32 SRNAMT
97 INTEGER INFOT, NOUT
98* ..
99* .. Common blocks ..
100 COMMON / infoc / infot, nout, ok, lerr
101 COMMON / srnamc / srnamt
102* ..
103* .. Intrinsic Functions ..
104 INTRINSIC dble, dcmplx
105* ..
106* .. Executable Statements ..
107*
108 nout = nunit
109 WRITE( nout, fmt = * )
110 c2 = path( 2: 3 )
111*
112* Set the variables to innocuous values.
113*
114 DO 20 j = 1, nmax
115 DO 10 i = 1, nmax
116 a( i, j ) = dcmplx( 1.d0 / dble( i+j ),
117 $ -1.d0 / dble( i+j ) )
118 af( i, j ) = dcmplx( 1.d0 / dble( i+j ),
119 $ -1.d0 / dble( i+j ) )
120 10 CONTINUE
121 b( j ) = 0.d0
122 e( j ) = 0.d0
123 r1( j ) = 0.d0
124 r2( j ) = 0.d0
125 w( j ) = 0.d0
126 x( j ) = 0.d0
127 ip( j ) = j
128 20 CONTINUE
129 anrm = 1.0d0
130 ok = .true.
131*
132 IF( lsamen( 2, c2, 'SY' ) ) THEN
133*
134* Test error exits of the routines that use factorization
135* of a symmetric indefinite matrix with patrial
136* (Bunch-Kaufman) diagonal pivoting method.
137*
138* ZSYTRF
139*
140 srnamt = 'ZSYTRF'
141 infot = 1
142 CALL zsytrf( '/', 0, a, 1, ip, w, 1, info )
143 CALL chkxer( 'ZSYTRF', infot, nout, lerr, ok )
144 infot = 2
145 CALL zsytrf( 'U', -1, a, 1, ip, w, 1, info )
146 CALL chkxer( 'ZSYTRF', infot, nout, lerr, ok )
147 infot = 4
148 CALL zsytrf( 'U', 2, a, 1, ip, w, 4, info )
149 CALL chkxer( 'ZSYTRF', infot, nout, lerr, ok )
150 infot = 7
151 CALL zsytrf( 'U', 0, a, 1, ip, w, 0, info )
152 CALL chkxer( 'ZSYTRF', infot, nout, lerr, ok )
153 infot = 7
154 CALL zsytrf( 'U', 0, a, 1, ip, w, -2, info )
155 CALL chkxer( 'ZSYTRF', infot, nout, lerr, ok )
156*
157* ZSYTF2
158*
159 srnamt = 'ZSYTF2'
160 infot = 1
161 CALL zsytf2( '/', 0, a, 1, ip, info )
162 CALL chkxer( 'ZSYTF2', infot, nout, lerr, ok )
163 infot = 2
164 CALL zsytf2( 'U', -1, a, 1, ip, info )
165 CALL chkxer( 'ZSYTF2', infot, nout, lerr, ok )
166 infot = 4
167 CALL zsytf2( 'U', 2, a, 1, ip, info )
168 CALL chkxer( 'ZSYTF2', infot, nout, lerr, ok )
169*
170* ZSYTRI
171*
172 srnamt = 'ZSYTRI'
173 infot = 1
174 CALL zsytri( '/', 0, a, 1, ip, w, info )
175 CALL chkxer( 'ZSYTRI', infot, nout, lerr, ok )
176 infot = 2
177 CALL zsytri( 'U', -1, a, 1, ip, w, info )
178 CALL chkxer( 'ZSYTRI', infot, nout, lerr, ok )
179 infot = 4
180 CALL zsytri( 'U', 2, a, 1, ip, w, info )
181 CALL chkxer( 'ZSYTRI', infot, nout, lerr, ok )
182*
183* ZSYTRI2
184*
185 srnamt = 'ZSYTRI2'
186 infot = 1
187 CALL zsytri2( '/', 0, a, 1, ip, w, 1, info )
188 CALL chkxer( 'ZSYTRI2', infot, nout, lerr, ok )
189 infot = 2
190 CALL zsytri2( 'U', -1, a, 1, ip, w, 1, info )
191 CALL chkxer( 'ZSYTRI2', infot, nout, lerr, ok )
192 infot = 4
193 CALL zsytri2( 'U', 2, a, 1, ip, w, 1, info )
194 CALL chkxer( 'ZSYTRI2', infot, nout, lerr, ok )
195*
196* ZSYTRI2X
197*
198 srnamt = 'ZSYTRI2X'
199 infot = 1
200 CALL zsytri2x( '/', 0, a, 1, ip, w, 1, info )
201 CALL chkxer( 'ZSYTRI2X', infot, nout, lerr, ok )
202 infot = 2
203 CALL zsytri2x( 'U', -1, a, 1, ip, w, 1, info )
204 CALL chkxer( 'ZSYTRI2X', infot, nout, lerr, ok )
205 infot = 4
206 CALL zsytri2x( 'U', 2, a, 1, ip, w, 1, info )
207 CALL chkxer( 'ZSYTRI2X', infot, nout, lerr, ok )
208*
209* ZSYTRS
210*
211 srnamt = 'ZSYTRS'
212 infot = 1
213 CALL zsytrs( '/', 0, 0, a, 1, ip, b, 1, info )
214 CALL chkxer( 'ZSYTRS', infot, nout, lerr, ok )
215 infot = 2
216 CALL zsytrs( 'U', -1, 0, a, 1, ip, b, 1, info )
217 CALL chkxer( 'ZSYTRS', infot, nout, lerr, ok )
218 infot = 3
219 CALL zsytrs( 'U', 0, -1, a, 1, ip, b, 1, info )
220 CALL chkxer( 'ZSYTRS', infot, nout, lerr, ok )
221 infot = 5
222 CALL zsytrs( 'U', 2, 1, a, 1, ip, b, 2, info )
223 CALL chkxer( 'ZSYTRS', infot, nout, lerr, ok )
224 infot = 8
225 CALL zsytrs( 'U', 2, 1, a, 2, ip, b, 1, info )
226 CALL chkxer( 'ZSYTRS', infot, nout, lerr, ok )
227*
228* ZSYRFS
229*
230 srnamt = 'ZSYRFS'
231 infot = 1
232 CALL zsyrfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
233 $ r, info )
234 CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
235 infot = 2
236 CALL zsyrfs( 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
237 $ w, r, info )
238 CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
239 infot = 3
240 CALL zsyrfs( 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
241 $ w, r, info )
242 CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
243 infot = 5
244 CALL zsyrfs( 'U', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
245 $ r, info )
246 CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
247 infot = 7
248 CALL zsyrfs( 'U', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
249 $ r, info )
250 CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
251 infot = 10
252 CALL zsyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
253 $ r, info )
254 CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
255 infot = 12
256 CALL zsyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
257 $ r, info )
258 CALL chkxer( 'ZSYRFS', infot, nout, lerr, ok )
259*
260* ZSYCON
261*
262 srnamt = 'ZSYCON'
263 infot = 1
264 CALL zsycon( '/', 0, a, 1, ip, anrm, rcond, w, info )
265 CALL chkxer( 'ZSYCON', infot, nout, lerr, ok )
266 infot = 2
267 CALL zsycon( 'U', -1, a, 1, ip, anrm, rcond, w, info )
268 CALL chkxer( 'ZSYCON', infot, nout, lerr, ok )
269 infot = 4
270 CALL zsycon( 'U', 2, a, 1, ip, anrm, rcond, w, info )
271 CALL chkxer( 'ZSYCON', infot, nout, lerr, ok )
272 infot = 6
273 CALL zsycon( 'U', 1, a, 1, ip, -anrm, rcond, w, info )
274 CALL chkxer( 'ZSYCON', infot, nout, lerr, ok )
275*
276 ELSE IF( lsamen( 2, c2, 'SR' ) ) THEN
277*
278* Test error exits of the routines that use factorization
279* of a symmetric indefinite matrix with rook
280* (bounded Bunch-Kaufman) diagonal pivoting method.
281*
282* ZSYTRF_ROOK
283*
284 srnamt = 'ZSYTRF_ROOK'
285 infot = 1
286 CALL zsytrf_rook( '/', 0, a, 1, ip, w, 1, info )
287 CALL chkxer( 'ZSYTRF_ROOK', infot, nout, lerr, ok )
288 infot = 2
289 CALL zsytrf_rook( 'U', -1, a, 1, ip, w, 1, info )
290 CALL chkxer( 'ZSYTRF_ROOK', infot, nout, lerr, ok )
291 infot = 4
292 CALL zsytrf_rook( 'U', 2, a, 1, ip, w, 4, info )
293 CALL chkxer( 'ZSYTRF_ROOK', infot, nout, lerr, ok )
294 infot = 7
295 CALL zsytrf_rook( 'U', 0, a, 1, ip, w, 0, info )
296 CALL chkxer( 'ZSYTRF_ROOK', infot, nout, lerr, ok )
297 infot = 7
298 CALL zsytrf_rook( 'U', 0, a, 1, ip, w, -2, info )
299 CALL chkxer( 'ZSYTRF_ROOK', infot, nout, lerr, ok )
300*
301* ZSYTF2_ROOK
302*
303 srnamt = 'ZSYTF2_ROOK'
304 infot = 1
305 CALL zsytf2_rook( '/', 0, a, 1, ip, info )
306 CALL chkxer( 'ZSYTF2_ROOK', infot, nout, lerr, ok )
307 infot = 2
308 CALL zsytf2_rook( 'U', -1, a, 1, ip, info )
309 CALL chkxer( 'ZSYTF2_ROOK', infot, nout, lerr, ok )
310 infot = 4
311 CALL zsytf2_rook( 'U', 2, a, 1, ip, info )
312 CALL chkxer( 'ZSYTF2_ROOK', infot, nout, lerr, ok )
313*
314* ZSYTRI_ROOK
315*
316 srnamt = 'ZSYTRI_ROOK'
317 infot = 1
318 CALL zsytri_rook( '/', 0, a, 1, ip, w, info )
319 CALL chkxer( 'ZSYTRI_ROOK', infot, nout, lerr, ok )
320 infot = 2
321 CALL zsytri_rook( 'U', -1, a, 1, ip, w, info )
322 CALL chkxer( 'ZSYTRI_ROOK', infot, nout, lerr, ok )
323 infot = 4
324 CALL zsytri_rook( 'U', 2, a, 1, ip, w, info )
325 CALL chkxer( 'ZSYTRI_ROOK', infot, nout, lerr, ok )
326*
327* ZSYTRS_ROOK
328*
329 srnamt = 'ZSYTRS_ROOK'
330 infot = 1
331 CALL zsytrs_rook( '/', 0, 0, a, 1, ip, b, 1, info )
332 CALL chkxer( 'ZSYTRS_ROOK', infot, nout, lerr, ok )
333 infot = 2
334 CALL zsytrs_rook( 'U', -1, 0, a, 1, ip, b, 1, info )
335 CALL chkxer( 'ZSYTRS_ROOK', infot, nout, lerr, ok )
336 infot = 3
337 CALL zsytrs_rook( 'U', 0, -1, a, 1, ip, b, 1, info )
338 CALL chkxer( 'ZSYTRS_ROOK', infot, nout, lerr, ok )
339 infot = 5
340 CALL zsytrs_rook( 'U', 2, 1, a, 1, ip, b, 2, info )
341 CALL chkxer( 'ZSYTRS_ROOK', infot, nout, lerr, ok )
342 infot = 8
343 CALL zsytrs_rook( 'U', 2, 1, a, 2, ip, b, 1, info )
344 CALL chkxer( 'ZSYTRS_ROOK', infot, nout, lerr, ok )
345*
346* ZSYCON_ROOK
347*
348 srnamt = 'ZSYCON_ROOK'
349 infot = 1
350 CALL zsycon_rook( '/', 0, a, 1, ip, anrm, rcond, w, info )
351 CALL chkxer( 'ZSYCON_ROOK', infot, nout, lerr, ok )
352 infot = 2
353 CALL zsycon_rook( 'U', -1, a, 1, ip, anrm, rcond, w, info )
354 CALL chkxer( 'ZSYCON_ROOK', infot, nout, lerr, ok )
355 infot = 4
356 CALL zsycon_rook( 'U', 2, a, 1, ip, anrm, rcond, w, info )
357 CALL chkxer( 'ZSYCON_ROOK', infot, nout, lerr, ok )
358 infot = 6
359 CALL zsycon_rook( 'U', 1, a, 1, ip, -anrm, rcond, w, info )
360 CALL chkxer( 'ZSYCON_ROOK', infot, nout, lerr, ok )
361*
362 ELSE IF( lsamen( 2, c2, 'SK' ) ) THEN
363*
364* Test error exits of the routines that use factorization
365* of a symmetric indefinite matrix with rook
366* (bounded Bunch-Kaufman) pivoting with the new storage
367* format for factors L ( or U) and D.
368*
369* L (or U) is stored in A, diagonal of D is stored on the
370* diagonal of A, subdiagonal of D is stored in a separate array E.
371*
372* ZSYTRF_RK
373*
374 srnamt = 'ZSYTRF_RK'
375 infot = 1
376 CALL zsytrf_rk( '/', 0, a, 1, e, ip, w, 1, info )
377 CALL chkxer( 'ZSYTRF_RK', infot, nout, lerr, ok )
378 infot = 2
379 CALL zsytrf_rk( 'U', -1, a, 1, e, ip, w, 1, info )
380 CALL chkxer( 'ZSYTRF_RK', infot, nout, lerr, ok )
381 infot = 4
382 CALL zsytrf_rk( 'U', 2, a, 1, e, ip, w, 4, info )
383 CALL chkxer( 'ZSYTRF_RK', infot, nout, lerr, ok )
384 infot = 8
385 CALL zsytrf_rk( 'U', 0, a, 1, e, ip, w, 0, info )
386 CALL chkxer( 'ZSYTRF_RK', infot, nout, lerr, ok )
387 infot = 8
388 CALL zsytrf_rk( 'U', 0, a, 1, e, ip, w, -2, info )
389 CALL chkxer( 'ZSYTRF_RK', infot, nout, lerr, ok )
390*
391* ZSYTF2_RK
392*
393 srnamt = 'ZSYTF2_RK'
394 infot = 1
395 CALL zsytf2_rk( '/', 0, a, 1, e, ip, info )
396 CALL chkxer( 'ZSYTF2_RK', infot, nout, lerr, ok )
397 infot = 2
398 CALL zsytf2_rk( 'U', -1, a, 1, e, ip, info )
399 CALL chkxer( 'ZSYTF2_RK', infot, nout, lerr, ok )
400 infot = 4
401 CALL zsytf2_rk( 'U', 2, a, 1, e, ip, info )
402 CALL chkxer( 'ZSYTF2_RK', infot, nout, lerr, ok )
403*
404* ZSYTRI_3
405*
406 srnamt = 'ZSYTRI_3'
407 infot = 1
408 CALL zsytri_3( '/', 0, a, 1, e, ip, w, 1, info )
409 CALL chkxer( 'ZSYTRI_3', infot, nout, lerr, ok )
410 infot = 2
411 CALL zsytri_3( 'U', -1, a, 1, e, ip, w, 1, info )
412 CALL chkxer( 'ZSYTRI_3', infot, nout, lerr, ok )
413 infot = 4
414 CALL zsytri_3( 'U', 2, a, 1, e, ip, w, 1, info )
415 CALL chkxer( 'ZSYTRI_3', infot, nout, lerr, ok )
416 infot = 8
417 CALL zsytri_3( 'U', 0, a, 1, e, ip, w, 0, info )
418 CALL chkxer( 'ZSYTRI_3', infot, nout, lerr, ok )
419 infot = 8
420 CALL zsytri_3( 'U', 0, a, 1, e, ip, w, -2, info )
421 CALL chkxer( 'ZSYTRI_3', infot, nout, lerr, ok )
422*
423* ZSYTRI_3X
424*
425 srnamt = 'ZSYTRI_3X'
426 infot = 1
427 CALL zsytri_3x( '/', 0, a, 1, e, ip, w, 1, info )
428 CALL chkxer( 'ZSYTRI_3X', infot, nout, lerr, ok )
429 infot = 2
430 CALL zsytri_3x( 'U', -1, a, 1, e, ip, w, 1, info )
431 CALL chkxer( 'ZSYTRI_3X', infot, nout, lerr, ok )
432 infot = 4
433 CALL zsytri_3x( 'U', 2, a, 1, e, ip, w, 1, info )
434 CALL chkxer( 'ZSYTRI_3X', infot, nout, lerr, ok )
435*
436* ZSYTRS_3
437*
438 srnamt = 'ZSYTRS_3'
439 infot = 1
440 CALL zsytrs_3( '/', 0, 0, a, 1, e, ip, b, 1, info )
441 CALL chkxer( 'ZSYTRS_3', infot, nout, lerr, ok )
442 infot = 2
443 CALL zsytrs_3( 'U', -1, 0, a, 1, e, ip, b, 1, info )
444 CALL chkxer( 'ZSYTRS_3', infot, nout, lerr, ok )
445 infot = 3
446 CALL zsytrs_3( 'U', 0, -1, a, 1, e, ip, b, 1, info )
447 CALL chkxer( 'ZSYTRS_3', infot, nout, lerr, ok )
448 infot = 5
449 CALL zsytrs_3( 'U', 2, 1, a, 1, e, ip, b, 2, info )
450 CALL chkxer( 'ZSYTRS_3', infot, nout, lerr, ok )
451 infot = 9
452 CALL zsytrs_3( 'U', 2, 1, a, 2, e, ip, b, 1, info )
453 CALL chkxer( 'ZSYTRS_3', infot, nout, lerr, ok )
454*
455* ZSYCON_3
456*
457 srnamt = 'ZSYCON_3'
458 infot = 1
459 CALL zsycon_3( '/', 0, a, 1, e, ip, anrm, rcond, w, info )
460 CALL chkxer( 'ZSYCON_3', infot, nout, lerr, ok )
461 infot = 2
462 CALL zsycon_3( 'U', -1, a, 1, e, ip, anrm, rcond, w, info )
463 CALL chkxer( 'ZSYCON_3', infot, nout, lerr, ok )
464 infot = 4
465 CALL zsycon_3( 'U', 2, a, 1, e, ip, anrm, rcond, w, info )
466 CALL chkxer( 'ZSYCON_3', infot, nout, lerr, ok )
467 infot = 7
468 CALL zsycon_3( 'U', 1, a, 1, e, ip, -1.0d0, rcond, w, info)
469 CALL chkxer( 'ZSYCON_3', infot, nout, lerr, ok )
470*
471 ELSE IF( lsamen( 2, c2, 'SP' ) ) THEN
472*
473* Test error exits of the routines that use factorization
474* of a symmetric indefinite packed matrix with patrial
475* (Bunch-Kaufman) pivoting.
476*
477* ZSPTRF
478*
479 srnamt = 'ZSPTRF'
480 infot = 1
481 CALL zsptrf( '/', 0, a, ip, info )
482 CALL chkxer( 'ZSPTRF', infot, nout, lerr, ok )
483 infot = 2
484 CALL zsptrf( 'U', -1, a, ip, info )
485 CALL chkxer( 'ZSPTRF', infot, nout, lerr, ok )
486*
487* ZSPTRI
488*
489 srnamt = 'ZSPTRI'
490 infot = 1
491 CALL zsptri( '/', 0, a, ip, w, info )
492 CALL chkxer( 'ZSPTRI', infot, nout, lerr, ok )
493 infot = 2
494 CALL zsptri( 'U', -1, a, ip, w, info )
495 CALL chkxer( 'ZSPTRI', infot, nout, lerr, ok )
496*
497* ZSPTRS
498*
499 srnamt = 'ZSPTRS'
500 infot = 1
501 CALL zsptrs( '/', 0, 0, a, ip, b, 1, info )
502 CALL chkxer( 'ZSPTRS', infot, nout, lerr, ok )
503 infot = 2
504 CALL zsptrs( 'U', -1, 0, a, ip, b, 1, info )
505 CALL chkxer( 'ZSPTRS', infot, nout, lerr, ok )
506 infot = 3
507 CALL zsptrs( 'U', 0, -1, a, ip, b, 1, info )
508 CALL chkxer( 'ZSPTRS', infot, nout, lerr, ok )
509 infot = 7
510 CALL zsptrs( 'U', 2, 1, a, ip, b, 1, info )
511 CALL chkxer( 'ZSPTRS', infot, nout, lerr, ok )
512*
513* ZSPRFS
514*
515 srnamt = 'ZSPRFS'
516 infot = 1
517 CALL zsprfs( '/', 0, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
518 $ info )
519 CALL chkxer( 'ZSPRFS', infot, nout, lerr, ok )
520 infot = 2
521 CALL zsprfs( 'U', -1, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
522 $ info )
523 CALL chkxer( 'ZSPRFS', infot, nout, lerr, ok )
524 infot = 3
525 CALL zsprfs( 'U', 0, -1, a, af, ip, b, 1, x, 1, r1, r2, w, r,
526 $ info )
527 CALL chkxer( 'ZSPRFS', infot, nout, lerr, ok )
528 infot = 8
529 CALL zsprfs( 'U', 2, 1, a, af, ip, b, 1, x, 2, r1, r2, w, r,
530 $ info )
531 CALL chkxer( 'ZSPRFS', infot, nout, lerr, ok )
532 infot = 10
533 CALL zsprfs( 'U', 2, 1, a, af, ip, b, 2, x, 1, r1, r2, w, r,
534 $ info )
535 CALL chkxer( 'ZSPRFS', infot, nout, lerr, ok )
536*
537* ZSPCON
538*
539 srnamt = 'ZSPCON'
540 infot = 1
541 CALL zspcon( '/', 0, a, ip, anrm, rcond, w, info )
542 CALL chkxer( 'ZSPCON', infot, nout, lerr, ok )
543 infot = 2
544 CALL zspcon( 'U', -1, a, ip, anrm, rcond, w, info )
545 CALL chkxer( 'ZSPCON', infot, nout, lerr, ok )
546 infot = 5
547 CALL zspcon( 'U', 1, a, ip, -anrm, rcond, w, info )
548 CALL chkxer( 'ZSPCON', infot, nout, lerr, ok )
549*
550 ELSE IF( lsamen( 2, c2, 'SA' ) ) THEN
551*
552* Test error exits of the routines that use factorization
553* of a symmetric indefinite matrix with Aasen's algorithm.
554*
555* ZSYTRF_AA
556*
557 srnamt = 'ZSYTRF_AA'
558 infot = 1
559 CALL zsytrf_aa( '/', 0, a, 1, ip, w, 1, info )
560 CALL chkxer( 'ZSYTRF_AA', infot, nout, lerr, ok )
561 infot = 2
562 CALL zsytrf_aa( 'U', -1, a, 1, ip, w, 1, info )
563 CALL chkxer( 'ZSYTRF_AA', infot, nout, lerr, ok )
564 infot = 4
565 CALL zsytrf_aa( 'U', 2, a, 1, ip, w, 4, info )
566 CALL chkxer( 'ZSYTRF_AA', infot, nout, lerr, ok )
567 infot = 7
568 CALL zsytrf_aa( 'U', 0, a, 1, ip, w, 0, info )
569 CALL chkxer( 'ZSYTRF_AA', infot, nout, lerr, ok )
570 infot = 7
571 CALL zsytrf_aa( 'U', 0, a, 1, ip, w, -2, info )
572 CALL chkxer( 'ZSYTRF_AA', infot, nout, lerr, ok )
573*
574* ZSYTRS_AA
575*
576 srnamt = 'ZSYTRS_AA'
577 infot = 1
578 CALL zsytrs_aa( '/', 0, 0, a, 1, ip, b, 1, w, 1, info )
579 CALL chkxer( 'ZSYTRS_AA', infot, nout, lerr, ok )
580 infot = 2
581 CALL zsytrs_aa( 'U', -1, 0, a, 1, ip, b, 1, w, 1, info )
582 CALL chkxer( 'ZSYTRS_AA', infot, nout, lerr, ok )
583 infot = 3
584 CALL zsytrs_aa( 'U', 0, -1, a, 1, ip, b, 1, w, 1, info )
585 CALL chkxer( 'ZSYTRS_AA', infot, nout, lerr, ok )
586 infot = 5
587 CALL zsytrs_aa( 'U', 2, 1, a, 1, ip, b, 2, w, 1, info )
588 CALL chkxer( 'ZSYTRS_AA', infot, nout, lerr, ok )
589 infot = 8
590 CALL zsytrs_aa( 'U', 2, 1, a, 2, ip, b, 1, w, 1, info )
591 CALL chkxer( 'ZSYTRS_AA', infot, nout, lerr, ok )
592*
593 ELSE IF( lsamen( 2, c2, 'S2' ) ) THEN
594*
595* Test error exits of the routines that use factorization
596* of a symmetric indefinite matrix with Aasen's algorithm.
597*
598* ZSYTRF_AA_2STAGE
599*
600 srnamt = 'ZSYTRF_AA_2STAGE'
601 infot = 1
602 CALL zsytrf_aa_2stage( '/', 0, a, 1, a, 1, ip, ip, w, 1,
603 $ info )
604 CALL chkxer( 'ZSYTRF_AA_2STAGE', infot, nout, lerr, ok )
605 infot = 2
606 CALL zsytrf_aa_2stage( 'U', -1, a, 1, a, 1, ip, ip, w, 1,
607 $ info )
608 CALL chkxer( 'ZSYTRF_AA_2STAGE', infot, nout, lerr, ok )
609 infot = 4
610 CALL zsytrf_aa_2stage( 'U', 2, a, 1, a, 2, ip, ip, w, 1,
611 $ info )
612 CALL chkxer( 'ZSYTRF_AA_2STAGE', infot, nout, lerr, ok )
613 infot = 6
614 CALL zsytrf_aa_2stage( 'U', 2, a, 2, a, 1, ip, ip, w, 1,
615 $ info )
616 CALL chkxer( 'ZSYTRF_AA_2STAGE', infot, nout, lerr, ok )
617 infot = 10
618 CALL zsytrf_aa_2stage( 'U', 2, a, 2, a, 8, ip, ip, w, 0,
619 $ info )
620 CALL chkxer( 'ZSYTRF_AA_2STAGE', infot, nout, lerr, ok )
621*
622* CHETRS_AA_2STAGE
623*
624 srnamt = 'ZSYTRS_AA_2STAGE'
625 infot = 1
626 CALL zsytrs_aa_2stage( '/', 0, 0, a, 1, a, 1, ip, ip,
627 $ b, 1, info )
628 CALL chkxer( 'ZSYTRS_AA_2STAGE', infot, nout, lerr, ok )
629 infot = 2
630 CALL zsytrs_aa_2stage( 'U', -1, 0, a, 1, a, 1, ip, ip,
631 $ b, 1, info )
632 CALL chkxer( 'ZSYTRS_AA_2STAGE', infot, nout, lerr, ok )
633 infot = 3
634 CALL zsytrs_aa_2stage( 'U', 0, -1, a, 1, a, 1, ip, ip,
635 $ b, 1, info )
636 CALL chkxer( 'ZSYTRS_AA_2STAGE', infot, nout, lerr, ok )
637 infot = 5
638 CALL zsytrs_aa_2stage( 'U', 2, 1, a, 1, a, 1, ip, ip,
639 $ b, 1, info )
640 CALL chkxer( 'ZSYTRS_AA_2STAGE', infot, nout, lerr, ok )
641 infot = 7
642 CALL zsytrs_aa_2stage( 'U', 2, 1, a, 2, a, 1, ip, ip,
643 $ b, 1, info )
644 CALL chkxer( 'ZSYTRS_AA_2STAGE', infot, nout, lerr, ok )
645 infot = 11
646 CALL zsytrs_aa_2stage( 'U', 2, 1, a, 2, a, 8, ip, ip,
647 $ b, 1, info )
648 CALL chkxer( 'ZSYTRS_AA_STAGE', infot, nout, lerr, ok )
649*
650 END IF
651*
652* Print a summary line.
653*
654 CALL alaesm( path, ok, nout )
655*
656 RETURN
657*
658* End of ZERRSY
659*
zsytf2_rk
subroutine zsytf2_rk(uplo, n, a, lda, e, ipiv, info)
ZSYTF2_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch...
Definition zsytf2_rk.f:241
zsytf2
subroutine zsytf2(uplo, n, a, lda, ipiv, info)
ZSYTF2 computes the factorization of a real symmetric indefinite matrix, using the diagonal pivoting ...
Definition zsytf2.f:191
zsytri2x
subroutine zsytri2x(uplo, n, a, lda, ipiv, work, nb, info)
ZSYTRI2X
Definition zsytri2x.f:120
zsytf2_rook
subroutine zsytf2_rook(uplo, n, a, lda, ipiv, info)
ZSYTF2_ROOK computes the factorization of a complex symmetric indefinite matrix using the bounded Bun...
Definition zsytf2_rook.f:194
zsytri_3x
subroutine zsytri_3x(uplo, n, a, lda, e, ipiv, work, nb, info)
ZSYTRI_3X
Definition zsytri_3x.f:159
zsytri
subroutine zsytri(uplo, n, a, lda, ipiv, work, info)
ZSYTRI
Definition zsytri.f:114

◆ zerrtr()

subroutine zerrtr ( character*3 path,
integer nunit )

ZERRTR

Purpose:
!>
!> ZERRTR tests the error exits for the COMPLEX*16 triangular routines.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 53 of file zerrtr.f.

54*
55* -- LAPACK test routine --
56* -- LAPACK is a software package provided by Univ. of Tennessee, --
57* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
58*
59* .. Scalar Arguments ..
60 CHARACTER*3 PATH
61 INTEGER NUNIT
62* ..
63*
64* =====================================================================
65*
66* .. Parameters ..
67 INTEGER NMAX
68 parameter( nmax = 2 )
69* ..
70* .. Local Scalars ..
71 CHARACTER*2 C2
72 INTEGER INFO
73 DOUBLE PRECISION RCOND, SCALE
74* ..
75* .. Local Arrays ..
76 DOUBLE PRECISION R1( NMAX ), R2( NMAX ), RW( NMAX )
77 COMPLEX*16 A( NMAX, NMAX ), B( NMAX ), W( NMAX ),
78 $ X( NMAX )
79* ..
80* .. External Functions ..
81 LOGICAL LSAMEN
82 EXTERNAL lsamen
83* ..
84* .. External Subroutines ..
85 EXTERNAL alaesm, chkxer, zlatbs, zlatps, zlatrs, ztbcon,
86 $ ztbrfs, ztbtrs, ztpcon, ztprfs, ztptri, ztptrs,
87 $ ztrcon, ztrrfs, ztrti2, ztrtri, ztrtrs
88* ..
89* .. Scalars in Common ..
90 LOGICAL LERR, OK
91 CHARACTER*32 SRNAMT
92 INTEGER INFOT, NOUT
93* ..
94* .. Common blocks ..
95 COMMON / infoc / infot, nout, ok, lerr
96 COMMON / srnamc / srnamt
97* ..
98* .. Executable Statements ..
99*
100 nout = nunit
101 WRITE( nout, fmt = * )
102 c2 = path( 2: 3 )
103 a( 1, 1 ) = 1.d0
104 a( 1, 2 ) = 2.d0
105 a( 2, 2 ) = 3.d0
106 a( 2, 1 ) = 4.d0
107 ok = .true.
108*
109* Test error exits for the general triangular routines.
110*
111 IF( lsamen( 2, c2, 'TR' ) ) THEN
112*
113* ZTRTRI
114*
115 srnamt = 'ZTRTRI'
116 infot = 1
117 CALL ztrtri( '/', 'N', 0, a, 1, info )
118 CALL chkxer( 'ZTRTRI', infot, nout, lerr, ok )
119 infot = 2
120 CALL ztrtri( 'U', '/', 0, a, 1, info )
121 CALL chkxer( 'ZTRTRI', infot, nout, lerr, ok )
122 infot = 3
123 CALL ztrtri( 'U', 'N', -1, a, 1, info )
124 CALL chkxer( 'ZTRTRI', infot, nout, lerr, ok )
125 infot = 5
126 CALL ztrtri( 'U', 'N', 2, a, 1, info )
127 CALL chkxer( 'ZTRTRI', infot, nout, lerr, ok )
128*
129* ZTRTI2
130*
131 srnamt = 'ZTRTI2'
132 infot = 1
133 CALL ztrti2( '/', 'N', 0, a, 1, info )
134 CALL chkxer( 'ZTRTI2', infot, nout, lerr, ok )
135 infot = 2
136 CALL ztrti2( 'U', '/', 0, a, 1, info )
137 CALL chkxer( 'ZTRTI2', infot, nout, lerr, ok )
138 infot = 3
139 CALL ztrti2( 'U', 'N', -1, a, 1, info )
140 CALL chkxer( 'ZTRTI2', infot, nout, lerr, ok )
141 infot = 5
142 CALL ztrti2( 'U', 'N', 2, a, 1, info )
143 CALL chkxer( 'ZTRTI2', infot, nout, lerr, ok )
144*
145*
146* ZTRTRS
147*
148 srnamt = 'ZTRTRS'
149 infot = 1
150 CALL ztrtrs( '/', 'N', 'N', 0, 0, a, 1, x, 1, info )
151 CALL chkxer( 'ZTRTRS', infot, nout, lerr, ok )
152 infot = 2
153 CALL ztrtrs( 'U', '/', 'N', 0, 0, a, 1, x, 1, info )
154 CALL chkxer( 'ZTRTRS', infot, nout, lerr, ok )
155 infot = 3
156 CALL ztrtrs( 'U', 'N', '/', 0, 0, a, 1, x, 1, info )
157 CALL chkxer( 'ZTRTRS', infot, nout, lerr, ok )
158 infot = 4
159 CALL ztrtrs( 'U', 'N', 'N', -1, 0, a, 1, x, 1, info )
160 CALL chkxer( 'ZTRTRS', infot, nout, lerr, ok )
161 infot = 5
162 CALL ztrtrs( 'U', 'N', 'N', 0, -1, a, 1, x, 1, info )
163 CALL chkxer( 'ZTRTRS', infot, nout, lerr, ok )
164 infot = 7
165*
166* ZTRRFS
167*
168 srnamt = 'ZTRRFS'
169 infot = 1
170 CALL ztrrfs( '/', 'N', 'N', 0, 0, a, 1, b, 1, x, 1, r1, r2, w,
171 $ rw, info )
172 CALL chkxer( 'ZTRRFS', infot, nout, lerr, ok )
173 infot = 2
174 CALL ztrrfs( 'U', '/', 'N', 0, 0, a, 1, b, 1, x, 1, r1, r2, w,
175 $ rw, info )
176 CALL chkxer( 'ZTRRFS', infot, nout, lerr, ok )
177 infot = 3
178 CALL ztrrfs( 'U', 'N', '/', 0, 0, a, 1, b, 1, x, 1, r1, r2, w,
179 $ rw, info )
180 CALL chkxer( 'ZTRRFS', infot, nout, lerr, ok )
181 infot = 4
182 CALL ztrrfs( 'U', 'N', 'N', -1, 0, a, 1, b, 1, x, 1, r1, r2, w,
183 $ rw, info )
184 CALL chkxer( 'ZTRRFS', infot, nout, lerr, ok )
185 infot = 5
186 CALL ztrrfs( 'U', 'N', 'N', 0, -1, a, 1, b, 1, x, 1, r1, r2, w,
187 $ rw, info )
188 CALL chkxer( 'ZTRRFS', infot, nout, lerr, ok )
189 infot = 7
190 CALL ztrrfs( 'U', 'N', 'N', 2, 1, a, 1, b, 2, x, 2, r1, r2, w,
191 $ rw, info )
192 CALL chkxer( 'ZTRRFS', infot, nout, lerr, ok )
193 infot = 9
194 CALL ztrrfs( 'U', 'N', 'N', 2, 1, a, 2, b, 1, x, 2, r1, r2, w,
195 $ rw, info )
196 CALL chkxer( 'ZTRRFS', infot, nout, lerr, ok )
197 infot = 11
198 CALL ztrrfs( 'U', 'N', 'N', 2, 1, a, 2, b, 2, x, 1, r1, r2, w,
199 $ rw, info )
200 CALL chkxer( 'ZTRRFS', infot, nout, lerr, ok )
201*
202* ZTRCON
203*
204 srnamt = 'ZTRCON'
205 infot = 1
206 CALL ztrcon( '/', 'U', 'N', 0, a, 1, rcond, w, rw, info )
207 CALL chkxer( 'ZTRCON', infot, nout, lerr, ok )
208 infot = 2
209 CALL ztrcon( '1', '/', 'N', 0, a, 1, rcond, w, rw, info )
210 CALL chkxer( 'ZTRCON', infot, nout, lerr, ok )
211 infot = 3
212 CALL ztrcon( '1', 'U', '/', 0, a, 1, rcond, w, rw, info )
213 CALL chkxer( 'ZTRCON', infot, nout, lerr, ok )
214 infot = 4
215 CALL ztrcon( '1', 'U', 'N', -1, a, 1, rcond, w, rw, info )
216 CALL chkxer( 'ZTRCON', infot, nout, lerr, ok )
217 infot = 6
218 CALL ztrcon( '1', 'U', 'N', 2, a, 1, rcond, w, rw, info )
219 CALL chkxer( 'ZTRCON', infot, nout, lerr, ok )
220*
221* ZLATRS
222*
223 srnamt = 'ZLATRS'
224 infot = 1
225 CALL zlatrs( '/', 'N', 'N', 'N', 0, a, 1, x, scale, rw, info )
226 CALL chkxer( 'ZLATRS', infot, nout, lerr, ok )
227 infot = 2
228 CALL zlatrs( 'U', '/', 'N', 'N', 0, a, 1, x, scale, rw, info )
229 CALL chkxer( 'ZLATRS', infot, nout, lerr, ok )
230 infot = 3
231 CALL zlatrs( 'U', 'N', '/', 'N', 0, a, 1, x, scale, rw, info )
232 CALL chkxer( 'ZLATRS', infot, nout, lerr, ok )
233 infot = 4
234 CALL zlatrs( 'U', 'N', 'N', '/', 0, a, 1, x, scale, rw, info )
235 CALL chkxer( 'ZLATRS', infot, nout, lerr, ok )
236 infot = 5
237 CALL zlatrs( 'U', 'N', 'N', 'N', -1, a, 1, x, scale, rw, info )
238 CALL chkxer( 'ZLATRS', infot, nout, lerr, ok )
239 infot = 7
240 CALL zlatrs( 'U', 'N', 'N', 'N', 2, a, 1, x, scale, rw, info )
241 CALL chkxer( 'ZLATRS', infot, nout, lerr, ok )
242*
243* Test error exits for the packed triangular routines.
244*
245 ELSE IF( lsamen( 2, c2, 'TP' ) ) THEN
246*
247* ZTPTRI
248*
249 srnamt = 'ZTPTRI'
250 infot = 1
251 CALL ztptri( '/', 'N', 0, a, info )
252 CALL chkxer( 'ZTPTRI', infot, nout, lerr, ok )
253 infot = 2
254 CALL ztptri( 'U', '/', 0, a, info )
255 CALL chkxer( 'ZTPTRI', infot, nout, lerr, ok )
256 infot = 3
257 CALL ztptri( 'U', 'N', -1, a, info )
258 CALL chkxer( 'ZTPTRI', infot, nout, lerr, ok )
259*
260* ZTPTRS
261*
262 srnamt = 'ZTPTRS'
263 infot = 1
264 CALL ztptrs( '/', 'N', 'N', 0, 0, a, x, 1, info )
265 CALL chkxer( 'ZTPTRS', infot, nout, lerr, ok )
266 infot = 2
267 CALL ztptrs( 'U', '/', 'N', 0, 0, a, x, 1, info )
268 CALL chkxer( 'ZTPTRS', infot, nout, lerr, ok )
269 infot = 3
270 CALL ztptrs( 'U', 'N', '/', 0, 0, a, x, 1, info )
271 CALL chkxer( 'ZTPTRS', infot, nout, lerr, ok )
272 infot = 4
273 CALL ztptrs( 'U', 'N', 'N', -1, 0, a, x, 1, info )
274 CALL chkxer( 'ZTPTRS', infot, nout, lerr, ok )
275 infot = 5
276 CALL ztptrs( 'U', 'N', 'N', 0, -1, a, x, 1, info )
277 CALL chkxer( 'ZTPTRS', infot, nout, lerr, ok )
278 infot = 8
279 CALL ztptrs( 'U', 'N', 'N', 2, 1, a, x, 1, info )
280 CALL chkxer( 'ZTPTRS', infot, nout, lerr, ok )
281*
282* ZTPRFS
283*
284 srnamt = 'ZTPRFS'
285 infot = 1
286 CALL ztprfs( '/', 'N', 'N', 0, 0, a, b, 1, x, 1, r1, r2, w, rw,
287 $ info )
288 CALL chkxer( 'ZTPRFS', infot, nout, lerr, ok )
289 infot = 2
290 CALL ztprfs( 'U', '/', 'N', 0, 0, a, b, 1, x, 1, r1, r2, w, rw,
291 $ info )
292 CALL chkxer( 'ZTPRFS', infot, nout, lerr, ok )
293 infot = 3
294 CALL ztprfs( 'U', 'N', '/', 0, 0, a, b, 1, x, 1, r1, r2, w, rw,
295 $ info )
296 CALL chkxer( 'ZTPRFS', infot, nout, lerr, ok )
297 infot = 4
298 CALL ztprfs( 'U', 'N', 'N', -1, 0, a, b, 1, x, 1, r1, r2, w,
299 $ rw, info )
300 CALL chkxer( 'ZTPRFS', infot, nout, lerr, ok )
301 infot = 5
302 CALL ztprfs( 'U', 'N', 'N', 0, -1, a, b, 1, x, 1, r1, r2, w,
303 $ rw, info )
304 CALL chkxer( 'ZTPRFS', infot, nout, lerr, ok )
305 infot = 8
306 CALL ztprfs( 'U', 'N', 'N', 2, 1, a, b, 1, x, 2, r1, r2, w, rw,
307 $ info )
308 CALL chkxer( 'ZTPRFS', infot, nout, lerr, ok )
309 infot = 10
310 CALL ztprfs( 'U', 'N', 'N', 2, 1, a, b, 2, x, 1, r1, r2, w, rw,
311 $ info )
312 CALL chkxer( 'ZTPRFS', infot, nout, lerr, ok )
313*
314* ZTPCON
315*
316 srnamt = 'ZTPCON'
317 infot = 1
318 CALL ztpcon( '/', 'U', 'N', 0, a, rcond, w, rw, info )
319 CALL chkxer( 'ZTPCON', infot, nout, lerr, ok )
320 infot = 2
321 CALL ztpcon( '1', '/', 'N', 0, a, rcond, w, rw, info )
322 CALL chkxer( 'ZTPCON', infot, nout, lerr, ok )
323 infot = 3
324 CALL ztpcon( '1', 'U', '/', 0, a, rcond, w, rw, info )
325 CALL chkxer( 'ZTPCON', infot, nout, lerr, ok )
326 infot = 4
327 CALL ztpcon( '1', 'U', 'N', -1, a, rcond, w, rw, info )
328 CALL chkxer( 'ZTPCON', infot, nout, lerr, ok )
329*
330* ZLATPS
331*
332 srnamt = 'ZLATPS'
333 infot = 1
334 CALL zlatps( '/', 'N', 'N', 'N', 0, a, x, scale, rw, info )
335 CALL chkxer( 'ZLATPS', infot, nout, lerr, ok )
336 infot = 2
337 CALL zlatps( 'U', '/', 'N', 'N', 0, a, x, scale, rw, info )
338 CALL chkxer( 'ZLATPS', infot, nout, lerr, ok )
339 infot = 3
340 CALL zlatps( 'U', 'N', '/', 'N', 0, a, x, scale, rw, info )
341 CALL chkxer( 'ZLATPS', infot, nout, lerr, ok )
342 infot = 4
343 CALL zlatps( 'U', 'N', 'N', '/', 0, a, x, scale, rw, info )
344 CALL chkxer( 'ZLATPS', infot, nout, lerr, ok )
345 infot = 5
346 CALL zlatps( 'U', 'N', 'N', 'N', -1, a, x, scale, rw, info )
347 CALL chkxer( 'ZLATPS', infot, nout, lerr, ok )
348*
349* Test error exits for the banded triangular routines.
350*
351 ELSE IF( lsamen( 2, c2, 'TB' ) ) THEN
352*
353* ZTBTRS
354*
355 srnamt = 'ZTBTRS'
356 infot = 1
357 CALL ztbtrs( '/', 'N', 'N', 0, 0, 0, a, 1, x, 1, info )
358 CALL chkxer( 'ZTBTRS', infot, nout, lerr, ok )
359 infot = 2
360 CALL ztbtrs( 'U', '/', 'N', 0, 0, 0, a, 1, x, 1, info )
361 CALL chkxer( 'ZTBTRS', infot, nout, lerr, ok )
362 infot = 3
363 CALL ztbtrs( 'U', 'N', '/', 0, 0, 0, a, 1, x, 1, info )
364 CALL chkxer( 'ZTBTRS', infot, nout, lerr, ok )
365 infot = 4
366 CALL ztbtrs( 'U', 'N', 'N', -1, 0, 0, a, 1, x, 1, info )
367 CALL chkxer( 'ZTBTRS', infot, nout, lerr, ok )
368 infot = 5
369 CALL ztbtrs( 'U', 'N', 'N', 0, -1, 0, a, 1, x, 1, info )
370 CALL chkxer( 'ZTBTRS', infot, nout, lerr, ok )
371 infot = 6
372 CALL ztbtrs( 'U', 'N', 'N', 0, 0, -1, a, 1, x, 1, info )
373 CALL chkxer( 'ZTBTRS', infot, nout, lerr, ok )
374 infot = 8
375 CALL ztbtrs( 'U', 'N', 'N', 2, 1, 1, a, 1, x, 2, info )
376 CALL chkxer( 'ZTBTRS', infot, nout, lerr, ok )
377 infot = 10
378 CALL ztbtrs( 'U', 'N', 'N', 2, 0, 1, a, 1, x, 1, info )
379 CALL chkxer( 'ZTBTRS', infot, nout, lerr, ok )
380*
381* ZTBRFS
382*
383 srnamt = 'ZTBRFS'
384 infot = 1
385 CALL ztbrfs( '/', 'N', 'N', 0, 0, 0, a, 1, b, 1, x, 1, r1, r2,
386 $ w, rw, info )
387 CALL chkxer( 'ZTBRFS', infot, nout, lerr, ok )
388 infot = 2
389 CALL ztbrfs( 'U', '/', 'N', 0, 0, 0, a, 1, b, 1, x, 1, r1, r2,
390 $ w, rw, info )
391 CALL chkxer( 'ZTBRFS', infot, nout, lerr, ok )
392 infot = 3
393 CALL ztbrfs( 'U', 'N', '/', 0, 0, 0, a, 1, b, 1, x, 1, r1, r2,
394 $ w, rw, info )
395 CALL chkxer( 'ZTBRFS', infot, nout, lerr, ok )
396 infot = 4
397 CALL ztbrfs( 'U', 'N', 'N', -1, 0, 0, a, 1, b, 1, x, 1, r1, r2,
398 $ w, rw, info )
399 CALL chkxer( 'ZTBRFS', infot, nout, lerr, ok )
400 infot = 5
401 CALL ztbrfs( 'U', 'N', 'N', 0, -1, 0, a, 1, b, 1, x, 1, r1, r2,
402 $ w, rw, info )
403 CALL chkxer( 'ZTBRFS', infot, nout, lerr, ok )
404 infot = 6
405 CALL ztbrfs( 'U', 'N', 'N', 0, 0, -1, a, 1, b, 1, x, 1, r1, r2,
406 $ w, rw, info )
407 CALL chkxer( 'ZTBRFS', infot, nout, lerr, ok )
408 infot = 8
409 CALL ztbrfs( 'U', 'N', 'N', 2, 1, 1, a, 1, b, 2, x, 2, r1, r2,
410 $ w, rw, info )
411 CALL chkxer( 'ZTBRFS', infot, nout, lerr, ok )
412 infot = 10
413 CALL ztbrfs( 'U', 'N', 'N', 2, 1, 1, a, 2, b, 1, x, 2, r1, r2,
414 $ w, rw, info )
415 CALL chkxer( 'ZTBRFS', infot, nout, lerr, ok )
416 infot = 12
417 CALL ztbrfs( 'U', 'N', 'N', 2, 1, 1, a, 2, b, 2, x, 1, r1, r2,
418 $ w, rw, info )
419 CALL chkxer( 'ZTBRFS', infot, nout, lerr, ok )
420*
421* ZTBCON
422*
423 srnamt = 'ZTBCON'
424 infot = 1
425 CALL ztbcon( '/', 'U', 'N', 0, 0, a, 1, rcond, w, rw, info )
426 CALL chkxer( 'ZTBCON', infot, nout, lerr, ok )
427 infot = 2
428 CALL ztbcon( '1', '/', 'N', 0, 0, a, 1, rcond, w, rw, info )
429 CALL chkxer( 'ZTBCON', infot, nout, lerr, ok )
430 infot = 3
431 CALL ztbcon( '1', 'U', '/', 0, 0, a, 1, rcond, w, rw, info )
432 CALL chkxer( 'ZTBCON', infot, nout, lerr, ok )
433 infot = 4
434 CALL ztbcon( '1', 'U', 'N', -1, 0, a, 1, rcond, w, rw, info )
435 CALL chkxer( 'ZTBCON', infot, nout, lerr, ok )
436 infot = 5
437 CALL ztbcon( '1', 'U', 'N', 0, -1, a, 1, rcond, w, rw, info )
438 CALL chkxer( 'ZTBCON', infot, nout, lerr, ok )
439 infot = 7
440 CALL ztbcon( '1', 'U', 'N', 2, 1, a, 1, rcond, w, rw, info )
441 CALL chkxer( 'ZTBCON', infot, nout, lerr, ok )
442*
443* ZLATBS
444*
445 srnamt = 'ZLATBS'
446 infot = 1
447 CALL zlatbs( '/', 'N', 'N', 'N', 0, 0, a, 1, x, scale, rw,
448 $ info )
449 CALL chkxer( 'ZLATBS', infot, nout, lerr, ok )
450 infot = 2
451 CALL zlatbs( 'U', '/', 'N', 'N', 0, 0, a, 1, x, scale, rw,
452 $ info )
453 CALL chkxer( 'ZLATBS', infot, nout, lerr, ok )
454 infot = 3
455 CALL zlatbs( 'U', 'N', '/', 'N', 0, 0, a, 1, x, scale, rw,
456 $ info )
457 CALL chkxer( 'ZLATBS', infot, nout, lerr, ok )
458 infot = 4
459 CALL zlatbs( 'U', 'N', 'N', '/', 0, 0, a, 1, x, scale, rw,
460 $ info )
461 CALL chkxer( 'ZLATBS', infot, nout, lerr, ok )
462 infot = 5
463 CALL zlatbs( 'U', 'N', 'N', 'N', -1, 0, a, 1, x, scale, rw,
464 $ info )
465 CALL chkxer( 'ZLATBS', infot, nout, lerr, ok )
466 infot = 6
467 CALL zlatbs( 'U', 'N', 'N', 'N', 1, -1, a, 1, x, scale, rw,
468 $ info )
469 CALL chkxer( 'ZLATBS', infot, nout, lerr, ok )
470 infot = 8
471 CALL zlatbs( 'U', 'N', 'N', 'N', 2, 1, a, 1, x, scale, rw,
472 $ info )
473 CALL chkxer( 'ZLATBS', infot, nout, lerr, ok )
474 END IF
475*
476* Print a summary line.
477*
478 CALL alaesm( path, ok, nout )
479*
480 RETURN
481*
482* End of ZERRTR
483*
ztrti2
subroutine ztrti2(uplo, diag, n, a, lda, info)
ZTRTI2 computes the inverse of a triangular matrix (unblocked algorithm).
Definition ztrti2.f:110

◆ zerrtz()

subroutine zerrtz ( character*3 path,
integer nunit )

ZERRTZ

Purpose:
!>
!> ZERRTZ tests the error exits for ZTZRZF.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 53 of file zerrtz.f.

54*
55* -- LAPACK test routine --
56* -- LAPACK is a software package provided by Univ. of Tennessee, --
57* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
58*
59* .. Scalar Arguments ..
60 CHARACTER*3 PATH
61 INTEGER NUNIT
62* ..
63*
64* =====================================================================
65*
66* .. Parameters ..
67 INTEGER NMAX
68 parameter( nmax = 2 )
69* ..
70* .. Local Scalars ..
71 CHARACTER*2 C2
72 INTEGER INFO
73* ..
74* .. Local Arrays ..
75 COMPLEX*16 A( NMAX, NMAX ), TAU( NMAX ), W( NMAX )
76* ..
77* .. External Functions ..
78 LOGICAL LSAMEN
79 EXTERNAL lsamen
80* ..
81* .. External Subroutines ..
82 EXTERNAL alaesm, chkxer, ztzrzf
83* ..
84* .. Scalars in Common ..
85 LOGICAL LERR, OK
86 CHARACTER*32 SRNAMT
87 INTEGER INFOT, NOUT
88* ..
89* .. Common blocks ..
90 COMMON / infoc / infot, nout, ok, lerr
91 COMMON / srnamc / srnamt
92* ..
93* .. Intrinsic Functions ..
94 INTRINSIC dcmplx
95* ..
96* .. Executable Statements ..
97*
98 nout = nunit
99 c2 = path( 2: 3 )
100 a( 1, 1 ) = dcmplx( 1.d+0, -1.d+0 )
101 a( 1, 2 ) = dcmplx( 2.d+0, -2.d+0 )
102 a( 2, 2 ) = dcmplx( 3.d+0, -3.d+0 )
103 a( 2, 1 ) = dcmplx( 4.d+0, -4.d+0 )
104 w( 1 ) = dcmplx( 0.d+0, 0.d+0 )
105 w( 2 ) = dcmplx( 0.d+0, 0.d+0 )
106 ok = .true.
107*
108* Test error exits for the trapezoidal routines.
109 WRITE( nout, fmt = * )
110 IF( lsamen( 2, c2, 'TZ' ) ) THEN
111*
112*
113* ZTZRZF
114*
115 srnamt = 'ZTZRZF'
116 infot = 1
117 CALL ztzrzf( -1, 0, a, 1, tau, w, 1, info )
118 CALL chkxer( 'ZTZRZF', infot, nout, lerr, ok )
119 infot = 2
120 CALL ztzrzf( 1, 0, a, 1, tau, w, 1, info )
121 CALL chkxer( 'ZTZRZF', infot, nout, lerr, ok )
122 infot = 4
123 CALL ztzrzf( 2, 2, a, 1, tau, w, 1, info )
124 CALL chkxer( 'ZTZRZF', infot, nout, lerr, ok )
125 infot = 7
126 CALL ztzrzf( 2, 2, a, 2, tau, w, 0, info )
127 CALL chkxer( 'ZTZRZF', infot, nout, lerr, ok )
128 infot = 7
129 CALL ztzrzf( 2, 3, a, 2, tau, w, 1, info )
130 CALL chkxer( 'ZTZRZF', infot, nout, lerr, ok )
131 END IF
132*
133* Print a summary line.
134*
135 CALL alaesm( path, ok, nout )
136*
137 RETURN
138*
139* End of ZERRTZ
140*

◆ zerrunhr_col()

subroutine zerrunhr_col ( character(len=3) path,
integer nunit )

ZERRUNHR_COL

Purpose:
!>
!> ZERRUNHR_COL tests the error exits for ZUNHR_COL that does
!> Householder reconstruction from the output of tall-skinny
!> factorization ZLATSQR.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 55 of file zerrunhr_col.f.

56 IMPLICIT NONE
57*
58* -- LAPACK test routine --
59* -- LAPACK is a software package provided by Univ. of Tennessee, --
60* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
61*
62* .. Scalar Arguments ..
63 CHARACTER(LEN=3) PATH
64 INTEGER NUNIT
65* ..
66*
67* =====================================================================
68*
69* .. Parameters ..
70 INTEGER NMAX
71 parameter( nmax = 2 )
72* ..
73* .. Local Scalars ..
74 INTEGER I, INFO, J
75* ..
76* .. Local Arrays ..
77 COMPLEX*16 A( NMAX, NMAX ), T( NMAX, NMAX ), D(NMAX)
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, zunhr_col
81* ..
82* .. Scalars in Common ..
83 LOGICAL LERR, OK
84 CHARACTER(LEN=32) SRNAMT
85 INTEGER INFOT, NOUT
86* ..
87* .. Common blocks ..
88 COMMON / infoc / infot, nout, ok, lerr
89 COMMON / srnamc / srnamt
90* ..
91* .. Intrinsic Functions ..
92 INTRINSIC dble, dcmplx
93* ..
94* .. Executable Statements ..
95*
96 nout = nunit
97 WRITE( nout, fmt = * )
98*
99* Set the variables to innocuous values.
100*
101 DO j = 1, nmax
102 DO i = 1, nmax
103 a( i, j ) = dcmplx( 1.d+0 / dble( i+j ) )
104 t( i, j ) = dcmplx( 1.d+0 / dble( i+j ) )
105 END DO
106 d( j ) = ( 0.d+0, 0.d+0 )
107 END DO
108 ok = .true.
109*
110* Error exits for Householder reconstruction
111*
112* ZUNHR_COL
113*
114 srnamt = 'ZUNHR_COL'
115*
116 infot = 1
117 CALL zunhr_col( -1, 0, 1, a, 1, t, 1, d, info )
118 CALL chkxer( 'ZUNHR_COL', infot, nout, lerr, ok )
119*
120 infot = 2
121 CALL zunhr_col( 0, -1, 1, a, 1, t, 1, d, info )
122 CALL chkxer( 'ZUNHR_COL', infot, nout, lerr, ok )
123 CALL zunhr_col( 1, 2, 1, a, 1, t, 1, d, info )
124 CALL chkxer( 'ZUNHR_COL', infot, nout, lerr, ok )
125*
126 infot = 3
127 CALL zunhr_col( 0, 0, -1, a, 1, t, 1, d, info )
128 CALL chkxer( 'ZUNHR_COL', infot, nout, lerr, ok )
129*
130 CALL zunhr_col( 0, 0, 0, a, 1, t, 1, d, info )
131 CALL chkxer( 'ZUNHR_COL', infot, nout, lerr, ok )
132*
133 infot = 5
134 CALL zunhr_col( 0, 0, 1, a, -1, t, 1, d, info )
135 CALL chkxer( 'ZUNHR_COL', infot, nout, lerr, ok )
136*
137 CALL zunhr_col( 0, 0, 1, a, 0, t, 1, d, info )
138 CALL chkxer( 'ZUNHR_COL', infot, nout, lerr, ok )
139*
140 CALL zunhr_col( 2, 0, 1, a, 1, t, 1, d, info )
141 CALL chkxer( 'ZUNHR_COL', infot, nout, lerr, ok )
142*
143 infot = 7
144 CALL zunhr_col( 0, 0, 1, a, 1, t, -1, d, info )
145 CALL chkxer( 'ZUNHR_COL', infot, nout, lerr, ok )
146*
147 CALL zunhr_col( 0, 0, 1, a, 1, t, 0, d, info )
148 CALL chkxer( 'ZUNHR_COL', infot, nout, lerr, ok )
149*
150 CALL zunhr_col( 4, 3, 2, a, 4, t, 1, d, info )
151 CALL chkxer( 'ZUNHR_COL', infot, nout, lerr, ok )
152*
153* Print a summary line.
154*
155 CALL alaesm( path, ok, nout )
156*
157 RETURN
158*
159* End of ZERRUNHR_COL
160*
zunhr_col
subroutine zunhr_col(m, n, nb, a, lda, t, ldt, d, info)
ZUNHR_COL
Definition zunhr_col.f:259

◆ zerrvx()

subroutine zerrvx ( character*3 path,
integer nunit )

ZERRVX

ZERRVXX

Purpose:
!>
!> ZERRVX tests the error exits for the COMPLEX*16 driver routines
!> for solving linear systems of equations.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name for the routines to be tested.
!>
[in]NUNIT
!>          NUNIT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 54 of file zerrvx.f.

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX
69 parameter( nmax = 4 )
70* ..
71* .. Local Scalars ..
72 CHARACTER EQ
73 CHARACTER*2 C2
74 INTEGER I, INFO, J
75 DOUBLE PRECISION RCOND
76* ..
77* .. Local Arrays ..
78 INTEGER IP( NMAX )
79 DOUBLE PRECISION C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ),
80 $ RF( NMAX ), RW( NMAX )
81 COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
82 $ E( NMAX ), W( 2*NMAX ), X( NMAX )
83* ..
84* .. External Functions ..
85 LOGICAL LSAMEN
86 EXTERNAL lsamen
87* ..
88* .. External Subroutines ..
89 EXTERNAL chkxer, zgbsv, zgbsvx, zgesv, zgesvx, zgtsv,
90 $ zgtsvx, zhesv, zhesv_rk, zhesv_rook, zhesvx,
91 $ zhpsv, zhpsvx, zpbsv, zpbsvx, zposv, zposvx,
92 $ zppsv, zppsvx, zptsv, zptsvx, zspsv, zspsvx,
93 $ zsysv, zsysv_aa, zsysv_rk, zsysv_rook,
94 $ zsysvx, zhesv_aa_2stage
95* ..
96* .. Scalars in Common ..
97 LOGICAL LERR, OK
98 CHARACTER*32 SRNAMT
99 INTEGER INFOT, NOUT
100* ..
101* .. Common blocks ..
102 COMMON / infoc / infot, nout, ok, lerr
103 COMMON / srnamc / srnamt
104* ..
105* .. Intrinsic Functions ..
106 INTRINSIC dble, dcmplx
107* ..
108* .. Executable Statements ..
109*
110 nout = nunit
111 WRITE( nout, fmt = * )
112 c2 = path( 2: 3 )
113*
114* Set the variables to innocuous values.
115*
116 DO 20 j = 1, nmax
117 DO 10 i = 1, nmax
118 a( i, j ) = dcmplx( 1.d0 / dble( i+j ),
119 $ -1.d0 / dble( i+j ) )
120 af( i, j ) = dcmplx( 1.d0 / dble( i+j ),
121 $ -1.d0 / dble( i+j ) )
122 10 CONTINUE
123 b( j ) = 0.d0
124 e( j ) = 0.d0
125 r1( j ) = 0.d0
126 r2( j ) = 0.d0
127 w( j ) = 0.d0
128 x( j ) = 0.d0
129 c( j ) = 0.d0
130 r( j ) = 0.d0
131 ip( j ) = j
132 20 CONTINUE
133 eq = ' '
134 ok = .true.
135*
136 IF( lsamen( 2, c2, 'GE' ) ) THEN
137*
138* ZGESV
139*
140 srnamt = 'ZGESV '
141 infot = 1
142 CALL zgesv( -1, 0, a, 1, ip, b, 1, info )
143 CALL chkxer( 'ZGESV ', infot, nout, lerr, ok )
144 infot = 2
145 CALL zgesv( 0, -1, a, 1, ip, b, 1, info )
146 CALL chkxer( 'ZGESV ', infot, nout, lerr, ok )
147 infot = 4
148 CALL zgesv( 2, 1, a, 1, ip, b, 2, info )
149 CALL chkxer( 'ZGESV ', infot, nout, lerr, ok )
150 infot = 7
151 CALL zgesv( 2, 1, a, 2, ip, b, 1, info )
152 CALL chkxer( 'ZGESV ', infot, nout, lerr, ok )
153*
154* ZGESVX
155*
156 srnamt = 'ZGESVX'
157 infot = 1
158 CALL zgesvx( '/', 'N', 0, 0, a, 1, af, 1, ip, eq, r, c, b, 1,
159 $ x, 1, rcond, r1, r2, w, rw, info )
160 CALL chkxer( 'ZGESVX', infot, nout, lerr, ok )
161 infot = 2
162 CALL zgesvx( 'N', '/', 0, 0, a, 1, af, 1, ip, eq, r, c, b, 1,
163 $ x, 1, rcond, r1, r2, w, rw, info )
164 CALL chkxer( 'ZGESVX', infot, nout, lerr, ok )
165 infot = 3
166 CALL zgesvx( 'N', 'N', -1, 0, a, 1, af, 1, ip, eq, r, c, b, 1,
167 $ x, 1, rcond, r1, r2, w, rw, info )
168 CALL chkxer( 'ZGESVX', infot, nout, lerr, ok )
169 infot = 4
170 CALL zgesvx( 'N', 'N', 0, -1, a, 1, af, 1, ip, eq, r, c, b, 1,
171 $ x, 1, rcond, r1, r2, w, rw, info )
172 CALL chkxer( 'ZGESVX', infot, nout, lerr, ok )
173 infot = 6
174 CALL zgesvx( 'N', 'N', 2, 1, a, 1, af, 2, ip, eq, r, c, b, 2,
175 $ x, 2, rcond, r1, r2, w, rw, info )
176 CALL chkxer( 'ZGESVX', infot, nout, lerr, ok )
177 infot = 8
178 CALL zgesvx( 'N', 'N', 2, 1, a, 2, af, 1, ip, eq, r, c, b, 2,
179 $ x, 2, rcond, r1, r2, w, rw, info )
180 CALL chkxer( 'ZGESVX', infot, nout, lerr, ok )
181 infot = 10
182 eq = '/'
183 CALL zgesvx( 'F', 'N', 0, 0, a, 1, af, 1, ip, eq, r, c, b, 1,
184 $ x, 1, rcond, r1, r2, w, rw, info )
185 CALL chkxer( 'ZGESVX', infot, nout, lerr, ok )
186 infot = 11
187 eq = 'R'
188 CALL zgesvx( 'F', 'N', 1, 0, a, 1, af, 1, ip, eq, r, c, b, 1,
189 $ x, 1, rcond, r1, r2, w, rw, info )
190 CALL chkxer( 'ZGESVX', infot, nout, lerr, ok )
191 infot = 12
192 eq = 'C'
193 CALL zgesvx( 'F', 'N', 1, 0, a, 1, af, 1, ip, eq, r, c, b, 1,
194 $ x, 1, rcond, r1, r2, w, rw, info )
195 CALL chkxer( 'ZGESVX', infot, nout, lerr, ok )
196 infot = 14
197 CALL zgesvx( 'N', 'N', 2, 1, a, 2, af, 2, ip, eq, r, c, b, 1,
198 $ x, 2, rcond, r1, r2, w, rw, info )
199 CALL chkxer( 'ZGESVX', infot, nout, lerr, ok )
200 infot = 16
201 CALL zgesvx( 'N', 'N', 2, 1, a, 2, af, 2, ip, eq, r, c, b, 2,
202 $ x, 1, rcond, r1, r2, w, rw, info )
203 CALL chkxer( 'ZGESVX', infot, nout, lerr, ok )
204*
205 ELSE IF( lsamen( 2, c2, 'GB' ) ) THEN
206*
207* ZGBSV
208*
209 srnamt = 'ZGBSV '
210 infot = 1
211 CALL zgbsv( -1, 0, 0, 0, a, 1, ip, b, 1, info )
212 CALL chkxer( 'ZGBSV ', infot, nout, lerr, ok )
213 infot = 2
214 CALL zgbsv( 1, -1, 0, 0, a, 1, ip, b, 1, info )
215 CALL chkxer( 'ZGBSV ', infot, nout, lerr, ok )
216 infot = 3
217 CALL zgbsv( 1, 0, -1, 0, a, 1, ip, b, 1, info )
218 CALL chkxer( 'ZGBSV ', infot, nout, lerr, ok )
219 infot = 4
220 CALL zgbsv( 0, 0, 0, -1, a, 1, ip, b, 1, info )
221 CALL chkxer( 'ZGBSV ', infot, nout, lerr, ok )
222 infot = 6
223 CALL zgbsv( 1, 1, 1, 0, a, 3, ip, b, 1, info )
224 CALL chkxer( 'ZGBSV ', infot, nout, lerr, ok )
225 infot = 9
226 CALL zgbsv( 2, 0, 0, 0, a, 1, ip, b, 1, info )
227 CALL chkxer( 'ZGBSV ', infot, nout, lerr, ok )
228*
229* ZGBSVX
230*
231 srnamt = 'ZGBSVX'
232 infot = 1
233 CALL zgbsvx( '/', 'N', 0, 0, 0, 0, a, 1, af, 1, ip, eq, r, c,
234 $ b, 1, x, 1, rcond, r1, r2, w, rw, info )
235 CALL chkxer( 'ZGBSVX', infot, nout, lerr, ok )
236 infot = 2
237 CALL zgbsvx( 'N', '/', 0, 0, 0, 0, a, 1, af, 1, ip, eq, r, c,
238 $ b, 1, x, 1, rcond, r1, r2, w, rw, info )
239 CALL chkxer( 'ZGBSVX', infot, nout, lerr, ok )
240 infot = 3
241 CALL zgbsvx( 'N', 'N', -1, 0, 0, 0, a, 1, af, 1, ip, eq, r, c,
242 $ b, 1, x, 1, rcond, r1, r2, w, rw, info )
243 CALL chkxer( 'ZGBSVX', infot, nout, lerr, ok )
244 infot = 4
245 CALL zgbsvx( 'N', 'N', 1, -1, 0, 0, a, 1, af, 1, ip, eq, r, c,
246 $ b, 1, x, 1, rcond, r1, r2, w, rw, info )
247 CALL chkxer( 'ZGBSVX', infot, nout, lerr, ok )
248 infot = 5
249 CALL zgbsvx( 'N', 'N', 1, 0, -1, 0, a, 1, af, 1, ip, eq, r, c,
250 $ b, 1, x, 1, rcond, r1, r2, w, rw, info )
251 CALL chkxer( 'ZGBSVX', infot, nout, lerr, ok )
252 infot = 6
253 CALL zgbsvx( 'N', 'N', 0, 0, 0, -1, a, 1, af, 1, ip, eq, r, c,
254 $ b, 1, x, 1, rcond, r1, r2, w, rw, info )
255 CALL chkxer( 'ZGBSVX', infot, nout, lerr, ok )
256 infot = 8
257 CALL zgbsvx( 'N', 'N', 1, 1, 1, 0, a, 2, af, 4, ip, eq, r, c,
258 $ b, 1, x, 1, rcond, r1, r2, w, rw, info )
259 CALL chkxer( 'ZGBSVX', infot, nout, lerr, ok )
260 infot = 10
261 CALL zgbsvx( 'N', 'N', 1, 1, 1, 0, a, 3, af, 3, ip, eq, r, c,
262 $ b, 1, x, 1, rcond, r1, r2, w, rw, info )
263 CALL chkxer( 'ZGBSVX', infot, nout, lerr, ok )
264 infot = 12
265 eq = '/'
266 CALL zgbsvx( 'F', 'N', 0, 0, 0, 0, a, 1, af, 1, ip, eq, r, c,
267 $ b, 1, x, 1, rcond, r1, r2, w, rw, info )
268 CALL chkxer( 'ZGBSVX', infot, nout, lerr, ok )
269 infot = 13
270 eq = 'R'
271 CALL zgbsvx( 'F', 'N', 1, 0, 0, 0, a, 1, af, 1, ip, eq, r, c,
272 $ b, 1, x, 1, rcond, r1, r2, w, rw, info )
273 CALL chkxer( 'ZGBSVX', infot, nout, lerr, ok )
274 infot = 14
275 eq = 'C'
276 CALL zgbsvx( 'F', 'N', 1, 0, 0, 0, a, 1, af, 1, ip, eq, r, c,
277 $ b, 1, x, 1, rcond, r1, r2, w, rw, info )
278 CALL chkxer( 'ZGBSVX', infot, nout, lerr, ok )
279 infot = 16
280 CALL zgbsvx( 'N', 'N', 2, 0, 0, 0, a, 1, af, 1, ip, eq, r, c,
281 $ b, 1, x, 2, rcond, r1, r2, w, rw, info )
282 CALL chkxer( 'ZGBSVX', infot, nout, lerr, ok )
283 infot = 18
284 CALL zgbsvx( 'N', 'N', 2, 0, 0, 0, a, 1, af, 1, ip, eq, r, c,
285 $ b, 2, x, 1, rcond, r1, r2, w, rw, info )
286 CALL chkxer( 'ZGBSVX', infot, nout, lerr, ok )
287*
288 ELSE IF( lsamen( 2, c2, 'GT' ) ) THEN
289*
290* ZGTSV
291*
292 srnamt = 'ZGTSV '
293 infot = 1
294 CALL zgtsv( -1, 0, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ), b, 1,
295 $ info )
296 CALL chkxer( 'ZGTSV ', infot, nout, lerr, ok )
297 infot = 2
298 CALL zgtsv( 0, -1, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ), b, 1,
299 $ info )
300 CALL chkxer( 'ZGTSV ', infot, nout, lerr, ok )
301 infot = 7
302 CALL zgtsv( 2, 0, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ), b, 1, info )
303 CALL chkxer( 'ZGTSV ', infot, nout, lerr, ok )
304*
305* ZGTSVX
306*
307 srnamt = 'ZGTSVX'
308 infot = 1
309 CALL zgtsvx( '/', 'N', 0, 0, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ),
310 $ af( 1, 1 ), af( 1, 2 ), af( 1, 3 ), af( 1, 4 ),
311 $ ip, b, 1, x, 1, rcond, r1, r2, w, rw, info )
312 CALL chkxer( 'ZGTSVX', infot, nout, lerr, ok )
313 infot = 2
314 CALL zgtsvx( 'N', '/', 0, 0, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ),
315 $ af( 1, 1 ), af( 1, 2 ), af( 1, 3 ), af( 1, 4 ),
316 $ ip, b, 1, x, 1, rcond, r1, r2, w, rw, info )
317 CALL chkxer( 'ZGTSVX', infot, nout, lerr, ok )
318 infot = 3
319 CALL zgtsvx( 'N', 'N', -1, 0, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ),
320 $ af( 1, 1 ), af( 1, 2 ), af( 1, 3 ), af( 1, 4 ),
321 $ ip, b, 1, x, 1, rcond, r1, r2, w, rw, info )
322 CALL chkxer( 'ZGTSVX', infot, nout, lerr, ok )
323 infot = 4
324 CALL zgtsvx( 'N', 'N', 0, -1, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ),
325 $ af( 1, 1 ), af( 1, 2 ), af( 1, 3 ), af( 1, 4 ),
326 $ ip, b, 1, x, 1, rcond, r1, r2, w, rw, info )
327 CALL chkxer( 'ZGTSVX', infot, nout, lerr, ok )
328 infot = 14
329 CALL zgtsvx( 'N', 'N', 2, 0, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ),
330 $ af( 1, 1 ), af( 1, 2 ), af( 1, 3 ), af( 1, 4 ),
331 $ ip, b, 1, x, 2, rcond, r1, r2, w, rw, info )
332 CALL chkxer( 'ZGTSVX', infot, nout, lerr, ok )
333 infot = 16
334 CALL zgtsvx( 'N', 'N', 2, 0, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ),
335 $ af( 1, 1 ), af( 1, 2 ), af( 1, 3 ), af( 1, 4 ),
336 $ ip, b, 2, x, 1, rcond, r1, r2, w, rw, info )
337 CALL chkxer( 'ZGTSVX', infot, nout, lerr, ok )
338*
339 ELSE IF( lsamen( 2, c2, 'PO' ) ) THEN
340*
341* ZPOSV
342*
343 srnamt = 'ZPOSV '
344 infot = 1
345 CALL zposv( '/', 0, 0, a, 1, b, 1, info )
346 CALL chkxer( 'ZPOSV ', infot, nout, lerr, ok )
347 infot = 2
348 CALL zposv( 'U', -1, 0, a, 1, b, 1, info )
349 CALL chkxer( 'ZPOSV ', infot, nout, lerr, ok )
350 infot = 3
351 CALL zposv( 'U', 0, -1, a, 1, b, 1, info )
352 CALL chkxer( 'ZPOSV ', infot, nout, lerr, ok )
353 infot = 5
354 CALL zposv( 'U', 2, 0, a, 1, b, 2, info )
355 CALL chkxer( 'ZPOSV ', infot, nout, lerr, ok )
356 infot = 7
357 CALL zposv( 'U', 2, 0, a, 2, b, 1, info )
358 CALL chkxer( 'ZPOSV ', infot, nout, lerr, ok )
359*
360* ZPOSVX
361*
362 srnamt = 'ZPOSVX'
363 infot = 1
364 CALL zposvx( '/', 'U', 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
365 $ rcond, r1, r2, w, rw, info )
366 CALL chkxer( 'ZPOSVX', infot, nout, lerr, ok )
367 infot = 2
368 CALL zposvx( 'N', '/', 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
369 $ rcond, r1, r2, w, rw, info )
370 CALL chkxer( 'ZPOSVX', infot, nout, lerr, ok )
371 infot = 3
372 CALL zposvx( 'N', 'U', -1, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
373 $ rcond, r1, r2, w, rw, info )
374 CALL chkxer( 'ZPOSVX', infot, nout, lerr, ok )
375 infot = 4
376 CALL zposvx( 'N', 'U', 0, -1, a, 1, af, 1, eq, c, b, 1, x, 1,
377 $ rcond, r1, r2, w, rw, info )
378 CALL chkxer( 'ZPOSVX', infot, nout, lerr, ok )
379 infot = 6
380 CALL zposvx( 'N', 'U', 2, 0, a, 1, af, 2, eq, c, b, 2, x, 2,
381 $ rcond, r1, r2, w, rw, info )
382 CALL chkxer( 'ZPOSVX', infot, nout, lerr, ok )
383 infot = 8
384 CALL zposvx( 'N', 'U', 2, 0, a, 2, af, 1, eq, c, b, 2, x, 2,
385 $ rcond, r1, r2, w, rw, info )
386 CALL chkxer( 'ZPOSVX', infot, nout, lerr, ok )
387 infot = 9
388 eq = '/'
389 CALL zposvx( 'F', 'U', 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
390 $ rcond, r1, r2, w, rw, info )
391 CALL chkxer( 'ZPOSVX', infot, nout, lerr, ok )
392 infot = 10
393 eq = 'Y'
394 CALL zposvx( 'F', 'U', 1, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
395 $ rcond, r1, r2, w, rw, info )
396 CALL chkxer( 'ZPOSVX', infot, nout, lerr, ok )
397 infot = 12
398 CALL zposvx( 'N', 'U', 2, 0, a, 2, af, 2, eq, c, b, 1, x, 2,
399 $ rcond, r1, r2, w, rw, info )
400 CALL chkxer( 'ZPOSVX', infot, nout, lerr, ok )
401 infot = 14
402 CALL zposvx( 'N', 'U', 2, 0, a, 2, af, 2, eq, c, b, 2, x, 1,
403 $ rcond, r1, r2, w, rw, info )
404 CALL chkxer( 'ZPOSVX', infot, nout, lerr, ok )
405*
406 ELSE IF( lsamen( 2, c2, 'PP' ) ) THEN
407*
408* ZPPSV
409*
410 srnamt = 'ZPPSV '
411 infot = 1
412 CALL zppsv( '/', 0, 0, a, b, 1, info )
413 CALL chkxer( 'ZPPSV ', infot, nout, lerr, ok )
414 infot = 2
415 CALL zppsv( 'U', -1, 0, a, b, 1, info )
416 CALL chkxer( 'ZPPSV ', infot, nout, lerr, ok )
417 infot = 3
418 CALL zppsv( 'U', 0, -1, a, b, 1, info )
419 CALL chkxer( 'ZPPSV ', infot, nout, lerr, ok )
420 infot = 6
421 CALL zppsv( 'U', 2, 0, a, b, 1, info )
422 CALL chkxer( 'ZPPSV ', infot, nout, lerr, ok )
423*
424* ZPPSVX
425*
426 srnamt = 'ZPPSVX'
427 infot = 1
428 CALL zppsvx( '/', 'U', 0, 0, a, af, eq, c, b, 1, x, 1, rcond,
429 $ r1, r2, w, rw, info )
430 CALL chkxer( 'ZPPSVX', infot, nout, lerr, ok )
431 infot = 2
432 CALL zppsvx( 'N', '/', 0, 0, a, af, eq, c, b, 1, x, 1, rcond,
433 $ r1, r2, w, rw, info )
434 CALL chkxer( 'ZPPSVX', infot, nout, lerr, ok )
435 infot = 3
436 CALL zppsvx( 'N', 'U', -1, 0, a, af, eq, c, b, 1, x, 1, rcond,
437 $ r1, r2, w, rw, info )
438 CALL chkxer( 'ZPPSVX', infot, nout, lerr, ok )
439 infot = 4
440 CALL zppsvx( 'N', 'U', 0, -1, a, af, eq, c, b, 1, x, 1, rcond,
441 $ r1, r2, w, rw, info )
442 CALL chkxer( 'ZPPSVX', infot, nout, lerr, ok )
443 infot = 7
444 eq = '/'
445 CALL zppsvx( 'F', 'U', 0, 0, a, af, eq, c, b, 1, x, 1, rcond,
446 $ r1, r2, w, rw, info )
447 CALL chkxer( 'ZPPSVX', infot, nout, lerr, ok )
448 infot = 8
449 eq = 'Y'
450 CALL zppsvx( 'F', 'U', 1, 0, a, af, eq, c, b, 1, x, 1, rcond,
451 $ r1, r2, w, rw, info )
452 CALL chkxer( 'ZPPSVX', infot, nout, lerr, ok )
453 infot = 10
454 CALL zppsvx( 'N', 'U', 2, 0, a, af, eq, c, b, 1, x, 2, rcond,
455 $ r1, r2, w, rw, info )
456 CALL chkxer( 'ZPPSVX', infot, nout, lerr, ok )
457 infot = 12
458 CALL zppsvx( 'N', 'U', 2, 0, a, af, eq, c, b, 2, x, 1, rcond,
459 $ r1, r2, w, rw, info )
460 CALL chkxer( 'ZPPSVX', infot, nout, lerr, ok )
461*
462 ELSE IF( lsamen( 2, c2, 'PB' ) ) THEN
463*
464* ZPBSV
465*
466 srnamt = 'ZPBSV '
467 infot = 1
468 CALL zpbsv( '/', 0, 0, 0, a, 1, b, 1, info )
469 CALL chkxer( 'ZPBSV ', infot, nout, lerr, ok )
470 infot = 2
471 CALL zpbsv( 'U', -1, 0, 0, a, 1, b, 1, info )
472 CALL chkxer( 'ZPBSV ', infot, nout, lerr, ok )
473 infot = 3
474 CALL zpbsv( 'U', 1, -1, 0, a, 1, b, 1, info )
475 CALL chkxer( 'ZPBSV ', infot, nout, lerr, ok )
476 infot = 4
477 CALL zpbsv( 'U', 0, 0, -1, a, 1, b, 1, info )
478 CALL chkxer( 'ZPBSV ', infot, nout, lerr, ok )
479 infot = 6
480 CALL zpbsv( 'U', 1, 1, 0, a, 1, b, 2, info )
481 CALL chkxer( 'ZPBSV ', infot, nout, lerr, ok )
482 infot = 8
483 CALL zpbsv( 'U', 2, 0, 0, a, 1, b, 1, info )
484 CALL chkxer( 'ZPBSV ', infot, nout, lerr, ok )
485*
486* ZPBSVX
487*
488 srnamt = 'ZPBSVX'
489 infot = 1
490 CALL zpbsvx( '/', 'U', 0, 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
491 $ rcond, r1, r2, w, rw, info )
492 CALL chkxer( 'ZPBSVX', infot, nout, lerr, ok )
493 infot = 2
494 CALL zpbsvx( 'N', '/', 0, 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
495 $ rcond, r1, r2, w, rw, info )
496 CALL chkxer( 'ZPBSVX', infot, nout, lerr, ok )
497 infot = 3
498 CALL zpbsvx( 'N', 'U', -1, 0, 0, a, 1, af, 1, eq, c, b, 1, x,
499 $ 1, rcond, r1, r2, w, rw, info )
500 CALL chkxer( 'ZPBSVX', infot, nout, lerr, ok )
501 infot = 4
502 CALL zpbsvx( 'N', 'U', 1, -1, 0, a, 1, af, 1, eq, c, b, 1, x,
503 $ 1, rcond, r1, r2, w, rw, info )
504 CALL chkxer( 'ZPBSVX', infot, nout, lerr, ok )
505 infot = 5
506 CALL zpbsvx( 'N', 'U', 0, 0, -1, a, 1, af, 1, eq, c, b, 1, x,
507 $ 1, rcond, r1, r2, w, rw, info )
508 CALL chkxer( 'ZPBSVX', infot, nout, lerr, ok )
509 infot = 7
510 CALL zpbsvx( 'N', 'U', 1, 1, 0, a, 1, af, 2, eq, c, b, 2, x, 2,
511 $ rcond, r1, r2, w, rw, info )
512 CALL chkxer( 'ZPBSVX', infot, nout, lerr, ok )
513 infot = 9
514 CALL zpbsvx( 'N', 'U', 1, 1, 0, a, 2, af, 1, eq, c, b, 2, x, 2,
515 $ rcond, r1, r2, w, rw, info )
516 CALL chkxer( 'ZPBSVX', infot, nout, lerr, ok )
517 infot = 10
518 eq = '/'
519 CALL zpbsvx( 'F', 'U', 0, 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
520 $ rcond, r1, r2, w, rw, info )
521 CALL chkxer( 'ZPBSVX', infot, nout, lerr, ok )
522 infot = 11
523 eq = 'Y'
524 CALL zpbsvx( 'F', 'U', 1, 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
525 $ rcond, r1, r2, w, rw, info )
526 CALL chkxer( 'ZPBSVX', infot, nout, lerr, ok )
527 infot = 13
528 CALL zpbsvx( 'N', 'U', 2, 0, 0, a, 1, af, 1, eq, c, b, 1, x, 2,
529 $ rcond, r1, r2, w, rw, info )
530 CALL chkxer( 'ZPBSVX', infot, nout, lerr, ok )
531 infot = 15
532 CALL zpbsvx( 'N', 'U', 2, 0, 0, a, 1, af, 1, eq, c, b, 2, x, 1,
533 $ rcond, r1, r2, w, rw, info )
534 CALL chkxer( 'ZPBSVX', infot, nout, lerr, ok )
535*
536 ELSE IF( lsamen( 2, c2, 'PT' ) ) THEN
537*
538* ZPTSV
539*
540 srnamt = 'ZPTSV '
541 infot = 1
542 CALL zptsv( -1, 0, r, a( 1, 1 ), b, 1, info )
543 CALL chkxer( 'ZPTSV ', infot, nout, lerr, ok )
544 infot = 2
545 CALL zptsv( 0, -1, r, a( 1, 1 ), b, 1, info )
546 CALL chkxer( 'ZPTSV ', infot, nout, lerr, ok )
547 infot = 6
548 CALL zptsv( 2, 0, r, a( 1, 1 ), b, 1, info )
549 CALL chkxer( 'ZPTSV ', infot, nout, lerr, ok )
550*
551* ZPTSVX
552*
553 srnamt = 'ZPTSVX'
554 infot = 1
555 CALL zptsvx( '/', 0, 0, r, a( 1, 1 ), rf, af( 1, 1 ), b, 1, x,
556 $ 1, rcond, r1, r2, w, rw, info )
557 CALL chkxer( 'ZPTSVX', infot, nout, lerr, ok )
558 infot = 2
559 CALL zptsvx( 'N', -1, 0, r, a( 1, 1 ), rf, af( 1, 1 ), b, 1, x,
560 $ 1, rcond, r1, r2, w, rw, info )
561 CALL chkxer( 'ZPTSVX', infot, nout, lerr, ok )
562 infot = 3
563 CALL zptsvx( 'N', 0, -1, r, a( 1, 1 ), rf, af( 1, 1 ), b, 1, x,
564 $ 1, rcond, r1, r2, w, rw, info )
565 CALL chkxer( 'ZPTSVX', infot, nout, lerr, ok )
566 infot = 9
567 CALL zptsvx( 'N', 2, 0, r, a( 1, 1 ), rf, af( 1, 1 ), b, 1, x,
568 $ 2, rcond, r1, r2, w, rw, info )
569 CALL chkxer( 'ZPTSVX', infot, nout, lerr, ok )
570 infot = 11
571 CALL zptsvx( 'N', 2, 0, r, a( 1, 1 ), rf, af( 1, 1 ), b, 2, x,
572 $ 1, rcond, r1, r2, w, rw, info )
573 CALL chkxer( 'ZPTSVX', infot, nout, lerr, ok )
574*
575 ELSE IF( lsamen( 2, c2, 'HE' ) ) THEN
576*
577* ZHESV
578*
579 srnamt = 'ZHESV '
580 infot = 1
581 CALL zhesv( '/', 0, 0, a, 1, ip, b, 1, w, 1, info )
582 CALL chkxer( 'ZHESV ', infot, nout, lerr, ok )
583 infot = 2
584 CALL zhesv( 'U', -1, 0, a, 1, ip, b, 1, w, 1, info )
585 CALL chkxer( 'ZHESV ', infot, nout, lerr, ok )
586 infot = 3
587 CALL zhesv( 'U', 0, -1, a, 1, ip, b, 1, w, 1, info )
588 CALL chkxer( 'ZHESV ', infot, nout, lerr, ok )
589 infot = 5
590 CALL zhesv( 'U', 2, 0, a, 1, ip, b, 2, w, 1, info )
591 CALL chkxer( 'ZHESV ', infot, nout, lerr, ok )
592 infot = 8
593 CALL zhesv( 'U', 2, 0, a, 2, ip, b, 1, w, 1, info )
594 CALL chkxer( 'ZHESV ', infot, nout, lerr, ok )
595 infot = 10
596 CALL zhesv( 'U', 0, 0, a, 1, ip, b, 1, w, 0, info )
597 CALL chkxer( 'ZHESV ', infot, nout, lerr, ok )
598 infot = 10
599 CALL zhesv( 'U', 0, 0, a, 1, ip, b, 1, w, -2, info )
600 CALL chkxer( 'ZHESV ', infot, nout, lerr, ok )
601*
602* ZHESVX
603*
604 srnamt = 'ZHESVX'
605 infot = 1
606 CALL zhesvx( '/', 'U', 0, 0, a, 1, af, 1, ip, b, 1, x, 1,
607 $ rcond, r1, r2, w, 1, rw, info )
608 CALL chkxer( 'ZHESVX', infot, nout, lerr, ok )
609 infot = 2
610 CALL zhesvx( 'N', '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1,
611 $ rcond, r1, r2, w, 1, rw, info )
612 CALL chkxer( 'ZHESVX', infot, nout, lerr, ok )
613 infot = 3
614 CALL zhesvx( 'N', 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1,
615 $ rcond, r1, r2, w, 1, rw, info )
616 CALL chkxer( 'ZHESVX', infot, nout, lerr, ok )
617 infot = 4
618 CALL zhesvx( 'N', 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1,
619 $ rcond, r1, r2, w, 1, rw, info )
620 CALL chkxer( 'ZHESVX', infot, nout, lerr, ok )
621 infot = 6
622 CALL zhesvx( 'N', 'U', 2, 0, a, 1, af, 2, ip, b, 2, x, 2,
623 $ rcond, r1, r2, w, 4, rw, info )
624 CALL chkxer( 'ZHESVX', infot, nout, lerr, ok )
625 infot = 8
626 CALL zhesvx( 'N', 'U', 2, 0, a, 2, af, 1, ip, b, 2, x, 2,
627 $ rcond, r1, r2, w, 4, rw, info )
628 CALL chkxer( 'ZHESVX', infot, nout, lerr, ok )
629 infot = 11
630 CALL zhesvx( 'N', 'U', 2, 0, a, 2, af, 2, ip, b, 1, x, 2,
631 $ rcond, r1, r2, w, 4, rw, info )
632 CALL chkxer( 'ZHESVX', infot, nout, lerr, ok )
633 infot = 13
634 CALL zhesvx( 'N', 'U', 2, 0, a, 2, af, 2, ip, b, 2, x, 1,
635 $ rcond, r1, r2, w, 4, rw, info )
636 CALL chkxer( 'ZHESVX', infot, nout, lerr, ok )
637 infot = 18
638 CALL zhesvx( 'N', 'U', 2, 0, a, 2, af, 2, ip, b, 2, x, 2,
639 $ rcond, r1, r2, w, 3, rw, info )
640 CALL chkxer( 'ZHESVX', infot, nout, lerr, ok )
641*
642 ELSE IF( lsamen( 2, c2, 'HR' ) ) THEN
643*
644* ZHESV_ROOK
645*
646 srnamt = 'ZHESV_ROOK'
647 infot = 1
648 CALL zhesv_rook( '/', 0, 0, a, 1, ip, b, 1, w, 1, info )
649 CALL chkxer( 'ZHESV_ROOK', infot, nout, lerr, ok )
650 infot = 2
651 CALL zhesv_rook( 'U', -1, 0, a, 1, ip, b, 1, w, 1, info )
652 CALL chkxer( 'ZHESV_ROOK', infot, nout, lerr, ok )
653 infot = 3
654 CALL zhesv_rook( 'U', 0, -1, a, 1, ip, b, 1, w, 1, info )
655 CALL chkxer( 'ZHESV_ROOK', infot, nout, lerr, ok )
656 infot = 8
657 CALL zhesv_rook( 'U', 2, 0, a, 2, ip, b, 1, w, 1, info )
658 CALL chkxer( 'ZHESV_ROOK', infot, nout, lerr, ok )
659 infot = 10
660 CALL zhesv_rook( 'U', 0, 0, a, 1, ip, b, 1, w, 0, info )
661 CALL chkxer( 'ZHESV_ROOK', infot, nout, lerr, ok )
662 infot = 10
663 CALL zhesv_rook( 'U', 0, 0, a, 1, ip, b, 1, w, -2, info )
664 CALL chkxer( 'ZHESV_ROOK', infot, nout, lerr, ok )
665*
666 ELSE IF( lsamen( 2, c2, 'HK' ) ) THEN
667*
668* ZSYSV_RK
669*
670* Test error exits of the driver that uses factorization
671* of a Hermitian indefinite matrix with rook
672* (bounded Bunch-Kaufman) pivoting with the new storage
673* format for factors L ( or U) and D.
674*
675* L (or U) is stored in A, diagonal of D is stored on the
676* diagonal of A, subdiagonal of D is stored in a separate array E.
677*
678 srnamt = 'ZHESV_RK'
679 infot = 1
680 CALL zhesv_rk( '/', 0, 0, a, 1, e, ip, b, 1, w, 1, info )
681 CALL chkxer( 'ZHESV_RK', infot, nout, lerr, ok )
682 infot = 2
683 CALL zhesv_rk( 'U', -1, 0, a, 1, e, ip, b, 1, w, 1, info )
684 CALL chkxer( 'ZHESV_RK', infot, nout, lerr, ok )
685 infot = 3
686 CALL zhesv_rk( 'U', 0, -1, a, 1, e, ip, b, 1, w, 1, info )
687 CALL chkxer( 'ZHESV_RK', infot, nout, lerr, ok )
688 infot = 5
689 CALL zhesv_rk( 'U', 2, 0, a, 1, e, ip, b, 2, w, 1, info )
690 CALL chkxer( 'ZHESV_RK', infot, nout, lerr, ok )
691 infot = 9
692 CALL zhesv_rk( 'U', 2, 0, a, 2, e, ip, b, 1, w, 1, info )
693 CALL chkxer( 'ZHESV_RK', infot, nout, lerr, ok )
694 infot = 11
695 CALL zhesv_rk( 'U', 0, 0, a, 1, e, ip, b, 1, w, 0, info )
696 CALL chkxer( 'ZHESV_RK', infot, nout, lerr, ok )
697 infot = 11
698 CALL zhesv_rk( 'U', 0, 0, a, 1, e, ip, b, 1, w, -2, info )
699 CALL chkxer( 'ZHESV_RK', infot, nout, lerr, ok )
700*
701 ELSE IF( lsamen( 2, c2, 'HA' ) ) THEN
702*
703* ZHESV_AA
704*
705 srnamt = 'ZHESV_AA'
706 infot = 1
707 CALL zhesv_aa( '/', 0, 0, a, 1, ip, b, 1, w, 1, info )
708 CALL chkxer( 'ZHESV_AA', infot, nout, lerr, ok )
709 infot = 2
710 CALL zhesv_aa( 'U', -1, 0, a, 1, ip, b, 1, w, 1, info )
711 CALL chkxer( 'ZHESV_AA', infot, nout, lerr, ok )
712 infot = 3
713 CALL zhesv_aa( 'U', 0, -1, a, 1, ip, b, 1, w, 1, info )
714 CALL chkxer( 'ZHESV_AA', infot, nout, lerr, ok )
715 infot = 8
716 CALL zhesv_aa( 'U', 2, 0, a, 2, ip, b, 1, w, 1, info )
717 CALL chkxer( 'ZHESV_AA', infot, nout, lerr, ok )
718*
719 ELSE IF( lsamen( 2, c2, 'H2' ) ) THEN
720*
721* ZHESV_AASEN_2STAGE
722*
723 srnamt = 'ZHESV_AA_2STAGE'
724 infot = 1
725 CALL zhesv_aa_2stage( '/', 0, 0, a, 1, a, 1, ip, ip, b, 1,
726 $ w, 1, info )
727 CALL chkxer( 'ZHESV_AA_2STAGE', infot, nout, lerr, ok )
728 infot = 2
729 CALL zhesv_aa_2stage( 'U', -1, 0, a, 1, a, 1, ip, ip, b, 1,
730 $ w, 1, info )
731 CALL chkxer( 'ZHESV_AA_2STAGE', infot, nout, lerr, ok )
732 infot = 3
733 CALL zhesv_aa_2stage( 'U', 0, -1, a, 1, a, 1, ip, ip, b, 1,
734 $ w, 1, info )
735 CALL chkxer( 'ZHESV_AA_2STAGE', infot, nout, lerr, ok )
736 infot = 5
737 CALL zhesv_aa_2stage( 'U', 2, 1, a, 1, a, 1, ip, ip, b, 1,
738 $ w, 1, info )
739 CALL chkxer( 'ZHESV_AA_2STAGE', infot, nout, lerr, ok )
740 infot = 11
741 CALL zhesv_aa_2stage( 'U', 2, 1, a, 2, a, 8, ip, ip, b, 1,
742 $ w, 1, info )
743 CALL chkxer( 'ZHESV_AA_2STAGE', infot, nout, lerr, ok )
744 infot = 7
745 CALL zhesv_aa_2stage( 'U', 2, 1, a, 2, a, 1, ip, ip, b, 2,
746 $ w, 1, info )
747 CALL chkxer( 'ZHESV_AA_2STAGE', infot, nout, lerr, ok )
748*
749 ELSE IF( lsamen( 2, c2, 'S2' ) ) THEN
750*
751* ZSYSV_AASEN_2STAGE
752*
753 srnamt = 'ZSYSV_AA_2STAGE'
754 infot = 1
755 CALL zsysv_aa_2stage( '/', 0, 0, a, 1, a, 1, ip, ip, b, 1,
756 $ w, 1, info )
757 CALL chkxer( 'ZSYSV_AA_2STAGE', infot, nout, lerr, ok )
758 infot = 2
759 CALL zsysv_aa_2stage( 'U', -1, 0, a, 1, a, 1, ip, ip, b, 1,
760 $ w, 1, info )
761 CALL chkxer( 'ZSYSV_AA_2STAGE', infot, nout, lerr, ok )
762 infot = 3
763 CALL zsysv_aa_2stage( 'U', 0, -1, a, 1, a, 1, ip, ip, b, 1,
764 $ w, 1, info )
765 CALL chkxer( 'ZSYSV_AA_2STAGE', infot, nout, lerr, ok )
766 infot = 5
767 CALL zsysv_aa_2stage( 'U', 2, 1, a, 1, a, 1, ip, ip, b, 1,
768 $ w, 1, info )
769 CALL chkxer( 'ZSYSV_AA_2STAGE', infot, nout, lerr, ok )
770 infot = 11
771 CALL zsysv_aa_2stage( 'U', 2, 1, a, 2, a, 8, ip, ip, b, 1,
772 $ w, 1, info )
773 CALL chkxer( 'ZSYSV_AA_2STAGE', infot, nout, lerr, ok )
774 infot = 7
775 CALL zsysv_aa_2stage( 'U', 2, 1, a, 2, a, 1, ip, ip, b, 2,
776 $ w, 1, info )
777 CALL chkxer( 'ZSYSV_AA_2STAGE', infot, nout, lerr, ok )
778**
779 ELSE IF( lsamen( 2, c2, 'HP' ) ) THEN
780*
781* ZHPSV
782*
783 srnamt = 'ZHPSV '
784 infot = 1
785 CALL zhpsv( '/', 0, 0, a, ip, b, 1, info )
786 CALL chkxer( 'ZHPSV ', infot, nout, lerr, ok )
787 infot = 2
788 CALL zhpsv( 'U', -1, 0, a, ip, b, 1, info )
789 CALL chkxer( 'ZHPSV ', infot, nout, lerr, ok )
790 infot = 3
791 CALL zhpsv( 'U', 0, -1, a, ip, b, 1, info )
792 CALL chkxer( 'ZHPSV ', infot, nout, lerr, ok )
793 infot = 7
794 CALL zhpsv( 'U', 2, 0, a, ip, b, 1, info )
795 CALL chkxer( 'ZHPSV ', infot, nout, lerr, ok )
796*
797* ZHPSVX
798*
799 srnamt = 'ZHPSVX'
800 infot = 1
801 CALL zhpsvx( '/', 'U', 0, 0, a, af, ip, b, 1, x, 1, rcond, r1,
802 $ r2, w, rw, info )
803 CALL chkxer( 'ZHPSVX', infot, nout, lerr, ok )
804 infot = 2
805 CALL zhpsvx( 'N', '/', 0, 0, a, af, ip, b, 1, x, 1, rcond, r1,
806 $ r2, w, rw, info )
807 CALL chkxer( 'ZHPSVX', infot, nout, lerr, ok )
808 infot = 3
809 CALL zhpsvx( 'N', 'U', -1, 0, a, af, ip, b, 1, x, 1, rcond, r1,
810 $ r2, w, rw, info )
811 CALL chkxer( 'ZHPSVX', infot, nout, lerr, ok )
812 infot = 4
813 CALL zhpsvx( 'N', 'U', 0, -1, a, af, ip, b, 1, x, 1, rcond, r1,
814 $ r2, w, rw, info )
815 CALL chkxer( 'ZHPSVX', infot, nout, lerr, ok )
816 infot = 9
817 CALL zhpsvx( 'N', 'U', 2, 0, a, af, ip, b, 1, x, 2, rcond, r1,
818 $ r2, w, rw, info )
819 CALL chkxer( 'ZHPSVX', infot, nout, lerr, ok )
820 infot = 11
821 CALL zhpsvx( 'N', 'U', 2, 0, a, af, ip, b, 2, x, 1, rcond, r1,
822 $ r2, w, rw, info )
823 CALL chkxer( 'ZHPSVX', infot, nout, lerr, ok )
824*
825 ELSE IF( lsamen( 2, c2, 'SY' ) ) THEN
826*
827* ZSYSV
828*
829 srnamt = 'ZSYSV '
830 infot = 1
831 CALL zsysv( '/', 0, 0, a, 1, ip, b, 1, w, 1, info )
832 CALL chkxer( 'ZSYSV ', infot, nout, lerr, ok )
833 infot = 2
834 CALL zsysv( 'U', -1, 0, a, 1, ip, b, 1, w, 1, info )
835 CALL chkxer( 'ZSYSV ', infot, nout, lerr, ok )
836 infot = 3
837 CALL zsysv( 'U', 0, -1, a, 1, ip, b, 1, w, 1, info )
838 CALL chkxer( 'ZSYSV ', infot, nout, lerr, ok )
839 infot = 8
840 CALL zsysv( 'U', 2, 0, a, 2, ip, b, 1, w, 1, info )
841 CALL chkxer( 'ZSYSV ', infot, nout, lerr, ok )
842 infot = 10
843 CALL zsysv( 'U', 0, 0, a, 1, ip, b, 1, w, 0, info )
844 CALL chkxer( 'ZSYSV ', infot, nout, lerr, ok )
845 infot = 10
846 CALL zsysv( 'U', 0, 0, a, 1, ip, b, 1, w, -2, info )
847 CALL chkxer( 'ZSYSV ', infot, nout, lerr, ok )
848*
849* ZSYSVX
850*
851 srnamt = 'ZSYSVX'
852 infot = 1
853 CALL zsysvx( '/', 'U', 0, 0, a, 1, af, 1, ip, b, 1, x, 1,
854 $ rcond, r1, r2, w, 1, rw, info )
855 CALL chkxer( 'ZSYSVX', infot, nout, lerr, ok )
856 infot = 2
857 CALL zsysvx( 'N', '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1,
858 $ rcond, r1, r2, w, 1, rw, info )
859 CALL chkxer( 'ZSYSVX', infot, nout, lerr, ok )
860 infot = 3
861 CALL zsysvx( 'N', 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1,
862 $ rcond, r1, r2, w, 1, rw, info )
863 CALL chkxer( 'ZSYSVX', infot, nout, lerr, ok )
864 infot = 4
865 CALL zsysvx( 'N', 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1,
866 $ rcond, r1, r2, w, 1, rw, info )
867 CALL chkxer( 'ZSYSVX', infot, nout, lerr, ok )
868 infot = 6
869 CALL zsysvx( 'N', 'U', 2, 0, a, 1, af, 2, ip, b, 2, x, 2,
870 $ rcond, r1, r2, w, 4, rw, info )
871 CALL chkxer( 'ZSYSVX', infot, nout, lerr, ok )
872 infot = 8
873 CALL zsysvx( 'N', 'U', 2, 0, a, 2, af, 1, ip, b, 2, x, 2,
874 $ rcond, r1, r2, w, 4, rw, info )
875 CALL chkxer( 'ZSYSVX', infot, nout, lerr, ok )
876 infot = 11
877 CALL zsysvx( 'N', 'U', 2, 0, a, 2, af, 2, ip, b, 1, x, 2,
878 $ rcond, r1, r2, w, 4, rw, info )
879 CALL chkxer( 'ZSYSVX', infot, nout, lerr, ok )
880 infot = 13
881 CALL zsysvx( 'N', 'U', 2, 0, a, 2, af, 2, ip, b, 2, x, 1,
882 $ rcond, r1, r2, w, 4, rw, info )
883 CALL chkxer( 'ZSYSVX', infot, nout, lerr, ok )
884 infot = 18
885 CALL zsysvx( 'N', 'U', 2, 0, a, 2, af, 2, ip, b, 2, x, 2,
886 $ rcond, r1, r2, w, 3, rw, info )
887 CALL chkxer( 'ZSYSVX', infot, nout, lerr, ok )
888*
889 ELSE IF( lsamen( 2, c2, 'SR' ) ) THEN
890*
891* ZSYSV_ROOK
892*
893 srnamt = 'ZSYSV_ROOK'
894 infot = 1
895 CALL zsysv_rook( '/', 0, 0, a, 1, ip, b, 1, w, 1, info )
896 CALL chkxer( 'ZSYSV_ROOK', infot, nout, lerr, ok )
897 infot = 2
898 CALL zsysv_rook( 'U', -1, 0, a, 1, ip, b, 1, w, 1, info )
899 CALL chkxer( 'ZSYSV_ROOK', infot, nout, lerr, ok )
900 infot = 3
901 CALL zsysv_rook( 'U', 0, -1, a, 1, ip, b, 1, w, 1, info )
902 CALL chkxer( 'ZSYSV_ROOK', infot, nout, lerr, ok )
903 infot = 8
904 CALL zsysv_rook( 'U', 2, 0, a, 2, ip, b, 1, w, 1, info )
905 CALL chkxer( 'ZSYSV_ROOK', infot, nout, lerr, ok )
906 infot = 10
907 CALL zsysv_rook( 'U', 0, 0, a, 1, ip, b, 1, w, 0, info )
908 CALL chkxer( 'ZSYSV_ROOK', infot, nout, lerr, ok )
909 infot = 10
910 CALL zsysv_rook( 'U', 0, 0, a, 1, ip, b, 1, w, -2, info )
911*
912 ELSE IF( lsamen( 2, c2, 'SK' ) ) THEN
913*
914* ZSYSV_RK
915*
916* Test error exits of the driver that uses factorization
917* of a symmetric indefinite matrix with rook
918* (bounded Bunch-Kaufman) pivoting with the new storage
919* format for factors L ( or U) and D.
920*
921* L (or U) is stored in A, diagonal of D is stored on the
922* diagonal of A, subdiagonal of D is stored in a separate array E.
923*
924 srnamt = 'ZSYSV_RK'
925 infot = 1
926 CALL zsysv_rk( '/', 0, 0, a, 1, e, ip, b, 1, w, 1, info )
927 CALL chkxer( 'ZSYSV_RK', infot, nout, lerr, ok )
928 infot = 2
929 CALL zsysv_rk( 'U', -1, 0, a, 1, e, ip, b, 1, w, 1, info )
930 CALL chkxer( 'ZSYSV_RK', infot, nout, lerr, ok )
931 infot = 3
932 CALL zsysv_rk( 'U', 0, -1, a, 1, e, ip, b, 1, w, 1, info )
933 CALL chkxer( 'ZSYSV_RK', infot, nout, lerr, ok )
934 infot = 5
935 CALL zsysv_rk( 'U', 2, 0, a, 1, e, ip, b, 2, w, 1, info )
936 CALL chkxer( 'ZSYSV_RK', infot, nout, lerr, ok )
937 infot = 9
938 CALL zsysv_rk( 'U', 2, 0, a, 2, e, ip, b, 1, w, 1, info )
939 CALL chkxer( 'ZSYSV_RK', infot, nout, lerr, ok )
940 infot = 11
941 CALL zsysv_rk( 'U', 0, 0, a, 1, e, ip, b, 1, w, 0, info )
942 CALL chkxer( 'ZSYSV_RK', infot, nout, lerr, ok )
943 infot = 11
944 CALL zsysv_rk( 'U', 0, 0, a, 1, e, ip, b, 1, w, -2, info )
945 CALL chkxer( 'ZSYSV_RK', infot, nout, lerr, ok )
946*
947 ELSE IF( lsamen( 2, c2, 'SP' ) ) THEN
948*
949* ZSPSV
950*
951 srnamt = 'ZSPSV '
952 infot = 1
953 CALL zspsv( '/', 0, 0, a, ip, b, 1, info )
954 CALL chkxer( 'ZSPSV ', infot, nout, lerr, ok )
955 infot = 2
956 CALL zspsv( 'U', -1, 0, a, ip, b, 1, info )
957 CALL chkxer( 'ZSPSV ', infot, nout, lerr, ok )
958 infot = 3
959 CALL zspsv( 'U', 0, -1, a, ip, b, 1, info )
960 CALL chkxer( 'ZSPSV ', infot, nout, lerr, ok )
961 infot = 7
962 CALL zspsv( 'U', 2, 0, a, ip, b, 1, info )
963 CALL chkxer( 'ZSPSV ', infot, nout, lerr, ok )
964*
965* ZSPSVX
966*
967 srnamt = 'ZSPSVX'
968 infot = 1
969 CALL zspsvx( '/', 'U', 0, 0, a, af, ip, b, 1, x, 1, rcond, r1,
970 $ r2, w, rw, info )
971 CALL chkxer( 'ZSPSVX', infot, nout, lerr, ok )
972 infot = 2
973 CALL zspsvx( 'N', '/', 0, 0, a, af, ip, b, 1, x, 1, rcond, r1,
974 $ r2, w, rw, info )
975 CALL chkxer( 'ZSPSVX', infot, nout, lerr, ok )
976 infot = 3
977 CALL zspsvx( 'N', 'U', -1, 0, a, af, ip, b, 1, x, 1, rcond, r1,
978 $ r2, w, rw, info )
979 CALL chkxer( 'ZSPSVX', infot, nout, lerr, ok )
980 infot = 4
981 CALL zspsvx( 'N', 'U', 0, -1, a, af, ip, b, 1, x, 1, rcond, r1,
982 $ r2, w, rw, info )
983 CALL chkxer( 'ZSPSVX', infot, nout, lerr, ok )
984 infot = 9
985 CALL zspsvx( 'N', 'U', 2, 0, a, af, ip, b, 1, x, 2, rcond, r1,
986 $ r2, w, rw, info )
987 CALL chkxer( 'ZSPSVX', infot, nout, lerr, ok )
988 infot = 11
989 CALL zspsvx( 'N', 'U', 2, 0, a, af, ip, b, 2, x, 1, rcond, r1,
990 $ r2, w, rw, info )
991 CALL chkxer( 'ZSPSVX', infot, nout, lerr, ok )
992 END IF
993*
994* Print a summary line.
995*
996 IF( ok ) THEN
997 WRITE( nout, fmt = 9999 )path
998 ELSE
999 WRITE( nout, fmt = 9998 )path
1000 END IF
1001*
1002 9999 FORMAT( 1x, a3, ' drivers passed the tests of the error exits' )
1003 9998 FORMAT( ' *** ', a3, ' drivers failed the tests of the error ',
1004 $ 'exits ***' )
1005*
1006 RETURN
1007*
1008* End of ZERRVX
1009*

◆ zgbt01()

subroutine zgbt01 ( integer m,
integer n,
integer kl,
integer ku,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldafac, * ) afac,
integer ldafac,
integer, dimension( * ) ipiv,
complex*16, dimension( * ) work,
double precision resid )

ZGBT01

Purpose:
!>
!> ZGBT01 reconstructs a band matrix A from its L*U factorization and
!> computes the residual:
!>    norm(L*U - A) / ( N * norm(A) * EPS ),
!> where EPS is the machine epsilon.
!>
!> The expression L*U - A is computed one column at a time, so A and
!> AFAC are not modified.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]KL
!>          KL is INTEGER
!>          The number of subdiagonals within the band of A.  KL >= 0.
!>
[in]KU
!>          KU is INTEGER
!>          The number of superdiagonals within the band of A.  KU >= 0.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original matrix A in band storage, stored in rows 1 to
!>          KL+KU+1.
!>
[in]LDA
!>          LDA is INTEGER.
!>          The leading dimension of the array A.  LDA >= max(1,KL+KU+1).
!>
[in]AFAC
!>          AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
!>          The factored form of the matrix A.  AFAC contains the banded
!>          factors L and U from the L*U factorization, as computed by
!>          ZGBTRF.  U is stored as an upper triangular band matrix with
!>          KL+KU superdiagonals in rows 1 to KL+KU+1, and the
!>          multipliers used during the factorization are stored in rows
!>          KL+KU+2 to 2*KL+KU+1.  See ZGBTRF for further details.
!>
[in]LDAFAC
!>          LDAFAC is INTEGER
!>          The leading dimension of the array AFAC.
!>          LDAFAC >= max(1,2*KL*KU+1).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (min(M,N))
!>          The pivot indices from ZGBTRF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*KL+KU+1)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(L*U - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file zgbt01.f.

126*
127* -- LAPACK test routine --
128* -- LAPACK is a software package provided by Univ. of Tennessee, --
129* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
130*
131* .. Scalar Arguments ..
132 INTEGER KL, KU, LDA, LDAFAC, M, N
133 DOUBLE PRECISION RESID
134* ..
135* .. Array Arguments ..
136 INTEGER IPIV( * )
137 COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ZERO, ONE
144 parameter( zero = 0.0d+0, one = 1.0d+0 )
145* ..
146* .. Local Scalars ..
147 INTEGER I, I1, I2, IL, IP, IW, J, JL, JU, JUA, KD, LENJ
148 DOUBLE PRECISION ANORM, EPS
149 COMPLEX*16 T
150* ..
151* .. External Functions ..
152 DOUBLE PRECISION DLAMCH, DZASUM
153 EXTERNAL dlamch, dzasum
154* ..
155* .. External Subroutines ..
156 EXTERNAL zaxpy, zcopy
157* ..
158* .. Intrinsic Functions ..
159 INTRINSIC dble, dcmplx, max, min
160* ..
161* .. Executable Statements ..
162*
163* Quick exit if M = 0 or N = 0.
164*
165 resid = zero
166 IF( m.LE.0 .OR. n.LE.0 )
167 $ RETURN
168*
169* Determine EPS and the norm of A.
170*
171 eps = dlamch( 'Epsilon' )
172 kd = ku + 1
173 anorm = zero
174 DO 10 j = 1, n
175 i1 = max( kd+1-j, 1 )
176 i2 = min( kd+m-j, kl+kd )
177 IF( i2.GE.i1 )
178 $ anorm = max( anorm, dzasum( i2-i1+1, a( i1, j ), 1 ) )
179 10 CONTINUE
180*
181* Compute one column at a time of L*U - A.
182*
183 kd = kl + ku + 1
184 DO 40 j = 1, n
185*
186* Copy the J-th column of U to WORK.
187*
188 ju = min( kl+ku, j-1 )
189 jl = min( kl, m-j )
190 lenj = min( m, j ) - j + ju + 1
191 IF( lenj.GT.0 ) THEN
192 CALL zcopy( lenj, afac( kd-ju, j ), 1, work, 1 )
193 DO 20 i = lenj + 1, ju + jl + 1
194 work( i ) = zero
195 20 CONTINUE
196*
197* Multiply by the unit lower triangular matrix L. Note that L
198* is stored as a product of transformations and permutations.
199*
200 DO 30 i = min( m-1, j ), j - ju, -1
201 il = min( kl, m-i )
202 IF( il.GT.0 ) THEN
203 iw = i - j + ju + 1
204 t = work( iw )
205 CALL zaxpy( il, t, afac( kd+1, i ), 1, work( iw+1 ),
206 $ 1 )
207 ip = ipiv( i )
208 IF( i.NE.ip ) THEN
209 ip = ip - j + ju + 1
210 work( iw ) = work( ip )
211 work( ip ) = t
212 END IF
213 END IF
214 30 CONTINUE
215*
216* Subtract the corresponding column of A.
217*
218 jua = min( ju, ku )
219 IF( jua+jl+1.GT.0 )
220 $ CALL zaxpy( jua+jl+1, -dcmplx( one ), a( ku+1-jua, j ),
221 $ 1, work( ju+1-jua ), 1 )
222*
223* Compute the 1-norm of the column.
224*
225 resid = max( resid, dzasum( ju+jl+1, work, 1 ) )
226 END IF
227 40 CONTINUE
228*
229* Compute norm(L*U - A) / ( N * norm(A) * EPS )
230*
231 IF( anorm.LE.zero ) THEN
232 IF( resid.NE.zero )
233 $ resid = one / eps
234 ELSE
235 resid = ( ( resid / dble( n ) ) / anorm ) / eps
236 END IF
237*
238 RETURN
239*
240* End of ZGBT01
241*
zaxpy
subroutine zaxpy(n, za, zx, incx, zy, incy)
ZAXPY
Definition zaxpy.f:88

◆ zgbt02()

subroutine zgbt02 ( character trans,
integer m,
integer n,
integer kl,
integer ku,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) rwork,
double precision resid )

ZGBT02

Purpose:
!>
!> ZGBT02 computes the residual for a solution of a banded system of
!> equations op(A)*X = B:
!>    RESID = norm(B - op(A)*X) / ( norm(op(A)) * norm(X) * EPS ),
!> where op(A) = A, A**T, or A**H, depending on TRANS, and EPS is the
!> machine epsilon.
!>
Parameters
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations:
!>          = 'N':  A    * X = B  (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose)
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]KL
!>          KL is INTEGER
!>          The number of subdiagonals within the band of A.  KL >= 0.
!>
[in]KU
!>          KU is INTEGER
!>          The number of superdiagonals within the band of A.  KU >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of B.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original matrix A in band storage, stored in rows 1 to
!>          KL+KU+1.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,KL+KU+1).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors for the system of linear
!>          equations.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  If TRANS = 'N',
!>          LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  IF TRANS = 'N',
!>          LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK)),
!>          where LRWORK >= M when TRANS = 'T' or 'C'; otherwise, RWORK
!>          is not referenced.
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - op(A)*X) / ( norm(op(A)) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 146 of file zgbt02.f.

148*
149* -- LAPACK test routine --
150* -- LAPACK is a software package provided by Univ. of Tennessee, --
151* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
152*
153* .. Scalar Arguments ..
154 CHARACTER TRANS
155 INTEGER KL, KU, LDA, LDB, LDX, M, N, NRHS
156 DOUBLE PRECISION RESID
157* ..
158* .. Array Arguments ..
159 DOUBLE PRECISION RWORK( * )
160 COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 DOUBLE PRECISION ZERO, ONE
167 parameter( zero = 0.0d+0, one = 1.0d+0 )
168 COMPLEX*16 CONE
169 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
170* ..
171* .. Local Scalars ..
172 INTEGER I1, I2, J, KD, N1
173 DOUBLE PRECISION ANORM, BNORM, EPS, TEMP, XNORM
174 COMPLEX*16 ZDUM
175* ..
176* .. External Functions ..
177 LOGICAL DISNAN, LSAME
178 DOUBLE PRECISION DLAMCH, DZASUM
179 EXTERNAL disnan, dlamch, dzasum, lsame
180* ..
181* .. External Subroutines ..
182 EXTERNAL zgbmv
183* ..
184* .. Statement Functions ..
185 DOUBLE PRECISION CABS1
186* ..
187* .. Intrinsic Functions ..
188 INTRINSIC abs, dble, dimag, max, min
189* ..
190* .. Statement Function definitions ..
191 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
192* ..
193* .. Executable Statements ..
194*
195* Quick return if N = 0 pr NRHS = 0
196*
197 IF( m.LE.0 .OR. n.LE.0 .OR. nrhs.LE.0 ) THEN
198 resid = zero
199 RETURN
200 END IF
201*
202* Exit with RESID = 1/EPS if ANORM = 0.
203*
204 eps = dlamch( 'Epsilon' )
205 anorm = zero
206 IF( lsame( trans, 'N' ) ) THEN
207*
208* Find norm1(A).
209*
210 kd = ku + 1
211 DO 10 j = 1, n
212 i1 = max( kd+1-j, 1 )
213 i2 = min( kd+m-j, kl+kd )
214 IF( i2.GE.i1 ) THEN
215 temp = dzasum( i2-i1+1, a( i1, j ), 1 )
216 IF( anorm.LT.temp .OR. disnan( temp ) ) anorm = temp
217 END IF
218 10 CONTINUE
219 ELSE
220*
221* Find normI(A).
222*
223 DO 12 i1 = 1, m
224 rwork( i1 ) = zero
225 12 CONTINUE
226 DO 16 j = 1, n
227 kd = ku + 1 - j
228 DO 14 i1 = max( 1, j-ku ), min( m, j+kl )
229 rwork( i1 ) = rwork( i1 ) + cabs1( a( kd+i1, j ) )
230 14 CONTINUE
231 16 CONTINUE
232 DO 18 i1 = 1, m
233 temp = rwork( i1 )
234 IF( anorm.LT.temp .OR. disnan( temp ) ) anorm = temp
235 18 CONTINUE
236 END IF
237 IF( anorm.LE.zero ) THEN
238 resid = one / eps
239 RETURN
240 END IF
241*
242 IF( lsame( trans, 'T' ) .OR. lsame( trans, 'C' ) ) THEN
243 n1 = n
244 ELSE
245 n1 = m
246 END IF
247*
248* Compute B - op(A)*X
249*
250 DO 20 j = 1, nrhs
251 CALL zgbmv( trans, m, n, kl, ku, -cone, a, lda, x( 1, j ), 1,
252 $ cone, b( 1, j ), 1 )
253 20 CONTINUE
254*
255* Compute the maximum over the number of right hand sides of
256* norm(B - op(A)*X) / ( norm(op(A)) * norm(X) * EPS ).
257*
258 resid = zero
259 DO 30 j = 1, nrhs
260 bnorm = dzasum( n1, b( 1, j ), 1 )
261 xnorm = dzasum( n1, x( 1, j ), 1 )
262 IF( xnorm.LE.zero ) THEN
263 resid = one / eps
264 ELSE
265 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
266 END IF
267 30 CONTINUE
268*
269 RETURN
270*
271* End of ZGBT02
272*
disnan
logical function disnan(din)
DISNAN tests input for NaN.
Definition disnan.f:59
zgbmv
subroutine zgbmv(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, incy)
ZGBMV
Definition zgbmv.f:187

◆ zgbt05()

subroutine zgbt05 ( character trans,
integer n,
integer kl,
integer ku,
integer nrhs,
complex*16, dimension( ldab, * ) ab,
integer ldab,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldxact, * ) xact,
integer ldxact,
double precision, dimension( * ) ferr,
double precision, dimension( * ) berr,
double precision, dimension( * ) reslts )

ZGBT05

Purpose:
!>
!> ZGBT05 tests the error bounds from iterative refinement for the
!> computed solution to a system of equations op(A)*X = B, where A is a
!> general band matrix of order n with kl subdiagonals and ku
!> superdiagonals and op(A) = A, A**T, or A**H, depending on TRANS.
!>
!> RESLTS(1) = test of the error bound
!>           = norm(X - XACT) / ( norm(X) * FERR )
!>
!> A large value is returned if this ratio is not less than one.
!>
!> RESLTS(2) = residual from the iterative refinement routine
!>           = the maximum of BERR / ( NZ*EPS + (*) ), where
!>             (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
!>             and NZ = max. number of nonzeros in any row of A, plus 1
!>
Parameters
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations.
!>          = 'N':  A    * X = B  (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
!>
[in]N
!>          N is INTEGER
!>          The number of rows of the matrices X, B, and XACT, and the
!>          order of the matrix A.  N >= 0.
!>
[in]KL
!>          KL is INTEGER
!>          The number of subdiagonals within the band of A.  KL >= 0.
!>
[in]KU
!>          KU is INTEGER
!>          The number of superdiagonals within the band of A.  KU >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of the matrices X, B, and XACT.
!>          NRHS >= 0.
!>
[in]AB
!>          AB is COMPLEX*16 array, dimension (LDAB,N)
!>          The original band matrix A, stored in rows 1 to KL+KU+1.
!>          The j-th column of A is stored in the j-th column of the
!>          array AB as follows:
!>          AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KL+KU+1.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vectors for the system of linear
!>          equations.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors.  Each vector is stored as a
!>          column of the matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in]XACT
!>          XACT is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( NZ*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 174 of file zgbt05.f.

176*
177* -- LAPACK test routine --
178* -- LAPACK is a software package provided by Univ. of Tennessee, --
179* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
180*
181* .. Scalar Arguments ..
182 CHARACTER TRANS
183 INTEGER KL, KU, LDAB, LDB, LDX, LDXACT, N, NRHS
184* ..
185* .. Array Arguments ..
186 DOUBLE PRECISION BERR( * ), FERR( * ), RESLTS( * )
187 COMPLEX*16 AB( LDAB, * ), B( LDB, * ), X( LDX, * ),
188 $ XACT( LDXACT, * )
189* ..
190*
191* =====================================================================
192*
193* .. Parameters ..
194 DOUBLE PRECISION ZERO, ONE
195 parameter( zero = 0.0d+0, one = 1.0d+0 )
196* ..
197* .. Local Scalars ..
198 LOGICAL NOTRAN
199 INTEGER I, IMAX, J, K, NZ
200 DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
201 COMPLEX*16 ZDUM
202* ..
203* .. External Functions ..
204 LOGICAL LSAME
205 INTEGER IZAMAX
206 DOUBLE PRECISION DLAMCH
207 EXTERNAL lsame, izamax, dlamch
208* ..
209* .. Intrinsic Functions ..
210 INTRINSIC abs, dble, dimag, max, min
211* ..
212* .. Statement Functions ..
213 DOUBLE PRECISION CABS1
214* ..
215* .. Statement Function definitions ..
216 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
217* ..
218* .. Executable Statements ..
219*
220* Quick exit if N = 0 or NRHS = 0.
221*
222 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
223 reslts( 1 ) = zero
224 reslts( 2 ) = zero
225 RETURN
226 END IF
227*
228 eps = dlamch( 'Epsilon' )
229 unfl = dlamch( 'Safe minimum' )
230 ovfl = one / unfl
231 notran = lsame( trans, 'N' )
232 nz = min( kl+ku+2, n+1 )
233*
234* Test 1: Compute the maximum of
235* norm(X - XACT) / ( norm(X) * FERR )
236* over all the vectors X and XACT using the infinity-norm.
237*
238 errbnd = zero
239 DO 30 j = 1, nrhs
240 imax = izamax( n, x( 1, j ), 1 )
241 xnorm = max( cabs1( x( imax, j ) ), unfl )
242 diff = zero
243 DO 10 i = 1, n
244 diff = max( diff, cabs1( x( i, j )-xact( i, j ) ) )
245 10 CONTINUE
246*
247 IF( xnorm.GT.one ) THEN
248 GO TO 20
249 ELSE IF( diff.LE.ovfl*xnorm ) THEN
250 GO TO 20
251 ELSE
252 errbnd = one / eps
253 GO TO 30
254 END IF
255*
256 20 CONTINUE
257 IF( diff / xnorm.LE.ferr( j ) ) THEN
258 errbnd = max( errbnd, ( diff / xnorm ) / ferr( j ) )
259 ELSE
260 errbnd = one / eps
261 END IF
262 30 CONTINUE
263 reslts( 1 ) = errbnd
264*
265* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
266* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
267*
268 DO 70 k = 1, nrhs
269 DO 60 i = 1, n
270 tmp = cabs1( b( i, k ) )
271 IF( notran ) THEN
272 DO 40 j = max( i-kl, 1 ), min( i+ku, n )
273 tmp = tmp + cabs1( ab( ku+1+i-j, j ) )*
274 $ cabs1( x( j, k ) )
275 40 CONTINUE
276 ELSE
277 DO 50 j = max( i-ku, 1 ), min( i+kl, n )
278 tmp = tmp + cabs1( ab( ku+1+j-i, i ) )*
279 $ cabs1( x( j, k ) )
280 50 CONTINUE
281 END IF
282 IF( i.EQ.1 ) THEN
283 axbi = tmp
284 ELSE
285 axbi = min( axbi, tmp )
286 END IF
287 60 CONTINUE
288 tmp = berr( k ) / ( nz*eps+nz*unfl / max( axbi, nz*unfl ) )
289 IF( k.EQ.1 ) THEN
290 reslts( 2 ) = tmp
291 ELSE
292 reslts( 2 ) = max( reslts( 2 ), tmp )
293 END IF
294 70 CONTINUE
295*
296 RETURN
297*
298* End of ZGBT05
299*
izamax
integer function izamax(n, zx, incx)
IZAMAX
Definition izamax.f:71

◆ zgelqs()

subroutine zgelqs ( integer m,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( lwork ) work,
integer lwork,
integer info )

ZGELQS

Purpose:
!>
!> Compute a minimum-norm solution
!>     min || A*X - B ||
!> using the LQ factorization
!>     A = L*Q
!> computed by ZGELQF.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= M >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of B.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the LQ factorization of the original matrix A as
!>          returned by ZGELQF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= M.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (M)
!>          Details of the orthogonal matrix Q.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the m-by-nrhs right hand side matrix B.
!>          On exit, the n-by-nrhs solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= N.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  LWORK must be at least NRHS,
!>          and should be at least NRHS*NB, where NB is the block size
!>          for this environment.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 119 of file zgelqs.f.

121*
122* -- LAPACK test routine --
123* -- LAPACK is a software package provided by Univ. of Tennessee, --
124* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
125*
126* .. Scalar Arguments ..
127 INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
128* ..
129* .. Array Arguments ..
130 COMPLEX*16 A( LDA, * ), B( LDB, * ), TAU( * ),
131 $ WORK( LWORK )
132* ..
133*
134* =====================================================================
135*
136* .. Parameters ..
137 COMPLEX*16 CZERO, CONE
138 parameter( czero = ( 0.0d+0, 0.0d+0 ),
139 $ cone = ( 1.0d+0, 0.0d+0 ) )
140* ..
141* .. External Subroutines ..
142 EXTERNAL xerbla, zlaset, ztrsm, zunmlq
143* ..
144* .. Intrinsic Functions ..
145 INTRINSIC max
146* ..
147* .. Executable Statements ..
148*
149* Test the input parameters.
150*
151 info = 0
152 IF( m.LT.0 ) THEN
153 info = -1
154 ELSE IF( n.LT.0 .OR. m.GT.n ) THEN
155 info = -2
156 ELSE IF( nrhs.LT.0 ) THEN
157 info = -3
158 ELSE IF( lda.LT.max( 1, m ) ) THEN
159 info = -5
160 ELSE IF( ldb.LT.max( 1, n ) ) THEN
161 info = -8
162 ELSE IF( lwork.LT.1 .OR. lwork.LT.nrhs .AND. m.GT.0 .AND. n.GT.0 )
163 $ THEN
164 info = -10
165 END IF
166 IF( info.NE.0 ) THEN
167 CALL xerbla( 'ZGELQS', -info )
168 RETURN
169 END IF
170*
171* Quick return if possible
172*
173 IF( n.EQ.0 .OR. nrhs.EQ.0 .OR. m.EQ.0 )
174 $ RETURN
175*
176* Solve L*X = B(1:m,:)
177*
178 CALL ztrsm( 'Left', 'Lower', 'No transpose', 'Non-unit', m, nrhs,
179 $ cone, a, lda, b, ldb )
180*
181* Set B(m+1:n,:) to zero
182*
183 IF( m.LT.n )
184 $ CALL zlaset( 'Full', n-m, nrhs, czero, czero, b( m+1, 1 ),
185 $ ldb )
186*
187* B := Q' * B
188*
189 CALL zunmlq( 'Left', 'Conjugate transpose', n, nrhs, m, a, lda,
190 $ tau, b, ldb, work, lwork, info )
191*
192 RETURN
193*
194* End of ZGELQS
195*
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60

◆ zgennd()

logical function zgennd ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda )

ZGENND

Purpose:
!>
!>    ZGENND tests that its argument has a real, non-negative diagonal.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows in A.
!>
[in]N
!>          N is INTEGER
!>          The number of columns in A.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA, N)
!>          The matrix.
!>
[in]LDA
!>          LDA is INTEGER
!>          Leading dimension of A.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 67 of file zgennd.f.

68*
69* -- LAPACK test routine --
70* -- LAPACK is a software package provided by Univ. of Tennessee, --
71* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
72*
73* .. Scalar Arguments ..
74 INTEGER M, N, LDA
75* ..
76* .. Array Arguments ..
77 COMPLEX*16 A( LDA, * )
78* ..
79*
80* =====================================================================
81*
82* .. Parameters ..
83 REAL ZERO
84 parameter( zero = 0.0e0 )
85* ..
86* .. Local Scalars ..
87 INTEGER I, K
88 COMPLEX*16 AII
89* ..
90* .. Intrinsics ..
91 INTRINSIC min, dble, dimag
92* ..
93* .. Executable Statements ..
94 k = min( m, n )
95 DO i = 1, k
96 aii = a( i, i )
97 IF( dble( aii ).LT.zero.OR.dimag( aii ).NE.zero ) THEN
98 zgennd = .false.
99 RETURN
100 END IF
101 END DO
102 zgennd = .true.
103 RETURN

◆ zgeqls()

subroutine zgeqls ( integer m,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( lwork ) work,
integer lwork,
integer info )

ZGEQLS

Purpose:
!>
!> Solve the least squares problem
!>     min || A*X - B ||
!> using the QL factorization
!>     A = Q*L
!> computed by ZGEQLF.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  M >= N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of B.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the QL factorization of the original matrix A as
!>          returned by ZGEQLF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= M.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (N)
!>          Details of the orthogonal matrix Q.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the m-by-nrhs right hand side matrix B.
!>          On exit, the n-by-nrhs solution matrix X, stored in rows
!>          m-n+1:m.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= M.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  LWORK must be at least NRHS,
!>          and should be at least NRHS*NB, where NB is the block size
!>          for this environment.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 120 of file zgeqls.f.

122*
123* -- LAPACK test routine --
124* -- LAPACK is a software package provided by Univ. of Tennessee, --
125* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
126*
127* .. Scalar Arguments ..
128 INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
129* ..
130* .. Array Arguments ..
131 COMPLEX*16 A( LDA, * ), B( LDB, * ), TAU( * ),
132 $ WORK( LWORK )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 COMPLEX*16 ONE
139 parameter( one = ( 1.0d+0, 0.0d+0 ) )
140* ..
141* .. External Subroutines ..
142 EXTERNAL xerbla, ztrsm, zunmql
143* ..
144* .. Intrinsic Functions ..
145 INTRINSIC max
146* ..
147* .. Executable Statements ..
148*
149* Test the input arguments.
150*
151 info = 0
152 IF( m.LT.0 ) THEN
153 info = -1
154 ELSE IF( n.LT.0 .OR. n.GT.m ) THEN
155 info = -2
156 ELSE IF( nrhs.LT.0 ) THEN
157 info = -3
158 ELSE IF( lda.LT.max( 1, m ) ) THEN
159 info = -5
160 ELSE IF( ldb.LT.max( 1, m ) ) THEN
161 info = -8
162 ELSE IF( lwork.LT.1 .OR. lwork.LT.nrhs .AND. m.GT.0 .AND. n.GT.0 )
163 $ THEN
164 info = -10
165 END IF
166 IF( info.NE.0 ) THEN
167 CALL xerbla( 'ZGEQLS', -info )
168 RETURN
169 END IF
170*
171* Quick return if possible
172*
173 IF( n.EQ.0 .OR. nrhs.EQ.0 .OR. m.EQ.0 )
174 $ RETURN
175*
176* B := Q' * B
177*
178 CALL zunmql( 'Left', 'Conjugate transpose', m, nrhs, n, a, lda,
179 $ tau, b, ldb, work, lwork, info )
180*
181* Solve L*X = B(m-n+1:m,:)
182*
183 CALL ztrsm( 'Left', 'Lower', 'No transpose', 'Non-unit', n, nrhs,
184 $ one, a( m-n+1, 1 ), lda, b( m-n+1, 1 ), ldb )
185*
186 RETURN
187*
188* End of ZGEQLS
189*

◆ zgeqrs()

subroutine zgeqrs ( integer m,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( lwork ) work,
integer lwork,
integer info )

ZGEQRS

Purpose:
!>
!> Solve the least squares problem
!>     min || A*X - B ||
!> using the QR factorization
!>     A = Q*R
!> computed by ZGEQRF.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  M >= N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of B.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the QR factorization of the original matrix A as
!>          returned by ZGEQRF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= M.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (N)
!>          Details of the orthogonal matrix Q.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the m-by-nrhs right hand side matrix B.
!>          On exit, the n-by-nrhs solution matrix X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= M.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  LWORK must be at least NRHS,
!>          and should be at least NRHS*NB, where NB is the block size
!>          for this environment.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 119 of file zgeqrs.f.

121*
122* -- LAPACK test routine --
123* -- LAPACK is a software package provided by Univ. of Tennessee, --
124* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
125*
126* .. Scalar Arguments ..
127 INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
128* ..
129* .. Array Arguments ..
130 COMPLEX*16 A( LDA, * ), B( LDB, * ), TAU( * ),
131 $ WORK( LWORK )
132* ..
133*
134* =====================================================================
135*
136* .. Parameters ..
137 COMPLEX*16 ONE
138 parameter( one = ( 1.0d+0, 0.0d+0 ) )
139* ..
140* .. External Subroutines ..
141 EXTERNAL xerbla, ztrsm, zunmqr
142* ..
143* .. Intrinsic Functions ..
144 INTRINSIC max
145* ..
146* .. Executable Statements ..
147*
148* Test the input arguments.
149*
150 info = 0
151 IF( m.LT.0 ) THEN
152 info = -1
153 ELSE IF( n.LT.0 .OR. n.GT.m ) THEN
154 info = -2
155 ELSE IF( nrhs.LT.0 ) THEN
156 info = -3
157 ELSE IF( lda.LT.max( 1, m ) ) THEN
158 info = -5
159 ELSE IF( ldb.LT.max( 1, m ) ) THEN
160 info = -8
161 ELSE IF( lwork.LT.1 .OR. lwork.LT.nrhs .AND. m.GT.0 .AND. n.GT.0 )
162 $ THEN
163 info = -10
164 END IF
165 IF( info.NE.0 ) THEN
166 CALL xerbla( 'ZGEQRS', -info )
167 RETURN
168 END IF
169*
170* Quick return if possible
171*
172 IF( n.EQ.0 .OR. nrhs.EQ.0 .OR. m.EQ.0 )
173 $ RETURN
174*
175* B := Q' * B
176*
177 CALL zunmqr( 'Left', 'Conjugate transpose', m, nrhs, n, a, lda,
178 $ tau, b, ldb, work, lwork, info )
179*
180* Solve R*X = B(1:n,:)
181*
182 CALL ztrsm( 'Left', 'Upper', 'No transpose', 'Non-unit', n, nrhs,
183 $ one, a, lda, b, ldb )
184*
185 RETURN
186*
187* End of ZGEQRS
188*

◆ zgerqs()

subroutine zgerqs ( integer m,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( lwork ) work,
integer lwork,
integer info )

ZGERQS

Purpose:
!>
!> Compute a minimum-norm solution
!>     min || A*X - B ||
!> using the RQ factorization
!>     A = R*Q
!> computed by ZGERQF.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= M >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of B.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the RQ factorization of the original matrix A as
!>          returned by ZGERQF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= M.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (M)
!>          Details of the orthogonal matrix Q.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the linear system.
!>          On exit, the solution vectors X.  Each solution vector
!>          is contained in rows 1:N of a column of B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B. LDB >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  LWORK must be at least NRHS,
!>          and should be at least NRHS*NB, where NB is the block size
!>          for this environment.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 120 of file zgerqs.f.

122*
123* -- LAPACK test routine --
124* -- LAPACK is a software package provided by Univ. of Tennessee, --
125* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
126*
127* .. Scalar Arguments ..
128 INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
129* ..
130* .. Array Arguments ..
131 COMPLEX*16 A( LDA, * ), B( LDB, * ), TAU( * ),
132 $ WORK( LWORK )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 COMPLEX*16 CZERO, CONE
139 parameter( czero = ( 0.0d+0, 0.0d+0 ),
140 $ cone = ( 1.0d+0, 0.0d+0 ) )
141* ..
142* .. External Subroutines ..
143 EXTERNAL xerbla, zlaset, ztrsm, zunmrq
144* ..
145* .. Intrinsic Functions ..
146 INTRINSIC max
147* ..
148* .. Executable Statements ..
149*
150* Test the input parameters.
151*
152 info = 0
153 IF( m.LT.0 ) THEN
154 info = -1
155 ELSE IF( n.LT.0 .OR. m.GT.n ) THEN
156 info = -2
157 ELSE IF( nrhs.LT.0 ) THEN
158 info = -3
159 ELSE IF( lda.LT.max( 1, m ) ) THEN
160 info = -5
161 ELSE IF( ldb.LT.max( 1, n ) ) THEN
162 info = -8
163 ELSE IF( lwork.LT.1 .OR. lwork.LT.nrhs .AND. m.GT.0 .AND. n.GT.0 )
164 $ THEN
165 info = -10
166 END IF
167 IF( info.NE.0 ) THEN
168 CALL xerbla( 'ZGERQS', -info )
169 RETURN
170 END IF
171*
172* Quick return if possible
173*
174 IF( n.EQ.0 .OR. nrhs.EQ.0 .OR. m.EQ.0 )
175 $ RETURN
176*
177* Solve R*X = B(n-m+1:n,:)
178*
179 CALL ztrsm( 'Left', 'Upper', 'No transpose', 'Non-unit', m, nrhs,
180 $ cone, a( 1, n-m+1 ), lda, b( n-m+1, 1 ), ldb )
181*
182* Set B(1:n-m,:) to zero
183*
184 CALL zlaset( 'Full', n-m, nrhs, czero, czero, b, ldb )
185*
186* B := Q' * B
187*
188 CALL zunmrq( 'Left', 'Conjugate transpose', n, nrhs, m, a, lda,
189 $ tau, b, ldb, work, lwork, info )
190*
191 RETURN
192*
193* End of ZGERQS
194*

◆ zget01()

subroutine zget01 ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldafac, * ) afac,
integer ldafac,
integer, dimension( * ) ipiv,
double precision, dimension( * ) rwork,
double precision resid )

ZGET01

Purpose:
!>
!> ZGET01 reconstructs a matrix A from its L*U factorization and
!> computes the residual
!>    norm(L*U - A) / ( N * norm(A) * EPS ),
!> where EPS is the machine epsilon.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original M x N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in,out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
!>          The factored form of the matrix A.  AFAC contains the factors
!>          L and U from the L*U factorization as computed by ZGETRF.
!>          Overwritten with the reconstructed matrix, and then with the
!>          difference L*U - A.
!>
[in]LDAFAC
!>          LDAFAC is INTEGER
!>          The leading dimension of the array AFAC.  LDAFAC >= max(1,M).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from ZGETRF.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(L*U - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 106 of file zget01.f.

108*
109* -- LAPACK test routine --
110* -- LAPACK is a software package provided by Univ. of Tennessee, --
111* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
112*
113* .. Scalar Arguments ..
114 INTEGER LDA, LDAFAC, M, N
115 DOUBLE PRECISION RESID
116* ..
117* .. Array Arguments ..
118 INTEGER IPIV( * )
119 DOUBLE PRECISION RWORK( * )
120 COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * )
121* ..
122*
123* =====================================================================
124*
125* .. Parameters ..
126 DOUBLE PRECISION ZERO, ONE
127 parameter( zero = 0.0d+0, one = 1.0d+0 )
128 COMPLEX*16 CONE
129 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
130* ..
131* .. Local Scalars ..
132 INTEGER I, J, K
133 DOUBLE PRECISION ANORM, EPS
134 COMPLEX*16 T
135* ..
136* .. External Functions ..
137 DOUBLE PRECISION DLAMCH, ZLANGE
138 COMPLEX*16 ZDOTU
139 EXTERNAL dlamch, zlange, zdotu
140* ..
141* .. External Subroutines ..
142 EXTERNAL zgemv, zlaswp, zscal, ztrmv
143* ..
144* .. Intrinsic Functions ..
145 INTRINSIC dble, min
146* ..
147* .. Executable Statements ..
148*
149* Quick exit if M = 0 or N = 0.
150*
151 IF( m.LE.0 .OR. n.LE.0 ) THEN
152 resid = zero
153 RETURN
154 END IF
155*
156* Determine EPS and the norm of A.
157*
158 eps = dlamch( 'Epsilon' )
159 anorm = zlange( '1', m, n, a, lda, rwork )
160*
161* Compute the product L*U and overwrite AFAC with the result.
162* A column at a time of the product is obtained, starting with
163* column N.
164*
165 DO 10 k = n, 1, -1
166 IF( k.GT.m ) THEN
167 CALL ztrmv( 'Lower', 'No transpose', 'Unit', m, afac,
168 $ ldafac, afac( 1, k ), 1 )
169 ELSE
170*
171* Compute elements (K+1:M,K)
172*
173 t = afac( k, k )
174 IF( k+1.LE.m ) THEN
175 CALL zscal( m-k, t, afac( k+1, k ), 1 )
176 CALL zgemv( 'No transpose', m-k, k-1, cone,
177 $ afac( k+1, 1 ), ldafac, afac( 1, k ), 1,
178 $ cone, afac( k+1, k ), 1 )
179 END IF
180*
181* Compute the (K,K) element
182*
183 afac( k, k ) = t + zdotu( k-1, afac( k, 1 ), ldafac,
184 $ afac( 1, k ), 1 )
185*
186* Compute elements (1:K-1,K)
187*
188 CALL ztrmv( 'Lower', 'No transpose', 'Unit', k-1, afac,
189 $ ldafac, afac( 1, k ), 1 )
190 END IF
191 10 CONTINUE
192 CALL zlaswp( n, afac, ldafac, 1, min( m, n ), ipiv, -1 )
193*
194* Compute the difference L*U - A and store in AFAC.
195*
196 DO 30 j = 1, n
197 DO 20 i = 1, m
198 afac( i, j ) = afac( i, j ) - a( i, j )
199 20 CONTINUE
200 30 CONTINUE
201*
202* Compute norm( L*U - A ) / ( N * norm(A) * EPS )
203*
204 resid = zlange( '1', m, n, afac, ldafac, rwork )
205*
206 IF( anorm.LE.zero ) THEN
207 IF( resid.NE.zero )
208 $ resid = one / eps
209 ELSE
210 resid = ( ( resid / dble( n ) ) / anorm ) / eps
211 END IF
212*
213 RETURN
214*
215* End of ZGET01
216*
zlaswp
subroutine zlaswp(n, a, lda, k1, k2, ipiv, incx)
ZLASWP performs a series of row interchanges on a general rectangular matrix.
Definition zlaswp.f:115
zdotu
complex *16 function zdotu(n, zx, incx, zy, incy)
ZDOTU
Definition zdotu.f:83
ztrmv
subroutine ztrmv(uplo, trans, diag, n, a, lda, x, incx)
ZTRMV
Definition ztrmv.f:147
zgemv
subroutine zgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
ZGEMV
Definition zgemv.f:158

◆ zget02()

subroutine zget02 ( character trans,
integer m,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) rwork,
double precision resid )

ZGET02

Purpose:
!>
!> ZGET02 computes the residual for a solution of a system of linear
!> equations op(A)*X = B:
!>    RESID = norm(B - op(A)*X) / ( norm(op(A)) * norm(X) * EPS ),
!> where op(A) = A, A**T, or A**H, depending on TRANS, and EPS is the
!> machine epsilon.
!>
Parameters
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations:
!>          = 'N':  A    * X = B  (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose)
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of B, the matrix of right hand sides.
!>          NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original M x N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors for the system of linear
!>          equations.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  If TRANS = 'N',
!>          LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - op(A)*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  IF TRANS = 'N',
!>          LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - op(A)*X) / ( norm(op(A)) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 132 of file zget02.f.

134*
135* -- LAPACK test routine --
136* -- LAPACK is a software package provided by Univ. of Tennessee, --
137* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
138*
139* .. Scalar Arguments ..
140 CHARACTER TRANS
141 INTEGER LDA, LDB, LDX, M, N, NRHS
142 DOUBLE PRECISION RESID
143* ..
144* .. Array Arguments ..
145 DOUBLE PRECISION RWORK( * )
146 COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * )
147* ..
148*
149* =====================================================================
150*
151* .. Parameters ..
152 DOUBLE PRECISION ZERO, ONE
153 parameter( zero = 0.0d+0, one = 1.0d+0 )
154 COMPLEX*16 CONE
155 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
156* ..
157* .. Local Scalars ..
158 INTEGER J, N1, N2
159 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
160* ..
161* .. External Functions ..
162 LOGICAL LSAME
163 DOUBLE PRECISION DLAMCH, DZASUM, ZLANGE
164 EXTERNAL lsame, dlamch, dzasum, zlange
165* ..
166* .. External Subroutines ..
167 EXTERNAL zgemm
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC max
171* ..
172* .. Executable Statements ..
173*
174* Quick exit if M = 0 or N = 0 or NRHS = 0
175*
176 IF( m.LE.0 .OR. n.LE.0 .OR. nrhs.EQ.0 ) THEN
177 resid = zero
178 RETURN
179 END IF
180*
181 IF( lsame( trans, 'T' ) .OR. lsame( trans, 'C' ) ) THEN
182 n1 = n
183 n2 = m
184 ELSE
185 n1 = m
186 n2 = n
187 END IF
188*
189* Exit with RESID = 1/EPS if ANORM = 0.
190*
191 eps = dlamch( 'Epsilon' )
192 IF( lsame( trans, 'N' ) ) THEN
193 anorm = zlange( '1', m, n, a, lda, rwork )
194 ELSE
195 anorm = zlange( 'I', m, n, a, lda, rwork )
196 END IF
197 IF( anorm.LE.zero ) THEN
198 resid = one / eps
199 RETURN
200 END IF
201*
202* Compute B - op(A)*X and store in B.
203*
204 CALL zgemm( trans, 'No transpose', n1, nrhs, n2, -cone, a, lda, x,
205 $ ldx, cone, b, ldb )
206*
207* Compute the maximum over the number of right hand sides of
208* norm(B - op(A)*X) / ( norm(op(A)) * norm(X) * EPS ) .
209*
210 resid = zero
211 DO 10 j = 1, nrhs
212 bnorm = dzasum( n1, b( 1, j ), 1 )
213 xnorm = dzasum( n2, x( 1, j ), 1 )
214 IF( xnorm.LE.zero ) THEN
215 resid = one / eps
216 ELSE
217 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
218 END IF
219 10 CONTINUE
220*
221 RETURN
222*
223* End of ZGET02
224*

◆ zget03()

subroutine zget03 ( integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldainv, * ) ainv,
integer ldainv,
complex*16, dimension( ldwork, * ) work,
integer ldwork,
double precision, dimension( * ) rwork,
double precision rcond,
double precision resid )

ZGET03

Purpose:
!>
!> ZGET03 computes the residual for a general matrix times its inverse:
!>    norm( I - AINV*A ) / ( N * norm(A) * norm(AINV) * EPS ),
!> where EPS is the machine epsilon.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original N x N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]AINV
!>          AINV is COMPLEX*16 array, dimension (LDAINV,N)
!>          The inverse of the matrix A.
!>
[in]LDAINV
!>          LDAINV is INTEGER
!>          The leading dimension of the array AINV.  LDAINV >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LDWORK,N)
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.  LDWORK >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of A, computed as
!>          ( 1/norm(A) ) / norm(AINV).
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(I - AINV*A) / ( N * norm(A) * norm(AINV) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 108 of file zget03.f.

110*
111* -- LAPACK test routine --
112* -- LAPACK is a software package provided by Univ. of Tennessee, --
113* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
114*
115* .. Scalar Arguments ..
116 INTEGER LDA, LDAINV, LDWORK, N
117 DOUBLE PRECISION RCOND, RESID
118* ..
119* .. Array Arguments ..
120 DOUBLE PRECISION RWORK( * )
121 COMPLEX*16 A( LDA, * ), AINV( LDAINV, * ),
122 $ WORK( LDWORK, * )
123* ..
124*
125* =====================================================================
126*
127* .. Parameters ..
128 DOUBLE PRECISION ZERO, ONE
129 parameter( zero = 0.0d+0, one = 1.0d+0 )
130 COMPLEX*16 CZERO, CONE
131 parameter( czero = ( 0.0d+0, 0.0d+0 ),
132 $ cone = ( 1.0d+0, 0.0d+0 ) )
133* ..
134* .. Local Scalars ..
135 INTEGER I
136 DOUBLE PRECISION AINVNM, ANORM, EPS
137* ..
138* .. External Functions ..
139 DOUBLE PRECISION DLAMCH, ZLANGE
140 EXTERNAL dlamch, zlange
141* ..
142* .. External Subroutines ..
143 EXTERNAL zgemm
144* ..
145* .. Intrinsic Functions ..
146 INTRINSIC dble
147* ..
148* .. Executable Statements ..
149*
150* Quick exit if N = 0.
151*
152 IF( n.LE.0 ) THEN
153 rcond = one
154 resid = zero
155 RETURN
156 END IF
157*
158* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
159*
160 eps = dlamch( 'Epsilon' )
161 anorm = zlange( '1', n, n, a, lda, rwork )
162 ainvnm = zlange( '1', n, n, ainv, ldainv, rwork )
163 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
164 rcond = zero
165 resid = one / eps
166 RETURN
167 END IF
168 rcond = ( one / anorm ) / ainvnm
169*
170* Compute I - A * AINV
171*
172 CALL zgemm( 'No transpose', 'No transpose', n, n, n, -cone, ainv,
173 $ ldainv, a, lda, czero, work, ldwork )
174 DO 10 i = 1, n
175 work( i, i ) = cone + work( i, i )
176 10 CONTINUE
177*
178* Compute norm(I - AINV*A) / (N * norm(A) * norm(AINV) * EPS)
179*
180 resid = zlange( '1', n, n, work, ldwork, rwork )
181*
182 resid = ( ( resid*rcond ) / eps ) / dble( n )
183*
184 RETURN
185*
186* End of ZGET03
187*

◆ zget04()

subroutine zget04 ( integer n,
integer nrhs,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldxact, * ) xact,
integer ldxact,
double precision rcond,
double precision resid )

ZGET04

Purpose:
!>
!> ZGET04 computes the difference between a computed solution and the
!> true solution to a system of linear equations.
!>
!> RESID =  ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ),
!> where RCOND is the reciprocal of the condition number and EPS is the
!> machine epsilon.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The number of rows of the matrices X and XACT.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of the matrices X and XACT.  NRHS >= 0.
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors.  Each vector is stored as a
!>          column of the matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in]XACT
!>          XACT is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of the coefficient
!>          matrix in the system of equations.
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the NRHS solution vectors of
!>          ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 101 of file zget04.f.

102*
103* -- LAPACK test routine --
104* -- LAPACK is a software package provided by Univ. of Tennessee, --
105* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
106*
107* .. Scalar Arguments ..
108 INTEGER LDX, LDXACT, N, NRHS
109 DOUBLE PRECISION RCOND, RESID
110* ..
111* .. Array Arguments ..
112 COMPLEX*16 X( LDX, * ), XACT( LDXACT, * )
113* ..
114*
115* =====================================================================
116*
117* .. Parameters ..
118 DOUBLE PRECISION ZERO
119 parameter( zero = 0.0d+0 )
120* ..
121* .. Local Scalars ..
122 INTEGER I, IX, J
123 DOUBLE PRECISION DIFFNM, EPS, XNORM
124 COMPLEX*16 ZDUM
125* ..
126* .. External Functions ..
127 INTEGER IZAMAX
128 DOUBLE PRECISION DLAMCH
129 EXTERNAL izamax, dlamch
130* ..
131* .. Intrinsic Functions ..
132 INTRINSIC abs, dble, dimag, max
133* ..
134* .. Statement Functions ..
135 DOUBLE PRECISION CABS1
136* ..
137* .. Statement Function definitions ..
138 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
139* ..
140* .. Executable Statements ..
141*
142* Quick exit if N = 0 or NRHS = 0.
143*
144 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
145 resid = zero
146 RETURN
147 END IF
148*
149* Exit with RESID = 1/EPS if RCOND is invalid.
150*
151 eps = dlamch( 'Epsilon' )
152 IF( rcond.LT.zero ) THEN
153 resid = 1.0d0 / eps
154 RETURN
155 END IF
156*
157* Compute the maximum of
158* norm(X - XACT) / ( norm(XACT) * EPS )
159* over all the vectors X and XACT .
160*
161 resid = zero
162 DO 20 j = 1, nrhs
163 ix = izamax( n, xact( 1, j ), 1 )
164 xnorm = cabs1( xact( ix, j ) )
165 diffnm = zero
166 DO 10 i = 1, n
167 diffnm = max( diffnm, cabs1( x( i, j )-xact( i, j ) ) )
168 10 CONTINUE
169 IF( xnorm.LE.zero ) THEN
170 IF( diffnm.GT.zero )
171 $ resid = 1.0d0 / eps
172 ELSE
173 resid = max( resid, ( diffnm / xnorm )*rcond )
174 END IF
175 20 CONTINUE
176 IF( resid*eps.LT.1.0d0 )
177 $ resid = resid / eps
178*
179 RETURN
180*
181* End of ZGET04
182*

◆ zget07()

subroutine zget07 ( character trans,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldxact, * ) xact,
integer ldxact,
double precision, dimension( * ) ferr,
logical chkferr,
double precision, dimension( * ) berr,
double precision, dimension( * ) reslts )

ZGET07

Purpose:
!>
!> ZGET07 tests the error bounds from iterative refinement for the
!> computed solution to a system of equations op(A)*X = B, where A is a
!> general n by n matrix and op(A) = A or A**T, depending on TRANS.
!>
!> RESLTS(1) = test of the error bound
!>           = norm(X - XACT) / ( norm(X) * FERR )
!>
!> A large value is returned if this ratio is not less than one.
!>
!> RESLTS(2) = residual from the iterative refinement routine
!>           = the maximum of BERR / ( (n+1)*EPS + (*) ), where
!>             (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
!>
Parameters
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations.
!>          = 'N':  A * X = B     (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
!>
[in]N
!>          N is INTEGER
!>          The number of rows of the matrices X and XACT.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of the matrices X and XACT.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original n by n matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vectors for the system of linear
!>          equations.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors.  Each vector is stored as a
!>          column of the matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in]XACT
!>          XACT is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]CHKFERR
!>          CHKFERR is LOGICAL
!>          Set to .TRUE. to check FERR, .FALSE. not to check FERR.
!>          When the test system is ill-conditioned, the 
!>          solution in XACT may be incorrect.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 164 of file zget07.f.

166*
167* -- LAPACK test routine --
168* -- LAPACK is a software package provided by Univ. of Tennessee, --
169* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
170*
171* .. Scalar Arguments ..
172 CHARACTER TRANS
173 LOGICAL CHKFERR
174 INTEGER LDA, LDB, LDX, LDXACT, N, NRHS
175* ..
176* .. Array Arguments ..
177 DOUBLE PRECISION BERR( * ), FERR( * ), RESLTS( * )
178 COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ),
179 $ XACT( LDXACT, * )
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 DOUBLE PRECISION ZERO, ONE
186 parameter( zero = 0.0d+0, one = 1.0d+0 )
187* ..
188* .. Local Scalars ..
189 LOGICAL NOTRAN
190 INTEGER I, IMAX, J, K
191 DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
192 COMPLEX*16 ZDUM
193* ..
194* .. External Functions ..
195 LOGICAL LSAME
196 INTEGER IZAMAX
197 DOUBLE PRECISION DLAMCH
198 EXTERNAL lsame, izamax, dlamch
199* ..
200* .. Intrinsic Functions ..
201 INTRINSIC abs, dble, dimag, max, min
202* ..
203* .. Statement Functions ..
204 DOUBLE PRECISION CABS1
205* ..
206* .. Statement Function definitions ..
207 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
208* ..
209* .. Executable Statements ..
210*
211* Quick exit if N = 0 or NRHS = 0.
212*
213 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
214 reslts( 1 ) = zero
215 reslts( 2 ) = zero
216 RETURN
217 END IF
218*
219 eps = dlamch( 'Epsilon' )
220 unfl = dlamch( 'Safe minimum' )
221 ovfl = one / unfl
222 notran = lsame( trans, 'N' )
223*
224* Test 1: Compute the maximum of
225* norm(X - XACT) / ( norm(X) * FERR )
226* over all the vectors X and XACT using the infinity-norm.
227*
228 errbnd = zero
229 IF( chkferr ) THEN
230 DO 30 j = 1, nrhs
231 imax = izamax( n, x( 1, j ), 1 )
232 xnorm = max( cabs1( x( imax, j ) ), unfl )
233 diff = zero
234 DO 10 i = 1, n
235 diff = max( diff, cabs1( x( i, j )-xact( i, j ) ) )
236 10 CONTINUE
237*
238 IF( xnorm.GT.one ) THEN
239 GO TO 20
240 ELSE IF( diff.LE.ovfl*xnorm ) THEN
241 GO TO 20
242 ELSE
243 errbnd = one / eps
244 GO TO 30
245 END IF
246*
247 20 CONTINUE
248 IF( diff / xnorm.LE.ferr( j ) ) THEN
249 errbnd = max( errbnd, ( diff / xnorm ) / ferr( j ) )
250 ELSE
251 errbnd = one / eps
252 END IF
253 30 CONTINUE
254 END IF
255 reslts( 1 ) = errbnd
256*
257* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
258* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
259*
260 DO 70 k = 1, nrhs
261 DO 60 i = 1, n
262 tmp = cabs1( b( i, k ) )
263 IF( notran ) THEN
264 DO 40 j = 1, n
265 tmp = tmp + cabs1( a( i, j ) )*cabs1( x( j, k ) )
266 40 CONTINUE
267 ELSE
268 DO 50 j = 1, n
269 tmp = tmp + cabs1( a( j, i ) )*cabs1( x( j, k ) )
270 50 CONTINUE
271 END IF
272 IF( i.EQ.1 ) THEN
273 axbi = tmp
274 ELSE
275 axbi = min( axbi, tmp )
276 END IF
277 60 CONTINUE
278 tmp = berr( k ) / ( ( n+1 )*eps+( n+1 )*unfl /
279 $ max( axbi, ( n+1 )*unfl ) )
280 IF( k.EQ.1 ) THEN
281 reslts( 2 ) = tmp
282 ELSE
283 reslts( 2 ) = max( reslts( 2 ), tmp )
284 END IF
285 70 CONTINUE
286*
287 RETURN
288*
289* End of ZGET07
290*

◆ zget08()

subroutine zget08 ( character trans,
integer m,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) rwork,
double precision resid )

ZGET08

Purpose:
!>
!> ZGET08 computes the residual for a solution of a system of linear
!> equations  A*x = b  or  A'*x = b:
!>    RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ),
!> where EPS is the machine epsilon.
!>
Parameters
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations:
!>          = 'N':  A *x = b
!>          = 'T':  A^T*x = b, where A^T is the transpose of A
!>          = 'C':  A^H*x = b, where A^H is the conjugate transpose of A
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of B, the matrix of right hand sides.
!>          NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original M x N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors for the system of linear
!>          equations.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  If TRANS = 'N',
!>          LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  IF TRANS = 'N',
!>          LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 131 of file zget08.f.

133*
134* -- LAPACK test routine --
135* -- LAPACK is a software package provided by Univ. of Tennessee, --
136* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
137*
138* .. Scalar Arguments ..
139 CHARACTER TRANS
140 INTEGER LDA, LDB, LDX, M, N, NRHS
141 DOUBLE PRECISION RESID
142* ..
143* .. Array Arguments ..
144 DOUBLE PRECISION RWORK( * )
145 COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * )
146* ..
147*
148* =====================================================================
149*
150* .. Parameters ..
151 DOUBLE PRECISION ZERO, ONE
152 parameter( zero = 0.0d+0, one = 1.0d+0 )
153 COMPLEX*16 CONE
154 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
155* ..
156* .. Local Scalars ..
157 INTEGER J, N1, N2
158 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
159 COMPLEX*16 ZDUM
160* ..
161* .. External Functions ..
162 LOGICAL LSAME
163 INTEGER IZAMAX
164 DOUBLE PRECISION DLAMCH, ZLANGE
165 EXTERNAL lsame, izamax, dlamch, zlange
166* ..
167* .. External Subroutines ..
168 EXTERNAL zgemm
169* ..
170* .. Intrinsic Functions ..
171 INTRINSIC abs, dble, dimag, max
172* ..
173* .. Statement Functions ..
174 DOUBLE PRECISION CABS1
175* ..
176* .. Statement Function definitions ..
177 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
178* ..
179* .. Executable Statements ..
180*
181* Quick exit if M = 0 or N = 0 or NRHS = 0
182*
183 IF( m.LE.0 .OR. n.LE.0 .OR. nrhs.EQ.0 ) THEN
184 resid = zero
185 RETURN
186 END IF
187*
188 IF( lsame( trans, 'T' ) .OR. lsame( trans, 'C' ) ) THEN
189 n1 = n
190 n2 = m
191 ELSE
192 n1 = m
193 n2 = n
194 END IF
195*
196* Exit with RESID = 1/EPS if ANORM = 0.
197*
198 eps = dlamch( 'Epsilon' )
199 anorm = zlange( 'I', n1, n2, a, lda, rwork )
200 IF( anorm.LE.zero ) THEN
201 resid = one / eps
202 RETURN
203 END IF
204*
205* Compute B - A*X (or B - A'*X ) and store in B.
206*
207 CALL zgemm( trans, 'No transpose', n1, nrhs, n2, -cone, a, lda, x,
208 $ ldx, cone, b, ldb )
209*
210* Compute the maximum over the number of right hand sides of
211* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) .
212*
213 resid = zero
214 DO 10 j = 1, nrhs
215 bnorm = cabs1( b( izamax( n1, b( 1, j ), 1 ), j ) )
216 xnorm = cabs1( x( izamax( n2, x( 1, j ), 1 ), j ) )
217 IF( xnorm.LE.zero ) THEN
218 resid = one / eps
219 ELSE
220 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
221 END IF
222 10 CONTINUE
223*
224 RETURN
225*
226* End of ZGET08
227*

◆ zgtt01()

subroutine zgtt01 ( integer n,
complex*16, dimension( * ) dl,
complex*16, dimension( * ) d,
complex*16, dimension( * ) du,
complex*16, dimension( * ) dlf,
complex*16, dimension( * ) df,
complex*16, dimension( * ) duf,
complex*16, dimension( * ) du2,
integer, dimension( * ) ipiv,
complex*16, dimension( ldwork, * ) work,
integer ldwork,
double precision, dimension( * ) rwork,
double precision resid )

ZGTT01

Purpose:
!>
!> ZGTT01 reconstructs a tridiagonal matrix A from its LU factorization
!> and computes the residual
!>    norm(L*U - A) / ( norm(A) * EPS ),
!> where EPS is the machine epsilon.
!>
Parameters
[in]N
!>          N is INTEGTER
!>          The order of the matrix A.  N >= 0.
!>
[in]DL
!>          DL is COMPLEX*16 array, dimension (N-1)
!>          The (n-1) sub-diagonal elements of A.
!>
[in]D
!>          D is COMPLEX*16 array, dimension (N)
!>          The diagonal elements of A.
!>
[in]DU
!>          DU is COMPLEX*16 array, dimension (N-1)
!>          The (n-1) super-diagonal elements of A.
!>
[in]DLF
!>          DLF is COMPLEX*16 array, dimension (N-1)
!>          The (n-1) multipliers that define the matrix L from the
!>          LU factorization of A.
!>
[in]DF
!>          DF is COMPLEX*16 array, dimension (N)
!>          The n diagonal elements of the upper triangular matrix U from
!>          the LU factorization of A.
!>
[in]DUF
!>          DUF is COMPLEX*16 array, dimension (N-1)
!>          The (n-1) elements of the first super-diagonal of U.
!>
[in]DU2
!>          DU2 is COMPLEX*16 array, dimension (N-2)
!>          The (n-2) elements of the second super-diagonal of U.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices; for 1 <= i <= n, row i of the matrix was
!>          interchanged with row IPIV(i).  IPIV(i) will always be either
!>          i or i+1; IPIV(i) = i indicates a row interchange was not
!>          required.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LDWORK,N)
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.  LDWORK >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The scaled residual:  norm(L*U - A) / (norm(A) * EPS)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 132 of file zgtt01.f.

134*
135* -- LAPACK test routine --
136* -- LAPACK is a software package provided by Univ. of Tennessee, --
137* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
138*
139* .. Scalar Arguments ..
140 INTEGER LDWORK, N
141 DOUBLE PRECISION RESID
142* ..
143* .. Array Arguments ..
144 INTEGER IPIV( * )
145 DOUBLE PRECISION RWORK( * )
146 COMPLEX*16 D( * ), DF( * ), DL( * ), DLF( * ), DU( * ),
147 $ DU2( * ), DUF( * ), WORK( LDWORK, * )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 DOUBLE PRECISION ONE, ZERO
154 parameter( one = 1.0d+0, zero = 0.0d+0 )
155* ..
156* .. Local Scalars ..
157 INTEGER I, IP, J, LASTJ
158 DOUBLE PRECISION ANORM, EPS
159 COMPLEX*16 LI
160* ..
161* .. External Functions ..
162 DOUBLE PRECISION DLAMCH, ZLANGT, ZLANHS
163 EXTERNAL dlamch, zlangt, zlanhs
164* ..
165* .. Intrinsic Functions ..
166 INTRINSIC min
167* ..
168* .. External Subroutines ..
169 EXTERNAL zaxpy, zswap
170* ..
171* .. Executable Statements ..
172*
173* Quick return if possible
174*
175 IF( n.LE.0 ) THEN
176 resid = zero
177 RETURN
178 END IF
179*
180 eps = dlamch( 'Epsilon' )
181*
182* Copy the matrix U to WORK.
183*
184 DO 20 j = 1, n
185 DO 10 i = 1, n
186 work( i, j ) = zero
187 10 CONTINUE
188 20 CONTINUE
189 DO 30 i = 1, n
190 IF( i.EQ.1 ) THEN
191 work( i, i ) = df( i )
192 IF( n.GE.2 )
193 $ work( i, i+1 ) = duf( i )
194 IF( n.GE.3 )
195 $ work( i, i+2 ) = du2( i )
196 ELSE IF( i.EQ.n ) THEN
197 work( i, i ) = df( i )
198 ELSE
199 work( i, i ) = df( i )
200 work( i, i+1 ) = duf( i )
201 IF( i.LT.n-1 )
202 $ work( i, i+2 ) = du2( i )
203 END IF
204 30 CONTINUE
205*
206* Multiply on the left by L.
207*
208 lastj = n
209 DO 40 i = n - 1, 1, -1
210 li = dlf( i )
211 CALL zaxpy( lastj-i+1, li, work( i, i ), ldwork,
212 $ work( i+1, i ), ldwork )
213 ip = ipiv( i )
214 IF( ip.EQ.i ) THEN
215 lastj = min( i+2, n )
216 ELSE
217 CALL zswap( lastj-i+1, work( i, i ), ldwork, work( i+1, i ),
218 $ ldwork )
219 END IF
220 40 CONTINUE
221*
222* Subtract the matrix A.
223*
224 work( 1, 1 ) = work( 1, 1 ) - d( 1 )
225 IF( n.GT.1 ) THEN
226 work( 1, 2 ) = work( 1, 2 ) - du( 1 )
227 work( n, n-1 ) = work( n, n-1 ) - dl( n-1 )
228 work( n, n ) = work( n, n ) - d( n )
229 DO 50 i = 2, n - 1
230 work( i, i-1 ) = work( i, i-1 ) - dl( i-1 )
231 work( i, i ) = work( i, i ) - d( i )
232 work( i, i+1 ) = work( i, i+1 ) - du( i )
233 50 CONTINUE
234 END IF
235*
236* Compute the 1-norm of the tridiagonal matrix A.
237*
238 anorm = zlangt( '1', n, dl, d, du )
239*
240* Compute the 1-norm of WORK, which is only guaranteed to be
241* upper Hessenberg.
242*
243 resid = zlanhs( '1', n, work, ldwork, rwork )
244*
245* Compute norm(L*U - A) / (norm(A) * EPS)
246*
247 IF( anorm.LE.zero ) THEN
248 IF( resid.NE.zero )
249 $ resid = one / eps
250 ELSE
251 resid = ( resid / anorm ) / eps
252 END IF
253*
254 RETURN
255*
256* End of ZGTT01
257*
zlanhs
double precision function zlanhs(norm, n, a, lda, work)
ZLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition zlanhs.f:109

◆ zgtt02()

subroutine zgtt02 ( character trans,
integer n,
integer nrhs,
complex*16, dimension( * ) dl,
complex*16, dimension( * ) d,
complex*16, dimension( * ) du,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision resid )

ZGTT02

Purpose:
!>
!> ZGTT02 computes the residual for the solution to a tridiagonal
!> system of equations:
!>    RESID = norm(B - op(A)*X) / (norm(op(A)) * norm(X) * EPS),
!> where EPS is the machine epsilon.
!>
Parameters
[in]TRANS
!>          TRANS is CHARACTER
!>          Specifies the form of the residual.
!>          = 'N':  B - A    * X  (No transpose)
!>          = 'T':  B - A**T * X  (Transpose)
!>          = 'C':  B - A**H * X  (Conjugate transpose)
!>
[in]N
!>          N is INTEGTER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices B and X.  NRHS >= 0.
!>
[in]DL
!>          DL is COMPLEX*16 array, dimension (N-1)
!>          The (n-1) sub-diagonal elements of A.
!>
[in]D
!>          D is COMPLEX*16 array, dimension (N)
!>          The diagonal elements of A.
!>
[in]DU
!>          DU is COMPLEX*16 array, dimension (N-1)
!>          The (n-1) super-diagonal elements of A.
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - op(A)*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(B - op(A)*X) / (norm(op(A)) * norm(X) * EPS)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 122 of file zgtt02.f.

124*
125* -- LAPACK test routine --
126* -- LAPACK is a software package provided by Univ. of Tennessee, --
127* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
128*
129* .. Scalar Arguments ..
130 CHARACTER TRANS
131 INTEGER LDB, LDX, N, NRHS
132 DOUBLE PRECISION RESID
133* ..
134* .. Array Arguments ..
135 COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ),
136 $ X( LDX, * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 DOUBLE PRECISION ONE, ZERO
143 parameter( one = 1.0d+0, zero = 0.0d+0 )
144* ..
145* .. Local Scalars ..
146 INTEGER J
147 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
148* ..
149* .. External Functions ..
150 LOGICAL LSAME
151 DOUBLE PRECISION DLAMCH, DZASUM, ZLANGT
152 EXTERNAL lsame, dlamch, dzasum, zlangt
153* ..
154* .. External Subroutines ..
155 EXTERNAL zlagtm
156* ..
157* .. Intrinsic Functions ..
158 INTRINSIC max
159* ..
160* .. Executable Statements ..
161*
162* Quick exit if N = 0 or NRHS = 0
163*
164 resid = zero
165 IF( n.LE.0 .OR. nrhs.EQ.0 )
166 $ RETURN
167*
168* Compute the maximum over the number of right hand sides of
169* norm(B - op(A)*X) / ( norm(op(A)) * norm(X) * EPS ).
170*
171 IF( lsame( trans, 'N' ) ) THEN
172 anorm = zlangt( '1', n, dl, d, du )
173 ELSE
174 anorm = zlangt( 'I', n, dl, d, du )
175 END IF
176*
177* Exit with RESID = 1/EPS if ANORM = 0.
178*
179 eps = dlamch( 'Epsilon' )
180 IF( anorm.LE.zero ) THEN
181 resid = one / eps
182 RETURN
183 END IF
184*
185* Compute B - op(A)*X and store in B.
186*
187 CALL zlagtm( trans, n, nrhs, -one, dl, d, du, x, ldx, one, b,
188 $ ldb )
189*
190 DO 10 j = 1, nrhs
191 bnorm = dzasum( n, b( 1, j ), 1 )
192 xnorm = dzasum( n, x( 1, j ), 1 )
193 IF( xnorm.LE.zero ) THEN
194 resid = one / eps
195 ELSE
196 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
197 END IF
198 10 CONTINUE
199*
200 RETURN
201*
202* End of ZGTT02
203*

◆ zgtt05()

subroutine zgtt05 ( character trans,
integer n,
integer nrhs,
complex*16, dimension( * ) dl,
complex*16, dimension( * ) d,
complex*16, dimension( * ) du,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldxact, * ) xact,
integer ldxact,
double precision, dimension( * ) ferr,
double precision, dimension( * ) berr,
double precision, dimension( * ) reslts )

ZGTT05

Purpose:
!>
!> ZGTT05 tests the error bounds from iterative refinement for the
!> computed solution to a system of equations A*X = B, where A is a
!> general tridiagonal matrix of order n and op(A) = A or A**T,
!> depending on TRANS.
!>
!> RESLTS(1) = test of the error bound
!>           = norm(X - XACT) / ( norm(X) * FERR )
!>
!> A large value is returned if this ratio is not less than one.
!>
!> RESLTS(2) = residual from the iterative refinement routine
!>           = the maximum of BERR / ( NZ*EPS + (*) ), where
!>             (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
!>             and NZ = max. number of nonzeros in any row of A, plus 1
!>
Parameters
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations.
!>          = 'N':  A * X = B     (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose = Transpose)
!>
[in]N
!>          N is INTEGER
!>          The number of rows of the matrices X and XACT.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of the matrices X and XACT.  NRHS >= 0.
!>
[in]DL
!>          DL is COMPLEX*16 array, dimension (N-1)
!>          The (n-1) sub-diagonal elements of A.
!>
[in]D
!>          D is COMPLEX*16 array, dimension (N)
!>          The diagonal elements of A.
!>
[in]DU
!>          DU is COMPLEX*16 array, dimension (N-1)
!>          The (n-1) super-diagonal elements of A.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vectors for the system of linear
!>          equations.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors.  Each vector is stored as a
!>          column of the matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in]XACT
!>          XACT is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( NZ*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 163 of file zgtt05.f.

165*
166* -- LAPACK test routine --
167* -- LAPACK is a software package provided by Univ. of Tennessee, --
168* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
169*
170* .. Scalar Arguments ..
171 CHARACTER TRANS
172 INTEGER LDB, LDX, LDXACT, N, NRHS
173* ..
174* .. Array Arguments ..
175 DOUBLE PRECISION BERR( * ), FERR( * ), RESLTS( * )
176 COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ),
177 $ X( LDX, * ), XACT( LDXACT, * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 DOUBLE PRECISION ZERO, ONE
184 parameter( zero = 0.0d+0, one = 1.0d+0 )
185* ..
186* .. Local Scalars ..
187 LOGICAL NOTRAN
188 INTEGER I, IMAX, J, K, NZ
189 DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
190 COMPLEX*16 ZDUM
191* ..
192* .. External Functions ..
193 LOGICAL LSAME
194 INTEGER IZAMAX
195 DOUBLE PRECISION DLAMCH
196 EXTERNAL lsame, izamax, dlamch
197* ..
198* .. Intrinsic Functions ..
199 INTRINSIC abs, dble, dimag, max, min
200* ..
201* .. Statement Functions ..
202 DOUBLE PRECISION CABS1
203* ..
204* .. Statement Function definitions ..
205 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
206* ..
207* .. Executable Statements ..
208*
209* Quick exit if N = 0 or NRHS = 0.
210*
211 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
212 reslts( 1 ) = zero
213 reslts( 2 ) = zero
214 RETURN
215 END IF
216*
217 eps = dlamch( 'Epsilon' )
218 unfl = dlamch( 'Safe minimum' )
219 ovfl = one / unfl
220 notran = lsame( trans, 'N' )
221 nz = 4
222*
223* Test 1: Compute the maximum of
224* norm(X - XACT) / ( norm(X) * FERR )
225* over all the vectors X and XACT using the infinity-norm.
226*
227 errbnd = zero
228 DO 30 j = 1, nrhs
229 imax = izamax( n, x( 1, j ), 1 )
230 xnorm = max( cabs1( x( imax, j ) ), unfl )
231 diff = zero
232 DO 10 i = 1, n
233 diff = max( diff, cabs1( x( i, j )-xact( i, j ) ) )
234 10 CONTINUE
235*
236 IF( xnorm.GT.one ) THEN
237 GO TO 20
238 ELSE IF( diff.LE.ovfl*xnorm ) THEN
239 GO TO 20
240 ELSE
241 errbnd = one / eps
242 GO TO 30
243 END IF
244*
245 20 CONTINUE
246 IF( diff / xnorm.LE.ferr( j ) ) THEN
247 errbnd = max( errbnd, ( diff / xnorm ) / ferr( j ) )
248 ELSE
249 errbnd = one / eps
250 END IF
251 30 CONTINUE
252 reslts( 1 ) = errbnd
253*
254* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
255* (*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
256*
257 DO 60 k = 1, nrhs
258 IF( notran ) THEN
259 IF( n.EQ.1 ) THEN
260 axbi = cabs1( b( 1, k ) ) +
261 $ cabs1( d( 1 ) )*cabs1( x( 1, k ) )
262 ELSE
263 axbi = cabs1( b( 1, k ) ) +
264 $ cabs1( d( 1 ) )*cabs1( x( 1, k ) ) +
265 $ cabs1( du( 1 ) )*cabs1( x( 2, k ) )
266 DO 40 i = 2, n - 1
267 tmp = cabs1( b( i, k ) ) +
268 $ cabs1( dl( i-1 ) )*cabs1( x( i-1, k ) ) +
269 $ cabs1( d( i ) )*cabs1( x( i, k ) ) +
270 $ cabs1( du( i ) )*cabs1( x( i+1, k ) )
271 axbi = min( axbi, tmp )
272 40 CONTINUE
273 tmp = cabs1( b( n, k ) ) + cabs1( dl( n-1 ) )*
274 $ cabs1( x( n-1, k ) ) + cabs1( d( n ) )*
275 $ cabs1( x( n, k ) )
276 axbi = min( axbi, tmp )
277 END IF
278 ELSE
279 IF( n.EQ.1 ) THEN
280 axbi = cabs1( b( 1, k ) ) +
281 $ cabs1( d( 1 ) )*cabs1( x( 1, k ) )
282 ELSE
283 axbi = cabs1( b( 1, k ) ) +
284 $ cabs1( d( 1 ) )*cabs1( x( 1, k ) ) +
285 $ cabs1( dl( 1 ) )*cabs1( x( 2, k ) )
286 DO 50 i = 2, n - 1
287 tmp = cabs1( b( i, k ) ) +
288 $ cabs1( du( i-1 ) )*cabs1( x( i-1, k ) ) +
289 $ cabs1( d( i ) )*cabs1( x( i, k ) ) +
290 $ cabs1( dl( i ) )*cabs1( x( i+1, k ) )
291 axbi = min( axbi, tmp )
292 50 CONTINUE
293 tmp = cabs1( b( n, k ) ) + cabs1( du( n-1 ) )*
294 $ cabs1( x( n-1, k ) ) + cabs1( d( n ) )*
295 $ cabs1( x( n, k ) )
296 axbi = min( axbi, tmp )
297 END IF
298 END IF
299 tmp = berr( k ) / ( nz*eps+nz*unfl / max( axbi, nz*unfl ) )
300 IF( k.EQ.1 ) THEN
301 reslts( 2 ) = tmp
302 ELSE
303 reslts( 2 ) = max( reslts( 2 ), tmp )
304 END IF
305 60 CONTINUE
306*
307 RETURN
308*
309* End of ZGTT05
310*

◆ zhet01()

subroutine zhet01 ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldafac, * ) afac,
integer ldafac,
integer, dimension( * ) ipiv,
complex*16, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) rwork,
double precision resid )

ZHET01

Purpose:
!>
!> ZHET01 reconstructs a Hermitian indefinite matrix A from its
!> block L*D*L' or U*D*U' factorization and computes the residual
!>    norm( C - A ) / ( N * norm(A) * EPS ),
!> where C is the reconstructed matrix, EPS is the machine epsilon,
!> L' is the conjugate transpose of L, and U' is the conjugate transpose
!> of U.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original Hermitian matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N)
!>
[in]AFAC
!>          AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
!>          The factored form of the matrix A.  AFAC contains the block
!>          diagonal matrix D and the multipliers used to obtain the
!>          factor L or U from the block L*D*L' or U*D*U' factorization
!>          as computed by ZHETRF.
!>
[in]LDAFAC
!>          LDAFAC is INTEGER
!>          The leading dimension of the array AFAC.  LDAFAC >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from ZHETRF.
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file zhet01.f.

126*
127* -- LAPACK test routine --
128* -- LAPACK is a software package provided by Univ. of Tennessee, --
129* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
130*
131* .. Scalar Arguments ..
132 CHARACTER UPLO
133 INTEGER LDA, LDAFAC, LDC, N
134 DOUBLE PRECISION RESID
135* ..
136* .. Array Arguments ..
137 INTEGER IPIV( * )
138 DOUBLE PRECISION RWORK( * )
139 COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
140* ..
141*
142* =====================================================================
143*
144* .. Parameters ..
145 DOUBLE PRECISION ZERO, ONE
146 parameter( zero = 0.0d+0, one = 1.0d+0 )
147 COMPLEX*16 CZERO, CONE
148 parameter( czero = ( 0.0d+0, 0.0d+0 ),
149 $ cone = ( 1.0d+0, 0.0d+0 ) )
150* ..
151* .. Local Scalars ..
152 INTEGER I, INFO, J
153 DOUBLE PRECISION ANORM, EPS
154* ..
155* .. External Functions ..
156 LOGICAL LSAME
157 DOUBLE PRECISION DLAMCH, ZLANHE
158 EXTERNAL lsame, dlamch, zlanhe
159* ..
160* .. External Subroutines ..
161 EXTERNAL zlaset, zlavhe
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC dble, dimag
165* ..
166* .. Executable Statements ..
167*
168* Quick exit if N = 0.
169*
170 IF( n.LE.0 ) THEN
171 resid = zero
172 RETURN
173 END IF
174*
175* Determine EPS and the norm of A.
176*
177 eps = dlamch( 'Epsilon' )
178 anorm = zlanhe( '1', uplo, n, a, lda, rwork )
179*
180* Check the imaginary parts of the diagonal elements and return with
181* an error code if any are nonzero.
182*
183 DO 10 j = 1, n
184 IF( dimag( afac( j, j ) ).NE.zero ) THEN
185 resid = one / eps
186 RETURN
187 END IF
188 10 CONTINUE
189*
190* Initialize C to the identity matrix.
191*
192 CALL zlaset( 'Full', n, n, czero, cone, c, ldc )
193*
194* Call ZLAVHE to form the product D * U' (or D * L' ).
195*
196 CALL zlavhe( uplo, 'Conjugate', 'Non-unit', n, n, afac, ldafac,
197 $ ipiv, c, ldc, info )
198*
199* Call ZLAVHE again to multiply by U (or L ).
200*
201 CALL zlavhe( uplo, 'No transpose', 'Unit', n, n, afac, ldafac,
202 $ ipiv, c, ldc, info )
203*
204* Compute the difference C - A .
205*
206 IF( lsame( uplo, 'U' ) ) THEN
207 DO 30 j = 1, n
208 DO 20 i = 1, j - 1
209 c( i, j ) = c( i, j ) - a( i, j )
210 20 CONTINUE
211 c( j, j ) = c( j, j ) - dble( a( j, j ) )
212 30 CONTINUE
213 ELSE
214 DO 50 j = 1, n
215 c( j, j ) = c( j, j ) - dble( a( j, j ) )
216 DO 40 i = j + 1, n
217 c( i, j ) = c( i, j ) - a( i, j )
218 40 CONTINUE
219 50 CONTINUE
220 END IF
221*
222* Compute norm( C - A ) / ( N * norm(A) * EPS )
223*
224 resid = zlanhe( '1', uplo, n, c, ldc, rwork )
225*
226 IF( anorm.LE.zero ) THEN
227 IF( resid.NE.zero )
228 $ resid = one / eps
229 ELSE
230 resid = ( ( resid / dble( n ) ) / anorm ) / eps
231 END IF
232*
233 RETURN
234*
235* End of ZHET01
236*
zlavhe
subroutine zlavhe(uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
ZLAVHE
Definition zlavhe.f:153

◆ zhet01_3()

subroutine zhet01_3 ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldafac, * ) afac,
integer ldafac,
complex*16, dimension( * ) e,
integer, dimension( * ) ipiv,
complex*16, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) rwork,
double precision resid )

ZHET01_3

Purpose:
!>
!> ZHET01_3 reconstructs a Hermitian indefinite matrix A from its
!> block L*D*L' or U*D*U' factorization computed by ZHETRF_RK
!> (or ZHETRF_BK) and computes the residual
!>    norm( C - A ) / ( N * norm(A) * EPS ),
!> where C is the reconstructed matrix and EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original Hermitian matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N)
!>
[in]AFAC
!>          AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
!>          Diagonal of the block diagonal matrix D and factors U or L
!>          as computed by ZHETRF_RK and ZHETRF_BK:
!>            a) ONLY diagonal elements of the Hermitian block diagonal
!>               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
!>               (superdiagonal (or subdiagonal) elements of D
!>                should be provided on entry in array E), and
!>            b) If UPLO = 'U': factor U in the superdiagonal part of A.
!>               If UPLO = 'L': factor L in the subdiagonal part of A.
!>
[in]LDAFAC
!>          LDAFAC is INTEGER
!>          The leading dimension of the array AFAC.
!>          LDAFAC >= max(1,N).
!>
[in]E
!>          E is COMPLEX*16 array, dimension (N)
!>          On entry, contains the superdiagonal (or subdiagonal)
!>          elements of the Hermitian block diagonal matrix D
!>          with 1-by-1 or 2-by-2 diagonal blocks, where
!>          If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced;
!>          If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from ZHETRF_RK (or ZHETRF_BK).
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 139 of file zhet01_3.f.

141*
142* -- LAPACK test routine --
143* -- LAPACK is a software package provided by Univ. of Tennessee, --
144* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
145*
146* .. Scalar Arguments ..
147 CHARACTER UPLO
148 INTEGER LDA, LDAFAC, LDC, N
149 DOUBLE PRECISION RESID
150* ..
151* .. Array Arguments ..
152 INTEGER IPIV( * )
153 DOUBLE PRECISION RWORK( * )
154 COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
155 $ E( * )
156* ..
157*
158* =====================================================================
159*
160* .. Parameters ..
161 DOUBLE PRECISION ZERO, ONE
162 parameter( zero = 0.0d+0, one = 1.0d+0 )
163 COMPLEX*16 CZERO, CONE
164 parameter( czero = ( 0.0d+0, 0.0d+0 ),
165 $ cone = ( 1.0d+0, 0.0d+0 ) )
166* ..
167* .. Local Scalars ..
168 INTEGER I, INFO, J
169 DOUBLE PRECISION ANORM, EPS
170* ..
171* .. External Functions ..
172 LOGICAL LSAME
173 DOUBLE PRECISION ZLANHE, DLAMCH
174 EXTERNAL lsame, zlanhe, dlamch
175* ..
176* .. External Subroutines ..
177 EXTERNAL zlaset, zlavhe_rook, zsyconvf_rook
178* ..
179* .. Intrinsic Functions ..
180 INTRINSIC dimag, dble
181* ..
182* .. Executable Statements ..
183*
184* Quick exit if N = 0.
185*
186 IF( n.LE.0 ) THEN
187 resid = zero
188 RETURN
189 END IF
190*
191* a) Revert to multiplyers of L
192*
193 CALL zsyconvf_rook( uplo, 'R', n, afac, ldafac, e, ipiv, info )
194*
195* 1) Determine EPS and the norm of A.
196*
197 eps = dlamch( 'Epsilon' )
198 anorm = zlanhe( '1', uplo, n, a, lda, rwork )
199*
200* Check the imaginary parts of the diagonal elements and return with
201* an error code if any are nonzero.
202*
203 DO j = 1, n
204 IF( dimag( afac( j, j ) ).NE.zero ) THEN
205 resid = one / eps
206 RETURN
207 END IF
208 END DO
209*
210* 2) Initialize C to the identity matrix.
211*
212 CALL zlaset( 'Full', n, n, czero, cone, c, ldc )
213*
214* 3) Call ZLAVHE_ROOK to form the product D * U' (or D * L' ).
215*
216 CALL zlavhe_rook( uplo, 'Conjugate', 'Non-unit', n, n, afac,
217 $ ldafac, ipiv, c, ldc, info )
218*
219* 4) Call ZLAVHE_RK again to multiply by U (or L ).
220*
221 CALL zlavhe_rook( uplo, 'No transpose', 'Unit', n, n, afac,
222 $ ldafac, ipiv, c, ldc, info )
223*
224* 5) Compute the difference C - A .
225*
226 IF( lsame( uplo, 'U' ) ) THEN
227 DO j = 1, n
228 DO i = 1, j - 1
229 c( i, j ) = c( i, j ) - a( i, j )
230 END DO
231 c( j, j ) = c( j, j ) - dble( a( j, j ) )
232 END DO
233 ELSE
234 DO j = 1, n
235 c( j, j ) = c( j, j ) - dble( a( j, j ) )
236 DO i = j + 1, n
237 c( i, j ) = c( i, j ) - a( i, j )
238 END DO
239 END DO
240 END IF
241*
242* 6) Compute norm( C - A ) / ( N * norm(A) * EPS )
243*
244 resid = zlanhe( '1', uplo, n, c, ldc, rwork )
245*
246 IF( anorm.LE.zero ) THEN
247 IF( resid.NE.zero )
248 $ resid = one / eps
249 ELSE
250 resid = ( ( resid/dble( n ) )/anorm ) / eps
251 END IF
252*
253* b) Convert to factor of L (or U)
254*
255 CALL zsyconvf_rook( uplo, 'C', n, afac, ldafac, e, ipiv, info )
256*
257 RETURN
258*
259* End of ZHET01_3
260*
zsyconvf_rook
subroutine zsyconvf_rook(uplo, way, n, a, lda, e, ipiv, info)
ZSYCONVF_ROOK
Definition zsyconvf_rook.f:200
zlavhe_rook
subroutine zlavhe_rook(uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
ZLAVHE_ROOK
Definition zlavhe_rook.f:153

◆ zhet01_aa()

subroutine zhet01_aa ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldafac, * ) afac,
integer ldafac,
integer, dimension( * ) ipiv,
complex*16, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) rwork,
double precision resid )

ZHET01_AA

Purpose:
!>
!> ZHET01_AA reconstructs a hermitian indefinite matrix A from its
!> block L*D*L' or U*D*U' factorization and computes the residual
!>    norm( C - A ) / ( N * norm(A) * EPS ),
!> where C is the reconstructed matrix and EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          hermitian matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original hermitian matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N)
!>
[in]AFAC
!>          AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
!>          The factored form of the matrix A.  AFAC contains the block
!>          diagonal matrix D and the multipliers used to obtain the
!>          factor L or U from the block L*D*L' or U*D*U' factorization
!>          as computed by ZHETRF.
!>
[in]LDAFAC
!>          LDAFAC is INTEGER
!>          The leading dimension of the array AFAC.  LDAFAC >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from ZHETRF.
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is COMPLEX*16 array, dimension (N)
!>
[out]RESID
!>          RESID is COMPLEX*16
!>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 122 of file zhet01_aa.f.

124*
125* -- LAPACK test routine --
126* -- LAPACK is a software package provided by Univ. of Tennessee, --
127* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
128*
129* .. Scalar Arguments ..
130 CHARACTER UPLO
131 INTEGER LDA, LDAFAC, LDC, N
132 DOUBLE PRECISION RESID
133* ..
134* .. Array Arguments ..
135 INTEGER IPIV( * )
136 DOUBLE PRECISION RWORK( * )
137 COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 COMPLEX*16 CZERO, CONE
144 parameter( czero = ( 0.0d+0, 0.0d+0 ),
145 $ cone = ( 1.0d+0, 0.0d+0 ) )
146 DOUBLE PRECISION ZERO, ONE
147 parameter( zero = 0.0d+0, one = 1.0d+0 )
148* ..
149* .. Local Scalars ..
150 INTEGER I, J
151 DOUBLE PRECISION ANORM, EPS
152* ..
153* .. External Functions ..
154 LOGICAL LSAME
155 DOUBLE PRECISION DLAMCH, ZLANHE
156 EXTERNAL lsame, dlamch, zlanhe
157* ..
158* .. External Subroutines ..
159 EXTERNAL zlaset, zlavhe
160* ..
161* .. Intrinsic Functions ..
162 INTRINSIC dble
163* ..
164* .. Executable Statements ..
165*
166* Quick exit if N = 0.
167*
168 IF( n.LE.0 ) THEN
169 resid = zero
170 RETURN
171 END IF
172*
173* Determine EPS and the norm of A.
174*
175 eps = dlamch( 'Epsilon' )
176 anorm = zlanhe( '1', uplo, n, a, lda, rwork )
177*
178* Initialize C to the tridiagonal matrix T.
179*
180 CALL zlaset( 'Full', n, n, czero, czero, c, ldc )
181 CALL zlacpy( 'F', 1, n, afac( 1, 1 ), ldafac+1, c( 1, 1 ), ldc+1 )
182 IF( n.GT.1 ) THEN
183 IF( lsame( uplo, 'U' ) ) THEN
184 CALL zlacpy( 'F', 1, n-1, afac( 1, 2 ), ldafac+1, c( 1, 2 ),
185 $ ldc+1 )
186 CALL zlacpy( 'F', 1, n-1, afac( 1, 2 ), ldafac+1, c( 2, 1 ),
187 $ ldc+1 )
188 CALL zlacgv( n-1, c( 2, 1 ), ldc+1 )
189 ELSE
190 CALL zlacpy( 'F', 1, n-1, afac( 2, 1 ), ldafac+1, c( 1, 2 ),
191 $ ldc+1 )
192 CALL zlacpy( 'F', 1, n-1, afac( 2, 1 ), ldafac+1, c( 2, 1 ),
193 $ ldc+1 )
194 CALL zlacgv( n-1, c( 1, 2 ), ldc+1 )
195 ENDIF
196*
197* Call ZTRMM to form the product U' * D (or L * D ).
198*
199 IF( lsame( uplo, 'U' ) ) THEN
200 CALL ztrmm( 'Left', uplo, 'Conjugate transpose', 'Unit',
201 $ n-1, n, cone, afac( 1, 2 ), ldafac, c( 2, 1 ),
202 $ ldc )
203 ELSE
204 CALL ztrmm( 'Left', uplo, 'No transpose', 'Unit', n-1, n,
205 $ cone, afac( 2, 1 ), ldafac, c( 2, 1 ), ldc )
206 END IF
207*
208* Call ZTRMM again to multiply by U (or L ).
209*
210 IF( lsame( uplo, 'U' ) ) THEN
211 CALL ztrmm( 'Right', uplo, 'No transpose', 'Unit', n, n-1,
212 $ cone, afac( 1, 2 ), ldafac, c( 1, 2 ), ldc )
213 ELSE
214 CALL ztrmm( 'Right', uplo, 'Conjugate transpose', 'Unit', n,
215 $ n-1, cone, afac( 2, 1 ), ldafac, c( 1, 2 ),
216 $ ldc )
217 END IF
218*
219* Apply hermitian pivots
220*
221 DO j = n, 1, -1
222 i = ipiv( j )
223 IF( i.NE.j )
224 $ CALL zswap( n, c( j, 1 ), ldc, c( i, 1 ), ldc )
225 END DO
226 DO j = n, 1, -1
227 i = ipiv( j )
228 IF( i.NE.j )
229 $ CALL zswap( n, c( 1, j ), 1, c( 1, i ), 1 )
230 END DO
231 ENDIF
232*
233*
234* Compute the difference C - A .
235*
236 IF( lsame( uplo, 'U' ) ) THEN
237 DO j = 1, n
238 DO i = 1, j
239 c( i, j ) = c( i, j ) - a( i, j )
240 END DO
241 END DO
242 ELSE
243 DO j = 1, n
244 DO i = j, n
245 c( i, j ) = c( i, j ) - a( i, j )
246 END DO
247 END DO
248 END IF
249*
250* Compute norm( C - A ) / ( N * norm(A) * EPS )
251*
252 resid = zlanhe( '1', uplo, n, c, ldc, rwork )
253*
254 IF( anorm.LE.zero ) THEN
255 IF( resid.NE.zero )
256 $ resid = one / eps
257 ELSE
258 resid = ( ( resid / dble( n ) ) / anorm ) / eps
259 END IF
260*
261 RETURN
262*
263* End of ZHET01_AA
264*
zlacgv
subroutine zlacgv(n, x, incx)
ZLACGV conjugates a complex vector.
Definition zlacgv.f:74
ztrmm
subroutine ztrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
ZTRMM
Definition ztrmm.f:177

◆ zhet01_rook()

subroutine zhet01_rook ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldafac, * ) afac,
integer ldafac,
integer, dimension( * ) ipiv,
complex*16, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) rwork,
double precision resid )

ZHET01_ROOK

Purpose:
!>
!> ZHET01_ROOK reconstructs a complex Hermitian indefinite matrix A from its
!> block L*D*L' or U*D*U' factorization and computes the residual
!>    norm( C - A ) / ( N * norm(A) * EPS ),
!> where C is the reconstructed matrix, EPS is the machine epsilon,
!> L' is the transpose of L, and U' is the transpose of U.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          complex Hermitian matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original complex Hermitian matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N)
!>
[in]AFAC
!>          AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
!>          The factored form of the matrix A.  AFAC contains the block
!>          diagonal matrix D and the multipliers used to obtain the
!>          factor L or U from the block L*D*L' or U*D*U' factorization
!>          as computed by CSYTRF_ROOK.
!>
[in]LDAFAC
!>          LDAFAC is INTEGER
!>          The leading dimension of the array AFAC.  LDAFAC >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from CSYTRF_ROOK.
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 123 of file zhet01_rook.f.

125*
126* -- LAPACK test routine --
127* -- LAPACK is a software package provided by Univ. of Tennessee, --
128* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
129*
130* .. Scalar Arguments ..
131 CHARACTER UPLO
132 INTEGER LDA, LDAFAC, LDC, N
133 DOUBLE PRECISION RESID
134* ..
135* .. Array Arguments ..
136 INTEGER IPIV( * )
137 DOUBLE PRECISION RWORK( * )
138 COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 DOUBLE PRECISION ZERO, ONE
145 parameter( zero = 0.0d+0, one = 1.0d+0 )
146 COMPLEX*16 CZERO, CONE
147 parameter( czero = ( 0.0d+0, 0.0d+0 ),
148 $ cone = ( 1.0d+0, 0.0d+0 ) )
149* ..
150* .. Local Scalars ..
151 INTEGER I, INFO, J
152 DOUBLE PRECISION ANORM, EPS
153* ..
154* .. External Functions ..
155 LOGICAL LSAME
156 DOUBLE PRECISION ZLANHE, DLAMCH
157 EXTERNAL lsame, zlanhe, dlamch
158* ..
159* .. External Subroutines ..
160 EXTERNAL zlaset, zlavhe_rook
161* ..
162* .. Intrinsic Functions ..
163 INTRINSIC dimag, dble
164* ..
165* .. Executable Statements ..
166*
167* Quick exit if N = 0.
168*
169 IF( n.LE.0 ) THEN
170 resid = zero
171 RETURN
172 END IF
173*
174* Determine EPS and the norm of A.
175*
176 eps = dlamch( 'Epsilon' )
177 anorm = zlanhe( '1', uplo, n, a, lda, rwork )
178*
179* Check the imaginary parts of the diagonal elements and return with
180* an error code if any are nonzero.
181*
182 DO 10 j = 1, n
183 IF( dimag( afac( j, j ) ).NE.zero ) THEN
184 resid = one / eps
185 RETURN
186 END IF
187 10 CONTINUE
188*
189* Initialize C to the identity matrix.
190*
191 CALL zlaset( 'Full', n, n, czero, cone, c, ldc )
192*
193* Call ZLAVHE_ROOK to form the product D * U' (or D * L' ).
194*
195 CALL zlavhe_rook( uplo, 'Conjugate', 'Non-unit', n, n, afac,
196 $ ldafac, ipiv, c, ldc, info )
197*
198* Call ZLAVHE_ROOK again to multiply by U (or L ).
199*
200 CALL zlavhe_rook( uplo, 'No transpose', 'Unit', n, n, afac,
201 $ ldafac, ipiv, c, ldc, info )
202*
203* Compute the difference C - A .
204*
205 IF( lsame( uplo, 'U' ) ) THEN
206 DO 30 j = 1, n
207 DO 20 i = 1, j - 1
208 c( i, j ) = c( i, j ) - a( i, j )
209 20 CONTINUE
210 c( j, j ) = c( j, j ) - dble( a( j, j ) )
211 30 CONTINUE
212 ELSE
213 DO 50 j = 1, n
214 c( j, j ) = c( j, j ) - dble( a( j, j ) )
215 DO 40 i = j + 1, n
216 c( i, j ) = c( i, j ) - a( i, j )
217 40 CONTINUE
218 50 CONTINUE
219 END IF
220*
221* Compute norm( C - A ) / ( N * norm(A) * EPS )
222*
223 resid = zlanhe( '1', uplo, n, c, ldc, rwork )
224*
225 IF( anorm.LE.zero ) THEN
226 IF( resid.NE.zero )
227 $ resid = one / eps
228 ELSE
229 resid = ( ( resid/dble( n ) )/anorm ) / eps
230 END IF
231*
232 RETURN
233*
234* End of ZHET01_ROOK
235*

◆ zhpt01()

subroutine zhpt01 ( character uplo,
integer n,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
integer, dimension( * ) ipiv,
complex*16, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) rwork,
double precision resid )

ZHPT01

Purpose:
!>
!> ZHPT01 reconstructs a Hermitian indefinite packed matrix A from its
!> block L*D*L' or U*D*U' factorization and computes the residual
!>    norm( C - A ) / ( N * norm(A) * EPS ),
!> where C is the reconstructed matrix, EPS is the machine epsilon,
!> L' is the conjugate transpose of L, and U' is the conjugate transpose
!> of U.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The original Hermitian matrix A, stored as a packed
!>          triangular matrix.
!>
[in]AFAC
!>          AFAC is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The factored form of the matrix A, stored as a packed
!>          triangular matrix.  AFAC contains the block diagonal matrix D
!>          and the multipliers used to obtain the factor L or U from the
!>          block L*D*L' or U*D*U' factorization as computed by ZHPTRF.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from ZHPTRF.
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 112 of file zhpt01.f.

113*
114* -- LAPACK test routine --
115* -- LAPACK is a software package provided by Univ. of Tennessee, --
116* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
117*
118* .. Scalar Arguments ..
119 CHARACTER UPLO
120 INTEGER LDC, N
121 DOUBLE PRECISION RESID
122* ..
123* .. Array Arguments ..
124 INTEGER IPIV( * )
125 DOUBLE PRECISION RWORK( * )
126 COMPLEX*16 A( * ), AFAC( * ), C( LDC, * )
127* ..
128*
129* =====================================================================
130*
131* .. Parameters ..
132 DOUBLE PRECISION ZERO, ONE
133 parameter( zero = 0.0d+0, one = 1.0d+0 )
134 COMPLEX*16 CZERO, CONE
135 parameter( czero = ( 0.0d+0, 0.0d+0 ),
136 $ cone = ( 1.0d+0, 0.0d+0 ) )
137* ..
138* .. Local Scalars ..
139 INTEGER I, INFO, J, JC
140 DOUBLE PRECISION ANORM, EPS
141* ..
142* .. External Functions ..
143 LOGICAL LSAME
144 DOUBLE PRECISION DLAMCH, ZLANHE, ZLANHP
145 EXTERNAL lsame, dlamch, zlanhe, zlanhp
146* ..
147* .. External Subroutines ..
148 EXTERNAL zlaset, zlavhp
149* ..
150* .. Intrinsic Functions ..
151 INTRINSIC dble, dimag
152* ..
153* .. Executable Statements ..
154*
155* Quick exit if N = 0.
156*
157 IF( n.LE.0 ) THEN
158 resid = zero
159 RETURN
160 END IF
161*
162* Determine EPS and the norm of A.
163*
164 eps = dlamch( 'Epsilon' )
165 anorm = zlanhp( '1', uplo, n, a, rwork )
166*
167* Check the imaginary parts of the diagonal elements and return with
168* an error code if any are nonzero.
169*
170 jc = 1
171 IF( lsame( uplo, 'U' ) ) THEN
172 DO 10 j = 1, n
173 IF( dimag( afac( jc ) ).NE.zero ) THEN
174 resid = one / eps
175 RETURN
176 END IF
177 jc = jc + j + 1
178 10 CONTINUE
179 ELSE
180 DO 20 j = 1, n
181 IF( dimag( afac( jc ) ).NE.zero ) THEN
182 resid = one / eps
183 RETURN
184 END IF
185 jc = jc + n - j + 1
186 20 CONTINUE
187 END IF
188*
189* Initialize C to the identity matrix.
190*
191 CALL zlaset( 'Full', n, n, czero, cone, c, ldc )
192*
193* Call ZLAVHP to form the product D * U' (or D * L' ).
194*
195 CALL zlavhp( uplo, 'Conjugate', 'Non-unit', n, n, afac, ipiv, c,
196 $ ldc, info )
197*
198* Call ZLAVHP again to multiply by U ( or L ).
199*
200 CALL zlavhp( uplo, 'No transpose', 'Unit', n, n, afac, ipiv, c,
201 $ ldc, info )
202*
203* Compute the difference C - A .
204*
205 IF( lsame( uplo, 'U' ) ) THEN
206 jc = 0
207 DO 40 j = 1, n
208 DO 30 i = 1, j - 1
209 c( i, j ) = c( i, j ) - a( jc+i )
210 30 CONTINUE
211 c( j, j ) = c( j, j ) - dble( a( jc+j ) )
212 jc = jc + j
213 40 CONTINUE
214 ELSE
215 jc = 1
216 DO 60 j = 1, n
217 c( j, j ) = c( j, j ) - dble( a( jc ) )
218 DO 50 i = j + 1, n
219 c( i, j ) = c( i, j ) - a( jc+i-j )
220 50 CONTINUE
221 jc = jc + n - j + 1
222 60 CONTINUE
223 END IF
224*
225* Compute norm( C - A ) / ( N * norm(A) * EPS )
226*
227 resid = zlanhe( '1', uplo, n, c, ldc, rwork )
228*
229 IF( anorm.LE.zero ) THEN
230 IF( resid.NE.zero )
231 $ resid = one / eps
232 ELSE
233 resid = ( ( resid / dble( n ) ) / anorm ) / eps
234 END IF
235*
236 RETURN
237*
238* End of ZHPT01
239*
zlavhp
subroutine zlavhp(uplo, trans, diag, n, nrhs, a, ipiv, b, ldb, info)
ZLAVHP
Definition zlavhp.f:131
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ zlahilb()

subroutine zlahilb ( integer n,
integer nrhs,
complex*16, dimension(lda,n) a,
integer lda,
complex*16, dimension(ldx, nrhs) x,
integer ldx,
complex*16, dimension(ldb, nrhs) b,
integer ldb,
double precision, dimension(n) work,
integer info,
character*3 path )

ZLAHILB

Purpose:
!>
!> ZLAHILB generates an N by N scaled Hilbert matrix in A along with
!> NRHS right-hand sides in B and solutions in X such that A*X=B.
!>
!> The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all
!> entries are integers.  The right-hand sides are the first NRHS
!> columns of M * the identity matrix, and the solutions are the
!> first NRHS columns of the inverse Hilbert matrix.
!>
!> The condition number of the Hilbert matrix grows exponentially with
!> its size, roughly as O(e ** (3.5*N)).  Additionally, the inverse
!> Hilbert matrices beyond a relatively small dimension cannot be
!> generated exactly without extra precision.  Precision is exhausted
!> when the largest entry in the inverse Hilbert matrix is greater than
!> 2 to the power of the number of bits in the fraction of the data type
!> used plus one, which is 24 for single precision.
!>
!> In single, the generated solution is exact for N <= 6 and has
!> small componentwise error for 7 <= N <= 11.
!>
Parameters
[in]N
!>          N is INTEGER
!>          The dimension of the matrix A.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The requested number of right-hand sides.
!>
[out]A
!>          A is COMPLEX array, dimension (LDA, N)
!>          The generated scaled Hilbert matrix.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= N.
!>
[out]X
!>          X is COMPLEX array, dimension (LDX, NRHS)
!>          The generated exact solutions.  Currently, the first NRHS
!>          columns of the inverse Hilbert matrix.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= N.
!>
[out]B
!>          B is REAL array, dimension (LDB, NRHS)
!>          The generated right-hand sides.  Currently, the first NRHS
!>          columns of LCM(1, 2, ..., 2*N-1) * the identity matrix.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= N.
!>
[out]WORK
!>          WORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          = 1: N is too large; the data is still generated but may not
!>               be not exact.
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 132 of file zlahilb.f.

134*
135* -- LAPACK test routine --
136* -- LAPACK is a software package provided by Univ. of Tennessee, --
137* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
138*
139* .. Scalar Arguments ..
140 INTEGER N, NRHS, LDA, LDX, LDB, INFO
141* .. Array Arguments ..
142 DOUBLE PRECISION WORK(N)
143 COMPLEX*16 A(LDA,N), X(LDX, NRHS), B(LDB, NRHS)
144 CHARACTER*3 PATH
145* ..
146*
147* =====================================================================
148* .. Local Scalars ..
149 INTEGER TM, TI, R
150 INTEGER M
151 INTEGER I, J
152 COMPLEX*16 TMP
153 CHARACTER*2 C2
154* ..
155* .. Parameters ..
156* NMAX_EXACT the largest dimension where the generated data is
157* exact.
158* NMAX_APPROX the largest dimension where the generated data has
159* a small componentwise relative error.
160* ??? complex uses how many bits ???
161 INTEGER NMAX_EXACT, NMAX_APPROX, SIZE_D
162 parameter(nmax_exact = 6, nmax_approx = 11, size_d = 8)
163*
164* d's are generated from random permutation of those eight elements.
165 COMPLEX*16 d1(8), d2(8), invd1(8), invd2(8)
166 DATA d1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/
167 DATA d2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/
168
169 DATA invd1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0),
170 $ (-.5,-.5),(.5,-.5),(.5,.5)/
171 DATA invd2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0),
172 $ (-.5,.5),(.5,.5),(.5,-.5)/
173* ..
174* .. External Functions
175 EXTERNAL zlaset, lsamen
176 INTRINSIC dble
177 LOGICAL LSAMEN
178* ..
179* .. Executable Statements ..
180 c2 = path( 2: 3 )
181*
182* Test the input arguments
183*
184 info = 0
185 IF (n .LT. 0 .OR. n .GT. nmax_approx) THEN
186 info = -1
187 ELSE IF (nrhs .LT. 0) THEN
188 info = -2
189 ELSE IF (lda .LT. n) THEN
190 info = -4
191 ELSE IF (ldx .LT. n) THEN
192 info = -6
193 ELSE IF (ldb .LT. n) THEN
194 info = -8
195 END IF
196 IF (info .LT. 0) THEN
197 CALL xerbla('ZLAHILB', -info)
198 RETURN
199 END IF
200 IF (n .GT. nmax_exact) THEN
201 info = 1
202 END IF
203*
204* Compute M = the LCM of the integers [1, 2*N-1]. The largest
205* reasonable N is small enough that integers suffice (up to N = 11).
206 m = 1
207 DO i = 2, (2*n-1)
208 tm = m
209 ti = i
210 r = mod(tm, ti)
211 DO WHILE (r .NE. 0)
212 tm = ti
213 ti = r
214 r = mod(tm, ti)
215 END DO
216 m = (m / ti) * i
217 END DO
218*
219* Generate the scaled Hilbert matrix in A
220* If we are testing SY routines,
221* take D1_i = D2_i, else, D1_i = D2_i*
222 IF ( lsamen( 2, c2, 'SY' ) ) THEN
223 DO j = 1, n
224 DO i = 1, n
225 a(i, j) = d1(mod(j,size_d)+1) * (dble(m) / (i + j - 1))
226 $ * d1(mod(i,size_d)+1)
227 END DO
228 END DO
229 ELSE
230 DO j = 1, n
231 DO i = 1, n
232 a(i, j) = d1(mod(j,size_d)+1) * (dble(m) / (i + j - 1))
233 $ * d2(mod(i,size_d)+1)
234 END DO
235 END DO
236 END IF
237*
238* Generate matrix B as simply the first NRHS columns of M * the
239* identity.
240 tmp = dble(m)
241 CALL zlaset('Full', n, nrhs, (0.0d+0,0.0d+0), tmp, b, ldb)
242*
243* Generate the true solutions in X. Because B = the first NRHS
244* columns of M*I, the true solutions are just the first NRHS columns
245* of the inverse Hilbert matrix.
246 work(1) = n
247 DO j = 2, n
248 work(j) = ( ( (work(j-1)/(j-1)) * (j-1 - n) ) /(j-1) )
249 $ * (n +j -1)
250 END DO
251
252* If we are testing SY routines,
253* take D1_i = D2_i, else, D1_i = D2_i*
254 IF ( lsamen( 2, c2, 'SY' ) ) THEN
255 DO j = 1, nrhs
256 DO i = 1, n
257 x(i, j) = invd1(mod(j,size_d)+1) *
258 $ ((work(i)*work(j)) / (i + j - 1))
259 $ * invd1(mod(i,size_d)+1)
260 END DO
261 END DO
262 ELSE
263 DO j = 1, nrhs
264 DO i = 1, n
265 x(i, j) = invd2(mod(j,size_d)+1) *
266 $ ((work(i)*work(j)) / (i + j - 1))
267 $ * invd1(mod(i,size_d)+1)
268 END DO
269 END DO
270 END IF

◆ zlaipd()

subroutine zlaipd ( integer n,
complex*16, dimension( * ) a,
integer inda,
integer vinda )

ZLAIPD

Purpose:
!>
!> ZLAIPD sets the imaginary part of the diagonal elements of a complex
!> matrix A to a large value.  This is used to test LAPACK routines for
!> complex Hermitian matrices, which are not supposed to access or use
!> the imaginary parts of the diagonals.
!>
Parameters
[in]N
!>          N is INTEGER
!>         The number of diagonal elements of A.
!>
[in,out]A
!>          A is COMPLEX*16 array, dimension
!>                        (1+(N-1)*INDA+(N-2)*VINDA)
!>         On entry, the complex (Hermitian) matrix A.
!>         On exit, the imaginary parts of the diagonal elements are set
!>         to BIGNUM = EPS / SAFMIN, where EPS is the machine epsilon and
!>         SAFMIN is the safe minimum.
!>
[in]INDA
!>          INDA is INTEGER
!>         The increment between A(1) and the next diagonal element of A.
!>         Typical values are
!>         = LDA+1:  square matrices with leading dimension LDA
!>         = 2:  packed upper triangular matrix, starting at A(1,1)
!>         = N:  packed lower triangular matrix, starting at A(1,1)
!>
[in]VINDA
!>          VINDA is INTEGER
!>         The change in the diagonal increment between columns of A.
!>         Typical values are
!>         = 0:  no change, the row and column increments in A are fixed
!>         = 1:  packed upper triangular matrix
!>         = -1:  packed lower triangular matrix
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 82 of file zlaipd.f.

83*
84* -- LAPACK test routine --
85* -- LAPACK is a software package provided by Univ. of Tennessee, --
86* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
87*
88* .. Scalar Arguments ..
89 INTEGER INDA, N, VINDA
90* ..
91* .. Array Arguments ..
92 COMPLEX*16 A( * )
93* ..
94*
95* =====================================================================
96*
97* .. Local Scalars ..
98 INTEGER I, IA, IXA
99 DOUBLE PRECISION BIGNUM
100* ..
101* .. External Functions ..
102 DOUBLE PRECISION DLAMCH
103 EXTERNAL dlamch
104* ..
105* .. Intrinsic Functions ..
106 INTRINSIC dble, dcmplx
107* ..
108* .. Executable Statements ..
109*
110 bignum = dlamch( 'Epsilon' ) / dlamch( 'Safe minimum' )
111 ia = 1
112 ixa = inda
113 DO 10 i = 1, n
114 a( ia ) = dcmplx( dble( a( ia ) ), bignum )
115 ia = ia + ixa
116 ixa = ixa + vinda
117 10 CONTINUE
118 RETURN

◆ zlaptm()

subroutine zlaptm ( character uplo,
integer n,
integer nrhs,
double precision alpha,
double precision, dimension( * ) d,
complex*16, dimension( * ) e,
complex*16, dimension( ldx, * ) x,
integer ldx,
double precision beta,
complex*16, dimension( ldb, * ) b,
integer ldb )

ZLAPTM

Purpose:
!>
!> ZLAPTM multiplies an N by NRHS matrix X by a Hermitian tridiagonal
!> matrix A and stores the result in a matrix B.  The operation has the
!> form
!>
!>    B := alpha * A * X + beta * B
!>
!> where alpha may be either 1. or -1. and beta may be 0., 1., or -1.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER
!>          Specifies whether the superdiagonal or the subdiagonal of the
!>          tridiagonal matrix A is stored.
!>          = 'U':  Upper, E is the superdiagonal of A.
!>          = 'L':  Lower, E is the subdiagonal of A.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices X and B.
!>
[in]ALPHA
!>          ALPHA is DOUBLE PRECISION
!>          The scalar alpha.  ALPHA must be 1. or -1.; otherwise,
!>          it is assumed to be 0.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The n diagonal elements of the tridiagonal matrix A.
!>
[in]E
!>          E is COMPLEX*16 array, dimension (N-1)
!>          The (n-1) subdiagonal or superdiagonal elements of A.
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The N by NRHS matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(N,1).
!>
[in]BETA
!>          BETA is DOUBLE PRECISION
!>          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,
!>          it is assumed to be 1.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the N by NRHS matrix B.
!>          On exit, B is overwritten by the matrix expression
!>          B := alpha * A * X + beta * B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(N,1).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 127 of file zlaptm.f.

129*
130* -- LAPACK test routine --
131* -- LAPACK is a software package provided by Univ. of Tennessee, --
132* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
133*
134* .. Scalar Arguments ..
135 CHARACTER UPLO
136 INTEGER LDB, LDX, N, NRHS
137 DOUBLE PRECISION ALPHA, BETA
138* ..
139* .. Array Arguments ..
140 DOUBLE PRECISION D( * )
141 COMPLEX*16 B( LDB, * ), E( * ), X( LDX, * )
142* ..
143*
144* =====================================================================
145*
146* .. Parameters ..
147 DOUBLE PRECISION ONE, ZERO
148 parameter( one = 1.0d+0, zero = 0.0d+0 )
149* ..
150* .. Local Scalars ..
151 INTEGER I, J
152* ..
153* .. External Functions ..
154 LOGICAL LSAME
155 EXTERNAL lsame
156* ..
157* .. Intrinsic Functions ..
158 INTRINSIC dconjg
159* ..
160* .. Executable Statements ..
161*
162 IF( n.EQ.0 )
163 $ RETURN
164*
165 IF( beta.EQ.zero ) THEN
166 DO 20 j = 1, nrhs
167 DO 10 i = 1, n
168 b( i, j ) = zero
169 10 CONTINUE
170 20 CONTINUE
171 ELSE IF( beta.EQ.-one ) THEN
172 DO 40 j = 1, nrhs
173 DO 30 i = 1, n
174 b( i, j ) = -b( i, j )
175 30 CONTINUE
176 40 CONTINUE
177 END IF
178*
179 IF( alpha.EQ.one ) THEN
180 IF( lsame( uplo, 'U' ) ) THEN
181*
182* Compute B := B + A*X, where E is the superdiagonal of A.
183*
184 DO 60 j = 1, nrhs
185 IF( n.EQ.1 ) THEN
186 b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j )
187 ELSE
188 b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j ) +
189 $ e( 1 )*x( 2, j )
190 b( n, j ) = b( n, j ) + dconjg( e( n-1 ) )*
191 $ x( n-1, j ) + d( n )*x( n, j )
192 DO 50 i = 2, n - 1
193 b( i, j ) = b( i, j ) + dconjg( e( i-1 ) )*
194 $ x( i-1, j ) + d( i )*x( i, j ) +
195 $ e( i )*x( i+1, j )
196 50 CONTINUE
197 END IF
198 60 CONTINUE
199 ELSE
200*
201* Compute B := B + A*X, where E is the subdiagonal of A.
202*
203 DO 80 j = 1, nrhs
204 IF( n.EQ.1 ) THEN
205 b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j )
206 ELSE
207 b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j ) +
208 $ dconjg( e( 1 ) )*x( 2, j )
209 b( n, j ) = b( n, j ) + e( n-1 )*x( n-1, j ) +
210 $ d( n )*x( n, j )
211 DO 70 i = 2, n - 1
212 b( i, j ) = b( i, j ) + e( i-1 )*x( i-1, j ) +
213 $ d( i )*x( i, j ) +
214 $ dconjg( e( i ) )*x( i+1, j )
215 70 CONTINUE
216 END IF
217 80 CONTINUE
218 END IF
219 ELSE IF( alpha.EQ.-one ) THEN
220 IF( lsame( uplo, 'U' ) ) THEN
221*
222* Compute B := B - A*X, where E is the superdiagonal of A.
223*
224 DO 100 j = 1, nrhs
225 IF( n.EQ.1 ) THEN
226 b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j )
227 ELSE
228 b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j ) -
229 $ e( 1 )*x( 2, j )
230 b( n, j ) = b( n, j ) - dconjg( e( n-1 ) )*
231 $ x( n-1, j ) - d( n )*x( n, j )
232 DO 90 i = 2, n - 1
233 b( i, j ) = b( i, j ) - dconjg( e( i-1 ) )*
234 $ x( i-1, j ) - d( i )*x( i, j ) -
235 $ e( i )*x( i+1, j )
236 90 CONTINUE
237 END IF
238 100 CONTINUE
239 ELSE
240*
241* Compute B := B - A*X, where E is the subdiagonal of A.
242*
243 DO 120 j = 1, nrhs
244 IF( n.EQ.1 ) THEN
245 b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j )
246 ELSE
247 b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j ) -
248 $ dconjg( e( 1 ) )*x( 2, j )
249 b( n, j ) = b( n, j ) - e( n-1 )*x( n-1, j ) -
250 $ d( n )*x( n, j )
251 DO 110 i = 2, n - 1
252 b( i, j ) = b( i, j ) - e( i-1 )*x( i-1, j ) -
253 $ d( i )*x( i, j ) -
254 $ dconjg( e( i ) )*x( i+1, j )
255 110 CONTINUE
256 END IF
257 120 CONTINUE
258 END IF
259 END IF
260 RETURN
261*
262* End of ZLAPTM
263*

◆ zlarhs()

subroutine zlarhs ( character*3 path,
character xtype,
character uplo,
character trans,
integer m,
integer n,
integer kl,
integer ku,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer, dimension( 4 ) iseed,
integer info )

ZLARHS

Purpose:
!>
!> ZLARHS chooses a set of NRHS random solution vectors and sets
!> up the right hand sides for the linear system
!>    op(A) * X = B,
!> where op(A) = A, A**T, or A**H, depending on TRANS.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The type of the complex matrix A.  PATH may be given in any
!>          combination of upper and lower case.  Valid paths include
!>             xGE:  General m x n matrix
!>             xGB:  General banded matrix
!>             xPO:  Hermitian positive definite, 2-D storage
!>             xPP:  Hermitian positive definite packed
!>             xPB:  Hermitian positive definite banded
!>             xHE:  Hermitian indefinite, 2-D storage
!>             xHP:  Hermitian indefinite packed
!>             xHB:  Hermitian indefinite banded
!>             xSY:  Symmetric indefinite, 2-D storage
!>             xSP:  Symmetric indefinite packed
!>             xSB:  Symmetric indefinite banded
!>             xTR:  Triangular
!>             xTP:  Triangular packed
!>             xTB:  Triangular banded
!>             xQR:  General m x n matrix
!>             xLQ:  General m x n matrix
!>             xQL:  General m x n matrix
!>             xRQ:  General m x n matrix
!>          where the leading character indicates the precision.
!>
[in]XTYPE
!>          XTYPE is CHARACTER*1
!>          Specifies how the exact solution X will be determined:
!>          = 'N':  New solution; generate a random X.
!>          = 'C':  Computed; use value of X on entry.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Used only if A is symmetric or triangular; specifies whether
!>          the upper or lower triangular part of the matrix A is stored.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Used only if A is nonsymmetric; specifies the operation
!>          applied to the matrix A.
!>          = 'N':  B := A    * X  (No transpose)
!>          = 'T':  B := A**T * X  (Transpose)
!>          = 'C':  B := A**H * X  (Conjugate transpose)
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]KL
!>          KL is INTEGER
!>          Used only if A is a band matrix; specifies the number of
!>          subdiagonals of A if A is a general band matrix or if A is
!>          symmetric or triangular and UPLO = 'L'; specifies the number
!>          of superdiagonals of A if A is symmetric or triangular and
!>          UPLO = 'U'.  0 <= KL <= M-1.
!>
[in]KU
!>          KU is INTEGER
!>          Used only if A is a general band matrix or if A is
!>          triangular.
!>
!>          If PATH = xGB, specifies the number of superdiagonals of A,
!>          and 0 <= KU <= N-1.
!>
!>          If PATH = xTR, xTP, or xTB, specifies whether or not the
!>          matrix has unit diagonal:
!>          = 1:  matrix has non-unit diagonal (default)
!>          = 2:  matrix has unit diagonal
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors in the system A*X = B.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The test matrix whose type is given by PATH.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>          If PATH = xGB, LDA >= KL+KU+1.
!>          If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1.
!>          Otherwise, LDA >= max(1,M).
!>
[in,out]X
!>          X is or output) COMPLEX*16 array, dimension (LDX,NRHS)
!>          On entry, if XTYPE = 'C' (for 'Computed'), then X contains
!>          the exact solution to the system of linear equations.
!>          On exit, if XTYPE = 'N' (for 'New'), then X is initialized
!>          with random values.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  If TRANS = 'N',
!>          LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M).
!>
[out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vector(s) for the system of equations,
!>          computed from B = op(A) * X, where op(A) is determined by
!>          TRANS.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  If TRANS = 'N',
!>          LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N).
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          The seed vector for the random number generator (used in
!>          ZLATMS).  Modified on exit.
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 206 of file zlarhs.f.

208*
209* -- LAPACK test routine --
210* -- LAPACK is a software package provided by Univ. of Tennessee, --
211* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
212*
213* .. Scalar Arguments ..
214 CHARACTER TRANS, UPLO, XTYPE
215 CHARACTER*3 PATH
216 INTEGER INFO, KL, KU, LDA, LDB, LDX, M, N, NRHS
217* ..
218* .. Array Arguments ..
219 INTEGER ISEED( 4 )
220 COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * )
221* ..
222*
223* =====================================================================
224*
225* .. Parameters ..
226 COMPLEX*16 ONE, ZERO
227 parameter( one = ( 1.0d+0, 0.0d+0 ),
228 $ zero = ( 0.0d+0, 0.0d+0 ) )
229* ..
230* .. Local Scalars ..
231 LOGICAL BAND, GEN, NOTRAN, QRS, SYM, TRAN, TRI
232 CHARACTER C1, DIAG
233 CHARACTER*2 C2
234 INTEGER J, MB, NX
235* ..
236* .. External Functions ..
237 LOGICAL LSAME, LSAMEN
238 EXTERNAL lsame, lsamen
239* ..
240* .. External Subroutines ..
241 EXTERNAL xerbla, zgbmv, zgemm, zhbmv, zhemm, zhpmv,
242 $ zlacpy, zlarnv, zsbmv, zspmv, zsymm, ztbmv,
243 $ ztpmv, ztrmm
244* ..
245* .. Intrinsic Functions ..
246 INTRINSIC max
247* ..
248* .. Executable Statements ..
249*
250* Test the input parameters.
251*
252 info = 0
253 c1 = path( 1: 1 )
254 c2 = path( 2: 3 )
255 tran = lsame( trans, 'T' ) .OR. lsame( trans, 'C' )
256 notran = .NOT.tran
257 gen = lsame( path( 2: 2 ), 'G' )
258 qrs = lsame( path( 2: 2 ), 'Q' ) .OR. lsame( path( 3: 3 ), 'Q' )
259 sym = lsame( path( 2: 2 ), 'P' ) .OR.
260 $ lsame( path( 2: 2 ), 'S' ) .OR. lsame( path( 2: 2 ), 'H' )
261 tri = lsame( path( 2: 2 ), 'T' )
262 band = lsame( path( 3: 3 ), 'B' )
263 IF( .NOT.lsame( c1, 'Zomplex precision' ) ) THEN
264 info = -1
265 ELSE IF( .NOT.( lsame( xtype, 'N' ) .OR. lsame( xtype, 'C' ) ) )
266 $ THEN
267 info = -2
268 ELSE IF( ( sym .OR. tri ) .AND. .NOT.
269 $ ( lsame( uplo, 'U' ) .OR. lsame( uplo, 'L' ) ) ) THEN
270 info = -3
271 ELSE IF( ( gen .OR. qrs ) .AND. .NOT.
272 $ ( tran .OR. lsame( trans, 'N' ) ) ) THEN
273 info = -4
274 ELSE IF( m.LT.0 ) THEN
275 info = -5
276 ELSE IF( n.LT.0 ) THEN
277 info = -6
278 ELSE IF( band .AND. kl.LT.0 ) THEN
279 info = -7
280 ELSE IF( band .AND. ku.LT.0 ) THEN
281 info = -8
282 ELSE IF( nrhs.LT.0 ) THEN
283 info = -9
284 ELSE IF( ( .NOT.band .AND. lda.LT.max( 1, m ) ) .OR.
285 $ ( band .AND. ( sym .OR. tri ) .AND. lda.LT.kl+1 ) .OR.
286 $ ( band .AND. gen .AND. lda.LT.kl+ku+1 ) ) THEN
287 info = -11
288 ELSE IF( ( notran .AND. ldx.LT.max( 1, n ) ) .OR.
289 $ ( tran .AND. ldx.LT.max( 1, m ) ) ) THEN
290 info = -13
291 ELSE IF( ( notran .AND. ldb.LT.max( 1, m ) ) .OR.
292 $ ( tran .AND. ldb.LT.max( 1, n ) ) ) THEN
293 info = -15
294 END IF
295 IF( info.NE.0 ) THEN
296 CALL xerbla( 'ZLARHS', -info )
297 RETURN
298 END IF
299*
300* Initialize X to NRHS random vectors unless XTYPE = 'C'.
301*
302 IF( tran ) THEN
303 nx = m
304 mb = n
305 ELSE
306 nx = n
307 mb = m
308 END IF
309 IF( .NOT.lsame( xtype, 'C' ) ) THEN
310 DO 10 j = 1, nrhs
311 CALL zlarnv( 2, iseed, n, x( 1, j ) )
312 10 CONTINUE
313 END IF
314*
315* Multiply X by op(A) using an appropriate
316* matrix multiply routine.
317*
318 IF( lsamen( 2, c2, 'GE' ) .OR. lsamen( 2, c2, 'QR' ) .OR.
319 $ lsamen( 2, c2, 'LQ' ) .OR. lsamen( 2, c2, 'QL' ) .OR.
320 $ lsamen( 2, c2, 'RQ' ) ) THEN
321*
322* General matrix
323*
324 CALL zgemm( trans, 'N', mb, nrhs, nx, one, a, lda, x, ldx,
325 $ zero, b, ldb )
326*
327 ELSE IF( lsamen( 2, c2, 'PO' ) .OR. lsamen( 2, c2, 'HE' ) ) THEN
328*
329* Hermitian matrix, 2-D storage
330*
331 CALL zhemm( 'Left', uplo, n, nrhs, one, a, lda, x, ldx, zero,
332 $ b, ldb )
333*
334 ELSE IF( lsamen( 2, c2, 'SY' ) ) THEN
335*
336* Symmetric matrix, 2-D storage
337*
338 CALL zsymm( 'Left', uplo, n, nrhs, one, a, lda, x, ldx, zero,
339 $ b, ldb )
340*
341 ELSE IF( lsamen( 2, c2, 'GB' ) ) THEN
342*
343* General matrix, band storage
344*
345 DO 20 j = 1, nrhs
346 CALL zgbmv( trans, m, n, kl, ku, one, a, lda, x( 1, j ), 1,
347 $ zero, b( 1, j ), 1 )
348 20 CONTINUE
349*
350 ELSE IF( lsamen( 2, c2, 'PB' ) .OR. lsamen( 2, c2, 'HB' ) ) THEN
351*
352* Hermitian matrix, band storage
353*
354 DO 30 j = 1, nrhs
355 CALL zhbmv( uplo, n, kl, one, a, lda, x( 1, j ), 1, zero,
356 $ b( 1, j ), 1 )
357 30 CONTINUE
358*
359 ELSE IF( lsamen( 2, c2, 'SB' ) ) THEN
360*
361* Symmetric matrix, band storage
362*
363 DO 40 j = 1, nrhs
364 CALL zsbmv( uplo, n, kl, one, a, lda, x( 1, j ), 1, zero,
365 $ b( 1, j ), 1 )
366 40 CONTINUE
367*
368 ELSE IF( lsamen( 2, c2, 'PP' ) .OR. lsamen( 2, c2, 'HP' ) ) THEN
369*
370* Hermitian matrix, packed storage
371*
372 DO 50 j = 1, nrhs
373 CALL zhpmv( uplo, n, one, a, x( 1, j ), 1, zero, b( 1, j ),
374 $ 1 )
375 50 CONTINUE
376*
377 ELSE IF( lsamen( 2, c2, 'SP' ) ) THEN
378*
379* Symmetric matrix, packed storage
380*
381 DO 60 j = 1, nrhs
382 CALL zspmv( uplo, n, one, a, x( 1, j ), 1, zero, b( 1, j ),
383 $ 1 )
384 60 CONTINUE
385*
386 ELSE IF( lsamen( 2, c2, 'TR' ) ) THEN
387*
388* Triangular matrix. Note that for triangular matrices,
389* KU = 1 => non-unit triangular
390* KU = 2 => unit triangular
391*
392 CALL zlacpy( 'Full', n, nrhs, x, ldx, b, ldb )
393 IF( ku.EQ.2 ) THEN
394 diag = 'U'
395 ELSE
396 diag = 'N'
397 END IF
398 CALL ztrmm( 'Left', uplo, trans, diag, n, nrhs, one, a, lda, b,
399 $ ldb )
400*
401 ELSE IF( lsamen( 2, c2, 'TP' ) ) THEN
402*
403* Triangular matrix, packed storage
404*
405 CALL zlacpy( 'Full', n, nrhs, x, ldx, b, ldb )
406 IF( ku.EQ.2 ) THEN
407 diag = 'U'
408 ELSE
409 diag = 'N'
410 END IF
411 DO 70 j = 1, nrhs
412 CALL ztpmv( uplo, trans, diag, n, a, b( 1, j ), 1 )
413 70 CONTINUE
414*
415 ELSE IF( lsamen( 2, c2, 'TB' ) ) THEN
416*
417* Triangular matrix, banded storage
418*
419 CALL zlacpy( 'Full', n, nrhs, x, ldx, b, ldb )
420 IF( ku.EQ.2 ) THEN
421 diag = 'U'
422 ELSE
423 diag = 'N'
424 END IF
425 DO 80 j = 1, nrhs
426 CALL ztbmv( uplo, trans, diag, n, kl, a, lda, b( 1, j ), 1 )
427 80 CONTINUE
428*
429 ELSE
430*
431* If none of the above, set INFO = -1 and return
432*
433 info = -1
434 CALL xerbla( 'ZLARHS', -info )
435 END IF
436*
437 RETURN
438*
439* End of ZLARHS
440*
zspmv
subroutine zspmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
ZSPMV computes a matrix-vector product for complex vectors using a complex symmetric packed matrix
Definition zspmv.f:151
zhbmv
subroutine zhbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
ZHBMV
Definition zhbmv.f:187
zhpmv
subroutine zhpmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
ZHPMV
Definition zhpmv.f:149
ztpmv
subroutine ztpmv(uplo, trans, diag, n, ap, x, incx)
ZTPMV
Definition ztpmv.f:142
ztbmv
subroutine ztbmv(uplo, trans, diag, n, k, a, lda, x, incx)
ZTBMV
Definition ztbmv.f:186
zhemm
subroutine zhemm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
ZHEMM
Definition zhemm.f:191
zsymm
subroutine zsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
ZSYMM
Definition zsymm.f:189
zsbmv
subroutine zsbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
ZSBMV
Definition zsbmv.f:152

◆ zlatb4()

subroutine zlatb4 ( character*3 path,
integer imat,
integer m,
integer n,
character type,
integer kl,
integer ku,
double precision anorm,
integer mode,
double precision cndnum,
character dist )

ZLATB4

Purpose:
!>
!> ZLATB4 sets parameters for the matrix generator based on the type of
!> matrix to be generated.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name.
!>
[in]IMAT
!>          IMAT is INTEGER
!>          An integer key describing which matrix to generate for this
!>          path.
!>
[in]M
!>          M is INTEGER
!>          The number of rows in the matrix to be generated.
!>
[in]N
!>          N is INTEGER
!>          The number of columns in the matrix to be generated.
!>
[out]TYPE
!>          TYPE is CHARACTER*1
!>          The type of the matrix to be generated:
!>          = 'S':  symmetric matrix
!>          = 'H':  Hermitian matrix
!>          = 'P':  Hermitian positive (semi)definite matrix
!>          = 'N':  nonsymmetric matrix
!>
[out]KL
!>          KL is INTEGER
!>          The lower band width of the matrix to be generated.
!>
[out]KU
!>          KU is INTEGER
!>          The upper band width of the matrix to be generated.
!>
[out]ANORM
!>          ANORM is DOUBLE PRECISION
!>          The desired norm of the matrix to be generated.  The diagonal
!>          matrix of singular values or eigenvalues is scaled by this
!>          value.
!>
[out]MODE
!>          MODE is INTEGER
!>          A key indicating how to choose the vector of eigenvalues.
!>
[out]CNDNUM
!>          CNDNUM is DOUBLE PRECISION
!>          The desired condition number.
!>
[out]DIST
!>          DIST is CHARACTER*1
!>          The type of distribution to be used by the random number
!>          generator.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 119 of file zlatb4.f.

121*
122* -- LAPACK test routine --
123* -- LAPACK is a software package provided by Univ. of Tennessee, --
124* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
125*
126* .. Scalar Arguments ..
127 CHARACTER DIST, TYPE
128 CHARACTER*3 PATH
129 INTEGER IMAT, KL, KU, M, MODE, N
130 DOUBLE PRECISION ANORM, CNDNUM
131* ..
132*
133* =====================================================================
134*
135* .. Parameters ..
136 DOUBLE PRECISION SHRINK, TENTH
137 parameter( shrink = 0.25d0, tenth = 0.1d+0 )
138 DOUBLE PRECISION ONE
139 parameter( one = 1.0d+0 )
140 DOUBLE PRECISION TWO
141 parameter( two = 2.0d+0 )
142* ..
143* .. Local Scalars ..
144 LOGICAL FIRST
145 CHARACTER*2 C2
146 INTEGER MAT
147 DOUBLE PRECISION BADC1, BADC2, EPS, LARGE, SMALL
148* ..
149* .. External Functions ..
150 LOGICAL LSAMEN
151 DOUBLE PRECISION DLAMCH
152 EXTERNAL lsamen, dlamch
153* ..
154* .. Intrinsic Functions ..
155 INTRINSIC abs, max, sqrt
156* ..
157* .. External Subroutines ..
158 EXTERNAL dlabad
159* ..
160* .. Save statement ..
161 SAVE eps, small, large, badc1, badc2, first
162* ..
163* .. Data statements ..
164 DATA first / .true. /
165* ..
166* .. Executable Statements ..
167*
168* Set some constants for use in the subroutine.
169*
170 IF( first ) THEN
171 first = .false.
172 eps = dlamch( 'Precision' )
173 badc2 = tenth / eps
174 badc1 = sqrt( badc2 )
175 small = dlamch( 'Safe minimum' )
176 large = one / small
177*
178* If it looks like we're on a Cray, take the square root of
179* SMALL and LARGE to avoid overflow and underflow problems.
180*
181 CALL dlabad( small, large )
182 small = shrink*( small / eps )
183 large = one / small
184 END IF
185*
186 c2 = path( 2: 3 )
187*
188* Set some parameters we don't plan to change.
189*
190 dist = 'S'
191 mode = 3
192*
193* xQR, xLQ, xQL, xRQ: Set parameters to generate a general
194* M x N matrix.
195*
196 IF( lsamen( 2, c2, 'QR' ) .OR. lsamen( 2, c2, 'LQ' ) .OR.
197 $ lsamen( 2, c2, 'QL' ) .OR. lsamen( 2, c2, 'RQ' ) ) THEN
198*
199* Set TYPE, the type of matrix to be generated.
200*
201 TYPE = 'N'
202*
203* Set the lower and upper bandwidths.
204*
205 IF( imat.EQ.1 ) THEN
206 kl = 0
207 ku = 0
208 ELSE IF( imat.EQ.2 ) THEN
209 kl = 0
210 ku = max( n-1, 0 )
211 ELSE IF( imat.EQ.3 ) THEN
212 kl = max( m-1, 0 )
213 ku = 0
214 ELSE
215 kl = max( m-1, 0 )
216 ku = max( n-1, 0 )
217 END IF
218*
219* Set the condition number and norm.
220*
221 IF( imat.EQ.5 ) THEN
222 cndnum = badc1
223 ELSE IF( imat.EQ.6 ) THEN
224 cndnum = badc2
225 ELSE
226 cndnum = two
227 END IF
228*
229 IF( imat.EQ.7 ) THEN
230 anorm = small
231 ELSE IF( imat.EQ.8 ) THEN
232 anorm = large
233 ELSE
234 anorm = one
235 END IF
236*
237 ELSE IF( lsamen( 2, c2, 'GE' ) ) THEN
238*
239* xGE: Set parameters to generate a general M x N matrix.
240*
241* Set TYPE, the type of matrix to be generated.
242*
243 TYPE = 'N'
244*
245* Set the lower and upper bandwidths.
246*
247 IF( imat.EQ.1 ) THEN
248 kl = 0
249 ku = 0
250 ELSE IF( imat.EQ.2 ) THEN
251 kl = 0
252 ku = max( n-1, 0 )
253 ELSE IF( imat.EQ.3 ) THEN
254 kl = max( m-1, 0 )
255 ku = 0
256 ELSE
257 kl = max( m-1, 0 )
258 ku = max( n-1, 0 )
259 END IF
260*
261* Set the condition number and norm.
262*
263 IF( imat.EQ.8 ) THEN
264 cndnum = badc1
265 ELSE IF( imat.EQ.9 ) THEN
266 cndnum = badc2
267 ELSE
268 cndnum = two
269 END IF
270*
271 IF( imat.EQ.10 ) THEN
272 anorm = small
273 ELSE IF( imat.EQ.11 ) THEN
274 anorm = large
275 ELSE
276 anorm = one
277 END IF
278*
279 ELSE IF( lsamen( 2, c2, 'GB' ) ) THEN
280*
281* xGB: Set parameters to generate a general banded matrix.
282*
283* Set TYPE, the type of matrix to be generated.
284*
285 TYPE = 'N'
286*
287* Set the condition number and norm.
288*
289 IF( imat.EQ.5 ) THEN
290 cndnum = badc1
291 ELSE IF( imat.EQ.6 ) THEN
292 cndnum = tenth*badc2
293 ELSE
294 cndnum = two
295 END IF
296*
297 IF( imat.EQ.7 ) THEN
298 anorm = small
299 ELSE IF( imat.EQ.8 ) THEN
300 anorm = large
301 ELSE
302 anorm = one
303 END IF
304*
305 ELSE IF( lsamen( 2, c2, 'GT' ) ) THEN
306*
307* xGT: Set parameters to generate a general tridiagonal matrix.
308*
309* Set TYPE, the type of matrix to be generated.
310*
311 TYPE = 'N'
312*
313* Set the lower and upper bandwidths.
314*
315 IF( imat.EQ.1 ) THEN
316 kl = 0
317 ELSE
318 kl = 1
319 END IF
320 ku = kl
321*
322* Set the condition number and norm.
323*
324 IF( imat.EQ.3 ) THEN
325 cndnum = badc1
326 ELSE IF( imat.EQ.4 ) THEN
327 cndnum = badc2
328 ELSE
329 cndnum = two
330 END IF
331*
332 IF( imat.EQ.5 .OR. imat.EQ.11 ) THEN
333 anorm = small
334 ELSE IF( imat.EQ.6 .OR. imat.EQ.12 ) THEN
335 anorm = large
336 ELSE
337 anorm = one
338 END IF
339*
340 ELSE IF( lsamen( 2, c2, 'PO' ) .OR. lsamen( 2, c2, 'PP' ) ) THEN
341*
342* xPO, xPP: Set parameters to generate a
343* symmetric or Hermitian positive definite matrix.
344*
345* Set TYPE, the type of matrix to be generated.
346*
347 TYPE = c2( 1: 1 )
348*
349* Set the lower and upper bandwidths.
350*
351 IF( imat.EQ.1 ) THEN
352 kl = 0
353 ELSE
354 kl = max( n-1, 0 )
355 END IF
356 ku = kl
357*
358* Set the condition number and norm.
359*
360 IF( imat.EQ.6 ) THEN
361 cndnum = badc1
362 ELSE IF( imat.EQ.7 ) THEN
363 cndnum = badc2
364 ELSE
365 cndnum = two
366 END IF
367*
368 IF( imat.EQ.8 ) THEN
369 anorm = small
370 ELSE IF( imat.EQ.9 ) THEN
371 anorm = large
372 ELSE
373 anorm = one
374 END IF
375*
376 ELSE IF( lsamen( 2, c2, 'HE' ) .OR. lsamen( 2, c2, 'HP' ) .OR.
377 $ lsamen( 2, c2, 'SY' ) .OR. lsamen( 2, c2, 'SP' ) ) THEN
378*
379* xHE, xHP, xSY, xSP: Set parameters to generate a
380* symmetric or Hermitian matrix.
381*
382* Set TYPE, the type of matrix to be generated.
383*
384 TYPE = c2( 1: 1 )
385*
386* Set the lower and upper bandwidths.
387*
388 IF( imat.EQ.1 ) THEN
389 kl = 0
390 ELSE
391 kl = max( n-1, 0 )
392 END IF
393 ku = kl
394*
395* Set the condition number and norm.
396*
397 IF( imat.EQ.7 ) THEN
398 cndnum = badc1
399 ELSE IF( imat.EQ.8 ) THEN
400 cndnum = badc2
401 ELSE
402 cndnum = two
403 END IF
404*
405 IF( imat.EQ.9 ) THEN
406 anorm = small
407 ELSE IF( imat.EQ.10 ) THEN
408 anorm = large
409 ELSE
410 anorm = one
411 END IF
412*
413 ELSE IF( lsamen( 2, c2, 'PB' ) ) THEN
414*
415* xPB: Set parameters to generate a symmetric band matrix.
416*
417* Set TYPE, the type of matrix to be generated.
418*
419 TYPE = 'P'
420*
421* Set the norm and condition number.
422*
423 IF( imat.EQ.5 ) THEN
424 cndnum = badc1
425 ELSE IF( imat.EQ.6 ) THEN
426 cndnum = badc2
427 ELSE
428 cndnum = two
429 END IF
430*
431 IF( imat.EQ.7 ) THEN
432 anorm = small
433 ELSE IF( imat.EQ.8 ) THEN
434 anorm = large
435 ELSE
436 anorm = one
437 END IF
438*
439 ELSE IF( lsamen( 2, c2, 'PT' ) ) THEN
440*
441* xPT: Set parameters to generate a symmetric positive definite
442* tridiagonal matrix.
443*
444 TYPE = 'P'
445 IF( imat.EQ.1 ) THEN
446 kl = 0
447 ELSE
448 kl = 1
449 END IF
450 ku = kl
451*
452* Set the condition number and norm.
453*
454 IF( imat.EQ.3 ) THEN
455 cndnum = badc1
456 ELSE IF( imat.EQ.4 ) THEN
457 cndnum = badc2
458 ELSE
459 cndnum = two
460 END IF
461*
462 IF( imat.EQ.5 .OR. imat.EQ.11 ) THEN
463 anorm = small
464 ELSE IF( imat.EQ.6 .OR. imat.EQ.12 ) THEN
465 anorm = large
466 ELSE
467 anorm = one
468 END IF
469*
470 ELSE IF( lsamen( 2, c2, 'TR' ) .OR. lsamen( 2, c2, 'TP' ) ) THEN
471*
472* xTR, xTP: Set parameters to generate a triangular matrix
473*
474* Set TYPE, the type of matrix to be generated.
475*
476 TYPE = 'N'
477*
478* Set the lower and upper bandwidths.
479*
480 mat = abs( imat )
481 IF( mat.EQ.1 .OR. mat.EQ.7 ) THEN
482 kl = 0
483 ku = 0
484 ELSE IF( imat.LT.0 ) THEN
485 kl = max( n-1, 0 )
486 ku = 0
487 ELSE
488 kl = 0
489 ku = max( n-1, 0 )
490 END IF
491*
492* Set the condition number and norm.
493*
494 IF( mat.EQ.3 .OR. mat.EQ.9 ) THEN
495 cndnum = badc1
496 ELSE IF( mat.EQ.4 .OR. mat.EQ.10 ) THEN
497 cndnum = badc2
498 ELSE
499 cndnum = two
500 END IF
501*
502 IF( mat.EQ.5 ) THEN
503 anorm = small
504 ELSE IF( mat.EQ.6 ) THEN
505 anorm = large
506 ELSE
507 anorm = one
508 END IF
509*
510 ELSE IF( lsamen( 2, c2, 'TB' ) ) THEN
511*
512* xTB: Set parameters to generate a triangular band matrix.
513*
514* Set TYPE, the type of matrix to be generated.
515*
516 TYPE = 'N'
517*
518* Set the norm and condition number.
519*
520 IF( imat.EQ.2 .OR. imat.EQ.8 ) THEN
521 cndnum = badc1
522 ELSE IF( imat.EQ.3 .OR. imat.EQ.9 ) THEN
523 cndnum = badc2
524 ELSE
525 cndnum = two
526 END IF
527*
528 IF( imat.EQ.4 ) THEN
529 anorm = small
530 ELSE IF( imat.EQ.5 ) THEN
531 anorm = large
532 ELSE
533 anorm = one
534 END IF
535 END IF
536 IF( n.LE.1 )
537 $ cndnum = one
538*
539 RETURN
540*
541* End of ZLATB4
542*
dlabad
subroutine dlabad(small, large)
DLABAD
Definition dlabad.f:74

◆ zlatb5()

subroutine zlatb5 ( character*3 path,
integer imat,
integer n,
character type,
integer kl,
integer ku,
double precision anorm,
integer mode,
double precision cndnum,
character dist )

ZLATB5

Purpose:
!>
!> ZLATB5 sets parameters for the matrix generator based on the type
!> of matrix to be generated.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The LAPACK path name.
!>
[in]IMAT
!>          IMAT is INTEGER
!>          An integer key describing which matrix to generate for this
!>          path.
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns in the matrix to be generated.
!>
[out]TYPE
!>          TYPE is CHARACTER*1
!>          The type of the matrix to be generated:
!>          = 'S':  symmetric matrix
!>          = 'P':  symmetric positive (semi)definite matrix
!>          = 'N':  nonsymmetric matrix
!>
[out]KL
!>          KL is INTEGER
!>          The lower band width of the matrix to be generated.
!>
[out]KU
!>          KU is INTEGER
!>          The upper band width of the matrix to be generated.
!>
[out]ANORM
!>          ANORM is DOUBLE PRECISION
!>          The desired norm of the matrix to be generated.  The diagonal
!>          matrix of singular values or eigenvalues is scaled by this
!>          value.
!>
[out]MODE
!>          MODE is INTEGER
!>          A key indicating how to choose the vector of eigenvalues.
!>
[out]CNDNUM
!>          CNDNUM is DOUBLE PRECISION
!>          The desired condition number.
!>
[out]DIST
!>          DIST is CHARACTER*1
!>          The type of distribution to be used by the random number
!>          generator.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 112 of file zlatb5.f.

114*
115* -- LAPACK test routine --
116* -- LAPACK is a software package provided by Univ. of Tennessee, --
117* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
118*
119* .. Scalar Arguments ..
120 DOUBLE PRECISION ANORM, CNDNUM
121 INTEGER IMAT, KL, KU, MODE, N
122 CHARACTER DIST, TYPE
123 CHARACTER*3 PATH
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 DOUBLE PRECISION SHRINK, TENTH
130 parameter( shrink = 0.25d0, tenth = 0.1d+0 )
131 DOUBLE PRECISION ONE
132 parameter( one = 1.0d+0 )
133 DOUBLE PRECISION TWO
134 parameter( two = 2.0d+0 )
135* ..
136* .. Local Scalars ..
137 DOUBLE PRECISION BADC1, BADC2, EPS, LARGE, SMALL
138 LOGICAL FIRST
139 CHARACTER*2 C2
140* ..
141* .. External Functions ..
142 DOUBLE PRECISION DLAMCH
143 EXTERNAL dlamch
144* ..
145* .. Intrinsic Functions ..
146 INTRINSIC max, sqrt
147* ..
148* .. External Subroutines ..
149 EXTERNAL dlabad
150* ..
151* .. Save statement ..
152 SAVE eps, small, large, badc1, badc2, first
153* ..
154* .. Data statements ..
155 DATA first / .true. /
156* ..
157* .. Executable Statements ..
158*
159* Set some constants for use in the subroutine.
160*
161 IF( first ) THEN
162 first = .false.
163 eps = dlamch( 'Precision' )
164 badc2 = tenth / eps
165 badc1 = sqrt( badc2 )
166 small = dlamch( 'Safe minimum' )
167 large = one / small
168*
169* If it looks like we're on a Cray, take the square root of
170* SMALL and LARGE to avoid overflow and underflow problems.
171*
172 CALL dlabad( small, large )
173 small = shrink*( small / eps )
174 large = one / small
175 END IF
176*
177 c2 = path( 2: 3 )
178*
179* Set some parameters
180*
181 dist = 'S'
182 mode = 3
183*
184* Set TYPE, the type of matrix to be generated.
185*
186 TYPE = c2( 1: 1 )
187*
188* Set the lower and upper bandwidths.
189*
190 IF( imat.EQ.1 ) THEN
191 kl = 0
192 ELSE
193 kl = max( n-1, 0 )
194 END IF
195 ku = kl
196*
197* Set the condition number and norm.etc
198*
199 IF( imat.EQ.3 ) THEN
200 cndnum = 1.0d12
201 mode = 2
202 ELSE IF( imat.EQ.4 ) THEN
203 cndnum = 1.0d12
204 mode = 1
205 ELSE IF( imat.EQ.5 ) THEN
206 cndnum = 1.0d12
207 mode = 3
208 ELSE IF( imat.EQ.6 ) THEN
209 cndnum = badc1
210 ELSE IF( imat.EQ.7 ) THEN
211 cndnum = badc2
212 ELSE
213 cndnum = two
214 END IF
215*
216 IF( imat.EQ.8 ) THEN
217 anorm = small
218 ELSE IF( imat.EQ.9 ) THEN
219 anorm = large
220 ELSE
221 anorm = one
222 END IF
223*
224 IF( n.LE.1 )
225 $ cndnum = one
226*
227 RETURN
228*
229* End of ZLATB5
230*

◆ zlatsp()

subroutine zlatsp ( character uplo,
integer n,
complex*16, dimension( * ) x,
integer, dimension( * ) iseed )

ZLATSP

Purpose:
!>
!> ZLATSP generates a special test matrix for the complex symmetric
!> (indefinite) factorization for packed matrices.  The pivot blocks of
!> the generated matrix will be in the following order:
!>    2x2 pivot block, non diagonalizable
!>    1x1 pivot block
!>    2x2 pivot block, diagonalizable
!>    (cycle repeats)
!> A row interchange is required for each non-diagonalizable 2x2 block.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER
!>          Specifies whether the generated matrix is to be upper or
!>          lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The dimension of the matrix to be generated.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The generated matrix in packed storage format.  The matrix
!>          consists of 3x3 and 2x2 diagonal blocks which result in the
!>          pivot sequence given above.  The matrix outside these
!>          diagonal blocks is zero.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry, the seed for the random number generator.  The last
!>          of the four integers must be odd.  (modified on exit)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 83 of file zlatsp.f.

84*
85* -- LAPACK test routine --
86* -- LAPACK is a software package provided by Univ. of Tennessee, --
87* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
88*
89* .. Scalar Arguments ..
90 CHARACTER UPLO
91 INTEGER N
92* ..
93* .. Array Arguments ..
94 INTEGER ISEED( * )
95 COMPLEX*16 X( * )
96* ..
97*
98* =====================================================================
99*
100* .. Parameters ..
101 COMPLEX*16 EYE
102 parameter( eye = ( 0.0d0, 1.0d0 ) )
103* ..
104* .. Local Scalars ..
105 INTEGER J, JJ, N5
106 DOUBLE PRECISION ALPHA, ALPHA3, BETA
107 COMPLEX*16 A, B, C, R
108* ..
109* .. External Functions ..
110 COMPLEX*16 ZLARND
111 EXTERNAL zlarnd
112* ..
113* .. Intrinsic Functions ..
114 INTRINSIC abs, sqrt
115* ..
116* .. Executable Statements ..
117*
118* Initialize constants
119*
120 alpha = ( 1.d0+sqrt( 17.d0 ) ) / 8.d0
121 beta = alpha - 1.d0 / 1000.d0
122 alpha3 = alpha*alpha*alpha
123*
124* Fill the matrix with zeros.
125*
126 DO 10 j = 1, n*( n+1 ) / 2
127 x( j ) = 0.0d0
128 10 CONTINUE
129*
130* UPLO = 'U': Upper triangular storage
131*
132 IF( uplo.EQ.'U' ) THEN
133 n5 = n / 5
134 n5 = n - 5*n5 + 1
135*
136 jj = n*( n+1 ) / 2
137 DO 20 j = n, n5, -5
138 a = alpha3*zlarnd( 5, iseed )
139 b = zlarnd( 5, iseed ) / alpha
140 c = a - 2.d0*b*eye
141 r = c / beta
142 x( jj ) = a
143 x( jj-2 ) = b
144 jj = jj - j
145 x( jj ) = zlarnd( 2, iseed )
146 x( jj-1 ) = r
147 jj = jj - ( j-1 )
148 x( jj ) = c
149 jj = jj - ( j-2 )
150 x( jj ) = zlarnd( 2, iseed )
151 jj = jj - ( j-3 )
152 x( jj ) = zlarnd( 2, iseed )
153 IF( abs( x( jj+( j-3 ) ) ).GT.abs( x( jj ) ) ) THEN
154 x( jj+( j-4 ) ) = 2.0d0*x( jj+( j-3 ) )
155 ELSE
156 x( jj+( j-4 ) ) = 2.0d0*x( jj )
157 END IF
158 jj = jj - ( j-4 )
159 20 CONTINUE
160*
161* Clean-up for N not a multiple of 5.
162*
163 j = n5 - 1
164 IF( j.GT.2 ) THEN
165 a = alpha3*zlarnd( 5, iseed )
166 b = zlarnd( 5, iseed ) / alpha
167 c = a - 2.d0*b*eye
168 r = c / beta
169 x( jj ) = a
170 x( jj-2 ) = b
171 jj = jj - j
172 x( jj ) = zlarnd( 2, iseed )
173 x( jj-1 ) = r
174 jj = jj - ( j-1 )
175 x( jj ) = c
176 jj = jj - ( j-2 )
177 j = j - 3
178 END IF
179 IF( j.GT.1 ) THEN
180 x( jj ) = zlarnd( 2, iseed )
181 x( jj-j ) = zlarnd( 2, iseed )
182 IF( abs( x( jj ) ).GT.abs( x( jj-j ) ) ) THEN
183 x( jj-1 ) = 2.0d0*x( jj )
184 ELSE
185 x( jj-1 ) = 2.0d0*x( jj-j )
186 END IF
187 jj = jj - j - ( j-1 )
188 j = j - 2
189 ELSE IF( j.EQ.1 ) THEN
190 x( jj ) = zlarnd( 2, iseed )
191 j = j - 1
192 END IF
193*
194* UPLO = 'L': Lower triangular storage
195*
196 ELSE
197 n5 = n / 5
198 n5 = n5*5
199*
200 jj = 1
201 DO 30 j = 1, n5, 5
202 a = alpha3*zlarnd( 5, iseed )
203 b = zlarnd( 5, iseed ) / alpha
204 c = a - 2.d0*b*eye
205 r = c / beta
206 x( jj ) = a
207 x( jj+2 ) = b
208 jj = jj + ( n-j+1 )
209 x( jj ) = zlarnd( 2, iseed )
210 x( jj+1 ) = r
211 jj = jj + ( n-j )
212 x( jj ) = c
213 jj = jj + ( n-j-1 )
214 x( jj ) = zlarnd( 2, iseed )
215 jj = jj + ( n-j-2 )
216 x( jj ) = zlarnd( 2, iseed )
217 IF( abs( x( jj-( n-j-2 ) ) ).GT.abs( x( jj ) ) ) THEN
218 x( jj-( n-j-2 )+1 ) = 2.0d0*x( jj-( n-j-2 ) )
219 ELSE
220 x( jj-( n-j-2 )+1 ) = 2.0d0*x( jj )
221 END IF
222 jj = jj + ( n-j-3 )
223 30 CONTINUE
224*
225* Clean-up for N not a multiple of 5.
226*
227 j = n5 + 1
228 IF( j.LT.n-1 ) THEN
229 a = alpha3*zlarnd( 5, iseed )
230 b = zlarnd( 5, iseed ) / alpha
231 c = a - 2.d0*b*eye
232 r = c / beta
233 x( jj ) = a
234 x( jj+2 ) = b
235 jj = jj + ( n-j+1 )
236 x( jj ) = zlarnd( 2, iseed )
237 x( jj+1 ) = r
238 jj = jj + ( n-j )
239 x( jj ) = c
240 jj = jj + ( n-j-1 )
241 j = j + 3
242 END IF
243 IF( j.LT.n ) THEN
244 x( jj ) = zlarnd( 2, iseed )
245 x( jj+( n-j+1 ) ) = zlarnd( 2, iseed )
246 IF( abs( x( jj ) ).GT.abs( x( jj+( n-j+1 ) ) ) ) THEN
247 x( jj+1 ) = 2.0d0*x( jj )
248 ELSE
249 x( jj+1 ) = 2.0d0*x( jj+( n-j+1 ) )
250 END IF
251 jj = jj + ( n-j+1 ) + ( n-j )
252 j = j + 2
253 ELSE IF( j.EQ.n ) THEN
254 x( jj ) = zlarnd( 2, iseed )
255 jj = jj + ( n-j+1 )
256 j = j + 1
257 END IF
258 END IF
259*
260 RETURN
261*
262* End of ZLATSP
263*

◆ zlatsy()

subroutine zlatsy ( character uplo,
integer n,
complex*16, dimension( ldx, * ) x,
integer ldx,
integer, dimension( * ) iseed )

ZLATSY

Purpose:
!>
!> ZLATSY generates a special test matrix for the complex symmetric
!> (indefinite) factorization.  The pivot blocks of the generated matrix
!> will be in the following order:
!>    2x2 pivot block, non diagonalizable
!>    1x1 pivot block
!>    2x2 pivot block, diagonalizable
!>    (cycle repeats)
!> A row interchange is required for each non-diagonalizable 2x2 block.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER
!>          Specifies whether the generated matrix is to be upper or
!>          lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The dimension of the matrix to be generated.
!>
[out]X
!>          X is COMPLEX*16 array, dimension (LDX,N)
!>          The generated matrix, consisting of 3x3 and 2x2 diagonal
!>          blocks which result in the pivot sequence given above.
!>          The matrix outside of these diagonal blocks is zero.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          On entry, the seed for the random number generator.  The last
!>          of the four integers must be odd.  (modified on exit)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 88 of file zlatsy.f.

89*
90* -- LAPACK test routine --
91* -- LAPACK is a software package provided by Univ. of Tennessee, --
92* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
93*
94* .. Scalar Arguments ..
95 CHARACTER UPLO
96 INTEGER LDX, N
97* ..
98* .. Array Arguments ..
99 INTEGER ISEED( * )
100 COMPLEX*16 X( LDX, * )
101* ..
102*
103* =====================================================================
104*
105* .. Parameters ..
106 COMPLEX*16 EYE
107 parameter( eye = ( 0.0d0, 1.0d0 ) )
108* ..
109* .. Local Scalars ..
110 INTEGER I, J, N5
111 DOUBLE PRECISION ALPHA, ALPHA3, BETA
112 COMPLEX*16 A, B, C, R
113* ..
114* .. External Functions ..
115 COMPLEX*16 ZLARND
116 EXTERNAL zlarnd
117* ..
118* .. Intrinsic Functions ..
119 INTRINSIC abs, sqrt
120* ..
121* .. Executable Statements ..
122*
123* Initialize constants
124*
125 alpha = ( 1.d0+sqrt( 17.d0 ) ) / 8.d0
126 beta = alpha - 1.d0 / 1000.d0
127 alpha3 = alpha*alpha*alpha
128*
129* UPLO = 'U': Upper triangular storage
130*
131 IF( uplo.EQ.'U' ) THEN
132*
133* Fill the upper triangle of the matrix with zeros.
134*
135 DO 20 j = 1, n
136 DO 10 i = 1, j
137 x( i, j ) = 0.0d0
138 10 CONTINUE
139 20 CONTINUE
140 n5 = n / 5
141 n5 = n - 5*n5 + 1
142*
143 DO 30 i = n, n5, -5
144 a = alpha3*zlarnd( 5, iseed )
145 b = zlarnd( 5, iseed ) / alpha
146 c = a - 2.d0*b*eye
147 r = c / beta
148 x( i, i ) = a
149 x( i-2, i ) = b
150 x( i-2, i-1 ) = r
151 x( i-2, i-2 ) = c
152 x( i-1, i-1 ) = zlarnd( 2, iseed )
153 x( i-3, i-3 ) = zlarnd( 2, iseed )
154 x( i-4, i-4 ) = zlarnd( 2, iseed )
155 IF( abs( x( i-3, i-3 ) ).GT.abs( x( i-4, i-4 ) ) ) THEN
156 x( i-4, i-3 ) = 2.0d0*x( i-3, i-3 )
157 ELSE
158 x( i-4, i-3 ) = 2.0d0*x( i-4, i-4 )
159 END IF
160 30 CONTINUE
161*
162* Clean-up for N not a multiple of 5.
163*
164 i = n5 - 1
165 IF( i.GT.2 ) THEN
166 a = alpha3*zlarnd( 5, iseed )
167 b = zlarnd( 5, iseed ) / alpha
168 c = a - 2.d0*b*eye
169 r = c / beta
170 x( i, i ) = a
171 x( i-2, i ) = b
172 x( i-2, i-1 ) = r
173 x( i-2, i-2 ) = c
174 x( i-1, i-1 ) = zlarnd( 2, iseed )
175 i = i - 3
176 END IF
177 IF( i.GT.1 ) THEN
178 x( i, i ) = zlarnd( 2, iseed )
179 x( i-1, i-1 ) = zlarnd( 2, iseed )
180 IF( abs( x( i, i ) ).GT.abs( x( i-1, i-1 ) ) ) THEN
181 x( i-1, i ) = 2.0d0*x( i, i )
182 ELSE
183 x( i-1, i ) = 2.0d0*x( i-1, i-1 )
184 END IF
185 i = i - 2
186 ELSE IF( i.EQ.1 ) THEN
187 x( i, i ) = zlarnd( 2, iseed )
188 i = i - 1
189 END IF
190*
191* UPLO = 'L': Lower triangular storage
192*
193 ELSE
194*
195* Fill the lower triangle of the matrix with zeros.
196*
197 DO 50 j = 1, n
198 DO 40 i = j, n
199 x( i, j ) = 0.0d0
200 40 CONTINUE
201 50 CONTINUE
202 n5 = n / 5
203 n5 = n5*5
204*
205 DO 60 i = 1, n5, 5
206 a = alpha3*zlarnd( 5, iseed )
207 b = zlarnd( 5, iseed ) / alpha
208 c = a - 2.d0*b*eye
209 r = c / beta
210 x( i, i ) = a
211 x( i+2, i ) = b
212 x( i+2, i+1 ) = r
213 x( i+2, i+2 ) = c
214 x( i+1, i+1 ) = zlarnd( 2, iseed )
215 x( i+3, i+3 ) = zlarnd( 2, iseed )
216 x( i+4, i+4 ) = zlarnd( 2, iseed )
217 IF( abs( x( i+3, i+3 ) ).GT.abs( x( i+4, i+4 ) ) ) THEN
218 x( i+4, i+3 ) = 2.0d0*x( i+3, i+3 )
219 ELSE
220 x( i+4, i+3 ) = 2.0d0*x( i+4, i+4 )
221 END IF
222 60 CONTINUE
223*
224* Clean-up for N not a multiple of 5.
225*
226 i = n5 + 1
227 IF( i.LT.n-1 ) THEN
228 a = alpha3*zlarnd( 5, iseed )
229 b = zlarnd( 5, iseed ) / alpha
230 c = a - 2.d0*b*eye
231 r = c / beta
232 x( i, i ) = a
233 x( i+2, i ) = b
234 x( i+2, i+1 ) = r
235 x( i+2, i+2 ) = c
236 x( i+1, i+1 ) = zlarnd( 2, iseed )
237 i = i + 3
238 END IF
239 IF( i.LT.n ) THEN
240 x( i, i ) = zlarnd( 2, iseed )
241 x( i+1, i+1 ) = zlarnd( 2, iseed )
242 IF( abs( x( i, i ) ).GT.abs( x( i+1, i+1 ) ) ) THEN
243 x( i+1, i ) = 2.0d0*x( i, i )
244 ELSE
245 x( i+1, i ) = 2.0d0*x( i+1, i+1 )
246 END IF
247 i = i + 2
248 ELSE IF( i.EQ.n ) THEN
249 x( i, i ) = zlarnd( 2, iseed )
250 i = i + 1
251 END IF
252 END IF
253*
254 RETURN
255*
256* End of ZLATSY
257*

◆ zlattb()

subroutine zlattb ( integer imat,
character uplo,
character trans,
character diag,
integer, dimension( 4 ) iseed,
integer n,
integer kd,
complex*16, dimension( ldab, * ) ab,
integer ldab,
complex*16, dimension( * ) b,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZLATTB

Purpose:
!>
!> ZLATTB generates a triangular test matrix in 2-dimensional storage.
!> IMAT and UPLO uniquely specify the properties of the test matrix,
!> which is returned in the array A.
!>
Parameters
[in]IMAT
!>          IMAT is INTEGER
!>          An integer key describing which matrix to generate for this
!>          path.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A will be upper or lower
!>          triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies whether the matrix or its transpose will be used.
!>          = 'N':  No transpose
!>          = 'T':  Transpose
!>          = 'C':  Conjugate transpose (= transpose)
!>
[out]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          The seed vector for the random number generator (used in
!>          ZLATMS).  Modified on exit.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix to be generated.
!>
[in]KD
!>          KD is INTEGER
!>          The number of superdiagonals or subdiagonals of the banded
!>          triangular matrix A.  KD >= 0.
!>
[out]AB
!>          AB is COMPLEX*16 array, dimension (LDAB,N)
!>          The upper or lower triangular banded matrix A, stored in the
!>          first KD+1 rows of AB.  Let j be a column of A, 1<=j<=n.
!>          If UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j.
!>          If UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[out]B
!>          B is COMPLEX*16 array, dimension (N)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 139 of file zlattb.f.

141*
142* -- LAPACK test routine --
143* -- LAPACK is a software package provided by Univ. of Tennessee, --
144* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
145*
146* .. Scalar Arguments ..
147 CHARACTER DIAG, TRANS, UPLO
148 INTEGER IMAT, INFO, KD, LDAB, N
149* ..
150* .. Array Arguments ..
151 INTEGER ISEED( 4 )
152 DOUBLE PRECISION RWORK( * )
153 COMPLEX*16 AB( LDAB, * ), B( * ), WORK( * )
154* ..
155*
156* =====================================================================
157*
158* .. Parameters ..
159 DOUBLE PRECISION ONE, TWO, ZERO
160 parameter( one = 1.0d+0, two = 2.0d+0, zero = 0.0d+0 )
161* ..
162* .. Local Scalars ..
163 LOGICAL UPPER
164 CHARACTER DIST, PACKIT, TYPE
165 CHARACTER*3 PATH
166 INTEGER I, IOFF, IY, J, JCOUNT, KL, KU, LENJ, MODE
167 DOUBLE PRECISION ANORM, BIGNUM, BNORM, BSCAL, CNDNUM, REXP,
168 $ SFAC, SMLNUM, TEXP, TLEFT, TNORM, TSCAL, ULP,
169 $ UNFL
170 COMPLEX*16 PLUS1, PLUS2, STAR1
171* ..
172* .. External Functions ..
173 LOGICAL LSAME
174 INTEGER IZAMAX
175 DOUBLE PRECISION DLAMCH, DLARND
176 COMPLEX*16 ZLARND
177 EXTERNAL lsame, izamax, dlamch, dlarnd, zlarnd
178* ..
179* .. External Subroutines ..
180 EXTERNAL dlabad, dlarnv, zcopy, zdscal, zlarnv, zlatb4,
181 $ zlatms, zswap
182* ..
183* .. Intrinsic Functions ..
184 INTRINSIC abs, dble, dcmplx, max, min, sqrt
185* ..
186* .. Executable Statements ..
187*
188 path( 1: 1 ) = 'Zomplex precision'
189 path( 2: 3 ) = 'TB'
190 unfl = dlamch( 'Safe minimum' )
191 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
192 smlnum = unfl
193 bignum = ( one-ulp ) / smlnum
194 CALL dlabad( smlnum, bignum )
195 IF( ( imat.GE.6 .AND. imat.LE.9 ) .OR. imat.EQ.17 ) THEN
196 diag = 'U'
197 ELSE
198 diag = 'N'
199 END IF
200 info = 0
201*
202* Quick return if N.LE.0.
203*
204 IF( n.LE.0 )
205 $ RETURN
206*
207* Call ZLATB4 to set parameters for CLATMS.
208*
209 upper = lsame( uplo, 'U' )
210 IF( upper ) THEN
211 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
212 $ CNDNUM, DIST )
213 ku = kd
214 ioff = 1 + max( 0, kd-n+1 )
215 kl = 0
216 packit = 'Q'
217 ELSE
218 CALL zlatb4( path, -imat, n, n, TYPE, KL, KU, ANORM, MODE,
219 $ CNDNUM, DIST )
220 kl = kd
221 ioff = 1
222 ku = 0
223 packit = 'B'
224 END IF
225*
226* IMAT <= 5: Non-unit triangular matrix
227*
228 IF( imat.LE.5 ) THEN
229 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE, CNDNUM,
230 $ ANORM, KL, KU, PACKIT, AB( IOFF, 1 ), LDAB, WORK,
231 $ INFO )
232*
233* IMAT > 5: Unit triangular matrix
234* The diagonal is deliberately set to something other than 1.
235*
236* IMAT = 6: Matrix is the identity
237*
238 ELSE IF( imat.EQ.6 ) THEN
239 IF( upper ) THEN
240 DO 20 j = 1, n
241 DO 10 i = max( 1, kd+2-j ), kd
242 ab( i, j ) = zero
243 10 CONTINUE
244 ab( kd+1, j ) = j
245 20 CONTINUE
246 ELSE
247 DO 40 j = 1, n
248 ab( 1, j ) = j
249 DO 30 i = 2, min( kd+1, n-j+1 )
250 ab( i, j ) = zero
251 30 CONTINUE
252 40 CONTINUE
253 END IF
254*
255* IMAT > 6: Non-trivial unit triangular matrix
256*
257* A unit triangular matrix T with condition CNDNUM is formed.
258* In this version, T only has bandwidth 2, the rest of it is zero.
259*
260 ELSE IF( imat.LE.9 ) THEN
261 tnorm = sqrt( cndnum )
262*
263* Initialize AB to zero.
264*
265 IF( upper ) THEN
266 DO 60 j = 1, n
267 DO 50 i = max( 1, kd+2-j ), kd
268 ab( i, j ) = zero
269 50 CONTINUE
270 ab( kd+1, j ) = dble( j )
271 60 CONTINUE
272 ELSE
273 DO 80 j = 1, n
274 DO 70 i = 2, min( kd+1, n-j+1 )
275 ab( i, j ) = zero
276 70 CONTINUE
277 ab( 1, j ) = dble( j )
278 80 CONTINUE
279 END IF
280*
281* Special case: T is tridiagonal. Set every other offdiagonal
282* so that the matrix has norm TNORM+1.
283*
284 IF( kd.EQ.1 ) THEN
285 IF( upper ) THEN
286 ab( 1, 2 ) = tnorm*zlarnd( 5, iseed )
287 lenj = ( n-3 ) / 2
288 CALL zlarnv( 2, iseed, lenj, work )
289 DO 90 j = 1, lenj
290 ab( 1, 2*( j+1 ) ) = tnorm*work( j )
291 90 CONTINUE
292 ELSE
293 ab( 2, 1 ) = tnorm*zlarnd( 5, iseed )
294 lenj = ( n-3 ) / 2
295 CALL zlarnv( 2, iseed, lenj, work )
296 DO 100 j = 1, lenj
297 ab( 2, 2*j+1 ) = tnorm*work( j )
298 100 CONTINUE
299 END IF
300 ELSE IF( kd.GT.1 ) THEN
301*
302* Form a unit triangular matrix T with condition CNDNUM. T is
303* given by
304* | 1 + * |
305* | 1 + |
306* T = | 1 + * |
307* | 1 + |
308* | 1 + * |
309* | 1 + |
310* | . . . |
311* Each element marked with a '*' is formed by taking the product
312* of the adjacent elements marked with '+'. The '*'s can be
313* chosen freely, and the '+'s are chosen so that the inverse of
314* T will have elements of the same magnitude as T.
315*
316* The two offdiagonals of T are stored in WORK.
317*
318 star1 = tnorm*zlarnd( 5, iseed )
319 sfac = sqrt( tnorm )
320 plus1 = sfac*zlarnd( 5, iseed )
321 DO 110 j = 1, n, 2
322 plus2 = star1 / plus1
323 work( j ) = plus1
324 work( n+j ) = star1
325 IF( j+1.LE.n ) THEN
326 work( j+1 ) = plus2
327 work( n+j+1 ) = zero
328 plus1 = star1 / plus2
329*
330* Generate a new *-value with norm between sqrt(TNORM)
331* and TNORM.
332*
333 rexp = dlarnd( 2, iseed )
334 IF( rexp.LT.zero ) THEN
335 star1 = -sfac**( one-rexp )*zlarnd( 5, iseed )
336 ELSE
337 star1 = sfac**( one+rexp )*zlarnd( 5, iseed )
338 END IF
339 END IF
340 110 CONTINUE
341*
342* Copy the tridiagonal T to AB.
343*
344 IF( upper ) THEN
345 CALL zcopy( n-1, work, 1, ab( kd, 2 ), ldab )
346 CALL zcopy( n-2, work( n+1 ), 1, ab( kd-1, 3 ), ldab )
347 ELSE
348 CALL zcopy( n-1, work, 1, ab( 2, 1 ), ldab )
349 CALL zcopy( n-2, work( n+1 ), 1, ab( 3, 1 ), ldab )
350 END IF
351 END IF
352*
353* IMAT > 9: Pathological test cases. These triangular matrices
354* are badly scaled or badly conditioned, so when used in solving a
355* triangular system they may cause overflow in the solution vector.
356*
357 ELSE IF( imat.EQ.10 ) THEN
358*
359* Type 10: Generate a triangular matrix with elements between
360* -1 and 1. Give the diagonal norm 2 to make it well-conditioned.
361* Make the right hand side large so that it requires scaling.
362*
363 IF( upper ) THEN
364 DO 120 j = 1, n
365 lenj = min( j-1, kd )
366 CALL zlarnv( 4, iseed, lenj, ab( kd+1-lenj, j ) )
367 ab( kd+1, j ) = zlarnd( 5, iseed )*two
368 120 CONTINUE
369 ELSE
370 DO 130 j = 1, n
371 lenj = min( n-j, kd )
372 IF( lenj.GT.0 )
373 $ CALL zlarnv( 4, iseed, lenj, ab( 2, j ) )
374 ab( 1, j ) = zlarnd( 5, iseed )*two
375 130 CONTINUE
376 END IF
377*
378* Set the right hand side so that the largest value is BIGNUM.
379*
380 CALL zlarnv( 2, iseed, n, b )
381 iy = izamax( n, b, 1 )
382 bnorm = abs( b( iy ) )
383 bscal = bignum / max( one, bnorm )
384 CALL zdscal( n, bscal, b, 1 )
385*
386 ELSE IF( imat.EQ.11 ) THEN
387*
388* Type 11: Make the first diagonal element in the solve small to
389* cause immediate overflow when dividing by T(j,j).
390* In type 11, the offdiagonal elements are small (CNORM(j) < 1).
391*
392 CALL zlarnv( 2, iseed, n, b )
393 tscal = one / dble( kd+1 )
394 IF( upper ) THEN
395 DO 140 j = 1, n
396 lenj = min( j-1, kd )
397 IF( lenj.GT.0 ) THEN
398 CALL zlarnv( 4, iseed, lenj, ab( kd+2-lenj, j ) )
399 CALL zdscal( lenj, tscal, ab( kd+2-lenj, j ), 1 )
400 END IF
401 ab( kd+1, j ) = zlarnd( 5, iseed )
402 140 CONTINUE
403 ab( kd+1, n ) = smlnum*ab( kd+1, n )
404 ELSE
405 DO 150 j = 1, n
406 lenj = min( n-j, kd )
407 IF( lenj.GT.0 ) THEN
408 CALL zlarnv( 4, iseed, lenj, ab( 2, j ) )
409 CALL zdscal( lenj, tscal, ab( 2, j ), 1 )
410 END IF
411 ab( 1, j ) = zlarnd( 5, iseed )
412 150 CONTINUE
413 ab( 1, 1 ) = smlnum*ab( 1, 1 )
414 END IF
415*
416 ELSE IF( imat.EQ.12 ) THEN
417*
418* Type 12: Make the first diagonal element in the solve small to
419* cause immediate overflow when dividing by T(j,j).
420* In type 12, the offdiagonal elements are O(1) (CNORM(j) > 1).
421*
422 CALL zlarnv( 2, iseed, n, b )
423 IF( upper ) THEN
424 DO 160 j = 1, n
425 lenj = min( j-1, kd )
426 IF( lenj.GT.0 )
427 $ CALL zlarnv( 4, iseed, lenj, ab( kd+2-lenj, j ) )
428 ab( kd+1, j ) = zlarnd( 5, iseed )
429 160 CONTINUE
430 ab( kd+1, n ) = smlnum*ab( kd+1, n )
431 ELSE
432 DO 170 j = 1, n
433 lenj = min( n-j, kd )
434 IF( lenj.GT.0 )
435 $ CALL zlarnv( 4, iseed, lenj, ab( 2, j ) )
436 ab( 1, j ) = zlarnd( 5, iseed )
437 170 CONTINUE
438 ab( 1, 1 ) = smlnum*ab( 1, 1 )
439 END IF
440*
441 ELSE IF( imat.EQ.13 ) THEN
442*
443* Type 13: T is diagonal with small numbers on the diagonal to
444* make the growth factor underflow, but a small right hand side
445* chosen so that the solution does not overflow.
446*
447 IF( upper ) THEN
448 jcount = 1
449 DO 190 j = n, 1, -1
450 DO 180 i = max( 1, kd+1-( j-1 ) ), kd
451 ab( i, j ) = zero
452 180 CONTINUE
453 IF( jcount.LE.2 ) THEN
454 ab( kd+1, j ) = smlnum*zlarnd( 5, iseed )
455 ELSE
456 ab( kd+1, j ) = zlarnd( 5, iseed )
457 END IF
458 jcount = jcount + 1
459 IF( jcount.GT.4 )
460 $ jcount = 1
461 190 CONTINUE
462 ELSE
463 jcount = 1
464 DO 210 j = 1, n
465 DO 200 i = 2, min( n-j+1, kd+1 )
466 ab( i, j ) = zero
467 200 CONTINUE
468 IF( jcount.LE.2 ) THEN
469 ab( 1, j ) = smlnum*zlarnd( 5, iseed )
470 ELSE
471 ab( 1, j ) = zlarnd( 5, iseed )
472 END IF
473 jcount = jcount + 1
474 IF( jcount.GT.4 )
475 $ jcount = 1
476 210 CONTINUE
477 END IF
478*
479* Set the right hand side alternately zero and small.
480*
481 IF( upper ) THEN
482 b( 1 ) = zero
483 DO 220 i = n, 2, -2
484 b( i ) = zero
485 b( i-1 ) = smlnum*zlarnd( 5, iseed )
486 220 CONTINUE
487 ELSE
488 b( n ) = zero
489 DO 230 i = 1, n - 1, 2
490 b( i ) = zero
491 b( i+1 ) = smlnum*zlarnd( 5, iseed )
492 230 CONTINUE
493 END IF
494*
495 ELSE IF( imat.EQ.14 ) THEN
496*
497* Type 14: Make the diagonal elements small to cause gradual
498* overflow when dividing by T(j,j). To control the amount of
499* scaling needed, the matrix is bidiagonal.
500*
501 texp = one / dble( kd+1 )
502 tscal = smlnum**texp
503 CALL zlarnv( 4, iseed, n, b )
504 IF( upper ) THEN
505 DO 250 j = 1, n
506 DO 240 i = max( 1, kd+2-j ), kd
507 ab( i, j ) = zero
508 240 CONTINUE
509 IF( j.GT.1 .AND. kd.GT.0 )
510 $ ab( kd, j ) = dcmplx( -one, -one )
511 ab( kd+1, j ) = tscal*zlarnd( 5, iseed )
512 250 CONTINUE
513 b( n ) = dcmplx( one, one )
514 ELSE
515 DO 270 j = 1, n
516 DO 260 i = 3, min( n-j+1, kd+1 )
517 ab( i, j ) = zero
518 260 CONTINUE
519 IF( j.LT.n .AND. kd.GT.0 )
520 $ ab( 2, j ) = dcmplx( -one, -one )
521 ab( 1, j ) = tscal*zlarnd( 5, iseed )
522 270 CONTINUE
523 b( 1 ) = dcmplx( one, one )
524 END IF
525*
526 ELSE IF( imat.EQ.15 ) THEN
527*
528* Type 15: One zero diagonal element.
529*
530 iy = n / 2 + 1
531 IF( upper ) THEN
532 DO 280 j = 1, n
533 lenj = min( j, kd+1 )
534 CALL zlarnv( 4, iseed, lenj, ab( kd+2-lenj, j ) )
535 IF( j.NE.iy ) THEN
536 ab( kd+1, j ) = zlarnd( 5, iseed )*two
537 ELSE
538 ab( kd+1, j ) = zero
539 END IF
540 280 CONTINUE
541 ELSE
542 DO 290 j = 1, n
543 lenj = min( n-j+1, kd+1 )
544 CALL zlarnv( 4, iseed, lenj, ab( 1, j ) )
545 IF( j.NE.iy ) THEN
546 ab( 1, j ) = zlarnd( 5, iseed )*two
547 ELSE
548 ab( 1, j ) = zero
549 END IF
550 290 CONTINUE
551 END IF
552 CALL zlarnv( 2, iseed, n, b )
553 CALL zdscal( n, two, b, 1 )
554*
555 ELSE IF( imat.EQ.16 ) THEN
556*
557* Type 16: Make the offdiagonal elements large to cause overflow
558* when adding a column of T. In the non-transposed case, the
559* matrix is constructed to cause overflow when adding a column in
560* every other step.
561*
562 tscal = unfl / ulp
563 tscal = ( one-ulp ) / tscal
564 DO 310 j = 1, n
565 DO 300 i = 1, kd + 1
566 ab( i, j ) = zero
567 300 CONTINUE
568 310 CONTINUE
569 texp = one
570 IF( kd.GT.0 ) THEN
571 IF( upper ) THEN
572 DO 330 j = n, 1, -kd
573 DO 320 i = j, max( 1, j-kd+1 ), -2
574 ab( 1+( j-i ), i ) = -tscal / dble( kd+2 )
575 ab( kd+1, i ) = one
576 b( i ) = texp*( one-ulp )
577 IF( i.GT.max( 1, j-kd+1 ) ) THEN
578 ab( 2+( j-i ), i-1 ) = -( tscal / dble( kd+2 ) )
579 $ / dble( kd+3 )
580 ab( kd+1, i-1 ) = one
581 b( i-1 ) = texp*dble( ( kd+1 )*( kd+1 )+kd )
582 END IF
583 texp = texp*two
584 320 CONTINUE
585 b( max( 1, j-kd+1 ) ) = ( dble( kd+2 ) /
586 $ dble( kd+3 ) )*tscal
587 330 CONTINUE
588 ELSE
589 DO 350 j = 1, n, kd
590 texp = one
591 lenj = min( kd+1, n-j+1 )
592 DO 340 i = j, min( n, j+kd-1 ), 2
593 ab( lenj-( i-j ), j ) = -tscal / dble( kd+2 )
594 ab( 1, j ) = one
595 b( j ) = texp*( one-ulp )
596 IF( i.LT.min( n, j+kd-1 ) ) THEN
597 ab( lenj-( i-j+1 ), i+1 ) = -( tscal /
598 $ dble( kd+2 ) ) / dble( kd+3 )
599 ab( 1, i+1 ) = one
600 b( i+1 ) = texp*dble( ( kd+1 )*( kd+1 )+kd )
601 END IF
602 texp = texp*two
603 340 CONTINUE
604 b( min( n, j+kd-1 ) ) = ( dble( kd+2 ) /
605 $ dble( kd+3 ) )*tscal
606 350 CONTINUE
607 END IF
608 END IF
609*
610 ELSE IF( imat.EQ.17 ) THEN
611*
612* Type 17: Generate a unit triangular matrix with elements
613* between -1 and 1, and make the right hand side large so that it
614* requires scaling.
615*
616 IF( upper ) THEN
617 DO 360 j = 1, n
618 lenj = min( j-1, kd )
619 CALL zlarnv( 4, iseed, lenj, ab( kd+1-lenj, j ) )
620 ab( kd+1, j ) = dble( j )
621 360 CONTINUE
622 ELSE
623 DO 370 j = 1, n
624 lenj = min( n-j, kd )
625 IF( lenj.GT.0 )
626 $ CALL zlarnv( 4, iseed, lenj, ab( 2, j ) )
627 ab( 1, j ) = dble( j )
628 370 CONTINUE
629 END IF
630*
631* Set the right hand side so that the largest value is BIGNUM.
632*
633 CALL zlarnv( 2, iseed, n, b )
634 iy = izamax( n, b, 1 )
635 bnorm = abs( b( iy ) )
636 bscal = bignum / max( one, bnorm )
637 CALL zdscal( n, bscal, b, 1 )
638*
639 ELSE IF( imat.EQ.18 ) THEN
640*
641* Type 18: Generate a triangular matrix with elements between
642* BIGNUM/(KD+1) and BIGNUM so that at least one of the column
643* norms will exceed BIGNUM.
644* 1/3/91: ZLATBS no longer can handle this case
645*
646 tleft = bignum / dble( kd+1 )
647 tscal = bignum*( dble( kd+1 ) / dble( kd+2 ) )
648 IF( upper ) THEN
649 DO 390 j = 1, n
650 lenj = min( j, kd+1 )
651 CALL zlarnv( 5, iseed, lenj, ab( kd+2-lenj, j ) )
652 CALL dlarnv( 1, iseed, lenj, rwork( kd+2-lenj ) )
653 DO 380 i = kd + 2 - lenj, kd + 1
654 ab( i, j ) = ab( i, j )*( tleft+rwork( i )*tscal )
655 380 CONTINUE
656 390 CONTINUE
657 ELSE
658 DO 410 j = 1, n
659 lenj = min( n-j+1, kd+1 )
660 CALL zlarnv( 5, iseed, lenj, ab( 1, j ) )
661 CALL dlarnv( 1, iseed, lenj, rwork )
662 DO 400 i = 1, lenj
663 ab( i, j ) = ab( i, j )*( tleft+rwork( i )*tscal )
664 400 CONTINUE
665 410 CONTINUE
666 END IF
667 CALL zlarnv( 2, iseed, n, b )
668 CALL zdscal( n, two, b, 1 )
669 END IF
670*
671* Flip the matrix if the transpose will be used.
672*
673 IF( .NOT.lsame( trans, 'N' ) ) THEN
674 IF( upper ) THEN
675 DO 420 j = 1, n / 2
676 lenj = min( n-2*j+1, kd+1 )
677 CALL zswap( lenj, ab( kd+1, j ), ldab-1,
678 $ ab( kd+2-lenj, n-j+1 ), -1 )
679 420 CONTINUE
680 ELSE
681 DO 430 j = 1, n / 2
682 lenj = min( n-2*j+1, kd+1 )
683 CALL zswap( lenj, ab( 1, j ), 1, ab( lenj, n-j+2-lenj ),
684 $ -ldab+1 )
685 430 CONTINUE
686 END IF
687 END IF
688*
689 RETURN
690*
691* End of ZLATTB
692*

◆ zlattp()

subroutine zlattp ( integer imat,
character uplo,
character trans,
character diag,
integer, dimension( 4 ) iseed,
integer n,
complex*16, dimension( * ) ap,
complex*16, dimension( * ) b,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZLATTP

Purpose:
!>
!> ZLATTP generates a triangular test matrix in packed storage.
!> IMAT and UPLO uniquely specify the properties of the test matrix,
!> which is returned in the array AP.
!>
Parameters
[in]IMAT
!>          IMAT is INTEGER
!>          An integer key describing which matrix to generate for this
!>          path.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A will be upper or lower
!>          triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies whether the matrix or its transpose will be used.
!>          = 'N':  No transpose
!>          = 'T':  Transpose
!>          = 'C':  Conjugate transpose
!>
[out]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          The seed vector for the random number generator (used in
!>          ZLATMS).  Modified on exit.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix to be generated.
!>
[out]AP
!>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The upper or lower triangular matrix A, packed columnwise in
!>          a linear array.  The j-th column of A is stored in the array
!>          AP as follows:
!>          if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L',
!>             AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
!>
[out]B
!>          B is COMPLEX*16 array, dimension (N)
!>          The right hand side vector, if IMAT > 10.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 129 of file zlattp.f.

131*
132* -- LAPACK test routine --
133* -- LAPACK is a software package provided by Univ. of Tennessee, --
134* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
135*
136* .. Scalar Arguments ..
137 CHARACTER DIAG, TRANS, UPLO
138 INTEGER IMAT, INFO, N
139* ..
140* .. Array Arguments ..
141 INTEGER ISEED( 4 )
142 DOUBLE PRECISION RWORK( * )
143 COMPLEX*16 AP( * ), B( * ), WORK( * )
144* ..
145*
146* =====================================================================
147*
148* .. Parameters ..
149 DOUBLE PRECISION ONE, TWO, ZERO
150 parameter( one = 1.0d+0, two = 2.0d+0, zero = 0.0d+0 )
151* ..
152* .. Local Scalars ..
153 LOGICAL UPPER
154 CHARACTER DIST, PACKIT, TYPE
155 CHARACTER*3 PATH
156 INTEGER I, IY, J, JC, JCNEXT, JCOUNT, JJ, JL, JR, JX,
157 $ KL, KU, MODE
158 DOUBLE PRECISION ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, REXP,
159 $ SFAC, SMLNUM, T, TEXP, TLEFT, TSCAL, ULP, UNFL,
160 $ X, Y, Z
161 COMPLEX*16 CTEMP, PLUS1, PLUS2, RA, RB, S, STAR1
162* ..
163* .. External Functions ..
164 LOGICAL LSAME
165 INTEGER IZAMAX
166 DOUBLE PRECISION DLAMCH
167 COMPLEX*16 ZLARND
168 EXTERNAL lsame, izamax, dlamch, zlarnd
169* ..
170* .. External Subroutines ..
171 EXTERNAL dlabad, dlarnv, zdscal, zlarnv, zlatb4, zlatms,
172 $ zrot, zrotg
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC abs, dble, dcmplx, dconjg, max, sqrt
176* ..
177* .. Executable Statements ..
178*
179 path( 1: 1 ) = 'Zomplex precision'
180 path( 2: 3 ) = 'TP'
181 unfl = dlamch( 'Safe minimum' )
182 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
183 smlnum = unfl
184 bignum = ( one-ulp ) / smlnum
185 CALL dlabad( smlnum, bignum )
186 IF( ( imat.GE.7 .AND. imat.LE.10 ) .OR. imat.EQ.18 ) THEN
187 diag = 'U'
188 ELSE
189 diag = 'N'
190 END IF
191 info = 0
192*
193* Quick return if N.LE.0.
194*
195 IF( n.LE.0 )
196 $ RETURN
197*
198* Call ZLATB4 to set parameters for CLATMS.
199*
200 upper = lsame( uplo, 'U' )
201 IF( upper ) THEN
202 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
203 $ CNDNUM, DIST )
204 packit = 'C'
205 ELSE
206 CALL zlatb4( path, -imat, n, n, TYPE, KL, KU, ANORM, MODE,
207 $ CNDNUM, DIST )
208 packit = 'R'
209 END IF
210*
211* IMAT <= 6: Non-unit triangular matrix
212*
213 IF( imat.LE.6 ) THEN
214 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE, CNDNUM,
215 $ ANORM, KL, KU, PACKIT, AP, N, WORK, INFO )
216*
217* IMAT > 6: Unit triangular matrix
218* The diagonal is deliberately set to something other than 1.
219*
220* IMAT = 7: Matrix is the identity
221*
222 ELSE IF( imat.EQ.7 ) THEN
223 IF( upper ) THEN
224 jc = 1
225 DO 20 j = 1, n
226 DO 10 i = 1, j - 1
227 ap( jc+i-1 ) = zero
228 10 CONTINUE
229 ap( jc+j-1 ) = j
230 jc = jc + j
231 20 CONTINUE
232 ELSE
233 jc = 1
234 DO 40 j = 1, n
235 ap( jc ) = j
236 DO 30 i = j + 1, n
237 ap( jc+i-j ) = zero
238 30 CONTINUE
239 jc = jc + n - j + 1
240 40 CONTINUE
241 END IF
242*
243* IMAT > 7: Non-trivial unit triangular matrix
244*
245* Generate a unit triangular matrix T with condition CNDNUM by
246* forming a triangular matrix with known singular values and
247* filling in the zero entries with Givens rotations.
248*
249 ELSE IF( imat.LE.10 ) THEN
250 IF( upper ) THEN
251 jc = 0
252 DO 60 j = 1, n
253 DO 50 i = 1, j - 1
254 ap( jc+i ) = zero
255 50 CONTINUE
256 ap( jc+j ) = j
257 jc = jc + j
258 60 CONTINUE
259 ELSE
260 jc = 1
261 DO 80 j = 1, n
262 ap( jc ) = j
263 DO 70 i = j + 1, n
264 ap( jc+i-j ) = zero
265 70 CONTINUE
266 jc = jc + n - j + 1
267 80 CONTINUE
268 END IF
269*
270* Since the trace of a unit triangular matrix is 1, the product
271* of its singular values must be 1. Let s = sqrt(CNDNUM),
272* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2.
273* The following triangular matrix has singular values s, 1, 1,
274* ..., 1, 1/s:
275*
276* 1 y y y ... y y z
277* 1 0 0 ... 0 0 y
278* 1 0 ... 0 0 y
279* . ... . . .
280* . . . .
281* 1 0 y
282* 1 y
283* 1
284*
285* To fill in the zeros, we first multiply by a matrix with small
286* condition number of the form
287*
288* 1 0 0 0 0 ...
289* 1 + * 0 0 ...
290* 1 + 0 0 0
291* 1 + * 0 0
292* 1 + 0 0
293* ...
294* 1 + 0
295* 1 0
296* 1
297*
298* Each element marked with a '*' is formed by taking the product
299* of the adjacent elements marked with '+'. The '*'s can be
300* chosen freely, and the '+'s are chosen so that the inverse of
301* T will have elements of the same magnitude as T. If the *'s in
302* both T and inv(T) have small magnitude, T is well conditioned.
303* The two offdiagonals of T are stored in WORK.
304*
305* The product of these two matrices has the form
306*
307* 1 y y y y y . y y z
308* 1 + * 0 0 . 0 0 y
309* 1 + 0 0 . 0 0 y
310* 1 + * . . . .
311* 1 + . . . .
312* . . . . .
313* . . . .
314* 1 + y
315* 1 y
316* 1
317*
318* Now we multiply by Givens rotations, using the fact that
319*
320* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ]
321* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ]
322* and
323* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ]
324* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ]
325*
326* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4).
327*
328 star1 = 0.25d0*zlarnd( 5, iseed )
329 sfac = 0.5d0
330 plus1 = sfac*zlarnd( 5, iseed )
331 DO 90 j = 1, n, 2
332 plus2 = star1 / plus1
333 work( j ) = plus1
334 work( n+j ) = star1
335 IF( j+1.LE.n ) THEN
336 work( j+1 ) = plus2
337 work( n+j+1 ) = zero
338 plus1 = star1 / plus2
339 rexp = zlarnd( 2, iseed )
340 IF( rexp.LT.zero ) THEN
341 star1 = -sfac**( one-rexp )*zlarnd( 5, iseed )
342 ELSE
343 star1 = sfac**( one+rexp )*zlarnd( 5, iseed )
344 END IF
345 END IF
346 90 CONTINUE
347*
348 x = sqrt( cndnum ) - one / sqrt( cndnum )
349 IF( n.GT.2 ) THEN
350 y = sqrt( two / dble( n-2 ) )*x
351 ELSE
352 y = zero
353 END IF
354 z = x*x
355*
356 IF( upper ) THEN
357*
358* Set the upper triangle of A with a unit triangular matrix
359* of known condition number.
360*
361 jc = 1
362 DO 100 j = 2, n
363 ap( jc+1 ) = y
364 IF( j.GT.2 )
365 $ ap( jc+j-1 ) = work( j-2 )
366 IF( j.GT.3 )
367 $ ap( jc+j-2 ) = work( n+j-3 )
368 jc = jc + j
369 100 CONTINUE
370 jc = jc - n
371 ap( jc+1 ) = z
372 DO 110 j = 2, n - 1
373 ap( jc+j ) = y
374 110 CONTINUE
375 ELSE
376*
377* Set the lower triangle of A with a unit triangular matrix
378* of known condition number.
379*
380 DO 120 i = 2, n - 1
381 ap( i ) = y
382 120 CONTINUE
383 ap( n ) = z
384 jc = n + 1
385 DO 130 j = 2, n - 1
386 ap( jc+1 ) = work( j-1 )
387 IF( j.LT.n-1 )
388 $ ap( jc+2 ) = work( n+j-1 )
389 ap( jc+n-j ) = y
390 jc = jc + n - j + 1
391 130 CONTINUE
392 END IF
393*
394* Fill in the zeros using Givens rotations
395*
396 IF( upper ) THEN
397 jc = 1
398 DO 150 j = 1, n - 1
399 jcnext = jc + j
400 ra = ap( jcnext+j-1 )
401 rb = two
402 CALL zrotg( ra, rb, c, s )
403*
404* Multiply by [ c s; -conjg(s) c] on the left.
405*
406 IF( n.GT.j+1 ) THEN
407 jx = jcnext + j
408 DO 140 i = j + 2, n
409 ctemp = c*ap( jx+j ) + s*ap( jx+j+1 )
410 ap( jx+j+1 ) = -dconjg( s )*ap( jx+j ) +
411 $ c*ap( jx+j+1 )
412 ap( jx+j ) = ctemp
413 jx = jx + i
414 140 CONTINUE
415 END IF
416*
417* Multiply by [-c -s; conjg(s) -c] on the right.
418*
419 IF( j.GT.1 )
420 $ CALL zrot( j-1, ap( jcnext ), 1, ap( jc ), 1, -c, -s )
421*
422* Negate A(J,J+1).
423*
424 ap( jcnext+j-1 ) = -ap( jcnext+j-1 )
425 jc = jcnext
426 150 CONTINUE
427 ELSE
428 jc = 1
429 DO 170 j = 1, n - 1
430 jcnext = jc + n - j + 1
431 ra = ap( jc+1 )
432 rb = two
433 CALL zrotg( ra, rb, c, s )
434 s = dconjg( s )
435*
436* Multiply by [ c -s; conjg(s) c] on the right.
437*
438 IF( n.GT.j+1 )
439 $ CALL zrot( n-j-1, ap( jcnext+1 ), 1, ap( jc+2 ), 1, c,
440 $ -s )
441*
442* Multiply by [-c s; -conjg(s) -c] on the left.
443*
444 IF( j.GT.1 ) THEN
445 jx = 1
446 DO 160 i = 1, j - 1
447 ctemp = -c*ap( jx+j-i ) + s*ap( jx+j-i+1 )
448 ap( jx+j-i+1 ) = -dconjg( s )*ap( jx+j-i ) -
449 $ c*ap( jx+j-i+1 )
450 ap( jx+j-i ) = ctemp
451 jx = jx + n - i + 1
452 160 CONTINUE
453 END IF
454*
455* Negate A(J+1,J).
456*
457 ap( jc+1 ) = -ap( jc+1 )
458 jc = jcnext
459 170 CONTINUE
460 END IF
461*
462* IMAT > 10: Pathological test cases. These triangular matrices
463* are badly scaled or badly conditioned, so when used in solving a
464* triangular system they may cause overflow in the solution vector.
465*
466 ELSE IF( imat.EQ.11 ) THEN
467*
468* Type 11: Generate a triangular matrix with elements between
469* -1 and 1. Give the diagonal norm 2 to make it well-conditioned.
470* Make the right hand side large so that it requires scaling.
471*
472 IF( upper ) THEN
473 jc = 1
474 DO 180 j = 1, n
475 CALL zlarnv( 4, iseed, j-1, ap( jc ) )
476 ap( jc+j-1 ) = zlarnd( 5, iseed )*two
477 jc = jc + j
478 180 CONTINUE
479 ELSE
480 jc = 1
481 DO 190 j = 1, n
482 IF( j.LT.n )
483 $ CALL zlarnv( 4, iseed, n-j, ap( jc+1 ) )
484 ap( jc ) = zlarnd( 5, iseed )*two
485 jc = jc + n - j + 1
486 190 CONTINUE
487 END IF
488*
489* Set the right hand side so that the largest value is BIGNUM.
490*
491 CALL zlarnv( 2, iseed, n, b )
492 iy = izamax( n, b, 1 )
493 bnorm = abs( b( iy ) )
494 bscal = bignum / max( one, bnorm )
495 CALL zdscal( n, bscal, b, 1 )
496*
497 ELSE IF( imat.EQ.12 ) THEN
498*
499* Type 12: Make the first diagonal element in the solve small to
500* cause immediate overflow when dividing by T(j,j).
501* In type 12, the offdiagonal elements are small (CNORM(j) < 1).
502*
503 CALL zlarnv( 2, iseed, n, b )
504 tscal = one / max( one, dble( n-1 ) )
505 IF( upper ) THEN
506 jc = 1
507 DO 200 j = 1, n
508 CALL zlarnv( 4, iseed, j-1, ap( jc ) )
509 CALL zdscal( j-1, tscal, ap( jc ), 1 )
510 ap( jc+j-1 ) = zlarnd( 5, iseed )
511 jc = jc + j
512 200 CONTINUE
513 ap( n*( n+1 ) / 2 ) = smlnum*ap( n*( n+1 ) / 2 )
514 ELSE
515 jc = 1
516 DO 210 j = 1, n
517 CALL zlarnv( 2, iseed, n-j, ap( jc+1 ) )
518 CALL zdscal( n-j, tscal, ap( jc+1 ), 1 )
519 ap( jc ) = zlarnd( 5, iseed )
520 jc = jc + n - j + 1
521 210 CONTINUE
522 ap( 1 ) = smlnum*ap( 1 )
523 END IF
524*
525 ELSE IF( imat.EQ.13 ) THEN
526*
527* Type 13: Make the first diagonal element in the solve small to
528* cause immediate overflow when dividing by T(j,j).
529* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1).
530*
531 CALL zlarnv( 2, iseed, n, b )
532 IF( upper ) THEN
533 jc = 1
534 DO 220 j = 1, n
535 CALL zlarnv( 4, iseed, j-1, ap( jc ) )
536 ap( jc+j-1 ) = zlarnd( 5, iseed )
537 jc = jc + j
538 220 CONTINUE
539 ap( n*( n+1 ) / 2 ) = smlnum*ap( n*( n+1 ) / 2 )
540 ELSE
541 jc = 1
542 DO 230 j = 1, n
543 CALL zlarnv( 4, iseed, n-j, ap( jc+1 ) )
544 ap( jc ) = zlarnd( 5, iseed )
545 jc = jc + n - j + 1
546 230 CONTINUE
547 ap( 1 ) = smlnum*ap( 1 )
548 END IF
549*
550 ELSE IF( imat.EQ.14 ) THEN
551*
552* Type 14: T is diagonal with small numbers on the diagonal to
553* make the growth factor underflow, but a small right hand side
554* chosen so that the solution does not overflow.
555*
556 IF( upper ) THEN
557 jcount = 1
558 jc = ( n-1 )*n / 2 + 1
559 DO 250 j = n, 1, -1
560 DO 240 i = 1, j - 1
561 ap( jc+i-1 ) = zero
562 240 CONTINUE
563 IF( jcount.LE.2 ) THEN
564 ap( jc+j-1 ) = smlnum*zlarnd( 5, iseed )
565 ELSE
566 ap( jc+j-1 ) = zlarnd( 5, iseed )
567 END IF
568 jcount = jcount + 1
569 IF( jcount.GT.4 )
570 $ jcount = 1
571 jc = jc - j + 1
572 250 CONTINUE
573 ELSE
574 jcount = 1
575 jc = 1
576 DO 270 j = 1, n
577 DO 260 i = j + 1, n
578 ap( jc+i-j ) = zero
579 260 CONTINUE
580 IF( jcount.LE.2 ) THEN
581 ap( jc ) = smlnum*zlarnd( 5, iseed )
582 ELSE
583 ap( jc ) = zlarnd( 5, iseed )
584 END IF
585 jcount = jcount + 1
586 IF( jcount.GT.4 )
587 $ jcount = 1
588 jc = jc + n - j + 1
589 270 CONTINUE
590 END IF
591*
592* Set the right hand side alternately zero and small.
593*
594 IF( upper ) THEN
595 b( 1 ) = zero
596 DO 280 i = n, 2, -2
597 b( i ) = zero
598 b( i-1 ) = smlnum*zlarnd( 5, iseed )
599 280 CONTINUE
600 ELSE
601 b( n ) = zero
602 DO 290 i = 1, n - 1, 2
603 b( i ) = zero
604 b( i+1 ) = smlnum*zlarnd( 5, iseed )
605 290 CONTINUE
606 END IF
607*
608 ELSE IF( imat.EQ.15 ) THEN
609*
610* Type 15: Make the diagonal elements small to cause gradual
611* overflow when dividing by T(j,j). To control the amount of
612* scaling needed, the matrix is bidiagonal.
613*
614 texp = one / max( one, dble( n-1 ) )
615 tscal = smlnum**texp
616 CALL zlarnv( 4, iseed, n, b )
617 IF( upper ) THEN
618 jc = 1
619 DO 310 j = 1, n
620 DO 300 i = 1, j - 2
621 ap( jc+i-1 ) = zero
622 300 CONTINUE
623 IF( j.GT.1 )
624 $ ap( jc+j-2 ) = dcmplx( -one, -one )
625 ap( jc+j-1 ) = tscal*zlarnd( 5, iseed )
626 jc = jc + j
627 310 CONTINUE
628 b( n ) = dcmplx( one, one )
629 ELSE
630 jc = 1
631 DO 330 j = 1, n
632 DO 320 i = j + 2, n
633 ap( jc+i-j ) = zero
634 320 CONTINUE
635 IF( j.LT.n )
636 $ ap( jc+1 ) = dcmplx( -one, -one )
637 ap( jc ) = tscal*zlarnd( 5, iseed )
638 jc = jc + n - j + 1
639 330 CONTINUE
640 b( 1 ) = dcmplx( one, one )
641 END IF
642*
643 ELSE IF( imat.EQ.16 ) THEN
644*
645* Type 16: One zero diagonal element.
646*
647 iy = n / 2 + 1
648 IF( upper ) THEN
649 jc = 1
650 DO 340 j = 1, n
651 CALL zlarnv( 4, iseed, j, ap( jc ) )
652 IF( j.NE.iy ) THEN
653 ap( jc+j-1 ) = zlarnd( 5, iseed )*two
654 ELSE
655 ap( jc+j-1 ) = zero
656 END IF
657 jc = jc + j
658 340 CONTINUE
659 ELSE
660 jc = 1
661 DO 350 j = 1, n
662 CALL zlarnv( 4, iseed, n-j+1, ap( jc ) )
663 IF( j.NE.iy ) THEN
664 ap( jc ) = zlarnd( 5, iseed )*two
665 ELSE
666 ap( jc ) = zero
667 END IF
668 jc = jc + n - j + 1
669 350 CONTINUE
670 END IF
671 CALL zlarnv( 2, iseed, n, b )
672 CALL zdscal( n, two, b, 1 )
673*
674 ELSE IF( imat.EQ.17 ) THEN
675*
676* Type 17: Make the offdiagonal elements large to cause overflow
677* when adding a column of T. In the non-transposed case, the
678* matrix is constructed to cause overflow when adding a column in
679* every other step.
680*
681 tscal = unfl / ulp
682 tscal = ( one-ulp ) / tscal
683 DO 360 j = 1, n*( n+1 ) / 2
684 ap( j ) = zero
685 360 CONTINUE
686 texp = one
687 IF( upper ) THEN
688 jc = ( n-1 )*n / 2 + 1
689 DO 370 j = n, 2, -2
690 ap( jc ) = -tscal / dble( n+1 )
691 ap( jc+j-1 ) = one
692 b( j ) = texp*( one-ulp )
693 jc = jc - j + 1
694 ap( jc ) = -( tscal / dble( n+1 ) ) / dble( n+2 )
695 ap( jc+j-2 ) = one
696 b( j-1 ) = texp*dble( n*n+n-1 )
697 texp = texp*two
698 jc = jc - j + 2
699 370 CONTINUE
700 b( 1 ) = ( dble( n+1 ) / dble( n+2 ) )*tscal
701 ELSE
702 jc = 1
703 DO 380 j = 1, n - 1, 2
704 ap( jc+n-j ) = -tscal / dble( n+1 )
705 ap( jc ) = one
706 b( j ) = texp*( one-ulp )
707 jc = jc + n - j + 1
708 ap( jc+n-j-1 ) = -( tscal / dble( n+1 ) ) / dble( n+2 )
709 ap( jc ) = one
710 b( j+1 ) = texp*dble( n*n+n-1 )
711 texp = texp*two
712 jc = jc + n - j
713 380 CONTINUE
714 b( n ) = ( dble( n+1 ) / dble( n+2 ) )*tscal
715 END IF
716*
717 ELSE IF( imat.EQ.18 ) THEN
718*
719* Type 18: Generate a unit triangular matrix with elements
720* between -1 and 1, and make the right hand side large so that it
721* requires scaling.
722*
723 IF( upper ) THEN
724 jc = 1
725 DO 390 j = 1, n
726 CALL zlarnv( 4, iseed, j-1, ap( jc ) )
727 ap( jc+j-1 ) = zero
728 jc = jc + j
729 390 CONTINUE
730 ELSE
731 jc = 1
732 DO 400 j = 1, n
733 IF( j.LT.n )
734 $ CALL zlarnv( 4, iseed, n-j, ap( jc+1 ) )
735 ap( jc ) = zero
736 jc = jc + n - j + 1
737 400 CONTINUE
738 END IF
739*
740* Set the right hand side so that the largest value is BIGNUM.
741*
742 CALL zlarnv( 2, iseed, n, b )
743 iy = izamax( n, b, 1 )
744 bnorm = abs( b( iy ) )
745 bscal = bignum / max( one, bnorm )
746 CALL zdscal( n, bscal, b, 1 )
747*
748 ELSE IF( imat.EQ.19 ) THEN
749*
750* Type 19: Generate a triangular matrix with elements between
751* BIGNUM/(n-1) and BIGNUM so that at least one of the column
752* norms will exceed BIGNUM.
753* 1/3/91: ZLATPS no longer can handle this case
754*
755 tleft = bignum / max( one, dble( n-1 ) )
756 tscal = bignum*( dble( n-1 ) / max( one, dble( n ) ) )
757 IF( upper ) THEN
758 jc = 1
759 DO 420 j = 1, n
760 CALL zlarnv( 5, iseed, j, ap( jc ) )
761 CALL dlarnv( 1, iseed, j, rwork )
762 DO 410 i = 1, j
763 ap( jc+i-1 ) = ap( jc+i-1 )*( tleft+rwork( i )*tscal )
764 410 CONTINUE
765 jc = jc + j
766 420 CONTINUE
767 ELSE
768 jc = 1
769 DO 440 j = 1, n
770 CALL zlarnv( 5, iseed, n-j+1, ap( jc ) )
771 CALL dlarnv( 1, iseed, n-j+1, rwork )
772 DO 430 i = j, n
773 ap( jc+i-j ) = ap( jc+i-j )*
774 $ ( tleft+rwork( i-j+1 )*tscal )
775 430 CONTINUE
776 jc = jc + n - j + 1
777 440 CONTINUE
778 END IF
779 CALL zlarnv( 2, iseed, n, b )
780 CALL zdscal( n, two, b, 1 )
781 END IF
782*
783* Flip the matrix across its counter-diagonal if the transpose will
784* be used.
785*
786 IF( .NOT.lsame( trans, 'N' ) ) THEN
787 IF( upper ) THEN
788 jj = 1
789 jr = n*( n+1 ) / 2
790 DO 460 j = 1, n / 2
791 jl = jj
792 DO 450 i = j, n - j
793 t = ap( jr-i+j )
794 ap( jr-i+j ) = ap( jl )
795 ap( jl ) = t
796 jl = jl + i
797 450 CONTINUE
798 jj = jj + j + 1
799 jr = jr - ( n-j+1 )
800 460 CONTINUE
801 ELSE
802 jl = 1
803 jj = n*( n+1 ) / 2
804 DO 480 j = 1, n / 2
805 jr = jj
806 DO 470 i = j, n - j
807 t = ap( jl+i-j )
808 ap( jl+i-j ) = ap( jr )
809 ap( jr ) = t
810 jr = jr - i
811 470 CONTINUE
812 jl = jl + n - j + 1
813 jj = jj - j - 1
814 480 CONTINUE
815 END IF
816 END IF
817*
818 RETURN
819*
820* End of ZLATTP
821*
zrot
subroutine zrot(n, cx, incx, cy, incy, c, s)
ZROT applies a plane rotation with real cosine and complex sine to a pair of complex vectors.
Definition zrot.f:103
zrotg
subroutine zrotg(a, b, c, s)
ZROTG
Definition zrotg.f90:91

◆ zlattr()

subroutine zlattr ( integer imat,
character uplo,
character trans,
character diag,
integer, dimension( 4 ) iseed,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) b,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
integer info )

ZLATTR

Purpose:
!>
!> ZLATTR generates a triangular test matrix in 2-dimensional storage.
!> IMAT and UPLO uniquely specify the properties of the test matrix,
!> which is returned in the array A.
!>
Parameters
[in]IMAT
!>          IMAT is INTEGER
!>          An integer key describing which matrix to generate for this
!>          path.
!>
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A will be upper or lower
!>          triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies whether the matrix or its transpose will be used.
!>          = 'N':  No transpose
!>          = 'T':  Transpose
!>          = 'C':  Conjugate transpose
!>
[out]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in,out]ISEED
!>          ISEED is INTEGER array, dimension (4)
!>          The seed vector for the random number generator (used in
!>          ZLATMS).  Modified on exit.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix to be generated.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The triangular matrix A.  If UPLO = 'U', the leading N x N
!>          upper triangular part of the array A contains the upper
!>          triangular matrix, and the strictly lower triangular part of
!>          A is not referenced.  If UPLO = 'L', the leading N x N lower
!>          triangular part of the array A contains the lower triangular
!>          matrix and the strictly upper triangular part of A is not
!>          referenced.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]B
!>          B is COMPLEX*16 array, dimension (N)
!>          The right hand side vector, if IMAT > 10.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 136 of file zlattr.f.

138*
139* -- LAPACK test routine --
140* -- LAPACK is a software package provided by Univ. of Tennessee, --
141* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
142*
143* .. Scalar Arguments ..
144 CHARACTER DIAG, TRANS, UPLO
145 INTEGER IMAT, INFO, LDA, N
146* ..
147* .. Array Arguments ..
148 INTEGER ISEED( 4 )
149 DOUBLE PRECISION RWORK( * )
150 COMPLEX*16 A( LDA, * ), B( * ), WORK( * )
151* ..
152*
153* =====================================================================
154*
155* .. Parameters ..
156 DOUBLE PRECISION ONE, TWO, ZERO
157 parameter( one = 1.0d+0, two = 2.0d+0, zero = 0.0d+0 )
158* ..
159* .. Local Scalars ..
160 LOGICAL UPPER
161 CHARACTER DIST, TYPE
162 CHARACTER*3 PATH
163 INTEGER I, IY, J, JCOUNT, KL, KU, MODE
164 DOUBLE PRECISION ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, REXP,
165 $ SFAC, SMLNUM, TEXP, TLEFT, TSCAL, ULP, UNFL, X,
166 $ Y, Z
167 COMPLEX*16 PLUS1, PLUS2, RA, RB, S, STAR1
168* ..
169* .. External Functions ..
170 LOGICAL LSAME
171 INTEGER IZAMAX
172 DOUBLE PRECISION DLAMCH, DLARND
173 COMPLEX*16 ZLARND
174 EXTERNAL lsame, izamax, dlamch, dlarnd, zlarnd
175* ..
176* .. External Subroutines ..
177 EXTERNAL dlabad, dlarnv, zcopy, zdscal, zlarnv, zlatb4,
178 $ zlatms, zrot, zrotg, zswap
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC abs, dble, dcmplx, dconjg, max, sqrt
182* ..
183* .. Executable Statements ..
184*
185 path( 1: 1 ) = 'Zomplex precision'
186 path( 2: 3 ) = 'TR'
187 unfl = dlamch( 'Safe minimum' )
188 ulp = dlamch( 'Epsilon' )*dlamch( 'Base' )
189 smlnum = unfl
190 bignum = ( one-ulp ) / smlnum
191 CALL dlabad( smlnum, bignum )
192 IF( ( imat.GE.7 .AND. imat.LE.10 ) .OR. imat.EQ.18 ) THEN
193 diag = 'U'
194 ELSE
195 diag = 'N'
196 END IF
197 info = 0
198*
199* Quick return if N.LE.0.
200*
201 IF( n.LE.0 )
202 $ RETURN
203*
204* Call ZLATB4 to set parameters for CLATMS.
205*
206 upper = lsame( uplo, 'U' )
207 IF( upper ) THEN
208 CALL zlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
209 $ CNDNUM, DIST )
210 ELSE
211 CALL zlatb4( path, -imat, n, n, TYPE, KL, KU, ANORM, MODE,
212 $ CNDNUM, DIST )
213 END IF
214*
215* IMAT <= 6: Non-unit triangular matrix
216*
217 IF( imat.LE.6 ) THEN
218 CALL zlatms( n, n, dist, iseed, TYPE, RWORK, MODE, CNDNUM,
219 $ ANORM, KL, KU, 'No packing', A, LDA, WORK, INFO )
220*
221* IMAT > 6: Unit triangular matrix
222* The diagonal is deliberately set to something other than 1.
223*
224* IMAT = 7: Matrix is the identity
225*
226 ELSE IF( imat.EQ.7 ) THEN
227 IF( upper ) THEN
228 DO 20 j = 1, n
229 DO 10 i = 1, j - 1
230 a( i, j ) = zero
231 10 CONTINUE
232 a( j, j ) = j
233 20 CONTINUE
234 ELSE
235 DO 40 j = 1, n
236 a( j, j ) = j
237 DO 30 i = j + 1, n
238 a( i, j ) = zero
239 30 CONTINUE
240 40 CONTINUE
241 END IF
242*
243* IMAT > 7: Non-trivial unit triangular matrix
244*
245* Generate a unit triangular matrix T with condition CNDNUM by
246* forming a triangular matrix with known singular values and
247* filling in the zero entries with Givens rotations.
248*
249 ELSE IF( imat.LE.10 ) THEN
250 IF( upper ) THEN
251 DO 60 j = 1, n
252 DO 50 i = 1, j - 1
253 a( i, j ) = zero
254 50 CONTINUE
255 a( j, j ) = j
256 60 CONTINUE
257 ELSE
258 DO 80 j = 1, n
259 a( j, j ) = j
260 DO 70 i = j + 1, n
261 a( i, j ) = zero
262 70 CONTINUE
263 80 CONTINUE
264 END IF
265*
266* Since the trace of a unit triangular matrix is 1, the product
267* of its singular values must be 1. Let s = sqrt(CNDNUM),
268* x = sqrt(s) - 1/sqrt(s), y = sqrt(2/(n-2))*x, and z = x**2.
269* The following triangular matrix has singular values s, 1, 1,
270* ..., 1, 1/s:
271*
272* 1 y y y ... y y z
273* 1 0 0 ... 0 0 y
274* 1 0 ... 0 0 y
275* . ... . . .
276* . . . .
277* 1 0 y
278* 1 y
279* 1
280*
281* To fill in the zeros, we first multiply by a matrix with small
282* condition number of the form
283*
284* 1 0 0 0 0 ...
285* 1 + * 0 0 ...
286* 1 + 0 0 0
287* 1 + * 0 0
288* 1 + 0 0
289* ...
290* 1 + 0
291* 1 0
292* 1
293*
294* Each element marked with a '*' is formed by taking the product
295* of the adjacent elements marked with '+'. The '*'s can be
296* chosen freely, and the '+'s are chosen so that the inverse of
297* T will have elements of the same magnitude as T. If the *'s in
298* both T and inv(T) have small magnitude, T is well conditioned.
299* The two offdiagonals of T are stored in WORK.
300*
301* The product of these two matrices has the form
302*
303* 1 y y y y y . y y z
304* 1 + * 0 0 . 0 0 y
305* 1 + 0 0 . 0 0 y
306* 1 + * . . . .
307* 1 + . . . .
308* . . . . .
309* . . . .
310* 1 + y
311* 1 y
312* 1
313*
314* Now we multiply by Givens rotations, using the fact that
315*
316* [ c s ] [ 1 w ] [ -c -s ] = [ 1 -w ]
317* [ -s c ] [ 0 1 ] [ s -c ] [ 0 1 ]
318* and
319* [ -c -s ] [ 1 0 ] [ c s ] = [ 1 0 ]
320* [ s -c ] [ w 1 ] [ -s c ] [ -w 1 ]
321*
322* where c = w / sqrt(w**2+4) and s = 2 / sqrt(w**2+4).
323*
324 star1 = 0.25d0*zlarnd( 5, iseed )
325 sfac = 0.5d0
326 plus1 = sfac*zlarnd( 5, iseed )
327 DO 90 j = 1, n, 2
328 plus2 = star1 / plus1
329 work( j ) = plus1
330 work( n+j ) = star1
331 IF( j+1.LE.n ) THEN
332 work( j+1 ) = plus2
333 work( n+j+1 ) = zero
334 plus1 = star1 / plus2
335 rexp = dlarnd( 2, iseed )
336 IF( rexp.LT.zero ) THEN
337 star1 = -sfac**( one-rexp )*zlarnd( 5, iseed )
338 ELSE
339 star1 = sfac**( one+rexp )*zlarnd( 5, iseed )
340 END IF
341 END IF
342 90 CONTINUE
343*
344 x = sqrt( cndnum ) - 1 / sqrt( cndnum )
345 IF( n.GT.2 ) THEN
346 y = sqrt( 2.d0 / ( n-2 ) )*x
347 ELSE
348 y = zero
349 END IF
350 z = x*x
351*
352 IF( upper ) THEN
353 IF( n.GT.3 ) THEN
354 CALL zcopy( n-3, work, 1, a( 2, 3 ), lda+1 )
355 IF( n.GT.4 )
356 $ CALL zcopy( n-4, work( n+1 ), 1, a( 2, 4 ), lda+1 )
357 END IF
358 DO 100 j = 2, n - 1
359 a( 1, j ) = y
360 a( j, n ) = y
361 100 CONTINUE
362 a( 1, n ) = z
363 ELSE
364 IF( n.GT.3 ) THEN
365 CALL zcopy( n-3, work, 1, a( 3, 2 ), lda+1 )
366 IF( n.GT.4 )
367 $ CALL zcopy( n-4, work( n+1 ), 1, a( 4, 2 ), lda+1 )
368 END IF
369 DO 110 j = 2, n - 1
370 a( j, 1 ) = y
371 a( n, j ) = y
372 110 CONTINUE
373 a( n, 1 ) = z
374 END IF
375*
376* Fill in the zeros using Givens rotations.
377*
378 IF( upper ) THEN
379 DO 120 j = 1, n - 1
380 ra = a( j, j+1 )
381 rb = 2.0d0
382 CALL zrotg( ra, rb, c, s )
383*
384* Multiply by [ c s; -conjg(s) c] on the left.
385*
386 IF( n.GT.j+1 )
387 $ CALL zrot( n-j-1, a( j, j+2 ), lda, a( j+1, j+2 ),
388 $ lda, c, s )
389*
390* Multiply by [-c -s; conjg(s) -c] on the right.
391*
392 IF( j.GT.1 )
393 $ CALL zrot( j-1, a( 1, j+1 ), 1, a( 1, j ), 1, -c, -s )
394*
395* Negate A(J,J+1).
396*
397 a( j, j+1 ) = -a( j, j+1 )
398 120 CONTINUE
399 ELSE
400 DO 130 j = 1, n - 1
401 ra = a( j+1, j )
402 rb = 2.0d0
403 CALL zrotg( ra, rb, c, s )
404 s = dconjg( s )
405*
406* Multiply by [ c -s; conjg(s) c] on the right.
407*
408 IF( n.GT.j+1 )
409 $ CALL zrot( n-j-1, a( j+2, j+1 ), 1, a( j+2, j ), 1, c,
410 $ -s )
411*
412* Multiply by [-c s; -conjg(s) -c] on the left.
413*
414 IF( j.GT.1 )
415 $ CALL zrot( j-1, a( j, 1 ), lda, a( j+1, 1 ), lda, -c,
416 $ s )
417*
418* Negate A(J+1,J).
419*
420 a( j+1, j ) = -a( j+1, j )
421 130 CONTINUE
422 END IF
423*
424* IMAT > 10: Pathological test cases. These triangular matrices
425* are badly scaled or badly conditioned, so when used in solving a
426* triangular system they may cause overflow in the solution vector.
427*
428 ELSE IF( imat.EQ.11 ) THEN
429*
430* Type 11: Generate a triangular matrix with elements between
431* -1 and 1. Give the diagonal norm 2 to make it well-conditioned.
432* Make the right hand side large so that it requires scaling.
433*
434 IF( upper ) THEN
435 DO 140 j = 1, n
436 CALL zlarnv( 4, iseed, j-1, a( 1, j ) )
437 a( j, j ) = zlarnd( 5, iseed )*two
438 140 CONTINUE
439 ELSE
440 DO 150 j = 1, n
441 IF( j.LT.n )
442 $ CALL zlarnv( 4, iseed, n-j, a( j+1, j ) )
443 a( j, j ) = zlarnd( 5, iseed )*two
444 150 CONTINUE
445 END IF
446*
447* Set the right hand side so that the largest value is BIGNUM.
448*
449 CALL zlarnv( 2, iseed, n, b )
450 iy = izamax( n, b, 1 )
451 bnorm = abs( b( iy ) )
452 bscal = bignum / max( one, bnorm )
453 CALL zdscal( n, bscal, b, 1 )
454*
455 ELSE IF( imat.EQ.12 ) THEN
456*
457* Type 12: Make the first diagonal element in the solve small to
458* cause immediate overflow when dividing by T(j,j).
459* In type 12, the offdiagonal elements are small (CNORM(j) < 1).
460*
461 CALL zlarnv( 2, iseed, n, b )
462 tscal = one / max( one, dble( n-1 ) )
463 IF( upper ) THEN
464 DO 160 j = 1, n
465 CALL zlarnv( 4, iseed, j-1, a( 1, j ) )
466 CALL zdscal( j-1, tscal, a( 1, j ), 1 )
467 a( j, j ) = zlarnd( 5, iseed )
468 160 CONTINUE
469 a( n, n ) = smlnum*a( n, n )
470 ELSE
471 DO 170 j = 1, n
472 IF( j.LT.n ) THEN
473 CALL zlarnv( 4, iseed, n-j, a( j+1, j ) )
474 CALL zdscal( n-j, tscal, a( j+1, j ), 1 )
475 END IF
476 a( j, j ) = zlarnd( 5, iseed )
477 170 CONTINUE
478 a( 1, 1 ) = smlnum*a( 1, 1 )
479 END IF
480*
481 ELSE IF( imat.EQ.13 ) THEN
482*
483* Type 13: Make the first diagonal element in the solve small to
484* cause immediate overflow when dividing by T(j,j).
485* In type 13, the offdiagonal elements are O(1) (CNORM(j) > 1).
486*
487 CALL zlarnv( 2, iseed, n, b )
488 IF( upper ) THEN
489 DO 180 j = 1, n
490 CALL zlarnv( 4, iseed, j-1, a( 1, j ) )
491 a( j, j ) = zlarnd( 5, iseed )
492 180 CONTINUE
493 a( n, n ) = smlnum*a( n, n )
494 ELSE
495 DO 190 j = 1, n
496 IF( j.LT.n )
497 $ CALL zlarnv( 4, iseed, n-j, a( j+1, j ) )
498 a( j, j ) = zlarnd( 5, iseed )
499 190 CONTINUE
500 a( 1, 1 ) = smlnum*a( 1, 1 )
501 END IF
502*
503 ELSE IF( imat.EQ.14 ) THEN
504*
505* Type 14: T is diagonal with small numbers on the diagonal to
506* make the growth factor underflow, but a small right hand side
507* chosen so that the solution does not overflow.
508*
509 IF( upper ) THEN
510 jcount = 1
511 DO 210 j = n, 1, -1
512 DO 200 i = 1, j - 1
513 a( i, j ) = zero
514 200 CONTINUE
515 IF( jcount.LE.2 ) THEN
516 a( j, j ) = smlnum*zlarnd( 5, iseed )
517 ELSE
518 a( j, j ) = zlarnd( 5, iseed )
519 END IF
520 jcount = jcount + 1
521 IF( jcount.GT.4 )
522 $ jcount = 1
523 210 CONTINUE
524 ELSE
525 jcount = 1
526 DO 230 j = 1, n
527 DO 220 i = j + 1, n
528 a( i, j ) = zero
529 220 CONTINUE
530 IF( jcount.LE.2 ) THEN
531 a( j, j ) = smlnum*zlarnd( 5, iseed )
532 ELSE
533 a( j, j ) = zlarnd( 5, iseed )
534 END IF
535 jcount = jcount + 1
536 IF( jcount.GT.4 )
537 $ jcount = 1
538 230 CONTINUE
539 END IF
540*
541* Set the right hand side alternately zero and small.
542*
543 IF( upper ) THEN
544 b( 1 ) = zero
545 DO 240 i = n, 2, -2
546 b( i ) = zero
547 b( i-1 ) = smlnum*zlarnd( 5, iseed )
548 240 CONTINUE
549 ELSE
550 b( n ) = zero
551 DO 250 i = 1, n - 1, 2
552 b( i ) = zero
553 b( i+1 ) = smlnum*zlarnd( 5, iseed )
554 250 CONTINUE
555 END IF
556*
557 ELSE IF( imat.EQ.15 ) THEN
558*
559* Type 15: Make the diagonal elements small to cause gradual
560* overflow when dividing by T(j,j). To control the amount of
561* scaling needed, the matrix is bidiagonal.
562*
563 texp = one / max( one, dble( n-1 ) )
564 tscal = smlnum**texp
565 CALL zlarnv( 4, iseed, n, b )
566 IF( upper ) THEN
567 DO 270 j = 1, n
568 DO 260 i = 1, j - 2
569 a( i, j ) = 0.d0
570 260 CONTINUE
571 IF( j.GT.1 )
572 $ a( j-1, j ) = dcmplx( -one, -one )
573 a( j, j ) = tscal*zlarnd( 5, iseed )
574 270 CONTINUE
575 b( n ) = dcmplx( one, one )
576 ELSE
577 DO 290 j = 1, n
578 DO 280 i = j + 2, n
579 a( i, j ) = 0.d0
580 280 CONTINUE
581 IF( j.LT.n )
582 $ a( j+1, j ) = dcmplx( -one, -one )
583 a( j, j ) = tscal*zlarnd( 5, iseed )
584 290 CONTINUE
585 b( 1 ) = dcmplx( one, one )
586 END IF
587*
588 ELSE IF( imat.EQ.16 ) THEN
589*
590* Type 16: One zero diagonal element.
591*
592 iy = n / 2 + 1
593 IF( upper ) THEN
594 DO 300 j = 1, n
595 CALL zlarnv( 4, iseed, j-1, a( 1, j ) )
596 IF( j.NE.iy ) THEN
597 a( j, j ) = zlarnd( 5, iseed )*two
598 ELSE
599 a( j, j ) = zero
600 END IF
601 300 CONTINUE
602 ELSE
603 DO 310 j = 1, n
604 IF( j.LT.n )
605 $ CALL zlarnv( 4, iseed, n-j, a( j+1, j ) )
606 IF( j.NE.iy ) THEN
607 a( j, j ) = zlarnd( 5, iseed )*two
608 ELSE
609 a( j, j ) = zero
610 END IF
611 310 CONTINUE
612 END IF
613 CALL zlarnv( 2, iseed, n, b )
614 CALL zdscal( n, two, b, 1 )
615*
616 ELSE IF( imat.EQ.17 ) THEN
617*
618* Type 17: Make the offdiagonal elements large to cause overflow
619* when adding a column of T. In the non-transposed case, the
620* matrix is constructed to cause overflow when adding a column in
621* every other step.
622*
623 tscal = unfl / ulp
624 tscal = ( one-ulp ) / tscal
625 DO 330 j = 1, n
626 DO 320 i = 1, n
627 a( i, j ) = 0.d0
628 320 CONTINUE
629 330 CONTINUE
630 texp = one
631 IF( upper ) THEN
632 DO 340 j = n, 2, -2
633 a( 1, j ) = -tscal / dble( n+1 )
634 a( j, j ) = one
635 b( j ) = texp*( one-ulp )
636 a( 1, j-1 ) = -( tscal / dble( n+1 ) ) / dble( n+2 )
637 a( j-1, j-1 ) = one
638 b( j-1 ) = texp*dble( n*n+n-1 )
639 texp = texp*2.d0
640 340 CONTINUE
641 b( 1 ) = ( dble( n+1 ) / dble( n+2 ) )*tscal
642 ELSE
643 DO 350 j = 1, n - 1, 2
644 a( n, j ) = -tscal / dble( n+1 )
645 a( j, j ) = one
646 b( j ) = texp*( one-ulp )
647 a( n, j+1 ) = -( tscal / dble( n+1 ) ) / dble( n+2 )
648 a( j+1, j+1 ) = one
649 b( j+1 ) = texp*dble( n*n+n-1 )
650 texp = texp*2.d0
651 350 CONTINUE
652 b( n ) = ( dble( n+1 ) / dble( n+2 ) )*tscal
653 END IF
654*
655 ELSE IF( imat.EQ.18 ) THEN
656*
657* Type 18: Generate a unit triangular matrix with elements
658* between -1 and 1, and make the right hand side large so that it
659* requires scaling.
660*
661 IF( upper ) THEN
662 DO 360 j = 1, n
663 CALL zlarnv( 4, iseed, j-1, a( 1, j ) )
664 a( j, j ) = zero
665 360 CONTINUE
666 ELSE
667 DO 370 j = 1, n
668 IF( j.LT.n )
669 $ CALL zlarnv( 4, iseed, n-j, a( j+1, j ) )
670 a( j, j ) = zero
671 370 CONTINUE
672 END IF
673*
674* Set the right hand side so that the largest value is BIGNUM.
675*
676 CALL zlarnv( 2, iseed, n, b )
677 iy = izamax( n, b, 1 )
678 bnorm = abs( b( iy ) )
679 bscal = bignum / max( one, bnorm )
680 CALL zdscal( n, bscal, b, 1 )
681*
682 ELSE IF( imat.EQ.19 ) THEN
683*
684* Type 19: Generate a triangular matrix with elements between
685* BIGNUM/(n-1) and BIGNUM so that at least one of the column
686* norms will exceed BIGNUM.
687* 1/3/91: ZLATRS no longer can handle this case
688*
689 tleft = bignum / max( one, dble( n-1 ) )
690 tscal = bignum*( dble( n-1 ) / max( one, dble( n ) ) )
691 IF( upper ) THEN
692 DO 390 j = 1, n
693 CALL zlarnv( 5, iseed, j, a( 1, j ) )
694 CALL dlarnv( 1, iseed, j, rwork )
695 DO 380 i = 1, j
696 a( i, j ) = a( i, j )*( tleft+rwork( i )*tscal )
697 380 CONTINUE
698 390 CONTINUE
699 ELSE
700 DO 410 j = 1, n
701 CALL zlarnv( 5, iseed, n-j+1, a( j, j ) )
702 CALL dlarnv( 1, iseed, n-j+1, rwork )
703 DO 400 i = j, n
704 a( i, j ) = a( i, j )*( tleft+rwork( i-j+1 )*tscal )
705 400 CONTINUE
706 410 CONTINUE
707 END IF
708 CALL zlarnv( 2, iseed, n, b )
709 CALL zdscal( n, two, b, 1 )
710 END IF
711*
712* Flip the matrix if the transpose will be used.
713*
714 IF( .NOT.lsame( trans, 'N' ) ) THEN
715 IF( upper ) THEN
716 DO 420 j = 1, n / 2
717 CALL zswap( n-2*j+1, a( j, j ), lda, a( j+1, n-j+1 ),
718 $ -1 )
719 420 CONTINUE
720 ELSE
721 DO 430 j = 1, n / 2
722 CALL zswap( n-2*j+1, a( j, j ), 1, a( n-j+1, j+1 ),
723 $ -lda )
724 430 CONTINUE
725 END IF
726 END IF
727*
728 RETURN
729*
730* End of ZLATTR
731*

◆ zlavhe()

subroutine zlavhe ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer info )

ZLAVHE

Purpose:
!>
!> ZLAVHE performs one of the matrix-vector operations
!>    x := A*x  or  x := A^H*x,
!> where x is an N element vector and  A is one of the factors
!> from the block U*D*U' or L*D*L' factorization computed by ZHETRF.
!>
!> If TRANS = 'N', multiplies by U  or U * D  (or L  or L * D)
!> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L')
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the factor stored in A is upper or lower
!>          triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the operation to be performed:
!>          = 'N':  x := A*x
!>          = 'C':  x := A'*x
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the diagonal blocks are unit
!>          matrices.  If the diagonal blocks are assumed to be unit,
!>          then A = U or A = L, otherwise A = U*D or A = L*D.
!>          = 'U':  Diagonal blocks are assumed to be unit matrices.
!>          = 'N':  Diagonal blocks are assumed to be non-unit matrices.
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of vectors
!>          x to be multiplied by A.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by ZHETRF.
!>          Stored as a 2-D triangular matrix.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D,
!>          as determined by ZHETRF.
!>
!>          If UPLO = 'U':
!>               If IPIV(k) > 0, then rows and columns k and IPIV(k)
!>               were interchanged and D(k,k) is a 1-by-1 diagonal block.
!>               (If IPIV( k ) = k, no interchange was done).
!>
!>               If IPIV(k) = IPIV(k-1) < 0, then rows and
!>               columns k-1 and -IPIV(k) were interchanged,
!>               D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
!>
!>          If UPLO = 'L':
!>               If IPIV(k) > 0, then rows and columns k and IPIV(k)
!>               were interchanged and D(k,k) is a 1-by-1 diagonal block.
!>               (If IPIV( k ) = k, no interchange was done).
!>
!>               If IPIV(k) = IPIV(k+1) < 0, then rows and
!>               columns k+1 and -IPIV(k) were interchanged,
!>               D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, B contains NRHS vectors of length N.
!>          On exit, B is overwritten with the product A * B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -k, the k-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 151 of file zlavhe.f.

153*
154* -- LAPACK test routine --
155* -- LAPACK is a software package provided by Univ. of Tennessee, --
156* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
157*
158* .. Scalar Arguments ..
159 CHARACTER DIAG, TRANS, UPLO
160 INTEGER INFO, LDA, LDB, N, NRHS
161* ..
162* .. Array Arguments ..
163 INTEGER IPIV( * )
164 COMPLEX*16 A( LDA, * ), B( LDB, * )
165* ..
166*
167* =====================================================================
168*
169* .. Parameters ..
170 COMPLEX*16 ONE
171 parameter( one = ( 1.0d+0, 0.0d+0 ) )
172* ..
173* .. Local Scalars ..
174 LOGICAL NOUNIT
175 INTEGER J, K, KP
176 COMPLEX*16 D11, D12, D21, D22, T1, T2
177* ..
178* .. External Functions ..
179 LOGICAL LSAME
180 EXTERNAL lsame
181* ..
182* .. External Subroutines ..
183 EXTERNAL xerbla, zgemv, zgeru, zlacgv, zscal, zswap
184* ..
185* .. Intrinsic Functions ..
186 INTRINSIC abs, dconjg, max
187* ..
188* .. Executable Statements ..
189*
190* Test the input parameters.
191*
192 info = 0
193 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN
194 info = -1
195 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'C' ) )
196 $ THEN
197 info = -2
198 ELSE IF( .NOT.lsame( diag, 'U' ) .AND. .NOT.lsame( diag, 'N' ) )
199 $ THEN
200 info = -3
201 ELSE IF( n.LT.0 ) THEN
202 info = -4
203 ELSE IF( lda.LT.max( 1, n ) ) THEN
204 info = -6
205 ELSE IF( ldb.LT.max( 1, n ) ) THEN
206 info = -9
207 END IF
208 IF( info.NE.0 ) THEN
209 CALL xerbla( 'ZLAVHE ', -info )
210 RETURN
211 END IF
212*
213* Quick return if possible.
214*
215 IF( n.EQ.0 )
216 $ RETURN
217*
218 nounit = lsame( diag, 'N' )
219*------------------------------------------
220*
221* Compute B := A * B (No transpose)
222*
223*------------------------------------------
224 IF( lsame( trans, 'N' ) ) THEN
225*
226* Compute B := U*B
227* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
228*
229 IF( lsame( uplo, 'U' ) ) THEN
230*
231* Loop forward applying the transformations.
232*
233 k = 1
234 10 CONTINUE
235 IF( k.GT.n )
236 $ GO TO 30
237 IF( ipiv( k ).GT.0 ) THEN
238*
239* 1 x 1 pivot block
240*
241* Multiply by the diagonal element if forming U * D.
242*
243 IF( nounit )
244 $ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
245*
246* Multiply by P(K) * inv(U(K)) if K > 1.
247*
248 IF( k.GT.1 ) THEN
249*
250* Apply the transformation.
251*
252 CALL zgeru( k-1, nrhs, one, a( 1, k ), 1, b( k, 1 ),
253 $ ldb, b( 1, 1 ), ldb )
254*
255* Interchange if P(K) != I.
256*
257 kp = ipiv( k )
258 IF( kp.NE.k )
259 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
260 END IF
261 k = k + 1
262 ELSE
263*
264* 2 x 2 pivot block
265*
266* Multiply by the diagonal block if forming U * D.
267*
268 IF( nounit ) THEN
269 d11 = a( k, k )
270 d22 = a( k+1, k+1 )
271 d12 = a( k, k+1 )
272 d21 = dconjg( d12 )
273 DO 20 j = 1, nrhs
274 t1 = b( k, j )
275 t2 = b( k+1, j )
276 b( k, j ) = d11*t1 + d12*t2
277 b( k+1, j ) = d21*t1 + d22*t2
278 20 CONTINUE
279 END IF
280*
281* Multiply by P(K) * inv(U(K)) if K > 1.
282*
283 IF( k.GT.1 ) THEN
284*
285* Apply the transformations.
286*
287 CALL zgeru( k-1, nrhs, one, a( 1, k ), 1, b( k, 1 ),
288 $ ldb, b( 1, 1 ), ldb )
289 CALL zgeru( k-1, nrhs, one, a( 1, k+1 ), 1,
290 $ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
291*
292* Interchange if P(K) != I.
293*
294 kp = abs( ipiv( k ) )
295 IF( kp.NE.k )
296 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
297 END IF
298 k = k + 2
299 END IF
300 GO TO 10
301 30 CONTINUE
302*
303* Compute B := L*B
304* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
305*
306 ELSE
307*
308* Loop backward applying the transformations to B.
309*
310 k = n
311 40 CONTINUE
312 IF( k.LT.1 )
313 $ GO TO 60
314*
315* Test the pivot index. If greater than zero, a 1 x 1
316* pivot was used, otherwise a 2 x 2 pivot was used.
317*
318 IF( ipiv( k ).GT.0 ) THEN
319*
320* 1 x 1 pivot block:
321*
322* Multiply by the diagonal element if forming L * D.
323*
324 IF( nounit )
325 $ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
326*
327* Multiply by P(K) * inv(L(K)) if K < N.
328*
329 IF( k.NE.n ) THEN
330 kp = ipiv( k )
331*
332* Apply the transformation.
333*
334 CALL zgeru( n-k, nrhs, one, a( k+1, k ), 1, b( k, 1 ),
335 $ ldb, b( k+1, 1 ), ldb )
336*
337* Interchange if a permutation was applied at the
338* K-th step of the factorization.
339*
340 IF( kp.NE.k )
341 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
342 END IF
343 k = k - 1
344*
345 ELSE
346*
347* 2 x 2 pivot block:
348*
349* Multiply by the diagonal block if forming L * D.
350*
351 IF( nounit ) THEN
352 d11 = a( k-1, k-1 )
353 d22 = a( k, k )
354 d21 = a( k, k-1 )
355 d12 = dconjg( d21 )
356 DO 50 j = 1, nrhs
357 t1 = b( k-1, j )
358 t2 = b( k, j )
359 b( k-1, j ) = d11*t1 + d12*t2
360 b( k, j ) = d21*t1 + d22*t2
361 50 CONTINUE
362 END IF
363*
364* Multiply by P(K) * inv(L(K)) if K < N.
365*
366 IF( k.NE.n ) THEN
367*
368* Apply the transformation.
369*
370 CALL zgeru( n-k, nrhs, one, a( k+1, k ), 1, b( k, 1 ),
371 $ ldb, b( k+1, 1 ), ldb )
372 CALL zgeru( n-k, nrhs, one, a( k+1, k-1 ), 1,
373 $ b( k-1, 1 ), ldb, b( k+1, 1 ), ldb )
374*
375* Interchange if a permutation was applied at the
376* K-th step of the factorization.
377*
378 kp = abs( ipiv( k ) )
379 IF( kp.NE.k )
380 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
381 END IF
382 k = k - 2
383 END IF
384 GO TO 40
385 60 CONTINUE
386 END IF
387*--------------------------------------------------
388*
389* Compute B := A^H * B (conjugate transpose)
390*
391*--------------------------------------------------
392 ELSE
393*
394* Form B := U^H*B
395* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
396* and U^H = inv(U^H(1))*P(1)* ... *inv(U^H(m))*P(m)
397*
398 IF( lsame( uplo, 'U' ) ) THEN
399*
400* Loop backward applying the transformations.
401*
402 k = n
403 70 CONTINUE
404 IF( k.LT.1 )
405 $ GO TO 90
406*
407* 1 x 1 pivot block.
408*
409 IF( ipiv( k ).GT.0 ) THEN
410 IF( k.GT.1 ) THEN
411*
412* Interchange if P(K) != I.
413*
414 kp = ipiv( k )
415 IF( kp.NE.k )
416 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
417*
418* Apply the transformation
419* y = y - B' conjg(x),
420* where x is a column of A and y is a row of B.
421*
422 CALL zlacgv( nrhs, b( k, 1 ), ldb )
423 CALL zgemv( 'Conjugate', k-1, nrhs, one, b, ldb,
424 $ a( 1, k ), 1, one, b( k, 1 ), ldb )
425 CALL zlacgv( nrhs, b( k, 1 ), ldb )
426 END IF
427 IF( nounit )
428 $ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
429 k = k - 1
430*
431* 2 x 2 pivot block.
432*
433 ELSE
434 IF( k.GT.2 ) THEN
435*
436* Interchange if P(K) != I.
437*
438 kp = abs( ipiv( k ) )
439 IF( kp.NE.k-1 )
440 $ CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
441 $ ldb )
442*
443* Apply the transformations
444* y = y - B' conjg(x),
445* where x is a block column of A and y is a block
446* row of B.
447*
448 CALL zlacgv( nrhs, b( k, 1 ), ldb )
449 CALL zgemv( 'Conjugate', k-2, nrhs, one, b, ldb,
450 $ a( 1, k ), 1, one, b( k, 1 ), ldb )
451 CALL zlacgv( nrhs, b( k, 1 ), ldb )
452*
453 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
454 CALL zgemv( 'Conjugate', k-2, nrhs, one, b, ldb,
455 $ a( 1, k-1 ), 1, one, b( k-1, 1 ), ldb )
456 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
457 END IF
458*
459* Multiply by the diagonal block if non-unit.
460*
461 IF( nounit ) THEN
462 d11 = a( k-1, k-1 )
463 d22 = a( k, k )
464 d12 = a( k-1, k )
465 d21 = dconjg( d12 )
466 DO 80 j = 1, nrhs
467 t1 = b( k-1, j )
468 t2 = b( k, j )
469 b( k-1, j ) = d11*t1 + d12*t2
470 b( k, j ) = d21*t1 + d22*t2
471 80 CONTINUE
472 END IF
473 k = k - 2
474 END IF
475 GO TO 70
476 90 CONTINUE
477*
478* Form B := L^H*B
479* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
480* and L^H = inv(L^H(m))*P(m)* ... *inv(L^H(1))*P(1)
481*
482 ELSE
483*
484* Loop forward applying the L-transformations.
485*
486 k = 1
487 100 CONTINUE
488 IF( k.GT.n )
489 $ GO TO 120
490*
491* 1 x 1 pivot block
492*
493 IF( ipiv( k ).GT.0 ) THEN
494 IF( k.LT.n ) THEN
495*
496* Interchange if P(K) != I.
497*
498 kp = ipiv( k )
499 IF( kp.NE.k )
500 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
501*
502* Apply the transformation
503*
504 CALL zlacgv( nrhs, b( k, 1 ), ldb )
505 CALL zgemv( 'Conjugate', n-k, nrhs, one, b( k+1, 1 ),
506 $ ldb, a( k+1, k ), 1, one, b( k, 1 ), ldb )
507 CALL zlacgv( nrhs, b( k, 1 ), ldb )
508 END IF
509 IF( nounit )
510 $ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
511 k = k + 1
512*
513* 2 x 2 pivot block.
514*
515 ELSE
516 IF( k.LT.n-1 ) THEN
517*
518* Interchange if P(K) != I.
519*
520 kp = abs( ipiv( k ) )
521 IF( kp.NE.k+1 )
522 $ CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
523 $ ldb )
524*
525* Apply the transformation
526*
527 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
528 CALL zgemv( 'Conjugate', n-k-1, nrhs, one,
529 $ b( k+2, 1 ), ldb, a( k+2, k+1 ), 1, one,
530 $ b( k+1, 1 ), ldb )
531 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
532*
533 CALL zlacgv( nrhs, b( k, 1 ), ldb )
534 CALL zgemv( 'Conjugate', n-k-1, nrhs, one,
535 $ b( k+2, 1 ), ldb, a( k+2, k ), 1, one,
536 $ b( k, 1 ), ldb )
537 CALL zlacgv( nrhs, b( k, 1 ), ldb )
538 END IF
539*
540* Multiply by the diagonal block if non-unit.
541*
542 IF( nounit ) THEN
543 d11 = a( k, k )
544 d22 = a( k+1, k+1 )
545 d21 = a( k+1, k )
546 d12 = dconjg( d21 )
547 DO 110 j = 1, nrhs
548 t1 = b( k, j )
549 t2 = b( k+1, j )
550 b( k, j ) = d11*t1 + d12*t2
551 b( k+1, j ) = d21*t1 + d22*t2
552 110 CONTINUE
553 END IF
554 k = k + 2
555 END IF
556 GO TO 100
557 120 CONTINUE
558 END IF
559*
560 END IF
561 RETURN
562*
563* End of ZLAVHE
564*
zgeru
subroutine zgeru(m, n, alpha, x, incx, y, incy, a, lda)
ZGERU
Definition zgeru.f:130

◆ zlavhe_rook()

subroutine zlavhe_rook ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer info )

ZLAVHE_ROOK

Purpose:
ZLAVHE_ROOK performs one of the matrix-vector operations x := A*x or x := A^H*x, where x is an N element vector and A is one of the factors from the block U*D*U' or L*D*L' factorization computed by ZHETRF_ROOK.

If TRANS = 'N', multiplies by U or U * D (or L or L * D) If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L')

Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the factor stored in A is upper or lower
!>          triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the operation to be performed:
!>          = 'N':  x := A*x
!>          = 'C':   x := A^H*x
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the diagonal blocks are unit
!>          matrices.  If the diagonal blocks are assumed to be unit,
!>          then A = U or A = L, otherwise A = U*D or A = L*D.
!>          = 'U':  Diagonal blocks are assumed to be unit matrices.
!>          = 'N':  Diagonal blocks are assumed to be non-unit matrices.
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of vectors
!>          x to be multiplied by A.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by ZHETRF_ROOK.
!>          Stored as a 2-D triangular matrix.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D,
!>          as determined by ZHETRF_ROOK.
!>          If UPLO = 'U':
!>             Only the last KB elements of IPIV are set.
!>
!>             If IPIV(k) > 0, then rows and columns k and IPIV(k) were
!>             interchanged and D(k,k) is a 1-by-1 diagonal block.
!>
!>             If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
!>             columns k and -IPIV(k) were interchanged and rows and
!>             columns k-1 and -IPIV(k-1) were inerchaged,
!>             D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
!>
!>          If UPLO = 'L':
!>             Only the first KB elements of IPIV are set.
!>
!>             If IPIV(k) > 0, then rows and columns k and IPIV(k)
!>             were interchanged and D(k,k) is a 1-by-1 diagonal block.
!>
!>             If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
!>             columns k and -IPIV(k) were interchanged and rows and
!>             columns k+1 and -IPIV(k+1) were inerchaged,
!>             D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!>
[in,out]B
!>          B is COMPLEX array, dimension (LDB,NRHS)
!>          On entry, B contains NRHS vectors of length N.
!>          On exit, B is overwritten with the product A * B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -k, the k-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 151 of file zlavhe_rook.f.

153*
154* -- LAPACK test routine --
155* -- LAPACK is a software package provided by Univ. of Tennessee, --
156* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
157*
158* .. Scalar Arguments ..
159 CHARACTER DIAG, TRANS, UPLO
160 INTEGER INFO, LDA, LDB, N, NRHS
161* ..
162* .. Array Arguments ..
163 INTEGER IPIV( * )
164 COMPLEX*16 A( LDA, * ), B( LDB, * )
165* ..
166*
167* =====================================================================
168*
169* .. Parameters ..
170 COMPLEX*16 CONE
171 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
172* ..
173* .. Local Scalars ..
174 LOGICAL NOUNIT
175 INTEGER J, K, KP
176 COMPLEX*16 D11, D12, D21, D22, T1, T2
177* ..
178* .. External Functions ..
179 LOGICAL LSAME
180 EXTERNAL lsame
181* ..
182* .. External Subroutines ..
183 EXTERNAL zgemv, zgeru, zlacgv, zscal, zswap, xerbla
184* ..
185* .. Intrinsic Functions ..
186 INTRINSIC abs, dconjg, max
187* ..
188* .. Executable Statements ..
189*
190* Test the input parameters.
191*
192 info = 0
193 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN
194 info = -1
195 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'C' ) )
196 $ THEN
197 info = -2
198 ELSE IF( .NOT.lsame( diag, 'U' ) .AND. .NOT.lsame( diag, 'N' ) )
199 $ THEN
200 info = -3
201 ELSE IF( n.LT.0 ) THEN
202 info = -4
203 ELSE IF( lda.LT.max( 1, n ) ) THEN
204 info = -6
205 ELSE IF( ldb.LT.max( 1, n ) ) THEN
206 info = -9
207 END IF
208 IF( info.NE.0 ) THEN
209 CALL xerbla( 'ZLAVHE_ROOK ', -info )
210 RETURN
211 END IF
212*
213* Quick return if possible.
214*
215 IF( n.EQ.0 )
216 $ RETURN
217*
218 nounit = lsame( diag, 'N' )
219*------------------------------------------
220*
221* Compute B := A * B (No transpose)
222*
223*------------------------------------------
224 IF( lsame( trans, 'N' ) ) THEN
225*
226* Compute B := U*B
227* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
228*
229 IF( lsame( uplo, 'U' ) ) THEN
230*
231* Loop forward applying the transformations.
232*
233 k = 1
234 10 CONTINUE
235 IF( k.GT.n )
236 $ GO TO 30
237 IF( ipiv( k ).GT.0 ) THEN
238*
239* 1 x 1 pivot block
240*
241* Multiply by the diagonal element if forming U * D.
242*
243 IF( nounit )
244 $ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
245*
246* Multiply by P(K) * inv(U(K)) if K > 1.
247*
248 IF( k.GT.1 ) THEN
249*
250* Apply the transformation.
251*
252 CALL zgeru( k-1, nrhs, cone, a( 1, k ), 1, b( k, 1 ),
253 $ ldb, b( 1, 1 ), ldb )
254*
255* Interchange if P(K) != I.
256*
257 kp = ipiv( k )
258 IF( kp.NE.k )
259 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
260 END IF
261 k = k + 1
262 ELSE
263*
264* 2 x 2 pivot block
265*
266* Multiply by the diagonal block if forming U * D.
267*
268 IF( nounit ) THEN
269 d11 = a( k, k )
270 d22 = a( k+1, k+1 )
271 d12 = a( k, k+1 )
272 d21 = dconjg( d12 )
273 DO 20 j = 1, nrhs
274 t1 = b( k, j )
275 t2 = b( k+1, j )
276 b( k, j ) = d11*t1 + d12*t2
277 b( k+1, j ) = d21*t1 + d22*t2
278 20 CONTINUE
279 END IF
280*
281* Multiply by P(K) * inv(U(K)) if K > 1.
282*
283 IF( k.GT.1 ) THEN
284*
285* Apply the transformations.
286*
287 CALL zgeru( k-1, nrhs, cone, a( 1, k ), 1, b( k, 1 ),
288 $ ldb, b( 1, 1 ), ldb )
289 CALL zgeru( k-1, nrhs, cone, a( 1, k+1 ), 1,
290 $ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
291*
292* Interchange if a permutation was applied at the
293* K-th step of the factorization.
294*
295* Swap the first of pair with IMAXth
296*
297 kp = abs( ipiv( k ) )
298 IF( kp.NE.k )
299 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
300*
301* NOW swap the first of pair with Pth
302*
303 kp = abs( ipiv( k+1 ) )
304 IF( kp.NE.k+1 )
305 $ CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
306 $ ldb )
307 END IF
308 k = k + 2
309 END IF
310 GO TO 10
311 30 CONTINUE
312*
313* Compute B := L*B
314* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
315*
316 ELSE
317*
318* Loop backward applying the transformations to B.
319*
320 k = n
321 40 CONTINUE
322 IF( k.LT.1 )
323 $ GO TO 60
324*
325* Test the pivot index. If greater than zero, a 1 x 1
326* pivot was used, otherwise a 2 x 2 pivot was used.
327*
328 IF( ipiv( k ).GT.0 ) THEN
329*
330* 1 x 1 pivot block:
331*
332* Multiply by the diagonal element if forming L * D.
333*
334 IF( nounit )
335 $ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
336*
337* Multiply by P(K) * inv(L(K)) if K < N.
338*
339 IF( k.NE.n ) THEN
340 kp = ipiv( k )
341*
342* Apply the transformation.
343*
344 CALL zgeru( n-k, nrhs, cone, a( k+1, k ), 1,
345 $ b( k, 1 ), ldb, b( k+1, 1 ), ldb )
346*
347* Interchange if a permutation was applied at the
348* K-th step of the factorization.
349*
350 IF( kp.NE.k )
351 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
352 END IF
353 k = k - 1
354*
355 ELSE
356*
357* 2 x 2 pivot block:
358*
359* Multiply by the diagonal block if forming L * D.
360*
361 IF( nounit ) THEN
362 d11 = a( k-1, k-1 )
363 d22 = a( k, k )
364 d21 = a( k, k-1 )
365 d12 = dconjg( d21 )
366 DO 50 j = 1, nrhs
367 t1 = b( k-1, j )
368 t2 = b( k, j )
369 b( k-1, j ) = d11*t1 + d12*t2
370 b( k, j ) = d21*t1 + d22*t2
371 50 CONTINUE
372 END IF
373*
374* Multiply by P(K) * inv(L(K)) if K < N.
375*
376 IF( k.NE.n ) THEN
377*
378* Apply the transformation.
379*
380 CALL zgeru( n-k, nrhs, cone, a( k+1, k ), 1,
381 $ b( k, 1 ), ldb, b( k+1, 1 ), ldb )
382 CALL zgeru( n-k, nrhs, cone, a( k+1, k-1 ), 1,
383 $ b( k-1, 1 ), ldb, b( k+1, 1 ), ldb )
384*
385* Interchange if a permutation was applied at the
386* K-th step of the factorization.
387*
388*
389* Swap the second of pair with IMAXth
390*
391 kp = abs( ipiv( k ) )
392 IF( kp.NE.k )
393 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
394*
395* NOW swap the first of pair with Pth
396*
397 kp = abs( ipiv( k-1 ) )
398 IF( kp.NE.k-1 )
399 $ CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
400 $ ldb )
401*
402 END IF
403 k = k - 2
404 END IF
405 GO TO 40
406 60 CONTINUE
407 END IF
408*--------------------------------------------------
409*
410* Compute B := A^H * B (conjugate transpose)
411*
412*--------------------------------------------------
413 ELSE
414*
415* Form B := U^H*B
416* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
417* and U^H = inv(U^H(1))*P(1)* ... *inv(U^H(m))*P(m)
418*
419 IF( lsame( uplo, 'U' ) ) THEN
420*
421* Loop backward applying the transformations.
422*
423 k = n
424 70 IF( k.LT.1 )
425 $ GO TO 90
426*
427* 1 x 1 pivot block.
428*
429 IF( ipiv( k ).GT.0 ) THEN
430 IF( k.GT.1 ) THEN
431*
432* Interchange if P(K) != I.
433*
434 kp = ipiv( k )
435 IF( kp.NE.k )
436 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
437*
438* Apply the transformation
439* y = y - B' DCONJG(x),
440* where x is a column of A and y is a row of B.
441*
442 CALL zlacgv( nrhs, b( k, 1 ), ldb )
443 CALL zgemv( 'Conjugate', k-1, nrhs, cone, b, ldb,
444 $ a( 1, k ), 1, cone, b( k, 1 ), ldb )
445 CALL zlacgv( nrhs, b( k, 1 ), ldb )
446 END IF
447 IF( nounit )
448 $ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
449 k = k - 1
450*
451* 2 x 2 pivot block.
452*
453 ELSE
454 IF( k.GT.2 ) THEN
455*
456* Swap the second of pair with Pth
457*
458 kp = abs( ipiv( k ) )
459 IF( kp.NE.k )
460 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
461*
462* Now swap the first of pair with IMAX(r)th
463*
464 kp = abs( ipiv( k-1 ) )
465 IF( kp.NE.k-1 )
466 $ CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
467 $ ldb )
468*
469* Apply the transformations
470* y = y - B' DCONJG(x),
471* where x is a block column of A and y is a block
472* row of B.
473*
474 CALL zlacgv( nrhs, b( k, 1 ), ldb )
475 CALL zgemv( 'Conjugate', k-2, nrhs, cone, b, ldb,
476 $ a( 1, k ), 1, cone, b( k, 1 ), ldb )
477 CALL zlacgv( nrhs, b( k, 1 ), ldb )
478*
479 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
480 CALL zgemv( 'Conjugate', k-2, nrhs, cone, b, ldb,
481 $ a( 1, k-1 ), 1, cone, b( k-1, 1 ), ldb )
482 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
483 END IF
484*
485* Multiply by the diagonal block if non-unit.
486*
487 IF( nounit ) THEN
488 d11 = a( k-1, k-1 )
489 d22 = a( k, k )
490 d12 = a( k-1, k )
491 d21 = dconjg( d12 )
492 DO 80 j = 1, nrhs
493 t1 = b( k-1, j )
494 t2 = b( k, j )
495 b( k-1, j ) = d11*t1 + d12*t2
496 b( k, j ) = d21*t1 + d22*t2
497 80 CONTINUE
498 END IF
499 k = k - 2
500 END IF
501 GO TO 70
502 90 CONTINUE
503*
504* Form B := L^H*B
505* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
506* and L^H = inv(L^H(m))*P(m)* ... *inv(L^H(1))*P(1)
507*
508 ELSE
509*
510* Loop forward applying the L-transformations.
511*
512 k = 1
513 100 CONTINUE
514 IF( k.GT.n )
515 $ GO TO 120
516*
517* 1 x 1 pivot block
518*
519 IF( ipiv( k ).GT.0 ) THEN
520 IF( k.LT.n ) THEN
521*
522* Interchange if P(K) != I.
523*
524 kp = ipiv( k )
525 IF( kp.NE.k )
526 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
527*
528* Apply the transformation
529*
530 CALL zlacgv( nrhs, b( k, 1 ), ldb )
531 CALL zgemv( 'Conjugate', n-k, nrhs, cone, b( k+1, 1 ),
532 $ ldb, a( k+1, k ), 1, cone, b( k, 1 ), ldb )
533 CALL zlacgv( nrhs, b( k, 1 ), ldb )
534 END IF
535 IF( nounit )
536 $ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
537 k = k + 1
538*
539* 2 x 2 pivot block.
540*
541 ELSE
542 IF( k.LT.n-1 ) THEN
543*
544* Swap the first of pair with Pth
545*
546 kp = abs( ipiv( k ) )
547 IF( kp.NE.k )
548 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
549*
550* Now swap the second of pair with IMAX(r)th
551*
552 kp = abs( ipiv( k+1 ) )
553 IF( kp.NE.k+1 )
554 $ CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
555 $ ldb )
556*
557* Apply the transformation
558*
559 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
560 CALL zgemv( 'Conjugate', n-k-1, nrhs, cone,
561 $ b( k+2, 1 ), ldb, a( k+2, k+1 ), 1, cone,
562 $ b( k+1, 1 ), ldb )
563 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
564*
565 CALL zlacgv( nrhs, b( k, 1 ), ldb )
566 CALL zgemv( 'Conjugate', n-k-1, nrhs, cone,
567 $ b( k+2, 1 ), ldb, a( k+2, k ), 1, cone,
568 $ b( k, 1 ), ldb )
569 CALL zlacgv( nrhs, b( k, 1 ), ldb )
570 END IF
571*
572* Multiply by the diagonal block if non-unit.
573*
574 IF( nounit ) THEN
575 d11 = a( k, k )
576 d22 = a( k+1, k+1 )
577 d21 = a( k+1, k )
578 d12 = dconjg( d21 )
579 DO 110 j = 1, nrhs
580 t1 = b( k, j )
581 t2 = b( k+1, j )
582 b( k, j ) = d11*t1 + d12*t2
583 b( k+1, j ) = d21*t1 + d22*t2
584 110 CONTINUE
585 END IF
586 k = k + 2
587 END IF
588 GO TO 100
589 120 CONTINUE
590 END IF
591*
592 END IF
593 RETURN
594*
595* End of ZLAVHE_ROOK
596*

◆ zlavhp()

subroutine zlavhp ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex*16, dimension( * ) a,
integer, dimension( * ) ipiv,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer info )

ZLAVHP

Purpose:
!>
!>    ZLAVHP  performs one of the matrix-vector operations
!>       x := A*x  or  x := A^H*x,
!>    where x is an N element vector and  A is one of the factors
!>    from the symmetric factorization computed by ZHPTRF.
!>    ZHPTRF produces a factorization of the form
!>         U * D * U^H     or     L * D * L^H,
!>    where U (or L) is a product of permutation and unit upper (lower)
!>    triangular matrices, U^H (or L^H) is the conjugate transpose of
!>    U (or L), and D is Hermitian and block diagonal with 1 x 1 and
!>    2 x 2 diagonal blocks.  The multipliers for the transformations
!>    and the upper or lower triangular parts of the diagonal blocks
!>    are stored columnwise in packed format in the linear array A.
!>
!>    If TRANS = 'N' or 'n', ZLAVHP multiplies either by U or U * D
!>    (or L or L * D).
!>    If TRANS = 'C' or 'c', ZLAVHP multiplies either by U^H or D * U^H
!>    (or L^H or D * L^H ).
!> 
!>  UPLO   - CHARACTER*1
!>           On entry, UPLO specifies whether the triangular matrix
!>           stored in A is upper or lower triangular.
!>              UPLO = 'U' or 'u'   The matrix is upper triangular.
!>              UPLO = 'L' or 'l'   The matrix is lower triangular.
!>           Unchanged on exit.
!>
!>  TRANS  - CHARACTER*1
!>           On entry, TRANS specifies the operation to be performed as
!>           follows:
!>              TRANS = 'N' or 'n'   x := A*x.
!>              TRANS = 'C' or 'c'   x := A^H*x.
!>           Unchanged on exit.
!>
!>  DIAG   - CHARACTER*1
!>           On entry, DIAG specifies whether the diagonal blocks are
!>           assumed to be unit matrices, as follows:
!>              DIAG = 'U' or 'u'   Diagonal blocks are unit matrices.
!>              DIAG = 'N' or 'n'   Diagonal blocks are non-unit.
!>           Unchanged on exit.
!>
!>  N      - INTEGER
!>           On entry, N specifies the order of the matrix A.
!>           N must be at least zero.
!>           Unchanged on exit.
!>
!>  NRHS   - INTEGER
!>           On entry, NRHS specifies the number of right hand sides,
!>           i.e., the number of vectors x to be multiplied by A.
!>           NRHS must be at least zero.
!>           Unchanged on exit.
!>
!>  A      - COMPLEX*16 array, dimension( N*(N+1)/2 )
!>           On entry, A contains a block diagonal matrix and the
!>           multipliers of the transformations used to obtain it,
!>           stored as a packed triangular matrix.
!>           Unchanged on exit.
!>
!>  IPIV   - INTEGER array, dimension( N )
!>           On entry, IPIV contains the vector of pivot indices as
!>           determined by ZSPTRF or ZHPTRF.
!>           If IPIV( K ) = K, no interchange was done.
!>           If IPIV( K ) <> K but IPIV( K ) > 0, then row K was inter-
!>           changed with row IPIV( K ) and a 1 x 1 pivot block was used.
!>           If IPIV( K ) < 0 and UPLO = 'U', then row K-1 was exchanged
!>           with row | IPIV( K ) | and a 2 x 2 pivot block was used.
!>           If IPIV( K ) < 0 and UPLO = 'L', then row K+1 was exchanged
!>           with row | IPIV( K ) | and a 2 x 2 pivot block was used.
!>
!>  B      - COMPLEX*16 array, dimension( LDB, NRHS )
!>           On entry, B contains NRHS vectors of length N.
!>           On exit, B is overwritten with the product A * B.
!>
!>  LDB    - INTEGER
!>           On entry, LDB contains the leading dimension of B as
!>           declared in the calling program.  LDB must be at least
!>           max( 1, N ).
!>           Unchanged on exit.
!>
!>  INFO   - INTEGER
!>           INFO is the error flag.
!>           On exit, a value of 0 indicates a successful exit.
!>           A negative value, say -K, indicates that the K-th argument
!>           has an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 129 of file zlavhp.f.

131*
132* -- LAPACK test routine --
133* -- LAPACK is a software package provided by Univ. of Tennessee, --
134* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
135*
136* .. Scalar Arguments ..
137 CHARACTER DIAG, TRANS, UPLO
138 INTEGER INFO, LDB, N, NRHS
139* ..
140* .. Array Arguments ..
141 INTEGER IPIV( * )
142 COMPLEX*16 A( * ), B( LDB, * )
143* ..
144*
145* =====================================================================
146*
147* .. Parameters ..
148 COMPLEX*16 ONE
149 parameter( one = ( 1.0d+0, 0.0d+0 ) )
150* ..
151* .. Local Scalars ..
152 LOGICAL NOUNIT
153 INTEGER J, K, KC, KCNEXT, KP
154 COMPLEX*16 D11, D12, D21, D22, T1, T2
155* ..
156* .. External Functions ..
157 LOGICAL LSAME
158 EXTERNAL lsame
159* ..
160* .. External Subroutines ..
161 EXTERNAL xerbla, zgemv, zgeru, zlacgv, zscal, zswap
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC abs, dconjg, max
165* ..
166* .. Executable Statements ..
167*
168* Test the input parameters.
169*
170 info = 0
171 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN
172 info = -1
173 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'C' ) )
174 $ THEN
175 info = -2
176 ELSE IF( .NOT.lsame( diag, 'U' ) .AND. .NOT.lsame( diag, 'N' ) )
177 $ THEN
178 info = -3
179 ELSE IF( n.LT.0 ) THEN
180 info = -4
181 ELSE IF( ldb.LT.max( 1, n ) ) THEN
182 info = -8
183 END IF
184 IF( info.NE.0 ) THEN
185 CALL xerbla( 'ZLAVHP ', -info )
186 RETURN
187 END IF
188*
189* Quick return if possible.
190*
191 IF( n.EQ.0 )
192 $ RETURN
193*
194 nounit = lsame( diag, 'N' )
195*------------------------------------------
196*
197* Compute B := A * B (No transpose)
198*
199*------------------------------------------
200 IF( lsame( trans, 'N' ) ) THEN
201*
202* Compute B := U*B
203* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
204*
205 IF( lsame( uplo, 'U' ) ) THEN
206*
207* Loop forward applying the transformations.
208*
209 k = 1
210 kc = 1
211 10 CONTINUE
212 IF( k.GT.n )
213 $ GO TO 30
214*
215* 1 x 1 pivot block
216*
217 IF( ipiv( k ).GT.0 ) THEN
218*
219* Multiply by the diagonal element if forming U * D.
220*
221 IF( nounit )
222 $ CALL zscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
223*
224* Multiply by P(K) * inv(U(K)) if K > 1.
225*
226 IF( k.GT.1 ) THEN
227*
228* Apply the transformation.
229*
230 CALL zgeru( k-1, nrhs, one, a( kc ), 1, b( k, 1 ),
231 $ ldb, b( 1, 1 ), ldb )
232*
233* Interchange if P(K) != I.
234*
235 kp = ipiv( k )
236 IF( kp.NE.k )
237 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
238 END IF
239 kc = kc + k
240 k = k + 1
241 ELSE
242*
243* 2 x 2 pivot block
244*
245 kcnext = kc + k
246*
247* Multiply by the diagonal block if forming U * D.
248*
249 IF( nounit ) THEN
250 d11 = a( kcnext-1 )
251 d22 = a( kcnext+k )
252 d12 = a( kcnext+k-1 )
253 d21 = dconjg( d12 )
254 DO 20 j = 1, nrhs
255 t1 = b( k, j )
256 t2 = b( k+1, j )
257 b( k, j ) = d11*t1 + d12*t2
258 b( k+1, j ) = d21*t1 + d22*t2
259 20 CONTINUE
260 END IF
261*
262* Multiply by P(K) * inv(U(K)) if K > 1.
263*
264 IF( k.GT.1 ) THEN
265*
266* Apply the transformations.
267*
268 CALL zgeru( k-1, nrhs, one, a( kc ), 1, b( k, 1 ),
269 $ ldb, b( 1, 1 ), ldb )
270 CALL zgeru( k-1, nrhs, one, a( kcnext ), 1,
271 $ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
272*
273* Interchange if P(K) != I.
274*
275 kp = abs( ipiv( k ) )
276 IF( kp.NE.k )
277 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
278 END IF
279 kc = kcnext + k + 1
280 k = k + 2
281 END IF
282 GO TO 10
283 30 CONTINUE
284*
285* Compute B := L*B
286* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
287*
288 ELSE
289*
290* Loop backward applying the transformations to B.
291*
292 k = n
293 kc = n*( n+1 ) / 2 + 1
294 40 CONTINUE
295 IF( k.LT.1 )
296 $ GO TO 60
297 kc = kc - ( n-k+1 )
298*
299* Test the pivot index. If greater than zero, a 1 x 1
300* pivot was used, otherwise a 2 x 2 pivot was used.
301*
302 IF( ipiv( k ).GT.0 ) THEN
303*
304* 1 x 1 pivot block:
305*
306* Multiply by the diagonal element if forming L * D.
307*
308 IF( nounit )
309 $ CALL zscal( nrhs, a( kc ), b( k, 1 ), ldb )
310*
311* Multiply by P(K) * inv(L(K)) if K < N.
312*
313 IF( k.NE.n ) THEN
314 kp = ipiv( k )
315*
316* Apply the transformation.
317*
318 CALL zgeru( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
319 $ ldb, b( k+1, 1 ), ldb )
320*
321* Interchange if a permutation was applied at the
322* K-th step of the factorization.
323*
324 IF( kp.NE.k )
325 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
326 END IF
327 k = k - 1
328*
329 ELSE
330*
331* 2 x 2 pivot block:
332*
333 kcnext = kc - ( n-k+2 )
334*
335* Multiply by the diagonal block if forming L * D.
336*
337 IF( nounit ) THEN
338 d11 = a( kcnext )
339 d22 = a( kc )
340 d21 = a( kcnext+1 )
341 d12 = dconjg( d21 )
342 DO 50 j = 1, nrhs
343 t1 = b( k-1, j )
344 t2 = b( k, j )
345 b( k-1, j ) = d11*t1 + d12*t2
346 b( k, j ) = d21*t1 + d22*t2
347 50 CONTINUE
348 END IF
349*
350* Multiply by P(K) * inv(L(K)) if K < N.
351*
352 IF( k.NE.n ) THEN
353*
354* Apply the transformation.
355*
356 CALL zgeru( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
357 $ ldb, b( k+1, 1 ), ldb )
358 CALL zgeru( n-k, nrhs, one, a( kcnext+2 ), 1,
359 $ b( k-1, 1 ), ldb, b( k+1, 1 ), ldb )
360*
361* Interchange if a permutation was applied at the
362* K-th step of the factorization.
363*
364 kp = abs( ipiv( k ) )
365 IF( kp.NE.k )
366 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
367 END IF
368 kc = kcnext
369 k = k - 2
370 END IF
371 GO TO 40
372 60 CONTINUE
373 END IF
374*-------------------------------------------------
375*
376* Compute B := A^H * B (conjugate transpose)
377*
378*-------------------------------------------------
379 ELSE
380*
381* Form B := U^H*B
382* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
383* and U^H = inv(U^H(1))*P(1)* ... *inv(U^H(m))*P(m)
384*
385 IF( lsame( uplo, 'U' ) ) THEN
386*
387* Loop backward applying the transformations.
388*
389 k = n
390 kc = n*( n+1 ) / 2 + 1
391 70 CONTINUE
392 IF( k.LT.1 )
393 $ GO TO 90
394 kc = kc - k
395*
396* 1 x 1 pivot block.
397*
398 IF( ipiv( k ).GT.0 ) THEN
399 IF( k.GT.1 ) THEN
400*
401* Interchange if P(K) != I.
402*
403 kp = ipiv( k )
404 IF( kp.NE.k )
405 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
406*
407* Apply the transformation:
408* y := y - B' * conjg(x)
409* where x is a column of A and y is a row of B.
410*
411 CALL zlacgv( nrhs, b( k, 1 ), ldb )
412 CALL zgemv( 'Conjugate', k-1, nrhs, one, b, ldb,
413 $ a( kc ), 1, one, b( k, 1 ), ldb )
414 CALL zlacgv( nrhs, b( k, 1 ), ldb )
415 END IF
416 IF( nounit )
417 $ CALL zscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
418 k = k - 1
419*
420* 2 x 2 pivot block.
421*
422 ELSE
423 kcnext = kc - ( k-1 )
424 IF( k.GT.2 ) THEN
425*
426* Interchange if P(K) != I.
427*
428 kp = abs( ipiv( k ) )
429 IF( kp.NE.k-1 )
430 $ CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
431 $ ldb )
432*
433* Apply the transformations.
434*
435 CALL zlacgv( nrhs, b( k, 1 ), ldb )
436 CALL zgemv( 'Conjugate', k-2, nrhs, one, b, ldb,
437 $ a( kc ), 1, one, b( k, 1 ), ldb )
438 CALL zlacgv( nrhs, b( k, 1 ), ldb )
439*
440 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
441 CALL zgemv( 'Conjugate', k-2, nrhs, one, b, ldb,
442 $ a( kcnext ), 1, one, b( k-1, 1 ), ldb )
443 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
444 END IF
445*
446* Multiply by the diagonal block if non-unit.
447*
448 IF( nounit ) THEN
449 d11 = a( kc-1 )
450 d22 = a( kc+k-1 )
451 d12 = a( kc+k-2 )
452 d21 = dconjg( d12 )
453 DO 80 j = 1, nrhs
454 t1 = b( k-1, j )
455 t2 = b( k, j )
456 b( k-1, j ) = d11*t1 + d12*t2
457 b( k, j ) = d21*t1 + d22*t2
458 80 CONTINUE
459 END IF
460 kc = kcnext
461 k = k - 2
462 END IF
463 GO TO 70
464 90 CONTINUE
465*
466* Form B := L^H*B
467* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
468* and L^H = inv(L(m))*P(m)* ... *inv(L(1))*P(1)
469*
470 ELSE
471*
472* Loop forward applying the L-transformations.
473*
474 k = 1
475 kc = 1
476 100 CONTINUE
477 IF( k.GT.n )
478 $ GO TO 120
479*
480* 1 x 1 pivot block
481*
482 IF( ipiv( k ).GT.0 ) THEN
483 IF( k.LT.n ) THEN
484*
485* Interchange if P(K) != I.
486*
487 kp = ipiv( k )
488 IF( kp.NE.k )
489 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
490*
491* Apply the transformation
492*
493 CALL zlacgv( nrhs, b( k, 1 ), ldb )
494 CALL zgemv( 'Conjugate', n-k, nrhs, one, b( k+1, 1 ),
495 $ ldb, a( kc+1 ), 1, one, b( k, 1 ), ldb )
496 CALL zlacgv( nrhs, b( k, 1 ), ldb )
497 END IF
498 IF( nounit )
499 $ CALL zscal( nrhs, a( kc ), b( k, 1 ), ldb )
500 kc = kc + n - k + 1
501 k = k + 1
502*
503* 2 x 2 pivot block.
504*
505 ELSE
506 kcnext = kc + n - k + 1
507 IF( k.LT.n-1 ) THEN
508*
509* Interchange if P(K) != I.
510*
511 kp = abs( ipiv( k ) )
512 IF( kp.NE.k+1 )
513 $ CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
514 $ ldb )
515*
516* Apply the transformation
517*
518 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
519 CALL zgemv( 'Conjugate', n-k-1, nrhs, one,
520 $ b( k+2, 1 ), ldb, a( kcnext+1 ), 1, one,
521 $ b( k+1, 1 ), ldb )
522 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
523*
524 CALL zlacgv( nrhs, b( k, 1 ), ldb )
525 CALL zgemv( 'Conjugate', n-k-1, nrhs, one,
526 $ b( k+2, 1 ), ldb, a( kc+2 ), 1, one,
527 $ b( k, 1 ), ldb )
528 CALL zlacgv( nrhs, b( k, 1 ), ldb )
529 END IF
530*
531* Multiply by the diagonal block if non-unit.
532*
533 IF( nounit ) THEN
534 d11 = a( kc )
535 d22 = a( kcnext )
536 d21 = a( kc+1 )
537 d12 = dconjg( d21 )
538 DO 110 j = 1, nrhs
539 t1 = b( k, j )
540 t2 = b( k+1, j )
541 b( k, j ) = d11*t1 + d12*t2
542 b( k+1, j ) = d21*t1 + d22*t2
543 110 CONTINUE
544 END IF
545 kc = kcnext + ( n-k )
546 k = k + 2
547 END IF
548 GO TO 100
549 120 CONTINUE
550 END IF
551*
552 END IF
553 RETURN
554*
555* End of ZLAVHP
556*

◆ zlavsp()

subroutine zlavsp ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex*16, dimension( * ) a,
integer, dimension( * ) ipiv,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer info )

ZLAVSP

Purpose:
!>
!>    ZLAVSP  performs one of the matrix-vector operations
!>       x := A*x  or  x := A^T*x,
!>    where x is an N element vector and  A is one of the factors
!>    from the symmetric factorization computed by ZSPTRF.
!>    ZSPTRF produces a factorization of the form
!>         U * D * U^T     or     L * D * L^T,
!>    where U (or L) is a product of permutation and unit upper (lower)
!>    triangular matrices, U^T (or L^T) is the transpose of
!>    U (or L), and D is symmetric and block diagonal with 1 x 1 and
!>    2 x 2 diagonal blocks.  The multipliers for the transformations
!>    and the upper or lower triangular parts of the diagonal blocks
!>    are stored columnwise in packed format in the linear array A.
!>
!>    If TRANS = 'N' or 'n', ZLAVSP multiplies either by U or U * D
!>    (or L or L * D).
!>    If TRANS = 'C' or 'c', ZLAVSP multiplies either by U^T or D * U^T
!>    (or L^T or D * L^T ).
!> 
!>  UPLO   - CHARACTER*1
!>           On entry, UPLO specifies whether the triangular matrix
!>           stored in A is upper or lower triangular.
!>              UPLO = 'U' or 'u'   The matrix is upper triangular.
!>              UPLO = 'L' or 'l'   The matrix is lower triangular.
!>           Unchanged on exit.
!>
!>  TRANS  - CHARACTER*1
!>           On entry, TRANS specifies the operation to be performed as
!>           follows:
!>              TRANS = 'N' or 'n'   x := A*x.
!>              TRANS = 'T' or 't'   x := A^T*x.
!>           Unchanged on exit.
!>
!>  DIAG   - CHARACTER*1
!>           On entry, DIAG specifies whether the diagonal blocks are
!>           assumed to be unit matrices, as follows:
!>              DIAG = 'U' or 'u'   Diagonal blocks are unit matrices.
!>              DIAG = 'N' or 'n'   Diagonal blocks are non-unit.
!>           Unchanged on exit.
!>
!>  N      - INTEGER
!>           On entry, N specifies the order of the matrix A.
!>           N must be at least zero.
!>           Unchanged on exit.
!>
!>  NRHS   - INTEGER
!>           On entry, NRHS specifies the number of right hand sides,
!>           i.e., the number of vectors x to be multiplied by A.
!>           NRHS must be at least zero.
!>           Unchanged on exit.
!>
!>  A      - COMPLEX*16 array, dimension( N*(N+1)/2 )
!>           On entry, A contains a block diagonal matrix and the
!>           multipliers of the transformations used to obtain it,
!>           stored as a packed triangular matrix.
!>           Unchanged on exit.
!>
!>  IPIV   - INTEGER array, dimension( N )
!>           On entry, IPIV contains the vector of pivot indices as
!>           determined by ZSPTRF.
!>           If IPIV( K ) = K, no interchange was done.
!>           If IPIV( K ) <> K but IPIV( K ) > 0, then row K was inter-
!>           changed with row IPIV( K ) and a 1 x 1 pivot block was used.
!>           If IPIV( K ) < 0 and UPLO = 'U', then row K-1 was exchanged
!>           with row | IPIV( K ) | and a 2 x 2 pivot block was used.
!>           If IPIV( K ) < 0 and UPLO = 'L', then row K+1 was exchanged
!>           with row | IPIV( K ) | and a 2 x 2 pivot block was used.
!>
!>  B      - COMPLEX*16 array, dimension( LDB, NRHS )
!>           On entry, B contains NRHS vectors of length N.
!>           On exit, B is overwritten with the product A * B.
!>
!>  LDB    - INTEGER
!>           On entry, LDB contains the leading dimension of B as
!>           declared in the calling program.  LDB must be at least
!>           max( 1, N ).
!>           Unchanged on exit.
!>
!>  INFO   - INTEGER
!>           INFO is the error flag.
!>           On exit, a value of 0 indicates a successful exit.
!>           A negative value, say -K, indicates that the K-th argument
!>           has an illegal value.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 129 of file zlavsp.f.

131*
132* -- LAPACK test routine --
133* -- LAPACK is a software package provided by Univ. of Tennessee, --
134* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
135*
136* .. Scalar Arguments ..
137 CHARACTER DIAG, TRANS, UPLO
138 INTEGER INFO, LDB, N, NRHS
139* ..
140* .. Array Arguments ..
141 INTEGER IPIV( * )
142 COMPLEX*16 A( * ), B( LDB, * )
143* ..
144*
145* =====================================================================
146*
147* .. Parameters ..
148 COMPLEX*16 ONE
149 parameter( one = ( 1.0d+0, 0.0d+0 ) )
150* ..
151* .. Local Scalars ..
152 LOGICAL NOUNIT
153 INTEGER J, K, KC, KCNEXT, KP
154 COMPLEX*16 D11, D12, D21, D22, T1, T2
155* ..
156* .. External Functions ..
157 LOGICAL LSAME
158 EXTERNAL lsame
159* ..
160* .. External Subroutines ..
161 EXTERNAL xerbla, zgemv, zgeru, zscal, zswap
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC abs, max
165* ..
166* .. Executable Statements ..
167*
168* Test the input parameters.
169*
170 info = 0
171 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN
172 info = -1
173 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'T' ) )
174 $ THEN
175 info = -2
176 ELSE IF( .NOT.lsame( diag, 'U' ) .AND. .NOT.lsame( diag, 'N' ) )
177 $ THEN
178 info = -3
179 ELSE IF( n.LT.0 ) THEN
180 info = -4
181 ELSE IF( ldb.LT.max( 1, n ) ) THEN
182 info = -8
183 END IF
184 IF( info.NE.0 ) THEN
185 CALL xerbla( 'ZLAVSP ', -info )
186 RETURN
187 END IF
188*
189* Quick return if possible.
190*
191 IF( n.EQ.0 )
192 $ RETURN
193*
194 nounit = lsame( diag, 'N' )
195*------------------------------------------
196*
197* Compute B := A * B (No transpose)
198*
199*------------------------------------------
200 IF( lsame( trans, 'N' ) ) THEN
201*
202* Compute B := U*B
203* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
204*
205 IF( lsame( uplo, 'U' ) ) THEN
206*
207* Loop forward applying the transformations.
208*
209 k = 1
210 kc = 1
211 10 CONTINUE
212 IF( k.GT.n )
213 $ GO TO 30
214*
215* 1 x 1 pivot block
216*
217 IF( ipiv( k ).GT.0 ) THEN
218*
219* Multiply by the diagonal element if forming U * D.
220*
221 IF( nounit )
222 $ CALL zscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
223*
224* Multiply by P(K) * inv(U(K)) if K > 1.
225*
226 IF( k.GT.1 ) THEN
227*
228* Apply the transformation.
229*
230 CALL zgeru( k-1, nrhs, one, a( kc ), 1, b( k, 1 ),
231 $ ldb, b( 1, 1 ), ldb )
232*
233* Interchange if P(K) != I.
234*
235 kp = ipiv( k )
236 IF( kp.NE.k )
237 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
238 END IF
239 kc = kc + k
240 k = k + 1
241 ELSE
242*
243* 2 x 2 pivot block
244*
245 kcnext = kc + k
246*
247* Multiply by the diagonal block if forming U * D.
248*
249 IF( nounit ) THEN
250 d11 = a( kcnext-1 )
251 d22 = a( kcnext+k )
252 d12 = a( kcnext+k-1 )
253 d21 = d12
254 DO 20 j = 1, nrhs
255 t1 = b( k, j )
256 t2 = b( k+1, j )
257 b( k, j ) = d11*t1 + d12*t2
258 b( k+1, j ) = d21*t1 + d22*t2
259 20 CONTINUE
260 END IF
261*
262* Multiply by P(K) * inv(U(K)) if K > 1.
263*
264 IF( k.GT.1 ) THEN
265*
266* Apply the transformations.
267*
268 CALL zgeru( k-1, nrhs, one, a( kc ), 1, b( k, 1 ),
269 $ ldb, b( 1, 1 ), ldb )
270 CALL zgeru( k-1, nrhs, one, a( kcnext ), 1,
271 $ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
272*
273* Interchange if P(K) != I.
274*
275 kp = abs( ipiv( k ) )
276 IF( kp.NE.k )
277 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
278 END IF
279 kc = kcnext + k + 1
280 k = k + 2
281 END IF
282 GO TO 10
283 30 CONTINUE
284*
285* Compute B := L*B
286* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
287*
288 ELSE
289*
290* Loop backward applying the transformations to B.
291*
292 k = n
293 kc = n*( n+1 ) / 2 + 1
294 40 CONTINUE
295 IF( k.LT.1 )
296 $ GO TO 60
297 kc = kc - ( n-k+1 )
298*
299* Test the pivot index. If greater than zero, a 1 x 1
300* pivot was used, otherwise a 2 x 2 pivot was used.
301*
302 IF( ipiv( k ).GT.0 ) THEN
303*
304* 1 x 1 pivot block:
305*
306* Multiply by the diagonal element if forming L * D.
307*
308 IF( nounit )
309 $ CALL zscal( nrhs, a( kc ), b( k, 1 ), ldb )
310*
311* Multiply by P(K) * inv(L(K)) if K < N.
312*
313 IF( k.NE.n ) THEN
314 kp = ipiv( k )
315*
316* Apply the transformation.
317*
318 CALL zgeru( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
319 $ ldb, b( k+1, 1 ), ldb )
320*
321* Interchange if a permutation was applied at the
322* K-th step of the factorization.
323*
324 IF( kp.NE.k )
325 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
326 END IF
327 k = k - 1
328*
329 ELSE
330*
331* 2 x 2 pivot block:
332*
333 kcnext = kc - ( n-k+2 )
334*
335* Multiply by the diagonal block if forming L * D.
336*
337 IF( nounit ) THEN
338 d11 = a( kcnext )
339 d22 = a( kc )
340 d21 = a( kcnext+1 )
341 d12 = d21
342 DO 50 j = 1, nrhs
343 t1 = b( k-1, j )
344 t2 = b( k, j )
345 b( k-1, j ) = d11*t1 + d12*t2
346 b( k, j ) = d21*t1 + d22*t2
347 50 CONTINUE
348 END IF
349*
350* Multiply by P(K) * inv(L(K)) if K < N.
351*
352 IF( k.NE.n ) THEN
353*
354* Apply the transformation.
355*
356 CALL zgeru( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
357 $ ldb, b( k+1, 1 ), ldb )
358 CALL zgeru( n-k, nrhs, one, a( kcnext+2 ), 1,
359 $ b( k-1, 1 ), ldb, b( k+1, 1 ), ldb )
360*
361* Interchange if a permutation was applied at the
362* K-th step of the factorization.
363*
364 kp = abs( ipiv( k ) )
365 IF( kp.NE.k )
366 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
367 END IF
368 kc = kcnext
369 k = k - 2
370 END IF
371 GO TO 40
372 60 CONTINUE
373 END IF
374*-------------------------------------------------
375*
376* Compute B := A^T * B (transpose)
377*
378*-------------------------------------------------
379 ELSE
380*
381* Form B := U^T*B
382* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
383* and U^T = inv(U^T(1))*P(1)* ... *inv(U^T(m))*P(m)
384*
385 IF( lsame( uplo, 'U' ) ) THEN
386*
387* Loop backward applying the transformations.
388*
389 k = n
390 kc = n*( n+1 ) / 2 + 1
391 70 CONTINUE
392 IF( k.LT.1 )
393 $ GO TO 90
394 kc = kc - k
395*
396* 1 x 1 pivot block.
397*
398 IF( ipiv( k ).GT.0 ) THEN
399 IF( k.GT.1 ) THEN
400*
401* Interchange if P(K) != I.
402*
403 kp = ipiv( k )
404 IF( kp.NE.k )
405 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
406*
407* Apply the transformation:
408* y := y - B' * conjg(x)
409* where x is a column of A and y is a row of B.
410*
411 CALL zgemv( 'Transpose', k-1, nrhs, one, b, ldb,
412 $ a( kc ), 1, one, b( k, 1 ), ldb )
413 END IF
414 IF( nounit )
415 $ CALL zscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
416 k = k - 1
417*
418* 2 x 2 pivot block.
419*
420 ELSE
421 kcnext = kc - ( k-1 )
422 IF( k.GT.2 ) THEN
423*
424* Interchange if P(K) != I.
425*
426 kp = abs( ipiv( k ) )
427 IF( kp.NE.k-1 )
428 $ CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
429 $ ldb )
430*
431* Apply the transformations.
432*
433 CALL zgemv( 'Transpose', k-2, nrhs, one, b, ldb,
434 $ a( kc ), 1, one, b( k, 1 ), ldb )
435*
436 CALL zgemv( 'Transpose', k-2, nrhs, one, b, ldb,
437 $ a( kcnext ), 1, one, b( k-1, 1 ), ldb )
438 END IF
439*
440* Multiply by the diagonal block if non-unit.
441*
442 IF( nounit ) THEN
443 d11 = a( kc-1 )
444 d22 = a( kc+k-1 )
445 d12 = a( kc+k-2 )
446 d21 = d12
447 DO 80 j = 1, nrhs
448 t1 = b( k-1, j )
449 t2 = b( k, j )
450 b( k-1, j ) = d11*t1 + d12*t2
451 b( k, j ) = d21*t1 + d22*t2
452 80 CONTINUE
453 END IF
454 kc = kcnext
455 k = k - 2
456 END IF
457 GO TO 70
458 90 CONTINUE
459*
460* Form B := L^T*B
461* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
462* and L^T = inv(L(m))*P(m)* ... *inv(L(1))*P(1)
463*
464 ELSE
465*
466* Loop forward applying the L-transformations.
467*
468 k = 1
469 kc = 1
470 100 CONTINUE
471 IF( k.GT.n )
472 $ GO TO 120
473*
474* 1 x 1 pivot block
475*
476 IF( ipiv( k ).GT.0 ) THEN
477 IF( k.LT.n ) THEN
478*
479* Interchange if P(K) != I.
480*
481 kp = ipiv( k )
482 IF( kp.NE.k )
483 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
484*
485* Apply the transformation
486*
487 CALL zgemv( 'Transpose', n-k, nrhs, one, b( k+1, 1 ),
488 $ ldb, a( kc+1 ), 1, one, b( k, 1 ), ldb )
489 END IF
490 IF( nounit )
491 $ CALL zscal( nrhs, a( kc ), b( k, 1 ), ldb )
492 kc = kc + n - k + 1
493 k = k + 1
494*
495* 2 x 2 pivot block.
496*
497 ELSE
498 kcnext = kc + n - k + 1
499 IF( k.LT.n-1 ) THEN
500*
501* Interchange if P(K) != I.
502*
503 kp = abs( ipiv( k ) )
504 IF( kp.NE.k+1 )
505 $ CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
506 $ ldb )
507*
508* Apply the transformation
509*
510 CALL zgemv( 'Transpose', n-k-1, nrhs, one,
511 $ b( k+2, 1 ), ldb, a( kcnext+1 ), 1, one,
512 $ b( k+1, 1 ), ldb )
513*
514 CALL zgemv( 'Transpose', n-k-1, nrhs, one,
515 $ b( k+2, 1 ), ldb, a( kc+2 ), 1, one,
516 $ b( k, 1 ), ldb )
517 END IF
518*
519* Multiply by the diagonal block if non-unit.
520*
521 IF( nounit ) THEN
522 d11 = a( kc )
523 d22 = a( kcnext )
524 d21 = a( kc+1 )
525 d12 = d21
526 DO 110 j = 1, nrhs
527 t1 = b( k, j )
528 t2 = b( k+1, j )
529 b( k, j ) = d11*t1 + d12*t2
530 b( k+1, j ) = d21*t1 + d22*t2
531 110 CONTINUE
532 END IF
533 kc = kcnext + ( n-k )
534 k = k + 2
535 END IF
536 GO TO 100
537 120 CONTINUE
538 END IF
539*
540 END IF
541 RETURN
542*
543* End of ZLAVSP
544*

◆ zlavsy()

subroutine zlavsy ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer info )

ZLAVSY

Purpose:
!>
!> ZLAVSY performs one of the matrix-vector operations
!>    x := A*x  or  x := A'*x,
!> where x is an N element vector and  A is one of the factors
!> from the block U*D*U' or L*D*L' factorization computed by ZSYTRF.
!>
!> If TRANS = 'N', multiplies by U  or U * D  (or L  or L * D)
!> If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L')
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the factor stored in A is upper or lower
!>          triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the operation to be performed:
!>          = 'N':  x := A*x
!>          = 'T':  x := A'*x
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the diagonal blocks are unit
!>          matrices.  If the diagonal blocks are assumed to be unit,
!>          then A = U or A = L, otherwise A = U*D or A = L*D.
!>          = 'U':  Diagonal blocks are assumed to be unit matrices.
!>          = 'N':  Diagonal blocks are assumed to be non-unit matrices.
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of vectors
!>          x to be multiplied by A.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by ZSYTRF.
!>          Stored as a 2-D triangular matrix.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D,
!>          as determined by ZSYTRF.
!>
!>          If UPLO = 'U':
!>               If IPIV(k) > 0, then rows and columns k and IPIV(k)
!>               were interchanged and D(k,k) is a 1-by-1 diagonal block.
!>               (If IPIV( k ) = k, no interchange was done).
!>
!>               If IPIV(k) = IPIV(k-1) < 0, then rows and
!>               columns k-1 and -IPIV(k) were interchanged,
!>               D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
!>
!>          If UPLO = 'L':
!>               If IPIV(k) > 0, then rows and columns k and IPIV(k)
!>               were interchanged and D(k,k) is a 1-by-1 diagonal block.
!>               (If IPIV( k ) = k, no interchange was done).
!>
!>               If IPIV(k) = IPIV(k+1) < 0, then rows and
!>               columns k+1 and -IPIV(k) were interchanged,
!>               D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, B contains NRHS vectors of length N.
!>          On exit, B is overwritten with the product A * B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -k, the k-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 151 of file zlavsy.f.

153*
154* -- LAPACK test routine --
155* -- LAPACK is a software package provided by Univ. of Tennessee, --
156* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
157*
158* .. Scalar Arguments ..
159 CHARACTER DIAG, TRANS, UPLO
160 INTEGER INFO, LDA, LDB, N, NRHS
161* ..
162* .. Array Arguments ..
163 INTEGER IPIV( * )
164 COMPLEX*16 A( LDA, * ), B( LDB, * )
165* ..
166*
167* =====================================================================
168*
169* .. Parameters ..
170 COMPLEX*16 CONE
171 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
172* ..
173* .. Local Scalars ..
174 LOGICAL NOUNIT
175 INTEGER J, K, KP
176 COMPLEX*16 D11, D12, D21, D22, T1, T2
177* ..
178* .. External Functions ..
179 LOGICAL LSAME
180 EXTERNAL lsame
181* ..
182* .. External Subroutines ..
183 EXTERNAL xerbla, zgemv, zgeru, zscal, zswap
184* ..
185* .. Intrinsic Functions ..
186 INTRINSIC abs, max
187* ..
188* .. Executable Statements ..
189*
190* Test the input parameters.
191*
192 info = 0
193 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN
194 info = -1
195 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'T' ) )
196 $ THEN
197 info = -2
198 ELSE IF( .NOT.lsame( diag, 'U' ) .AND. .NOT.lsame( diag, 'N' ) )
199 $ THEN
200 info = -3
201 ELSE IF( n.LT.0 ) THEN
202 info = -4
203 ELSE IF( lda.LT.max( 1, n ) ) THEN
204 info = -6
205 ELSE IF( ldb.LT.max( 1, n ) ) THEN
206 info = -9
207 END IF
208 IF( info.NE.0 ) THEN
209 CALL xerbla( 'ZLAVSY ', -info )
210 RETURN
211 END IF
212*
213* Quick return if possible.
214*
215 IF( n.EQ.0 )
216 $ RETURN
217*
218 nounit = lsame( diag, 'N' )
219*------------------------------------------
220*
221* Compute B := A * B (No transpose)
222*
223*------------------------------------------
224 IF( lsame( trans, 'N' ) ) THEN
225*
226* Compute B := U*B
227* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
228*
229 IF( lsame( uplo, 'U' ) ) THEN
230*
231* Loop forward applying the transformations.
232*
233 k = 1
234 10 CONTINUE
235 IF( k.GT.n )
236 $ GO TO 30
237 IF( ipiv( k ).GT.0 ) THEN
238*
239* 1 x 1 pivot block
240*
241* Multiply by the diagonal element if forming U * D.
242*
243 IF( nounit )
244 $ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
245*
246* Multiply by P(K) * inv(U(K)) if K > 1.
247*
248 IF( k.GT.1 ) THEN
249*
250* Apply the transformation.
251*
252 CALL zgeru( k-1, nrhs, cone, a( 1, k ), 1, b( k, 1 ),
253 $ ldb, b( 1, 1 ), ldb )
254*
255* Interchange if P(K) != I.
256*
257 kp = ipiv( k )
258 IF( kp.NE.k )
259 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
260 END IF
261 k = k + 1
262 ELSE
263*
264* 2 x 2 pivot block
265*
266* Multiply by the diagonal block if forming U * D.
267*
268 IF( nounit ) THEN
269 d11 = a( k, k )
270 d22 = a( k+1, k+1 )
271 d12 = a( k, k+1 )
272 d21 = d12
273 DO 20 j = 1, nrhs
274 t1 = b( k, j )
275 t2 = b( k+1, j )
276 b( k, j ) = d11*t1 + d12*t2
277 b( k+1, j ) = d21*t1 + d22*t2
278 20 CONTINUE
279 END IF
280*
281* Multiply by P(K) * inv(U(K)) if K > 1.
282*
283 IF( k.GT.1 ) THEN
284*
285* Apply the transformations.
286*
287 CALL zgeru( k-1, nrhs, cone, a( 1, k ), 1, b( k, 1 ),
288 $ ldb, b( 1, 1 ), ldb )
289 CALL zgeru( k-1, nrhs, cone, a( 1, k+1 ), 1,
290 $ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
291*
292* Interchange if P(K) != I.
293*
294 kp = abs( ipiv( k ) )
295 IF( kp.NE.k )
296 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
297 END IF
298 k = k + 2
299 END IF
300 GO TO 10
301 30 CONTINUE
302*
303* Compute B := L*B
304* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
305*
306 ELSE
307*
308* Loop backward applying the transformations to B.
309*
310 k = n
311 40 CONTINUE
312 IF( k.LT.1 )
313 $ GO TO 60
314*
315* Test the pivot index. If greater than zero, a 1 x 1
316* pivot was used, otherwise a 2 x 2 pivot was used.
317*
318 IF( ipiv( k ).GT.0 ) THEN
319*
320* 1 x 1 pivot block:
321*
322* Multiply by the diagonal element if forming L * D.
323*
324 IF( nounit )
325 $ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
326*
327* Multiply by P(K) * inv(L(K)) if K < N.
328*
329 IF( k.NE.n ) THEN
330 kp = ipiv( k )
331*
332* Apply the transformation.
333*
334 CALL zgeru( n-k, nrhs, cone, a( k+1, k ), 1,
335 $ b( k, 1 ), ldb, b( k+1, 1 ), ldb )
336*
337* Interchange if a permutation was applied at the
338* K-th step of the factorization.
339*
340 IF( kp.NE.k )
341 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
342 END IF
343 k = k - 1
344*
345 ELSE
346*
347* 2 x 2 pivot block:
348*
349* Multiply by the diagonal block if forming L * D.
350*
351 IF( nounit ) THEN
352 d11 = a( k-1, k-1 )
353 d22 = a( k, k )
354 d21 = a( k, k-1 )
355 d12 = d21
356 DO 50 j = 1, nrhs
357 t1 = b( k-1, j )
358 t2 = b( k, j )
359 b( k-1, j ) = d11*t1 + d12*t2
360 b( k, j ) = d21*t1 + d22*t2
361 50 CONTINUE
362 END IF
363*
364* Multiply by P(K) * inv(L(K)) if K < N.
365*
366 IF( k.NE.n ) THEN
367*
368* Apply the transformation.
369*
370 CALL zgeru( n-k, nrhs, cone, a( k+1, k ), 1,
371 $ b( k, 1 ), ldb, b( k+1, 1 ), ldb )
372 CALL zgeru( n-k, nrhs, cone, a( k+1, k-1 ), 1,
373 $ b( k-1, 1 ), ldb, b( k+1, 1 ), ldb )
374*
375* Interchange if a permutation was applied at the
376* K-th step of the factorization.
377*
378 kp = abs( ipiv( k ) )
379 IF( kp.NE.k )
380 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
381 END IF
382 k = k - 2
383 END IF
384 GO TO 40
385 60 CONTINUE
386 END IF
387*----------------------------------------
388*
389* Compute B := A' * B (transpose)
390*
391*----------------------------------------
392 ELSE IF( lsame( trans, 'T' ) ) THEN
393*
394* Form B := U'*B
395* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
396* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m)
397*
398 IF( lsame( uplo, 'U' ) ) THEN
399*
400* Loop backward applying the transformations.
401*
402 k = n
403 70 CONTINUE
404 IF( k.LT.1 )
405 $ GO TO 90
406*
407* 1 x 1 pivot block.
408*
409 IF( ipiv( k ).GT.0 ) THEN
410 IF( k.GT.1 ) THEN
411*
412* Interchange if P(K) != I.
413*
414 kp = ipiv( k )
415 IF( kp.NE.k )
416 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
417*
418* Apply the transformation
419*
420 CALL zgemv( 'Transpose', k-1, nrhs, cone, b, ldb,
421 $ a( 1, k ), 1, cone, b( k, 1 ), ldb )
422 END IF
423 IF( nounit )
424 $ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
425 k = k - 1
426*
427* 2 x 2 pivot block.
428*
429 ELSE
430 IF( k.GT.2 ) THEN
431*
432* Interchange if P(K) != I.
433*
434 kp = abs( ipiv( k ) )
435 IF( kp.NE.k-1 )
436 $ CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
437 $ ldb )
438*
439* Apply the transformations
440*
441 CALL zgemv( 'Transpose', k-2, nrhs, cone, b, ldb,
442 $ a( 1, k ), 1, cone, b( k, 1 ), ldb )
443 CALL zgemv( 'Transpose', k-2, nrhs, cone, b, ldb,
444 $ a( 1, k-1 ), 1, cone, b( k-1, 1 ), ldb )
445 END IF
446*
447* Multiply by the diagonal block if non-unit.
448*
449 IF( nounit ) THEN
450 d11 = a( k-1, k-1 )
451 d22 = a( k, k )
452 d12 = a( k-1, k )
453 d21 = d12
454 DO 80 j = 1, nrhs
455 t1 = b( k-1, j )
456 t2 = b( k, j )
457 b( k-1, j ) = d11*t1 + d12*t2
458 b( k, j ) = d21*t1 + d22*t2
459 80 CONTINUE
460 END IF
461 k = k - 2
462 END IF
463 GO TO 70
464 90 CONTINUE
465*
466* Form B := L'*B
467* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
468* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1)
469*
470 ELSE
471*
472* Loop forward applying the L-transformations.
473*
474 k = 1
475 100 CONTINUE
476 IF( k.GT.n )
477 $ GO TO 120
478*
479* 1 x 1 pivot block
480*
481 IF( ipiv( k ).GT.0 ) THEN
482 IF( k.LT.n ) THEN
483*
484* Interchange if P(K) != I.
485*
486 kp = ipiv( k )
487 IF( kp.NE.k )
488 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
489*
490* Apply the transformation
491*
492 CALL zgemv( 'Transpose', n-k, nrhs, cone, b( k+1, 1 ),
493 $ ldb, a( k+1, k ), 1, cone, b( k, 1 ), ldb )
494 END IF
495 IF( nounit )
496 $ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
497 k = k + 1
498*
499* 2 x 2 pivot block.
500*
501 ELSE
502 IF( k.LT.n-1 ) THEN
503*
504* Interchange if P(K) != I.
505*
506 kp = abs( ipiv( k ) )
507 IF( kp.NE.k+1 )
508 $ CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
509 $ ldb )
510*
511* Apply the transformation
512*
513 CALL zgemv( 'Transpose', n-k-1, nrhs, cone,
514 $ b( k+2, 1 ), ldb, a( k+2, k+1 ), 1, cone,
515 $ b( k+1, 1 ), ldb )
516 CALL zgemv( 'Transpose', n-k-1, nrhs, cone,
517 $ b( k+2, 1 ), ldb, a( k+2, k ), 1, cone,
518 $ b( k, 1 ), ldb )
519 END IF
520*
521* Multiply by the diagonal block if non-unit.
522*
523 IF( nounit ) THEN
524 d11 = a( k, k )
525 d22 = a( k+1, k+1 )
526 d21 = a( k+1, k )
527 d12 = d21
528 DO 110 j = 1, nrhs
529 t1 = b( k, j )
530 t2 = b( k+1, j )
531 b( k, j ) = d11*t1 + d12*t2
532 b( k+1, j ) = d21*t1 + d22*t2
533 110 CONTINUE
534 END IF
535 k = k + 2
536 END IF
537 GO TO 100
538 120 CONTINUE
539 END IF
540 END IF
541 RETURN
542*
543* End of ZLAVSY
544*

◆ zlavsy_rook()

subroutine zlavsy_rook ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
complex*16, dimension( ldb, * ) b,
integer ldb,
integer info )

ZLAVSY_ROOK

Purpose:
!>
!> ZLAVSY_ROOK performs one of the matrix-vector operations
!>    x := A*x  or  x := A'*x,
!> where x is an N element vector and  A is one of the factors
!> from the block U*D*U' or L*D*L' factorization computed by ZSYTRF_ROOK.
!>
!> If TRANS = 'N', multiplies by U  or U * D  (or L  or L * D)
!> If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L')
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the factor stored in A is upper or lower
!>          triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the operation to be performed:
!>          = 'N':  x := A*x
!>          = 'T':  x := A'*x
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the diagonal blocks are unit
!>          matrices.  If the diagonal blocks are assumed to be unit,
!>          then A = U or A = L, otherwise A = U*D or A = L*D.
!>          = 'U':  Diagonal blocks are assumed to be unit matrices.
!>          = 'N':  Diagonal blocks are assumed to be non-unit matrices.
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of vectors
!>          x to be multiplied by A.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by ZSYTRF_ROOK.
!>          Stored as a 2-D triangular matrix.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          Details of the interchanges and the block structure of D,
!>          as determined by ZSYTRF_ROOK.
!>
!>          If UPLO = 'U':
!>               If IPIV(k) > 0, then rows and columns k and IPIV(k)
!>               were interchanged and D(k,k) is a 1-by-1 diagonal block.
!>               (If IPIV( k ) = k, no interchange was done).
!>
!>               If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
!>               columns k and -IPIV(k) were interchanged and rows and
!>               columns k-1 and -IPIV(k-1) were inerchaged,
!>               D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
!>
!>          If UPLO = 'L':
!>               If IPIV(k) > 0, then rows and columns k and IPIV(k)
!>               were interchanged and D(k,k) is a 1-by-1 diagonal block.
!>               (If IPIV( k ) = k, no interchange was done).
!>
!>               If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
!>               columns k and -IPIV(k) were interchanged and rows and
!>               columns k+1 and -IPIV(k+1) were inerchaged,
!>               D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, B contains NRHS vectors of length N.
!>          On exit, B is overwritten with the product A * B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -k, the k-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 153 of file zlavsy_rook.f.

155*
156* -- LAPACK test routine --
157* -- LAPACK is a software package provided by Univ. of Tennessee, --
158* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
159*
160* .. Scalar Arguments ..
161 CHARACTER DIAG, TRANS, UPLO
162 INTEGER INFO, LDA, LDB, N, NRHS
163* ..
164* .. Array Arguments ..
165 INTEGER IPIV( * )
166 COMPLEX*16 A( LDA, * ), B( LDB, * )
167* ..
168*
169* =====================================================================
170*
171* .. Parameters ..
172 COMPLEX*16 CONE
173 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
174* ..
175* .. Local Scalars ..
176 LOGICAL NOUNIT
177 INTEGER J, K, KP
178 COMPLEX*16 D11, D12, D21, D22, T1, T2
179* ..
180* .. External Functions ..
181 LOGICAL LSAME
182 EXTERNAL lsame
183* ..
184* .. External Subroutines ..
185 EXTERNAL xerbla, zgemv, zgeru, zscal, zswap
186* ..
187* .. Intrinsic Functions ..
188 INTRINSIC abs, max
189* ..
190* .. Executable Statements ..
191*
192* Test the input parameters.
193*
194 info = 0
195 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN
196 info = -1
197 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'T' ) )
198 $ THEN
199 info = -2
200 ELSE IF( .NOT.lsame( diag, 'U' ) .AND. .NOT.lsame( diag, 'N' ) )
201 $ THEN
202 info = -3
203 ELSE IF( n.LT.0 ) THEN
204 info = -4
205 ELSE IF( lda.LT.max( 1, n ) ) THEN
206 info = -6
207 ELSE IF( ldb.LT.max( 1, n ) ) THEN
208 info = -9
209 END IF
210 IF( info.NE.0 ) THEN
211 CALL xerbla( 'ZLAVSY_ROOK ', -info )
212 RETURN
213 END IF
214*
215* Quick return if possible.
216*
217 IF( n.EQ.0 )
218 $ RETURN
219*
220 nounit = lsame( diag, 'N' )
221*------------------------------------------
222*
223* Compute B := A * B (No transpose)
224*
225*------------------------------------------
226 IF( lsame( trans, 'N' ) ) THEN
227*
228* Compute B := U*B
229* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
230*
231 IF( lsame( uplo, 'U' ) ) THEN
232*
233* Loop forward applying the transformations.
234*
235 k = 1
236 10 CONTINUE
237 IF( k.GT.n )
238 $ GO TO 30
239 IF( ipiv( k ).GT.0 ) THEN
240*
241* 1 x 1 pivot block
242*
243* Multiply by the diagonal element if forming U * D.
244*
245 IF( nounit )
246 $ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
247*
248* Multiply by P(K) * inv(U(K)) if K > 1.
249*
250 IF( k.GT.1 ) THEN
251*
252* Apply the transformation.
253*
254 CALL zgeru( k-1, nrhs, cone, a( 1, k ), 1, b( k, 1 ),
255 $ ldb, b( 1, 1 ), ldb )
256*
257* Interchange if P(K) != I.
258*
259 kp = ipiv( k )
260 IF( kp.NE.k )
261 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
262 END IF
263 k = k + 1
264 ELSE
265*
266* 2 x 2 pivot block
267*
268* Multiply by the diagonal block if forming U * D.
269*
270 IF( nounit ) THEN
271 d11 = a( k, k )
272 d22 = a( k+1, k+1 )
273 d12 = a( k, k+1 )
274 d21 = d12
275 DO 20 j = 1, nrhs
276 t1 = b( k, j )
277 t2 = b( k+1, j )
278 b( k, j ) = d11*t1 + d12*t2
279 b( k+1, j ) = d21*t1 + d22*t2
280 20 CONTINUE
281 END IF
282*
283* Multiply by P(K) * inv(U(K)) if K > 1.
284*
285 IF( k.GT.1 ) THEN
286*
287* Apply the transformations.
288*
289 CALL zgeru( k-1, nrhs, cone, a( 1, k ), 1, b( k, 1 ),
290 $ ldb, b( 1, 1 ), ldb )
291 CALL zgeru( k-1, nrhs, cone, a( 1, k+1 ), 1,
292 $ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
293*
294* Interchange if a permutation was applied at the
295* K-th step of the factorization.
296*
297* Swap the first of pair with IMAXth
298*
299 kp = abs( ipiv( k ) )
300 IF( kp.NE.k )
301 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
302*
303* NOW swap the first of pair with Pth
304*
305 kp = abs( ipiv( k+1 ) )
306 IF( kp.NE.k+1 )
307 $ CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
308 $ ldb )
309 END IF
310 k = k + 2
311 END IF
312 GO TO 10
313 30 CONTINUE
314*
315* Compute B := L*B
316* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
317*
318 ELSE
319*
320* Loop backward applying the transformations to B.
321*
322 k = n
323 40 CONTINUE
324 IF( k.LT.1 )
325 $ GO TO 60
326*
327* Test the pivot index. If greater than zero, a 1 x 1
328* pivot was used, otherwise a 2 x 2 pivot was used.
329*
330 IF( ipiv( k ).GT.0 ) THEN
331*
332* 1 x 1 pivot block:
333*
334* Multiply by the diagonal element if forming L * D.
335*
336 IF( nounit )
337 $ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
338*
339* Multiply by P(K) * inv(L(K)) if K < N.
340*
341 IF( k.NE.n ) THEN
342 kp = ipiv( k )
343*
344* Apply the transformation.
345*
346 CALL zgeru( n-k, nrhs, cone, a( k+1, k ), 1,
347 $ b( k, 1 ), ldb, b( k+1, 1 ), ldb )
348*
349* Interchange if a permutation was applied at the
350* K-th step of the factorization.
351*
352 IF( kp.NE.k )
353 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
354 END IF
355 k = k - 1
356*
357 ELSE
358*
359* 2 x 2 pivot block:
360*
361* Multiply by the diagonal block if forming L * D.
362*
363 IF( nounit ) THEN
364 d11 = a( k-1, k-1 )
365 d22 = a( k, k )
366 d21 = a( k, k-1 )
367 d12 = d21
368 DO 50 j = 1, nrhs
369 t1 = b( k-1, j )
370 t2 = b( k, j )
371 b( k-1, j ) = d11*t1 + d12*t2
372 b( k, j ) = d21*t1 + d22*t2
373 50 CONTINUE
374 END IF
375*
376* Multiply by P(K) * inv(L(K)) if K < N.
377*
378 IF( k.NE.n ) THEN
379*
380* Apply the transformation.
381*
382 CALL zgeru( n-k, nrhs, cone, a( k+1, k ), 1,
383 $ b( k, 1 ), ldb, b( k+1, 1 ), ldb )
384 CALL zgeru( n-k, nrhs, cone, a( k+1, k-1 ), 1,
385 $ b( k-1, 1 ), ldb, b( k+1, 1 ), ldb )
386*
387* Interchange if a permutation was applied at the
388* K-th step of the factorization.
389*
390* Swap the second of pair with IMAXth
391*
392 kp = abs( ipiv( k ) )
393 IF( kp.NE.k )
394 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
395*
396* NOW swap the first of pair with Pth
397*
398 kp = abs( ipiv( k-1 ) )
399 IF( kp.NE.k-1 )
400 $ CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
401 $ ldb )
402 END IF
403 k = k - 2
404 END IF
405 GO TO 40
406 60 CONTINUE
407 END IF
408*----------------------------------------
409*
410* Compute B := A' * B (transpose)
411*
412*----------------------------------------
413 ELSE IF( lsame( trans, 'T' ) ) THEN
414*
415* Form B := U'*B
416* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
417* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m)
418*
419 IF( lsame( uplo, 'U' ) ) THEN
420*
421* Loop backward applying the transformations.
422*
423 k = n
424 70 CONTINUE
425 IF( k.LT.1 )
426 $ GO TO 90
427*
428* 1 x 1 pivot block.
429*
430 IF( ipiv( k ).GT.0 ) THEN
431 IF( k.GT.1 ) THEN
432*
433* Interchange if P(K) != I.
434*
435 kp = ipiv( k )
436 IF( kp.NE.k )
437 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
438*
439* Apply the transformation
440*
441 CALL zgemv( 'Transpose', k-1, nrhs, cone, b, ldb,
442 $ a( 1, k ), 1, cone, b( k, 1 ), ldb )
443 END IF
444 IF( nounit )
445 $ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
446 k = k - 1
447*
448* 2 x 2 pivot block.
449*
450 ELSE
451 IF( k.GT.2 ) THEN
452*
453* Swap the second of pair with Pth
454*
455 kp = abs( ipiv( k ) )
456 IF( kp.NE.k )
457 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
458*
459* Now swap the first of pair with IMAX(r)th
460*
461 kp = abs( ipiv( k-1 ) )
462 IF( kp.NE.k-1 )
463 $ CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
464 $ ldb )
465*
466* Apply the transformations
467*
468 CALL zgemv( 'Transpose', k-2, nrhs, cone, b, ldb,
469 $ a( 1, k ), 1, cone, b( k, 1 ), ldb )
470 CALL zgemv( 'Transpose', k-2, nrhs, cone, b, ldb,
471 $ a( 1, k-1 ), 1, cone, b( k-1, 1 ), ldb )
472 END IF
473*
474* Multiply by the diagonal block if non-unit.
475*
476 IF( nounit ) THEN
477 d11 = a( k-1, k-1 )
478 d22 = a( k, k )
479 d12 = a( k-1, k )
480 d21 = d12
481 DO 80 j = 1, nrhs
482 t1 = b( k-1, j )
483 t2 = b( k, j )
484 b( k-1, j ) = d11*t1 + d12*t2
485 b( k, j ) = d21*t1 + d22*t2
486 80 CONTINUE
487 END IF
488 k = k - 2
489 END IF
490 GO TO 70
491 90 CONTINUE
492*
493* Form B := L'*B
494* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
495* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1)
496*
497 ELSE
498*
499* Loop forward applying the L-transformations.
500*
501 k = 1
502 100 CONTINUE
503 IF( k.GT.n )
504 $ GO TO 120
505*
506* 1 x 1 pivot block
507*
508 IF( ipiv( k ).GT.0 ) THEN
509 IF( k.LT.n ) THEN
510*
511* Interchange if P(K) != I.
512*
513 kp = ipiv( k )
514 IF( kp.NE.k )
515 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
516*
517* Apply the transformation
518*
519 CALL zgemv( 'Transpose', n-k, nrhs, cone, b( k+1, 1 ),
520 $ ldb, a( k+1, k ), 1, cone, b( k, 1 ), ldb )
521 END IF
522 IF( nounit )
523 $ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
524 k = k + 1
525*
526* 2 x 2 pivot block.
527*
528 ELSE
529 IF( k.LT.n-1 ) THEN
530*
531* Swap the first of pair with Pth
532*
533 kp = abs( ipiv( k ) )
534 IF( kp.NE.k )
535 $ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
536*
537* Now swap the second of pair with IMAX(r)th
538*
539 kp = abs( ipiv( k+1 ) )
540 IF( kp.NE.k+1 )
541 $ CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
542 $ ldb )
543*
544* Apply the transformation
545*
546 CALL zgemv( 'Transpose', n-k-1, nrhs, cone,
547 $ b( k+2, 1 ), ldb, a( k+2, k+1 ), 1, cone,
548 $ b( k+1, 1 ), ldb )
549 CALL zgemv( 'Transpose', n-k-1, nrhs, cone,
550 $ b( k+2, 1 ), ldb, a( k+2, k ), 1, cone,
551 $ b( k, 1 ), ldb )
552 END IF
553*
554* Multiply by the diagonal block if non-unit.
555*
556 IF( nounit ) THEN
557 d11 = a( k, k )
558 d22 = a( k+1, k+1 )
559 d21 = a( k+1, k )
560 d12 = d21
561 DO 110 j = 1, nrhs
562 t1 = b( k, j )
563 t2 = b( k+1, j )
564 b( k, j ) = d11*t1 + d12*t2
565 b( k+1, j ) = d21*t1 + d22*t2
566 110 CONTINUE
567 END IF
568 k = k + 2
569 END IF
570 GO TO 100
571 120 CONTINUE
572 END IF
573 END IF
574 RETURN
575*
576* End of ZLAVSY_ROOK
577*

◆ zlqt01()

subroutine zlqt01 ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
complex*16, dimension( lda, * ) af,
complex*16, dimension( lda, * ) q,
complex*16, dimension( lda, * ) l,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result )

ZLQT01

Purpose:
!>
!> ZLQT01 tests ZGELQF, which computes the LQ factorization of an m-by-n
!> matrix A, and partially tests ZUNGLQ which forms the n-by-n
!> orthogonal matrix Q.
!>
!> ZLQT01 compares L with A*Q', and checks that Q is orthogonal.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The m-by-n matrix A.
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the LQ factorization of A, as returned by ZGELQF.
!>          See ZGELQF for further details.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDA,N)
!>          The n-by-n orthogonal matrix Q.
!>
[out]L
!>          L is COMPLEX*16 array, dimension (LDA,max(M,N))
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays A, AF, Q and L.
!>          LDA >= max(M,N).
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by ZGELQF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(M,N))
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file zlqt01.f.

126*
127* -- LAPACK test routine --
128* -- LAPACK is a software package provided by Univ. of Tennessee, --
129* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
130*
131* .. Scalar Arguments ..
132 INTEGER LDA, LWORK, M, N
133* ..
134* .. Array Arguments ..
135 DOUBLE PRECISION RESULT( * ), RWORK( * )
136 COMPLEX*16 A( LDA, * ), AF( LDA, * ), L( LDA, * ),
137 $ Q( LDA, * ), TAU( * ), WORK( LWORK )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ZERO, ONE
144 parameter( zero = 0.0d+0, one = 1.0d+0 )
145 COMPLEX*16 ROGUE
146 parameter( rogue = ( -1.0d+10, -1.0d+10 ) )
147* ..
148* .. Local Scalars ..
149 INTEGER INFO, MINMN
150 DOUBLE PRECISION ANORM, EPS, RESID
151* ..
152* .. External Functions ..
153 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY
154 EXTERNAL dlamch, zlange, zlansy
155* ..
156* .. External Subroutines ..
157 EXTERNAL zgelqf, zgemm, zherk, zlacpy, zlaset, zunglq
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC dble, dcmplx, max, min
161* ..
162* .. Scalars in Common ..
163 CHARACTER*32 SRNAMT
164* ..
165* .. Common blocks ..
166 COMMON / srnamc / srnamt
167* ..
168* .. Executable Statements ..
169*
170 minmn = min( m, n )
171 eps = dlamch( 'Epsilon' )
172*
173* Copy the matrix A to the array AF.
174*
175 CALL zlacpy( 'Full', m, n, a, lda, af, lda )
176*
177* Factorize the matrix A in the array AF.
178*
179 srnamt = 'ZGELQF'
180 CALL zgelqf( m, n, af, lda, tau, work, lwork, info )
181*
182* Copy details of Q
183*
184 CALL zlaset( 'Full', n, n, rogue, rogue, q, lda )
185 IF( n.GT.1 )
186 $ CALL zlacpy( 'Upper', m, n-1, af( 1, 2 ), lda, q( 1, 2 ), lda )
187*
188* Generate the n-by-n matrix Q
189*
190 srnamt = 'ZUNGLQ'
191 CALL zunglq( n, n, minmn, q, lda, tau, work, lwork, info )
192*
193* Copy L
194*
195 CALL zlaset( 'Full', m, n, dcmplx( zero ), dcmplx( zero ), l,
196 $ lda )
197 CALL zlacpy( 'Lower', m, n, af, lda, l, lda )
198*
199* Compute L - A*Q'
200*
201 CALL zgemm( 'No transpose', 'Conjugate transpose', m, n, n,
202 $ dcmplx( -one ), a, lda, q, lda, dcmplx( one ), l,
203 $ lda )
204*
205* Compute norm( L - Q'*A ) / ( N * norm(A) * EPS ) .
206*
207 anorm = zlange( '1', m, n, a, lda, rwork )
208 resid = zlange( '1', m, n, l, lda, rwork )
209 IF( anorm.GT.zero ) THEN
210 result( 1 ) = ( ( resid / dble( max( 1, n ) ) ) / anorm ) / eps
211 ELSE
212 result( 1 ) = zero
213 END IF
214*
215* Compute I - Q*Q'
216*
217 CALL zlaset( 'Full', n, n, dcmplx( zero ), dcmplx( one ), l, lda )
218 CALL zherk( 'Upper', 'No transpose', n, n, -one, q, lda, one, l,
219 $ lda )
220*
221* Compute norm( I - Q*Q' ) / ( N * EPS ) .
222*
223 resid = zlansy( '1', 'Upper', n, l, lda, rwork )
224*
225 result( 2 ) = ( resid / dble( max( 1, n ) ) ) / eps
226*
227 RETURN
228*
229* End of ZLQT01
230*

◆ zlqt02()

subroutine zlqt02 ( integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
complex*16, dimension( lda, * ) af,
complex*16, dimension( lda, * ) q,
complex*16, dimension( lda, * ) l,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result )

ZLQT02

Purpose:
!>
!> ZLQT02 tests ZUNGLQ, which generates an m-by-n matrix Q with
!> orthonornmal rows that is defined as the product of k elementary
!> reflectors.
!>
!> Given the LQ factorization of an m-by-n matrix A, ZLQT02 generates
!> the orthogonal matrix Q defined by the factorization of the first k
!> rows of A; it compares L(1:k,1:m) with A(1:k,1:n)*Q(1:m,1:n)', and
!> checks that the rows of Q are orthonormal.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix Q to be generated.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix Q to be generated.
!>          N >= M >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines the
!>          matrix Q. M >= K >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The m-by-n matrix A which was factorized by ZLQT01.
!>
[in]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the LQ factorization of A, as returned by ZGELQF.
!>          See ZGELQF for further details.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDA,N)
!>
[out]L
!>          L is COMPLEX*16 array, dimension (LDA,M)
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays A, AF, Q and L. LDA >= N.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (M)
!>          The scalar factors of the elementary reflectors corresponding
!>          to the LQ factorization in AF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 133 of file zlqt02.f.

135*
136* -- LAPACK test routine --
137* -- LAPACK is a software package provided by Univ. of Tennessee, --
138* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
139*
140* .. Scalar Arguments ..
141 INTEGER K, LDA, LWORK, M, N
142* ..
143* .. Array Arguments ..
144 DOUBLE PRECISION RESULT( * ), RWORK( * )
145 COMPLEX*16 A( LDA, * ), AF( LDA, * ), L( LDA, * ),
146 $ Q( LDA, * ), TAU( * ), WORK( LWORK )
147* ..
148*
149* =====================================================================
150*
151* .. Parameters ..
152 DOUBLE PRECISION ZERO, ONE
153 parameter( zero = 0.0d+0, one = 1.0d+0 )
154 COMPLEX*16 ROGUE
155 parameter( rogue = ( -1.0d+10, -1.0d+10 ) )
156* ..
157* .. Local Scalars ..
158 INTEGER INFO
159 DOUBLE PRECISION ANORM, EPS, RESID
160* ..
161* .. External Functions ..
162 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY
163 EXTERNAL dlamch, zlange, zlansy
164* ..
165* .. External Subroutines ..
166 EXTERNAL zgemm, zherk, zlacpy, zlaset, zunglq
167* ..
168* .. Intrinsic Functions ..
169 INTRINSIC dble, dcmplx, max
170* ..
171* .. Scalars in Common ..
172 CHARACTER*32 SRNAMT
173* ..
174* .. Common blocks ..
175 COMMON / srnamc / srnamt
176* ..
177* .. Executable Statements ..
178*
179 eps = dlamch( 'Epsilon' )
180*
181* Copy the first k rows of the factorization to the array Q
182*
183 CALL zlaset( 'Full', m, n, rogue, rogue, q, lda )
184 CALL zlacpy( 'Upper', k, n-1, af( 1, 2 ), lda, q( 1, 2 ), lda )
185*
186* Generate the first n columns of the matrix Q
187*
188 srnamt = 'ZUNGLQ'
189 CALL zunglq( m, n, k, q, lda, tau, work, lwork, info )
190*
191* Copy L(1:k,1:m)
192*
193 CALL zlaset( 'Full', k, m, dcmplx( zero ), dcmplx( zero ), l,
194 $ lda )
195 CALL zlacpy( 'Lower', k, m, af, lda, l, lda )
196*
197* Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)'
198*
199 CALL zgemm( 'No transpose', 'Conjugate transpose', k, m, n,
200 $ dcmplx( -one ), a, lda, q, lda, dcmplx( one ), l,
201 $ lda )
202*
203* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) .
204*
205 anorm = zlange( '1', k, n, a, lda, rwork )
206 resid = zlange( '1', k, m, l, lda, rwork )
207 IF( anorm.GT.zero ) THEN
208 result( 1 ) = ( ( resid / dble( max( 1, n ) ) ) / anorm ) / eps
209 ELSE
210 result( 1 ) = zero
211 END IF
212*
213* Compute I - Q*Q'
214*
215 CALL zlaset( 'Full', m, m, dcmplx( zero ), dcmplx( one ), l, lda )
216 CALL zherk( 'Upper', 'No transpose', m, n, -one, q, lda, one, l,
217 $ lda )
218*
219* Compute norm( I - Q*Q' ) / ( N * EPS ) .
220*
221 resid = zlansy( '1', 'Upper', m, l, lda, rwork )
222*
223 result( 2 ) = ( resid / dble( max( 1, n ) ) ) / eps
224*
225 RETURN
226*
227* End of ZLQT02
228*

◆ zlqt03()

subroutine zlqt03 ( integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) af,
complex*16, dimension( lda, * ) c,
complex*16, dimension( lda, * ) cc,
complex*16, dimension( lda, * ) q,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result )

ZLQT03

Purpose:
!>
!> ZLQT03 tests ZUNMLQ, which computes Q*C, Q'*C, C*Q or C*Q'.
!>
!> ZLQT03 compares the results of a call to ZUNMLQ with the results of
!> forming Q explicitly by a call to ZUNGLQ and then performing matrix
!> multiplication by a call to ZGEMM.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows or columns of the matrix C; C is n-by-m if
!>          Q is applied from the left, or m-by-n if Q is applied from
!>          the right.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The order of the orthogonal matrix Q.  N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines the
!>          orthogonal matrix Q.  N >= K >= 0.
!>
[in]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the LQ factorization of an m-by-n matrix, as
!>          returned by ZGELQF. See CGELQF for further details.
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDA,N)
!>
[out]CC
!>          CC is COMPLEX*16 array, dimension (LDA,N)
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDA,N)
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays AF, C, CC, and Q.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors corresponding
!>          to the LQ factorization in AF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of WORK.  LWORK must be at least M, and should be
!>          M*NB, where NB is the blocksize for this environment.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The test ratios compare two techniques for multiplying a
!>          random matrix C by an n-by-n orthogonal matrix Q.
!>          RESULT(1) = norm( Q*C - Q*C )  / ( N * norm(C) * EPS )
!>          RESULT(2) = norm( C*Q - C*Q )  / ( N * norm(C) * EPS )
!>          RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS )
!>          RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 134 of file zlqt03.f.

136*
137* -- LAPACK test routine --
138* -- LAPACK is a software package provided by Univ. of Tennessee, --
139* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
140*
141* .. Scalar Arguments ..
142 INTEGER K, LDA, LWORK, M, N
143* ..
144* .. Array Arguments ..
145 DOUBLE PRECISION RESULT( * ), RWORK( * )
146 COMPLEX*16 AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
147 $ Q( LDA, * ), TAU( * ), WORK( LWORK )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 DOUBLE PRECISION ZERO, ONE
154 parameter( zero = 0.0d+0, one = 1.0d+0 )
155 COMPLEX*16 ROGUE
156 parameter( rogue = ( -1.0d+10, -1.0d+10 ) )
157* ..
158* .. Local Scalars ..
159 CHARACTER SIDE, TRANS
160 INTEGER INFO, ISIDE, ITRANS, J, MC, NC
161 DOUBLE PRECISION CNORM, EPS, RESID
162* ..
163* .. External Functions ..
164 LOGICAL LSAME
165 DOUBLE PRECISION DLAMCH, ZLANGE
166 EXTERNAL lsame, dlamch, zlange
167* ..
168* .. External Subroutines ..
169 EXTERNAL zgemm, zlacpy, zlarnv, zlaset, zunglq, zunmlq
170* ..
171* .. Local Arrays ..
172 INTEGER ISEED( 4 )
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC dble, dcmplx, max
176* ..
177* .. Scalars in Common ..
178 CHARACTER*32 SRNAMT
179* ..
180* .. Common blocks ..
181 COMMON / srnamc / srnamt
182* ..
183* .. Data statements ..
184 DATA iseed / 1988, 1989, 1990, 1991 /
185* ..
186* .. Executable Statements ..
187*
188 eps = dlamch( 'Epsilon' )
189*
190* Copy the first k rows of the factorization to the array Q
191*
192 CALL zlaset( 'Full', n, n, rogue, rogue, q, lda )
193 CALL zlacpy( 'Upper', k, n-1, af( 1, 2 ), lda, q( 1, 2 ), lda )
194*
195* Generate the n-by-n matrix Q
196*
197 srnamt = 'ZUNGLQ'
198 CALL zunglq( n, n, k, q, lda, tau, work, lwork, info )
199*
200 DO 30 iside = 1, 2
201 IF( iside.EQ.1 ) THEN
202 side = 'L'
203 mc = n
204 nc = m
205 ELSE
206 side = 'R'
207 mc = m
208 nc = n
209 END IF
210*
211* Generate MC by NC matrix C
212*
213 DO 10 j = 1, nc
214 CALL zlarnv( 2, iseed, mc, c( 1, j ) )
215 10 CONTINUE
216 cnorm = zlange( '1', mc, nc, c, lda, rwork )
217 IF( cnorm.EQ.zero )
218 $ cnorm = one
219*
220 DO 20 itrans = 1, 2
221 IF( itrans.EQ.1 ) THEN
222 trans = 'N'
223 ELSE
224 trans = 'C'
225 END IF
226*
227* Copy C
228*
229 CALL zlacpy( 'Full', mc, nc, c, lda, cc, lda )
230*
231* Apply Q or Q' to C
232*
233 srnamt = 'ZUNMLQ'
234 CALL zunmlq( side, trans, mc, nc, k, af, lda, tau, cc, lda,
235 $ work, lwork, info )
236*
237* Form explicit product and subtract
238*
239 IF( lsame( side, 'L' ) ) THEN
240 CALL zgemm( trans, 'No transpose', mc, nc, mc,
241 $ dcmplx( -one ), q, lda, c, lda,
242 $ dcmplx( one ), cc, lda )
243 ELSE
244 CALL zgemm( 'No transpose', trans, mc, nc, nc,
245 $ dcmplx( -one ), c, lda, q, lda,
246 $ dcmplx( one ), cc, lda )
247 END IF
248*
249* Compute error in the difference
250*
251 resid = zlange( '1', mc, nc, cc, lda, rwork )
252 result( ( iside-1 )*2+itrans ) = resid /
253 $ ( dble( max( 1, n ) )*cnorm*eps )
254*
255 20 CONTINUE
256 30 CONTINUE
257*
258 RETURN
259*
260* End of ZLQT03
261*

◆ zpbt01()

subroutine zpbt01 ( character uplo,
integer n,
integer kd,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldafac, * ) afac,
integer ldafac,
double precision, dimension( * ) rwork,
double precision resid )

ZPBT01

Purpose:
!>
!> ZPBT01 reconstructs a Hermitian positive definite band matrix A from
!> its L*L' or U'*U factorization and computes the residual
!>    norm( L*L' - A ) / ( N * norm(A) * EPS ) or
!>    norm( U'*U - A ) / ( N * norm(A) * EPS ),
!> where EPS is the machine epsilon, L' is the conjugate transpose of
!> L, and U' is the conjugate transpose of U.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of super-diagonals of the matrix A if UPLO = 'U',
!>          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original Hermitian band matrix A.  If UPLO = 'U', the
!>          upper triangular part of A is stored as a band matrix; if
!>          UPLO = 'L', the lower triangular part of A is stored.  The
!>          columns of the appropriate triangle are stored in the columns
!>          of A and the diagonals of the triangle are stored in the rows
!>          of A.  See ZPBTRF for further details.
!>
[in]LDA
!>          LDA is INTEGER.
!>          The leading dimension of the array A.  LDA >= max(1,KD+1).
!>
[in]AFAC
!>          AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
!>          The factored form of the matrix A.  AFAC contains the factor
!>          L or U from the L*L' or U'*U factorization in band storage
!>          format, as computed by ZPBTRF.
!>
[in]LDAFAC
!>          LDAFAC is INTEGER
!>          The leading dimension of the array AFAC.
!>          LDAFAC >= max(1,KD+1).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 118 of file zpbt01.f.

120*
121* -- LAPACK test routine --
122* -- LAPACK is a software package provided by Univ. of Tennessee, --
123* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
124*
125* .. Scalar Arguments ..
126 CHARACTER UPLO
127 INTEGER KD, LDA, LDAFAC, N
128 DOUBLE PRECISION RESID
129* ..
130* .. Array Arguments ..
131 DOUBLE PRECISION RWORK( * )
132 COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * )
133* ..
134*
135* =====================================================================
136*
137*
138* .. Parameters ..
139 DOUBLE PRECISION ZERO, ONE
140 parameter( zero = 0.0d+0, one = 1.0d+0 )
141* ..
142* .. Local Scalars ..
143 INTEGER I, J, K, KC, KLEN, ML, MU
144 DOUBLE PRECISION AKK, ANORM, EPS
145* ..
146* .. External Functions ..
147 LOGICAL LSAME
148 DOUBLE PRECISION DLAMCH, ZLANHB
149 COMPLEX*16 ZDOTC
150 EXTERNAL lsame, dlamch, zlanhb, zdotc
151* ..
152* .. External Subroutines ..
153 EXTERNAL zdscal, zher, ztrmv
154* ..
155* .. Intrinsic Functions ..
156 INTRINSIC dble, dimag, max, min
157* ..
158* .. Executable Statements ..
159*
160* Quick exit if N = 0.
161*
162 IF( n.LE.0 ) THEN
163 resid = zero
164 RETURN
165 END IF
166*
167* Exit with RESID = 1/EPS if ANORM = 0.
168*
169 eps = dlamch( 'Epsilon' )
170 anorm = zlanhb( '1', uplo, n, kd, a, lda, rwork )
171 IF( anorm.LE.zero ) THEN
172 resid = one / eps
173 RETURN
174 END IF
175*
176* Check the imaginary parts of the diagonal elements and return with
177* an error code if any are nonzero.
178*
179 IF( lsame( uplo, 'U' ) ) THEN
180 DO 10 j = 1, n
181 IF( dimag( afac( kd+1, j ) ).NE.zero ) THEN
182 resid = one / eps
183 RETURN
184 END IF
185 10 CONTINUE
186 ELSE
187 DO 20 j = 1, n
188 IF( dimag( afac( 1, j ) ).NE.zero ) THEN
189 resid = one / eps
190 RETURN
191 END IF
192 20 CONTINUE
193 END IF
194*
195* Compute the product U'*U, overwriting U.
196*
197 IF( lsame( uplo, 'U' ) ) THEN
198 DO 30 k = n, 1, -1
199 kc = max( 1, kd+2-k )
200 klen = kd + 1 - kc
201*
202* Compute the (K,K) element of the result.
203*
204 akk = zdotc( klen+1, afac( kc, k ), 1, afac( kc, k ), 1 )
205 afac( kd+1, k ) = akk
206*
207* Compute the rest of column K.
208*
209 IF( klen.GT.0 )
210 $ CALL ztrmv( 'Upper', 'Conjugate', 'Non-unit', klen,
211 $ afac( kd+1, k-klen ), ldafac-1,
212 $ afac( kc, k ), 1 )
213*
214 30 CONTINUE
215*
216* UPLO = 'L': Compute the product L*L', overwriting L.
217*
218 ELSE
219 DO 40 k = n, 1, -1
220 klen = min( kd, n-k )
221*
222* Add a multiple of column K of the factor L to each of
223* columns K+1 through N.
224*
225 IF( klen.GT.0 )
226 $ CALL zher( 'Lower', klen, one, afac( 2, k ), 1,
227 $ afac( 1, k+1 ), ldafac-1 )
228*
229* Scale column K by the diagonal element.
230*
231 akk = afac( 1, k )
232 CALL zdscal( klen+1, akk, afac( 1, k ), 1 )
233*
234 40 CONTINUE
235 END IF
236*
237* Compute the difference L*L' - A or U'*U - A.
238*
239 IF( lsame( uplo, 'U' ) ) THEN
240 DO 60 j = 1, n
241 mu = max( 1, kd+2-j )
242 DO 50 i = mu, kd + 1
243 afac( i, j ) = afac( i, j ) - a( i, j )
244 50 CONTINUE
245 60 CONTINUE
246 ELSE
247 DO 80 j = 1, n
248 ml = min( kd+1, n-j+1 )
249 DO 70 i = 1, ml
250 afac( i, j ) = afac( i, j ) - a( i, j )
251 70 CONTINUE
252 80 CONTINUE
253 END IF
254*
255* Compute norm( L*L' - A ) / ( N * norm(A) * EPS )
256*
257 resid = zlanhb( '1', uplo, n, kd, afac, ldafac, rwork )
258*
259 resid = ( ( resid / dble( n ) ) / anorm ) / eps
260*
261 RETURN
262*
263* End of ZPBT01
264*
zdotc
complex *16 function zdotc(n, zx, incx, zy, incy)
ZDOTC
Definition zdotc.f:83
zher
subroutine zher(uplo, n, alpha, x, incx, a, lda)
ZHER
Definition zher.f:135

◆ zpbt02()

subroutine zpbt02 ( character uplo,
integer n,
integer kd,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) rwork,
double precision resid )

ZPBT02

Purpose:
!>
!> ZPBT02 computes the residual for a solution of a Hermitian banded
!> system of equations  A*x = b:
!>    RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS)
!> where EPS is the machine precision.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of super-diagonals of the matrix A if UPLO = 'U',
!>          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides. NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original Hermitian band matrix A.  If UPLO = 'U', the
!>          upper triangular part of A is stored as a band matrix; if
!>          UPLO = 'L', the lower triangular part of A is stored.  The
!>          columns of the appropriate triangle are stored in the columns
!>          of A and the diagonals of the triangle are stored in the rows
!>          of A.  See ZPBTRF for further details.
!>
[in]LDA
!>          LDA is INTEGER.
!>          The leading dimension of the array A.  LDA >= max(1,KD+1).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors for the system of linear
!>          equations.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.   LDX >= max(1,N).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 134 of file zpbt02.f.

136*
137* -- LAPACK test routine --
138* -- LAPACK is a software package provided by Univ. of Tennessee, --
139* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
140*
141* .. Scalar Arguments ..
142 CHARACTER UPLO
143 INTEGER KD, LDA, LDB, LDX, N, NRHS
144 DOUBLE PRECISION RESID
145* ..
146* .. Array Arguments ..
147 DOUBLE PRECISION RWORK( * )
148 COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * )
149* ..
150*
151* =====================================================================
152*
153* .. Parameters ..
154 DOUBLE PRECISION ZERO, ONE
155 parameter( zero = 0.0d+0, one = 1.0d+0 )
156 COMPLEX*16 CONE
157 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
158* ..
159* .. Local Scalars ..
160 INTEGER J
161 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
162* ..
163* .. External Functions ..
164 DOUBLE PRECISION DLAMCH, DZASUM, ZLANHB
165 EXTERNAL dlamch, dzasum, zlanhb
166* ..
167* .. External Subroutines ..
168 EXTERNAL zhbmv
169* ..
170* .. Intrinsic Functions ..
171 INTRINSIC max
172* ..
173* .. Executable Statements ..
174*
175* Quick exit if N = 0 or NRHS = 0.
176*
177 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
178 resid = zero
179 RETURN
180 END IF
181*
182* Exit with RESID = 1/EPS if ANORM = 0.
183*
184 eps = dlamch( 'Epsilon' )
185 anorm = zlanhb( '1', uplo, n, kd, a, lda, rwork )
186 IF( anorm.LE.zero ) THEN
187 resid = one / eps
188 RETURN
189 END IF
190*
191* Compute B - A*X
192*
193 DO 10 j = 1, nrhs
194 CALL zhbmv( uplo, n, kd, -cone, a, lda, x( 1, j ), 1, cone,
195 $ b( 1, j ), 1 )
196 10 CONTINUE
197*
198* Compute the maximum over the number of right hand sides of
199* norm( B - A*X ) / ( norm(A) * norm(X) * EPS )
200*
201 resid = zero
202 DO 20 j = 1, nrhs
203 bnorm = dzasum( n, b( 1, j ), 1 )
204 xnorm = dzasum( n, x( 1, j ), 1 )
205 IF( xnorm.LE.zero ) THEN
206 resid = one / eps
207 ELSE
208 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
209 END IF
210 20 CONTINUE
211*
212 RETURN
213*
214* End of ZPBT02
215*

◆ zpbt05()

subroutine zpbt05 ( character uplo,
integer n,
integer kd,
integer nrhs,
complex*16, dimension( ldab, * ) ab,
integer ldab,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldxact, * ) xact,
integer ldxact,
double precision, dimension( * ) ferr,
double precision, dimension( * ) berr,
double precision, dimension( * ) reslts )

ZPBT05

Purpose:
!>
!> ZPBT05 tests the error bounds from iterative refinement for the
!> computed solution to a system of equations A*X = B, where A is a
!> Hermitian band matrix.
!>
!> RESLTS(1) = test of the error bound
!>           = norm(X - XACT) / ( norm(X) * FERR )
!>
!> A large value is returned if this ratio is not less than one.
!>
!> RESLTS(2) = residual from the iterative refinement routine
!>           = the maximum of BERR / ( NZ*EPS + (*) ), where
!>             (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
!>             and NZ = max. number of nonzeros in any row of A, plus 1
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix A is stored.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows of the matrices X, B, and XACT, and the
!>          order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of super-diagonals of the matrix A if UPLO = 'U',
!>          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of the matrices X, B, and XACT.
!>          NRHS >= 0.
!>
[in]AB
!>          AB is COMPLEX*16 array, dimension (LDAB,N)
!>          The upper or lower triangle of the Hermitian band matrix A,
!>          stored in the first KD+1 rows of the array.  The j-th column
!>          of A is stored in the j-th column of the array AB as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vectors for the system of linear
!>          equations.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors.  Each vector is stored as a
!>          column of the matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in]XACT
!>          XACT is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( NZ*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 169 of file zpbt05.f.

171*
172* -- LAPACK test routine --
173* -- LAPACK is a software package provided by Univ. of Tennessee, --
174* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
175*
176* .. Scalar Arguments ..
177 CHARACTER UPLO
178 INTEGER KD, LDAB, LDB, LDX, LDXACT, N, NRHS
179* ..
180* .. Array Arguments ..
181 DOUBLE PRECISION BERR( * ), FERR( * ), RESLTS( * )
182 COMPLEX*16 AB( LDAB, * ), B( LDB, * ), X( LDX, * ),
183 $ XACT( LDXACT, * )
184* ..
185*
186* =====================================================================
187*
188* .. Parameters ..
189 DOUBLE PRECISION ZERO, ONE
190 parameter( zero = 0.0d+0, one = 1.0d+0 )
191* ..
192* .. Local Scalars ..
193 LOGICAL UPPER
194 INTEGER I, IMAX, J, K, NZ
195 DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
196 COMPLEX*16 ZDUM
197* ..
198* .. External Functions ..
199 LOGICAL LSAME
200 INTEGER IZAMAX
201 DOUBLE PRECISION DLAMCH
202 EXTERNAL lsame, izamax, dlamch
203* ..
204* .. Intrinsic Functions ..
205 INTRINSIC abs, dble, dimag, max, min
206* ..
207* .. Statement Functions ..
208 DOUBLE PRECISION CABS1
209* ..
210* .. Statement Function definitions ..
211 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
212* ..
213* .. Executable Statements ..
214*
215* Quick exit if N = 0 or NRHS = 0.
216*
217 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
218 reslts( 1 ) = zero
219 reslts( 2 ) = zero
220 RETURN
221 END IF
222*
223 eps = dlamch( 'Epsilon' )
224 unfl = dlamch( 'Safe minimum' )
225 ovfl = one / unfl
226 upper = lsame( uplo, 'U' )
227 nz = 2*max( kd, n-1 ) + 1
228*
229* Test 1: Compute the maximum of
230* norm(X - XACT) / ( norm(X) * FERR )
231* over all the vectors X and XACT using the infinity-norm.
232*
233 errbnd = zero
234 DO 30 j = 1, nrhs
235 imax = izamax( n, x( 1, j ), 1 )
236 xnorm = max( cabs1( x( imax, j ) ), unfl )
237 diff = zero
238 DO 10 i = 1, n
239 diff = max( diff, cabs1( x( i, j )-xact( i, j ) ) )
240 10 CONTINUE
241*
242 IF( xnorm.GT.one ) THEN
243 GO TO 20
244 ELSE IF( diff.LE.ovfl*xnorm ) THEN
245 GO TO 20
246 ELSE
247 errbnd = one / eps
248 GO TO 30
249 END IF
250*
251 20 CONTINUE
252 IF( diff / xnorm.LE.ferr( j ) ) THEN
253 errbnd = max( errbnd, ( diff / xnorm ) / ferr( j ) )
254 ELSE
255 errbnd = one / eps
256 END IF
257 30 CONTINUE
258 reslts( 1 ) = errbnd
259*
260* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
261* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
262*
263 DO 90 k = 1, nrhs
264 DO 80 i = 1, n
265 tmp = cabs1( b( i, k ) )
266 IF( upper ) THEN
267 DO 40 j = max( i-kd, 1 ), i - 1
268 tmp = tmp + cabs1( ab( kd+1-i+j, i ) )*
269 $ cabs1( x( j, k ) )
270 40 CONTINUE
271 tmp = tmp + abs( dble( ab( kd+1, i ) ) )*
272 $ cabs1( x( i, k ) )
273 DO 50 j = i + 1, min( i+kd, n )
274 tmp = tmp + cabs1( ab( kd+1+i-j, j ) )*
275 $ cabs1( x( j, k ) )
276 50 CONTINUE
277 ELSE
278 DO 60 j = max( i-kd, 1 ), i - 1
279 tmp = tmp + cabs1( ab( 1+i-j, j ) )*cabs1( x( j, k ) )
280 60 CONTINUE
281 tmp = tmp + abs( dble( ab( 1, i ) ) )*cabs1( x( i, k ) )
282 DO 70 j = i + 1, min( i+kd, n )
283 tmp = tmp + cabs1( ab( 1+j-i, i ) )*cabs1( x( j, k ) )
284 70 CONTINUE
285 END IF
286 IF( i.EQ.1 ) THEN
287 axbi = tmp
288 ELSE
289 axbi = min( axbi, tmp )
290 END IF
291 80 CONTINUE
292 tmp = berr( k ) / ( nz*eps+nz*unfl / max( axbi, nz*unfl ) )
293 IF( k.EQ.1 ) THEN
294 reslts( 2 ) = tmp
295 ELSE
296 reslts( 2 ) = max( reslts( 2 ), tmp )
297 END IF
298 90 CONTINUE
299*
300 RETURN
301*
302* End of ZPBT05
303*

◆ zpot01()

subroutine zpot01 ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldafac, * ) afac,
integer ldafac,
double precision, dimension( * ) rwork,
double precision resid )

ZPOT01

Purpose:
!>
!> ZPOT01 reconstructs a Hermitian positive definite matrix  A  from
!> its L*L' or U'*U factorization and computes the residual
!>    norm( L*L' - A ) / ( N * norm(A) * EPS ) or
!>    norm( U'*U - A ) / ( N * norm(A) * EPS ),
!> where EPS is the machine epsilon, L' is the conjugate transpose of L,
!> and U' is the conjugate transpose of U.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original Hermitian matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N)
!>
[in,out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
!>          On entry, the factor L or U from the L * L**H or U**H * U
!>          factorization of A.
!>          Overwritten with the reconstructed matrix, and then with
!>          the difference L * L**H - A (or U**H * U - A).
!>
[in]LDAFAC
!>          LDAFAC is INTEGER
!>          The leading dimension of the array AFAC.  LDAFAC >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L * L**H - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U**H * U - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 105 of file zpot01.f.

106*
107* -- LAPACK test routine --
108* -- LAPACK is a software package provided by Univ. of Tennessee, --
109* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
110*
111* .. Scalar Arguments ..
112 CHARACTER UPLO
113 INTEGER LDA, LDAFAC, N
114 DOUBLE PRECISION RESID
115* ..
116* .. Array Arguments ..
117 DOUBLE PRECISION RWORK( * )
118 COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * )
119* ..
120*
121* =====================================================================
122*
123* .. Parameters ..
124 DOUBLE PRECISION ZERO, ONE
125 parameter( zero = 0.0d+0, one = 1.0d+0 )
126* ..
127* .. Local Scalars ..
128 INTEGER I, J, K
129 DOUBLE PRECISION ANORM, EPS, TR
130 COMPLEX*16 TC
131* ..
132* .. External Functions ..
133 LOGICAL LSAME
134 DOUBLE PRECISION DLAMCH, ZLANHE
135 COMPLEX*16 ZDOTC
136 EXTERNAL lsame, dlamch, zlanhe, zdotc
137* ..
138* .. External Subroutines ..
139 EXTERNAL zher, zscal, ztrmv
140* ..
141* .. Intrinsic Functions ..
142 INTRINSIC dble, dimag
143* ..
144* .. Executable Statements ..
145*
146* Quick exit if N = 0.
147*
148 IF( n.LE.0 ) THEN
149 resid = zero
150 RETURN
151 END IF
152*
153* Exit with RESID = 1/EPS if ANORM = 0.
154*
155 eps = dlamch( 'Epsilon' )
156 anorm = zlanhe( '1', uplo, n, a, lda, rwork )
157 IF( anorm.LE.zero ) THEN
158 resid = one / eps
159 RETURN
160 END IF
161*
162* Check the imaginary parts of the diagonal elements and return with
163* an error code if any are nonzero.
164*
165 DO 10 j = 1, n
166 IF( dimag( afac( j, j ) ).NE.zero ) THEN
167 resid = one / eps
168 RETURN
169 END IF
170 10 CONTINUE
171*
172* Compute the product U**H * U, overwriting U.
173*
174 IF( lsame( uplo, 'U' ) ) THEN
175 DO 20 k = n, 1, -1
176*
177* Compute the (K,K) element of the result.
178*
179 tr = zdotc( k, afac( 1, k ), 1, afac( 1, k ), 1 )
180 afac( k, k ) = tr
181*
182* Compute the rest of column K.
183*
184 CALL ztrmv( 'Upper', 'Conjugate', 'Non-unit', k-1, afac,
185 $ ldafac, afac( 1, k ), 1 )
186*
187 20 CONTINUE
188*
189* Compute the product L * L**H, overwriting L.
190*
191 ELSE
192 DO 30 k = n, 1, -1
193*
194* Add a multiple of column K of the factor L to each of
195* columns K+1 through N.
196*
197 IF( k+1.LE.n )
198 $ CALL zher( 'Lower', n-k, one, afac( k+1, k ), 1,
199 $ afac( k+1, k+1 ), ldafac )
200*
201* Scale column K by the diagonal element.
202*
203 tc = afac( k, k )
204 CALL zscal( n-k+1, tc, afac( k, k ), 1 )
205*
206 30 CONTINUE
207 END IF
208*
209* Compute the difference L * L**H - A (or U**H * U - A).
210*
211 IF( lsame( uplo, 'U' ) ) THEN
212 DO 50 j = 1, n
213 DO 40 i = 1, j - 1
214 afac( i, j ) = afac( i, j ) - a( i, j )
215 40 CONTINUE
216 afac( j, j ) = afac( j, j ) - dble( a( j, j ) )
217 50 CONTINUE
218 ELSE
219 DO 70 j = 1, n
220 afac( j, j ) = afac( j, j ) - dble( a( j, j ) )
221 DO 60 i = j + 1, n
222 afac( i, j ) = afac( i, j ) - a( i, j )
223 60 CONTINUE
224 70 CONTINUE
225 END IF
226*
227* Compute norm(L*U - A) / ( N * norm(A) * EPS )
228*
229 resid = zlanhe( '1', uplo, n, afac, ldafac, rwork )
230*
231 resid = ( ( resid / dble( n ) ) / anorm ) / eps
232*
233 RETURN
234*
235* End of ZPOT01
236*

◆ zpot02()

subroutine zpot02 ( character uplo,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) rwork,
double precision resid )

ZPOT02

Purpose:
!>
!> ZPOT02 computes the residual for the solution of a Hermitian system
!> of linear equations  A*x = b:
!>
!>    RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ),
!>
!> where EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of B, the matrix of right hand sides.
!>          NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original Hermitian matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N)
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors for the system of linear
!>          equations.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.   LDX >= max(1,N).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 125 of file zpot02.f.

127*
128* -- LAPACK test routine --
129* -- LAPACK is a software package provided by Univ. of Tennessee, --
130* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
131*
132* .. Scalar Arguments ..
133 CHARACTER UPLO
134 INTEGER LDA, LDB, LDX, N, NRHS
135 DOUBLE PRECISION RESID
136* ..
137* .. Array Arguments ..
138 DOUBLE PRECISION RWORK( * )
139 COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * )
140* ..
141*
142* =====================================================================
143*
144* .. Parameters ..
145 DOUBLE PRECISION ZERO, ONE
146 parameter( zero = 0.0d+0, one = 1.0d+0 )
147 COMPLEX*16 CONE
148 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
149* ..
150* .. Local Scalars ..
151 INTEGER J
152 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
153* ..
154* .. External Functions ..
155 DOUBLE PRECISION DLAMCH, DZASUM, ZLANHE
156 EXTERNAL dlamch, dzasum, zlanhe
157* ..
158* .. External Subroutines ..
159 EXTERNAL zhemm
160* ..
161* .. Intrinsic Functions ..
162 INTRINSIC max
163* ..
164* .. Executable Statements ..
165*
166* Quick exit if N = 0 or NRHS = 0.
167*
168 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
169 resid = zero
170 RETURN
171 END IF
172*
173* Exit with RESID = 1/EPS if ANORM = 0.
174*
175 eps = dlamch( 'Epsilon' )
176 anorm = zlanhe( '1', uplo, n, a, lda, rwork )
177 IF( anorm.LE.zero ) THEN
178 resid = one / eps
179 RETURN
180 END IF
181*
182* Compute B - A*X
183*
184 CALL zhemm( 'Left', uplo, n, nrhs, -cone, a, lda, x, ldx, cone, b,
185 $ ldb )
186*
187* Compute the maximum over the number of right hand sides of
188* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) .
189*
190 resid = zero
191 DO 10 j = 1, nrhs
192 bnorm = dzasum( n, b( 1, j ), 1 )
193 xnorm = dzasum( n, x( 1, j ), 1 )
194 IF( xnorm.LE.zero ) THEN
195 resid = one / eps
196 ELSE
197 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
198 END IF
199 10 CONTINUE
200*
201 RETURN
202*
203* End of ZPOT02
204*

◆ zpot03()

subroutine zpot03 ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldainv, * ) ainv,
integer ldainv,
complex*16, dimension( ldwork, * ) work,
integer ldwork,
double precision, dimension( * ) rwork,
double precision rcond,
double precision resid )

ZPOT03

Purpose:
!>
!> ZPOT03 computes the residual for a Hermitian matrix times its
!> inverse:
!>    norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ),
!> where EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original Hermitian matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N)
!>
[in,out]AINV
!>          AINV is COMPLEX*16 array, dimension (LDAINV,N)
!>          On entry, the inverse of the matrix A, stored as a Hermitian
!>          matrix in the same format as A.
!>          In this version, AINV is expanded into a full matrix and
!>          multiplied by A, so the opposing triangle of AINV will be
!>          changed; i.e., if the upper triangular part of AINV is
!>          stored, the lower triangular part will be used as work space.
!>
[in]LDAINV
!>          LDAINV is INTEGER
!>          The leading dimension of the array AINV.  LDAINV >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LDWORK,N)
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.  LDWORK >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of A, computed as
!>          ( 1/norm(A) ) / norm(AINV).
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file zpot03.f.

126*
127* -- LAPACK test routine --
128* -- LAPACK is a software package provided by Univ. of Tennessee, --
129* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
130*
131* .. Scalar Arguments ..
132 CHARACTER UPLO
133 INTEGER LDA, LDAINV, LDWORK, N
134 DOUBLE PRECISION RCOND, RESID
135* ..
136* .. Array Arguments ..
137 DOUBLE PRECISION RWORK( * )
138 COMPLEX*16 A( LDA, * ), AINV( LDAINV, * ),
139 $ WORK( LDWORK, * )
140* ..
141*
142* =====================================================================
143*
144* .. Parameters ..
145 DOUBLE PRECISION ZERO, ONE
146 parameter( zero = 0.0d+0, one = 1.0d+0 )
147 COMPLEX*16 CZERO, CONE
148 parameter( czero = ( 0.0d+0, 0.0d+0 ),
149 $ cone = ( 1.0d+0, 0.0d+0 ) )
150* ..
151* .. Local Scalars ..
152 INTEGER I, J
153 DOUBLE PRECISION AINVNM, ANORM, EPS
154* ..
155* .. External Functions ..
156 LOGICAL LSAME
157 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANHE
158 EXTERNAL lsame, dlamch, zlange, zlanhe
159* ..
160* .. External Subroutines ..
161 EXTERNAL zhemm
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC dble, dconjg
165* ..
166* .. Executable Statements ..
167*
168* Quick exit if N = 0.
169*
170 IF( n.LE.0 ) THEN
171 rcond = one
172 resid = zero
173 RETURN
174 END IF
175*
176* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
177*
178 eps = dlamch( 'Epsilon' )
179 anorm = zlanhe( '1', uplo, n, a, lda, rwork )
180 ainvnm = zlanhe( '1', uplo, n, ainv, ldainv, rwork )
181 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
182 rcond = zero
183 resid = one / eps
184 RETURN
185 END IF
186 rcond = ( one / anorm ) / ainvnm
187*
188* Expand AINV into a full matrix and call ZHEMM to multiply
189* AINV on the left by A.
190*
191 IF( lsame( uplo, 'U' ) ) THEN
192 DO 20 j = 1, n
193 DO 10 i = 1, j - 1
194 ainv( j, i ) = dconjg( ainv( i, j ) )
195 10 CONTINUE
196 20 CONTINUE
197 ELSE
198 DO 40 j = 1, n
199 DO 30 i = j + 1, n
200 ainv( j, i ) = dconjg( ainv( i, j ) )
201 30 CONTINUE
202 40 CONTINUE
203 END IF
204 CALL zhemm( 'Left', uplo, n, n, -cone, a, lda, ainv, ldainv,
205 $ czero, work, ldwork )
206*
207* Add the identity matrix to WORK .
208*
209 DO 50 i = 1, n
210 work( i, i ) = work( i, i ) + cone
211 50 CONTINUE
212*
213* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS)
214*
215 resid = zlange( '1', n, n, work, ldwork, rwork )
216*
217 resid = ( ( resid*rcond ) / eps ) / dble( n )
218*
219 RETURN
220*
221* End of ZPOT03
222*

◆ zpot05()

subroutine zpot05 ( character uplo,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldxact, * ) xact,
integer ldxact,
double precision, dimension( * ) ferr,
double precision, dimension( * ) berr,
double precision, dimension( * ) reslts )

ZPOT05

Purpose:
!>
!> ZPOT05 tests the error bounds from iterative refinement for the
!> computed solution to a system of equations A*X = B, where A is a
!> Hermitian n by n matrix.
!>
!> RESLTS(1) = test of the error bound
!>           = norm(X - XACT) / ( norm(X) * FERR )
!>
!> A large value is returned if this ratio is not less than one.
!>
!> RESLTS(2) = residual from the iterative refinement routine
!>           = the maximum of BERR / ( (n+1)*EPS + (*) ), where
!>             (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix A is stored.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows of the matrices X, B, and XACT, and the
!>          order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of the matrices X, B, and XACT.
!>          NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The Hermitian matrix A.  If UPLO = 'U', the leading n by n
!>          upper triangular part of A contains the upper triangular part
!>          of the matrix A, and the strictly lower triangular part of A
!>          is not referenced.  If UPLO = 'L', the leading n by n lower
!>          triangular part of A contains the lower triangular part of
!>          the matrix A, and the strictly upper triangular part of A is
!>          not referenced.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vectors for the system of linear
!>          equations.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors.  Each vector is stored as a
!>          column of the matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in]XACT
!>          XACT is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 163 of file zpot05.f.

165*
166* -- LAPACK test routine --
167* -- LAPACK is a software package provided by Univ. of Tennessee, --
168* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
169*
170* .. Scalar Arguments ..
171 CHARACTER UPLO
172 INTEGER LDA, LDB, LDX, LDXACT, N, NRHS
173* ..
174* .. Array Arguments ..
175 DOUBLE PRECISION BERR( * ), FERR( * ), RESLTS( * )
176 COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ),
177 $ XACT( LDXACT, * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 DOUBLE PRECISION ZERO, ONE
184 parameter( zero = 0.0d+0, one = 1.0d+0 )
185* ..
186* .. Local Scalars ..
187 LOGICAL UPPER
188 INTEGER I, IMAX, J, K
189 DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
190 COMPLEX*16 ZDUM
191* ..
192* .. External Functions ..
193 LOGICAL LSAME
194 INTEGER IZAMAX
195 DOUBLE PRECISION DLAMCH
196 EXTERNAL lsame, izamax, dlamch
197* ..
198* .. Intrinsic Functions ..
199 INTRINSIC abs, dble, dimag, max, min
200* ..
201* .. Statement Functions ..
202 DOUBLE PRECISION CABS1
203* ..
204* .. Statement Function definitions ..
205 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
206* ..
207* .. Executable Statements ..
208*
209* Quick exit if N = 0 or NRHS = 0.
210*
211 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
212 reslts( 1 ) = zero
213 reslts( 2 ) = zero
214 RETURN
215 END IF
216*
217 eps = dlamch( 'Epsilon' )
218 unfl = dlamch( 'Safe minimum' )
219 ovfl = one / unfl
220 upper = lsame( uplo, 'U' )
221*
222* Test 1: Compute the maximum of
223* norm(X - XACT) / ( norm(X) * FERR )
224* over all the vectors X and XACT using the infinity-norm.
225*
226 errbnd = zero
227 DO 30 j = 1, nrhs
228 imax = izamax( n, x( 1, j ), 1 )
229 xnorm = max( cabs1( x( imax, j ) ), unfl )
230 diff = zero
231 DO 10 i = 1, n
232 diff = max( diff, cabs1( x( i, j )-xact( i, j ) ) )
233 10 CONTINUE
234*
235 IF( xnorm.GT.one ) THEN
236 GO TO 20
237 ELSE IF( diff.LE.ovfl*xnorm ) THEN
238 GO TO 20
239 ELSE
240 errbnd = one / eps
241 GO TO 30
242 END IF
243*
244 20 CONTINUE
245 IF( diff / xnorm.LE.ferr( j ) ) THEN
246 errbnd = max( errbnd, ( diff / xnorm ) / ferr( j ) )
247 ELSE
248 errbnd = one / eps
249 END IF
250 30 CONTINUE
251 reslts( 1 ) = errbnd
252*
253* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
254* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
255*
256 DO 90 k = 1, nrhs
257 DO 80 i = 1, n
258 tmp = cabs1( b( i, k ) )
259 IF( upper ) THEN
260 DO 40 j = 1, i - 1
261 tmp = tmp + cabs1( a( j, i ) )*cabs1( x( j, k ) )
262 40 CONTINUE
263 tmp = tmp + abs( dble( a( i, i ) ) )*cabs1( x( i, k ) )
264 DO 50 j = i + 1, n
265 tmp = tmp + cabs1( a( i, j ) )*cabs1( x( j, k ) )
266 50 CONTINUE
267 ELSE
268 DO 60 j = 1, i - 1
269 tmp = tmp + cabs1( a( i, j ) )*cabs1( x( j, k ) )
270 60 CONTINUE
271 tmp = tmp + abs( dble( a( i, i ) ) )*cabs1( x( i, k ) )
272 DO 70 j = i + 1, n
273 tmp = tmp + cabs1( a( j, i ) )*cabs1( x( j, k ) )
274 70 CONTINUE
275 END IF
276 IF( i.EQ.1 ) THEN
277 axbi = tmp
278 ELSE
279 axbi = min( axbi, tmp )
280 END IF
281 80 CONTINUE
282 tmp = berr( k ) / ( ( n+1 )*eps+( n+1 )*unfl /
283 $ max( axbi, ( n+1 )*unfl ) )
284 IF( k.EQ.1 ) THEN
285 reslts( 2 ) = tmp
286 ELSE
287 reslts( 2 ) = max( reslts( 2 ), tmp )
288 END IF
289 90 CONTINUE
290*
291 RETURN
292*
293* End of ZPOT05
294*

◆ zpot06()

subroutine zpot06 ( character uplo,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) rwork,
double precision resid )

ZPOT06

Purpose:
!>
!> ZPOT06 computes the residual for a solution of a system of linear
!> equations  A*x = b :
!>    RESID = norm(B - A*X,inf) / ( norm(A,inf) * norm(X,inf) * EPS ),
!> where EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of B, the matrix of right hand sides.
!>          NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original M x N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors for the system of linear
!>          equations.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  If TRANS = 'N',
!>          LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,N).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  IF TRANS = 'N',
!>          LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 125 of file zpot06.f.

127*
128* -- LAPACK test routine --
129* -- LAPACK is a software package provided by Univ. of Tennessee, --
130* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
131*
132* .. Scalar Arguments ..
133 CHARACTER UPLO
134 INTEGER LDA, LDB, LDX, N, NRHS
135 DOUBLE PRECISION RESID
136* ..
137* .. Array Arguments ..
138 DOUBLE PRECISION RWORK( * )
139 COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * )
140* ..
141*
142* =====================================================================
143*
144* .. Parameters ..
145 DOUBLE PRECISION ZERO, ONE
146 parameter( zero = 0.0d+0, one = 1.0d+0 )
147 COMPLEX*16 CONE, NEGCONE
148 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
149 parameter( negcone = ( -1.0d+0, 0.0d+0 ) )
150* ..
151* .. Local Scalars ..
152 INTEGER IFAIL, J
153 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
154 COMPLEX*16 ZDUM
155* ..
156* .. External Functions ..
157 LOGICAL LSAME
158 INTEGER IZAMAX
159 DOUBLE PRECISION DLAMCH, ZLANSY
160 EXTERNAL lsame, izamax, dlamch, zlansy
161* ..
162* .. External Subroutines ..
163 EXTERNAL zhemm
164* ..
165* .. Intrinsic Functions ..
166 INTRINSIC abs, dble, dimag, max
167* ..
168* .. Statement Functions ..
169 DOUBLE PRECISION CABS1
170* ..
171* .. Statement Function definitions ..
172 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
173* ..
174* ..
175* .. Executable Statements ..
176*
177* Quick exit if N = 0 or NRHS = 0
178*
179 IF( n.LE.0 .OR. nrhs.EQ.0 ) THEN
180 resid = zero
181 RETURN
182 END IF
183*
184* Exit with RESID = 1/EPS if ANORM = 0.
185*
186 eps = dlamch( 'Epsilon' )
187 anorm = zlansy( 'I', uplo, n, a, lda, rwork )
188 IF( anorm.LE.zero ) THEN
189 resid = one / eps
190 RETURN
191 END IF
192*
193* Compute B - A*X and store in B.
194 ifail=0
195*
196 CALL zhemm( 'Left', uplo, n, nrhs, negcone, a, lda, x,
197 $ ldx, cone, b, ldb )
198*
199* Compute the maximum over the number of right hand sides of
200* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) .
201*
202 resid = zero
203 DO 10 j = 1, nrhs
204 bnorm = cabs1(b(izamax( n, b( 1, j ), 1 ),j))
205 xnorm = cabs1(x(izamax( n, x( 1, j ), 1 ),j))
206 IF( xnorm.LE.zero ) THEN
207 resid = one / eps
208 ELSE
209 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
210 END IF
211 10 CONTINUE
212*
213 RETURN
214*
215* End of ZPOT06
216*

◆ zppt01()

subroutine zppt01 ( character uplo,
integer n,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
double precision, dimension( * ) rwork,
double precision resid )

ZPPT01

Purpose:
!>
!> ZPPT01 reconstructs a Hermitian positive definite packed matrix A
!> from its L*L' or U'*U factorization and computes the residual
!>    norm( L*L' - A ) / ( N * norm(A) * EPS ) or
!>    norm( U'*U - A ) / ( N * norm(A) * EPS ),
!> where EPS is the machine epsilon, L' is the conjugate transpose of
!> L, and U' is the conjugate transpose of U.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The original Hermitian matrix A, stored as a packed
!>          triangular matrix.
!>
[in,out]AFAC
!>          AFAC is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          On entry, the factor L or U from the L*L' or U'*U
!>          factorization of A, stored as a packed triangular matrix.
!>          Overwritten with the reconstructed matrix, and then with the
!>          difference L*L' - A (or U'*U - A).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 94 of file zppt01.f.

95*
96* -- LAPACK test routine --
97* -- LAPACK is a software package provided by Univ. of Tennessee, --
98* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
99*
100* .. Scalar Arguments ..
101 CHARACTER UPLO
102 INTEGER N
103 DOUBLE PRECISION RESID
104* ..
105* .. Array Arguments ..
106 DOUBLE PRECISION RWORK( * )
107 COMPLEX*16 A( * ), AFAC( * )
108* ..
109*
110* =====================================================================
111*
112* .. Parameters ..
113 DOUBLE PRECISION ZERO, ONE
114 parameter( zero = 0.0d+0, one = 1.0d+0 )
115* ..
116* .. Local Scalars ..
117 INTEGER I, K, KC
118 DOUBLE PRECISION ANORM, EPS, TR
119 COMPLEX*16 TC
120* ..
121* .. External Functions ..
122 LOGICAL LSAME
123 DOUBLE PRECISION DLAMCH, ZLANHP
124 COMPLEX*16 ZDOTC
125 EXTERNAL lsame, dlamch, zlanhp, zdotc
126* ..
127* .. External Subroutines ..
128 EXTERNAL zhpr, zscal, ztpmv
129* ..
130* .. Intrinsic Functions ..
131 INTRINSIC dble, dimag
132* ..
133* .. Executable Statements ..
134*
135* Quick exit if N = 0
136*
137 IF( n.LE.0 ) THEN
138 resid = zero
139 RETURN
140 END IF
141*
142* Exit with RESID = 1/EPS if ANORM = 0.
143*
144 eps = dlamch( 'Epsilon' )
145 anorm = zlanhp( '1', uplo, n, a, rwork )
146 IF( anorm.LE.zero ) THEN
147 resid = one / eps
148 RETURN
149 END IF
150*
151* Check the imaginary parts of the diagonal elements and return with
152* an error code if any are nonzero.
153*
154 kc = 1
155 IF( lsame( uplo, 'U' ) ) THEN
156 DO 10 k = 1, n
157 IF( dimag( afac( kc ) ).NE.zero ) THEN
158 resid = one / eps
159 RETURN
160 END IF
161 kc = kc + k + 1
162 10 CONTINUE
163 ELSE
164 DO 20 k = 1, n
165 IF( dimag( afac( kc ) ).NE.zero ) THEN
166 resid = one / eps
167 RETURN
168 END IF
169 kc = kc + n - k + 1
170 20 CONTINUE
171 END IF
172*
173* Compute the product U'*U, overwriting U.
174*
175 IF( lsame( uplo, 'U' ) ) THEN
176 kc = ( n*( n-1 ) ) / 2 + 1
177 DO 30 k = n, 1, -1
178*
179* Compute the (K,K) element of the result.
180*
181 tr = zdotc( k, afac( kc ), 1, afac( kc ), 1 )
182 afac( kc+k-1 ) = tr
183*
184* Compute the rest of column K.
185*
186 IF( k.GT.1 ) THEN
187 CALL ztpmv( 'Upper', 'Conjugate', 'Non-unit', k-1, afac,
188 $ afac( kc ), 1 )
189 kc = kc - ( k-1 )
190 END IF
191 30 CONTINUE
192*
193* Compute the difference L*L' - A
194*
195 kc = 1
196 DO 50 k = 1, n
197 DO 40 i = 1, k - 1
198 afac( kc+i-1 ) = afac( kc+i-1 ) - a( kc+i-1 )
199 40 CONTINUE
200 afac( kc+k-1 ) = afac( kc+k-1 ) - dble( a( kc+k-1 ) )
201 kc = kc + k
202 50 CONTINUE
203*
204* Compute the product L*L', overwriting L.
205*
206 ELSE
207 kc = ( n*( n+1 ) ) / 2
208 DO 60 k = n, 1, -1
209*
210* Add a multiple of column K of the factor L to each of
211* columns K+1 through N.
212*
213 IF( k.LT.n )
214 $ CALL zhpr( 'Lower', n-k, one, afac( kc+1 ), 1,
215 $ afac( kc+n-k+1 ) )
216*
217* Scale column K by the diagonal element.
218*
219 tc = afac( kc )
220 CALL zscal( n-k+1, tc, afac( kc ), 1 )
221*
222 kc = kc - ( n-k+2 )
223 60 CONTINUE
224*
225* Compute the difference U'*U - A
226*
227 kc = 1
228 DO 80 k = 1, n
229 afac( kc ) = afac( kc ) - dble( a( kc ) )
230 DO 70 i = k + 1, n
231 afac( kc+i-k ) = afac( kc+i-k ) - a( kc+i-k )
232 70 CONTINUE
233 kc = kc + n - k + 1
234 80 CONTINUE
235 END IF
236*
237* Compute norm( L*U - A ) / ( N * norm(A) * EPS )
238*
239 resid = zlanhp( '1', uplo, n, afac, rwork )
240*
241 resid = ( ( resid / dble( n ) ) / anorm ) / eps
242*
243 RETURN
244*
245* End of ZPPT01
246*
zhpr
subroutine zhpr(uplo, n, alpha, x, incx, ap)
ZHPR
Definition zhpr.f:130

◆ zppt02()

subroutine zppt02 ( character uplo,
integer n,
integer nrhs,
complex*16, dimension( * ) a,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) rwork,
double precision resid )

ZPPT02

Purpose:
!>
!> ZPPT02 computes the residual in the solution of a Hermitian system
!> of linear equations  A*x = b  when packed storage is used for the
!> coefficient matrix.  The ratio computed is
!>
!>    RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS),
!>
!> where EPS is the machine precision.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of B, the matrix of right hand sides.
!>          NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The original Hermitian matrix A, stored as a packed
!>          triangular matrix.
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors for the system of linear
!>          equations.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.   LDX >= max(1,N).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 121 of file zppt02.f.

123*
124* -- LAPACK test routine --
125* -- LAPACK is a software package provided by Univ. of Tennessee, --
126* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
127*
128* .. Scalar Arguments ..
129 CHARACTER UPLO
130 INTEGER LDB, LDX, N, NRHS
131 DOUBLE PRECISION RESID
132* ..
133* .. Array Arguments ..
134 DOUBLE PRECISION RWORK( * )
135 COMPLEX*16 A( * ), B( LDB, * ), X( LDX, * )
136* ..
137*
138* =====================================================================
139*
140* .. Parameters ..
141 DOUBLE PRECISION ZERO, ONE
142 parameter( zero = 0.0d+0, one = 1.0d+0 )
143 COMPLEX*16 CONE
144 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
145* ..
146* .. Local Scalars ..
147 INTEGER J
148 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
149* ..
150* .. External Functions ..
151 DOUBLE PRECISION DLAMCH, DZASUM, ZLANHP
152 EXTERNAL dlamch, dzasum, zlanhp
153* ..
154* .. External Subroutines ..
155 EXTERNAL zhpmv
156* ..
157* .. Intrinsic Functions ..
158 INTRINSIC max
159* ..
160* .. Executable Statements ..
161*
162* Quick exit if N = 0 or NRHS = 0.
163*
164 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
165 resid = zero
166 RETURN
167 END IF
168*
169* Exit with RESID = 1/EPS if ANORM = 0.
170*
171 eps = dlamch( 'Epsilon' )
172 anorm = zlanhp( '1', uplo, n, a, rwork )
173 IF( anorm.LE.zero ) THEN
174 resid = one / eps
175 RETURN
176 END IF
177*
178* Compute B - A*X for the matrix of right hand sides B.
179*
180 DO 10 j = 1, nrhs
181 CALL zhpmv( uplo, n, -cone, a, x( 1, j ), 1, cone, b( 1, j ),
182 $ 1 )
183 10 CONTINUE
184*
185* Compute the maximum over the number of right hand sides of
186* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) .
187*
188 resid = zero
189 DO 20 j = 1, nrhs
190 bnorm = dzasum( n, b( 1, j ), 1 )
191 xnorm = dzasum( n, x( 1, j ), 1 )
192 IF( xnorm.LE.zero ) THEN
193 resid = one / eps
194 ELSE
195 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
196 END IF
197 20 CONTINUE
198*
199 RETURN
200*
201* End of ZPPT02
202*

◆ zppt03()

subroutine zppt03 ( character uplo,
integer n,
complex*16, dimension( * ) a,
complex*16, dimension( * ) ainv,
complex*16, dimension( ldwork, * ) work,
integer ldwork,
double precision, dimension( * ) rwork,
double precision rcond,
double precision resid )

ZPPT03

Purpose:
!>
!> ZPPT03 computes the residual for a Hermitian packed matrix times its
!> inverse:
!>    norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ),
!> where EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The original Hermitian matrix A, stored as a packed
!>          triangular matrix.
!>
[in]AINV
!>          AINV is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The (Hermitian) inverse of the matrix A, stored as a packed
!>          triangular matrix.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LDWORK,N)
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.  LDWORK >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of A, computed as
!>          ( 1/norm(A) ) / norm(AINV).
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 108 of file zppt03.f.

110*
111* -- LAPACK test routine --
112* -- LAPACK is a software package provided by Univ. of Tennessee, --
113* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
114*
115* .. Scalar Arguments ..
116 CHARACTER UPLO
117 INTEGER LDWORK, N
118 DOUBLE PRECISION RCOND, RESID
119* ..
120* .. Array Arguments ..
121 DOUBLE PRECISION RWORK( * )
122 COMPLEX*16 A( * ), AINV( * ), WORK( LDWORK, * )
123* ..
124*
125* =====================================================================
126*
127* .. Parameters ..
128 DOUBLE PRECISION ZERO, ONE
129 parameter( zero = 0.0d+0, one = 1.0d+0 )
130 COMPLEX*16 CZERO, CONE
131 parameter( czero = ( 0.0d+0, 0.0d+0 ),
132 $ cone = ( 1.0d+0, 0.0d+0 ) )
133* ..
134* .. Local Scalars ..
135 INTEGER I, J, JJ
136 DOUBLE PRECISION AINVNM, ANORM, EPS
137* ..
138* .. External Functions ..
139 LOGICAL LSAME
140 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANHP
141 EXTERNAL lsame, dlamch, zlange, zlanhp
142* ..
143* .. Intrinsic Functions ..
144 INTRINSIC dble, dconjg
145* ..
146* .. External Subroutines ..
147 EXTERNAL zcopy, zhpmv
148* ..
149* .. Executable Statements ..
150*
151* Quick exit if N = 0.
152*
153 IF( n.LE.0 ) THEN
154 rcond = one
155 resid = zero
156 RETURN
157 END IF
158*
159* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
160*
161 eps = dlamch( 'Epsilon' )
162 anorm = zlanhp( '1', uplo, n, a, rwork )
163 ainvnm = zlanhp( '1', uplo, n, ainv, rwork )
164 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
165 rcond = zero
166 resid = one / eps
167 RETURN
168 END IF
169 rcond = ( one / anorm ) / ainvnm
170*
171* UPLO = 'U':
172* Copy the leading N-1 x N-1 submatrix of AINV to WORK(1:N,2:N) and
173* expand it to a full matrix, then multiply by A one column at a
174* time, moving the result one column to the left.
175*
176 IF( lsame( uplo, 'U' ) ) THEN
177*
178* Copy AINV
179*
180 jj = 1
181 DO 20 j = 1, n - 1
182 CALL zcopy( j, ainv( jj ), 1, work( 1, j+1 ), 1 )
183 DO 10 i = 1, j - 1
184 work( j, i+1 ) = dconjg( ainv( jj+i-1 ) )
185 10 CONTINUE
186 jj = jj + j
187 20 CONTINUE
188 jj = ( ( n-1 )*n ) / 2 + 1
189 DO 30 i = 1, n - 1
190 work( n, i+1 ) = dconjg( ainv( jj+i-1 ) )
191 30 CONTINUE
192*
193* Multiply by A
194*
195 DO 40 j = 1, n - 1
196 CALL zhpmv( 'Upper', n, -cone, a, work( 1, j+1 ), 1, czero,
197 $ work( 1, j ), 1 )
198 40 CONTINUE
199 CALL zhpmv( 'Upper', n, -cone, a, ainv( jj ), 1, czero,
200 $ work( 1, n ), 1 )
201*
202* UPLO = 'L':
203* Copy the trailing N-1 x N-1 submatrix of AINV to WORK(1:N,1:N-1)
204* and multiply by A, moving each column to the right.
205*
206 ELSE
207*
208* Copy AINV
209*
210 DO 50 i = 1, n - 1
211 work( 1, i ) = dconjg( ainv( i+1 ) )
212 50 CONTINUE
213 jj = n + 1
214 DO 70 j = 2, n
215 CALL zcopy( n-j+1, ainv( jj ), 1, work( j, j-1 ), 1 )
216 DO 60 i = 1, n - j
217 work( j, j+i-1 ) = dconjg( ainv( jj+i ) )
218 60 CONTINUE
219 jj = jj + n - j + 1
220 70 CONTINUE
221*
222* Multiply by A
223*
224 DO 80 j = n, 2, -1
225 CALL zhpmv( 'Lower', n, -cone, a, work( 1, j-1 ), 1, czero,
226 $ work( 1, j ), 1 )
227 80 CONTINUE
228 CALL zhpmv( 'Lower', n, -cone, a, ainv( 1 ), 1, czero,
229 $ work( 1, 1 ), 1 )
230*
231 END IF
232*
233* Add the identity matrix to WORK .
234*
235 DO 90 i = 1, n
236 work( i, i ) = work( i, i ) + cone
237 90 CONTINUE
238*
239* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS)
240*
241 resid = zlange( '1', n, n, work, ldwork, rwork )
242*
243 resid = ( ( resid*rcond ) / eps ) / dble( n )
244*
245 RETURN
246*
247* End of ZPPT03
248*

◆ zppt05()

subroutine zppt05 ( character uplo,
integer n,
integer nrhs,
complex*16, dimension( * ) ap,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldxact, * ) xact,
integer ldxact,
double precision, dimension( * ) ferr,
double precision, dimension( * ) berr,
double precision, dimension( * ) reslts )

ZPPT05

Purpose:
!>
!> ZPPT05 tests the error bounds from iterative refinement for the
!> computed solution to a system of equations A*X = B, where A is a
!> Hermitian matrix in packed storage format.
!>
!> RESLTS(1) = test of the error bound
!>           = norm(X - XACT) / ( norm(X) * FERR )
!>
!> A large value is returned if this ratio is not less than one.
!>
!> RESLTS(2) = residual from the iterative refinement routine
!>           = the maximum of BERR / ( (n+1)*EPS + (*) ), where
!>             (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix A is stored.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows of the matrices X, B, and XACT, and the
!>          order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of the matrices X, B, and XACT.
!>          NRHS >= 0.
!>
[in]AP
!>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The upper or lower triangle of the Hermitian matrix A, packed
!>          columnwise in a linear array.  The j-th column of A is stored
!>          in the array AP as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vectors for the system of linear
!>          equations.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors.  Each vector is stored as a
!>          column of the matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in]XACT
!>          XACT is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 155 of file zppt05.f.

157*
158* -- LAPACK test routine --
159* -- LAPACK is a software package provided by Univ. of Tennessee, --
160* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
161*
162* .. Scalar Arguments ..
163 CHARACTER UPLO
164 INTEGER LDB, LDX, LDXACT, N, NRHS
165* ..
166* .. Array Arguments ..
167 DOUBLE PRECISION BERR( * ), FERR( * ), RESLTS( * )
168 COMPLEX*16 AP( * ), B( LDB, * ), X( LDX, * ),
169 $ XACT( LDXACT, * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 DOUBLE PRECISION ZERO, ONE
176 parameter( zero = 0.0d+0, one = 1.0d+0 )
177* ..
178* .. Local Scalars ..
179 LOGICAL UPPER
180 INTEGER I, IMAX, J, JC, K
181 DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
182 COMPLEX*16 ZDUM
183* ..
184* .. External Functions ..
185 LOGICAL LSAME
186 INTEGER IZAMAX
187 DOUBLE PRECISION DLAMCH
188 EXTERNAL lsame, izamax, dlamch
189* ..
190* .. Intrinsic Functions ..
191 INTRINSIC abs, dble, dimag, max, min
192* ..
193* .. Statement Functions ..
194 DOUBLE PRECISION CABS1
195* ..
196* .. Statement Function definitions ..
197 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
198* ..
199* .. Executable Statements ..
200*
201* Quick exit if N = 0 or NRHS = 0.
202*
203 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
204 reslts( 1 ) = zero
205 reslts( 2 ) = zero
206 RETURN
207 END IF
208*
209 eps = dlamch( 'Epsilon' )
210 unfl = dlamch( 'Safe minimum' )
211 ovfl = one / unfl
212 upper = lsame( uplo, 'U' )
213*
214* Test 1: Compute the maximum of
215* norm(X - XACT) / ( norm(X) * FERR )
216* over all the vectors X and XACT using the infinity-norm.
217*
218 errbnd = zero
219 DO 30 j = 1, nrhs
220 imax = izamax( n, x( 1, j ), 1 )
221 xnorm = max( cabs1( x( imax, j ) ), unfl )
222 diff = zero
223 DO 10 i = 1, n
224 diff = max( diff, cabs1( x( i, j )-xact( i, j ) ) )
225 10 CONTINUE
226*
227 IF( xnorm.GT.one ) THEN
228 GO TO 20
229 ELSE IF( diff.LE.ovfl*xnorm ) THEN
230 GO TO 20
231 ELSE
232 errbnd = one / eps
233 GO TO 30
234 END IF
235*
236 20 CONTINUE
237 IF( diff / xnorm.LE.ferr( j ) ) THEN
238 errbnd = max( errbnd, ( diff / xnorm ) / ferr( j ) )
239 ELSE
240 errbnd = one / eps
241 END IF
242 30 CONTINUE
243 reslts( 1 ) = errbnd
244*
245* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
246* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
247*
248 DO 90 k = 1, nrhs
249 DO 80 i = 1, n
250 tmp = cabs1( b( i, k ) )
251 IF( upper ) THEN
252 jc = ( ( i-1 )*i ) / 2
253 DO 40 j = 1, i - 1
254 tmp = tmp + cabs1( ap( jc+j ) )*cabs1( x( j, k ) )
255 40 CONTINUE
256 tmp = tmp + abs( dble( ap( jc+i ) ) )*cabs1( x( i, k ) )
257 jc = jc + i + i
258 DO 50 j = i + 1, n
259 tmp = tmp + cabs1( ap( jc ) )*cabs1( x( j, k ) )
260 jc = jc + j
261 50 CONTINUE
262 ELSE
263 jc = i
264 DO 60 j = 1, i - 1
265 tmp = tmp + cabs1( ap( jc ) )*cabs1( x( j, k ) )
266 jc = jc + n - j
267 60 CONTINUE
268 tmp = tmp + abs( dble( ap( jc ) ) )*cabs1( x( i, k ) )
269 DO 70 j = i + 1, n
270 tmp = tmp + cabs1( ap( jc+j-i ) )*cabs1( x( j, k ) )
271 70 CONTINUE
272 END IF
273 IF( i.EQ.1 ) THEN
274 axbi = tmp
275 ELSE
276 axbi = min( axbi, tmp )
277 END IF
278 80 CONTINUE
279 tmp = berr( k ) / ( ( n+1 )*eps+( n+1 )*unfl /
280 $ max( axbi, ( n+1 )*unfl ) )
281 IF( k.EQ.1 ) THEN
282 reslts( 2 ) = tmp
283 ELSE
284 reslts( 2 ) = max( reslts( 2 ), tmp )
285 END IF
286 90 CONTINUE
287*
288 RETURN
289*
290* End of ZPPT05
291*

◆ zpst01()

subroutine zpst01 ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldafac, * ) afac,
integer ldafac,
complex*16, dimension( ldperm, * ) perm,
integer ldperm,
integer, dimension( * ) piv,
double precision, dimension( * ) rwork,
double precision resid,
integer rank )

ZPST01

Purpose:
!>
!> ZPST01 reconstructs an Hermitian positive semidefinite matrix A
!> from its L or U factors and the permutation matrix P and computes
!> the residual
!>    norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or
!>    norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ),
!> where EPS is the machine epsilon, L' is the conjugate transpose of L,
!> and U' is the conjugate transpose of U.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original Hermitian matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N)
!>
[in]AFAC
!>          AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
!>          The factor L or U from the L*L' or U'*U
!>          factorization of A.
!>
[in]LDAFAC
!>          LDAFAC is INTEGER
!>          The leading dimension of the array AFAC.  LDAFAC >= max(1,N).
!>
[out]PERM
!>          PERM is COMPLEX*16 array, dimension (LDPERM,N)
!>          Overwritten with the reconstructed matrix, and then with the
!>          difference P*L*L'*P' - A (or P*U'*U*P' - A)
!>
[in]LDPERM
!>          LDPERM is INTEGER
!>          The leading dimension of the array PERM.
!>          LDAPERM >= max(1,N).
!>
[in]PIV
!>          PIV is INTEGER array, dimension (N)
!>          PIV is such that the nonzero entries are
!>          P( PIV( K ), K ) = 1.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS )
!>
[in]RANK
!>          RANK is INTEGER
!>          number of nonzero singular values of A.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 134 of file zpst01.f.

136*
137* -- LAPACK test routine --
138* -- LAPACK is a software package provided by Univ. of Tennessee, --
139* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
140*
141* .. Scalar Arguments ..
142 DOUBLE PRECISION RESID
143 INTEGER LDA, LDAFAC, LDPERM, N, RANK
144 CHARACTER UPLO
145* ..
146* .. Array Arguments ..
147 COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ),
148 $ PERM( LDPERM, * )
149 DOUBLE PRECISION RWORK( * )
150 INTEGER PIV( * )
151* ..
152*
153* =====================================================================
154*
155* .. Parameters ..
156 DOUBLE PRECISION ZERO, ONE
157 parameter( zero = 0.0d+0, one = 1.0d+0 )
158 COMPLEX*16 CZERO
159 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
160* ..
161* .. Local Scalars ..
162 COMPLEX*16 TC
163 DOUBLE PRECISION ANORM, EPS, TR
164 INTEGER I, J, K
165* ..
166* .. External Functions ..
167 COMPLEX*16 ZDOTC
168 DOUBLE PRECISION DLAMCH, ZLANHE
169 LOGICAL LSAME
170 EXTERNAL zdotc, dlamch, zlanhe, lsame
171* ..
172* .. External Subroutines ..
173 EXTERNAL zher, zscal, ztrmv
174* ..
175* .. Intrinsic Functions ..
176 INTRINSIC dble, dconjg, dimag
177* ..
178* .. Executable Statements ..
179*
180* Quick exit if N = 0.
181*
182 IF( n.LE.0 ) THEN
183 resid = zero
184 RETURN
185 END IF
186*
187* Exit with RESID = 1/EPS if ANORM = 0.
188*
189 eps = dlamch( 'Epsilon' )
190 anorm = zlanhe( '1', uplo, n, a, lda, rwork )
191 IF( anorm.LE.zero ) THEN
192 resid = one / eps
193 RETURN
194 END IF
195*
196* Check the imaginary parts of the diagonal elements and return with
197* an error code if any are nonzero.
198*
199 DO 100 j = 1, n
200 IF( dimag( afac( j, j ) ).NE.zero ) THEN
201 resid = one / eps
202 RETURN
203 END IF
204 100 CONTINUE
205*
206* Compute the product U'*U, overwriting U.
207*
208 IF( lsame( uplo, 'U' ) ) THEN
209*
210 IF( rank.LT.n ) THEN
211 DO 120 j = rank + 1, n
212 DO 110 i = rank + 1, j
213 afac( i, j ) = czero
214 110 CONTINUE
215 120 CONTINUE
216 END IF
217*
218 DO 130 k = n, 1, -1
219*
220* Compute the (K,K) element of the result.
221*
222 tr = zdotc( k, afac( 1, k ), 1, afac( 1, k ), 1 )
223 afac( k, k ) = tr
224*
225* Compute the rest of column K.
226*
227 CALL ztrmv( 'Upper', 'Conjugate', 'Non-unit', k-1, afac,
228 $ ldafac, afac( 1, k ), 1 )
229*
230 130 CONTINUE
231*
232* Compute the product L*L', overwriting L.
233*
234 ELSE
235*
236 IF( rank.LT.n ) THEN
237 DO 150 j = rank + 1, n
238 DO 140 i = j, n
239 afac( i, j ) = czero
240 140 CONTINUE
241 150 CONTINUE
242 END IF
243*
244 DO 160 k = n, 1, -1
245* Add a multiple of column K of the factor L to each of
246* columns K+1 through N.
247*
248 IF( k+1.LE.n )
249 $ CALL zher( 'Lower', n-k, one, afac( k+1, k ), 1,
250 $ afac( k+1, k+1 ), ldafac )
251*
252* Scale column K by the diagonal element.
253*
254 tc = afac( k, k )
255 CALL zscal( n-k+1, tc, afac( k, k ), 1 )
256 160 CONTINUE
257*
258 END IF
259*
260* Form P*L*L'*P' or P*U'*U*P'
261*
262 IF( lsame( uplo, 'U' ) ) THEN
263*
264 DO 180 j = 1, n
265 DO 170 i = 1, n
266 IF( piv( i ).LE.piv( j ) ) THEN
267 IF( i.LE.j ) THEN
268 perm( piv( i ), piv( j ) ) = afac( i, j )
269 ELSE
270 perm( piv( i ), piv( j ) ) = dconjg( afac( j, i ) )
271 END IF
272 END IF
273 170 CONTINUE
274 180 CONTINUE
275*
276*
277 ELSE
278*
279 DO 200 j = 1, n
280 DO 190 i = 1, n
281 IF( piv( i ).GE.piv( j ) ) THEN
282 IF( i.GE.j ) THEN
283 perm( piv( i ), piv( j ) ) = afac( i, j )
284 ELSE
285 perm( piv( i ), piv( j ) ) = dconjg( afac( j, i ) )
286 END IF
287 END IF
288 190 CONTINUE
289 200 CONTINUE
290*
291 END IF
292*
293* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A).
294*
295 IF( lsame( uplo, 'U' ) ) THEN
296 DO 220 j = 1, n
297 DO 210 i = 1, j - 1
298 perm( i, j ) = perm( i, j ) - a( i, j )
299 210 CONTINUE
300 perm( j, j ) = perm( j, j ) - dble( a( j, j ) )
301 220 CONTINUE
302 ELSE
303 DO 240 j = 1, n
304 perm( j, j ) = perm( j, j ) - dble( a( j, j ) )
305 DO 230 i = j + 1, n
306 perm( i, j ) = perm( i, j ) - a( i, j )
307 230 CONTINUE
308 240 CONTINUE
309 END IF
310*
311* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or
312* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ).
313*
314 resid = zlanhe( '1', uplo, n, perm, ldafac, rwork )
315*
316 resid = ( ( resid / dble( n ) ) / anorm ) / eps
317*
318 RETURN
319*
320* End of ZPST01
321*

◆ zptt01()

subroutine zptt01 ( integer n,
double precision, dimension( * ) d,
complex*16, dimension( * ) e,
double precision, dimension( * ) df,
complex*16, dimension( * ) ef,
complex*16, dimension( * ) work,
double precision resid )

ZPTT01

Purpose:
!>
!> ZPTT01 reconstructs a tridiagonal matrix A from its L*D*L'
!> factorization and computes the residual
!>    norm(L*D*L' - A) / ( n * norm(A) * EPS ),
!> where EPS is the machine epsilon.
!>
Parameters
[in]N
!>          N is INTEGTER
!>          The order of the matrix A.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The n diagonal elements of the tridiagonal matrix A.
!>
[in]E
!>          E is COMPLEX*16 array, dimension (N-1)
!>          The (n-1) subdiagonal elements of the tridiagonal matrix A.
!>
[in]DF
!>          DF is DOUBLE PRECISION array, dimension (N)
!>          The n diagonal elements of the factor L from the L*D*L'
!>          factorization of A.
!>
[in]EF
!>          EF is COMPLEX*16 array, dimension (N-1)
!>          The (n-1) subdiagonal elements of the factor L from the
!>          L*D*L' factorization of A.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (2*N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(L*D*L' - A) / (n * norm(A) * EPS)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 91 of file zptt01.f.

92*
93* -- LAPACK test routine --
94* -- LAPACK is a software package provided by Univ. of Tennessee, --
95* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
96*
97* .. Scalar Arguments ..
98 INTEGER N
99 DOUBLE PRECISION RESID
100* ..
101* .. Array Arguments ..
102 DOUBLE PRECISION D( * ), DF( * )
103 COMPLEX*16 E( * ), EF( * ), WORK( * )
104* ..
105*
106* =====================================================================
107*
108* .. Parameters ..
109 DOUBLE PRECISION ONE, ZERO
110 parameter( one = 1.0d+0, zero = 0.0d+0 )
111* ..
112* .. Local Scalars ..
113 INTEGER I
114 DOUBLE PRECISION ANORM, EPS
115 COMPLEX*16 DE
116* ..
117* .. External Functions ..
118 DOUBLE PRECISION DLAMCH
119 EXTERNAL dlamch
120* ..
121* .. Intrinsic Functions ..
122 INTRINSIC abs, dble, dconjg, max
123* ..
124* .. Executable Statements ..
125*
126* Quick return if possible
127*
128 IF( n.LE.0 ) THEN
129 resid = zero
130 RETURN
131 END IF
132*
133 eps = dlamch( 'Epsilon' )
134*
135* Construct the difference L*D*L' - A.
136*
137 work( 1 ) = df( 1 ) - d( 1 )
138 DO 10 i = 1, n - 1
139 de = df( i )*ef( i )
140 work( n+i ) = de - e( i )
141 work( 1+i ) = de*dconjg( ef( i ) ) + df( i+1 ) - d( i+1 )
142 10 CONTINUE
143*
144* Compute the 1-norms of the tridiagonal matrices A and WORK.
145*
146 IF( n.EQ.1 ) THEN
147 anorm = d( 1 )
148 resid = abs( work( 1 ) )
149 ELSE
150 anorm = max( d( 1 )+abs( e( 1 ) ), d( n )+abs( e( n-1 ) ) )
151 resid = max( abs( work( 1 ) )+abs( work( n+1 ) ),
152 $ abs( work( n ) )+abs( work( 2*n-1 ) ) )
153 DO 20 i = 2, n - 1
154 anorm = max( anorm, d( i )+abs( e( i ) )+abs( e( i-1 ) ) )
155 resid = max( resid, abs( work( i ) )+abs( work( n+i-1 ) )+
156 $ abs( work( n+i ) ) )
157 20 CONTINUE
158 END IF
159*
160* Compute norm(L*D*L' - A) / (n * norm(A) * EPS)
161*
162 IF( anorm.LE.zero ) THEN
163 IF( resid.NE.zero )
164 $ resid = one / eps
165 ELSE
166 resid = ( ( resid / dble( n ) ) / anorm ) / eps
167 END IF
168*
169 RETURN
170*
171* End of ZPTT01
172*

◆ zptt02()

subroutine zptt02 ( character uplo,
integer n,
integer nrhs,
double precision, dimension( * ) d,
complex*16, dimension( * ) e,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision resid )

ZPTT02

Purpose:
!>
!> ZPTT02 computes the residual for the solution to a symmetric
!> tridiagonal system of equations:
!>    RESID = norm(B - A*X) / (norm(A) * norm(X) * EPS),
!> where EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the superdiagonal or the subdiagonal of the
!>          tridiagonal matrix A is stored.
!>          = 'U':  E is the superdiagonal of A
!>          = 'L':  E is the subdiagonal of A
!>
[in]N
!>          N is INTEGTER
!>          The order of the matrix A.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices B and X.  NRHS >= 0.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The n diagonal elements of the tridiagonal matrix A.
!>
[in]E
!>          E is COMPLEX*16 array, dimension (N-1)
!>          The (n-1) subdiagonal elements of the tridiagonal matrix A.
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The n by nrhs matrix of solution vectors X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the n by nrhs matrix of right hand side vectors B.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(B - A*X) / (norm(A) * norm(X) * EPS)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 114 of file zptt02.f.

115*
116* -- LAPACK test routine --
117* -- LAPACK is a software package provided by Univ. of Tennessee, --
118* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
119*
120* .. Scalar Arguments ..
121 CHARACTER UPLO
122 INTEGER LDB, LDX, N, NRHS
123 DOUBLE PRECISION RESID
124* ..
125* .. Array Arguments ..
126 DOUBLE PRECISION D( * )
127 COMPLEX*16 B( LDB, * ), E( * ), X( LDX, * )
128* ..
129*
130* =====================================================================
131*
132* .. Parameters ..
133 DOUBLE PRECISION ONE, ZERO
134 parameter( one = 1.0d+0, zero = 0.0d+0 )
135* ..
136* .. Local Scalars ..
137 INTEGER J
138 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
139* ..
140* .. External Functions ..
141 DOUBLE PRECISION DLAMCH, DZASUM, ZLANHT
142 EXTERNAL dlamch, dzasum, zlanht
143* ..
144* .. Intrinsic Functions ..
145 INTRINSIC max
146* ..
147* .. External Subroutines ..
148 EXTERNAL zlaptm
149* ..
150* .. Executable Statements ..
151*
152* Quick return if possible
153*
154 IF( n.LE.0 ) THEN
155 resid = zero
156 RETURN
157 END IF
158*
159* Compute the 1-norm of the tridiagonal matrix A.
160*
161 anorm = zlanht( '1', n, d, e )
162*
163* Exit with RESID = 1/EPS if ANORM = 0.
164*
165 eps = dlamch( 'Epsilon' )
166 IF( anorm.LE.zero ) THEN
167 resid = one / eps
168 RETURN
169 END IF
170*
171* Compute B - A*X.
172*
173 CALL zlaptm( uplo, n, nrhs, -one, d, e, x, ldx, one, b, ldb )
174*
175* Compute the maximum over the number of right hand sides of
176* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
177*
178 resid = zero
179 DO 10 j = 1, nrhs
180 bnorm = dzasum( n, b( 1, j ), 1 )
181 xnorm = dzasum( n, x( 1, j ), 1 )
182 IF( xnorm.LE.zero ) THEN
183 resid = one / eps
184 ELSE
185 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
186 END IF
187 10 CONTINUE
188*
189 RETURN
190*
191* End of ZPTT02
192*

◆ zptt05()

subroutine zptt05 ( integer n,
integer nrhs,
double precision, dimension( * ) d,
complex*16, dimension( * ) e,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldxact, * ) xact,
integer ldxact,
double precision, dimension( * ) ferr,
double precision, dimension( * ) berr,
double precision, dimension( * ) reslts )

ZPTT05

Purpose:
!>
!> ZPTT05 tests the error bounds from iterative refinement for the
!> computed solution to a system of equations A*X = B, where A is a
!> Hermitian tridiagonal matrix of order n.
!>
!> RESLTS(1) = test of the error bound
!>           = norm(X - XACT) / ( norm(X) * FERR )
!>
!> A large value is returned if this ratio is not less than one.
!>
!> RESLTS(2) = residual from the iterative refinement routine
!>           = the maximum of BERR / ( NZ*EPS + (*) ), where
!>             (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
!>             and NZ = max. number of nonzeros in any row of A, plus 1
!>
Parameters
[in]N
!>          N is INTEGER
!>          The number of rows of the matrices X, B, and XACT, and the
!>          order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of the matrices X, B, and XACT.
!>          NRHS >= 0.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The n diagonal elements of the tridiagonal matrix A.
!>
[in]E
!>          E is COMPLEX*16 array, dimension (N-1)
!>          The (n-1) subdiagonal elements of the tridiagonal matrix A.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vectors for the system of linear
!>          equations.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors.  Each vector is stored as a
!>          column of the matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in]XACT
!>          XACT is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( NZ*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 148 of file zptt05.f.

150*
151* -- LAPACK test routine --
152* -- LAPACK is a software package provided by Univ. of Tennessee, --
153* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
154*
155* .. Scalar Arguments ..
156 INTEGER LDB, LDX, LDXACT, N, NRHS
157* ..
158* .. Array Arguments ..
159 DOUBLE PRECISION BERR( * ), D( * ), FERR( * ), RESLTS( * )
160 COMPLEX*16 B( LDB, * ), E( * ), X( LDX, * ),
161 $ XACT( LDXACT, * )
162* ..
163*
164* =====================================================================
165*
166* .. Parameters ..
167 DOUBLE PRECISION ZERO, ONE
168 parameter( zero = 0.0d+0, one = 1.0d+0 )
169* ..
170* .. Local Scalars ..
171 INTEGER I, IMAX, J, K, NZ
172 DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
173 COMPLEX*16 ZDUM
174* ..
175* .. External Functions ..
176 INTEGER IZAMAX
177 DOUBLE PRECISION DLAMCH
178 EXTERNAL izamax, dlamch
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC abs, dble, dimag, max, min
182* ..
183* .. Statement Functions ..
184 DOUBLE PRECISION CABS1
185* ..
186* .. Statement Function definitions ..
187 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
188* ..
189* .. Executable Statements ..
190*
191* Quick exit if N = 0 or NRHS = 0.
192*
193 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
194 reslts( 1 ) = zero
195 reslts( 2 ) = zero
196 RETURN
197 END IF
198*
199 eps = dlamch( 'Epsilon' )
200 unfl = dlamch( 'Safe minimum' )
201 ovfl = one / unfl
202 nz = 4
203*
204* Test 1: Compute the maximum of
205* norm(X - XACT) / ( norm(X) * FERR )
206* over all the vectors X and XACT using the infinity-norm.
207*
208 errbnd = zero
209 DO 30 j = 1, nrhs
210 imax = izamax( n, x( 1, j ), 1 )
211 xnorm = max( cabs1( x( imax, j ) ), unfl )
212 diff = zero
213 DO 10 i = 1, n
214 diff = max( diff, cabs1( x( i, j )-xact( i, j ) ) )
215 10 CONTINUE
216*
217 IF( xnorm.GT.one ) THEN
218 GO TO 20
219 ELSE IF( diff.LE.ovfl*xnorm ) THEN
220 GO TO 20
221 ELSE
222 errbnd = one / eps
223 GO TO 30
224 END IF
225*
226 20 CONTINUE
227 IF( diff / xnorm.LE.ferr( j ) ) THEN
228 errbnd = max( errbnd, ( diff / xnorm ) / ferr( j ) )
229 ELSE
230 errbnd = one / eps
231 END IF
232 30 CONTINUE
233 reslts( 1 ) = errbnd
234*
235* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
236* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
237*
238 DO 50 k = 1, nrhs
239 IF( n.EQ.1 ) THEN
240 axbi = cabs1( b( 1, k ) ) + cabs1( d( 1 )*x( 1, k ) )
241 ELSE
242 axbi = cabs1( b( 1, k ) ) + cabs1( d( 1 )*x( 1, k ) ) +
243 $ cabs1( e( 1 ) )*cabs1( x( 2, k ) )
244 DO 40 i = 2, n - 1
245 tmp = cabs1( b( i, k ) ) + cabs1( e( i-1 ) )*
246 $ cabs1( x( i-1, k ) ) + cabs1( d( i )*x( i, k ) ) +
247 $ cabs1( e( i ) )*cabs1( x( i+1, k ) )
248 axbi = min( axbi, tmp )
249 40 CONTINUE
250 tmp = cabs1( b( n, k ) ) + cabs1( e( n-1 ) )*
251 $ cabs1( x( n-1, k ) ) + cabs1( d( n )*x( n, k ) )
252 axbi = min( axbi, tmp )
253 END IF
254 tmp = berr( k ) / ( nz*eps+nz*unfl / max( axbi, nz*unfl ) )
255 IF( k.EQ.1 ) THEN
256 reslts( 2 ) = tmp
257 ELSE
258 reslts( 2 ) = max( reslts( 2 ), tmp )
259 END IF
260 50 CONTINUE
261*
262 RETURN
263*
264* End of ZPTT05
265*

◆ zqlt01()

subroutine zqlt01 ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
complex*16, dimension( lda, * ) af,
complex*16, dimension( lda, * ) q,
complex*16, dimension( lda, * ) l,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result )

ZQLT01

Purpose:
!>
!> ZQLT01 tests ZGEQLF, which computes the QL factorization of an m-by-n
!> matrix A, and partially tests ZUNGQL which forms the m-by-m
!> orthogonal matrix Q.
!>
!> ZQLT01 compares L with Q'*A, and checks that Q is orthogonal.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The m-by-n matrix A.
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the QL factorization of A, as returned by ZGEQLF.
!>          See ZGEQLF for further details.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDA,M)
!>          The m-by-m orthogonal matrix Q.
!>
[out]L
!>          L is COMPLEX*16 array, dimension (LDA,max(M,N))
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays A, AF, Q and R.
!>          LDA >= max(M,N).
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by ZGEQLF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file zqlt01.f.

126*
127* -- LAPACK test routine --
128* -- LAPACK is a software package provided by Univ. of Tennessee, --
129* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
130*
131* .. Scalar Arguments ..
132 INTEGER LDA, LWORK, M, N
133* ..
134* .. Array Arguments ..
135 DOUBLE PRECISION RESULT( * ), RWORK( * )
136 COMPLEX*16 A( LDA, * ), AF( LDA, * ), L( LDA, * ),
137 $ Q( LDA, * ), TAU( * ), WORK( LWORK )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ZERO, ONE
144 parameter( zero = 0.0d+0, one = 1.0d+0 )
145 COMPLEX*16 ROGUE
146 parameter( rogue = ( -1.0d+10, -1.0d+10 ) )
147* ..
148* .. Local Scalars ..
149 INTEGER INFO, MINMN
150 DOUBLE PRECISION ANORM, EPS, RESID
151* ..
152* .. External Functions ..
153 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY
154 EXTERNAL dlamch, zlange, zlansy
155* ..
156* .. External Subroutines ..
157 EXTERNAL zgemm, zgeqlf, zherk, zlacpy, zlaset, zungql
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC dble, dcmplx, max, min
161* ..
162* .. Scalars in Common ..
163 CHARACTER*32 SRNAMT
164* ..
165* .. Common blocks ..
166 COMMON / srnamc / srnamt
167* ..
168* .. Executable Statements ..
169*
170 minmn = min( m, n )
171 eps = dlamch( 'Epsilon' )
172*
173* Copy the matrix A to the array AF.
174*
175 CALL zlacpy( 'Full', m, n, a, lda, af, lda )
176*
177* Factorize the matrix A in the array AF.
178*
179 srnamt = 'ZGEQLF'
180 CALL zgeqlf( m, n, af, lda, tau, work, lwork, info )
181*
182* Copy details of Q
183*
184 CALL zlaset( 'Full', m, m, rogue, rogue, q, lda )
185 IF( m.GE.n ) THEN
186 IF( n.LT.m .AND. n.GT.0 )
187 $ CALL zlacpy( 'Full', m-n, n, af, lda, q( 1, m-n+1 ), lda )
188 IF( n.GT.1 )
189 $ CALL zlacpy( 'Upper', n-1, n-1, af( m-n+1, 2 ), lda,
190 $ q( m-n+1, m-n+2 ), lda )
191 ELSE
192 IF( m.GT.1 )
193 $ CALL zlacpy( 'Upper', m-1, m-1, af( 1, n-m+2 ), lda,
194 $ q( 1, 2 ), lda )
195 END IF
196*
197* Generate the m-by-m matrix Q
198*
199 srnamt = 'ZUNGQL'
200 CALL zungql( m, m, minmn, q, lda, tau, work, lwork, info )
201*
202* Copy L
203*
204 CALL zlaset( 'Full', m, n, dcmplx( zero ), dcmplx( zero ), l,
205 $ lda )
206 IF( m.GE.n ) THEN
207 IF( n.GT.0 )
208 $ CALL zlacpy( 'Lower', n, n, af( m-n+1, 1 ), lda,
209 $ l( m-n+1, 1 ), lda )
210 ELSE
211 IF( n.GT.m .AND. m.GT.0 )
212 $ CALL zlacpy( 'Full', m, n-m, af, lda, l, lda )
213 IF( m.GT.0 )
214 $ CALL zlacpy( 'Lower', m, m, af( 1, n-m+1 ), lda,
215 $ l( 1, n-m+1 ), lda )
216 END IF
217*
218* Compute L - Q'*A
219*
220 CALL zgemm( 'Conjugate transpose', 'No transpose', m, n, m,
221 $ dcmplx( -one ), q, lda, a, lda, dcmplx( one ), l,
222 $ lda )
223*
224* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) .
225*
226 anorm = zlange( '1', m, n, a, lda, rwork )
227 resid = zlange( '1', m, n, l, lda, rwork )
228 IF( anorm.GT.zero ) THEN
229 result( 1 ) = ( ( resid / dble( max( 1, m ) ) ) / anorm ) / eps
230 ELSE
231 result( 1 ) = zero
232 END IF
233*
234* Compute I - Q'*Q
235*
236 CALL zlaset( 'Full', m, m, dcmplx( zero ), dcmplx( one ), l, lda )
237 CALL zherk( 'Upper', 'Conjugate transpose', m, m, -one, q, lda,
238 $ one, l, lda )
239*
240* Compute norm( I - Q'*Q ) / ( M * EPS ) .
241*
242 resid = zlansy( '1', 'Upper', m, l, lda, rwork )
243*
244 result( 2 ) = ( resid / dble( max( 1, m ) ) ) / eps
245*
246 RETURN
247*
248* End of ZQLT01
249*

◆ zqlt02()

subroutine zqlt02 ( integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
complex*16, dimension( lda, * ) af,
complex*16, dimension( lda, * ) q,
complex*16, dimension( lda, * ) l,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result )

ZQLT02

Purpose:
!>
!> ZQLT02 tests ZUNGQL, which generates an m-by-n matrix Q with
!> orthonornmal columns that is defined as the product of k elementary
!> reflectors.
!>
!> Given the QL factorization of an m-by-n matrix A, ZQLT02 generates
!> the orthogonal matrix Q defined by the factorization of the last k
!> columns of A; it compares L(m-n+1:m,n-k+1:n) with
!> Q(1:m,m-n+1:m)'*A(1:m,n-k+1:n), and checks that the columns of Q are
!> orthonormal.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix Q to be generated.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix Q to be generated.
!>          M >= N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines the
!>          matrix Q. N >= K >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The m-by-n matrix A which was factorized by ZQLT01.
!>
[in]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the QL factorization of A, as returned by ZGEQLF.
!>          See ZGEQLF for further details.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDA,N)
!>
[out]L
!>          L is COMPLEX*16 array, dimension (LDA,N)
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays A, AF, Q and L. LDA >= M.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (N)
!>          The scalar factors of the elementary reflectors corresponding
!>          to the QL factorization in AF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 134 of file zqlt02.f.

136*
137* -- LAPACK test routine --
138* -- LAPACK is a software package provided by Univ. of Tennessee, --
139* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
140*
141* .. Scalar Arguments ..
142 INTEGER K, LDA, LWORK, M, N
143* ..
144* .. Array Arguments ..
145 DOUBLE PRECISION RESULT( * ), RWORK( * )
146 COMPLEX*16 A( LDA, * ), AF( LDA, * ), L( LDA, * ),
147 $ Q( LDA, * ), TAU( * ), WORK( LWORK )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 DOUBLE PRECISION ZERO, ONE
154 parameter( zero = 0.0d+0, one = 1.0d+0 )
155 COMPLEX*16 ROGUE
156 parameter( rogue = ( -1.0d+10, -1.0d+10 ) )
157* ..
158* .. Local Scalars ..
159 INTEGER INFO
160 DOUBLE PRECISION ANORM, EPS, RESID
161* ..
162* .. External Functions ..
163 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY
164 EXTERNAL dlamch, zlange, zlansy
165* ..
166* .. External Subroutines ..
167 EXTERNAL zgemm, zherk, zlacpy, zlaset, zungql
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC dble, dcmplx, max
171* ..
172* .. Scalars in Common ..
173 CHARACTER*32 SRNAMT
174* ..
175* .. Common blocks ..
176 COMMON / srnamc / srnamt
177* ..
178* .. Executable Statements ..
179*
180* Quick return if possible
181*
182 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 ) THEN
183 result( 1 ) = zero
184 result( 2 ) = zero
185 RETURN
186 END IF
187*
188 eps = dlamch( 'Epsilon' )
189*
190* Copy the last k columns of the factorization to the array Q
191*
192 CALL zlaset( 'Full', m, n, rogue, rogue, q, lda )
193 IF( k.LT.m )
194 $ CALL zlacpy( 'Full', m-k, k, af( 1, n-k+1 ), lda,
195 $ q( 1, n-k+1 ), lda )
196 IF( k.GT.1 )
197 $ CALL zlacpy( 'Upper', k-1, k-1, af( m-k+1, n-k+2 ), lda,
198 $ q( m-k+1, n-k+2 ), lda )
199*
200* Generate the last n columns of the matrix Q
201*
202 srnamt = 'ZUNGQL'
203 CALL zungql( m, n, k, q, lda, tau( n-k+1 ), work, lwork, info )
204*
205* Copy L(m-n+1:m,n-k+1:n)
206*
207 CALL zlaset( 'Full', n, k, dcmplx( zero ), dcmplx( zero ),
208 $ l( m-n+1, n-k+1 ), lda )
209 CALL zlacpy( 'Lower', k, k, af( m-k+1, n-k+1 ), lda,
210 $ l( m-k+1, n-k+1 ), lda )
211*
212* Compute L(m-n+1:m,n-k+1:n) - Q(1:m,m-n+1:m)' * A(1:m,n-k+1:n)
213*
214 CALL zgemm( 'Conjugate transpose', 'No transpose', n, k, m,
215 $ dcmplx( -one ), q, lda, a( 1, n-k+1 ), lda,
216 $ dcmplx( one ), l( m-n+1, n-k+1 ), lda )
217*
218* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) .
219*
220 anorm = zlange( '1', m, k, a( 1, n-k+1 ), lda, rwork )
221 resid = zlange( '1', n, k, l( m-n+1, n-k+1 ), lda, rwork )
222 IF( anorm.GT.zero ) THEN
223 result( 1 ) = ( ( resid / dble( max( 1, m ) ) ) / anorm ) / eps
224 ELSE
225 result( 1 ) = zero
226 END IF
227*
228* Compute I - Q'*Q
229*
230 CALL zlaset( 'Full', n, n, dcmplx( zero ), dcmplx( one ), l, lda )
231 CALL zherk( 'Upper', 'Conjugate transpose', n, m, -one, q, lda,
232 $ one, l, lda )
233*
234* Compute norm( I - Q'*Q ) / ( M * EPS ) .
235*
236 resid = zlansy( '1', 'Upper', n, l, lda, rwork )
237*
238 result( 2 ) = ( resid / dble( max( 1, m ) ) ) / eps
239*
240 RETURN
241*
242* End of ZQLT02
243*

◆ zqlt03()

subroutine zqlt03 ( integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) af,
complex*16, dimension( lda, * ) c,
complex*16, dimension( lda, * ) cc,
complex*16, dimension( lda, * ) q,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result )

ZQLT03

Purpose:
!>
!> ZQLT03 tests ZUNMQL, which computes Q*C, Q'*C, C*Q or C*Q'.
!>
!> ZQLT03 compares the results of a call to ZUNMQL with the results of
!> forming Q explicitly by a call to ZUNGQL and then performing matrix
!> multiplication by a call to ZGEMM.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The order of the orthogonal matrix Q.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of rows or columns of the matrix C; C is m-by-n if
!>          Q is applied from the left, or n-by-m if Q is applied from
!>          the right.  N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines the
!>          orthogonal matrix Q.  M >= K >= 0.
!>
[in]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the QL factorization of an m-by-n matrix, as
!>          returned by ZGEQLF. See CGEQLF for further details.
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDA,N)
!>
[out]CC
!>          CC is COMPLEX*16 array, dimension (LDA,N)
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDA,M)
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays AF, C, CC, and Q.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors corresponding
!>          to the QL factorization in AF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of WORK.  LWORK must be at least M, and should be
!>          M*NB, where NB is the blocksize for this environment.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The test ratios compare two techniques for multiplying a
!>          random matrix C by an m-by-m orthogonal matrix Q.
!>          RESULT(1) = norm( Q*C - Q*C )  / ( M * norm(C) * EPS )
!>          RESULT(2) = norm( C*Q - C*Q )  / ( M * norm(C) * EPS )
!>          RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS )
!>          RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 134 of file zqlt03.f.

136*
137* -- LAPACK test routine --
138* -- LAPACK is a software package provided by Univ. of Tennessee, --
139* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
140*
141* .. Scalar Arguments ..
142 INTEGER K, LDA, LWORK, M, N
143* ..
144* .. Array Arguments ..
145 DOUBLE PRECISION RESULT( * ), RWORK( * )
146 COMPLEX*16 AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
147 $ Q( LDA, * ), TAU( * ), WORK( LWORK )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 DOUBLE PRECISION ZERO, ONE
154 parameter( zero = 0.0d+0, one = 1.0d+0 )
155 COMPLEX*16 ROGUE
156 parameter( rogue = ( -1.0d+10, -1.0d+10 ) )
157* ..
158* .. Local Scalars ..
159 CHARACTER SIDE, TRANS
160 INTEGER INFO, ISIDE, ITRANS, J, MC, MINMN, NC
161 DOUBLE PRECISION CNORM, EPS, RESID
162* ..
163* .. External Functions ..
164 LOGICAL LSAME
165 DOUBLE PRECISION DLAMCH, ZLANGE
166 EXTERNAL lsame, dlamch, zlange
167* ..
168* .. External Subroutines ..
169 EXTERNAL zgemm, zlacpy, zlarnv, zlaset, zungql, zunmql
170* ..
171* .. Local Arrays ..
172 INTEGER ISEED( 4 )
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC dble, dcmplx, max, min
176* ..
177* .. Scalars in Common ..
178 CHARACTER*32 SRNAMT
179* ..
180* .. Common blocks ..
181 COMMON / srnamc / srnamt
182* ..
183* .. Data statements ..
184 DATA iseed / 1988, 1989, 1990, 1991 /
185* ..
186* .. Executable Statements ..
187*
188 eps = dlamch( 'Epsilon' )
189 minmn = min( m, n )
190*
191* Quick return if possible
192*
193 IF( minmn.EQ.0 ) THEN
194 result( 1 ) = zero
195 result( 2 ) = zero
196 result( 3 ) = zero
197 result( 4 ) = zero
198 RETURN
199 END IF
200*
201* Copy the last k columns of the factorization to the array Q
202*
203 CALL zlaset( 'Full', m, m, rogue, rogue, q, lda )
204 IF( k.GT.0 .AND. m.GT.k )
205 $ CALL zlacpy( 'Full', m-k, k, af( 1, n-k+1 ), lda,
206 $ q( 1, m-k+1 ), lda )
207 IF( k.GT.1 )
208 $ CALL zlacpy( 'Upper', k-1, k-1, af( m-k+1, n-k+2 ), lda,
209 $ q( m-k+1, m-k+2 ), lda )
210*
211* Generate the m-by-m matrix Q
212*
213 srnamt = 'ZUNGQL'
214 CALL zungql( m, m, k, q, lda, tau( minmn-k+1 ), work, lwork,
215 $ info )
216*
217 DO 30 iside = 1, 2
218 IF( iside.EQ.1 ) THEN
219 side = 'L'
220 mc = m
221 nc = n
222 ELSE
223 side = 'R'
224 mc = n
225 nc = m
226 END IF
227*
228* Generate MC by NC matrix C
229*
230 DO 10 j = 1, nc
231 CALL zlarnv( 2, iseed, mc, c( 1, j ) )
232 10 CONTINUE
233 cnorm = zlange( '1', mc, nc, c, lda, rwork )
234 IF( cnorm.EQ.zero )
235 $ cnorm = one
236*
237 DO 20 itrans = 1, 2
238 IF( itrans.EQ.1 ) THEN
239 trans = 'N'
240 ELSE
241 trans = 'C'
242 END IF
243*
244* Copy C
245*
246 CALL zlacpy( 'Full', mc, nc, c, lda, cc, lda )
247*
248* Apply Q or Q' to C
249*
250 srnamt = 'ZUNMQL'
251 IF( k.GT.0 )
252 $ CALL zunmql( side, trans, mc, nc, k, af( 1, n-k+1 ), lda,
253 $ tau( minmn-k+1 ), cc, lda, work, lwork,
254 $ info )
255*
256* Form explicit product and subtract
257*
258 IF( lsame( side, 'L' ) ) THEN
259 CALL zgemm( trans, 'No transpose', mc, nc, mc,
260 $ dcmplx( -one ), q, lda, c, lda,
261 $ dcmplx( one ), cc, lda )
262 ELSE
263 CALL zgemm( 'No transpose', trans, mc, nc, nc,
264 $ dcmplx( -one ), c, lda, q, lda,
265 $ dcmplx( one ), cc, lda )
266 END IF
267*
268* Compute error in the difference
269*
270 resid = zlange( '1', mc, nc, cc, lda, rwork )
271 result( ( iside-1 )*2+itrans ) = resid /
272 $ ( dble( max( 1, m ) )*cnorm*eps )
273*
274 20 CONTINUE
275 30 CONTINUE
276*
277 RETURN
278*
279* End of ZQLT03
280*

◆ zqpt01()

double precision function zqpt01 ( integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
complex*16, dimension( lda, * ) af,
integer lda,
complex*16, dimension( * ) tau,
integer, dimension( * ) jpvt,
complex*16, dimension( lwork ) work,
integer lwork )

ZQPT01

Purpose:
!>
!> ZQPT01 tests the QR-factorization with pivoting of a matrix A.  The
!> array AF contains the (possibly partial) QR-factorization of A, where
!> the upper triangle of AF(1:k,1:k) is a partial triangular factor,
!> the entries below the diagonal in the first k columns are the
!> Householder vectors, and the rest of AF contains a partially updated
!> matrix.
!>
!> This function returns ||A*P - Q*R||/(||norm(A)||*eps*M)
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrices A and AF.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrices A and AF.
!>
[in]K
!>          K is INTEGER
!>          The number of columns of AF that have been reduced
!>          to upper triangular form.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA, N)
!>          The original matrix A.
!>
[in]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          The (possibly partial) output of ZGEQPF.  The upper triangle
!>          of AF(1:k,1:k) is a partial triangular factor, the entries
!>          below the diagonal in the first k columns are the Householder
!>          vectors, and the rest of AF contains a partially updated
!>          matrix.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays A and AF.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          Details of the Householder transformations as returned by
!>          ZGEQPF.
!>
[in]JPVT
!>          JPVT is INTEGER array, dimension (N)
!>          Pivot information as returned by ZGEQPF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  LWORK >= M*N+N.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 118 of file zqpt01.f.

120*
121* -- LAPACK test routine --
122* -- LAPACK is a software package provided by Univ. of Tennessee, --
123* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
124*
125* .. Scalar Arguments ..
126 INTEGER K, LDA, LWORK, M, N
127* ..
128* .. Array Arguments ..
129 INTEGER JPVT( * )
130 COMPLEX*16 A( LDA, * ), AF( LDA, * ), TAU( * ),
131 $ WORK( LWORK )
132* ..
133*
134* =====================================================================
135*
136* .. Parameters ..
137 DOUBLE PRECISION ZERO, ONE
138 parameter( zero = 0.0d0, one = 1.0d0 )
139* ..
140* .. Local Scalars ..
141 INTEGER I, INFO, J
142 DOUBLE PRECISION NORMA
143* ..
144* .. Local Arrays ..
145 DOUBLE PRECISION RWORK( 1 )
146* ..
147* .. External Functions ..
148 DOUBLE PRECISION DLAMCH, ZLANGE
149 EXTERNAL dlamch, zlange
150* ..
151* .. External Subroutines ..
152 EXTERNAL xerbla, zaxpy, zcopy, zunmqr
153* ..
154* .. Intrinsic Functions ..
155 INTRINSIC dble, dcmplx, max, min
156* ..
157* .. Executable Statements ..
158*
159 zqpt01 = zero
160*
161* Test if there is enough workspace
162*
163 IF( lwork.LT.m*n+n ) THEN
164 CALL xerbla( 'ZQPT01', 10 )
165 RETURN
166 END IF
167*
168* Quick return if possible
169*
170 IF( m.LE.0 .OR. n.LE.0 )
171 $ RETURN
172*
173 norma = zlange( 'One-norm', m, n, a, lda, rwork )
174*
175 DO 30 j = 1, k
176 DO 10 i = 1, min( j, m )
177 work( ( j-1 )*m+i ) = af( i, j )
178 10 CONTINUE
179 DO 20 i = j + 1, m
180 work( ( j-1 )*m+i ) = zero
181 20 CONTINUE
182 30 CONTINUE
183 DO 40 j = k + 1, n
184 CALL zcopy( m, af( 1, j ), 1, work( ( j-1 )*m+1 ), 1 )
185 40 CONTINUE
186*
187 CALL zunmqr( 'Left', 'No transpose', m, n, k, af, lda, tau, work,
188 $ m, work( m*n+1 ), lwork-m*n, info )
189*
190 DO 50 j = 1, n
191*
192* Compare i-th column of QR and jpvt(i)-th column of A
193*
194 CALL zaxpy( m, dcmplx( -one ), a( 1, jpvt( j ) ), 1,
195 $ work( ( j-1 )*m+1 ), 1 )
196 50 CONTINUE
197*
198 zqpt01 = zlange( 'One-norm', m, n, work, m, rwork ) /
199 $ ( dble( max( m, n ) )*dlamch( 'Epsilon' ) )
200 IF( norma.NE.zero )
201 $ zqpt01 = zqpt01 / norma
202*
203 RETURN
204*
205* End of ZQPT01
206*

◆ zqrt01()

subroutine zqrt01 ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
complex*16, dimension( lda, * ) af,
complex*16, dimension( lda, * ) q,
complex*16, dimension( lda, * ) r,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result )

ZQRT01

Purpose:
!>
!> ZQRT01 tests ZGEQRF, which computes the QR factorization of an m-by-n
!> matrix A, and partially tests ZUNGQR which forms the m-by-m
!> orthogonal matrix Q.
!>
!> ZQRT01 compares R with Q'*A, and checks that Q is orthogonal.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The m-by-n matrix A.
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the QR factorization of A, as returned by ZGEQRF.
!>          See ZGEQRF for further details.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDA,M)
!>          The m-by-m orthogonal matrix Q.
!>
[out]R
!>          R is COMPLEX*16 array, dimension (LDA,max(M,N))
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays A, AF, Q and R.
!>          LDA >= max(M,N).
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by ZGEQRF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file zqrt01.f.

126*
127* -- LAPACK test routine --
128* -- LAPACK is a software package provided by Univ. of Tennessee, --
129* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
130*
131* .. Scalar Arguments ..
132 INTEGER LDA, LWORK, M, N
133* ..
134* .. Array Arguments ..
135 DOUBLE PRECISION RESULT( * ), RWORK( * )
136 COMPLEX*16 A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
137 $ R( LDA, * ), TAU( * ), WORK( LWORK )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ZERO, ONE
144 parameter( zero = 0.0d+0, one = 1.0d+0 )
145 COMPLEX*16 ROGUE
146 parameter( rogue = ( -1.0d+10, -1.0d+10 ) )
147* ..
148* .. Local Scalars ..
149 INTEGER INFO, MINMN
150 DOUBLE PRECISION ANORM, EPS, RESID
151* ..
152* .. External Functions ..
153 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY
154 EXTERNAL dlamch, zlange, zlansy
155* ..
156* .. External Subroutines ..
157 EXTERNAL zgemm, zgeqrf, zherk, zlacpy, zlaset, zungqr
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC dble, dcmplx, max, min
161* ..
162* .. Scalars in Common ..
163 CHARACTER*32 SRNAMT
164* ..
165* .. Common blocks ..
166 COMMON / srnamc / srnamt
167* ..
168* .. Executable Statements ..
169*
170 minmn = min( m, n )
171 eps = dlamch( 'Epsilon' )
172*
173* Copy the matrix A to the array AF.
174*
175 CALL zlacpy( 'Full', m, n, a, lda, af, lda )
176*
177* Factorize the matrix A in the array AF.
178*
179 srnamt = 'ZGEQRF'
180 CALL zgeqrf( m, n, af, lda, tau, work, lwork, info )
181*
182* Copy details of Q
183*
184 CALL zlaset( 'Full', m, m, rogue, rogue, q, lda )
185 CALL zlacpy( 'Lower', m-1, n, af( 2, 1 ), lda, q( 2, 1 ), lda )
186*
187* Generate the m-by-m matrix Q
188*
189 srnamt = 'ZUNGQR'
190 CALL zungqr( m, m, minmn, q, lda, tau, work, lwork, info )
191*
192* Copy R
193*
194 CALL zlaset( 'Full', m, n, dcmplx( zero ), dcmplx( zero ), r,
195 $ lda )
196 CALL zlacpy( 'Upper', m, n, af, lda, r, lda )
197*
198* Compute R - Q'*A
199*
200 CALL zgemm( 'Conjugate transpose', 'No transpose', m, n, m,
201 $ dcmplx( -one ), q, lda, a, lda, dcmplx( one ), r,
202 $ lda )
203*
204* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) .
205*
206 anorm = zlange( '1', m, n, a, lda, rwork )
207 resid = zlange( '1', m, n, r, lda, rwork )
208 IF( anorm.GT.zero ) THEN
209 result( 1 ) = ( ( resid / dble( max( 1, m ) ) ) / anorm ) / eps
210 ELSE
211 result( 1 ) = zero
212 END IF
213*
214* Compute I - Q'*Q
215*
216 CALL zlaset( 'Full', m, m, dcmplx( zero ), dcmplx( one ), r, lda )
217 CALL zherk( 'Upper', 'Conjugate transpose', m, m, -one, q, lda,
218 $ one, r, lda )
219*
220* Compute norm( I - Q'*Q ) / ( M * EPS ) .
221*
222 resid = zlansy( '1', 'Upper', m, r, lda, rwork )
223*
224 result( 2 ) = ( resid / dble( max( 1, m ) ) ) / eps
225*
226 RETURN
227*
228* End of ZQRT01
229*

◆ zqrt01p()

subroutine zqrt01p ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
complex*16, dimension( lda, * ) af,
complex*16, dimension( lda, * ) q,
complex*16, dimension( lda, * ) r,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result )

ZQRT01P

Purpose:
!>
!> ZQRT01P tests ZGEQRFP, which computes the QR factorization of an m-by-n
!> matrix A, and partially tests ZUNGQR which forms the m-by-m
!> orthogonal matrix Q.
!>
!> ZQRT01P compares R with Q'*A, and checks that Q is orthogonal.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The m-by-n matrix A.
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the QR factorization of A, as returned by ZGEQRFP.
!>          See ZGEQRFP for further details.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDA,M)
!>          The m-by-m orthogonal matrix Q.
!>
[out]R
!>          R is COMPLEX*16 array, dimension (LDA,max(M,N))
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays A, AF, Q and R.
!>          LDA >= max(M,N).
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by ZGEQRFP.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file zqrt01p.f.

126*
127* -- LAPACK test routine --
128* -- LAPACK is a software package provided by Univ. of Tennessee, --
129* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
130*
131* .. Scalar Arguments ..
132 INTEGER LDA, LWORK, M, N
133* ..
134* .. Array Arguments ..
135 DOUBLE PRECISION RESULT( * ), RWORK( * )
136 COMPLEX*16 A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
137 $ R( LDA, * ), TAU( * ), WORK( LWORK )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ZERO, ONE
144 parameter( zero = 0.0d+0, one = 1.0d+0 )
145 COMPLEX*16 ROGUE
146 parameter( rogue = ( -1.0d+10, -1.0d+10 ) )
147* ..
148* .. Local Scalars ..
149 INTEGER INFO, MINMN
150 DOUBLE PRECISION ANORM, EPS, RESID
151* ..
152* .. External Functions ..
153 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY
154 EXTERNAL dlamch, zlange, zlansy
155* ..
156* .. External Subroutines ..
157 EXTERNAL zgemm, zgeqrfp, zherk, zlacpy, zlaset, zungqr
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC dble, dcmplx, max, min
161* ..
162* .. Scalars in Common ..
163 CHARACTER*32 SRNAMT
164* ..
165* .. Common blocks ..
166 COMMON / srnamc / srnamt
167* ..
168* .. Executable Statements ..
169*
170 minmn = min( m, n )
171 eps = dlamch( 'Epsilon' )
172*
173* Copy the matrix A to the array AF.
174*
175 CALL zlacpy( 'Full', m, n, a, lda, af, lda )
176*
177* Factorize the matrix A in the array AF.
178*
179 srnamt = 'ZGEQRFP'
180 CALL zgeqrfp( m, n, af, lda, tau, work, lwork, info )
181*
182* Copy details of Q
183*
184 CALL zlaset( 'Full', m, m, rogue, rogue, q, lda )
185 CALL zlacpy( 'Lower', m-1, n, af( 2, 1 ), lda, q( 2, 1 ), lda )
186*
187* Generate the m-by-m matrix Q
188*
189 srnamt = 'ZUNGQR'
190 CALL zungqr( m, m, minmn, q, lda, tau, work, lwork, info )
191*
192* Copy R
193*
194 CALL zlaset( 'Full', m, n, dcmplx( zero ), dcmplx( zero ), r,
195 $ lda )
196 CALL zlacpy( 'Upper', m, n, af, lda, r, lda )
197*
198* Compute R - Q'*A
199*
200 CALL zgemm( 'Conjugate transpose', 'No transpose', m, n, m,
201 $ dcmplx( -one ), q, lda, a, lda, dcmplx( one ), r,
202 $ lda )
203*
204* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) .
205*
206 anorm = zlange( '1', m, n, a, lda, rwork )
207 resid = zlange( '1', m, n, r, lda, rwork )
208 IF( anorm.GT.zero ) THEN
209 result( 1 ) = ( ( resid / dble( max( 1, m ) ) ) / anorm ) / eps
210 ELSE
211 result( 1 ) = zero
212 END IF
213*
214* Compute I - Q'*Q
215*
216 CALL zlaset( 'Full', m, m, dcmplx( zero ), dcmplx( one ), r, lda )
217 CALL zherk( 'Upper', 'Conjugate transpose', m, m, -one, q, lda,
218 $ one, r, lda )
219*
220* Compute norm( I - Q'*Q ) / ( M * EPS ) .
221*
222 resid = zlansy( '1', 'Upper', m, r, lda, rwork )
223*
224 result( 2 ) = ( resid / dble( max( 1, m ) ) ) / eps
225*
226 RETURN
227*
228* End of ZQRT01P
229*

◆ zqrt02()

subroutine zqrt02 ( integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
complex*16, dimension( lda, * ) af,
complex*16, dimension( lda, * ) q,
complex*16, dimension( lda, * ) r,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result )

ZQRT02

Purpose:
!>
!> ZQRT02 tests ZUNGQR, which generates an m-by-n matrix Q with
!> orthonornmal columns that is defined as the product of k elementary
!> reflectors.
!>
!> Given the QR factorization of an m-by-n matrix A, ZQRT02 generates
!> the orthogonal matrix Q defined by the factorization of the first k
!> columns of A; it compares R(1:n,1:k) with Q(1:m,1:n)'*A(1:m,1:k),
!> and checks that the columns of Q are orthonormal.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix Q to be generated.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix Q to be generated.
!>          M >= N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines the
!>          matrix Q. N >= K >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The m-by-n matrix A which was factorized by ZQRT01.
!>
[in]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the QR factorization of A, as returned by ZGEQRF.
!>          See ZGEQRF for further details.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDA,N)
!>
[out]R
!>          R is COMPLEX*16 array, dimension (LDA,N)
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays A, AF, Q and R. LDA >= M.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (N)
!>          The scalar factors of the elementary reflectors corresponding
!>          to the QR factorization in AF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 133 of file zqrt02.f.

135*
136* -- LAPACK test routine --
137* -- LAPACK is a software package provided by Univ. of Tennessee, --
138* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
139*
140* .. Scalar Arguments ..
141 INTEGER K, LDA, LWORK, M, N
142* ..
143* .. Array Arguments ..
144 DOUBLE PRECISION RESULT( * ), RWORK( * )
145 COMPLEX*16 A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
146 $ R( LDA, * ), TAU( * ), WORK( LWORK )
147* ..
148*
149* =====================================================================
150*
151* .. Parameters ..
152 DOUBLE PRECISION ZERO, ONE
153 parameter( zero = 0.0d+0, one = 1.0d+0 )
154 COMPLEX*16 ROGUE
155 parameter( rogue = ( -1.0d+10, -1.0d+10 ) )
156* ..
157* .. Local Scalars ..
158 INTEGER INFO
159 DOUBLE PRECISION ANORM, EPS, RESID
160* ..
161* .. External Functions ..
162 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY
163 EXTERNAL dlamch, zlange, zlansy
164* ..
165* .. External Subroutines ..
166 EXTERNAL zgemm, zherk, zlacpy, zlaset, zungqr
167* ..
168* .. Intrinsic Functions ..
169 INTRINSIC dble, dcmplx, max
170* ..
171* .. Scalars in Common ..
172 CHARACTER*32 SRNAMT
173* ..
174* .. Common blocks ..
175 COMMON / srnamc / srnamt
176* ..
177* .. Executable Statements ..
178*
179 eps = dlamch( 'Epsilon' )
180*
181* Copy the first k columns of the factorization to the array Q
182*
183 CALL zlaset( 'Full', m, n, rogue, rogue, q, lda )
184 CALL zlacpy( 'Lower', m-1, k, af( 2, 1 ), lda, q( 2, 1 ), lda )
185*
186* Generate the first n columns of the matrix Q
187*
188 srnamt = 'ZUNGQR'
189 CALL zungqr( m, n, k, q, lda, tau, work, lwork, info )
190*
191* Copy R(1:n,1:k)
192*
193 CALL zlaset( 'Full', n, k, dcmplx( zero ), dcmplx( zero ), r,
194 $ lda )
195 CALL zlacpy( 'Upper', n, k, af, lda, r, lda )
196*
197* Compute R(1:n,1:k) - Q(1:m,1:n)' * A(1:m,1:k)
198*
199 CALL zgemm( 'Conjugate transpose', 'No transpose', n, k, m,
200 $ dcmplx( -one ), q, lda, a, lda, dcmplx( one ), r,
201 $ lda )
202*
203* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) .
204*
205 anorm = zlange( '1', m, k, a, lda, rwork )
206 resid = zlange( '1', n, k, r, lda, rwork )
207 IF( anorm.GT.zero ) THEN
208 result( 1 ) = ( ( resid / dble( max( 1, m ) ) ) / anorm ) / eps
209 ELSE
210 result( 1 ) = zero
211 END IF
212*
213* Compute I - Q'*Q
214*
215 CALL zlaset( 'Full', n, n, dcmplx( zero ), dcmplx( one ), r, lda )
216 CALL zherk( 'Upper', 'Conjugate transpose', n, m, -one, q, lda,
217 $ one, r, lda )
218*
219* Compute norm( I - Q'*Q ) / ( M * EPS ) .
220*
221 resid = zlansy( '1', 'Upper', n, r, lda, rwork )
222*
223 result( 2 ) = ( resid / dble( max( 1, m ) ) ) / eps
224*
225 RETURN
226*
227* End of ZQRT02
228*

◆ zqrt03()

subroutine zqrt03 ( integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) af,
complex*16, dimension( lda, * ) c,
complex*16, dimension( lda, * ) cc,
complex*16, dimension( lda, * ) q,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result )

ZQRT03

Purpose:
!>
!> ZQRT03 tests ZUNMQR, which computes Q*C, Q'*C, C*Q or C*Q'.
!>
!> ZQRT03 compares the results of a call to ZUNMQR with the results of
!> forming Q explicitly by a call to ZUNGQR and then performing matrix
!> multiplication by a call to ZGEMM.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The order of the orthogonal matrix Q.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of rows or columns of the matrix C; C is m-by-n if
!>          Q is applied from the left, or n-by-m if Q is applied from
!>          the right.  N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines the
!>          orthogonal matrix Q.  M >= K >= 0.
!>
[in]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the QR factorization of an m-by-n matrix, as
!>          returned by ZGEQRF. See ZGEQRF for further details.
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDA,N)
!>
[out]CC
!>          CC is COMPLEX*16 array, dimension (LDA,N)
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDA,M)
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays AF, C, CC, and Q.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors corresponding
!>          to the QR factorization in AF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of WORK.  LWORK must be at least M, and should be
!>          M*NB, where NB is the blocksize for this environment.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The test ratios compare two techniques for multiplying a
!>          random matrix C by an m-by-m orthogonal matrix Q.
!>          RESULT(1) = norm( Q*C - Q*C )  / ( M * norm(C) * EPS )
!>          RESULT(2) = norm( C*Q - C*Q )  / ( M * norm(C) * EPS )
!>          RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS )
!>          RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 134 of file zqrt03.f.

136*
137* -- LAPACK test routine --
138* -- LAPACK is a software package provided by Univ. of Tennessee, --
139* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
140*
141* .. Scalar Arguments ..
142 INTEGER K, LDA, LWORK, M, N
143* ..
144* .. Array Arguments ..
145 DOUBLE PRECISION RESULT( * ), RWORK( * )
146 COMPLEX*16 AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
147 $ Q( LDA, * ), TAU( * ), WORK( LWORK )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 DOUBLE PRECISION ZERO, ONE
154 parameter( zero = 0.0d+0, one = 1.0d+0 )
155 COMPLEX*16 ROGUE
156 parameter( rogue = ( -1.0d+10, -1.0d+10 ) )
157* ..
158* .. Local Scalars ..
159 CHARACTER SIDE, TRANS
160 INTEGER INFO, ISIDE, ITRANS, J, MC, NC
161 DOUBLE PRECISION CNORM, EPS, RESID
162* ..
163* .. External Functions ..
164 LOGICAL LSAME
165 DOUBLE PRECISION DLAMCH, ZLANGE
166 EXTERNAL lsame, dlamch, zlange
167* ..
168* .. External Subroutines ..
169 EXTERNAL zgemm, zlacpy, zlarnv, zlaset, zungqr, zunmqr
170* ..
171* .. Local Arrays ..
172 INTEGER ISEED( 4 )
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC dble, dcmplx, max
176* ..
177* .. Scalars in Common ..
178 CHARACTER*32 SRNAMT
179* ..
180* .. Common blocks ..
181 COMMON / srnamc / srnamt
182* ..
183* .. Data statements ..
184 DATA iseed / 1988, 1989, 1990, 1991 /
185* ..
186* .. Executable Statements ..
187*
188 eps = dlamch( 'Epsilon' )
189*
190* Copy the first k columns of the factorization to the array Q
191*
192 CALL zlaset( 'Full', m, m, rogue, rogue, q, lda )
193 CALL zlacpy( 'Lower', m-1, k, af( 2, 1 ), lda, q( 2, 1 ), lda )
194*
195* Generate the m-by-m matrix Q
196*
197 srnamt = 'ZUNGQR'
198 CALL zungqr( m, m, k, q, lda, tau, work, lwork, info )
199*
200 DO 30 iside = 1, 2
201 IF( iside.EQ.1 ) THEN
202 side = 'L'
203 mc = m
204 nc = n
205 ELSE
206 side = 'R'
207 mc = n
208 nc = m
209 END IF
210*
211* Generate MC by NC matrix C
212*
213 DO 10 j = 1, nc
214 CALL zlarnv( 2, iseed, mc, c( 1, j ) )
215 10 CONTINUE
216 cnorm = zlange( '1', mc, nc, c, lda, rwork )
217 IF( cnorm.EQ.zero )
218 $ cnorm = one
219*
220 DO 20 itrans = 1, 2
221 IF( itrans.EQ.1 ) THEN
222 trans = 'N'
223 ELSE
224 trans = 'C'
225 END IF
226*
227* Copy C
228*
229 CALL zlacpy( 'Full', mc, nc, c, lda, cc, lda )
230*
231* Apply Q or Q' to C
232*
233 srnamt = 'ZUNMQR'
234 CALL zunmqr( side, trans, mc, nc, k, af, lda, tau, cc, lda,
235 $ work, lwork, info )
236*
237* Form explicit product and subtract
238*
239 IF( lsame( side, 'L' ) ) THEN
240 CALL zgemm( trans, 'No transpose', mc, nc, mc,
241 $ dcmplx( -one ), q, lda, c, lda,
242 $ dcmplx( one ), cc, lda )
243 ELSE
244 CALL zgemm( 'No transpose', trans, mc, nc, nc,
245 $ dcmplx( -one ), c, lda, q, lda,
246 $ dcmplx( one ), cc, lda )
247 END IF
248*
249* Compute error in the difference
250*
251 resid = zlange( '1', mc, nc, cc, lda, rwork )
252 result( ( iside-1 )*2+itrans ) = resid /
253 $ ( dble( max( 1, m ) )*cnorm*eps )
254*
255 20 CONTINUE
256 30 CONTINUE
257*
258 RETURN
259*
260* End of ZQRT03
261*

◆ zqrt04()

subroutine zqrt04 ( integer m,
integer n,
integer nb,
double precision, dimension(6) result )

ZQRT04

Purpose:
!>
!> ZQRT04 tests ZGEQRT and ZGEMQRT.
!>
Parameters
[in]M
!>          M is INTEGER
!>          Number of rows in test matrix.
!>
[in]N
!>          N is INTEGER
!>          Number of columns in test matrix.
!>
[in]NB
!>          NB is INTEGER
!>          Block size of test matrix.  NB <= Min(M,N).
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (6)
!>          Results of each of the six tests below.
!>
!>          RESULT(1) = | A - Q R |
!>          RESULT(2) = | I - Q^H Q |
!>          RESULT(3) = | Q C - Q C |
!>          RESULT(4) = | Q^H C - Q^H C |
!>          RESULT(5) = | C Q - C Q |
!>          RESULT(6) = | C Q^H - C Q^H |
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 72 of file zqrt04.f.

73 IMPLICIT NONE
74*
75* -- LAPACK test routine --
76* -- LAPACK is a software package provided by Univ. of Tennessee, --
77* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
78*
79* .. Scalar Arguments ..
80 INTEGER M, N, NB, LDT
81* .. Return values ..
82 DOUBLE PRECISION RESULT(6)
83*
84* =====================================================================
85*
86* ..
87* .. Local allocatable arrays
88 COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:),
89 $ R(:,:), WORK( : ), T(:,:),
90 $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
91 DOUBLE PRECISION, ALLOCATABLE :: RWORK(:)
92*
93* .. Parameters ..
94 DOUBLE PRECISION ZERO
95 COMPLEX*16 ONE, CZERO
96 parameter( zero = 0.0, one = (1.0,0.0), czero=(0.0,0.0) )
97* ..
98* .. Local Scalars ..
99 INTEGER INFO, J, K, L, LWORK
100 DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM
101* ..
102* .. Local Arrays ..
103 INTEGER ISEED( 4 )
104* ..
105* .. External Functions ..
106 DOUBLE PRECISION DLAMCH
107 DOUBLE PRECISION ZLANGE, ZLANSY
108 LOGICAL LSAME
109 EXTERNAL dlamch, zlange, zlansy, lsame
110* ..
111* .. Intrinsic Functions ..
112 INTRINSIC max, min
113* ..
114* .. Data statements ..
115 DATA iseed / 1988, 1989, 1990, 1991 /
116*
117 eps = dlamch( 'Epsilon' )
118 k = min(m,n)
119 l = max(m,n)
120 lwork = max(2,l)*max(2,l)*nb
121*
122* Dynamically allocate local arrays
123*
124 ALLOCATE ( a(m,n), af(m,n), q(m,m), r(m,l), rwork(l),
125 $ work(lwork), t(nb,n), c(m,n), cf(m,n),
126 $ d(n,m), df(n,m) )
127*
128* Put random numbers into A and copy to AF
129*
130 ldt=nb
131 DO j=1,n
132 CALL zlarnv( 2, iseed, m, a( 1, j ) )
133 END DO
134 CALL zlacpy( 'Full', m, n, a, m, af, m )
135*
136* Factor the matrix A in the array AF.
137*
138 CALL zgeqrt( m, n, nb, af, m, t, ldt, work, info )
139*
140* Generate the m-by-m matrix Q
141*
142 CALL zlaset( 'Full', m, m, czero, one, q, m )
143 CALL zgemqrt( 'R', 'N', m, m, k, nb, af, m, t, ldt, q, m,
144 $ work, info )
145*
146* Copy R
147*
148 CALL zlaset( 'Full', m, n, czero, czero, r, m )
149 CALL zlacpy( 'Upper', m, n, af, m, r, m )
150*
151* Compute |R - Q'*A| / |A| and store in RESULT(1)
152*
153 CALL zgemm( 'C', 'N', m, n, m, -one, q, m, a, m, one, r, m )
154 anorm = zlange( '1', m, n, a, m, rwork )
155 resid = zlange( '1', m, n, r, m, rwork )
156 IF( anorm.GT.zero ) THEN
157 result( 1 ) = resid / (eps*max(1,m)*anorm)
158 ELSE
159 result( 1 ) = zero
160 END IF
161*
162* Compute |I - Q'*Q| and store in RESULT(2)
163*
164 CALL zlaset( 'Full', m, m, czero, one, r, m )
165 CALL zherk( 'U', 'C', m, m, dreal(-one), q, m, dreal(one), r, m )
166 resid = zlansy( '1', 'Upper', m, r, m, rwork )
167 result( 2 ) = resid / (eps*max(1,m))
168*
169* Generate random m-by-n matrix C and a copy CF
170*
171 DO j=1,n
172 CALL zlarnv( 2, iseed, m, c( 1, j ) )
173 END DO
174 cnorm = zlange( '1', m, n, c, m, rwork)
175 CALL zlacpy( 'Full', m, n, c, m, cf, m )
176*
177* Apply Q to C as Q*C
178*
179 CALL zgemqrt( 'L', 'N', m, n, k, nb, af, m, t, nb, cf, m,
180 $ work, info)
181*
182* Compute |Q*C - Q*C| / |C|
183*
184 CALL zgemm( 'N', 'N', m, n, m, -one, q, m, c, m, one, cf, m )
185 resid = zlange( '1', m, n, cf, m, rwork )
186 IF( cnorm.GT.zero ) THEN
187 result( 3 ) = resid / (eps*max(1,m)*cnorm)
188 ELSE
189 result( 3 ) = zero
190 END IF
191*
192* Copy C into CF again
193*
194 CALL zlacpy( 'Full', m, n, c, m, cf, m )
195*
196* Apply Q to C as QT*C
197*
198 CALL zgemqrt( 'L', 'C', m, n, k, nb, af, m, t, nb, cf, m,
199 $ work, info)
200*
201* Compute |QT*C - QT*C| / |C|
202*
203 CALL zgemm( 'C', 'N', m, n, m, -one, q, m, c, m, one, cf, m )
204 resid = zlange( '1', m, n, cf, m, rwork )
205 IF( cnorm.GT.zero ) THEN
206 result( 4 ) = resid / (eps*max(1,m)*cnorm)
207 ELSE
208 result( 4 ) = zero
209 END IF
210*
211* Generate random n-by-m matrix D and a copy DF
212*
213 DO j=1,m
214 CALL zlarnv( 2, iseed, n, d( 1, j ) )
215 END DO
216 dnorm = zlange( '1', n, m, d, n, rwork)
217 CALL zlacpy( 'Full', n, m, d, n, df, n )
218*
219* Apply Q to D as D*Q
220*
221 CALL zgemqrt( 'R', 'N', n, m, k, nb, af, m, t, nb, df, n,
222 $ work, info)
223*
224* Compute |D*Q - D*Q| / |D|
225*
226 CALL zgemm( 'N', 'N', n, m, m, -one, d, n, q, m, one, df, n )
227 resid = zlange( '1', n, m, df, n, rwork )
228 IF( cnorm.GT.zero ) THEN
229 result( 5 ) = resid / (eps*max(1,m)*dnorm)
230 ELSE
231 result( 5 ) = zero
232 END IF
233*
234* Copy D into DF again
235*
236 CALL zlacpy( 'Full', n, m, d, n, df, n )
237*
238* Apply Q to D as D*QT
239*
240 CALL zgemqrt( 'R', 'C', n, m, k, nb, af, m, t, nb, df, n,
241 $ work, info)
242*
243* Compute |D*QT - D*QT| / |D|
244*
245 CALL zgemm( 'N', 'C', n, m, m, -one, d, n, q, m, one, df, n )
246 resid = zlange( '1', n, m, df, n, rwork )
247 IF( cnorm.GT.zero ) THEN
248 result( 6 ) = resid / (eps*max(1,m)*dnorm)
249 ELSE
250 result( 6 ) = zero
251 END IF
252*
253* Deallocate all arrays
254*
255 DEALLOCATE ( a, af, q, r, rwork, work, t, c, d, cf, df)
256*
257 RETURN

◆ zqrt05()

subroutine zqrt05 ( integer m,
integer n,
integer l,
integer nb,
double precision, dimension(6) result )

ZQRT05

Purpose:
!>
!> ZQRT05 tests ZTPQRT and ZTPMQRT.
!>
Parameters
[in]M
!>          M is INTEGER
!>          Number of rows in lower part of the test matrix.
!>
[in]N
!>          N is INTEGER
!>          Number of columns in test matrix.
!>
[in]L
!>          L is INTEGER
!>          The number of rows of the upper trapezoidal part the
!>          lower test matrix.  0 <= L <= M.
!>
[in]NB
!>          NB is INTEGER
!>          Block size of test matrix.  NB <= N.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (6)
!>          Results of each of the six tests below.
!>
!>          RESULT(1) = | A - Q R |
!>          RESULT(2) = | I - Q^H Q |
!>          RESULT(3) = | Q C - Q C |
!>          RESULT(4) = | Q^H C - Q^H C |
!>          RESULT(5) = | C Q - C Q |
!>          RESULT(6) = | C Q^H - C Q^H |
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 79 of file zqrt05.f.

80 IMPLICIT NONE
81*
82* -- LAPACK test routine --
83* -- LAPACK is a software package provided by Univ. of Tennessee, --
84* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
85*
86* .. Scalar Arguments ..
87 INTEGER LWORK, M, N, L, NB, LDT
88* .. Return values ..
89 DOUBLE PRECISION RESULT(6)
90*
91* =====================================================================
92*
93* ..
94* .. Local allocatable arrays
95 COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:),
96 $ R(:,:), WORK( : ), T(:,:),
97 $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
98 DOUBLE PRECISION, ALLOCATABLE :: RWORK(:)
99*
100* .. Parameters ..
101 DOUBLE PRECISION ZERO
102 COMPLEX*16 ONE, CZERO
103 parameter( zero = 0.0, one = (1.0,0.0), czero=(0.0,0.0) )
104* ..
105* .. Local Scalars ..
106 INTEGER INFO, J, K, M2, NP1
107 DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM
108* ..
109* .. Local Arrays ..
110 INTEGER ISEED( 4 )
111* ..
112* .. External Functions ..
113 DOUBLE PRECISION DLAMCH
114 DOUBLE PRECISION ZLANGE, ZLANSY
115 LOGICAL LSAME
116 EXTERNAL dlamch, zlange, zlansy, lsame
117* ..
118* .. Data statements ..
119 DATA iseed / 1988, 1989, 1990, 1991 /
120*
121 eps = dlamch( 'Epsilon' )
122 k = n
123 m2 = m+n
124 IF( m.GT.0 ) THEN
125 np1 = n+1
126 ELSE
127 np1 = 1
128 END IF
129 lwork = m2*m2*nb
130*
131* Dynamically allocate all arrays
132*
133 ALLOCATE(a(m2,n),af(m2,n),q(m2,m2),r(m2,m2),rwork(m2),
134 $ work(lwork),t(nb,n),c(m2,n),cf(m2,n),
135 $ d(n,m2),df(n,m2) )
136*
137* Put random stuff into A
138*
139 ldt=nb
140 CALL zlaset( 'Full', m2, n, czero, czero, a, m2 )
141 CALL zlaset( 'Full', nb, n, czero, czero, t, nb )
142 DO j=1,n
143 CALL zlarnv( 2, iseed, j, a( 1, j ) )
144 END DO
145 IF( m.GT.0 ) THEN
146 DO j=1,n
147 CALL zlarnv( 2, iseed, m-l, a( min(n+m,n+1), j ) )
148 END DO
149 END IF
150 IF( l.GT.0 ) THEN
151 DO j=1,n
152 CALL zlarnv( 2, iseed, min(j,l), a( min(n+m,n+m-l+1), j ) )
153 END DO
154 END IF
155*
156* Copy the matrix A to the array AF.
157*
158 CALL zlacpy( 'Full', m2, n, a, m2, af, m2 )
159*
160* Factor the matrix A in the array AF.
161*
162 CALL ztpqrt( m,n,l,nb,af,m2,af(np1,1),m2,t,ldt,work,info)
163*
164* Generate the (M+N)-by-(M+N) matrix Q by applying H to I
165*
166 CALL zlaset( 'Full', m2, m2, czero, one, q, m2 )
167 CALL zgemqrt( 'R', 'N', m2, m2, k, nb, af, m2, t, ldt, q, m2,
168 $ work, info )
169*
170* Copy R
171*
172 CALL zlaset( 'Full', m2, n, czero, czero, r, m2 )
173 CALL zlacpy( 'Upper', m2, n, af, m2, r, m2 )
174*
175* Compute |R - Q'*A| / |A| and store in RESULT(1)
176*
177 CALL zgemm( 'C', 'N', m2, n, m2, -one, q, m2, a, m2, one, r, m2 )
178 anorm = zlange( '1', m2, n, a, m2, rwork )
179 resid = zlange( '1', m2, n, r, m2, rwork )
180 IF( anorm.GT.zero ) THEN
181 result( 1 ) = resid / (eps*anorm*max(1,m2))
182 ELSE
183 result( 1 ) = zero
184 END IF
185*
186* Compute |I - Q'*Q| and store in RESULT(2)
187*
188 CALL zlaset( 'Full', m2, m2, czero, one, r, m2 )
189 CALL zherk( 'U', 'C', m2, m2, dreal(-one), q, m2, dreal(one),
190 $ r, m2 )
191 resid = zlansy( '1', 'Upper', m2, r, m2, rwork )
192 result( 2 ) = resid / (eps*max(1,m2))
193*
194* Generate random m-by-n matrix C and a copy CF
195*
196 DO j=1,n
197 CALL zlarnv( 2, iseed, m2, c( 1, j ) )
198 END DO
199 cnorm = zlange( '1', m2, n, c, m2, rwork)
200 CALL zlacpy( 'Full', m2, n, c, m2, cf, m2 )
201*
202* Apply Q to C as Q*C
203*
204 CALL ztpmqrt( 'L','N', m,n,k,l,nb,af(np1,1),m2,t,ldt,cf,m2,
205 $ cf(np1,1),m2,work,info)
206*
207* Compute |Q*C - Q*C| / |C|
208*
209 CALL zgemm( 'N', 'N', m2, n, m2, -one, q, m2, c, m2, one, cf, m2 )
210 resid = zlange( '1', m2, n, cf, m2, rwork )
211 IF( cnorm.GT.zero ) THEN
212 result( 3 ) = resid / (eps*max(1,m2)*cnorm)
213 ELSE
214 result( 3 ) = zero
215 END IF
216*
217* Copy C into CF again
218*
219 CALL zlacpy( 'Full', m2, n, c, m2, cf, m2 )
220*
221* Apply Q to C as QT*C
222*
223 CALL ztpmqrt( 'L','C',m,n,k,l,nb,af(np1,1),m2,t,ldt,cf,m2,
224 $ cf(np1,1),m2,work,info)
225*
226* Compute |QT*C - QT*C| / |C|
227*
228 CALL zgemm('C','N',m2,n,m2,-one,q,m2,c,m2,one,cf,m2)
229 resid = zlange( '1', m2, n, cf, m2, rwork )
230 IF( cnorm.GT.zero ) THEN
231 result( 4 ) = resid / (eps*max(1,m2)*cnorm)
232 ELSE
233 result( 4 ) = zero
234 END IF
235*
236* Generate random n-by-m matrix D and a copy DF
237*
238 DO j=1,m2
239 CALL zlarnv( 2, iseed, n, d( 1, j ) )
240 END DO
241 dnorm = zlange( '1', n, m2, d, n, rwork)
242 CALL zlacpy( 'Full', n, m2, d, n, df, n )
243*
244* Apply Q to D as D*Q
245*
246 CALL ztpmqrt('R','N',n,m,n,l,nb,af(np1,1),m2,t,ldt,df,n,
247 $ df(1,np1),n,work,info)
248*
249* Compute |D*Q - D*Q| / |D|
250*
251 CALL zgemm('N','N',n,m2,m2,-one,d,n,q,m2,one,df,n)
252 resid = zlange('1',n, m2,df,n,rwork )
253 IF( cnorm.GT.zero ) THEN
254 result( 5 ) = resid / (eps*max(1,m2)*dnorm)
255 ELSE
256 result( 5 ) = zero
257 END IF
258*
259* Copy D into DF again
260*
261 CALL zlacpy('Full',n,m2,d,n,df,n )
262*
263* Apply Q to D as D*QT
264*
265 CALL ztpmqrt('R','C',n,m,n,l,nb,af(np1,1),m2,t,ldt,df,n,
266 $ df(1,np1),n,work,info)
267
268*
269* Compute |D*QT - D*QT| / |D|
270*
271 CALL zgemm( 'N', 'C', n, m2, m2, -one, d, n, q, m2, one, df, n )
272 resid = zlange( '1', n, m2, df, n, rwork )
273 IF( cnorm.GT.zero ) THEN
274 result( 6 ) = resid / (eps*max(1,m2)*dnorm)
275 ELSE
276 result( 6 ) = zero
277 END IF
278*
279* Deallocate all arrays
280*
281 DEALLOCATE ( a, af, q, r, rwork, work, t, c, d, cf, df)
282 RETURN

◆ zqrt11()

double precision function zqrt11 ( integer m,
integer k,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( lwork ) work,
integer lwork )

ZQRT11

Purpose:
!>
!> ZQRT11 computes the test ratio
!>
!>       || Q'*Q - I || / (eps * m)
!>
!> where the orthogonal matrix Q is represented as a product of
!> elementary transformations.  Each transformation has the form
!>
!>    H(k) = I - tau(k) v(k) v(k)'
!>
!> where tau(k) is stored in TAU(k) and v(k) is an m-vector of the form
!> [ 0 ... 0 1 x(k) ]', where x(k) is a vector of length m-k stored
!> in A(k+1:m,k).
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.
!>
[in]K
!>          K is INTEGER
!>          The number of columns of A whose subdiagonal entries
!>          contain information about orthogonal transformations.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,K)
!>          The (possibly partial) output of a QR reduction routine.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (K)
!>          The scaling factors tau for the elementary transformations as
!>          computed by the QR factorization routine.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  LWORK >= M*M + M.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 97 of file zqrt11.f.

98*
99* -- LAPACK test routine --
100* -- LAPACK is a software package provided by Univ. of Tennessee, --
101* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
102*
103* .. Scalar Arguments ..
104 INTEGER K, LDA, LWORK, M
105* ..
106* .. Array Arguments ..
107 COMPLEX*16 A( LDA, * ), TAU( * ), WORK( LWORK )
108* ..
109*
110* =====================================================================
111*
112* .. Parameters ..
113 DOUBLE PRECISION ZERO, ONE
114 parameter( zero = 0.0d0, one = 1.0d0 )
115* ..
116* .. Local Scalars ..
117 INTEGER INFO, J
118* ..
119* .. External Functions ..
120 DOUBLE PRECISION DLAMCH, ZLANGE
121 EXTERNAL dlamch, zlange
122* ..
123* .. External Subroutines ..
124 EXTERNAL xerbla, zlaset, zunm2r
125* ..
126* .. Intrinsic Functions ..
127 INTRINSIC dble, dcmplx
128* ..
129* .. Local Arrays ..
130 DOUBLE PRECISION RDUMMY( 1 )
131* ..
132* .. Executable Statements ..
133*
134 zqrt11 = zero
135*
136* Test for sufficient workspace
137*
138 IF( lwork.LT.m*m+m ) THEN
139 CALL xerbla( 'ZQRT11', 7 )
140 RETURN
141 END IF
142*
143* Quick return if possible
144*
145 IF( m.LE.0 )
146 $ RETURN
147*
148 CALL zlaset( 'Full', m, m, dcmplx( zero ), dcmplx( one ), work,
149 $ m )
150*
151* Form Q
152*
153 CALL zunm2r( 'Left', 'No transpose', m, m, k, a, lda, tau, work,
154 $ m, work( m*m+1 ), info )
155*
156* Form Q'*Q
157*
158 CALL zunm2r( 'Left', 'Conjugate transpose', m, m, k, a, lda, tau,
159 $ work, m, work( m*m+1 ), info )
160*
161 DO 10 j = 1, m
162 work( ( j-1 )*m+j ) = work( ( j-1 )*m+j ) - one
163 10 CONTINUE
164*
165 zqrt11 = zlange( 'One-norm', m, m, work, m, rdummy ) /
166 $ ( dble( m )*dlamch( 'Epsilon' ) )
167*
168 RETURN
169*
170* End of ZQRT11
171*

◆ zqrt12()

double precision function zqrt12 ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) s,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork )

ZQRT12

Purpose:
!>
!> ZQRT12 computes the singular values `svlues' of the upper trapezoid
!> of A(1:M,1:N) and returns the ratio
!>
!>      || s - svlues||/(||svlues||*eps*max(M,N))
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The M-by-N matrix A. Only the upper trapezoid is referenced.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>
[in]S
!>          S is DOUBLE PRECISION array, dimension (min(M,N))
!>          The singular values of the matrix A.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK. LWORK >= M*N + 2*min(M,N) +
!>          max(M,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (2*min(M,N))
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 95 of file zqrt12.f.

97*
98* -- LAPACK test routine --
99* -- LAPACK is a software package provided by Univ. of Tennessee, --
100* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
101*
102* .. Scalar Arguments ..
103 INTEGER LDA, LWORK, M, N
104* ..
105* .. Array Arguments ..
106 DOUBLE PRECISION RWORK( * ), S( * )
107 COMPLEX*16 A( LDA, * ), WORK( LWORK )
108* ..
109*
110* =====================================================================
111*
112* .. Parameters ..
113 DOUBLE PRECISION ZERO, ONE
114 parameter( zero = 0.0d0, one = 1.0d0 )
115* ..
116* .. Local Scalars ..
117 INTEGER I, INFO, ISCL, J, MN
118 DOUBLE PRECISION ANRM, BIGNUM, NRMSVL, SMLNUM
119* ..
120* .. Local Arrays ..
121 DOUBLE PRECISION DUMMY( 1 )
122* ..
123* .. External Functions ..
124 DOUBLE PRECISION DASUM, DLAMCH, DNRM2, ZLANGE
125 EXTERNAL dasum, dlamch, dnrm2, zlange
126* ..
127* .. External Subroutines ..
128 EXTERNAL daxpy, dbdsqr, dlabad, dlascl, xerbla, zgebd2,
129 $ zlascl, zlaset
130* ..
131* .. Intrinsic Functions ..
132 INTRINSIC dble, dcmplx, max, min
133* ..
134* .. Executable Statements ..
135*
136 zqrt12 = zero
137*
138* Test that enough workspace is supplied
139*
140 IF( lwork.LT.m*n+2*min( m, n )+max( m, n ) ) THEN
141 CALL xerbla( 'ZQRT12', 7 )
142 RETURN
143 END IF
144*
145* Quick return if possible
146*
147 mn = min( m, n )
148 IF( mn.LE.zero )
149 $ RETURN
150*
151 nrmsvl = dnrm2( mn, s, 1 )
152*
153* Copy upper triangle of A into work
154*
155 CALL zlaset( 'Full', m, n, dcmplx( zero ), dcmplx( zero ), work,
156 $ m )
157 DO 20 j = 1, n
158 DO 10 i = 1, min( j, m )
159 work( ( j-1 )*m+i ) = a( i, j )
160 10 CONTINUE
161 20 CONTINUE
162*
163* Get machine parameters
164*
165 smlnum = dlamch( 'S' ) / dlamch( 'P' )
166 bignum = one / smlnum
167 CALL dlabad( smlnum, bignum )
168*
169* Scale work if max entry outside range [SMLNUM,BIGNUM]
170*
171 anrm = zlange( 'M', m, n, work, m, dummy )
172 iscl = 0
173 IF( anrm.GT.zero .AND. anrm.LT.smlnum ) THEN
174*
175* Scale matrix norm up to SMLNUM
176*
177 CALL zlascl( 'G', 0, 0, anrm, smlnum, m, n, work, m, info )
178 iscl = 1
179 ELSE IF( anrm.GT.bignum ) THEN
180*
181* Scale matrix norm down to BIGNUM
182*
183 CALL zlascl( 'G', 0, 0, anrm, bignum, m, n, work, m, info )
184 iscl = 1
185 END IF
186*
187 IF( anrm.NE.zero ) THEN
188*
189* Compute SVD of work
190*
191 CALL zgebd2( m, n, work, m, rwork( 1 ), rwork( mn+1 ),
192 $ work( m*n+1 ), work( m*n+mn+1 ),
193 $ work( m*n+2*mn+1 ), info )
194 CALL dbdsqr( 'Upper', mn, 0, 0, 0, rwork( 1 ), rwork( mn+1 ),
195 $ dummy, mn, dummy, 1, dummy, mn, rwork( 2*mn+1 ),
196 $ info )
197*
198 IF( iscl.EQ.1 ) THEN
199 IF( anrm.GT.bignum ) THEN
200 CALL dlascl( 'G', 0, 0, bignum, anrm, mn, 1, rwork( 1 ),
201 $ mn, info )
202 END IF
203 IF( anrm.LT.smlnum ) THEN
204 CALL dlascl( 'G', 0, 0, smlnum, anrm, mn, 1, rwork( 1 ),
205 $ mn, info )
206 END IF
207 END IF
208*
209 ELSE
210*
211 DO 30 i = 1, mn
212 rwork( i ) = zero
213 30 CONTINUE
214 END IF
215*
216* Compare s and singular values of work
217*
218 CALL daxpy( mn, -one, s, 1, rwork( 1 ), 1 )
219 zqrt12 = dasum( mn, rwork( 1 ), 1 ) /
220 $ ( dlamch( 'Epsilon' )*dble( max( m, n ) ) )
221 IF( nrmsvl.NE.zero )
222 $ zqrt12 = zqrt12 / nrmsvl
223*
224 RETURN
225*
226* End of ZQRT12
227*
dlascl
subroutine dlascl(type, kl, ku, cfrom, cto, m, n, a, lda, info)
DLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
Definition dlascl.f:143
dbdsqr
subroutine dbdsqr(uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c, ldc, work, info)
DBDSQR
Definition dbdsqr.f:241
zgebd2
subroutine zgebd2(m, n, a, lda, d, e, tauq, taup, work, info)
ZGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
Definition zgebd2.f:189
zlascl
subroutine zlascl(type, kl, ku, cfrom, cto, m, n, a, lda, info)
ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
Definition zlascl.f:143
dnrm2
real(wp) function dnrm2(n, x, incx)
DNRM2
Definition dnrm2.f90:89

◆ zqrt13()

subroutine zqrt13 ( integer scale,
integer m,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
double precision norma,
integer, dimension( 4 ) iseed )

ZQRT13

Purpose:
!>
!> ZQRT13 generates a full-rank matrix that may be scaled to have large
!> or small norm.
!>
Parameters
[in]SCALE
!>          SCALE is INTEGER
!>          SCALE = 1: normally scaled matrix
!>          SCALE = 2: matrix scaled up
!>          SCALE = 3: matrix scaled down
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of A.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The M-by-N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>
[out]NORMA
!>          NORMA is DOUBLE PRECISION
!>          The one-norm of A.
!>
[in,out]ISEED
!>          ISEED is integer array, dimension (4)
!>          Seed for random number generator
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 90 of file zqrt13.f.

91*
92* -- LAPACK test routine --
93* -- LAPACK is a software package provided by Univ. of Tennessee, --
94* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
95*
96* .. Scalar Arguments ..
97 INTEGER LDA, M, N, SCALE
98 DOUBLE PRECISION NORMA
99* ..
100* .. Array Arguments ..
101 INTEGER ISEED( 4 )
102 COMPLEX*16 A( LDA, * )
103* ..
104*
105* =====================================================================
106*
107* .. Parameters ..
108 DOUBLE PRECISION ONE
109 parameter( one = 1.0d0 )
110* ..
111* .. Local Scalars ..
112 INTEGER INFO, J
113 DOUBLE PRECISION BIGNUM, SMLNUM
114* ..
115* .. External Functions ..
116 DOUBLE PRECISION DLAMCH, DZASUM, ZLANGE
117 EXTERNAL dlamch, dzasum, zlange
118* ..
119* .. External Subroutines ..
120 EXTERNAL dlabad, zlarnv, zlascl
121* ..
122* .. Intrinsic Functions ..
123 INTRINSIC dble, dcmplx, sign
124* ..
125* .. Local Arrays ..
126 DOUBLE PRECISION DUMMY( 1 )
127* ..
128* .. Executable Statements ..
129*
130 IF( m.LE.0 .OR. n.LE.0 )
131 $ RETURN
132*
133* benign matrix
134*
135 DO 10 j = 1, n
136 CALL zlarnv( 2, iseed, m, a( 1, j ) )
137 IF( j.LE.m ) THEN
138 a( j, j ) = a( j, j ) + dcmplx( sign( dzasum( m, a( 1, j ),
139 $ 1 ), dble( a( j, j ) ) ) )
140 END IF
141 10 CONTINUE
142*
143* scaled versions
144*
145 IF( scale.NE.1 ) THEN
146 norma = zlange( 'Max', m, n, a, lda, dummy )
147 smlnum = dlamch( 'Safe minimum' )
148 bignum = one / smlnum
149 CALL dlabad( smlnum, bignum )
150 smlnum = smlnum / dlamch( 'Epsilon' )
151 bignum = one / smlnum
152*
153 IF( scale.EQ.2 ) THEN
154*
155* matrix scaled up
156*
157 CALL zlascl( 'General', 0, 0, norma, bignum, m, n, a, lda,
158 $ info )
159 ELSE IF( scale.EQ.3 ) THEN
160*
161* matrix scaled down
162*
163 CALL zlascl( 'General', 0, 0, norma, smlnum, m, n, a, lda,
164 $ info )
165 END IF
166 END IF
167*
168 norma = zlange( 'One-norm', m, n, a, lda, dummy )
169 RETURN
170*
171* End of ZQRT13
172*

◆ zqrt14()

double precision function zqrt14 ( character trans,
integer m,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( lwork ) work,
integer lwork )

ZQRT14

Purpose:
!>
!> ZQRT14 checks whether X is in the row space of A or A'.  It does so
!> by scaling both X and A such that their norms are in the range
!> [sqrt(eps), 1/sqrt(eps)], then computing a QR factorization of [A,X]
!> (if TRANS = 'C') or an LQ factorization of [A',X]' (if TRANS = 'N'),
!> and returning the norm of the trailing triangle, scaled by
!> MAX(M,N,NRHS)*eps.
!>
Parameters
[in]TRANS
!>          TRANS is CHARACTER*1
!>          = 'N':  No transpose, check for X in the row space of A
!>          = 'C':  Conjugate transpose, check for X in row space of A'.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of X.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The M-by-N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          If TRANS = 'N', the N-by-NRHS matrix X.
!>          IF TRANS = 'C', the M-by-NRHS matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.
!>
[out]WORK
!>          WORK is COMPLEX*16 array dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          length of workspace array required
!>          If TRANS = 'N', LWORK >= (M+NRHS)*(N+2);
!>          if TRANS = 'C', LWORK >= (N+NRHS)*(M+2).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 114 of file zqrt14.f.

116*
117* -- LAPACK test routine --
118* -- LAPACK is a software package provided by Univ. of Tennessee, --
119* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
120*
121* .. Scalar Arguments ..
122 CHARACTER TRANS
123 INTEGER LDA, LDX, LWORK, M, N, NRHS
124* ..
125* .. Array Arguments ..
126 COMPLEX*16 A( LDA, * ), WORK( LWORK ), X( LDX, * )
127* ..
128*
129* =====================================================================
130*
131* .. Parameters ..
132 DOUBLE PRECISION ZERO, ONE
133 parameter( zero = 0.0d0, one = 1.0d0 )
134* ..
135* .. Local Scalars ..
136 LOGICAL TPSD
137 INTEGER I, INFO, J, LDWORK
138 DOUBLE PRECISION ANRM, ERR, XNRM
139* ..
140* .. Local Arrays ..
141 DOUBLE PRECISION RWORK( 1 )
142* ..
143* .. External Functions ..
144 LOGICAL LSAME
145 DOUBLE PRECISION DLAMCH, ZLANGE
146 EXTERNAL lsame, dlamch, zlange
147* ..
148* .. External Subroutines ..
149 EXTERNAL xerbla, zgelq2, zgeqr2, zlacpy, zlascl
150* ..
151* .. Intrinsic Functions ..
152 INTRINSIC abs, dble, dconjg, max, min
153* ..
154* .. Executable Statements ..
155*
156 zqrt14 = zero
157 IF( lsame( trans, 'N' ) ) THEN
158 ldwork = m + nrhs
159 tpsd = .false.
160 IF( lwork.LT.( m+nrhs )*( n+2 ) ) THEN
161 CALL xerbla( 'ZQRT14', 10 )
162 RETURN
163 ELSE IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
164 RETURN
165 END IF
166 ELSE IF( lsame( trans, 'C' ) ) THEN
167 ldwork = m
168 tpsd = .true.
169 IF( lwork.LT.( n+nrhs )*( m+2 ) ) THEN
170 CALL xerbla( 'ZQRT14', 10 )
171 RETURN
172 ELSE IF( m.LE.0 .OR. nrhs.LE.0 ) THEN
173 RETURN
174 END IF
175 ELSE
176 CALL xerbla( 'ZQRT14', 1 )
177 RETURN
178 END IF
179*
180* Copy and scale A
181*
182 CALL zlacpy( 'All', m, n, a, lda, work, ldwork )
183 anrm = zlange( 'M', m, n, work, ldwork, rwork )
184 IF( anrm.NE.zero )
185 $ CALL zlascl( 'G', 0, 0, anrm, one, m, n, work, ldwork, info )
186*
187* Copy X or X' into the right place and scale it
188*
189 IF( tpsd ) THEN
190*
191* Copy X into columns n+1:n+nrhs of work
192*
193 CALL zlacpy( 'All', m, nrhs, x, ldx, work( n*ldwork+1 ),
194 $ ldwork )
195 xnrm = zlange( 'M', m, nrhs, work( n*ldwork+1 ), ldwork,
196 $ rwork )
197 IF( xnrm.NE.zero )
198 $ CALL zlascl( 'G', 0, 0, xnrm, one, m, nrhs,
199 $ work( n*ldwork+1 ), ldwork, info )
200*
201* Compute QR factorization of X
202*
203 CALL zgeqr2( m, n+nrhs, work, ldwork,
204 $ work( ldwork*( n+nrhs )+1 ),
205 $ work( ldwork*( n+nrhs )+min( m, n+nrhs )+1 ),
206 $ info )
207*
208* Compute largest entry in upper triangle of
209* work(n+1:m,n+1:n+nrhs)
210*
211 err = zero
212 DO 20 j = n + 1, n + nrhs
213 DO 10 i = n + 1, min( m, j )
214 err = max( err, abs( work( i+( j-1 )*m ) ) )
215 10 CONTINUE
216 20 CONTINUE
217*
218 ELSE
219*
220* Copy X' into rows m+1:m+nrhs of work
221*
222 DO 40 i = 1, n
223 DO 30 j = 1, nrhs
224 work( m+j+( i-1 )*ldwork ) = dconjg( x( i, j ) )
225 30 CONTINUE
226 40 CONTINUE
227*
228 xnrm = zlange( 'M', nrhs, n, work( m+1 ), ldwork, rwork )
229 IF( xnrm.NE.zero )
230 $ CALL zlascl( 'G', 0, 0, xnrm, one, nrhs, n, work( m+1 ),
231 $ ldwork, info )
232*
233* Compute LQ factorization of work
234*
235 CALL zgelq2( ldwork, n, work, ldwork, work( ldwork*n+1 ),
236 $ work( ldwork*( n+1 )+1 ), info )
237*
238* Compute largest entry in lower triangle in
239* work(m+1:m+nrhs,m+1:n)
240*
241 err = zero
242 DO 60 j = m + 1, n
243 DO 50 i = j, ldwork
244 err = max( err, abs( work( i+( j-1 )*ldwork ) ) )
245 50 CONTINUE
246 60 CONTINUE
247*
248 END IF
249*
250 zqrt14 = err / ( dble( max( m, n, nrhs ) )*dlamch( 'Epsilon' ) )
251*
252 RETURN
253*
254* End of ZQRT14
255*

◆ zqrt15()

subroutine zqrt15 ( integer scale,
integer rksel,
integer m,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) s,
integer rank,
double precision norma,
double precision normb,
integer, dimension( 4 ) iseed,
complex*16, dimension( lwork ) work,
integer lwork )

ZQRT15

Purpose:
!>
!> ZQRT15 generates a matrix with full or deficient rank and of various
!> norms.
!>
Parameters
[in]SCALE
!>          SCALE is INTEGER
!>          SCALE = 1: normally scaled matrix
!>          SCALE = 2: matrix scaled up
!>          SCALE = 3: matrix scaled down
!>
[in]RKSEL
!>          RKSEL is INTEGER
!>          RKSEL = 1: full rank matrix
!>          RKSEL = 2: rank-deficient matrix
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of A.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of B.
!>
[out]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The M-by-N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>
[out]B
!>          B is COMPLEX*16 array, dimension (LDB, NRHS)
!>          A matrix that is in the range space of matrix A.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension MIN(M,N)
!>          Singular values of A.
!>
[out]RANK
!>          RANK is INTEGER
!>          number of nonzero singular values of A.
!>
[out]NORMA
!>          NORMA is DOUBLE PRECISION
!>          one-norm norm of A.
!>
[out]NORMB
!>          NORMB is DOUBLE PRECISION
!>          one-norm norm of B.
!>
[in,out]ISEED
!>          ISEED is integer array, dimension (4)
!>          seed for random number generator.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          length of work space required.
!>          LWORK >= MAX(M+MIN(M,N),NRHS*MIN(M,N),2*N+M)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 147 of file zqrt15.f.

149*
150* -- LAPACK test routine --
151* -- LAPACK is a software package provided by Univ. of Tennessee, --
152* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
153*
154* .. Scalar Arguments ..
155 INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE
156 DOUBLE PRECISION NORMA, NORMB
157* ..
158* .. Array Arguments ..
159 INTEGER ISEED( 4 )
160 DOUBLE PRECISION S( * )
161 COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( LWORK )
162* ..
163*
164* =====================================================================
165*
166* .. Parameters ..
167 DOUBLE PRECISION ZERO, ONE, TWO, SVMIN
168 parameter( zero = 0.0d+0, one = 1.0d+0, two = 2.0d+0,
169 $ svmin = 0.1d+0 )
170 COMPLEX*16 CZERO, CONE
171 parameter( czero = ( 0.0d+0, 0.0d+0 ),
172 $ cone = ( 1.0d+0, 0.0d+0 ) )
173* ..
174* .. Local Scalars ..
175 INTEGER INFO, J, MN
176 DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TEMP
177* ..
178* .. Local Arrays ..
179 DOUBLE PRECISION DUMMY( 1 )
180* ..
181* .. External Functions ..
182 DOUBLE PRECISION DASUM, DLAMCH, DLARND, DZNRM2, ZLANGE
183 EXTERNAL dasum, dlamch, dlarnd, dznrm2, zlange
184* ..
185* .. External Subroutines ..
186 EXTERNAL dlabad, dlaord, dlascl, xerbla, zdscal, zgemm,
187 $ zlarf, zlarnv, zlaror, zlascl, zlaset
188* ..
189* .. Intrinsic Functions ..
190 INTRINSIC abs, dcmplx, max, min
191* ..
192* .. Executable Statements ..
193*
194 mn = min( m, n )
195 IF( lwork.LT.max( m+mn, mn*nrhs, 2*n+m ) ) THEN
196 CALL xerbla( 'ZQRT15', 16 )
197 RETURN
198 END IF
199*
200 smlnum = dlamch( 'Safe minimum' )
201 bignum = one / smlnum
202 CALL dlabad( smlnum, bignum )
203 eps = dlamch( 'Epsilon' )
204 smlnum = ( smlnum / eps ) / eps
205 bignum = one / smlnum
206*
207* Determine rank and (unscaled) singular values
208*
209 IF( rksel.EQ.1 ) THEN
210 rank = mn
211 ELSE IF( rksel.EQ.2 ) THEN
212 rank = ( 3*mn ) / 4
213 DO 10 j = rank + 1, mn
214 s( j ) = zero
215 10 CONTINUE
216 ELSE
217 CALL xerbla( 'ZQRT15', 2 )
218 END IF
219*
220 IF( rank.GT.0 ) THEN
221*
222* Nontrivial case
223*
224 s( 1 ) = one
225 DO 30 j = 2, rank
226 20 CONTINUE
227 temp = dlarnd( 1, iseed )
228 IF( temp.GT.svmin ) THEN
229 s( j ) = abs( temp )
230 ELSE
231 GO TO 20
232 END IF
233 30 CONTINUE
234 CALL dlaord( 'Decreasing', rank, s, 1 )
235*
236* Generate 'rank' columns of a random orthogonal matrix in A
237*
238 CALL zlarnv( 2, iseed, m, work )
239 CALL zdscal( m, one / dznrm2( m, work, 1 ), work, 1 )
240 CALL zlaset( 'Full', m, rank, czero, cone, a, lda )
241 CALL zlarf( 'Left', m, rank, work, 1, dcmplx( two ), a, lda,
242 $ work( m+1 ) )
243*
244* workspace used: m+mn
245*
246* Generate consistent rhs in the range space of A
247*
248 CALL zlarnv( 2, iseed, rank*nrhs, work )
249 CALL zgemm( 'No transpose', 'No transpose', m, nrhs, rank,
250 $ cone, a, lda, work, rank, czero, b, ldb )
251*
252* work space used: <= mn *nrhs
253*
254* generate (unscaled) matrix A
255*
256 DO 40 j = 1, rank
257 CALL zdscal( m, s( j ), a( 1, j ), 1 )
258 40 CONTINUE
259 IF( rank.LT.n )
260 $ CALL zlaset( 'Full', m, n-rank, czero, czero,
261 $ a( 1, rank+1 ), lda )
262 CALL zlaror( 'Right', 'No initialization', m, n, a, lda, iseed,
263 $ work, info )
264*
265 ELSE
266*
267* work space used 2*n+m
268*
269* Generate null matrix and rhs
270*
271 DO 50 j = 1, mn
272 s( j ) = zero
273 50 CONTINUE
274 CALL zlaset( 'Full', m, n, czero, czero, a, lda )
275 CALL zlaset( 'Full', m, nrhs, czero, czero, b, ldb )
276*
277 END IF
278*
279* Scale the matrix
280*
281 IF( scale.NE.1 ) THEN
282 norma = zlange( 'Max', m, n, a, lda, dummy )
283 IF( norma.NE.zero ) THEN
284 IF( scale.EQ.2 ) THEN
285*
286* matrix scaled up
287*
288 CALL zlascl( 'General', 0, 0, norma, bignum, m, n, a,
289 $ lda, info )
290 CALL dlascl( 'General', 0, 0, norma, bignum, mn, 1, s,
291 $ mn, info )
292 CALL zlascl( 'General', 0, 0, norma, bignum, m, nrhs, b,
293 $ ldb, info )
294 ELSE IF( scale.EQ.3 ) THEN
295*
296* matrix scaled down
297*
298 CALL zlascl( 'General', 0, 0, norma, smlnum, m, n, a,
299 $ lda, info )
300 CALL dlascl( 'General', 0, 0, norma, smlnum, mn, 1, s,
301 $ mn, info )
302 CALL zlascl( 'General', 0, 0, norma, smlnum, m, nrhs, b,
303 $ ldb, info )
304 ELSE
305 CALL xerbla( 'ZQRT15', 1 )
306 RETURN
307 END IF
308 END IF
309 END IF
310*
311 norma = dasum( mn, s, 1 )
312 normb = zlange( 'One-norm', m, nrhs, b, ldb, dummy )
313*
314 RETURN
315*
316* End of ZQRT15
317*
zlarf
subroutine zlarf(side, m, n, v, incv, tau, c, ldc, work)
ZLARF applies an elementary reflector to a general rectangular matrix.
Definition zlarf.f:128
zlaror
subroutine zlaror(side, init, m, n, a, lda, iseed, x, info)
ZLAROR
Definition zlaror.f:158
dznrm2
real(wp) function dznrm2(n, x, incx)
DZNRM2
Definition dznrm2.f90:90

◆ zqrt16()

subroutine zqrt16 ( character trans,
integer m,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) rwork,
double precision resid )

ZQRT16

Purpose:
!>
!> ZQRT16 computes the residual for a solution of a system of linear
!> equations  A*x = b  or  A'*x = b:
!>    RESID = norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ),
!> where EPS is the machine epsilon.
!>
Parameters
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations:
!>          = 'N':  A *x = b
!>          = 'T':  A^T*x = b, where A^T is the transpose of A
!>          = 'C':  A^H*x = b, where A^H is the conjugate transpose of A
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of B, the matrix of right hand sides.
!>          NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original M x N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors for the system of linear
!>          equations.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  If TRANS = 'N',
!>          LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  IF TRANS = 'N',
!>          LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 131 of file zqrt16.f.

133*
134* -- LAPACK test routine --
135* -- LAPACK is a software package provided by Univ. of Tennessee, --
136* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
137*
138* .. Scalar Arguments ..
139 CHARACTER TRANS
140 INTEGER LDA, LDB, LDX, M, N, NRHS
141 DOUBLE PRECISION RESID
142* ..
143* .. Array Arguments ..
144 DOUBLE PRECISION RWORK( * )
145 COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * )
146* ..
147*
148* =====================================================================
149*
150* .. Parameters ..
151 DOUBLE PRECISION ZERO, ONE
152 parameter( zero = 0.0d+0, one = 1.0d+0 )
153 COMPLEX*16 CONE
154 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
155* ..
156* .. Local Scalars ..
157 INTEGER J, N1, N2
158 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
159* ..
160* .. External Functions ..
161 LOGICAL LSAME
162 DOUBLE PRECISION DLAMCH, DZASUM, ZLANGE
163 EXTERNAL lsame, dlamch, dzasum, zlange
164* ..
165* .. External Subroutines ..
166 EXTERNAL zgemm
167* ..
168* .. Intrinsic Functions ..
169 INTRINSIC max
170* ..
171* .. Executable Statements ..
172*
173* Quick exit if M = 0 or N = 0 or NRHS = 0
174*
175 IF( m.LE.0 .OR. n.LE.0 .OR. nrhs.EQ.0 ) THEN
176 resid = zero
177 RETURN
178 END IF
179*
180 IF( lsame( trans, 'T' ) .OR. lsame( trans, 'C' ) ) THEN
181 anorm = zlange( 'I', m, n, a, lda, rwork )
182 n1 = n
183 n2 = m
184 ELSE
185 anorm = zlange( '1', m, n, a, lda, rwork )
186 n1 = m
187 n2 = n
188 END IF
189*
190 eps = dlamch( 'Epsilon' )
191*
192* Compute B - A*X (or B - A'*X ) and store in B.
193*
194 CALL zgemm( trans, 'No transpose', n1, nrhs, n2, -cone, a, lda, x,
195 $ ldx, cone, b, ldb )
196*
197* Compute the maximum over the number of right hand sides of
198* norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ) .
199*
200 resid = zero
201 DO 10 j = 1, nrhs
202 bnorm = dzasum( n1, b( 1, j ), 1 )
203 xnorm = dzasum( n2, x( 1, j ), 1 )
204 IF( anorm.EQ.zero .AND. bnorm.EQ.zero ) THEN
205 resid = zero
206 ELSE IF( anorm.LE.zero .OR. xnorm.LE.zero ) THEN
207 resid = one / eps
208 ELSE
209 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) /
210 $ ( max( m, n )*eps ) )
211 END IF
212 10 CONTINUE
213*
214 RETURN
215*
216* End of ZQRT16
217*

◆ zqrt17()

double precision function zqrt17 ( character trans,
integer iresid,
integer m,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldb, * ) c,
complex*16, dimension( lwork ) work,
integer lwork )

ZQRT17

Purpose:
!>
!> ZQRT17 computes the ratio
!>
!>    norm(R**H * op(A)) / ( norm(A) * alpha * max(M,N,NRHS) * EPS ),
!>
!> where R = B - op(A)*X, op(A) is A or A**H, depending on TRANS, EPS
!> is the machine epsilon, and
!>
!>    alpha = norm(B) if IRESID = 1 (zero-residual problem)
!>    alpha = norm(R) if IRESID = 2 (otherwise).
!>
!> The norm used is the 1-norm.
!>
Parameters
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies whether or not the transpose of A is used.
!>          = 'N':  No transpose, op(A) = A.
!>          = 'C':  Conjugate transpose, op(A) = A**H.
!>
[in]IRESID
!>          IRESID is INTEGER
!>          IRESID = 1 indicates zero-residual problem.
!>          IRESID = 2 indicates non-zero residual.
!>
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.
!>          If TRANS = 'N', the number of rows of the matrix B.
!>          If TRANS = 'C', the number of rows of the matrix X.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix  A.
!>          If TRANS = 'N', the number of rows of the matrix X.
!>          If TRANS = 'C', the number of rows of the matrix B.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of the matrices X and B.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The m-by-n matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= M.
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          If TRANS = 'N', the n-by-nrhs matrix X.
!>          If TRANS = 'C', the m-by-nrhs matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.
!>          If TRANS = 'N', LDX >= N.
!>          If TRANS = 'C', LDX >= M.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          If TRANS = 'N', the m-by-nrhs matrix B.
!>          If TRANS = 'C', the n-by-nrhs matrix B.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.
!>          If TRANS = 'N', LDB >= M.
!>          If TRANS = 'C', LDB >= N.
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDB,NRHS)
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  LWORK >= NRHS*(M+N).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 151 of file zqrt17.f.

153*
154* -- LAPACK test routine --
155* -- LAPACK is a software package provided by Univ. of Tennessee, --
156* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
157*
158* .. Scalar Arguments ..
159 CHARACTER TRANS
160 INTEGER IRESID, LDA, LDB, LDX, LWORK, M, N, NRHS
161* ..
162* .. Array Arguments ..
163 COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDB, * ),
164 $ WORK( LWORK ), X( LDX, * )
165* ..
166*
167* =====================================================================
168*
169* .. Parameters ..
170 DOUBLE PRECISION ZERO, ONE
171 parameter( zero = 0.0d0, one = 1.0d0 )
172* ..
173* .. Local Scalars ..
174 INTEGER INFO, ISCL, NCOLS, NROWS
175 DOUBLE PRECISION ERR, NORMA, NORMB, NORMRS, SMLNUM
176* ..
177* .. Local Arrays ..
178 DOUBLE PRECISION RWORK( 1 )
179* ..
180* .. External Functions ..
181 LOGICAL LSAME
182 DOUBLE PRECISION DLAMCH, ZLANGE
183 EXTERNAL lsame, dlamch, zlange
184* ..
185* .. External Subroutines ..
186 EXTERNAL xerbla, zgemm, zlacpy, zlascl
187* ..
188* .. Intrinsic Functions ..
189 INTRINSIC dble, dcmplx, max
190* ..
191* .. Executable Statements ..
192*
193 zqrt17 = zero
194*
195 IF( lsame( trans, 'N' ) ) THEN
196 nrows = m
197 ncols = n
198 ELSE IF( lsame( trans, 'C' ) ) THEN
199 nrows = n
200 ncols = m
201 ELSE
202 CALL xerbla( 'ZQRT17', 1 )
203 RETURN
204 END IF
205*
206 IF( lwork.LT.ncols*nrhs ) THEN
207 CALL xerbla( 'ZQRT17', 13 )
208 RETURN
209 END IF
210*
211 IF( m.LE.0 .OR. n.LE.0 .OR. nrhs.LE.0 )
212 $ RETURN
213*
214 norma = zlange( 'One-norm', m, n, a, lda, rwork )
215 smlnum = dlamch( 'Safe minimum' ) / dlamch( 'Precision' )
216 iscl = 0
217*
218* compute residual and scale it
219*
220 CALL zlacpy( 'All', nrows, nrhs, b, ldb, c, ldb )
221 CALL zgemm( trans, 'No transpose', nrows, nrhs, ncols,
222 $ dcmplx( -one ), a, lda, x, ldx, dcmplx( one ), c,
223 $ ldb )
224 normrs = zlange( 'Max', nrows, nrhs, c, ldb, rwork )
225 IF( normrs.GT.smlnum ) THEN
226 iscl = 1
227 CALL zlascl( 'General', 0, 0, normrs, one, nrows, nrhs, c, ldb,
228 $ info )
229 END IF
230*
231* compute R**H * op(A)
232*
233 CALL zgemm( 'Conjugate transpose', trans, nrhs, ncols, nrows,
234 $ dcmplx( one ), c, ldb, a, lda, dcmplx( zero ), work,
235 $ nrhs )
236*
237* compute and properly scale error
238*
239 err = zlange( 'One-norm', nrhs, ncols, work, nrhs, rwork )
240 IF( norma.NE.zero )
241 $ err = err / norma
242*
243 IF( iscl.EQ.1 )
244 $ err = err*normrs
245*
246 IF( iresid.EQ.1 ) THEN
247 normb = zlange( 'One-norm', nrows, nrhs, b, ldb, rwork )
248 IF( normb.NE.zero )
249 $ err = err / normb
250 ELSE
251 IF( normrs.NE.zero )
252 $ err = err / normrs
253 END IF
254*
255 zqrt17 = err / ( dlamch( 'Epsilon' )*dble( max( m, n, nrhs ) ) )
256 RETURN
257*
258* End of ZQRT17
259*

◆ zrqt01()

subroutine zrqt01 ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
complex*16, dimension( lda, * ) af,
complex*16, dimension( lda, * ) q,
complex*16, dimension( lda, * ) r,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result )

ZRQT01

Purpose:
!>
!> ZRQT01 tests ZGERQF, which computes the RQ factorization of an m-by-n
!> matrix A, and partially tests ZUNGRQ which forms the n-by-n
!> orthogonal matrix Q.
!>
!> ZRQT01 compares R with A*Q', and checks that Q is orthogonal.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The m-by-n matrix A.
!>
[out]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the RQ factorization of A, as returned by ZGERQF.
!>          See ZGERQF for further details.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDA,N)
!>          The n-by-n orthogonal matrix Q.
!>
[out]R
!>          R is COMPLEX*16 array, dimension (LDA,max(M,N))
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays A, AF, Q and L.
!>          LDA >= max(M,N).
!>
[out]TAU
!>          TAU is COMPLEX*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by ZGERQF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(M,N))
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file zrqt01.f.

126*
127* -- LAPACK test routine --
128* -- LAPACK is a software package provided by Univ. of Tennessee, --
129* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
130*
131* .. Scalar Arguments ..
132 INTEGER LDA, LWORK, M, N
133* ..
134* .. Array Arguments ..
135 DOUBLE PRECISION RESULT( * ), RWORK( * )
136 COMPLEX*16 A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
137 $ R( LDA, * ), TAU( * ), WORK( LWORK )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ZERO, ONE
144 parameter( zero = 0.0d+0, one = 1.0d+0 )
145 COMPLEX*16 ROGUE
146 parameter( rogue = ( -1.0d+10, -1.0d+10 ) )
147* ..
148* .. Local Scalars ..
149 INTEGER INFO, MINMN
150 DOUBLE PRECISION ANORM, EPS, RESID
151* ..
152* .. External Functions ..
153 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY
154 EXTERNAL dlamch, zlange, zlansy
155* ..
156* .. External Subroutines ..
157 EXTERNAL zgemm, zgerqf, zherk, zlacpy, zlaset, zungrq
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC dble, dcmplx, max, min
161* ..
162* .. Scalars in Common ..
163 CHARACTER*32 SRNAMT
164* ..
165* .. Common blocks ..
166 COMMON / srnamc / srnamt
167* ..
168* .. Executable Statements ..
169*
170 minmn = min( m, n )
171 eps = dlamch( 'Epsilon' )
172*
173* Copy the matrix A to the array AF.
174*
175 CALL zlacpy( 'Full', m, n, a, lda, af, lda )
176*
177* Factorize the matrix A in the array AF.
178*
179 srnamt = 'ZGERQF'
180 CALL zgerqf( m, n, af, lda, tau, work, lwork, info )
181*
182* Copy details of Q
183*
184 CALL zlaset( 'Full', n, n, rogue, rogue, q, lda )
185 IF( m.LE.n ) THEN
186 IF( m.GT.0 .AND. m.LT.n )
187 $ CALL zlacpy( 'Full', m, n-m, af, lda, q( n-m+1, 1 ), lda )
188 IF( m.GT.1 )
189 $ CALL zlacpy( 'Lower', m-1, m-1, af( 2, n-m+1 ), lda,
190 $ q( n-m+2, n-m+1 ), lda )
191 ELSE
192 IF( n.GT.1 )
193 $ CALL zlacpy( 'Lower', n-1, n-1, af( m-n+2, 1 ), lda,
194 $ q( 2, 1 ), lda )
195 END IF
196*
197* Generate the n-by-n matrix Q
198*
199 srnamt = 'ZUNGRQ'
200 CALL zungrq( n, n, minmn, q, lda, tau, work, lwork, info )
201*
202* Copy R
203*
204 CALL zlaset( 'Full', m, n, dcmplx( zero ), dcmplx( zero ), r,
205 $ lda )
206 IF( m.LE.n ) THEN
207 IF( m.GT.0 )
208 $ CALL zlacpy( 'Upper', m, m, af( 1, n-m+1 ), lda,
209 $ r( 1, n-m+1 ), lda )
210 ELSE
211 IF( m.GT.n .AND. n.GT.0 )
212 $ CALL zlacpy( 'Full', m-n, n, af, lda, r, lda )
213 IF( n.GT.0 )
214 $ CALL zlacpy( 'Upper', n, n, af( m-n+1, 1 ), lda,
215 $ r( m-n+1, 1 ), lda )
216 END IF
217*
218* Compute R - A*Q'
219*
220 CALL zgemm( 'No transpose', 'Conjugate transpose', m, n, n,
221 $ dcmplx( -one ), a, lda, q, lda, dcmplx( one ), r,
222 $ lda )
223*
224* Compute norm( R - Q'*A ) / ( N * norm(A) * EPS ) .
225*
226 anorm = zlange( '1', m, n, a, lda, rwork )
227 resid = zlange( '1', m, n, r, lda, rwork )
228 IF( anorm.GT.zero ) THEN
229 result( 1 ) = ( ( resid / dble( max( 1, n ) ) ) / anorm ) / eps
230 ELSE
231 result( 1 ) = zero
232 END IF
233*
234* Compute I - Q*Q'
235*
236 CALL zlaset( 'Full', n, n, dcmplx( zero ), dcmplx( one ), r, lda )
237 CALL zherk( 'Upper', 'No transpose', n, n, -one, q, lda, one, r,
238 $ lda )
239*
240* Compute norm( I - Q*Q' ) / ( N * EPS ) .
241*
242 resid = zlansy( '1', 'Upper', n, r, lda, rwork )
243*
244 result( 2 ) = ( resid / dble( max( 1, n ) ) ) / eps
245*
246 RETURN
247*
248* End of ZRQT01
249*

◆ zrqt02()

subroutine zrqt02 ( integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) a,
complex*16, dimension( lda, * ) af,
complex*16, dimension( lda, * ) q,
complex*16, dimension( lda, * ) r,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result )

ZRQT02

Purpose:
!>
!> ZRQT02 tests ZUNGRQ, which generates an m-by-n matrix Q with
!> orthonornmal rows that is defined as the product of k elementary
!> reflectors.
!>
!> Given the RQ factorization of an m-by-n matrix A, ZRQT02 generates
!> the orthogonal matrix Q defined by the factorization of the last k
!> rows of A; it compares R(m-k+1:m,n-m+1:n) with
!> A(m-k+1:m,1:n)*Q(n-m+1:n,1:n)', and checks that the rows of Q are
!> orthonormal.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix Q to be generated.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix Q to be generated.
!>          N >= M >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines the
!>          matrix Q. M >= K >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The m-by-n matrix A which was factorized by ZRQT01.
!>
[in]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the RQ factorization of A, as returned by ZGERQF.
!>          See ZGERQF for further details.
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDA,N)
!>
[out]R
!>          R is COMPLEX*16 array, dimension (LDA,M)
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays A, AF, Q and L. LDA >= N.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (M)
!>          The scalar factors of the elementary reflectors corresponding
!>          to the RQ factorization in AF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 134 of file zrqt02.f.

136*
137* -- LAPACK test routine --
138* -- LAPACK is a software package provided by Univ. of Tennessee, --
139* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
140*
141* .. Scalar Arguments ..
142 INTEGER K, LDA, LWORK, M, N
143* ..
144* .. Array Arguments ..
145 DOUBLE PRECISION RESULT( * ), RWORK( * )
146 COMPLEX*16 A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
147 $ R( LDA, * ), TAU( * ), WORK( LWORK )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 DOUBLE PRECISION ZERO, ONE
154 parameter( zero = 0.0d+0, one = 1.0d+0 )
155 COMPLEX*16 ROGUE
156 parameter( rogue = ( -1.0d+10, -1.0d+10 ) )
157* ..
158* .. Local Scalars ..
159 INTEGER INFO
160 DOUBLE PRECISION ANORM, EPS, RESID
161* ..
162* .. External Functions ..
163 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY
164 EXTERNAL dlamch, zlange, zlansy
165* ..
166* .. External Subroutines ..
167 EXTERNAL zgemm, zherk, zlacpy, zlaset, zungrq
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC dble, dcmplx, max
171* ..
172* .. Scalars in Common ..
173 CHARACTER*32 SRNAMT
174* ..
175* .. Common blocks ..
176 COMMON / srnamc / srnamt
177* ..
178* .. Executable Statements ..
179*
180* Quick return if possible
181*
182 IF( m.EQ.0 .OR. n.EQ.0 .OR. k.EQ.0 ) THEN
183 result( 1 ) = zero
184 result( 2 ) = zero
185 RETURN
186 END IF
187*
188 eps = dlamch( 'Epsilon' )
189*
190* Copy the last k rows of the factorization to the array Q
191*
192 CALL zlaset( 'Full', m, n, rogue, rogue, q, lda )
193 IF( k.LT.n )
194 $ CALL zlacpy( 'Full', k, n-k, af( m-k+1, 1 ), lda,
195 $ q( m-k+1, 1 ), lda )
196 IF( k.GT.1 )
197 $ CALL zlacpy( 'Lower', k-1, k-1, af( m-k+2, n-k+1 ), lda,
198 $ q( m-k+2, n-k+1 ), lda )
199*
200* Generate the last n rows of the matrix Q
201*
202 srnamt = 'ZUNGRQ'
203 CALL zungrq( m, n, k, q, lda, tau( m-k+1 ), work, lwork, info )
204*
205* Copy R(m-k+1:m,n-m+1:n)
206*
207 CALL zlaset( 'Full', k, m, dcmplx( zero ), dcmplx( zero ),
208 $ r( m-k+1, n-m+1 ), lda )
209 CALL zlacpy( 'Upper', k, k, af( m-k+1, n-k+1 ), lda,
210 $ r( m-k+1, n-k+1 ), lda )
211*
212* Compute R(m-k+1:m,n-m+1:n) - A(m-k+1:m,1:n) * Q(n-m+1:n,1:n)'
213*
214 CALL zgemm( 'No transpose', 'Conjugate transpose', k, m, n,
215 $ dcmplx( -one ), a( m-k+1, 1 ), lda, q, lda,
216 $ dcmplx( one ), r( m-k+1, n-m+1 ), lda )
217*
218* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) .
219*
220 anorm = zlange( '1', k, n, a( m-k+1, 1 ), lda, rwork )
221 resid = zlange( '1', k, m, r( m-k+1, n-m+1 ), lda, rwork )
222 IF( anorm.GT.zero ) THEN
223 result( 1 ) = ( ( resid / dble( max( 1, n ) ) ) / anorm ) / eps
224 ELSE
225 result( 1 ) = zero
226 END IF
227*
228* Compute I - Q*Q'
229*
230 CALL zlaset( 'Full', m, m, dcmplx( zero ), dcmplx( one ), r, lda )
231 CALL zherk( 'Upper', 'No transpose', m, n, -one, q, lda, one, r,
232 $ lda )
233*
234* Compute norm( I - Q*Q' ) / ( N * EPS ) .
235*
236 resid = zlansy( '1', 'Upper', m, r, lda, rwork )
237*
238 result( 2 ) = ( resid / dble( max( 1, n ) ) ) / eps
239*
240 RETURN
241*
242* End of ZRQT02
243*

◆ zrqt03()

subroutine zrqt03 ( integer m,
integer n,
integer k,
complex*16, dimension( lda, * ) af,
complex*16, dimension( lda, * ) c,
complex*16, dimension( lda, * ) cc,
complex*16, dimension( lda, * ) q,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( lwork ) work,
integer lwork,
double precision, dimension( * ) rwork,
double precision, dimension( * ) result )

ZRQT03

Purpose:
!>
!> ZRQT03 tests ZUNMRQ, which computes Q*C, Q'*C, C*Q or C*Q'.
!>
!> ZRQT03 compares the results of a call to ZUNMRQ with the results of
!> forming Q explicitly by a call to ZUNGRQ and then performing matrix
!> multiplication by a call to ZGEMM.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows or columns of the matrix C; C is n-by-m if
!>          Q is applied from the left, or m-by-n if Q is applied from
!>          the right.  M >= 0.
!>
[in]N
!>          N is INTEGER
!>          The order of the orthogonal matrix Q.  N >= 0.
!>
[in]K
!>          K is INTEGER
!>          The number of elementary reflectors whose product defines the
!>          orthogonal matrix Q.  N >= K >= 0.
!>
[in]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          Details of the RQ factorization of an m-by-n matrix, as
!>          returned by ZGERQF. See CGERQF for further details.
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDA,N)
!>
[out]CC
!>          CC is COMPLEX*16 array, dimension (LDA,N)
!>
[out]Q
!>          Q is COMPLEX*16 array, dimension (LDA,N)
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays AF, C, CC, and Q.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors corresponding
!>          to the RQ factorization in AF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of WORK.  LWORK must be at least M, and should be
!>          M*NB, where NB is the blocksize for this environment.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The test ratios compare two techniques for multiplying a
!>          random matrix C by an n-by-n orthogonal matrix Q.
!>          RESULT(1) = norm( Q*C - Q*C )  / ( N * norm(C) * EPS )
!>          RESULT(2) = norm( C*Q - C*Q )  / ( N * norm(C) * EPS )
!>          RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS )
!>          RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 134 of file zrqt03.f.

136*
137* -- LAPACK test routine --
138* -- LAPACK is a software package provided by Univ. of Tennessee, --
139* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
140*
141* .. Scalar Arguments ..
142 INTEGER K, LDA, LWORK, M, N
143* ..
144* .. Array Arguments ..
145 DOUBLE PRECISION RESULT( * ), RWORK( * )
146 COMPLEX*16 AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
147 $ Q( LDA, * ), TAU( * ), WORK( LWORK )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 DOUBLE PRECISION ZERO, ONE
154 parameter( zero = 0.0d+0, one = 1.0d+0 )
155 COMPLEX*16 ROGUE
156 parameter( rogue = ( -1.0d+10, -1.0d+10 ) )
157* ..
158* .. Local Scalars ..
159 CHARACTER SIDE, TRANS
160 INTEGER INFO, ISIDE, ITRANS, J, MC, MINMN, NC
161 DOUBLE PRECISION CNORM, EPS, RESID
162* ..
163* .. External Functions ..
164 LOGICAL LSAME
165 DOUBLE PRECISION DLAMCH, ZLANGE
166 EXTERNAL lsame, dlamch, zlange
167* ..
168* .. External Subroutines ..
169 EXTERNAL zgemm, zlacpy, zlarnv, zlaset, zungrq, zunmrq
170* ..
171* .. Local Arrays ..
172 INTEGER ISEED( 4 )
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC dble, dcmplx, max, min
176* ..
177* .. Scalars in Common ..
178 CHARACTER*32 SRNAMT
179* ..
180* .. Common blocks ..
181 COMMON / srnamc / srnamt
182* ..
183* .. Data statements ..
184 DATA iseed / 1988, 1989, 1990, 1991 /
185* ..
186* .. Executable Statements ..
187*
188 eps = dlamch( 'Epsilon' )
189 minmn = min( m, n )
190*
191* Quick return if possible
192*
193 IF( minmn.EQ.0 ) THEN
194 result( 1 ) = zero
195 result( 2 ) = zero
196 result( 3 ) = zero
197 result( 4 ) = zero
198 RETURN
199 END IF
200*
201* Copy the last k rows of the factorization to the array Q
202*
203 CALL zlaset( 'Full', n, n, rogue, rogue, q, lda )
204 IF( k.GT.0 .AND. n.GT.k )
205 $ CALL zlacpy( 'Full', k, n-k, af( m-k+1, 1 ), lda,
206 $ q( n-k+1, 1 ), lda )
207 IF( k.GT.1 )
208 $ CALL zlacpy( 'Lower', k-1, k-1, af( m-k+2, n-k+1 ), lda,
209 $ q( n-k+2, n-k+1 ), lda )
210*
211* Generate the n-by-n matrix Q
212*
213 srnamt = 'ZUNGRQ'
214 CALL zungrq( n, n, k, q, lda, tau( minmn-k+1 ), work, lwork,
215 $ info )
216*
217 DO 30 iside = 1, 2
218 IF( iside.EQ.1 ) THEN
219 side = 'L'
220 mc = n
221 nc = m
222 ELSE
223 side = 'R'
224 mc = m
225 nc = n
226 END IF
227*
228* Generate MC by NC matrix C
229*
230 DO 10 j = 1, nc
231 CALL zlarnv( 2, iseed, mc, c( 1, j ) )
232 10 CONTINUE
233 cnorm = zlange( '1', mc, nc, c, lda, rwork )
234 IF( cnorm.EQ.zero )
235 $ cnorm = one
236*
237 DO 20 itrans = 1, 2
238 IF( itrans.EQ.1 ) THEN
239 trans = 'N'
240 ELSE
241 trans = 'C'
242 END IF
243*
244* Copy C
245*
246 CALL zlacpy( 'Full', mc, nc, c, lda, cc, lda )
247*
248* Apply Q or Q' to C
249*
250 srnamt = 'ZUNMRQ'
251 IF( k.GT.0 )
252 $ CALL zunmrq( side, trans, mc, nc, k, af( m-k+1, 1 ), lda,
253 $ tau( minmn-k+1 ), cc, lda, work, lwork,
254 $ info )
255*
256* Form explicit product and subtract
257*
258 IF( lsame( side, 'L' ) ) THEN
259 CALL zgemm( trans, 'No transpose', mc, nc, mc,
260 $ dcmplx( -one ), q, lda, c, lda,
261 $ dcmplx( one ), cc, lda )
262 ELSE
263 CALL zgemm( 'No transpose', trans, mc, nc, nc,
264 $ dcmplx( -one ), c, lda, q, lda,
265 $ dcmplx( one ), cc, lda )
266 END IF
267*
268* Compute error in the difference
269*
270 resid = zlange( '1', mc, nc, cc, lda, rwork )
271 result( ( iside-1 )*2+itrans ) = resid /
272 $ ( dble( max( 1, n ) )*cnorm*eps )
273*
274 20 CONTINUE
275 30 CONTINUE
276*
277 RETURN
278*
279* End of ZRQT03
280*

◆ zrzt01()

double precision function zrzt01 ( integer m,
integer n,
complex*16, dimension( lda, * ) a,
complex*16, dimension( lda, * ) af,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( lwork ) work,
integer lwork )

ZRZT01

Purpose:
!>
!> ZRZT01 returns
!>      || A - R*Q || / ( M * eps * ||A|| )
!> for an upper trapezoidal A that was factored with ZTZRZF.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrices A and AF.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrices A and AF.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original upper trapezoidal M by N matrix A.
!>
[in]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          The output of ZTZRZF for input matrix A.
!>          The lower triangle is not referenced.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays A and AF.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (M)
!>          Details of the  Householder transformations as returned by
!>          ZTZRZF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  LWORK >= m*n + m.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 96 of file zrzt01.f.

98*
99* -- LAPACK test routine --
100* -- LAPACK is a software package provided by Univ. of Tennessee, --
101* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
102*
103* .. Scalar Arguments ..
104 INTEGER LDA, LWORK, M, N
105* ..
106* .. Array Arguments ..
107 COMPLEX*16 A( LDA, * ), AF( LDA, * ), TAU( * ),
108 $ WORK( LWORK )
109* ..
110*
111* =====================================================================
112*
113* .. Parameters ..
114 DOUBLE PRECISION ZERO, ONE
115 parameter( zero = 0.0d0, one = 1.0d0 )
116* ..
117* .. Local Scalars ..
118 INTEGER I, INFO, J
119 DOUBLE PRECISION NORMA
120* ..
121* .. Local Arrays ..
122 DOUBLE PRECISION RWORK( 1 )
123* ..
124* .. External Functions ..
125 DOUBLE PRECISION DLAMCH, ZLANGE
126 EXTERNAL dlamch, zlange
127* ..
128* .. External Subroutines ..
129 EXTERNAL xerbla, zaxpy, zlaset, zunmrz
130* ..
131* .. Intrinsic Functions ..
132 INTRINSIC dble, dcmplx, max
133* ..
134* .. Executable Statements ..
135*
136 zrzt01 = zero
137*
138 IF( lwork.LT.m*n+m ) THEN
139 CALL xerbla( 'ZRZT01', 8 )
140 RETURN
141 END IF
142*
143* Quick return if possible
144*
145 IF( m.LE.0 .OR. n.LE.0 )
146 $ RETURN
147*
148 norma = zlange( 'One-norm', m, n, a, lda, rwork )
149*
150* Copy upper triangle R
151*
152 CALL zlaset( 'Full', m, n, dcmplx( zero ), dcmplx( zero ), work,
153 $ m )
154 DO 20 j = 1, m
155 DO 10 i = 1, j
156 work( ( j-1 )*m+i ) = af( i, j )
157 10 CONTINUE
158 20 CONTINUE
159*
160* R = R * P(1) * ... *P(m)
161*
162 CALL zunmrz( 'Right', 'No tranpose', m, n, m, n-m, af, lda, tau,
163 $ work, m, work( m*n+1 ), lwork-m*n, info )
164*
165* R = R - A
166*
167 DO 30 i = 1, n
168 CALL zaxpy( m, dcmplx( -one ), a( 1, i ), 1,
169 $ work( ( i-1 )*m+1 ), 1 )
170 30 CONTINUE
171*
172 zrzt01 = zlange( 'One-norm', m, n, work, m, rwork )
173*
174 zrzt01 = zrzt01 / ( dlamch( 'Epsilon' )*dble( max( m, n ) ) )
175 IF( norma.NE.zero )
176 $ zrzt01 = zrzt01 / norma
177*
178 RETURN
179*
180* End of ZRZT01
181*
zunmrz
subroutine zunmrz(side, trans, m, n, k, l, a, lda, tau, c, ldc, work, lwork, info)
ZUNMRZ
Definition zunmrz.f:187

◆ zrzt02()

double precision function zrzt02 ( integer m,
integer n,
complex*16, dimension( lda, * ) af,
integer lda,
complex*16, dimension( * ) tau,
complex*16, dimension( lwork ) work,
integer lwork )

ZRZT02

Purpose:
!>
!> ZRZT02 returns
!>      || I - Q'*Q || / ( M * eps)
!> where the matrix Q is defined by the Householder transformations
!> generated by ZTZRZF.
!>
Parameters
[in]M
!>          M is INTEGER
!>          The number of rows of the matrix AF.
!>
[in]N
!>          N is INTEGER
!>          The number of columns of the matrix AF.
!>
[in]AF
!>          AF is COMPLEX*16 array, dimension (LDA,N)
!>          The output of ZTZRZF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array AF.
!>
[in]TAU
!>          TAU is COMPLEX*16 array, dimension (M)
!>          Details of the Householder transformations as returned by
!>          ZTZRZF.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          Length of WORK array. LWORK >= N*N+N.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 89 of file zrzt02.f.

91*
92* -- LAPACK test routine --
93* -- LAPACK is a software package provided by Univ. of Tennessee, --
94* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
95*
96* .. Scalar Arguments ..
97 INTEGER LDA, LWORK, M, N
98* ..
99* .. Array Arguments ..
100 COMPLEX*16 AF( LDA, * ), TAU( * ), WORK( LWORK )
101* ..
102*
103* =====================================================================
104*
105* .. Parameters ..
106 DOUBLE PRECISION ZERO, ONE
107 parameter( zero = 0.0d0, one = 1.0d0 )
108* ..
109* .. Local Scalars ..
110 INTEGER I, INFO
111* ..
112* .. Local Arrays ..
113 DOUBLE PRECISION RWORK( 1 )
114* ..
115* .. External Functions ..
116 DOUBLE PRECISION DLAMCH, ZLANGE
117 EXTERNAL dlamch, zlange
118* ..
119* .. External Subroutines ..
120 EXTERNAL xerbla, zlaset, zunmrz
121* ..
122* .. Intrinsic Functions ..
123 INTRINSIC dble, dcmplx, max
124* ..
125* .. Executable Statements ..
126*
127 zrzt02 = zero
128*
129 IF( lwork.LT.n*n+n ) THEN
130 CALL xerbla( 'ZRZT02', 7 )
131 RETURN
132 END IF
133*
134* Quick return if possible
135*
136 IF( m.LE.0 .OR. n.LE.0 )
137 $ RETURN
138*
139* Q := I
140*
141 CALL zlaset( 'Full', n, n, dcmplx( zero ), dcmplx( one ), work,
142 $ n )
143*
144* Q := P(1) * ... * P(m) * Q
145*
146 CALL zunmrz( 'Left', 'No transpose', n, n, m, n-m, af, lda, tau,
147 $ work, n, work( n*n+1 ), lwork-n*n, info )
148*
149* Q := P(m)' * ... * P(1)' * Q
150*
151 CALL zunmrz( 'Left', 'Conjugate transpose', n, n, m, n-m, af, lda,
152 $ tau, work, n, work( n*n+1 ), lwork-n*n, info )
153*
154* Q := Q - I
155*
156 DO 10 i = 1, n
157 work( ( i-1 )*n+i ) = work( ( i-1 )*n+i ) - one
158 10 CONTINUE
159*
160 zrzt02 = zlange( 'One-norm', n, n, work, n, rwork ) /
161 $ ( dlamch( 'Epsilon' )*dble( max( m, n ) ) )
162 RETURN
163*
164* End of ZRZT02
165*

◆ zsbmv()

subroutine zsbmv ( character uplo,
integer n,
integer k,
complex*16 alpha,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( * ) x,
integer incx,
complex*16 beta,
complex*16, dimension( * ) y,
integer incy )

ZSBMV

Purpose:
!>
!> ZSBMV  performs the matrix-vector  operation
!>
!>    y := alpha*A*x + beta*y,
!>
!> where alpha and beta are scalars, x and y are n element vectors and
!> A is an n by n symmetric band matrix, with k super-diagonals.
!> 
!>  UPLO   - CHARACTER*1
!>           On entry, UPLO specifies whether the upper or lower
!>           triangular part of the band matrix A is being supplied as
!>           follows:
!>
!>              UPLO = 'U' or 'u'   The upper triangular part of A is
!>                                  being supplied.
!>
!>              UPLO = 'L' or 'l'   The lower triangular part of A is
!>                                  being supplied.
!>
!>           Unchanged on exit.
!>
!>  N      - INTEGER
!>           On entry, N specifies the order of the matrix A.
!>           N must be at least zero.
!>           Unchanged on exit.
!>
!>  K      - INTEGER
!>           On entry, K specifies the number of super-diagonals of the
!>           matrix A. K must satisfy  0 .le. K.
!>           Unchanged on exit.
!>
!>  ALPHA  - COMPLEX*16
!>           On entry, ALPHA specifies the scalar alpha.
!>           Unchanged on exit.
!>
!>  A      - COMPLEX*16 array, dimension( LDA, N )
!>           Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
!>           by n part of the array A must contain the upper triangular
!>           band part of the symmetric matrix, supplied column by
!>           column, with the leading diagonal of the matrix in row
!>           ( k + 1 ) of the array, the first super-diagonal starting at
!>           position 2 in row k, and so on. The top left k by k triangle
!>           of the array A is not referenced.
!>           The following program segment will transfer the upper
!>           triangular part of a symmetric band matrix from conventional
!>           full matrix storage to band storage:
!>
!>                 DO 20, J = 1, N
!>                    M = K + 1 - J
!>                    DO 10, I = MAX( 1, J - K ), J
!>                       A( M + I, J ) = matrix( I, J )
!>              10    CONTINUE
!>              20 CONTINUE
!>
!>           Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
!>           by n part of the array A must contain the lower triangular
!>           band part of the symmetric matrix, supplied column by
!>           column, with the leading diagonal of the matrix in row 1 of
!>           the array, the first sub-diagonal starting at position 1 in
!>           row 2, and so on. The bottom right k by k triangle of the
!>           array A is not referenced.
!>           The following program segment will transfer the lower
!>           triangular part of a symmetric band matrix from conventional
!>           full matrix storage to band storage:
!>
!>                 DO 20, J = 1, N
!>                    M = 1 - J
!>                    DO 10, I = J, MIN( N, J + K )
!>                       A( M + I, J ) = matrix( I, J )
!>              10    CONTINUE
!>              20 CONTINUE
!>
!>           Unchanged on exit.
!>
!>  LDA    - INTEGER
!>           On entry, LDA specifies the first dimension of A as declared
!>           in the calling (sub) program. LDA must be at least
!>           ( k + 1 ).
!>           Unchanged on exit.
!>
!>  X      - COMPLEX*16 array, dimension at least
!>           ( 1 + ( N - 1 )*abs( INCX ) ).
!>           Before entry, the incremented array X must contain the
!>           vector x.
!>           Unchanged on exit.
!>
!>  INCX   - INTEGER
!>           On entry, INCX specifies the increment for the elements of
!>           X. INCX must not be zero.
!>           Unchanged on exit.
!>
!>  BETA   - COMPLEX*16
!>           On entry, BETA specifies the scalar beta.
!>           Unchanged on exit.
!>
!>  Y      - COMPLEX*16 array, dimension at least
!>           ( 1 + ( N - 1 )*abs( INCY ) ).
!>           Before entry, the incremented array Y must contain the
!>           vector y. On exit, Y is overwritten by the updated vector y.
!>
!>  INCY   - INTEGER
!>           On entry, INCY specifies the increment for the elements of
!>           Y. INCY must not be zero.
!>           Unchanged on exit.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 150 of file zsbmv.f.

152*
153* -- LAPACK test routine --
154* -- LAPACK is a software package provided by Univ. of Tennessee, --
155* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
156*
157* .. Scalar Arguments ..
158 CHARACTER UPLO
159 INTEGER INCX, INCY, K, LDA, N
160 COMPLEX*16 ALPHA, BETA
161* ..
162* .. Array Arguments ..
163 COMPLEX*16 A( LDA, * ), X( * ), Y( * )
164* ..
165*
166* =====================================================================
167*
168* .. Parameters ..
169 COMPLEX*16 ONE
170 parameter( one = ( 1.0d+0, 0.0d+0 ) )
171 COMPLEX*16 ZERO
172 parameter( zero = ( 0.0d+0, 0.0d+0 ) )
173* ..
174* .. Local Scalars ..
175 INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L
176 COMPLEX*16 TEMP1, TEMP2
177* ..
178* .. External Functions ..
179 LOGICAL LSAME
180 EXTERNAL lsame
181* ..
182* .. External Subroutines ..
183 EXTERNAL xerbla
184* ..
185* .. Intrinsic Functions ..
186 INTRINSIC max, min
187* ..
188* .. Executable Statements ..
189*
190* Test the input parameters.
191*
192 info = 0
193 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN
194 info = 1
195 ELSE IF( n.LT.0 ) THEN
196 info = 2
197 ELSE IF( k.LT.0 ) THEN
198 info = 3
199 ELSE IF( lda.LT.( k+1 ) ) THEN
200 info = 6
201 ELSE IF( incx.EQ.0 ) THEN
202 info = 8
203 ELSE IF( incy.EQ.0 ) THEN
204 info = 11
205 END IF
206 IF( info.NE.0 ) THEN
207 CALL xerbla( 'ZSBMV ', info )
208 RETURN
209 END IF
210*
211* Quick return if possible.
212*
213 IF( ( n.EQ.0 ) .OR. ( ( alpha.EQ.zero ) .AND. ( beta.EQ.one ) ) )
214 $ RETURN
215*
216* Set up the start points in X and Y.
217*
218 IF( incx.GT.0 ) THEN
219 kx = 1
220 ELSE
221 kx = 1 - ( n-1 )*incx
222 END IF
223 IF( incy.GT.0 ) THEN
224 ky = 1
225 ELSE
226 ky = 1 - ( n-1 )*incy
227 END IF
228*
229* Start the operations. In this version the elements of the array A
230* are accessed sequentially with one pass through A.
231*
232* First form y := beta*y.
233*
234 IF( beta.NE.one ) THEN
235 IF( incy.EQ.1 ) THEN
236 IF( beta.EQ.zero ) THEN
237 DO 10 i = 1, n
238 y( i ) = zero
239 10 CONTINUE
240 ELSE
241 DO 20 i = 1, n
242 y( i ) = beta*y( i )
243 20 CONTINUE
244 END IF
245 ELSE
246 iy = ky
247 IF( beta.EQ.zero ) THEN
248 DO 30 i = 1, n
249 y( iy ) = zero
250 iy = iy + incy
251 30 CONTINUE
252 ELSE
253 DO 40 i = 1, n
254 y( iy ) = beta*y( iy )
255 iy = iy + incy
256 40 CONTINUE
257 END IF
258 END IF
259 END IF
260 IF( alpha.EQ.zero )
261 $ RETURN
262 IF( lsame( uplo, 'U' ) ) THEN
263*
264* Form y when upper triangle of A is stored.
265*
266 kplus1 = k + 1
267 IF( ( incx.EQ.1 ) .AND. ( incy.EQ.1 ) ) THEN
268 DO 60 j = 1, n
269 temp1 = alpha*x( j )
270 temp2 = zero
271 l = kplus1 - j
272 DO 50 i = max( 1, j-k ), j - 1
273 y( i ) = y( i ) + temp1*a( l+i, j )
274 temp2 = temp2 + a( l+i, j )*x( i )
275 50 CONTINUE
276 y( j ) = y( j ) + temp1*a( kplus1, j ) + alpha*temp2
277 60 CONTINUE
278 ELSE
279 jx = kx
280 jy = ky
281 DO 80 j = 1, n
282 temp1 = alpha*x( jx )
283 temp2 = zero
284 ix = kx
285 iy = ky
286 l = kplus1 - j
287 DO 70 i = max( 1, j-k ), j - 1
288 y( iy ) = y( iy ) + temp1*a( l+i, j )
289 temp2 = temp2 + a( l+i, j )*x( ix )
290 ix = ix + incx
291 iy = iy + incy
292 70 CONTINUE
293 y( jy ) = y( jy ) + temp1*a( kplus1, j ) + alpha*temp2
294 jx = jx + incx
295 jy = jy + incy
296 IF( j.GT.k ) THEN
297 kx = kx + incx
298 ky = ky + incy
299 END IF
300 80 CONTINUE
301 END IF
302 ELSE
303*
304* Form y when lower triangle of A is stored.
305*
306 IF( ( incx.EQ.1 ) .AND. ( incy.EQ.1 ) ) THEN
307 DO 100 j = 1, n
308 temp1 = alpha*x( j )
309 temp2 = zero
310 y( j ) = y( j ) + temp1*a( 1, j )
311 l = 1 - j
312 DO 90 i = j + 1, min( n, j+k )
313 y( i ) = y( i ) + temp1*a( l+i, j )
314 temp2 = temp2 + a( l+i, j )*x( i )
315 90 CONTINUE
316 y( j ) = y( j ) + alpha*temp2
317 100 CONTINUE
318 ELSE
319 jx = kx
320 jy = ky
321 DO 120 j = 1, n
322 temp1 = alpha*x( jx )
323 temp2 = zero
324 y( jy ) = y( jy ) + temp1*a( 1, j )
325 l = 1 - j
326 ix = jx
327 iy = jy
328 DO 110 i = j + 1, min( n, j+k )
329 ix = ix + incx
330 iy = iy + incy
331 y( iy ) = y( iy ) + temp1*a( l+i, j )
332 temp2 = temp2 + a( l+i, j )*x( ix )
333 110 CONTINUE
334 y( jy ) = y( jy ) + alpha*temp2
335 jx = jx + incx
336 jy = jy + incy
337 120 CONTINUE
338 END IF
339 END IF
340*
341 RETURN
342*
343* End of ZSBMV
344*

◆ zspt01()

subroutine zspt01 ( character uplo,
integer n,
complex*16, dimension( * ) a,
complex*16, dimension( * ) afac,
integer, dimension( * ) ipiv,
complex*16, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) rwork,
double precision resid )

ZSPT01

Purpose:
!>
!> ZSPT01 reconstructs a symmetric indefinite packed matrix A from its
!> diagonal pivoting factorization A = U*D*U' or A = L*D*L' and computes
!> the residual
!>    norm( C - A ) / ( N * norm(A) * EPS ),
!> where C is the reconstructed matrix and EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          Hermitian matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The original symmetric matrix A, stored as a packed
!>          triangular matrix.
!>
[in]AFAC
!>          AFAC is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The factored form of the matrix A, stored as a packed
!>          triangular matrix.  AFAC contains the block diagonal matrix D
!>          and the multipliers used to obtain the factor L or U from the
!>          L*D*L' or U*D*U' factorization as computed by ZSPTRF.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from ZSPTRF.
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 111 of file zspt01.f.

112*
113* -- LAPACK test routine --
114* -- LAPACK is a software package provided by Univ. of Tennessee, --
115* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
116*
117* .. Scalar Arguments ..
118 CHARACTER UPLO
119 INTEGER LDC, N
120 DOUBLE PRECISION RESID
121* ..
122* .. Array Arguments ..
123 INTEGER IPIV( * )
124 DOUBLE PRECISION RWORK( * )
125 COMPLEX*16 A( * ), AFAC( * ), C( LDC, * )
126* ..
127*
128* =====================================================================
129*
130* .. Parameters ..
131 DOUBLE PRECISION ZERO, ONE
132 parameter( zero = 0.0d+0, one = 1.0d+0 )
133 COMPLEX*16 CZERO, CONE
134 parameter( czero = ( 0.0d+0, 0.0d+0 ),
135 $ cone = ( 1.0d+0, 0.0d+0 ) )
136* ..
137* .. Local Scalars ..
138 INTEGER I, INFO, J, JC
139 DOUBLE PRECISION ANORM, EPS
140* ..
141* .. External Functions ..
142 LOGICAL LSAME
143 DOUBLE PRECISION DLAMCH, ZLANSP, ZLANSY
144 EXTERNAL lsame, dlamch, zlansp, zlansy
145* ..
146* .. External Subroutines ..
147 EXTERNAL zlaset, zlavsp
148* ..
149* .. Intrinsic Functions ..
150 INTRINSIC dble
151* ..
152* .. Executable Statements ..
153*
154* Quick exit if N = 0.
155*
156 IF( n.LE.0 ) THEN
157 resid = zero
158 RETURN
159 END IF
160*
161* Determine EPS and the norm of A.
162*
163 eps = dlamch( 'Epsilon' )
164 anorm = zlansp( '1', uplo, n, a, rwork )
165*
166* Initialize C to the identity matrix.
167*
168 CALL zlaset( 'Full', n, n, czero, cone, c, ldc )
169*
170* Call ZLAVSP to form the product D * U' (or D * L' ).
171*
172 CALL zlavsp( uplo, 'Transpose', 'Non-unit', n, n, afac, ipiv, c,
173 $ ldc, info )
174*
175* Call ZLAVSP again to multiply by U ( or L ).
176*
177 CALL zlavsp( uplo, 'No transpose', 'Unit', n, n, afac, ipiv, c,
178 $ ldc, info )
179*
180* Compute the difference C - A .
181*
182 IF( lsame( uplo, 'U' ) ) THEN
183 jc = 0
184 DO 20 j = 1, n
185 DO 10 i = 1, j
186 c( i, j ) = c( i, j ) - a( jc+i )
187 10 CONTINUE
188 jc = jc + j
189 20 CONTINUE
190 ELSE
191 jc = 1
192 DO 40 j = 1, n
193 DO 30 i = j, n
194 c( i, j ) = c( i, j ) - a( jc+i-j )
195 30 CONTINUE
196 jc = jc + n - j + 1
197 40 CONTINUE
198 END IF
199*
200* Compute norm( C - A ) / ( N * norm(A) * EPS )
201*
202 resid = zlansy( '1', uplo, n, c, ldc, rwork )
203*
204 IF( anorm.LE.zero ) THEN
205 IF( resid.NE.zero )
206 $ resid = one / eps
207 ELSE
208 resid = ( ( resid / dble( n ) ) / anorm ) / eps
209 END IF
210*
211 RETURN
212*
213* End of ZSPT01
214*
zlavsp
subroutine zlavsp(uplo, trans, diag, n, nrhs, a, ipiv, b, ldb, info)
ZLAVSP
Definition zlavsp.f:131

◆ zspt02()

subroutine zspt02 ( character uplo,
integer n,
integer nrhs,
complex*16, dimension( * ) a,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) rwork,
double precision resid )

ZSPT02

Purpose:
!>
!> ZSPT02 computes the residual in the solution of a complex symmetric
!> system of linear equations  A*x = b  when packed storage is used for
!> the coefficient matrix.  The ratio computed is
!>
!>    RESID = norm( B - A*X ) / ( norm(A) * norm(X) * EPS).
!>
!> where EPS is the machine precision.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          complex symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of B, the matrix of right hand sides.
!>          NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The original complex symmetric matrix A, stored as a packed
!>          triangular matrix.
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors for the system of linear
!>          equations.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.   LDX >= max(1,N).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 121 of file zspt02.f.

123*
124* -- LAPACK test routine --
125* -- LAPACK is a software package provided by Univ. of Tennessee, --
126* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
127*
128* .. Scalar Arguments ..
129 CHARACTER UPLO
130 INTEGER LDB, LDX, N, NRHS
131 DOUBLE PRECISION RESID
132* ..
133* .. Array Arguments ..
134 DOUBLE PRECISION RWORK( * )
135 COMPLEX*16 A( * ), B( LDB, * ), X( LDX, * )
136* ..
137*
138* =====================================================================
139*
140* .. Parameters ..
141 DOUBLE PRECISION ZERO, ONE
142 parameter( zero = 0.0d+0, one = 1.0d+0 )
143 COMPLEX*16 CONE
144 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
145* ..
146* .. Local Scalars ..
147 INTEGER J
148 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
149* ..
150* .. External Functions ..
151 DOUBLE PRECISION DLAMCH, DZASUM, ZLANSP
152 EXTERNAL dlamch, dzasum, zlansp
153* ..
154* .. External Subroutines ..
155 EXTERNAL zspmv
156* ..
157* .. Intrinsic Functions ..
158 INTRINSIC max
159* ..
160* .. Executable Statements ..
161*
162* Quick exit if N = 0 or NRHS = 0
163*
164 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
165 resid = zero
166 RETURN
167 END IF
168*
169* Exit with RESID = 1/EPS if ANORM = 0.
170*
171 eps = dlamch( 'Epsilon' )
172 anorm = zlansp( '1', uplo, n, a, rwork )
173 IF( anorm.LE.zero ) THEN
174 resid = one / eps
175 RETURN
176 END IF
177*
178* Compute B - A*X for the matrix of right hand sides B.
179*
180 DO 10 j = 1, nrhs
181 CALL zspmv( uplo, n, -cone, a, x( 1, j ), 1, cone, b( 1, j ),
182 $ 1 )
183 10 CONTINUE
184*
185* Compute the maximum over the number of right hand sides of
186* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) .
187*
188 resid = zero
189 DO 20 j = 1, nrhs
190 bnorm = dzasum( n, b( 1, j ), 1 )
191 xnorm = dzasum( n, x( 1, j ), 1 )
192 IF( xnorm.LE.zero ) THEN
193 resid = one / eps
194 ELSE
195 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
196 END IF
197 20 CONTINUE
198*
199 RETURN
200*
201* End of ZSPT02
202*

◆ zspt03()

subroutine zspt03 ( character uplo,
integer n,
complex*16, dimension( * ) a,
complex*16, dimension( * ) ainv,
complex*16, dimension( ldw, * ) work,
integer ldw,
double precision, dimension( * ) rwork,
double precision rcond,
double precision resid )

ZSPT03

Purpose:
!>
!> ZSPT03 computes the residual for a complex symmetric packed matrix
!> times its inverse:
!>    norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ),
!> where EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          complex symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The original complex symmetric matrix A, stored as a packed
!>          triangular matrix.
!>
[in]AINV
!>          AINV is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The (symmetric) inverse of the matrix A, stored as a packed
!>          triangular matrix.
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LDW,N)
!>
[in]LDW
!>          LDW is INTEGER
!>          The leading dimension of the array WORK.  LDW >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of A, computed as
!>          ( 1/norm(A) ) / norm(AINV).
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 108 of file zspt03.f.

110*
111* -- LAPACK test routine --
112* -- LAPACK is a software package provided by Univ. of Tennessee, --
113* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
114*
115* .. Scalar Arguments ..
116 CHARACTER UPLO
117 INTEGER LDW, N
118 DOUBLE PRECISION RCOND, RESID
119* ..
120* .. Array Arguments ..
121 DOUBLE PRECISION RWORK( * )
122 COMPLEX*16 A( * ), AINV( * ), WORK( LDW, * )
123* ..
124*
125* =====================================================================
126*
127* .. Parameters ..
128 DOUBLE PRECISION ZERO, ONE
129 parameter( zero = 0.0d+0, one = 1.0d+0 )
130* ..
131* .. Local Scalars ..
132 INTEGER I, ICOL, J, JCOL, K, KCOL, NALL
133 DOUBLE PRECISION AINVNM, ANORM, EPS
134 COMPLEX*16 T
135* ..
136* .. External Functions ..
137 LOGICAL LSAME
138 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSP
139 COMPLEX*16 ZDOTU
140 EXTERNAL lsame, dlamch, zlange, zlansp, zdotu
141* ..
142* .. Intrinsic Functions ..
143 INTRINSIC dble
144* ..
145* .. Executable Statements ..
146*
147* Quick exit if N = 0.
148*
149 IF( n.LE.0 ) THEN
150 rcond = one
151 resid = zero
152 RETURN
153 END IF
154*
155* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
156*
157 eps = dlamch( 'Epsilon' )
158 anorm = zlansp( '1', uplo, n, a, rwork )
159 ainvnm = zlansp( '1', uplo, n, ainv, rwork )
160 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
161 rcond = zero
162 resid = one / eps
163 RETURN
164 END IF
165 rcond = ( one / anorm ) / ainvnm
166*
167* Case where both A and AINV are upper triangular:
168* Each element of - A * AINV is computed by taking the dot product
169* of a row of A with a column of AINV.
170*
171 IF( lsame( uplo, 'U' ) ) THEN
172 DO 70 i = 1, n
173 icol = ( ( i-1 )*i ) / 2 + 1
174*
175* Code when J <= I
176*
177 DO 30 j = 1, i
178 jcol = ( ( j-1 )*j ) / 2 + 1
179 t = zdotu( j, a( icol ), 1, ainv( jcol ), 1 )
180 jcol = jcol + 2*j - 1
181 kcol = icol - 1
182 DO 10 k = j + 1, i
183 t = t + a( kcol+k )*ainv( jcol )
184 jcol = jcol + k
185 10 CONTINUE
186 kcol = kcol + 2*i
187 DO 20 k = i + 1, n
188 t = t + a( kcol )*ainv( jcol )
189 kcol = kcol + k
190 jcol = jcol + k
191 20 CONTINUE
192 work( i, j ) = -t
193 30 CONTINUE
194*
195* Code when J > I
196*
197 DO 60 j = i + 1, n
198 jcol = ( ( j-1 )*j ) / 2 + 1
199 t = zdotu( i, a( icol ), 1, ainv( jcol ), 1 )
200 jcol = jcol - 1
201 kcol = icol + 2*i - 1
202 DO 40 k = i + 1, j
203 t = t + a( kcol )*ainv( jcol+k )
204 kcol = kcol + k
205 40 CONTINUE
206 jcol = jcol + 2*j
207 DO 50 k = j + 1, n
208 t = t + a( kcol )*ainv( jcol )
209 kcol = kcol + k
210 jcol = jcol + k
211 50 CONTINUE
212 work( i, j ) = -t
213 60 CONTINUE
214 70 CONTINUE
215 ELSE
216*
217* Case where both A and AINV are lower triangular
218*
219 nall = ( n*( n+1 ) ) / 2
220 DO 140 i = 1, n
221*
222* Code when J <= I
223*
224 icol = nall - ( ( n-i+1 )*( n-i+2 ) ) / 2 + 1
225 DO 100 j = 1, i
226 jcol = nall - ( ( n-j )*( n-j+1 ) ) / 2 - ( n-i )
227 t = zdotu( n-i+1, a( icol ), 1, ainv( jcol ), 1 )
228 kcol = i
229 jcol = j
230 DO 80 k = 1, j - 1
231 t = t + a( kcol )*ainv( jcol )
232 jcol = jcol + n - k
233 kcol = kcol + n - k
234 80 CONTINUE
235 jcol = jcol - j
236 DO 90 k = j, i - 1
237 t = t + a( kcol )*ainv( jcol+k )
238 kcol = kcol + n - k
239 90 CONTINUE
240 work( i, j ) = -t
241 100 CONTINUE
242*
243* Code when J > I
244*
245 icol = nall - ( ( n-i )*( n-i+1 ) ) / 2
246 DO 130 j = i + 1, n
247 jcol = nall - ( ( n-j+1 )*( n-j+2 ) ) / 2 + 1
248 t = zdotu( n-j+1, a( icol-n+j ), 1, ainv( jcol ), 1 )
249 kcol = i
250 jcol = j
251 DO 110 k = 1, i - 1
252 t = t + a( kcol )*ainv( jcol )
253 jcol = jcol + n - k
254 kcol = kcol + n - k
255 110 CONTINUE
256 kcol = kcol - i
257 DO 120 k = i, j - 1
258 t = t + a( kcol+k )*ainv( jcol )
259 jcol = jcol + n - k
260 120 CONTINUE
261 work( i, j ) = -t
262 130 CONTINUE
263 140 CONTINUE
264 END IF
265*
266* Add the identity matrix to WORK .
267*
268 DO 150 i = 1, n
269 work( i, i ) = work( i, i ) + one
270 150 CONTINUE
271*
272* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS)
273*
274 resid = zlange( '1', n, n, work, ldw, rwork )
275*
276 resid = ( ( resid*rcond ) / eps ) / dble( n )
277*
278 RETURN
279*
280* End of ZSPT03
281*

◆ zsyt01()

subroutine zsyt01 ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldafac, * ) afac,
integer ldafac,
integer, dimension( * ) ipiv,
complex*16, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) rwork,
double precision resid )

ZSYT01

Purpose:
!>
!> ZSYT01 reconstructs a complex symmetric indefinite matrix A from its
!> block L*D*L' or U*D*U' factorization and computes the residual
!>    norm( C - A ) / ( N * norm(A) * EPS ),
!> where C is the reconstructed matrix, EPS is the machine epsilon,
!> L' is the transpose of L, and U' is the transpose of U.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          complex symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original complex symmetric matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N)
!>
[in]AFAC
!>          AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
!>          The factored form of the matrix A.  AFAC contains the block
!>          diagonal matrix D and the multipliers used to obtain the
!>          factor L or U from the block L*D*L' or U*D*U' factorization
!>          as computed by ZSYTRF.
!>
[in]LDAFAC
!>          LDAFAC is INTEGER
!>          The leading dimension of the array AFAC.  LDAFAC >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from ZSYTRF.
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 123 of file zsyt01.f.

125*
126* -- LAPACK test routine --
127* -- LAPACK is a software package provided by Univ. of Tennessee, --
128* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
129*
130* .. Scalar Arguments ..
131 CHARACTER UPLO
132 INTEGER LDA, LDAFAC, LDC, N
133 DOUBLE PRECISION RESID
134* ..
135* .. Array Arguments ..
136 INTEGER IPIV( * )
137 DOUBLE PRECISION RWORK( * )
138 COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 DOUBLE PRECISION ZERO, ONE
145 parameter( zero = 0.0d+0, one = 1.0d+0 )
146 COMPLEX*16 CZERO, CONE
147 parameter( czero = ( 0.0d+0, 0.0d+0 ),
148 $ cone = ( 1.0d+0, 0.0d+0 ) )
149* ..
150* .. Local Scalars ..
151 INTEGER I, INFO, J
152 DOUBLE PRECISION ANORM, EPS
153* ..
154* .. External Functions ..
155 LOGICAL LSAME
156 DOUBLE PRECISION DLAMCH, ZLANSY
157 EXTERNAL lsame, dlamch, zlansy
158* ..
159* .. External Subroutines ..
160 EXTERNAL zlaset, zlavsy
161* ..
162* .. Intrinsic Functions ..
163 INTRINSIC dble
164* ..
165* .. Executable Statements ..
166*
167* Quick exit if N = 0.
168*
169 IF( n.LE.0 ) THEN
170 resid = zero
171 RETURN
172 END IF
173*
174* Determine EPS and the norm of A.
175*
176 eps = dlamch( 'Epsilon' )
177 anorm = zlansy( '1', uplo, n, a, lda, rwork )
178*
179* Initialize C to the identity matrix.
180*
181 CALL zlaset( 'Full', n, n, czero, cone, c, ldc )
182*
183* Call ZLAVSY to form the product D * U' (or D * L' ).
184*
185 CALL zlavsy( uplo, 'Transpose', 'Non-unit', n, n, afac, ldafac,
186 $ ipiv, c, ldc, info )
187*
188* Call ZLAVSY again to multiply by U (or L ).
189*
190 CALL zlavsy( uplo, 'No transpose', 'Unit', n, n, afac, ldafac,
191 $ ipiv, c, ldc, info )
192*
193* Compute the difference C - A .
194*
195 IF( lsame( uplo, 'U' ) ) THEN
196 DO 20 j = 1, n
197 DO 10 i = 1, j
198 c( i, j ) = c( i, j ) - a( i, j )
199 10 CONTINUE
200 20 CONTINUE
201 ELSE
202 DO 40 j = 1, n
203 DO 30 i = j, n
204 c( i, j ) = c( i, j ) - a( i, j )
205 30 CONTINUE
206 40 CONTINUE
207 END IF
208*
209* Compute norm( C - A ) / ( N * norm(A) * EPS )
210*
211 resid = zlansy( '1', uplo, n, c, ldc, rwork )
212*
213 IF( anorm.LE.zero ) THEN
214 IF( resid.NE.zero )
215 $ resid = one / eps
216 ELSE
217 resid = ( ( resid / dble( n ) ) / anorm ) / eps
218 END IF
219*
220 RETURN
221*
222* End of ZSYT01
223*
zlavsy
subroutine zlavsy(uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
ZLAVSY
Definition zlavsy.f:153

◆ zsyt01_3()

subroutine zsyt01_3 ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldafac, * ) afac,
integer ldafac,
complex*16, dimension( * ) e,
integer, dimension( * ) ipiv,
complex*16, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) rwork,
double precision resid )

ZSYT01_3

Purpose:
!>
!> ZSYT01_3 reconstructs a symmetric indefinite matrix A from its
!> block L*D*L' or U*D*U' factorization computed by ZSYTRF_RK
!> (or ZSYTRF_BK) and computes the residual
!>    norm( C - A ) / ( N * norm(A) * EPS ),
!> where C is the reconstructed matrix and EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original symmetric matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N)
!>
[in]AFAC
!>          AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
!>          Diagonal of the block diagonal matrix D and factors U or L
!>          as computed by ZSYTRF_RK and ZSYTRF_BK:
!>            a) ONLY diagonal elements of the symmetric block diagonal
!>               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k);
!>               (superdiagonal (or subdiagonal) elements of D
!>                should be provided on entry in array E), and
!>            b) If UPLO = 'U': factor U in the superdiagonal part of A.
!>               If UPLO = 'L': factor L in the subdiagonal part of A.
!>
[in]LDAFAC
!>          LDAFAC is INTEGER
!>          The leading dimension of the array AFAC.
!>          LDAFAC >= max(1,N).
!>
[in]E
!>          E is COMPLEX*16 array, dimension (N)
!>          On entry, contains the superdiagonal (or subdiagonal)
!>          elements of the symmetric block diagonal matrix D
!>          with 1-by-1 or 2-by-2 diagonal blocks, where
!>          If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced;
!>          If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from ZSYTRF_RK (or ZSYTRF_BK).
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 139 of file zsyt01_3.f.

141*
142* -- LAPACK test routine --
143* -- LAPACK is a software package provided by Univ. of Tennessee, --
144* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
145*
146* .. Scalar Arguments ..
147 CHARACTER UPLO
148 INTEGER LDA, LDAFAC, LDC, N
149 DOUBLE PRECISION RESID
150* ..
151* .. Array Arguments ..
152 INTEGER IPIV( * )
153 DOUBLE PRECISION RWORK( * )
154 COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
155 $ E( * )
156* ..
157*
158* =====================================================================
159*
160* .. Parameters ..
161 DOUBLE PRECISION ZERO, ONE
162 parameter( zero = 0.0d+0, one = 1.0d+0 )
163 COMPLEX*16 CZERO, CONE
164 parameter( czero = ( 0.0d+0, 0.0d+0 ),
165 $ cone = ( 1.0d+0, 0.0d+0 ) )
166* ..
167* .. Local Scalars ..
168 INTEGER I, INFO, J
169 DOUBLE PRECISION ANORM, EPS
170* ..
171* .. External Functions ..
172 LOGICAL LSAME
173 DOUBLE PRECISION DLAMCH, ZLANSY
174 EXTERNAL lsame, dlamch, zlansy
175* ..
176* .. External Subroutines ..
177 EXTERNAL zlaset, zlavsy_rook, zsyconvf_rook
178* ..
179* .. Intrinsic Functions ..
180 INTRINSIC dble
181* ..
182* .. Executable Statements ..
183*
184* Quick exit if N = 0.
185*
186 IF( n.LE.0 ) THEN
187 resid = zero
188 RETURN
189 END IF
190*
191* a) Revert to multiplyers of L
192*
193 CALL zsyconvf_rook( uplo, 'R', n, afac, ldafac, e, ipiv, info )
194*
195* 1) Determine EPS and the norm of A.
196*
197 eps = dlamch( 'Epsilon' )
198 anorm = zlansy( '1', uplo, n, a, lda, rwork )
199*
200* 2) Initialize C to the identity matrix.
201*
202 CALL zlaset( 'Full', n, n, czero, cone, c, ldc )
203*
204* 3) Call ZLAVSY_ROOK to form the product D * U' (or D * L' ).
205*
206 CALL zlavsy_rook( uplo, 'Transpose', 'Non-unit', n, n, afac,
207 $ ldafac, ipiv, c, ldc, info )
208*
209* 4) Call ZLAVSY_ROOK again to multiply by U (or L ).
210*
211 CALL zlavsy_rook( uplo, 'No transpose', 'Unit', n, n, afac,
212 $ ldafac, ipiv, c, ldc, info )
213*
214* 5) Compute the difference C - A .
215*
216 IF( lsame( uplo, 'U' ) ) THEN
217 DO j = 1, n
218 DO i = 1, j
219 c( i, j ) = c( i, j ) - a( i, j )
220 END DO
221 END DO
222 ELSE
223 DO j = 1, n
224 DO i = j, n
225 c( i, j ) = c( i, j ) - a( i, j )
226 END DO
227 END DO
228 END IF
229*
230* 6) Compute norm( C - A ) / ( N * norm(A) * EPS )
231*
232 resid = zlansy( '1', uplo, n, c, ldc, rwork )
233*
234 IF( anorm.LE.zero ) THEN
235 IF( resid.NE.zero )
236 $ resid = one / eps
237 ELSE
238 resid = ( ( resid / dble( n ) ) / anorm ) / eps
239 END IF
240
241*
242* b) Convert to factor of L (or U)
243*
244 CALL zsyconvf_rook( uplo, 'C', n, afac, ldafac, e, ipiv, info )
245*
246 RETURN
247*
248* End of ZSYT01_3
249*
zlavsy_rook
subroutine zlavsy_rook(uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
ZLAVSY_ROOK
Definition zlavsy_rook.f:155

◆ zsyt01_aa()

subroutine zsyt01_aa ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldafac, * ) afac,
integer ldafac,
integer, dimension( * ) ipiv,
complex*16, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) rwork,
double precision resid )

ZSYT01

Purpose:
!>
!> ZSYT01 reconstructs a hermitian indefinite matrix A from its
!> block L*D*L' or U*D*U' factorization and computes the residual
!>    norm( C - A ) / ( N * norm(A) * EPS ),
!> where C is the reconstructed matrix and EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          hermitian matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original hermitian matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N)
!>
[in]AFAC
!>          AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
!>          The factored form of the matrix A.  AFAC contains the block
!>          diagonal matrix D and the multipliers used to obtain the
!>          factor L or U from the block L*D*L' or U*D*U' factorization
!>          as computed by ZSYTRF.
!>
[in]LDAFAC
!>          LDAFAC is INTEGER
!>          The leading dimension of the array AFAC.  LDAFAC >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from ZSYTRF.
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is COMPLEX*16 array, dimension (N)
!>
[out]RESID
!>          RESID is COMPLEX*16
!>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 122 of file zsyt01_aa.f.

124*
125* -- LAPACK test routine --
126* -- LAPACK is a software package provided by Univ. of Tennessee, --
127* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
128*
129* .. Scalar Arguments ..
130 CHARACTER UPLO
131 INTEGER LDA, LDAFAC, LDC, N
132 DOUBLE PRECISION RESID
133* ..
134* .. Array Arguments ..
135 INTEGER IPIV( * )
136 COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
137 DOUBLE PRECISION RWORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ZERO, ONE
144 parameter( zero = 0.0d+0, one = 1.0d+0 )
145 COMPLEX*16 CZERO, CONE
146 parameter( czero = 0.0e+0, cone = 1.0e+0 )
147* ..
148* .. Local Scalars ..
149 INTEGER I, J
150 DOUBLE PRECISION ANORM, EPS
151* ..
152* .. External Functions ..
153 LOGICAL LSAME
154 DOUBLE PRECISION DLAMCH, ZLANSY
155 EXTERNAL lsame, dlamch, zlansy
156* ..
157* .. External Subroutines ..
158 EXTERNAL zlaset, zlavsy
159* ..
160* .. Intrinsic Functions ..
161 INTRINSIC dble
162* ..
163* .. Executable Statements ..
164*
165* Quick exit if N = 0.
166*
167 IF( n.LE.0 ) THEN
168 resid = zero
169 RETURN
170 END IF
171*
172* Determine EPS and the norm of A.
173*
174 eps = dlamch( 'Epsilon' )
175 anorm = zlansy( '1', uplo, n, a, lda, rwork )
176*
177* Initialize C to the tridiagonal matrix T.
178*
179 CALL zlaset( 'Full', n, n, czero, czero, c, ldc )
180 CALL zlacpy( 'F', 1, n, afac( 1, 1 ), ldafac+1, c( 1, 1 ), ldc+1 )
181 IF( n.GT.1 ) THEN
182 IF( lsame( uplo, 'U' ) ) THEN
183 CALL zlacpy( 'F', 1, n-1, afac( 1, 2 ), ldafac+1, c( 1, 2 ),
184 $ ldc+1 )
185 CALL zlacpy( 'F', 1, n-1, afac( 1, 2 ), ldafac+1, c( 2, 1 ),
186 $ ldc+1 )
187 ELSE
188 CALL zlacpy( 'F', 1, n-1, afac( 2, 1 ), ldafac+1, c( 1, 2 ),
189 $ ldc+1 )
190 CALL zlacpy( 'F', 1, n-1, afac( 2, 1 ), ldafac+1, c( 2, 1 ),
191 $ ldc+1 )
192 ENDIF
193*
194* Call ZTRMM to form the product U' * D (or L * D ).
195*
196 IF( lsame( uplo, 'U' ) ) THEN
197 CALL ztrmm( 'Left', uplo, 'Transpose', 'Unit', n-1, n,
198 $ cone, afac( 1, 2 ), ldafac, c( 2, 1 ), ldc )
199 ELSE
200 CALL ztrmm( 'Left', uplo, 'No transpose', 'Unit', n-1, n,
201 $ cone, afac( 2, 1 ), ldafac, c( 2, 1 ), ldc )
202 END IF
203*
204* Call ZTRMM again to multiply by U (or L ).
205*
206 IF( lsame( uplo, 'U' ) ) THEN
207 CALL ztrmm( 'Right', uplo, 'No transpose', 'Unit', n, n-1,
208 $ cone, afac( 1, 2 ), ldafac, c( 1, 2 ), ldc )
209 ELSE
210 CALL ztrmm( 'Right', uplo, 'Transpose', 'Unit', n, n-1,
211 $ cone, afac( 2, 1 ), ldafac, c( 1, 2 ), ldc )
212 END IF
213 ENDIF
214*
215* Apply symmetric pivots
216*
217 DO j = n, 1, -1
218 i = ipiv( j )
219 IF( i.NE.j )
220 $ CALL zswap( n, c( j, 1 ), ldc, c( i, 1 ), ldc )
221 END DO
222 DO j = n, 1, -1
223 i = ipiv( j )
224 IF( i.NE.j )
225 $ CALL zswap( n, c( 1, j ), 1, c( 1, i ), 1 )
226 END DO
227*
228*
229* Compute the difference C - A .
230*
231 IF( lsame( uplo, 'U' ) ) THEN
232 DO j = 1, n
233 DO i = 1, j
234 c( i, j ) = c( i, j ) - a( i, j )
235 END DO
236 END DO
237 ELSE
238 DO j = 1, n
239 DO i = j, n
240 c( i, j ) = c( i, j ) - a( i, j )
241 END DO
242 END DO
243 END IF
244*
245* Compute norm( C - A ) / ( N * norm(A) * EPS )
246*
247 resid = zlansy( '1', uplo, n, c, ldc, rwork )
248*
249 IF( anorm.LE.zero ) THEN
250 IF( resid.NE.zero )
251 $ resid = one / eps
252 ELSE
253 resid = ( ( resid / dble( n ) ) / anorm ) / eps
254 END IF
255*
256 RETURN
257*
258* End of ZSYT01_AA
259*

◆ zsyt01_rook()

subroutine zsyt01_rook ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldafac, * ) afac,
integer ldafac,
integer, dimension( * ) ipiv,
complex*16, dimension( ldc, * ) c,
integer ldc,
double precision, dimension( * ) rwork,
double precision resid )

ZSYT01_ROOK

Purpose:
!>
!> ZSYT01_ROOK reconstructs a complex symmetric indefinite matrix A from its
!> block L*D*L' or U*D*U' factorization and computes the residual
!>    norm( C - A ) / ( N * norm(A) * EPS ),
!> where C is the reconstructed matrix, EPS is the machine epsilon,
!> L' is the transpose of L, and U' is the transpose of U.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          complex symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original complex symmetric matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N)
!>
[in]AFAC
!>          AFAC is COMPLEX*16 array, dimension (LDAFAC,N)
!>          The factored form of the matrix A.  AFAC contains the block
!>          diagonal matrix D and the multipliers used to obtain the
!>          factor L or U from the block L*D*L' or U*D*U' factorization
!>          as computed by ZSYTRF_ROOK.
!>
[in]LDAFAC
!>          LDAFAC is INTEGER
!>          The leading dimension of the array AFAC.  LDAFAC >= max(1,N).
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from ZSYTRF_ROOK.
!>
[out]C
!>          C is COMPLEX*16 array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 123 of file zsyt01_rook.f.

125*
126* -- LAPACK test routine --
127* -- LAPACK is a software package provided by Univ. of Tennessee, --
128* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
129*
130* .. Scalar Arguments ..
131 CHARACTER UPLO
132 INTEGER LDA, LDAFAC, LDC, N
133 DOUBLE PRECISION RESID
134* ..
135* .. Array Arguments ..
136 INTEGER IPIV( * )
137 DOUBLE PRECISION RWORK( * )
138 COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 DOUBLE PRECISION ZERO, ONE
145 parameter( zero = 0.0d+0, one = 1.0d+0 )
146 COMPLEX*16 CZERO, CONE
147 parameter( czero = ( 0.0d+0, 0.0d+0 ),
148 $ cone = ( 1.0d+0, 0.0d+0 ) )
149* ..
150* .. Local Scalars ..
151 INTEGER I, INFO, J
152 DOUBLE PRECISION ANORM, EPS
153* ..
154* .. External Functions ..
155 LOGICAL LSAME
156 DOUBLE PRECISION DLAMCH, ZLANSY
157 EXTERNAL lsame, dlamch, zlansy
158* ..
159* .. External Subroutines ..
160 EXTERNAL zlaset, zlavsy_rook
161* ..
162* .. Intrinsic Functions ..
163 INTRINSIC dble
164* ..
165* .. Executable Statements ..
166*
167* Quick exit if N = 0.
168*
169 IF( n.LE.0 ) THEN
170 resid = zero
171 RETURN
172 END IF
173*
174* Determine EPS and the norm of A.
175*
176 eps = dlamch( 'Epsilon' )
177 anorm = zlansy( '1', uplo, n, a, lda, rwork )
178*
179* Initialize C to the identity matrix.
180*
181 CALL zlaset( 'Full', n, n, czero, cone, c, ldc )
182*
183* Call ZLAVSY_ROOK to form the product D * U' (or D * L' ).
184*
185 CALL zlavsy_rook( uplo, 'Transpose', 'Non-unit', n, n, afac,
186 $ ldafac, ipiv, c, ldc, info )
187*
188* Call ZLAVSY_ROOK again to multiply by U (or L ).
189*
190 CALL zlavsy_rook( uplo, 'No transpose', 'Unit', n, n, afac,
191 $ ldafac, ipiv, c, ldc, info )
192*
193* Compute the difference C - A .
194*
195 IF( lsame( uplo, 'U' ) ) THEN
196 DO 20 j = 1, n
197 DO 10 i = 1, j
198 c( i, j ) = c( i, j ) - a( i, j )
199 10 CONTINUE
200 20 CONTINUE
201 ELSE
202 DO 40 j = 1, n
203 DO 30 i = j, n
204 c( i, j ) = c( i, j ) - a( i, j )
205 30 CONTINUE
206 40 CONTINUE
207 END IF
208*
209* Compute norm( C - A ) / ( N * norm(A) * EPS )
210*
211 resid = zlansy( '1', uplo, n, c, ldc, rwork )
212*
213 IF( anorm.LE.zero ) THEN
214 IF( resid.NE.zero )
215 $ resid = one / eps
216 ELSE
217 resid = ( ( resid / dble( n ) ) / anorm ) / eps
218 END IF
219*
220 RETURN
221*
222* End of ZSYT01_ROOK
223*

◆ zsyt02()

subroutine zsyt02 ( character uplo,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( * ) rwork,
double precision resid )

ZSYT02

Purpose:
!>
!> ZSYT02 computes the residual for a solution to a complex symmetric
!> system of linear equations  A*x = b:
!>
!>    RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ),
!>
!> where EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of B, the matrix of right hand sides.
!>          NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original complex symmetric matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N)
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors for the system of linear
!>          equations.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.   LDX >= max(1,N).
!>
[in,out]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 125 of file zsyt02.f.

127*
128* -- LAPACK test routine --
129* -- LAPACK is a software package provided by Univ. of Tennessee, --
130* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
131*
132* .. Scalar Arguments ..
133 CHARACTER UPLO
134 INTEGER LDA, LDB, LDX, N, NRHS
135 DOUBLE PRECISION RESID
136* ..
137* .. Array Arguments ..
138 DOUBLE PRECISION RWORK( * )
139 COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * )
140* ..
141*
142* =====================================================================
143*
144* .. Parameters ..
145 DOUBLE PRECISION ZERO, ONE
146 parameter( zero = 0.0d+0, one = 1.0d+0 )
147 COMPLEX*16 CONE
148 parameter( cone = ( 1.0d+0, 0.0d+0 ) )
149* ..
150* .. Local Scalars ..
151 INTEGER J
152 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
153* ..
154* .. External Functions ..
155 DOUBLE PRECISION DLAMCH, DZASUM, ZLANSY
156 EXTERNAL dlamch, dzasum, zlansy
157* ..
158* .. External Subroutines ..
159 EXTERNAL zsymm
160* ..
161* .. Intrinsic Functions ..
162 INTRINSIC max
163* ..
164* .. Executable Statements ..
165*
166* Quick exit if N = 0 or NRHS = 0
167*
168 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
169 resid = zero
170 RETURN
171 END IF
172*
173* Exit with RESID = 1/EPS if ANORM = 0.
174*
175 eps = dlamch( 'Epsilon' )
176 anorm = zlansy( '1', uplo, n, a, lda, rwork )
177 IF( anorm.LE.zero ) THEN
178 resid = one / eps
179 RETURN
180 END IF
181*
182* Compute B - A*X (or B - A'*X ) and store in B .
183*
184 CALL zsymm( 'Left', uplo, n, nrhs, -cone, a, lda, x, ldx, cone, b,
185 $ ldb )
186*
187* Compute the maximum over the number of right hand sides of
188* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) .
189*
190 resid = zero
191 DO 10 j = 1, nrhs
192 bnorm = dzasum( n, b( 1, j ), 1 )
193 xnorm = dzasum( n, x( 1, j ), 1 )
194 IF( xnorm.LE.zero ) THEN
195 resid = one / eps
196 ELSE
197 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
198 END IF
199 10 CONTINUE
200*
201 RETURN
202*
203* End of ZSYT02
204*

◆ zsyt03()

subroutine zsyt03 ( character uplo,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldainv, * ) ainv,
integer ldainv,
complex*16, dimension( ldwork, * ) work,
integer ldwork,
double precision, dimension( * ) rwork,
double precision rcond,
double precision resid )

ZSYT03

Purpose:
!>
!> ZSYT03 computes the residual for a complex symmetric matrix times
!> its inverse:
!>    norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS )
!> where EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the upper or lower triangular part of the
!>          complex symmetric matrix A is stored:
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The original complex symmetric matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N)
!>
[in,out]AINV
!>          AINV is COMPLEX*16 array, dimension (LDAINV,N)
!>          On entry, the inverse of the matrix A, stored as a symmetric
!>          matrix in the same format as A.
!>          In this version, AINV is expanded into a full matrix and
!>          multiplied by A, so the opposing triangle of AINV will be
!>          changed; i.e., if the upper triangular part of AINV is
!>          stored, the lower triangular part will be used as work space.
!>
[in]LDAINV
!>          LDAINV is INTEGER
!>          The leading dimension of the array AINV.  LDAINV >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (LDWORK,N)
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.  LDWORK >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of A, computed as
!>          RCOND = 1/ (norm(A) * norm(AINV)).
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file zsyt03.f.

126*
127* -- LAPACK test routine --
128* -- LAPACK is a software package provided by Univ. of Tennessee, --
129* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
130*
131* .. Scalar Arguments ..
132 CHARACTER UPLO
133 INTEGER LDA, LDAINV, LDWORK, N
134 DOUBLE PRECISION RCOND, RESID
135* ..
136* .. Array Arguments ..
137 DOUBLE PRECISION RWORK( * )
138 COMPLEX*16 A( LDA, * ), AINV( LDAINV, * ),
139 $ WORK( LDWORK, * )
140* ..
141*
142* =====================================================================
143*
144*
145* .. Parameters ..
146 DOUBLE PRECISION ZERO, ONE
147 parameter( zero = 0.0d+0, one = 1.0d+0 )
148 COMPLEX*16 CZERO, CONE
149 parameter( czero = ( 0.0d+0, 0.0d+0 ),
150 $ cone = ( 1.0d+0, 0.0d+0 ) )
151* ..
152* .. Local Scalars ..
153 INTEGER I, J
154 DOUBLE PRECISION AINVNM, ANORM, EPS
155* ..
156* .. External Functions ..
157 LOGICAL LSAME
158 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY
159 EXTERNAL lsame, dlamch, zlange, zlansy
160* ..
161* .. External Subroutines ..
162 EXTERNAL zsymm
163* ..
164* .. Intrinsic Functions ..
165 INTRINSIC dble
166* ..
167* .. Executable Statements ..
168*
169* Quick exit if N = 0
170*
171 IF( n.LE.0 ) THEN
172 rcond = one
173 resid = zero
174 RETURN
175 END IF
176*
177* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
178*
179 eps = dlamch( 'Epsilon' )
180 anorm = zlansy( '1', uplo, n, a, lda, rwork )
181 ainvnm = zlansy( '1', uplo, n, ainv, ldainv, rwork )
182 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
183 rcond = zero
184 resid = one / eps
185 RETURN
186 END IF
187 rcond = ( one / anorm ) / ainvnm
188*
189* Expand AINV into a full matrix and call ZSYMM to multiply
190* AINV on the left by A (store the result in WORK).
191*
192 IF( lsame( uplo, 'U' ) ) THEN
193 DO 20 j = 1, n
194 DO 10 i = 1, j - 1
195 ainv( j, i ) = ainv( i, j )
196 10 CONTINUE
197 20 CONTINUE
198 ELSE
199 DO 40 j = 1, n
200 DO 30 i = j + 1, n
201 ainv( j, i ) = ainv( i, j )
202 30 CONTINUE
203 40 CONTINUE
204 END IF
205 CALL zsymm( 'Left', uplo, n, n, -cone, a, lda, ainv, ldainv,
206 $ czero, work, ldwork )
207*
208* Add the identity matrix to WORK .
209*
210 DO 50 i = 1, n
211 work( i, i ) = work( i, i ) + cone
212 50 CONTINUE
213*
214* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS)
215*
216 resid = zlange( '1', n, n, work, ldwork, rwork )
217*
218 resid = ( ( resid*rcond ) / eps ) / dble( n )
219*
220 RETURN
221*
222* End of ZSYT03
223*

◆ ztbt02()

subroutine ztbt02 ( character uplo,
character trans,
character diag,
integer n,
integer kd,
integer nrhs,
complex*16, dimension( ldab, * ) ab,
integer ldab,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
double precision resid )

ZTBT02

Purpose:
!>
!> ZTBT02 computes the residual for the computed solution to a
!> triangular system of linear equations op(A)*X = B, when A is a
!> triangular band matrix. The test ratio is the maximum over
!>    norm(b - op(A)*x) / ( ||op(A)||_1 * norm(x) * EPS ),
!> where op(A) = A, A**T, or A**H, b is the column of B, x is the
!> solution vector, and EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the operation applied to A.
!>          = 'N':  A    * X = B  (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of superdiagonals or subdiagonals of the
!>          triangular band matrix A.  KD >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices X and B.  NRHS >= 0.
!>
[in]AB
!>          AB is COMPLEX*16 array, dimension (LDA,N)
!>          The upper or lower triangular band matrix A, stored in the
!>          first kd+1 rows of the array. The j-th column of A is stored
!>          in the j-th column of the array AB as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= max(1,KD+1).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors for the system of linear
!>          equations.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vectors for the system of linear
!>          equations.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 157 of file ztbt02.f.

159*
160* -- LAPACK test routine --
161* -- LAPACK is a software package provided by Univ. of Tennessee, --
162* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
163*
164* .. Scalar Arguments ..
165 CHARACTER DIAG, TRANS, UPLO
166 INTEGER KD, LDAB, LDB, LDX, N, NRHS
167 DOUBLE PRECISION RESID
168* ..
169* .. Array Arguments ..
170 DOUBLE PRECISION RWORK( * )
171 COMPLEX*16 AB( LDAB, * ), B( LDB, * ), WORK( * ),
172 $ X( LDX, * )
173* ..
174*
175* =====================================================================
176*
177* .. Parameters ..
178 DOUBLE PRECISION ZERO, ONE
179 parameter( zero = 0.0d+0, one = 1.0d+0 )
180* ..
181* .. Local Scalars ..
182 INTEGER J
183 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
184* ..
185* .. External Functions ..
186 LOGICAL LSAME
187 DOUBLE PRECISION DLAMCH, DZASUM, ZLANTB
188 EXTERNAL lsame, dlamch, dzasum, zlantb
189* ..
190* .. External Subroutines ..
191 EXTERNAL zaxpy, zcopy, ztbmv
192* ..
193* .. Intrinsic Functions ..
194 INTRINSIC dcmplx, max
195* ..
196* .. Executable Statements ..
197*
198* Quick exit if N = 0 or NRHS = 0
199*
200 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
201 resid = zero
202 RETURN
203 END IF
204*
205* Compute the 1-norm of op(A).
206*
207 IF( lsame( trans, 'N' ) ) THEN
208 anorm = zlantb( '1', uplo, diag, n, kd, ab, ldab, rwork )
209 ELSE
210 anorm = zlantb( 'I', uplo, diag, n, kd, ab, ldab, rwork )
211 END IF
212*
213* Exit with RESID = 1/EPS if ANORM = 0.
214*
215 eps = dlamch( 'Epsilon' )
216 IF( anorm.LE.zero ) THEN
217 resid = one / eps
218 RETURN
219 END IF
220*
221* Compute the maximum over the number of right hand sides of
222* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
223*
224 resid = zero
225 DO 10 j = 1, nrhs
226 CALL zcopy( n, x( 1, j ), 1, work, 1 )
227 CALL ztbmv( uplo, trans, diag, n, kd, ab, ldab, work, 1 )
228 CALL zaxpy( n, dcmplx( -one ), b( 1, j ), 1, work, 1 )
229 bnorm = dzasum( n, work, 1 )
230 xnorm = dzasum( n, x( 1, j ), 1 )
231 IF( xnorm.LE.zero ) THEN
232 resid = one / eps
233 ELSE
234 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
235 END IF
236 10 CONTINUE
237*
238 RETURN
239*
240* End of ZTBT02
241*

◆ ztbt03()

subroutine ztbt03 ( character uplo,
character trans,
character diag,
integer n,
integer kd,
integer nrhs,
complex*16, dimension( ldab, * ) ab,
integer ldab,
double precision scale,
double precision, dimension( * ) cnorm,
double precision tscal,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( * ) work,
double precision resid )

ZTBT03

Purpose:
!>
!> ZTBT03 computes the residual for the solution to a scaled triangular
!> system of equations  A*x = s*b,  A**T *x = s*b,  or  A**H *x = s*b
!> when A is a triangular band matrix.  Here A**T  denotes the transpose
!> of A, A**H denotes the conjugate transpose of A, s is a scalar, and
!> x and b are N by NRHS matrices.  The test ratio is the maximum over
!> the number of right hand sides of
!>    norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
!> where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the operation applied to A.
!>          = 'N':  A *x = s*b     (No transpose)
!>          = 'T':  A**T *x = s*b  (Transpose)
!>          = 'C':  A**H *x = s*b  (Conjugate transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of superdiagonals or subdiagonals of the
!>          triangular band matrix A.  KD >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices X and B.  NRHS >= 0.
!>
[in]AB
!>          AB is COMPLEX*16 array, dimension (LDAB,N)
!>          The upper or lower triangular band matrix A, stored in the
!>          first kd+1 rows of the array. The j-th column of A is stored
!>          in the j-th column of the array AB as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[in]SCALE
!>          SCALE is DOUBLE PRECISION
!>          The scaling factor s used in solving the triangular system.
!>
[in]CNORM
!>          CNORM is DOUBLE PRECISION array, dimension (N)
!>          The 1-norms of the columns of A, not counting the diagonal.
!>
[in]TSCAL
!>          TSCAL is DOUBLE PRECISION
!>          The scaling factor used in computing the 1-norms in CNORM.
!>          CNORM actually contains the column norms of TSCAL*A.
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors for the system of linear
!>          equations.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vectors for the system of linear
!>          equations.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 174 of file ztbt03.f.

177*
178* -- LAPACK test routine --
179* -- LAPACK is a software package provided by Univ. of Tennessee, --
180* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
181*
182* .. Scalar Arguments ..
183 CHARACTER DIAG, TRANS, UPLO
184 INTEGER KD, LDAB, LDB, LDX, N, NRHS
185 DOUBLE PRECISION RESID, SCALE, TSCAL
186* ..
187* .. Array Arguments ..
188 DOUBLE PRECISION CNORM( * )
189 COMPLEX*16 AB( LDAB, * ), B( LDB, * ), WORK( * ),
190 $ X( LDX, * )
191* ..
192*
193* =====================================================================
194*
195*
196* .. Parameters ..
197 DOUBLE PRECISION ONE, ZERO
198 parameter( one = 1.0d+0, zero = 0.0d+0 )
199* ..
200* .. Local Scalars ..
201 INTEGER IX, J
202 DOUBLE PRECISION EPS, ERR, SMLNUM, TNORM, XNORM, XSCAL
203* ..
204* .. External Functions ..
205 LOGICAL LSAME
206 INTEGER IZAMAX
207 DOUBLE PRECISION DLAMCH
208 EXTERNAL lsame, izamax, dlamch
209* ..
210* .. External Subroutines ..
211 EXTERNAL zaxpy, zcopy, zdscal, ztbmv
212* ..
213* .. Intrinsic Functions ..
214 INTRINSIC abs, dble, dcmplx, max
215* ..
216* .. Executable Statements ..
217*
218* Quick exit if N = 0
219*
220 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
221 resid = zero
222 RETURN
223 END IF
224 eps = dlamch( 'Epsilon' )
225 smlnum = dlamch( 'Safe minimum' )
226*
227* Compute the norm of the triangular matrix A using the column
228* norms already computed by ZLATBS.
229*
230 tnorm = zero
231 IF( lsame( diag, 'N' ) ) THEN
232 IF( lsame( uplo, 'U' ) ) THEN
233 DO 10 j = 1, n
234 tnorm = max( tnorm, tscal*abs( ab( kd+1, j ) )+
235 $ cnorm( j ) )
236 10 CONTINUE
237 ELSE
238 DO 20 j = 1, n
239 tnorm = max( tnorm, tscal*abs( ab( 1, j ) )+cnorm( j ) )
240 20 CONTINUE
241 END IF
242 ELSE
243 DO 30 j = 1, n
244 tnorm = max( tnorm, tscal+cnorm( j ) )
245 30 CONTINUE
246 END IF
247*
248* Compute the maximum over the number of right hand sides of
249* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
250*
251 resid = zero
252 DO 40 j = 1, nrhs
253 CALL zcopy( n, x( 1, j ), 1, work, 1 )
254 ix = izamax( n, work, 1 )
255 xnorm = max( one, abs( x( ix, j ) ) )
256 xscal = ( one / xnorm ) / dble( kd+1 )
257 CALL zdscal( n, xscal, work, 1 )
258 CALL ztbmv( uplo, trans, diag, n, kd, ab, ldab, work, 1 )
259 CALL zaxpy( n, dcmplx( -scale*xscal ), b( 1, j ), 1, work, 1 )
260 ix = izamax( n, work, 1 )
261 err = tscal*abs( work( ix ) )
262 ix = izamax( n, x( 1, j ), 1 )
263 xnorm = abs( x( ix, j ) )
264 IF( err*smlnum.LE.xnorm ) THEN
265 IF( xnorm.GT.zero )
266 $ err = err / xnorm
267 ELSE
268 IF( err.GT.zero )
269 $ err = one / eps
270 END IF
271 IF( err*smlnum.LE.tnorm ) THEN
272 IF( tnorm.GT.zero )
273 $ err = err / tnorm
274 ELSE
275 IF( err.GT.zero )
276 $ err = one / eps
277 END IF
278 resid = max( resid, err )
279 40 CONTINUE
280*
281 RETURN
282*
283* End of ZTBT03
284*

◆ ztbt05()

subroutine ztbt05 ( character uplo,
character trans,
character diag,
integer n,
integer kd,
integer nrhs,
complex*16, dimension( ldab, * ) ab,
integer ldab,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldxact, * ) xact,
integer ldxact,
double precision, dimension( * ) ferr,
double precision, dimension( * ) berr,
double precision, dimension( * ) reslts )

ZTBT05

Purpose:
!>
!> ZTBT05 tests the error bounds from iterative refinement for the
!> computed solution to a system of equations A*X = B, where A is a
!> triangular band matrix.
!>
!> RESLTS(1) = test of the error bound
!>           = norm(X - XACT) / ( norm(X) * FERR )
!>
!> A large value is returned if this ratio is not less than one.
!>
!> RESLTS(2) = residual from the iterative refinement routine
!>           = the maximum of BERR / ( NZ*EPS + (*) ), where
!>             (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
!>             and NZ = max. number of nonzeros in any row of A, plus 1
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations.
!>          = 'N':  A * X = B  (No transpose)
!>          = 'T':  A'* X = B  (Transpose)
!>          = 'C':  A'* X = B  (Conjugate transpose = Transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows of the matrices X, B, and XACT, and the
!>          order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of super-diagonals of the matrix A if UPLO = 'U',
!>          or the number of sub-diagonals if UPLO = 'L'.  KD >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of the matrices X, B, and XACT.
!>          NRHS >= 0.
!>
[in]AB
!>          AB is COMPLEX*16 array, dimension (LDAB,N)
!>          The upper or lower triangular band matrix A, stored in the
!>          first kd+1 rows of the array. The j-th column of A is stored
!>          in the j-th column of the array AB as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>          If DIAG = 'U', the diagonal elements of A are not referenced
!>          and are assumed to be 1.
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vectors for the system of linear
!>          equations.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors.  Each vector is stored as a
!>          column of the matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in]XACT
!>          XACT is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( NZ*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 187 of file ztbt05.f.

189*
190* -- LAPACK test routine --
191* -- LAPACK is a software package provided by Univ. of Tennessee, --
192* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
193*
194* .. Scalar Arguments ..
195 CHARACTER DIAG, TRANS, UPLO
196 INTEGER KD, LDAB, LDB, LDX, LDXACT, N, NRHS
197* ..
198* .. Array Arguments ..
199 DOUBLE PRECISION BERR( * ), FERR( * ), RESLTS( * )
200 COMPLEX*16 AB( LDAB, * ), B( LDB, * ), X( LDX, * ),
201 $ XACT( LDXACT, * )
202* ..
203*
204* =====================================================================
205*
206* .. Parameters ..
207 DOUBLE PRECISION ZERO, ONE
208 parameter( zero = 0.0d+0, one = 1.0d+0 )
209* ..
210* .. Local Scalars ..
211 LOGICAL NOTRAN, UNIT, UPPER
212 INTEGER I, IFU, IMAX, J, K, NZ
213 DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
214 COMPLEX*16 ZDUM
215* ..
216* .. External Functions ..
217 LOGICAL LSAME
218 INTEGER IZAMAX
219 DOUBLE PRECISION DLAMCH
220 EXTERNAL lsame, izamax, dlamch
221* ..
222* .. Intrinsic Functions ..
223 INTRINSIC abs, dble, dimag, max, min
224* ..
225* .. Statement Functions ..
226 DOUBLE PRECISION CABS1
227* ..
228* .. Statement Function definitions ..
229 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
230* ..
231* .. Executable Statements ..
232*
233* Quick exit if N = 0 or NRHS = 0.
234*
235 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
236 reslts( 1 ) = zero
237 reslts( 2 ) = zero
238 RETURN
239 END IF
240*
241 eps = dlamch( 'Epsilon' )
242 unfl = dlamch( 'Safe minimum' )
243 ovfl = one / unfl
244 upper = lsame( uplo, 'U' )
245 notran = lsame( trans, 'N' )
246 unit = lsame( diag, 'U' )
247 nz = min( kd, n-1 ) + 1
248*
249* Test 1: Compute the maximum of
250* norm(X - XACT) / ( norm(X) * FERR )
251* over all the vectors X and XACT using the infinity-norm.
252*
253 errbnd = zero
254 DO 30 j = 1, nrhs
255 imax = izamax( n, x( 1, j ), 1 )
256 xnorm = max( cabs1( x( imax, j ) ), unfl )
257 diff = zero
258 DO 10 i = 1, n
259 diff = max( diff, cabs1( x( i, j )-xact( i, j ) ) )
260 10 CONTINUE
261*
262 IF( xnorm.GT.one ) THEN
263 GO TO 20
264 ELSE IF( diff.LE.ovfl*xnorm ) THEN
265 GO TO 20
266 ELSE
267 errbnd = one / eps
268 GO TO 30
269 END IF
270*
271 20 CONTINUE
272 IF( diff / xnorm.LE.ferr( j ) ) THEN
273 errbnd = max( errbnd, ( diff / xnorm ) / ferr( j ) )
274 ELSE
275 errbnd = one / eps
276 END IF
277 30 CONTINUE
278 reslts( 1 ) = errbnd
279*
280* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
281* (*) = NZ*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
282*
283 ifu = 0
284 IF( unit )
285 $ ifu = 1
286 DO 90 k = 1, nrhs
287 DO 80 i = 1, n
288 tmp = cabs1( b( i, k ) )
289 IF( upper ) THEN
290 IF( .NOT.notran ) THEN
291 DO 40 j = max( i-kd, 1 ), i - ifu
292 tmp = tmp + cabs1( ab( kd+1-i+j, i ) )*
293 $ cabs1( x( j, k ) )
294 40 CONTINUE
295 IF( unit )
296 $ tmp = tmp + cabs1( x( i, k ) )
297 ELSE
298 IF( unit )
299 $ tmp = tmp + cabs1( x( i, k ) )
300 DO 50 j = i + ifu, min( i+kd, n )
301 tmp = tmp + cabs1( ab( kd+1+i-j, j ) )*
302 $ cabs1( x( j, k ) )
303 50 CONTINUE
304 END IF
305 ELSE
306 IF( notran ) THEN
307 DO 60 j = max( i-kd, 1 ), i - ifu
308 tmp = tmp + cabs1( ab( 1+i-j, j ) )*
309 $ cabs1( x( j, k ) )
310 60 CONTINUE
311 IF( unit )
312 $ tmp = tmp + cabs1( x( i, k ) )
313 ELSE
314 IF( unit )
315 $ tmp = tmp + cabs1( x( i, k ) )
316 DO 70 j = i + ifu, min( i+kd, n )
317 tmp = tmp + cabs1( ab( 1+j-i, i ) )*
318 $ cabs1( x( j, k ) )
319 70 CONTINUE
320 END IF
321 END IF
322 IF( i.EQ.1 ) THEN
323 axbi = tmp
324 ELSE
325 axbi = min( axbi, tmp )
326 END IF
327 80 CONTINUE
328 tmp = berr( k ) / ( nz*eps+nz*unfl / max( axbi, nz*unfl ) )
329 IF( k.EQ.1 ) THEN
330 reslts( 2 ) = tmp
331 ELSE
332 reslts( 2 ) = max( reslts( 2 ), tmp )
333 END IF
334 90 CONTINUE
335*
336 RETURN
337*
338* End of ZTBT05
339*

◆ ztbt06()

subroutine ztbt06 ( double precision rcond,
double precision rcondc,
character uplo,
character diag,
integer n,
integer kd,
complex*16, dimension( ldab, * ) ab,
integer ldab,
double precision, dimension( * ) rwork,
double precision rat )

ZTBT06

Purpose:
!>
!> ZTBT06 computes a test ratio comparing RCOND (the reciprocal
!> condition number of a triangular matrix A) and RCONDC, the estimate
!> computed by ZTBCON.  Information about the triangular matrix A is
!> used if one estimate is zero and the other is non-zero to decide if
!> underflow in the estimate is justified.
!>
Parameters
[in]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The estimate of the reciprocal condition number obtained by
!>          forming the explicit inverse of the matrix A and computing
!>          RCOND = 1/( norm(A) * norm(inv(A)) ).
!>
[in]RCONDC
!>          RCONDC is DOUBLE PRECISION
!>          The estimate of the reciprocal condition number computed by
!>          ZTBCON.
!>
[in]UPLO
!>          UPLO is CHARACTER
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]DIAG
!>          DIAG is CHARACTER
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]KD
!>          KD is INTEGER
!>          The number of superdiagonals or subdiagonals of the
!>          triangular band matrix A.  KD >= 0.
!>
[in]AB
!>          AB is COMPLEX*16 array, dimension (LDAB,N)
!>          The upper or lower triangular band matrix A, stored in the
!>          first kd+1 rows of the array. The j-th column of A is stored
!>          in the j-th column of the array AB as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RAT
!>          RAT is DOUBLE PRECISION
!>          The test ratio.  If both RCOND and RCONDC are nonzero,
!>             RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1.
!>          If RAT = 0, the two estimates are exactly the same.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file ztbt06.f.

126*
127* -- LAPACK test routine --
128* -- LAPACK is a software package provided by Univ. of Tennessee, --
129* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
130*
131* .. Scalar Arguments ..
132 CHARACTER DIAG, UPLO
133 INTEGER KD, LDAB, N
134 DOUBLE PRECISION RAT, RCOND, RCONDC
135* ..
136* .. Array Arguments ..
137 DOUBLE PRECISION RWORK( * )
138 COMPLEX*16 AB( LDAB, * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 DOUBLE PRECISION ZERO, ONE
145 parameter( zero = 0.0d+0, one = 1.0d+0 )
146* ..
147* .. Local Scalars ..
148 DOUBLE PRECISION ANORM, BIGNUM, EPS, RMAX, RMIN
149* ..
150* .. External Functions ..
151 DOUBLE PRECISION DLAMCH, ZLANTB
152 EXTERNAL dlamch, zlantb
153* ..
154* .. Intrinsic Functions ..
155 INTRINSIC max, min
156* ..
157* .. Executable Statements ..
158*
159 eps = dlamch( 'Epsilon' )
160 rmax = max( rcond, rcondc )
161 rmin = min( rcond, rcondc )
162*
163* Do the easy cases first.
164*
165 IF( rmin.LT.zero ) THEN
166*
167* Invalid value for RCOND or RCONDC, return 1/EPS.
168*
169 rat = one / eps
170*
171 ELSE IF( rmin.GT.zero ) THEN
172*
173* Both estimates are positive, return RMAX/RMIN - 1.
174*
175 rat = rmax / rmin - one
176*
177 ELSE IF( rmax.EQ.zero ) THEN
178*
179* Both estimates zero.
180*
181 rat = zero
182*
183 ELSE
184*
185* One estimate is zero, the other is non-zero. If the matrix is
186* ill-conditioned, return the nonzero estimate multiplied by
187* 1/EPS; if the matrix is badly scaled, return the nonzero
188* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum
189* element in absolute value in A.
190*
191 bignum = one / dlamch( 'Safe minimum' )
192 anorm = zlantb( 'M', uplo, diag, n, kd, ab, ldab, rwork )
193*
194 rat = rmax*( min( bignum / max( one, anorm ), one / eps ) )
195 END IF
196*
197 RETURN
198*
199* End of ZTBT06
200*

◆ ztpt01()

subroutine ztpt01 ( character uplo,
character diag,
integer n,
complex*16, dimension( * ) ap,
complex*16, dimension( * ) ainvp,
double precision rcond,
double precision, dimension( * ) rwork,
double precision resid )

ZTPT01

Purpose:
!>
!> ZTPT01 computes the residual for a triangular matrix A times its
!> inverse when A is stored in packed format:
!>    RESID = norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS ),
!> where EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]AP
!>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The original upper or lower triangular matrix A, packed
!>          columnwise in a linear array.  The j-th column of A is stored
!>          in the array AP as follows:
!>          if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L',
!>             AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
!>
[in]AINVP
!>          AINVP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          On entry, the (triangular) inverse of the matrix A, packed
!>          columnwise in a linear array as in AP.
!>          On exit, the contents of AINVP are destroyed.
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal condition number of A, computed as
!>          1/(norm(A) * norm(AINV)).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 108 of file ztpt01.f.

109*
110* -- LAPACK test routine --
111* -- LAPACK is a software package provided by Univ. of Tennessee, --
112* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
113*
114* .. Scalar Arguments ..
115 CHARACTER DIAG, UPLO
116 INTEGER N
117 DOUBLE PRECISION RCOND, RESID
118* ..
119* .. Array Arguments ..
120 DOUBLE PRECISION RWORK( * )
121 COMPLEX*16 AINVP( * ), AP( * )
122* ..
123*
124* =====================================================================
125*
126* .. Parameters ..
127 DOUBLE PRECISION ZERO, ONE
128 parameter( zero = 0.0d+0, one = 1.0d+0 )
129* ..
130* .. Local Scalars ..
131 LOGICAL UNITD
132 INTEGER J, JC
133 DOUBLE PRECISION AINVNM, ANORM, EPS
134* ..
135* .. External Functions ..
136 LOGICAL LSAME
137 DOUBLE PRECISION DLAMCH, ZLANTP
138 EXTERNAL lsame, dlamch, zlantp
139* ..
140* .. External Subroutines ..
141 EXTERNAL ztpmv
142* ..
143* .. Intrinsic Functions ..
144 INTRINSIC dble
145* ..
146* .. Executable Statements ..
147*
148* Quick exit if N = 0.
149*
150 IF( n.LE.0 ) THEN
151 rcond = one
152 resid = zero
153 RETURN
154 END IF
155*
156* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
157*
158 eps = dlamch( 'Epsilon' )
159 anorm = zlantp( '1', uplo, diag, n, ap, rwork )
160 ainvnm = zlantp( '1', uplo, diag, n, ainvp, rwork )
161 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
162 rcond = zero
163 resid = one / eps
164 RETURN
165 END IF
166 rcond = ( one / anorm ) / ainvnm
167*
168* Compute A * AINV, overwriting AINV.
169*
170 unitd = lsame( diag, 'U' )
171 IF( lsame( uplo, 'U' ) ) THEN
172 jc = 1
173 DO 10 j = 1, n
174 IF( unitd )
175 $ ainvp( jc+j-1 ) = one
176*
177* Form the j-th column of A*AINV.
178*
179 CALL ztpmv( 'Upper', 'No transpose', diag, j, ap,
180 $ ainvp( jc ), 1 )
181*
182* Subtract 1 from the diagonal to form A*AINV - I.
183*
184 ainvp( jc+j-1 ) = ainvp( jc+j-1 ) - one
185 jc = jc + j
186 10 CONTINUE
187 ELSE
188 jc = 1
189 DO 20 j = 1, n
190 IF( unitd )
191 $ ainvp( jc ) = one
192*
193* Form the j-th column of A*AINV.
194*
195 CALL ztpmv( 'Lower', 'No transpose', diag, n-j+1, ap( jc ),
196 $ ainvp( jc ), 1 )
197*
198* Subtract 1 from the diagonal to form A*AINV - I.
199*
200 ainvp( jc ) = ainvp( jc ) - one
201 jc = jc + n - j + 1
202 20 CONTINUE
203 END IF
204*
205* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS)
206*
207 resid = zlantp( '1', uplo, 'Non-unit', n, ainvp, rwork )
208*
209 resid = ( ( resid*rcond ) / dble( n ) ) / eps
210*
211 RETURN
212*
213* End of ZTPT01
214*

◆ ztpt02()

subroutine ztpt02 ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex*16, dimension( * ) ap,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
double precision resid )

ZTPT02

Purpose:
!>
!> ZTPT02 computes the residual for the computed solution to a
!> triangular system of linear equations op(A)*X = B, when the
!> triangular matrix A is stored in packed format. The test ratio is
!> the maximum over
!>    norm(b - op(A)*x) / ( ||op(A)||_1 * norm(x) * EPS ),
!> where op(A) = A, A**T, or A**H, b is the column of B, x is the
!> solution vector, and EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the operation applied to A.
!>          = 'N':  A    * X = B  (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices X and B.  NRHS >= 0.
!>
[in]AP
!>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The upper or lower triangular matrix A, packed columnwise in
!>          a linear array.  The j-th column of A is stored in the array
!>          AP as follows:
!>          if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L',
!>             AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors for the system of linear
!>          equations.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vectors for the system of linear
!>          equations.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*X - B) / ( norm(op(A)) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 145 of file ztpt02.f.

147*
148* -- LAPACK test routine --
149* -- LAPACK is a software package provided by Univ. of Tennessee, --
150* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
151*
152* .. Scalar Arguments ..
153 CHARACTER DIAG, TRANS, UPLO
154 INTEGER LDB, LDX, N, NRHS
155 DOUBLE PRECISION RESID
156* ..
157* .. Array Arguments ..
158 DOUBLE PRECISION RWORK( * )
159 COMPLEX*16 AP( * ), B( LDB, * ), WORK( * ), X( LDX, * )
160* ..
161*
162* =====================================================================
163*
164* .. Parameters ..
165 DOUBLE PRECISION ZERO, ONE
166 parameter( zero = 0.0d+0, one = 1.0d+0 )
167* ..
168* .. Local Scalars ..
169 INTEGER J
170 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
171* ..
172* .. External Functions ..
173 LOGICAL LSAME
174 DOUBLE PRECISION DLAMCH, DZASUM, ZLANTP
175 EXTERNAL lsame, dlamch, dzasum, zlantp
176* ..
177* .. External Subroutines ..
178 EXTERNAL zaxpy, zcopy, ztpmv
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC dcmplx, max
182* ..
183* .. Executable Statements ..
184*
185* Quick exit if N = 0 or NRHS = 0
186*
187 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
188 resid = zero
189 RETURN
190 END IF
191*
192* Compute the 1-norm of op(A).
193*
194 IF( lsame( trans, 'N' ) ) THEN
195 anorm = zlantp( '1', uplo, diag, n, ap, rwork )
196 ELSE
197 anorm = zlantp( 'I', uplo, diag, n, ap, rwork )
198 END IF
199*
200* Exit with RESID = 1/EPS if ANORM = 0.
201*
202 eps = dlamch( 'Epsilon' )
203 IF( anorm.LE.zero ) THEN
204 resid = one / eps
205 RETURN
206 END IF
207*
208* Compute the maximum over the number of right hand sides of
209* norm(op(A)*X - B) / ( norm(op(A)) * norm(X) * EPS ).
210*
211 resid = zero
212 DO 10 j = 1, nrhs
213 CALL zcopy( n, x( 1, j ), 1, work, 1 )
214 CALL ztpmv( uplo, trans, diag, n, ap, work, 1 )
215 CALL zaxpy( n, dcmplx( -one ), b( 1, j ), 1, work, 1 )
216 bnorm = dzasum( n, work, 1 )
217 xnorm = dzasum( n, x( 1, j ), 1 )
218 IF( xnorm.LE.zero ) THEN
219 resid = one / eps
220 ELSE
221 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
222 END IF
223 10 CONTINUE
224*
225 RETURN
226*
227* End of ZTPT02
228*

◆ ztpt03()

subroutine ztpt03 ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex*16, dimension( * ) ap,
double precision scale,
double precision, dimension( * ) cnorm,
double precision tscal,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( * ) work,
double precision resid )

ZTPT03

Purpose:
!>
!> ZTPT03 computes the residual for the solution to a scaled triangular
!> system of equations A*x = s*b,  A**T *x = s*b,  or  A**H *x = s*b,
!> when the triangular matrix A is stored in packed format.  Here A**T
!> denotes the transpose of A, A**H denotes the conjugate transpose of
!> A, s is a scalar, and x and b are N by NRHS matrices.  The test ratio
!> is the maximum over the number of right hand sides of
!>    norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
!> where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the operation applied to A.
!>          = 'N':  A *x = s*b     (No transpose)
!>          = 'T':  A**T *x = s*b  (Transpose)
!>          = 'C':  A**H *x = s*b  (Conjugate transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices X and B.  NRHS >= 0.
!>
[in]AP
!>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The upper or lower triangular matrix A, packed columnwise in
!>          a linear array.  The j-th column of A is stored in the array
!>          AP as follows:
!>          if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L',
!>             AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
!>
[in]SCALE
!>          SCALE is DOUBLE PRECISION
!>          The scaling factor s used in solving the triangular system.
!>
[in]CNORM
!>          CNORM is DOUBLE PRECISION array, dimension (N)
!>          The 1-norms of the columns of A, not counting the diagonal.
!>
[in]TSCAL
!>          TSCAL is DOUBLE PRECISION
!>          The scaling factor used in computing the 1-norms in CNORM.
!>          CNORM actually contains the column norms of TSCAL*A.
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors for the system of linear
!>          equations.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vectors for the system of linear
!>          equations.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 160 of file ztpt03.f.

162*
163* -- LAPACK test routine --
164* -- LAPACK is a software package provided by Univ. of Tennessee, --
165* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
166*
167* .. Scalar Arguments ..
168 CHARACTER DIAG, TRANS, UPLO
169 INTEGER LDB, LDX, N, NRHS
170 DOUBLE PRECISION RESID, SCALE, TSCAL
171* ..
172* .. Array Arguments ..
173 DOUBLE PRECISION CNORM( * )
174 COMPLEX*16 AP( * ), B( LDB, * ), WORK( * ), X( LDX, * )
175* ..
176*
177* =====================================================================
178*
179* .. Parameters ..
180 DOUBLE PRECISION ONE, ZERO
181 parameter( one = 1.0d+0, zero = 0.0d+0 )
182* ..
183* .. Local Scalars ..
184 INTEGER IX, J, JJ
185 DOUBLE PRECISION EPS, ERR, SMLNUM, TNORM, XNORM, XSCAL
186* ..
187* .. External Functions ..
188 LOGICAL LSAME
189 INTEGER IZAMAX
190 DOUBLE PRECISION DLAMCH
191 EXTERNAL lsame, izamax, dlamch
192* ..
193* .. External Subroutines ..
194 EXTERNAL zaxpy, zcopy, zdscal, ztpmv
195* ..
196* .. Intrinsic Functions ..
197 INTRINSIC abs, dble, dcmplx, max
198* ..
199* .. Executable Statements ..
200*
201* Quick exit if N = 0.
202*
203 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
204 resid = zero
205 RETURN
206 END IF
207 eps = dlamch( 'Epsilon' )
208 smlnum = dlamch( 'Safe minimum' )
209*
210* Compute the norm of the triangular matrix A using the column
211* norms already computed by ZLATPS.
212*
213 tnorm = 0.d0
214 IF( lsame( diag, 'N' ) ) THEN
215 IF( lsame( uplo, 'U' ) ) THEN
216 jj = 1
217 DO 10 j = 1, n
218 tnorm = max( tnorm, tscal*abs( ap( jj ) )+cnorm( j ) )
219 jj = jj + j
220 10 CONTINUE
221 ELSE
222 jj = 1
223 DO 20 j = 1, n
224 tnorm = max( tnorm, tscal*abs( ap( jj ) )+cnorm( j ) )
225 jj = jj + n - j + 1
226 20 CONTINUE
227 END IF
228 ELSE
229 DO 30 j = 1, n
230 tnorm = max( tnorm, tscal+cnorm( j ) )
231 30 CONTINUE
232 END IF
233*
234* Compute the maximum over the number of right hand sides of
235* norm(op(A)*x - s*b) / ( norm(A) * norm(x) * EPS ).
236*
237 resid = zero
238 DO 40 j = 1, nrhs
239 CALL zcopy( n, x( 1, j ), 1, work, 1 )
240 ix = izamax( n, work, 1 )
241 xnorm = max( one, abs( x( ix, j ) ) )
242 xscal = ( one / xnorm ) / dble( n )
243 CALL zdscal( n, xscal, work, 1 )
244 CALL ztpmv( uplo, trans, diag, n, ap, work, 1 )
245 CALL zaxpy( n, dcmplx( -scale*xscal ), b( 1, j ), 1, work, 1 )
246 ix = izamax( n, work, 1 )
247 err = tscal*abs( work( ix ) )
248 ix = izamax( n, x( 1, j ), 1 )
249 xnorm = abs( x( ix, j ) )
250 IF( err*smlnum.LE.xnorm ) THEN
251 IF( xnorm.GT.zero )
252 $ err = err / xnorm
253 ELSE
254 IF( err.GT.zero )
255 $ err = one / eps
256 END IF
257 IF( err*smlnum.LE.tnorm ) THEN
258 IF( tnorm.GT.zero )
259 $ err = err / tnorm
260 ELSE
261 IF( err.GT.zero )
262 $ err = one / eps
263 END IF
264 resid = max( resid, err )
265 40 CONTINUE
266*
267 RETURN
268*
269* End of ZTPT03
270*

◆ ztpt05()

subroutine ztpt05 ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex*16, dimension( * ) ap,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldxact, * ) xact,
integer ldxact,
double precision, dimension( * ) ferr,
double precision, dimension( * ) berr,
double precision, dimension( * ) reslts )

ZTPT05

Purpose:
!>
!> ZTPT05 tests the error bounds from iterative refinement for the
!> computed solution to a system of equations A*X = B, where A is a
!> triangular matrix in packed storage format.
!>
!> RESLTS(1) = test of the error bound
!>           = norm(X - XACT) / ( norm(X) * FERR )
!>
!> A large value is returned if this ratio is not less than one.
!>
!> RESLTS(2) = residual from the iterative refinement routine
!>           = the maximum of BERR / ( (n+1)*EPS + (*) ), where
!>             (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations.
!>          = 'N':  A * X = B  (No transpose)
!>          = 'T':  A'* X = B  (Transpose)
!>          = 'C':  A'* X = B  (Conjugate transpose = Transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows of the matrices X, B, and XACT, and the
!>          order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of the matrices X, B, and XACT.
!>          NRHS >= 0.
!>
[in]AP
!>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The upper or lower triangular matrix A, packed columnwise in
!>          a linear array.  The j-th column of A is stored in the array
!>          AP as follows:
!>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
!>          If DIAG = 'U', the diagonal elements of A are not referenced
!>          and are assumed to be 1.
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vectors for the system of linear
!>          equations.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors.  Each vector is stored as a
!>          column of the matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in]XACT
!>          XACT is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 173 of file ztpt05.f.

175*
176* -- LAPACK test routine --
177* -- LAPACK is a software package provided by Univ. of Tennessee, --
178* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
179*
180* .. Scalar Arguments ..
181 CHARACTER DIAG, TRANS, UPLO
182 INTEGER LDB, LDX, LDXACT, N, NRHS
183* ..
184* .. Array Arguments ..
185 DOUBLE PRECISION BERR( * ), FERR( * ), RESLTS( * )
186 COMPLEX*16 AP( * ), B( LDB, * ), X( LDX, * ),
187 $ XACT( LDXACT, * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 DOUBLE PRECISION ZERO, ONE
194 parameter( zero = 0.0d+0, one = 1.0d+0 )
195* ..
196* .. Local Scalars ..
197 LOGICAL NOTRAN, UNIT, UPPER
198 INTEGER I, IFU, IMAX, J, JC, K
199 DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
200 COMPLEX*16 ZDUM
201* ..
202* .. External Functions ..
203 LOGICAL LSAME
204 INTEGER IZAMAX
205 DOUBLE PRECISION DLAMCH
206 EXTERNAL lsame, izamax, dlamch
207* ..
208* .. Intrinsic Functions ..
209 INTRINSIC abs, dble, dimag, max, min
210* ..
211* .. Statement Functions ..
212 DOUBLE PRECISION CABS1
213* ..
214* .. Statement Function definitions ..
215 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
216* ..
217* .. Executable Statements ..
218*
219* Quick exit if N = 0 or NRHS = 0.
220*
221 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
222 reslts( 1 ) = zero
223 reslts( 2 ) = zero
224 RETURN
225 END IF
226*
227 eps = dlamch( 'Epsilon' )
228 unfl = dlamch( 'Safe minimum' )
229 ovfl = one / unfl
230 upper = lsame( uplo, 'U' )
231 notran = lsame( trans, 'N' )
232 unit = lsame( diag, 'U' )
233*
234* Test 1: Compute the maximum of
235* norm(X - XACT) / ( norm(X) * FERR )
236* over all the vectors X and XACT using the infinity-norm.
237*
238 errbnd = zero
239 DO 30 j = 1, nrhs
240 imax = izamax( n, x( 1, j ), 1 )
241 xnorm = max( cabs1( x( imax, j ) ), unfl )
242 diff = zero
243 DO 10 i = 1, n
244 diff = max( diff, cabs1( x( i, j )-xact( i, j ) ) )
245 10 CONTINUE
246*
247 IF( xnorm.GT.one ) THEN
248 GO TO 20
249 ELSE IF( diff.LE.ovfl*xnorm ) THEN
250 GO TO 20
251 ELSE
252 errbnd = one / eps
253 GO TO 30
254 END IF
255*
256 20 CONTINUE
257 IF( diff / xnorm.LE.ferr( j ) ) THEN
258 errbnd = max( errbnd, ( diff / xnorm ) / ferr( j ) )
259 ELSE
260 errbnd = one / eps
261 END IF
262 30 CONTINUE
263 reslts( 1 ) = errbnd
264*
265* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
266* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
267*
268 ifu = 0
269 IF( unit )
270 $ ifu = 1
271 DO 90 k = 1, nrhs
272 DO 80 i = 1, n
273 tmp = cabs1( b( i, k ) )
274 IF( upper ) THEN
275 jc = ( ( i-1 )*i ) / 2
276 IF( .NOT.notran ) THEN
277 DO 40 j = 1, i - ifu
278 tmp = tmp + cabs1( ap( jc+j ) )*cabs1( x( j, k ) )
279 40 CONTINUE
280 IF( unit )
281 $ tmp = tmp + cabs1( x( i, k ) )
282 ELSE
283 jc = jc + i
284 IF( unit ) THEN
285 tmp = tmp + cabs1( x( i, k ) )
286 jc = jc + i
287 END IF
288 DO 50 j = i + ifu, n
289 tmp = tmp + cabs1( ap( jc ) )*cabs1( x( j, k ) )
290 jc = jc + j
291 50 CONTINUE
292 END IF
293 ELSE
294 IF( notran ) THEN
295 jc = i
296 DO 60 j = 1, i - ifu
297 tmp = tmp + cabs1( ap( jc ) )*cabs1( x( j, k ) )
298 jc = jc + n - j
299 60 CONTINUE
300 IF( unit )
301 $ tmp = tmp + cabs1( x( i, k ) )
302 ELSE
303 jc = ( i-1 )*( n-i ) + ( i*( i+1 ) ) / 2
304 IF( unit )
305 $ tmp = tmp + cabs1( x( i, k ) )
306 DO 70 j = i + ifu, n
307 tmp = tmp + cabs1( ap( jc+j-i ) )*
308 $ cabs1( x( j, k ) )
309 70 CONTINUE
310 END IF
311 END IF
312 IF( i.EQ.1 ) THEN
313 axbi = tmp
314 ELSE
315 axbi = min( axbi, tmp )
316 END IF
317 80 CONTINUE
318 tmp = berr( k ) / ( ( n+1 )*eps+( n+1 )*unfl /
319 $ max( axbi, ( n+1 )*unfl ) )
320 IF( k.EQ.1 ) THEN
321 reslts( 2 ) = tmp
322 ELSE
323 reslts( 2 ) = max( reslts( 2 ), tmp )
324 END IF
325 90 CONTINUE
326*
327 RETURN
328*
329* End of ZTPT05
330*

◆ ztpt06()

subroutine ztpt06 ( double precision rcond,
double precision rcondc,
character uplo,
character diag,
integer n,
complex*16, dimension( * ) ap,
double precision, dimension( * ) rwork,
double precision rat )

ZTPT06

Purpose:
!>
!> ZTPT06 computes a test ratio comparing RCOND (the reciprocal
!> condition number of the triangular matrix A) and RCONDC, the estimate
!> computed by ZTPCON.  Information about the triangular matrix is used
!> if one estimate is zero and the other is non-zero to decide if
!> underflow in the estimate is justified.
!>
Parameters
[in]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The estimate of the reciprocal condition number obtained by
!>          forming the explicit inverse of the matrix A and computing
!>          RCOND = 1/( norm(A) * norm(inv(A)) ).
!>
[in]RCONDC
!>          RCONDC is DOUBLE PRECISION
!>          The estimate of the reciprocal condition number computed by
!>          ZTPCON.
!>
[in]UPLO
!>          UPLO is CHARACTER
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]DIAG
!>          DIAG is CHARACTER
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]AP
!>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
!>          The upper or lower triangular matrix A, packed columnwise in
!>          a linear array.  The j-th column of A is stored in the array
!>          AP as follows:
!>          if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L',
!>             AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RAT
!>          RAT is DOUBLE PRECISION
!>          The test ratio.  If both RCOND and RCONDC are nonzero,
!>             RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1.
!>          If RAT = 0, the two estimates are exactly the same.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 111 of file ztpt06.f.

112*
113* -- LAPACK test routine --
114* -- LAPACK is a software package provided by Univ. of Tennessee, --
115* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
116*
117* .. Scalar Arguments ..
118 CHARACTER DIAG, UPLO
119 INTEGER N
120 DOUBLE PRECISION RAT, RCOND, RCONDC
121* ..
122* .. Array Arguments ..
123 DOUBLE PRECISION RWORK( * )
124 COMPLEX*16 AP( * )
125* ..
126*
127* =====================================================================
128*
129* .. Parameters ..
130 DOUBLE PRECISION ZERO, ONE
131 parameter( zero = 0.0d+0, one = 1.0d+0 )
132* ..
133* .. Local Scalars ..
134 DOUBLE PRECISION ANORM, BIGNUM, EPS, RMAX, RMIN
135* ..
136* .. External Functions ..
137 DOUBLE PRECISION DLAMCH, ZLANTP
138 EXTERNAL dlamch, zlantp
139* ..
140* .. Intrinsic Functions ..
141 INTRINSIC max, min
142* ..
143* .. Executable Statements ..
144*
145 eps = dlamch( 'Epsilon' )
146 rmax = max( rcond, rcondc )
147 rmin = min( rcond, rcondc )
148*
149* Do the easy cases first.
150*
151 IF( rmin.LT.zero ) THEN
152*
153* Invalid value for RCOND or RCONDC, return 1/EPS.
154*
155 rat = one / eps
156*
157 ELSE IF( rmin.GT.zero ) THEN
158*
159* Both estimates are positive, return RMAX/RMIN - 1.
160*
161 rat = rmax / rmin - one
162*
163 ELSE IF( rmax.EQ.zero ) THEN
164*
165* Both estimates zero.
166*
167 rat = zero
168*
169 ELSE
170*
171* One estimate is zero, the other is non-zero. If the matrix is
172* ill-conditioned, return the nonzero estimate multiplied by
173* 1/EPS; if the matrix is badly scaled, return the nonzero
174* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum
175* element in absolute value in A.
176*
177 bignum = one / dlamch( 'Safe minimum' )
178 anorm = zlantp( 'M', uplo, diag, n, ap, rwork )
179*
180 rat = rmax*( min( bignum / max( one, anorm ), one / eps ) )
181 END IF
182*
183 RETURN
184*
185* End of ZTPT06
186*

◆ ztrt01()

subroutine ztrt01 ( character uplo,
character diag,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldainv, * ) ainv,
integer ldainv,
double precision rcond,
double precision, dimension( * ) rwork,
double precision resid )

ZTRT01

Purpose:
!>
!> ZTRT01 computes the residual for a triangular matrix A times its
!> inverse:
!>    RESID = norm( A*AINV - I ) / ( N * norm(A) * norm(AINV) * EPS ),
!> where EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The triangular matrix A.  If UPLO = 'U', the leading n by n
!>          upper triangular part of the array A contains the upper
!>          triangular matrix, and the strictly lower triangular part of
!>          A is not referenced.  If UPLO = 'L', the leading n by n lower
!>          triangular part of the array A contains the lower triangular
!>          matrix, and the strictly upper triangular part of A is not
!>          referenced.  If DIAG = 'U', the diagonal elements of A are
!>          also not referenced and are assumed to be 1.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]AINV
!>          AINV is COMPLEX*16 array, dimension (LDAINV,N)
!>          On entry, the (triangular) inverse of the matrix A, in the
!>          same storage format as A.
!>          On exit, the contents of AINV are destroyed.
!>
[in]LDAINV
!>          LDAINV is INTEGER
!>          The leading dimension of the array AINV.  LDAINV >= max(1,N).
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal condition number of A, computed as
!>          1/(norm(A) * norm(AINV)).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 123 of file ztrt01.f.

125*
126* -- LAPACK test routine --
127* -- LAPACK is a software package provided by Univ. of Tennessee, --
128* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
129*
130* .. Scalar Arguments ..
131 CHARACTER DIAG, UPLO
132 INTEGER LDA, LDAINV, N
133 DOUBLE PRECISION RCOND, RESID
134* ..
135* .. Array Arguments ..
136 DOUBLE PRECISION RWORK( * )
137 COMPLEX*16 A( LDA, * ), AINV( LDAINV, * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ZERO, ONE
144 parameter( zero = 0.0d+0, one = 1.0d+0 )
145* ..
146* .. Local Scalars ..
147 INTEGER J
148 DOUBLE PRECISION AINVNM, ANORM, EPS
149* ..
150* .. External Functions ..
151 LOGICAL LSAME
152 DOUBLE PRECISION DLAMCH, ZLANTR
153 EXTERNAL lsame, dlamch, zlantr
154* ..
155* .. External Subroutines ..
156 EXTERNAL ztrmv
157* ..
158* .. Intrinsic Functions ..
159 INTRINSIC dble
160* ..
161* .. Executable Statements ..
162*
163* Quick exit if N = 0
164*
165 IF( n.LE.0 ) THEN
166 rcond = one
167 resid = zero
168 RETURN
169 END IF
170*
171* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
172*
173 eps = dlamch( 'Epsilon' )
174 anorm = zlantr( '1', uplo, diag, n, n, a, lda, rwork )
175 ainvnm = zlantr( '1', uplo, diag, n, n, ainv, ldainv, rwork )
176 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
177 rcond = zero
178 resid = one / eps
179 RETURN
180 END IF
181 rcond = ( one / anorm ) / ainvnm
182*
183* Set the diagonal of AINV to 1 if AINV has unit diagonal.
184*
185 IF( lsame( diag, 'U' ) ) THEN
186 DO 10 j = 1, n
187 ainv( j, j ) = one
188 10 CONTINUE
189 END IF
190*
191* Compute A * AINV, overwriting AINV.
192*
193 IF( lsame( uplo, 'U' ) ) THEN
194 DO 20 j = 1, n
195 CALL ztrmv( 'Upper', 'No transpose', diag, j, a, lda,
196 $ ainv( 1, j ), 1 )
197 20 CONTINUE
198 ELSE
199 DO 30 j = 1, n
200 CALL ztrmv( 'Lower', 'No transpose', diag, n-j+1, a( j, j ),
201 $ lda, ainv( j, j ), 1 )
202 30 CONTINUE
203 END IF
204*
205* Subtract 1 from each diagonal element to form A*AINV - I.
206*
207 DO 40 j = 1, n
208 ainv( j, j ) = ainv( j, j ) - one
209 40 CONTINUE
210*
211* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS)
212*
213 resid = zlantr( '1', uplo, 'Non-unit', n, n, ainv, ldainv, rwork )
214*
215 resid = ( ( resid*rcond ) / dble( n ) ) / eps
216*
217 RETURN
218*
219* End of ZTRT01
220*

◆ ztrt02()

subroutine ztrt02 ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( * ) work,
double precision, dimension( * ) rwork,
double precision resid )

ZTRT02

Purpose:
!>
!> ZTRT02 computes the residual for the computed solution to a
!> triangular system of linear equations op(A)*X = B, where A is a
!> triangular matrix. The test ratio is the maximum over
!>    norm(b - op(A)*x) / ( ||op(A)||_1 * norm(x) * EPS ),
!> where op(A) = A, A**T, or A**H, b is the column of B, x is the
!> solution vector, and EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the operation applied to A.
!>          = 'N':  A    * X = B  (No transpose)
!>          = 'T':  A**T * X = B  (Transpose)
!>          = 'C':  A**H * X = B  (Conjugate transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices X and B.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The triangular matrix A.  If UPLO = 'U', the leading n by n
!>          upper triangular part of the array A contains the upper
!>          triangular matrix, and the strictly lower triangular part of
!>          A is not referenced.  If UPLO = 'L', the leading n by n lower
!>          triangular part of the array A contains the lower triangular
!>          matrix, and the strictly upper triangular part of A is not
!>          referenced.  If DIAG = 'U', the diagonal elements of A are
!>          also not referenced and are assumed to be 1.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors for the system of linear
!>          equations.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vectors for the system of linear
!>          equations.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N)
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*X - B) / ( norm(op(A)) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 153 of file ztrt02.f.

155*
156* -- LAPACK test routine --
157* -- LAPACK is a software package provided by Univ. of Tennessee, --
158* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
159*
160* .. Scalar Arguments ..
161 CHARACTER DIAG, TRANS, UPLO
162 INTEGER LDA, LDB, LDX, N, NRHS
163 DOUBLE PRECISION RESID
164* ..
165* .. Array Arguments ..
166 DOUBLE PRECISION RWORK( * )
167 COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ),
168 $ X( LDX, * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 DOUBLE PRECISION ZERO, ONE
175 parameter( zero = 0.0d+0, one = 1.0d+0 )
176* ..
177* .. Local Scalars ..
178 INTEGER J
179 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
180* ..
181* .. External Functions ..
182 LOGICAL LSAME
183 DOUBLE PRECISION DLAMCH, DZASUM, ZLANTR
184 EXTERNAL lsame, dlamch, dzasum, zlantr
185* ..
186* .. External Subroutines ..
187 EXTERNAL zaxpy, zcopy, ztrmv
188* ..
189* .. Intrinsic Functions ..
190 INTRINSIC dcmplx, max
191* ..
192* .. Executable Statements ..
193*
194* Quick exit if N = 0 or NRHS = 0
195*
196 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
197 resid = zero
198 RETURN
199 END IF
200*
201* Compute the 1-norm of op(A).
202*
203 IF( lsame( trans, 'N' ) ) THEN
204 anorm = zlantr( '1', uplo, diag, n, n, a, lda, rwork )
205 ELSE
206 anorm = zlantr( 'I', uplo, diag, n, n, a, lda, rwork )
207 END IF
208*
209* Exit with RESID = 1/EPS if ANORM = 0.
210*
211 eps = dlamch( 'Epsilon' )
212 IF( anorm.LE.zero ) THEN
213 resid = one / eps
214 RETURN
215 END IF
216*
217* Compute the maximum over the number of right hand sides of
218* norm(op(A)*X - B) / ( norm(op(A)) * norm(X) * EPS )
219*
220 resid = zero
221 DO 10 j = 1, nrhs
222 CALL zcopy( n, x( 1, j ), 1, work, 1 )
223 CALL ztrmv( uplo, trans, diag, n, a, lda, work, 1 )
224 CALL zaxpy( n, dcmplx( -one ), b( 1, j ), 1, work, 1 )
225 bnorm = dzasum( n, work, 1 )
226 xnorm = dzasum( n, x( 1, j ), 1 )
227 IF( xnorm.LE.zero ) THEN
228 resid = one / eps
229 ELSE
230 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
231 END IF
232 10 CONTINUE
233*
234 RETURN
235*
236* End of ZTRT02
237*

◆ ztrt03()

subroutine ztrt03 ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
double precision scale,
double precision, dimension( * ) cnorm,
double precision tscal,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( * ) work,
double precision resid )

ZTRT03

Purpose:
!>
!> ZTRT03 computes the residual for the solution to a scaled triangular
!> system of equations A*x = s*b,  A**T *x = s*b,  or  A**H *x = s*b.
!> Here A is a triangular matrix, A**T denotes the transpose of A, A**H
!> denotes the conjugate transpose of A, s is a scalar, and x and b are
!> N by NRHS matrices.  The test ratio is the maximum over the number of
!> right hand sides of
!>    norm(s*b - op(A)*x) / ( norm(op(A)) * norm(x) * EPS ),
!> where op(A) denotes A, A**T, or A**H, and EPS is the machine epsilon.
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the operation applied to A.
!>          = 'N':  A *x = s*b     (No transpose)
!>          = 'T':  A**T *x = s*b  (Transpose)
!>          = 'C':  A**H *x = s*b  (Conjugate transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices X and B.  NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The triangular matrix A.  If UPLO = 'U', the leading n by n
!>          upper triangular part of the array A contains the upper
!>          triangular matrix, and the strictly lower triangular part of
!>          A is not referenced.  If UPLO = 'L', the leading n by n lower
!>          triangular part of the array A contains the lower triangular
!>          matrix, and the strictly upper triangular part of A is not
!>          referenced.  If DIAG = 'U', the diagonal elements of A are
!>          also not referenced and are assumed to be 1.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]SCALE
!>          SCALE is DOUBLE PRECISION
!>          The scaling factor s used in solving the triangular system.
!>
[in]CNORM
!>          CNORM is DOUBLE PRECISION array, dimension (N)
!>          The 1-norms of the columns of A, not counting the diagonal.
!>
[in]TSCAL
!>          TSCAL is DOUBLE PRECISION
!>          The scaling factor used in computing the 1-norms in CNORM.
!>          CNORM actually contains the column norms of TSCAL*A.
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors for the system of linear
!>          equations.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vectors for the system of linear
!>          equations.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]WORK
!>          WORK is COMPLEX*16 array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 169 of file ztrt03.f.

171*
172* -- LAPACK test routine --
173* -- LAPACK is a software package provided by Univ. of Tennessee, --
174* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
175*
176* .. Scalar Arguments ..
177 CHARACTER DIAG, TRANS, UPLO
178 INTEGER LDA, LDB, LDX, N, NRHS
179 DOUBLE PRECISION RESID, SCALE, TSCAL
180* ..
181* .. Array Arguments ..
182 DOUBLE PRECISION CNORM( * )
183 COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ),
184 $ X( LDX, * )
185* ..
186*
187* =====================================================================
188*
189* .. Parameters ..
190 DOUBLE PRECISION ONE, ZERO
191 parameter( one = 1.0d+0, zero = 0.0d+0 )
192* ..
193* .. Local Scalars ..
194 INTEGER IX, J
195 DOUBLE PRECISION EPS, ERR, SMLNUM, TNORM, XNORM, XSCAL
196* ..
197* .. External Functions ..
198 LOGICAL LSAME
199 INTEGER IZAMAX
200 DOUBLE PRECISION DLAMCH
201 EXTERNAL lsame, izamax, dlamch
202* ..
203* .. External Subroutines ..
204 EXTERNAL zaxpy, zcopy, zdscal, ztrmv
205* ..
206* .. Intrinsic Functions ..
207 INTRINSIC abs, dble, dcmplx, max
208* ..
209* .. Executable Statements ..
210*
211* Quick exit if N = 0
212*
213 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
214 resid = zero
215 RETURN
216 END IF
217 eps = dlamch( 'Epsilon' )
218 smlnum = dlamch( 'Safe minimum' )
219*
220* Compute the norm of the triangular matrix A using the column
221* norms already computed by ZLATRS.
222*
223 tnorm = zero
224 IF( lsame( diag, 'N' ) ) THEN
225 DO 10 j = 1, n
226 tnorm = max( tnorm, tscal*abs( a( j, j ) )+cnorm( j ) )
227 10 CONTINUE
228 ELSE
229 DO 20 j = 1, n
230 tnorm = max( tnorm, tscal+cnorm( j ) )
231 20 CONTINUE
232 END IF
233*
234* Compute the maximum over the number of right hand sides of
235* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
236*
237 resid = zero
238 DO 30 j = 1, nrhs
239 CALL zcopy( n, x( 1, j ), 1, work, 1 )
240 ix = izamax( n, work, 1 )
241 xnorm = max( one, abs( x( ix, j ) ) )
242 xscal = ( one / xnorm ) / dble( n )
243 CALL zdscal( n, xscal, work, 1 )
244 CALL ztrmv( uplo, trans, diag, n, a, lda, work, 1 )
245 CALL zaxpy( n, dcmplx( -scale*xscal ), b( 1, j ), 1, work, 1 )
246 ix = izamax( n, work, 1 )
247 err = tscal*abs( work( ix ) )
248 ix = izamax( n, x( 1, j ), 1 )
249 xnorm = abs( x( ix, j ) )
250 IF( err*smlnum.LE.xnorm ) THEN
251 IF( xnorm.GT.zero )
252 $ err = err / xnorm
253 ELSE
254 IF( err.GT.zero )
255 $ err = one / eps
256 END IF
257 IF( err*smlnum.LE.tnorm ) THEN
258 IF( tnorm.GT.zero )
259 $ err = err / tnorm
260 ELSE
261 IF( err.GT.zero )
262 $ err = one / eps
263 END IF
264 resid = max( resid, err )
265 30 CONTINUE
266*
267 RETURN
268*
269* End of ZTRT03
270*

◆ ztrt05()

subroutine ztrt05 ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex*16, dimension( lda, * ) a,
integer lda,
complex*16, dimension( ldb, * ) b,
integer ldb,
complex*16, dimension( ldx, * ) x,
integer ldx,
complex*16, dimension( ldxact, * ) xact,
integer ldxact,
double precision, dimension( * ) ferr,
double precision, dimension( * ) berr,
double precision, dimension( * ) reslts )

ZTRT05

Purpose:
!>
!> ZTRT05 tests the error bounds from iterative refinement for the
!> computed solution to a system of equations A*X = B, where A is a
!> triangular n by n matrix.
!>
!> RESLTS(1) = test of the error bound
!>           = norm(X - XACT) / ( norm(X) * FERR )
!>
!> A large value is returned if this ratio is not less than one.
!>
!> RESLTS(2) = residual from the iterative refinement routine
!>           = the maximum of BERR / ( (n+1)*EPS + (*) ), where
!>             (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
!>
Parameters
[in]UPLO
!>          UPLO is CHARACTER*1
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]TRANS
!>          TRANS is CHARACTER*1
!>          Specifies the form of the system of equations.
!>          = 'N':  A * X = B  (No transpose)
!>          = 'T':  A'* X = B  (Transpose)
!>          = 'C':  A'* X = B  (Conjugate transpose = Transpose)
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]N
!>          N is INTEGER
!>          The number of rows of the matrices X, B, and XACT, and the
!>          order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of columns of the matrices X, B, and XACT.
!>          NRHS >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The triangular matrix A.  If UPLO = 'U', the leading n by n
!>          upper triangular part of the array A contains the upper
!>          triangular matrix, and the strictly lower triangular part of
!>          A is not referenced.  If UPLO = 'L', the leading n by n lower
!>          triangular part of the array A contains the lower triangular
!>          matrix, and the strictly upper triangular part of A is not
!>          referenced.  If DIAG = 'U', the diagonal elements of A are
!>          also not referenced and are assumed to be 1.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]B
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          The right hand side vectors for the system of linear
!>          equations.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[in]X
!>          X is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The computed solution vectors.  Each vector is stored as a
!>          column of the matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(1,N).
!>
[in]XACT
!>          XACT is COMPLEX*16 array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 180 of file ztrt05.f.

182*
183* -- LAPACK test routine --
184* -- LAPACK is a software package provided by Univ. of Tennessee, --
185* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
186*
187* .. Scalar Arguments ..
188 CHARACTER DIAG, TRANS, UPLO
189 INTEGER LDA, LDB, LDX, LDXACT, N, NRHS
190* ..
191* .. Array Arguments ..
192 DOUBLE PRECISION BERR( * ), FERR( * ), RESLTS( * )
193 COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ),
194 $ XACT( LDXACT, * )
195* ..
196*
197* =====================================================================
198*
199* .. Parameters ..
200 DOUBLE PRECISION ZERO, ONE
201 parameter( zero = 0.0d+0, one = 1.0d+0 )
202* ..
203* .. Local Scalars ..
204 LOGICAL NOTRAN, UNIT, UPPER
205 INTEGER I, IFU, IMAX, J, K
206 DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
207 COMPLEX*16 ZDUM
208* ..
209* .. External Functions ..
210 LOGICAL LSAME
211 INTEGER IZAMAX
212 DOUBLE PRECISION DLAMCH
213 EXTERNAL lsame, izamax, dlamch
214* ..
215* .. Intrinsic Functions ..
216 INTRINSIC abs, dble, dimag, max, min
217* ..
218* .. Statement Functions ..
219 DOUBLE PRECISION CABS1
220* ..
221* .. Statement Function definitions ..
222 cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
223* ..
224* .. Executable Statements ..
225*
226* Quick exit if N = 0 or NRHS = 0.
227*
228 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
229 reslts( 1 ) = zero
230 reslts( 2 ) = zero
231 RETURN
232 END IF
233*
234 eps = dlamch( 'Epsilon' )
235 unfl = dlamch( 'Safe minimum' )
236 ovfl = one / unfl
237 upper = lsame( uplo, 'U' )
238 notran = lsame( trans, 'N' )
239 unit = lsame( diag, 'U' )
240*
241* Test 1: Compute the maximum of
242* norm(X - XACT) / ( norm(X) * FERR )
243* over all the vectors X and XACT using the infinity-norm.
244*
245 errbnd = zero
246 DO 30 j = 1, nrhs
247 imax = izamax( n, x( 1, j ), 1 )
248 xnorm = max( cabs1( x( imax, j ) ), unfl )
249 diff = zero
250 DO 10 i = 1, n
251 diff = max( diff, cabs1( x( i, j )-xact( i, j ) ) )
252 10 CONTINUE
253*
254 IF( xnorm.GT.one ) THEN
255 GO TO 20
256 ELSE IF( diff.LE.ovfl*xnorm ) THEN
257 GO TO 20
258 ELSE
259 errbnd = one / eps
260 GO TO 30
261 END IF
262*
263 20 CONTINUE
264 IF( diff / xnorm.LE.ferr( j ) ) THEN
265 errbnd = max( errbnd, ( diff / xnorm ) / ferr( j ) )
266 ELSE
267 errbnd = one / eps
268 END IF
269 30 CONTINUE
270 reslts( 1 ) = errbnd
271*
272* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
273* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
274*
275 ifu = 0
276 IF( unit )
277 $ ifu = 1
278 DO 90 k = 1, nrhs
279 DO 80 i = 1, n
280 tmp = cabs1( b( i, k ) )
281 IF( upper ) THEN
282 IF( .NOT.notran ) THEN
283 DO 40 j = 1, i - ifu
284 tmp = tmp + cabs1( a( j, i ) )*cabs1( x( j, k ) )
285 40 CONTINUE
286 IF( unit )
287 $ tmp = tmp + cabs1( x( i, k ) )
288 ELSE
289 IF( unit )
290 $ tmp = tmp + cabs1( x( i, k ) )
291 DO 50 j = i + ifu, n
292 tmp = tmp + cabs1( a( i, j ) )*cabs1( x( j, k ) )
293 50 CONTINUE
294 END IF
295 ELSE
296 IF( notran ) THEN
297 DO 60 j = 1, i - ifu
298 tmp = tmp + cabs1( a( i, j ) )*cabs1( x( j, k ) )
299 60 CONTINUE
300 IF( unit )
301 $ tmp = tmp + cabs1( x( i, k ) )
302 ELSE
303 IF( unit )
304 $ tmp = tmp + cabs1( x( i, k ) )
305 DO 70 j = i + ifu, n
306 tmp = tmp + cabs1( a( j, i ) )*cabs1( x( j, k ) )
307 70 CONTINUE
308 END IF
309 END IF
310 IF( i.EQ.1 ) THEN
311 axbi = tmp
312 ELSE
313 axbi = min( axbi, tmp )
314 END IF
315 80 CONTINUE
316 tmp = berr( k ) / ( ( n+1 )*eps+( n+1 )*unfl /
317 $ max( axbi, ( n+1 )*unfl ) )
318 IF( k.EQ.1 ) THEN
319 reslts( 2 ) = tmp
320 ELSE
321 reslts( 2 ) = max( reslts( 2 ), tmp )
322 END IF
323 90 CONTINUE
324*
325 RETURN
326*
327* End of ZTRT05
328*

◆ ztrt06()

subroutine ztrt06 ( double precision rcond,
double precision rcondc,
character uplo,
character diag,
integer n,
complex*16, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) rwork,
double precision rat )

ZTRT06

Purpose:
!>
!> ZTRT06 computes a test ratio comparing RCOND (the reciprocal
!> condition number of a triangular matrix A) and RCONDC, the estimate
!> computed by ZTRCON.  Information about the triangular matrix A is
!> used if one estimate is zero and the other is non-zero to decide if
!> underflow in the estimate is justified.
!>
Parameters
[in]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The estimate of the reciprocal condition number obtained by
!>          forming the explicit inverse of the matrix A and computing
!>          RCOND = 1/( norm(A) * norm(inv(A)) ).
!>
[in]RCONDC
!>          RCONDC is DOUBLE PRECISION
!>          The estimate of the reciprocal condition number computed by
!>          ZTRCON.
!>
[in]UPLO
!>          UPLO is CHARACTER
!>          Specifies whether the matrix A is upper or lower triangular.
!>          = 'U':  Upper triangular
!>          = 'L':  Lower triangular
!>
[in]DIAG
!>          DIAG is CHARACTER
!>          Specifies whether or not the matrix A is unit triangular.
!>          = 'N':  Non-unit triangular
!>          = 'U':  Unit triangular
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]A
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          The triangular matrix A.  If UPLO = 'U', the leading n by n
!>          upper triangular part of the array A contains the upper
!>          triangular matrix, and the strictly lower triangular part of
!>          A is not referenced.  If UPLO = 'L', the leading n by n lower
!>          triangular part of the array A contains the lower triangular
!>          matrix, and the strictly upper triangular part of A is not
!>          referenced.  If DIAG = 'U', the diagonal elements of A are
!>          also not referenced and are assumed to be 1.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RAT
!>          RAT is DOUBLE PRECISION
!>          The test ratio.  If both RCOND and RCONDC are nonzero,
!>             RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1.
!>          If RAT = 0, the two estimates are exactly the same.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 120 of file ztrt06.f.

122*
123* -- LAPACK test routine --
124* -- LAPACK is a software package provided by Univ. of Tennessee, --
125* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
126*
127* .. Scalar Arguments ..
128 CHARACTER DIAG, UPLO
129 INTEGER LDA, N
130 DOUBLE PRECISION RAT, RCOND, RCONDC
131* ..
132* .. Array Arguments ..
133 DOUBLE PRECISION RWORK( * )
134 COMPLEX*16 A( LDA, * )
135* ..
136*
137* =====================================================================
138*
139* .. Parameters ..
140 DOUBLE PRECISION ZERO, ONE
141 parameter( zero = 0.0d+0, one = 1.0d+0 )
142* ..
143* .. Local Scalars ..
144 DOUBLE PRECISION ANORM, BIGNUM, EPS, RMAX, RMIN
145* ..
146* .. External Functions ..
147 DOUBLE PRECISION DLAMCH, ZLANTR
148 EXTERNAL dlamch, zlantr
149* ..
150* .. Intrinsic Functions ..
151 INTRINSIC max, min
152* ..
153* .. Executable Statements ..
154*
155 eps = dlamch( 'Epsilon' )
156 rmax = max( rcond, rcondc )
157 rmin = min( rcond, rcondc )
158*
159* Do the easy cases first.
160*
161 IF( rmin.LT.zero ) THEN
162*
163* Invalid value for RCOND or RCONDC, return 1/EPS.
164*
165 rat = one / eps
166*
167 ELSE IF( rmin.GT.zero ) THEN
168*
169* Both estimates are positive, return RMAX/RMIN - 1.
170*
171 rat = rmax / rmin - one
172*
173 ELSE IF( rmax.EQ.zero ) THEN
174*
175* Both estimates zero.
176*
177 rat = zero
178*
179 ELSE
180*
181* One estimate is zero, the other is non-zero. If the matrix is
182* ill-conditioned, return the nonzero estimate multiplied by
183* 1/EPS; if the matrix is badly scaled, return the nonzero
184* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum
185* element in absolute value in A.
186*
187 bignum = one / dlamch( 'Safe minimum' )
188 anorm = zlantr( 'M', uplo, diag, n, n, a, lda, rwork )
189*
190 rat = rmax*( min( bignum / max( one, anorm ), one / eps ) )
191 END IF
192*
193 RETURN
194*
195* End of ZTRT06
196*

◆ zunhr_col01()

subroutine zunhr_col01 ( integer m,
integer n,
integer mb1,
integer nb1,
integer nb2,
double precision, dimension(6) result )

ZUNHR_COL01

Purpose:
!>
!> ZUNHR_COL01 tests ZUNGTSQR and ZUNHR_COL using ZLATSQR, ZGEMQRT.
!> Therefore, ZLATSQR (part of ZGEQR), ZGEMQRT (part of ZGEMQR)
!> have to be tested before this test.
!>
!>
Parameters
[in]M
!>          M is INTEGER
!>          Number of rows in test matrix.
!>
[in]N
!>          N is INTEGER
!>          Number of columns in test matrix.
!>
[in]MB1
!>          MB1 is INTEGER
!>          Number of row in row block in an input test matrix.
!>
[in]NB1
!>          NB1 is INTEGER
!>          Number of columns in column block an input test matrix.
!>
[in]NB2
!>          NB2 is INTEGER
!>          Number of columns in column block in an output test matrix.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (6)
!>          Results of each of the six tests below.
!>
!>            A is a m-by-n test input matrix to be factored.
!>            so that A = Q_gr * ( R )
!>                               ( 0 ),
!>
!>            Q_qr is an implicit m-by-m unitary Q matrix, the result
!>            of factorization in blocked WY-representation,
!>            stored in ZGEQRT output format.
!>
!>            R is a n-by-n upper-triangular matrix,
!>
!>            0 is a (m-n)-by-n zero matrix,
!>
!>            Q is an explicit m-by-m unitary matrix Q = Q_gr * I
!>
!>            C is an m-by-n random matrix,
!>
!>            D is an n-by-m random matrix.
!>
!>          The six tests are:
!>
!>          RESULT(1) = |R - (Q**H) * A| / ( eps * m * |A| )
!>            is equivalent to test for | A - Q * R | / (eps * m * |A|),
!>
!>          RESULT(2) = |I - (Q**H) * Q| / ( eps * m ),
!>
!>          RESULT(3) = | Q_qr * C - Q * C | / (eps * m * |C|),
!>
!>          RESULT(4) = | (Q_gr**H) * C - (Q**H) * C | / (eps * m * |C|)
!>
!>          RESULT(5) = | D * Q_qr - D * Q | / (eps * m * |D|)
!>
!>          RESULT(6) = | D * (Q_qr**H) - D * (Q**H) | / (eps * m * |D|),
!>
!>          where:
!>            Q_qr * C, (Q_gr**H) * C, D * Q_qr, D * (Q_qr**H) are
!>            computed using ZGEMQRT,
!>
!>            Q * C, (Q**H) * C, D * Q, D * (Q**H)  are
!>            computed using ZGEMM.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 118 of file zunhr_col01.f.

119 IMPLICIT NONE
120*
121* -- LAPACK test routine --
122* -- LAPACK is a software package provided by Univ. of Tennessee, --
123* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
124*
125* .. Scalar Arguments ..
126 INTEGER M, N, MB1, NB1, NB2
127* .. Return values ..
128 DOUBLE PRECISION RESULT(6)
129*
130* =====================================================================
131*
132* ..
133* .. Local allocatable arrays
134 COMPLEX*16 , ALLOCATABLE :: A(:,:), AF(:,:), Q(:,:), R(:,:),
135 $ WORK( : ), T1(:,:), T2(:,:), DIAG(:),
136 $ C(:,:), CF(:,:), D(:,:), DF(:,:)
137 DOUBLE PRECISION, ALLOCATABLE :: RWORK(:)
138*
139* .. Parameters ..
140 DOUBLE PRECISION ZERO
141 parameter( zero = 0.0d+0 )
142 COMPLEX*16 CONE, CZERO
143 parameter( cone = ( 1.0d+0, 0.0d+0 ),
144 $ czero = ( 0.0d+0, 0.0d+0 ) )
145* ..
146* .. Local Scalars ..
147 LOGICAL TESTZEROS
148 INTEGER INFO, I, J, K, L, LWORK, NB1_UB, NB2_UB, NRB
149 DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM
150* ..
151* .. Local Arrays ..
152 INTEGER ISEED( 4 )
153 COMPLEX*16 WORKQUERY( 1 )
154* ..
155* .. External Functions ..
156 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY
157 EXTERNAL dlamch, zlange, zlansy
158* ..
159* .. External Subroutines ..
160 EXTERNAL zlacpy, zlarnv, zlaset, zlatsqr, zunhr_col,
161 $ zungtsqr, zscal, zgemm, zgemqrt, zherk
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC ceiling, dble, max, min
165* ..
166* .. Scalars in Common ..
167 CHARACTER(LEN=32) SRNAMT
168* ..
169* .. Common blocks ..
170 COMMON / srmnamc / srnamt
171* ..
172* .. Data statements ..
173 DATA iseed / 1988, 1989, 1990, 1991 /
174*
175* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS
176*
177 testzeros = .false.
178*
179 eps = dlamch( 'Epsilon' )
180 k = min( m, n )
181 l = max( m, n, 1)
182*
183* Dynamically allocate local arrays
184*
185 ALLOCATE ( a(m,n), af(m,n), q(l,l), r(m,l), rwork(l),
186 $ c(m,n), cf(m,n),
187 $ d(n,m), df(n,m) )
188*
189* Put random numbers into A and copy to AF
190*
191 DO j = 1, n
192 CALL zlarnv( 2, iseed, m, a( 1, j ) )
193 END DO
194 IF( testzeros ) THEN
195 IF( m.GE.4 ) THEN
196 DO j = 1, n
197 CALL zlarnv( 2, iseed, m/2, a( m/4, j ) )
198 END DO
199 END IF
200 END IF
201 CALL zlacpy( 'Full', m, n, a, m, af, m )
202*
203* Number of row blocks in ZLATSQR
204*
205 nrb = max( 1, ceiling( dble( m - n ) / dble( mb1 - n ) ) )
206*
207 ALLOCATE ( t1( nb1, n * nrb ) )
208 ALLOCATE ( t2( nb2, n ) )
209 ALLOCATE ( diag( n ) )
210*
211* Begin determine LWORK for the array WORK and allocate memory.
212*
213* ZLATSQR requires NB1 to be bounded by N.
214*
215 nb1_ub = min( nb1, n)
216*
217* ZGEMQRT requires NB2 to be bounded by N.
218*
219 nb2_ub = min( nb2, n)
220*
221 CALL zlatsqr( m, n, mb1, nb1_ub, af, m, t1, nb1,
222 $ workquery, -1, info )
223 lwork = int( workquery( 1 ) )
224 CALL zungtsqr( m, n, mb1, nb1, af, m, t1, nb1, workquery, -1,
225 $ info )
226
227 lwork = max( lwork, int( workquery( 1 ) ) )
228*
229* In ZGEMQRT, WORK is N*NB2_UB if SIDE = 'L',
230* or M*NB2_UB if SIDE = 'R'.
231*
232 lwork = max( lwork, nb2_ub * n, nb2_ub * m )
233*
234 ALLOCATE ( work( lwork ) )
235*
236* End allocate memory for WORK.
237*
238*
239* Begin Householder reconstruction routines
240*
241* Factor the matrix A in the array AF.
242*
243 srnamt = 'ZLATSQR'
244 CALL zlatsqr( m, n, mb1, nb1_ub, af, m, t1, nb1, work, lwork,
245 $ info )
246*
247* Copy the factor R into the array R.
248*
249 srnamt = 'ZLACPY'
250 CALL zlacpy( 'U', n, n, af, m, r, m )
251*
252* Reconstruct the orthogonal matrix Q.
253*
254 srnamt = 'ZUNGTSQR'
255 CALL zungtsqr( m, n, mb1, nb1, af, m, t1, nb1, work, lwork,
256 $ info )
257*
258* Perform the Householder reconstruction, the result is stored
259* the arrays AF and T2.
260*
261 srnamt = 'ZUNHR_COL'
262 CALL zunhr_col( m, n, nb2, af, m, t2, nb2, diag, info )
263*
264* Compute the factor R_hr corresponding to the Householder
265* reconstructed Q_hr and place it in the upper triangle of AF to
266* match the Q storage format in ZGEQRT. R_hr = R_tsqr * S,
267* this means changing the sign of I-th row of the matrix R_tsqr
268* according to sign of of I-th diagonal element DIAG(I) of the
269* matrix S.
270*
271 srnamt = 'ZLACPY'
272 CALL zlacpy( 'U', n, n, r, m, af, m )
273*
274 DO i = 1, n
275 IF( diag( i ).EQ.-cone ) THEN
276 CALL zscal( n+1-i, -cone, af( i, i ), m )
277 END IF
278 END DO
279*
280* End Householder reconstruction routines.
281*
282*
283* Generate the m-by-m matrix Q
284*
285 CALL zlaset( 'Full', m, m, czero, cone, q, m )
286*
287 srnamt = 'ZGEMQRT'
288 CALL zgemqrt( 'L', 'N', m, m, k, nb2_ub, af, m, t2, nb2, q, m,
289 $ work, info )
290*
291* Copy R
292*
293 CALL zlaset( 'Full', m, n, czero, czero, r, m )
294*
295 CALL zlacpy( 'Upper', m, n, af, m, r, m )
296*
297* TEST 1
298* Compute |R - (Q**H)*A| / ( eps * m * |A| ) and store in RESULT(1)
299*
300 CALL zgemm( 'C', 'N', m, n, m, -cone, q, m, a, m, cone, r, m )
301*
302 anorm = zlange( '1', m, n, a, m, rwork )
303 resid = zlange( '1', m, n, r, m, rwork )
304 IF( anorm.GT.zero ) THEN
305 result( 1 ) = resid / ( eps * max( 1, m ) * anorm )
306 ELSE
307 result( 1 ) = zero
308 END IF
309*
310* TEST 2
311* Compute |I - (Q**H)*Q| / ( eps * m ) and store in RESULT(2)
312*
313 CALL zlaset( 'Full', m, m, czero, cone, r, m )
314 CALL zherk( 'U', 'C', m, m, -cone, q, m, cone, r, m )
315 resid = zlansy( '1', 'Upper', m, r, m, rwork )
316 result( 2 ) = resid / ( eps * max( 1, m ) )
317*
318* Generate random m-by-n matrix C
319*
320 DO j = 1, n
321 CALL zlarnv( 2, iseed, m, c( 1, j ) )
322 END DO
323 cnorm = zlange( '1', m, n, c, m, rwork )
324 CALL zlacpy( 'Full', m, n, c, m, cf, m )
325*
326* Apply Q to C as Q*C = CF
327*
328 srnamt = 'ZGEMQRT'
329 CALL zgemqrt( 'L', 'N', m, n, k, nb2_ub, af, m, t2, nb2, cf, m,
330 $ work, info )
331*
332* TEST 3
333* Compute |CF - Q*C| / ( eps * m * |C| )
334*
335 CALL zgemm( 'N', 'N', m, n, m, -cone, q, m, c, m, cone, cf, m )
336 resid = zlange( '1', m, n, cf, m, rwork )
337 IF( cnorm.GT.zero ) THEN
338 result( 3 ) = resid / ( eps * max( 1, m ) * cnorm )
339 ELSE
340 result( 3 ) = zero
341 END IF
342*
343* Copy C into CF again
344*
345 CALL zlacpy( 'Full', m, n, c, m, cf, m )
346*
347* Apply Q to C as (Q**H)*C = CF
348*
349 srnamt = 'ZGEMQRT'
350 CALL zgemqrt( 'L', 'C', m, n, k, nb2_ub, af, m, t2, nb2, cf, m,
351 $ work, info )
352*
353* TEST 4
354* Compute |CF - (Q**H)*C| / ( eps * m * |C|)
355*
356 CALL zgemm( 'C', 'N', m, n, m, -cone, q, m, c, m, cone, cf, m )
357 resid = zlange( '1', m, n, cf, m, rwork )
358 IF( cnorm.GT.zero ) THEN
359 result( 4 ) = resid / ( eps * max( 1, m ) * cnorm )
360 ELSE
361 result( 4 ) = zero
362 END IF
363*
364* Generate random n-by-m matrix D and a copy DF
365*
366 DO j = 1, m
367 CALL zlarnv( 2, iseed, n, d( 1, j ) )
368 END DO
369 dnorm = zlange( '1', n, m, d, n, rwork )
370 CALL zlacpy( 'Full', n, m, d, n, df, n )
371*
372* Apply Q to D as D*Q = DF
373*
374 srnamt = 'ZGEMQRT'
375 CALL zgemqrt( 'R', 'N', n, m, k, nb2_ub, af, m, t2, nb2, df, n,
376 $ work, info )
377*
378* TEST 5
379* Compute |DF - D*Q| / ( eps * m * |D| )
380*
381 CALL zgemm( 'N', 'N', n, m, m, -cone, d, n, q, m, cone, df, n )
382 resid = zlange( '1', n, m, df, n, rwork )
383 IF( dnorm.GT.zero ) THEN
384 result( 5 ) = resid / ( eps * max( 1, m ) * dnorm )
385 ELSE
386 result( 5 ) = zero
387 END IF
388*
389* Copy D into DF again
390*
391 CALL zlacpy( 'Full', n, m, d, n, df, n )
392*
393* Apply Q to D as D*QT = DF
394*
395 srnamt = 'ZGEMQRT'
396 CALL zgemqrt( 'R', 'C', n, m, k, nb2_ub, af, m, t2, nb2, df, n,
397 $ work, info )
398*
399* TEST 6
400* Compute |DF - D*(Q**H)| / ( eps * m * |D| )
401*
402 CALL zgemm( 'N', 'C', n, m, m, -cone, d, n, q, m, cone, df, n )
403 resid = zlange( '1', n, m, df, n, rwork )
404 IF( dnorm.GT.zero ) THEN
405 result( 6 ) = resid / ( eps * max( 1, m ) * dnorm )
406 ELSE
407 result( 6 ) = zero
408 END IF
409*
410* Deallocate all arrays
411*
412 DEALLOCATE ( a, af, q, r, rwork, work, t1, t2, diag,
413 $ c, d, cf, df )
414*
415 RETURN
416*
417* End of ZUNHR_COL01
418*
zungtsqr
subroutine zungtsqr(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
ZUNGTSQR
Definition zungtsqr.f:175
zlatsqr
subroutine zlatsqr(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
ZLATSQR
Definition zlatsqr.f:166

◆ zunhr_col02()

subroutine zunhr_col02 ( integer m,
integer n,
integer mb1,
integer nb1,
integer nb2,
double precision, dimension(6) result )

ZUNHR_COL02

Purpose:
!>
!> ZUNHR_COL02 tests ZUNGTSQR_ROW and ZUNHR_COL inside ZGETSQRHRT
!> (which calls ZLATSQR, ZUNGTSQR_ROW and ZUNHR_COL) using ZGEMQRT.
!> Therefore, ZLATSQR (part of ZGEQR), ZGEMQRT (part of ZGEMQR)
!> have to be tested before this test.
!>
!>
Parameters
[in]M
!>          M is INTEGER
!>          Number of rows in test matrix.
!>
[in]N
!>          N is INTEGER
!>          Number of columns in test matrix.
!>
[in]MB1
!>          MB1 is INTEGER
!>          Number of row in row block in an input test matrix.
!>
[in]NB1
!>          NB1 is INTEGER
!>          Number of columns in column block an input test matrix.
!>
[in]NB2
!>          NB2 is INTEGER
!>          Number of columns in column block in an output test matrix.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (6)
!>          Results of each of the six tests below.
!>
!>            A is a m-by-n test input matrix to be factored.
!>            so that A = Q_gr * ( R )
!>                               ( 0 ),
!>
!>            Q_qr is an implicit m-by-m unitary Q matrix, the result
!>            of factorization in blocked WY-representation,
!>            stored in ZGEQRT output format.
!>
!>            R is a n-by-n upper-triangular matrix,
!>
!>            0 is a (m-n)-by-n zero matrix,
!>
!>            Q is an explicit m-by-m unitary matrix Q = Q_gr * I
!>
!>            C is an m-by-n random matrix,
!>
!>            D is an n-by-m random matrix.
!>
!>          The six tests are:
!>
!>          RESULT(1) = |R - (Q**H) * A| / ( eps * m * |A| )
!>            is equivalent to test for | A - Q * R | / (eps * m * |A|),
!>
!>          RESULT(2) = |I - (Q**H) * Q| / ( eps * m ),
!>
!>          RESULT(3) = | Q_qr * C - Q * C | / (eps * m * |C|),
!>
!>          RESULT(4) = | (Q_gr**H) * C - (Q**H) * C | / (eps * m * |C|)
!>
!>          RESULT(5) = | D * Q_qr - D * Q | / (eps * m * |D|)
!>
!>          RESULT(6) = | D * (Q_qr**H) - D * (Q**H) | / (eps * m * |D|),
!>
!>          where:
!>            Q_qr * C, (Q_gr**H) * C, D * Q_qr, D * (Q_qr**H) are
!>            computed using ZGEMQRT,
!>
!>            Q * C, (Q**H) * C, D * Q, D * (Q**H)  are
!>            computed using ZGEMM.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 119 of file zunhr_col02.f.

120 IMPLICIT NONE
121*
122* -- LAPACK test routine --
123* -- LAPACK is a software package provided by Univ. of Tennessee, --
124* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
125*
126* .. Scalar Arguments ..
127 INTEGER M, N, MB1, NB1, NB2
128* .. Return values ..
129 DOUBLE PRECISION RESULT(6)
130*
131* =====================================================================
132*
133* ..
134* .. Local allocatable arrays
135 COMPLEX*16 , ALLOCATABLE :: A(:,:), AF(:,:), Q(:,:), R(:,:),
136 $ WORK( : ), T1(:,:), T2(:,:), DIAG(:),
137 $ C(:,:), CF(:,:), D(:,:), DF(:,:)
138 DOUBLE PRECISION, ALLOCATABLE :: RWORK(:)
139*
140* .. Parameters ..
141 DOUBLE PRECISION ZERO
142 parameter( zero = 0.0d+0 )
143 COMPLEX*16 CONE, CZERO
144 parameter( cone = ( 1.0d+0, 0.0d+0 ),
145 $ czero = ( 0.0d+0, 0.0d+0 ) )
146* ..
147* .. Local Scalars ..
148 LOGICAL TESTZEROS
149 INTEGER INFO, J, K, L, LWORK, NB2_UB, NRB
150 DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM
151* ..
152* .. Local Arrays ..
153 INTEGER ISEED( 4 )
154 COMPLEX*16 WORKQUERY( 1 )
155* ..
156* .. External Functions ..
157 DOUBLE PRECISION DLAMCH, ZLANGE, ZLANSY
158 EXTERNAL dlamch, zlange, zlansy
159* ..
160* .. External Subroutines ..
161 EXTERNAL zlacpy, zlarnv, zlaset, zgetsqrhrt,
162 $ zscal, zgemm, zgemqrt, zherk
163* ..
164* .. Intrinsic Functions ..
165 INTRINSIC ceiling, dble, max, min
166* ..
167* .. Scalars in Common ..
168 CHARACTER(LEN=32) SRNAMT
169* ..
170* .. Common blocks ..
171 COMMON / srmnamc / srnamt
172* ..
173* .. Data statements ..
174 DATA iseed / 1988, 1989, 1990, 1991 /
175*
176* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS
177*
178 testzeros = .false.
179*
180 eps = dlamch( 'Epsilon' )
181 k = min( m, n )
182 l = max( m, n, 1)
183*
184* Dynamically allocate local arrays
185*
186 ALLOCATE ( a(m,n), af(m,n), q(l,l), r(m,l), rwork(l),
187 $ c(m,n), cf(m,n),
188 $ d(n,m), df(n,m) )
189*
190* Put random numbers into A and copy to AF
191*
192 DO j = 1, n
193 CALL zlarnv( 2, iseed, m, a( 1, j ) )
194 END DO
195 IF( testzeros ) THEN
196 IF( m.GE.4 ) THEN
197 DO j = 1, n
198 CALL zlarnv( 2, iseed, m/2, a( m/4, j ) )
199 END DO
200 END IF
201 END IF
202 CALL zlacpy( 'Full', m, n, a, m, af, m )
203*
204* Number of row blocks in ZLATSQR
205*
206 nrb = max( 1, ceiling( dble( m - n ) / dble( mb1 - n ) ) )
207*
208 ALLOCATE ( t1( nb1, n * nrb ) )
209 ALLOCATE ( t2( nb2, n ) )
210 ALLOCATE ( diag( n ) )
211*
212* Begin determine LWORK for the array WORK and allocate memory.
213*
214* ZGEMQRT requires NB2 to be bounded by N.
215*
216 nb2_ub = min( nb2, n)
217*
218*
219 CALL zgetsqrhrt( m, n, mb1, nb1, nb2, af, m, t2, nb2,
220 $ workquery, -1, info )
221*
222 lwork = int( workquery( 1 ) )
223*
224* In ZGEMQRT, WORK is N*NB2_UB if SIDE = 'L',
225* or M*NB2_UB if SIDE = 'R'.
226*
227 lwork = max( lwork, nb2_ub * n, nb2_ub * m )
228*
229 ALLOCATE ( work( lwork ) )
230*
231* End allocate memory for WORK.
232*
233*
234* Begin Householder reconstruction routines
235*
236* Factor the matrix A in the array AF.
237*
238 srnamt = 'ZGETSQRHRT'
239 CALL zgetsqrhrt( m, n, mb1, nb1, nb2, af, m, t2, nb2,
240 $ work, lwork, info )
241*
242* End Householder reconstruction routines.
243*
244*
245* Generate the m-by-m matrix Q
246*
247 CALL zlaset( 'Full', m, m, czero, cone, q, m )
248*
249 srnamt = 'ZGEMQRT'
250 CALL zgemqrt( 'L', 'N', m, m, k, nb2_ub, af, m, t2, nb2, q, m,
251 $ work, info )
252*
253* Copy R
254*
255 CALL zlaset( 'Full', m, n, czero, czero, r, m )
256*
257 CALL zlacpy( 'Upper', m, n, af, m, r, m )
258*
259* TEST 1
260* Compute |R - (Q**T)*A| / ( eps * m * |A| ) and store in RESULT(1)
261*
262 CALL zgemm( 'C', 'N', m, n, m, -cone, q, m, a, m, cone, r, m )
263*
264 anorm = zlange( '1', m, n, a, m, rwork )
265 resid = zlange( '1', m, n, r, m, rwork )
266 IF( anorm.GT.zero ) THEN
267 result( 1 ) = resid / ( eps * max( 1, m ) * anorm )
268 ELSE
269 result( 1 ) = zero
270 END IF
271*
272* TEST 2
273* Compute |I - (Q**T)*Q| / ( eps * m ) and store in RESULT(2)
274*
275 CALL zlaset( 'Full', m, m, czero, cone, r, m )
276 CALL zherk( 'U', 'C', m, m, -cone, q, m, cone, r, m )
277 resid = zlansy( '1', 'Upper', m, r, m, rwork )
278 result( 2 ) = resid / ( eps * max( 1, m ) )
279*
280* Generate random m-by-n matrix C
281*
282 DO j = 1, n
283 CALL zlarnv( 2, iseed, m, c( 1, j ) )
284 END DO
285 cnorm = zlange( '1', m, n, c, m, rwork )
286 CALL zlacpy( 'Full', m, n, c, m, cf, m )
287*
288* Apply Q to C as Q*C = CF
289*
290 srnamt = 'ZGEMQRT'
291 CALL zgemqrt( 'L', 'N', m, n, k, nb2_ub, af, m, t2, nb2, cf, m,
292 $ work, info )
293*
294* TEST 3
295* Compute |CF - Q*C| / ( eps * m * |C| )
296*
297 CALL zgemm( 'N', 'N', m, n, m, -cone, q, m, c, m, cone, cf, m )
298 resid = zlange( '1', m, n, cf, m, rwork )
299 IF( cnorm.GT.zero ) THEN
300 result( 3 ) = resid / ( eps * max( 1, m ) * cnorm )
301 ELSE
302 result( 3 ) = zero
303 END IF
304*
305* Copy C into CF again
306*
307 CALL zlacpy( 'Full', m, n, c, m, cf, m )
308*
309* Apply Q to C as (Q**T)*C = CF
310*
311 srnamt = 'ZGEMQRT'
312 CALL zgemqrt( 'L', 'C', m, n, k, nb2_ub, af, m, t2, nb2, cf, m,
313 $ work, info )
314*
315* TEST 4
316* Compute |CF - (Q**T)*C| / ( eps * m * |C|)
317*
318 CALL zgemm( 'C', 'N', m, n, m, -cone, q, m, c, m, cone, cf, m )
319 resid = zlange( '1', m, n, cf, m, rwork )
320 IF( cnorm.GT.zero ) THEN
321 result( 4 ) = resid / ( eps * max( 1, m ) * cnorm )
322 ELSE
323 result( 4 ) = zero
324 END IF
325*
326* Generate random n-by-m matrix D and a copy DF
327*
328 DO j = 1, m
329 CALL zlarnv( 2, iseed, n, d( 1, j ) )
330 END DO
331 dnorm = zlange( '1', n, m, d, n, rwork )
332 CALL zlacpy( 'Full', n, m, d, n, df, n )
333*
334* Apply Q to D as D*Q = DF
335*
336 srnamt = 'ZGEMQRT'
337 CALL zgemqrt( 'R', 'N', n, m, k, nb2_ub, af, m, t2, nb2, df, n,
338 $ work, info )
339*
340* TEST 5
341* Compute |DF - D*Q| / ( eps * m * |D| )
342*
343 CALL zgemm( 'N', 'N', n, m, m, -cone, d, n, q, m, cone, df, n )
344 resid = zlange( '1', n, m, df, n, rwork )
345 IF( dnorm.GT.zero ) THEN
346 result( 5 ) = resid / ( eps * max( 1, m ) * dnorm )
347 ELSE
348 result( 5 ) = zero
349 END IF
350*
351* Copy D into DF again
352*
353 CALL zlacpy( 'Full', n, m, d, n, df, n )
354*
355* Apply Q to D as D*QT = DF
356*
357 srnamt = 'ZGEMQRT'
358 CALL zgemqrt( 'R', 'C', n, m, k, nb2_ub, af, m, t2, nb2, df, n,
359 $ work, info )
360*
361* TEST 6
362* Compute |DF - D*(Q**T)| / ( eps * m * |D| )
363*
364 CALL zgemm( 'N', 'C', n, m, m, -cone, d, n, q, m, cone, df, n )
365 resid = zlange( '1', n, m, df, n, rwork )
366 IF( dnorm.GT.zero ) THEN
367 result( 6 ) = resid / ( eps * max( 1, m ) * dnorm )
368 ELSE
369 result( 6 ) = zero
370 END IF
371*
372* Deallocate all arrays
373*
374 DEALLOCATE ( a, af, q, r, rwork, work, t1, t2, diag,
375 $ c, d, cf, df )
376*
377 RETURN
378*
379* End of ZUNHR_COL02
380*
zgetsqrhrt
subroutine zgetsqrhrt(m, n, mb1, nb1, nb2, a, lda, t, ldt, work, lwork, info)
ZGETSQRHRT
Definition zgetsqrhrt.f:179