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

Functions

program cchkaa
 CCHKAA
subroutine cchkeq (thresh, nout)
 CCHKEQ
subroutine cchkgb (dotype, nm, mval, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, a, la, afac, lafac, b, x, xact, work, rwork, iwork, nout)
 CCHKGB
subroutine cchkge (dotype, nm, mval, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CCHKGE
subroutine cchkgt (dotype, nn, nval, nns, nsval, thresh, tsterr, a, af, b, x, xact, work, rwork, iwork, nout)
 CCHKGT
subroutine cchkhe (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CCHKHE
subroutine cchkhe_aa (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CCHKHE_AA
subroutine cchkhe_aa_2stage (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CCHKHE_AA_2STAGE
subroutine cchkhe_rk (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, e, ainv, b, x, xact, work, rwork, iwork, nout)
 CCHKHE_RK
subroutine cchkhe_rook (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CCHKHE_ROOK
subroutine cchkhp (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CCHKHP
subroutine cchklq (dotype, nm, mval, nn, nval, nnb, nbval, nxval, nrhs, thresh, tsterr, nmax, a, af, aq, al, ac, b, x, xact, tau, work, rwork, nout)
 CCHKLQ
subroutine cchkpb (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, nout)
 CCHKPB
subroutine cchkpo (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, nout)
 CCHKPO
subroutine cchkpp (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, nout)
 CCHKPP
subroutine cchkps (dotype, nn, nval, nnb, nbval, nrank, rankval, thresh, tsterr, nmax, a, afac, perm, piv, work, rwork, nout)
 CCHKPS
subroutine cchkpt (dotype, nn, nval, nns, nsval, thresh, tsterr, a, d, e, b, x, xact, work, rwork, nout)
 CCHKPT
subroutine cchkq3 (dotype, nm, mval, nn, nval, nnb, nbval, nxval, thresh, a, copya, s, tau, work, rwork, iwork, nout)
 CCHKQ3
subroutine cchkql (dotype, nm, mval, nn, nval, nnb, nbval, nxval, nrhs, thresh, tsterr, nmax, a, af, aq, al, ac, b, x, xact, tau, work, rwork, nout)
 CCHKQL
subroutine cchkqr (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)
 CCHKQR
subroutine cchkqrt (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 CCHKQRT
subroutine cchkqrtp (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 CCHKQRTP
program cchkrfp
 CCHKRFP
subroutine cchkrq (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)
 CCHKRQ
subroutine cchksp (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CCHKSP
subroutine cchksy (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CCHKSY
subroutine cchksy_aa (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CCHKSY_AA
subroutine cchksy_aa_2stage (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CCHKSY_AA_2STAGE
subroutine cchksy_rk (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, e, ainv, b, x, xact, work, rwork, iwork, nout)
 CCHKSY_RK
subroutine cchksy_rook (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CCHKSY_ROOK
subroutine cchktb (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, ab, ainv, b, x, xact, work, rwork, nout)
 CCHKTB
subroutine cchktp (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, ap, ainvp, b, x, xact, work, rwork, nout)
 CCHKTP
subroutine cchktr (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, ainv, b, x, xact, work, rwork, nout)
 CCHKTR
subroutine cchktz (dotype, nm, mval, nn, nval, thresh, tsterr, a, copya, s, tau, work, rwork, nout)
 CCHKTZ
subroutine cchkunhr_col (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 CCHKUNHR_COL
subroutine cdrvgb (dotype, nn, nval, nrhs, thresh, tsterr, a, la, afb, lafb, asav, b, bsav, x, xact, s, work, rwork, iwork, nout)
 CDRVGB
subroutine cdrvge (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, asav, b, bsav, x, xact, s, work, rwork, iwork, nout)
 CDRVGE
subroutine cdrvgt (dotype, nn, nval, nrhs, thresh, tsterr, a, af, b, x, xact, work, rwork, iwork, nout)
 CDRVGT
subroutine cdrvhe (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CDRVHE
subroutine cdrvhe_aa (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CDRVHE_AA
subroutine cdrvhe_aa_2stage (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CDRVHE_AA_2STAGE
subroutine cdrvhe_rk (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, e, ainv, b, x, xact, work, rwork, iwork, nout)
 CDRVHE_RK
subroutine cdrvhe_rook (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CDRVHE_ROOK
subroutine cdrvhp (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CDRVHP
subroutine cdrvls (dotype, nm, mval, nn, nval, nns, nsval, nnb, nbval, nxval, thresh, tsterr, a, copya, b, copyb, c, s, copys, nout)
 CDRVLS
subroutine cdrvpb (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, asav, b, bsav, x, xact, s, work, rwork, nout)
 CDRVPB
subroutine cdrvpo (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, asav, b, bsav, x, xact, s, work, rwork, nout)
 CDRVPO
subroutine cdrvpp (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, asav, b, bsav, x, xact, s, work, rwork, nout)
 CDRVPP
subroutine cdrvpt (dotype, nn, nval, nrhs, thresh, tsterr, a, d, e, b, x, xact, work, rwork, nout)
 CDRVPT
subroutine cdrvrf1 (nout, nn, nval, thresh, a, lda, arf, work)
 CDRVRF1
subroutine cdrvrf2 (nout, nn, nval, a, lda, arf, ap, asav)
 CDRVRF2
subroutine cdrvrf3 (nout, nn, nval, thresh, a, lda, arf, b1, b2, s_work_clange, c_work_cgeqrf, tau)
 CDRVRF3
subroutine cdrvrf4 (nout, nn, nval, thresh, c1, c2, ldc, crf, a, lda, s_work_clange)
 CDRVRF4
subroutine cdrvrfp (nout, nn, nval, nns, nsval, nnt, ntval, thresh, a, asav, afac, ainv, b, bsav, xact, x, arf, arfinv, c_work_clatms, c_work_cpot02, c_work_cpot03, s_work_clatms, s_work_clanhe, s_work_cpot01, s_work_cpot02, s_work_cpot03)
 CDRVRFP
subroutine cdrvsp (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CDRVSP
subroutine cdrvsy (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CDRVSY
subroutine cdrvsy_aa (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CDRVSY_AA
subroutine cdrvsy_aa_2stage (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CDRVSY_AA_2STAGE
subroutine cdrvsy_rk (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, e, ainv, b, x, xact, work, rwork, iwork, nout)
 CDRVSY_RK
subroutine cdrvsy_rook (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 CDRVSY_ROOK
subroutine cebchvxx (thresh, path)
 CEBCHVXX
subroutine cerrge (path, nunit)
 CERRGE
subroutine cerrgt (path, nunit)
 CERRGT
subroutine cerrhe (path, nunit)
 CERRHE
subroutine cerrlq (path, nunit)
 CERRLQ
subroutine cerrls (path, nunit)
 CERRLS
subroutine cerrpo (path, nunit)
 CERRPO
subroutine cerrps (path, nunit)
 CERRPS
subroutine cerrql (path, nunit)
 CERRQL
subroutine cerrqp (path, nunit)
 CERRQP
subroutine cerrqr (path, nunit)
 CERRQR
subroutine cerrqrt (path, nunit)
 CERRQRT
subroutine cerrqrtp (path, nunit)
 CERRQRTP
subroutine cerrrfp (nunit)
 CERRRFP
subroutine cerrrq (path, nunit)
 CERRRQ
subroutine cerrsy (path, nunit)
 CERRSY
subroutine cerrtr (path, nunit)
 CERRTR
subroutine cerrtz (path, nunit)
 CERRTZ
subroutine cerrunhr_col (path, nunit)
 CERRUNHR_COL
subroutine cerrvx (path, nunit)
 CERRVX
subroutine cgbt01 (m, n, kl, ku, a, lda, afac, ldafac, ipiv, work, resid)
 CGBT01
subroutine cgbt02 (trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 CGBT02
subroutine cgbt05 (trans, n, kl, ku, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 CGBT05
subroutine cgelqs (m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
 CGELQS
logical function cgennd (m, n, a, lda)
 CGENND
subroutine cgeqls (m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
 CGEQLS
subroutine cgeqrs (m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
 CGEQRS
subroutine cgerqs (m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
 CGERQS
subroutine cget01 (m, n, a, lda, afac, ldafac, ipiv, rwork, resid)
 CGET01
subroutine cget02 (trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 CGET02
subroutine cget03 (n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
 CGET03
subroutine cget04 (n, nrhs, x, ldx, xact, ldxact, rcond, resid)
 CGET04
subroutine cget07 (trans, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, chkferr, berr, reslts)
 CGET07
subroutine cgtt01 (n, dl, d, du, dlf, df, duf, du2, ipiv, work, ldwork, rwork, resid)
 CGTT01
subroutine cgtt02 (trans, n, nrhs, dl, d, du, x, ldx, b, ldb, resid)
 CGTT02
subroutine cgtt05 (trans, n, nrhs, dl, d, du, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 CGTT05
subroutine chet01 (uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
 CHET01
subroutine chet01_3 (uplo, n, a, lda, afac, ldafac, e, ipiv, c, ldc, rwork, resid)
 CHET01_3
subroutine chet01_aa (uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
 CHET01_AA
subroutine chet01_rook (uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
 CHET01_ROOK
subroutine chkxer (srnamt, infot, nout, lerr, ok)
 CHKXER
subroutine chpt01 (uplo, n, a, afac, ipiv, c, ldc, rwork, resid)
 CHPT01
subroutine clahilb (n, nrhs, a, lda, x, ldx, b, ldb, work, info, path)
 CLAHILB
subroutine claipd (n, a, inda, vinda)
 CLAIPD
subroutine claptm (uplo, n, nrhs, alpha, d, e, x, ldx, beta, b, ldb)
 CLAPTM
subroutine clarhs (path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
 CLARHS
subroutine clatb4 (path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
 CLATB4
subroutine clatb5 (path, imat, n, type, kl, ku, anorm, mode, cndnum, dist)
 CLATB5
subroutine clatsp (uplo, n, x, iseed)
 CLATSP
subroutine clatsy (uplo, n, x, ldx, iseed)
 CLATSY
subroutine clattb (imat, uplo, trans, diag, iseed, n, kd, ab, ldab, b, work, rwork, info)
 CLATTB
subroutine clattp (imat, uplo, trans, diag, iseed, n, ap, b, work, rwork, info)
 CLATTP
subroutine clattr (imat, uplo, trans, diag, iseed, n, a, lda, b, work, rwork, info)
 CLATTR
subroutine clavhe (uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
 CLAVHE
subroutine clavhe_rook (uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
 CLAVHE_ROOK
subroutine clavhp (uplo, trans, diag, n, nrhs, a, ipiv, b, ldb, info)
 CLAVHP
subroutine clavsp (uplo, trans, diag, n, nrhs, a, ipiv, b, ldb, info)
 CLAVSP
subroutine clavsy (uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
 CLAVSY
subroutine clavsy_rook (uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
 CLAVSY_ROOK
subroutine clqt01 (m, n, a, af, q, l, lda, tau, work, lwork, rwork, result)
 CLQT01
subroutine clqt02 (m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
 CLQT02
subroutine clqt03 (m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
 CLQT03
subroutine cpbt01 (uplo, n, kd, a, lda, afac, ldafac, rwork, resid)
 CPBT01
subroutine cpbt02 (uplo, n, kd, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 CPBT02
subroutine cpbt05 (uplo, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 CPBT05
subroutine cpot01 (uplo, n, a, lda, afac, ldafac, rwork, resid)
 CPOT01
subroutine cpot02 (uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 CPOT02
subroutine cpot03 (uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
 CPOT03
subroutine cpot05 (uplo, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 CPOT05
subroutine cppt01 (uplo, n, a, afac, rwork, resid)
 CPPT01
subroutine cppt02 (uplo, n, nrhs, a, x, ldx, b, ldb, rwork, resid)
 CPPT02
subroutine cppt03 (uplo, n, a, ainv, work, ldwork, rwork, rcond, resid)
 CPPT03
subroutine cppt05 (uplo, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 CPPT05
subroutine cpst01 (uplo, n, a, lda, afac, ldafac, perm, ldperm, piv, rwork, resid, rank)
 CPST01
subroutine cptt01 (n, d, e, df, ef, work, resid)
 CPTT01
subroutine cptt02 (uplo, n, nrhs, d, e, x, ldx, b, ldb, resid)
 CPTT02
subroutine cptt05 (n, nrhs, d, e, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 CPTT05
subroutine cqlt01 (m, n, a, af, q, l, lda, tau, work, lwork, rwork, result)
 CQLT01
subroutine cqlt02 (m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
 CQLT02
subroutine cqlt03 (m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
 CQLT03
real function cqpt01 (m, n, k, a, af, lda, tau, jpvt, work, lwork)
 CQPT01
subroutine cqrt01 (m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
 CQRT01
subroutine cqrt01p (m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
 CQRT01P
subroutine cqrt02 (m, n, k, a, af, q, r, lda, tau, work, lwork, rwork, result)
 CQRT02
subroutine cqrt03 (m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
 CQRT03
subroutine cqrt04 (m, n, nb, result)
 CQRT04
subroutine cqrt05 (m, n, l, nb, result)
 CQRT05
real function cqrt11 (m, k, a, lda, tau, work, lwork)
 CQRT11
real function cqrt12 (m, n, a, lda, s, work, lwork, rwork)
 CQRT12
subroutine cqrt13 (scale, m, n, a, lda, norma, iseed)
 CQRT13
real function cqrt14 (trans, m, n, nrhs, a, lda, x, ldx, work, lwork)
 CQRT14
subroutine cqrt15 (scale, rksel, m, n, nrhs, a, lda, b, ldb, s, rank, norma, normb, iseed, work, lwork)
 CQRT15
subroutine cqrt16 (trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 CQRT16
real function cqrt17 (trans, iresid, m, n, nrhs, a, lda, x, ldx, b, ldb, c, work, lwork)
 CQRT17
subroutine crqt01 (m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
 CRQT01
subroutine crqt02 (m, n, k, a, af, q, r, lda, tau, work, lwork, rwork, result)
 CRQT02
subroutine crqt03 (m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
 CRQT03
real function crzt01 (m, n, a, af, lda, tau, work, lwork)
 CRZT01
real function crzt02 (m, n, af, lda, tau, work, lwork)
 CRZT02
subroutine csbmv (uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
 CSBMV
subroutine cspt01 (uplo, n, a, afac, ipiv, c, ldc, rwork, resid)
 CSPT01
subroutine cspt02 (uplo, n, nrhs, a, x, ldx, b, ldb, rwork, resid)
 CSPT02
subroutine cspt03 (uplo, n, a, ainv, work, ldw, rwork, rcond, resid)
 CSPT03
subroutine csyt01 (uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
 CSYT01
subroutine csyt01_3 (uplo, n, a, lda, afac, ldafac, e, ipiv, c, ldc, rwork, resid)
 CSYT01_3
subroutine csyt01_aa (uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
 CSYT01
subroutine csyt01_rook (uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
 CSYT01_ROOK
subroutine csyt02 (uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 CSYT02
subroutine csyt03 (uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
 CSYT03
subroutine ctbt02 (uplo, trans, diag, n, kd, nrhs, ab, ldab, x, ldx, b, ldb, work, rwork, resid)
 CTBT02
subroutine ctbt03 (uplo, trans, diag, n, kd, nrhs, ab, ldab, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
 CTBT03
subroutine ctbt05 (uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 CTBT05
subroutine ctbt06 (rcond, rcondc, uplo, diag, n, kd, ab, ldab, rwork, rat)
 CTBT06
subroutine ctpt01 (uplo, diag, n, ap, ainvp, rcond, rwork, resid)
 CTPT01
subroutine ctpt02 (uplo, trans, diag, n, nrhs, ap, x, ldx, b, ldb, work, rwork, resid)
 CTPT02
subroutine ctpt03 (uplo, trans, diag, n, nrhs, ap, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
 CTPT03
subroutine ctpt05 (uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 CTPT05
subroutine ctpt06 (rcond, rcondc, uplo, diag, n, ap, rwork, rat)
 CTPT06
subroutine ctrt01 (uplo, diag, n, a, lda, ainv, ldainv, rcond, rwork, resid)
 CTRT01
subroutine ctrt02 (uplo, trans, diag, n, nrhs, a, lda, x, ldx, b, ldb, work, rwork, resid)
 CTRT02
subroutine ctrt03 (uplo, trans, diag, n, nrhs, a, lda, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
 CTRT03
subroutine ctrt05 (uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 CTRT05
subroutine ctrt06 (rcond, rcondc, uplo, diag, n, a, lda, rwork, rat)
 CTRT06
subroutine cunhr_col01 (m, n, mb1, nb1, nb2, result)
 CUNHR_COL01
subroutine cunhr_col02 (m, n, mb1, nb1, nb2, result)
 CUNHR_COL02

Detailed Description

This is the group of complex LAPACK TESTING LIN routines.

Function Documentation

◆ cchkaa()

program cchkaa

CCHKAA

Purpose:
!>
!> CCHKAA is the main test program for the COMPLEX 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 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
!> CGE   11               List types on next line if 0 < NTYPES < 11
!> CGB    8               List types on next line if 0 < NTYPES <  8
!> CGT   12               List types on next line if 0 < NTYPES < 12
!> CPO    9               List types on next line if 0 < NTYPES <  9
!> CPO    9               List types on next line if 0 < NTYPES <  9
!> CPP    9               List types on next line if 0 < NTYPES <  9
!> CPB    8               List types on next line if 0 < NTYPES <  8
!> CPT   12               List types on next line if 0 < NTYPES < 12
!> CHE   10               List types on next line if 0 < NTYPES < 10
!> CHR   10               List types on next line if 0 < NTYPES < 10
!> CHK   10               List types on next line if 0 < NTYPES < 10
!> CHA   10               List types on next line if 0 < NTYPES < 10
!> CH2   10               List types on next line if 0 < NTYPES < 10
!> CSA   11               List types on next line if 0 < NTYPES < 10
!> CS2   11               List types on next line if 0 < NTYPES < 10
!> CHP   10               List types on next line if 0 < NTYPES < 10
!> CSY   11               List types on next line if 0 < NTYPES < 11
!> CSK   11               List types on next line if 0 < NTYPES < 11
!> CSR   11               List types on next line if 0 < NTYPES < 11
!> CSP   11               List types on next line if 0 < NTYPES < 11
!> CTR   18               List types on next line if 0 < NTYPES < 18
!> CTP   18               List types on next line if 0 < NTYPES < 18
!> CTB   17               List types on next line if 0 < NTYPES < 17
!> CQR    8               List types on next line if 0 < NTYPES <  8
!> CRQ    8               List types on next line if 0 < NTYPES <  8
!> CLQ    8               List types on next line if 0 < NTYPES <  8
!> CQL    8               List types on next line if 0 < NTYPES <  8
!> CQP    6               List types on next line if 0 < NTYPES <  6
!> CTZ    3               List types on next line if 0 < NTYPES <  3
!> CLS    6               List types on next line if 0 < NTYPES <  6
!> CEQ
!> CQT
!> CQX
!> CTS
!> CHH
!> 
!>  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 cchkaa.F.

◆ cchkeq()

subroutine cchkeq ( real thresh,
integer nout )

CCHKEQ

Purpose:
!>
!> CCHKEQ tests CGEEQU, CGBEQU, CPOEQU, CPPEQU and CPBEQU
!>
Parameters
[in]THRESH
!>          THRESH is REAL
!>          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 cchkeq.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 REAL THRESH
62* ..
63*
64* =====================================================================
65*
66* .. Parameters ..
67 REAL ZERO, ONE, TEN
68 parameter( zero = 0.0e0, one = 1.0e+0, ten = 1.0e1 )
69 COMPLEX CZERO
70 parameter( czero = ( 0.0e0, 0.0e0 ) )
71 COMPLEX CONE
72 parameter( cone = ( 1.0e0, 0.0e0 ) )
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 REAL CCOND, EPS, NORM, RATIO, RCMAX, RCMIN, RCOND
84* ..
85* .. Local Arrays ..
86 REAL C( NSZ ), POW( NPOW ), R( NSZ ), RESLTS( 5 ),
87 $ RPOW( NPOW )
88 COMPLEX A( NSZ, NSZ ), AB( NSZB, NSZ ), AP( NSZP )
89* ..
90* .. External Functions ..
91 REAL SLAMCH
92 EXTERNAL slamch
93* ..
94* .. External Subroutines ..
95 EXTERNAL cgbequ, cgeequ, cpbequ, cpoequ, cppequ
96* ..
97* .. Intrinsic Functions ..
98 INTRINSIC abs, max, min
99* ..
100* .. Executable Statements ..
101*
102 path( 1:1 ) = 'Complex precision'
103 path( 2:3 ) = 'EQ'
104*
105 eps = slamch( '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 CGEEQU
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 cgeequ( 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 cgeequ( 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 cgeequ( 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 CGBEQU
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 cgbequ( 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 CPOEQU
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 cpoequ( 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 cpoequ( 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 CPPEQU
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 cppequ( '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 cppequ( '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 cppequ( '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 CPBEQU
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 cpbequ( '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 cpbequ( '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 cpbequ( '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 cpbequ( '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( ' CGEEQU failed test with value ', e10.3, ' exceeding',
478 $ ' threshold ', e10.3 )
479 9997 FORMAT( ' CGBEQU failed test with value ', e10.3, ' exceeding',
480 $ ' threshold ', e10.3 )
481 9996 FORMAT( ' CPOEQU failed test with value ', e10.3, ' exceeding',
482 $ ' threshold ', e10.3 )
483 9995 FORMAT( ' CPPEQU failed test with value ', e10.3, ' exceeding',
484 $ ' threshold ', e10.3 )
485 9994 FORMAT( ' CPBEQU failed test with value ', e10.3, ' exceeding',
486 $ ' threshold ', e10.3 )
487 RETURN
488*
489* End of CCHKEQ
490*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
cgbequ
subroutine cgbequ(m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, info)
CGBEQU
Definition cgbequ.f:154
cgeequ
subroutine cgeequ(m, n, a, lda, r, c, rowcnd, colcnd, amax, info)
CGEEQU
Definition cgeequ.f:140
cppequ
subroutine cppequ(uplo, n, ap, s, scond, amax, info)
CPPEQU
Definition cppequ.f:117
cpbequ
subroutine cpbequ(uplo, n, kd, ab, ldab, s, scond, amax, info)
CPBEQU
Definition cpbequ.f:130
cpoequ
subroutine cpoequ(n, a, lda, s, scond, amax, info)
CPOEQU
Definition cpoequ.f:113
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21

◆ cchkgb()

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

CCHKGB

Purpose:
!>
!> CCHKGB tests CGBTRF, -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 REAL
!>          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 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 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 array, dimension (NMAX*NSMAX)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NSMAX,NMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchkgb.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 REAL THRESH
200* ..
201* .. Array Arguments ..
202 LOGICAL DOTYPE( * )
203 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
204 $ NVAL( * )
205 REAL RWORK( * )
206 COMPLEX A( * ), AFAC( * ), B( * ), WORK( * ), X( * ),
207 $ XACT( * )
208* ..
209*
210* =====================================================================
211*
212* .. Parameters ..
213 REAL ONE, ZERO
214 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL RESULT( NTESTS )
236* ..
237* .. External Functions ..
238 REAL CLANGB, CLANGE, SGET06
239 EXTERNAL clangb, clange, sget06
240* ..
241* .. External Subroutines ..
242 EXTERNAL alaerh, alahd, alasum, ccopy, cerrge, cgbcon,
243 $ cgbrfs, cgbt01, cgbt02, cgbt05, cgbtrf, cgbtrs,
244 $ cget04, clacpy, clarhs, claset, clatb4, clatms,
245 $ xlaenv
246* ..
247* .. Intrinsic Functions ..
248 INTRINSIC cmplx, 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 ) = 'Complex 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 cerrge( 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 CLATB4 and generate a
381* test matrix with CLATMS.
382*
383 CALL clatb4( 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 = 'CLATMS'
391 CALL clatms( 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 CLATMS.
396*
397 IF( info.NE.0 ) THEN
398 CALL alaerh( path, 'CLATMS', 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 ccopy( 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 ccopy( 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 = CLANGB( 'O', N, KL, KU, A, LDA, RWORK )
451* ANORMI = CLANGB( '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 clacpy( 'Full', kl+ku+1, n, a, lda,
463 $ afac( kl+1 ), ldafac )
464 srnamt = 'CGBTRF'
465 CALL cgbtrf( m, n, kl, ku, afac, ldafac, iwork,
466 $ info )
467*
468* Check error code from CGBTRF.
469*
470 IF( info.NE.izero )
471 $ CALL alaerh( path, 'CGBTRF', 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 cgbt01( 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 = clangb( 'O', n, kl, ku, a, lda, rwork )
502 anormi = clangb( '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 claset( 'Full', n, n, cmplx( zero ),
511 $ cmplx( one ), work, ldb )
512 srnamt = 'CGBTRS'
513 CALL cgbtrs( '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 = clange( '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 = clange( '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 = 'CLARHS'
569 CALL clarhs( path, xtype, ' ', trans, n,
570 $ n, kl, ku, nrhs, a, lda,
571 $ xact, ldb, b, ldb, iseed,
572 $ info )
573 xtype = 'C'
574 CALL clacpy( 'Full', n, nrhs, b, ldb, x,
575 $ ldb )
576*
577 srnamt = 'CGBTRS'
578 CALL cgbtrs( trans, n, kl, ku, nrhs, afac,
579 $ ldafac, iwork, x, ldb, info )
580*
581* Check error code from CGBTRS.
582*
583 IF( info.NE.0 )
584 $ CALL alaerh( path, 'CGBTRS', info, 0,
585 $ trans, n, n, kl, ku, -1,
586 $ imat, nfail, nerrs, nout )
587*
588 CALL clacpy( 'Full', n, nrhs, b, ldb,
589 $ work, ldb )
590 CALL cgbt02( 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 cget04( 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 = 'CGBRFS'
606 CALL cgbrfs( 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 CGBRFS.
613*
614 IF( info.NE.0 )
615 $ CALL alaerh( path, 'CGBRFS', info, 0,
616 $ trans, n, n, kl, ku, nrhs,
617 $ imat, nfail, nerrs, nout )
618*
619 CALL cget04( n, nrhs, x, ldb, xact, ldb,
620 $ rcondc, result( 4 ) )
621 CALL cgbt05( 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 = 'CGBCON'
658 CALL cgbcon( norm, n, kl, ku, afac, ldafac,
659 $ iwork, anorm, rcond, work,
660 $ rwork, info )
661*
662* Check error code from CGBCON.
663*
664 IF( info.NE.0 )
665 $ CALL alaerh( path, 'CGBCON', info, 0,
666 $ norm, n, n, kl, ku, -1, imat,
667 $ nfail, nerrs, nout )
668*
669 result( 7 ) = sget06( 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 CCHKGB, 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 CCHKGB, 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 CCHKGB
710*
cmplx
float cmplx[2]
Definition pblas.h:136
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
clangb
real function clangb(norm, n, kl, ku, ab, ldab, work)
CLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition clangb.f:125
cgbrfs
subroutine cgbrfs(trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CGBRFS
Definition cgbrfs.f:206
cgbtrf
subroutine cgbtrf(m, n, kl, ku, ab, ldab, ipiv, info)
CGBTRF
Definition cgbtrf.f:144
cgbcon
subroutine cgbcon(norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond, work, rwork, info)
CGBCON
Definition cgbcon.f:147
cgbtrs
subroutine cgbtrs(trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
CGBTRS
Definition cgbtrs.f:138
clange
real function clange(norm, m, n, a, lda, work)
CLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition clange.f:115
clacpy
subroutine clacpy(uplo, m, n, a, lda, b, ldb)
CLACPY copies all or part of one two-dimensional array to another.
Definition clacpy.f:103
claset
subroutine claset(uplo, m, n, alpha, beta, a, lda)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition claset.f:106
ccopy
subroutine ccopy(n, cx, incx, cy, incy)
CCOPY
Definition ccopy.f:81
clarhs
subroutine clarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
CLARHS
Definition clarhs.f:208
cgbt01
subroutine cgbt01(m, n, kl, ku, a, lda, afac, ldafac, ipiv, work, resid)
CGBT01
Definition cgbt01.f:126
cgbt02
subroutine cgbt02(trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
CGBT02
Definition cgbt02.f:148
cgbt05
subroutine cgbt05(trans, n, kl, ku, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
CGBT05
Definition cgbt05.f:176
clatb4
subroutine clatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
CLATB4
Definition clatb4.f:121
cerrge
subroutine cerrge(path, nunit)
CERRGE
Definition cerrge.f:55
cget04
subroutine cget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
CGET04
Definition cget04.f:102
clatms
subroutine clatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
CLATMS
Definition clatms.f:332
sget06
real function sget06(rcond, rcondc)
SGET06
Definition sget06.f:55

◆ cchkge()

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

CCHKGE

Purpose:
!>
!> CCHKGE tests CGETRF, -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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchkge.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 REAL THRESH
195* ..
196* .. Array Arguments ..
197 LOGICAL DOTYPE( * )
198 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
199 $ NVAL( * )
200 REAL RWORK( * )
201 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
202 $ WORK( * ), X( * ), XACT( * )
203* ..
204*
205* =====================================================================
206*
207* .. Parameters ..
208 REAL ONE, ZERO
209 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL RESULT( NTESTS )
231* ..
232* .. External Functions ..
233 REAL CLANGE, SGET06
234 EXTERNAL clange, sget06
235* ..
236* .. External Subroutines ..
237 EXTERNAL alaerh, alahd, alasum, cerrge, cgecon, cgerfs,
238 $ cget01, cget02, cget03, cget04, cget07, cgetrf,
239 $ cgetri, cgetrs, clacpy, clarhs, claset, clatb4,
240 $ clatms, xlaenv
241* ..
242* .. Intrinsic Functions ..
243 INTRINSIC cmplx, 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 ) = 'Complex 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 cerrge( 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 CLATB4 and generate a test matrix
308* with CLATMS.
309*
310 CALL clatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
311 $ CNDNUM, DIST )
312*
313 srnamt = 'CLATMS'
314 CALL clatms( 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 CLATMS.
319*
320 IF( info.NE.0 ) THEN
321 CALL alaerh( path, 'CLATMS', 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 claset( 'Full', m, n-izero+1, cmplx( zero ),
344 $ cmplx( 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 = CLANGE( 'O', M, N, A, LDA, RWORK )
354* ANORMI = CLANGE( '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 clacpy( 'Full', m, n, a, lda, afac, lda )
365 srnamt = 'CGETRF'
366 CALL cgetrf( m, n, afac, lda, iwork, info )
367*
368* Check error code from CGETRF.
369*
370 IF( info.NE.izero )
371 $ CALL alaerh( path, 'CGETRF', 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 clacpy( 'Full', m, n, afac, lda, ainv, lda )
380 CALL cget01( 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 clacpy( 'Full', n, n, afac, lda, ainv, lda )
390 srnamt = 'CGETRI'
391 nrhs = nsval( 1 )
392 lwork = nmax*max( 3, nrhs )
393 CALL cgetri( n, ainv, lda, iwork, work, lwork,
394 $ info )
395*
396* Check error code from CGETRI.
397*
398 IF( info.NE.0 )
399 $ CALL alaerh( path, 'CGETRI', 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 cget03( n, a, lda, ainv, lda, work, lda,
408 $ rwork, rcondo, result( 2 ) )
409 anormo = clange( 'O', m, n, a, lda, rwork )
410*
411* Compute the infinity-norm condition number of A.
412*
413 anormi = clange( 'I', m, n, a, lda, rwork )
414 ainvnm = clange( '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 = clange( 'O', m, n, a, lda, rwork )
427 anormi = clange( '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 = 'CLARHS'
471 CALL clarhs( path, xtype, ' ', trans, n, n, kl,
472 $ ku, nrhs, a, lda, xact, lda, b,
473 $ lda, iseed, info )
474 xtype = 'C'
475*
476 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
477 srnamt = 'CGETRS'
478 CALL cgetrs( trans, n, nrhs, afac, lda, iwork,
479 $ x, lda, info )
480*
481* Check error code from CGETRS.
482*
483 IF( info.NE.0 )
484 $ CALL alaerh( path, 'CGETRS', info, 0, trans,
485 $ n, n, -1, -1, nrhs, imat, nfail,
486 $ nerrs, nout )
487*
488 CALL clacpy( 'Full', n, nrhs, b, lda, work,
489 $ lda )
490 CALL cget02( 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 cget04( 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 = 'CGERFS'
504 CALL cgerfs( 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 CGERFS.
510*
511 IF( info.NE.0 )
512 $ CALL alaerh( path, 'CGERFS', info, 0, trans,
513 $ n, n, -1, -1, nrhs, imat, nfail,
514 $ nerrs, nout )
515*
516 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
517 $ result( 5 ) )
518 CALL cget07( 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 = 'CGECON'
553 CALL cgecon( norm, n, afac, lda, anorm, rcond,
554 $ work, rwork, info )
555*
556* Check error code from CGECON.
557*
558 IF( info.NE.0 )
559 $ CALL alaerh( path, 'CGECON', 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 ) = sget06( 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 CCHKGE
600*
cgetrs
subroutine cgetrs(trans, n, nrhs, a, lda, ipiv, b, ldb, info)
CGETRS
Definition cgetrs.f:121
cgetrf
subroutine cgetrf(m, n, a, lda, ipiv, info)
CGETRF
Definition cgetrf.f:108
cgetri
subroutine cgetri(n, a, lda, ipiv, work, lwork, info)
CGETRI
Definition cgetri.f:114
cgecon
subroutine cgecon(norm, n, a, lda, anorm, rcond, work, rwork, info)
CGECON
Definition cgecon.f:124
cgerfs
subroutine cgerfs(trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CGERFS
Definition cgerfs.f:186
cget02
subroutine cget02(trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
CGET02
Definition cget02.f:134
cget01
subroutine cget01(m, n, a, lda, afac, ldafac, ipiv, rwork, resid)
CGET01
Definition cget01.f:108
cget07
subroutine cget07(trans, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, chkferr, berr, reslts)
CGET07
Definition cget07.f:166
cget03
subroutine cget03(n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
CGET03
Definition cget03.f:110

◆ cchkgt()

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

CCHKGT

Purpose:
!>
!> CCHKGT tests CGTTRF, -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 REAL
!>          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 array, dimension (NMAX*4)
!>
[out]AF
!>          AF is COMPLEX array, dimension (NMAX*4)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchkgt.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 REAL THRESH
156* ..
157* .. Array Arguments ..
158 LOGICAL DOTYPE( * )
159 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
160 REAL RWORK( * )
161 COMPLEX A( * ), AF( * ), B( * ), WORK( * ), X( * ),
162 $ XACT( * )
163* ..
164*
165* =====================================================================
166*
167* .. Parameters ..
168 REAL ONE, ZERO
169 parameter( one = 1.0e+0, zero = 0.0e+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 REAL AINVNM, ANORM, COND, RCOND, RCONDC, RCONDI,
183 $ RCONDO
184* ..
185* .. Local Arrays ..
186 CHARACTER TRANSS( 3 )
187 INTEGER ISEED( 4 ), ISEEDY( 4 )
188 REAL RESULT( NTESTS )
189 COMPLEX Z( 3 )
190* ..
191* .. External Functions ..
192 REAL CLANGT, SCASUM, SGET06
193 EXTERNAL clangt, scasum, sget06
194* ..
195* .. External Subroutines ..
196 EXTERNAL alaerh, alahd, alasum, ccopy, cerrge, cget04,
197 $ cgtcon, cgtrfs, cgtt01, cgtt02, cgtt05, cgttrf,
198 $ cgttrs, clacpy, clagtm, clarnv, clatb4, clatms,
199 $ csscal
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 ) = 'Complex 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 cerrge( 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 CLATB4.
253*
254 CALL clatb4( 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 = 'CLATMS'
264 CALL clatms( 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 CLATMS.
269*
270 IF( info.NE.0 ) THEN
271 CALL alaerh( path, 'CLATMS', 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 ccopy( n-1, af( 4 ), 3, a, 1 )
279 CALL ccopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
280 END IF
281 CALL ccopy( 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 clarnv( 2, iseed, n+2*m, a )
293 IF( anorm.NE.one )
294 $ CALL csscal( 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 ccopy( n+2*m, a, 1, af, 1 )
349 srnamt = 'CGTTRF'
350 CALL cgttrf( n, af, af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
351 $ iwork, info )
352*
353* Check error code from CGTTRF.
354*
355 IF( info.NE.izero )
356 $ CALL alaerh( path, 'CGTTRF', info, izero, ' ', n, n, 1,
357 $ 1, -1, imat, nfail, nerrs, nout )
358 trfcon = info.NE.0
359*
360 CALL cgtt01( 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 = clangt( norm, n, a, a( m+1 ), a( n+m+1 ) )
382*
383 IF( .NOT.trfcon ) THEN
384*
385* Use CGTTRS 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 cgttrs( 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, scasum( 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 = 'CGTCON'
421 CALL cgtcon( 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 CGTCON.
426*
427 IF( info.NE.0 )
428 $ CALL alaerh( path, 'CGTCON', info, 0, norm, n, n, -1,
429 $ -1, -1, imat, nfail, nerrs, nout )
430*
431 result( 7 ) = sget06( 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 clarnv( 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 clagtm( trans, n, nrhs, one, a,
472 $ a( m+1 ), a( n+m+1 ), xact, lda,
473 $ zero, b, lda )
474*
475*+ TEST 2
476* Solve op(A) * X = B and compute the residual.
477*
478 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
479 srnamt = 'CGTTRS'
480 CALL cgttrs( trans, n, nrhs, af, af( m+1 ),
481 $ af( n+m+1 ), af( n+2*m+1 ), iwork, x,
482 $ lda, info )
483*
484* Check error code from CGTTRS.
485*
486 IF( info.NE.0 )
487 $ CALL alaerh( path, 'CGTTRS', info, 0, trans, n, n,
488 $ -1, -1, nrhs, imat, nfail, nerrs,
489 $ nout )
490*
491 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
492 CALL cgtt02( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
493 $ x, lda, work, lda, result( 2 ) )
494*
495*+ TEST 3
496* Check solution from generated exact solution.
497*
498 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
499 $ result( 3 ) )
500*
501*+ TESTS 4, 5, and 6
502* Use iterative refinement to improve the solution.
503*
504 srnamt = 'CGTRFS'
505 CALL cgtrfs( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
506 $ af, af( m+1 ), af( n+m+1 ),
507 $ af( n+2*m+1 ), iwork, b, lda, x, lda,
508 $ rwork, rwork( nrhs+1 ), work,
509 $ rwork( 2*nrhs+1 ), info )
510*
511* Check error code from CGTRFS.
512*
513 IF( info.NE.0 )
514 $ CALL alaerh( path, 'CGTRFS', info, 0, trans, n, n,
515 $ -1, -1, nrhs, imat, nfail, nerrs,
516 $ nout )
517*
518 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
519 $ result( 4 ) )
520 CALL cgtt05( trans, n, nrhs, a, a( m+1 ), a( n+m+1 ),
521 $ b, lda, x, lda, xact, lda, rwork,
522 $ rwork( nrhs+1 ), result( 5 ) )
523*
524* Print information about the tests that did not pass the
525* threshold.
526*
527 DO 70 k = 2, 6
528 IF( result( k ).GE.thresh ) THEN
529 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
530 $ CALL alahd( nout, path )
531 WRITE( nout, fmt = 9998 )trans, n, nrhs, imat,
532 $ k, result( k )
533 nfail = nfail + 1
534 END IF
535 70 CONTINUE
536 nrun = nrun + 5
537 80 CONTINUE
538 90 CONTINUE
539 100 CONTINUE
540 110 CONTINUE
541*
542* Print a summary of the results.
543*
544 CALL alasum( path, nout, nfail, nrun, nerrs )
545*
546 9999 FORMAT( 12x, 'N =', i5, ',', 10x, ' type ', i2, ', test(', i2,
547 $ ') = ', g12.5 )
548 9998 FORMAT( ' TRANS=''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
549 $ i2, ', test(', i2, ') = ', g12.5 )
550 9997 FORMAT( ' NORM =''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
551 $ ', test(', i2, ') = ', g12.5 )
552 RETURN
553*
554* End of CCHKGT
555*
cgttrf
subroutine cgttrf(n, dl, d, du, du2, ipiv, info)
CGTTRF
Definition cgttrf.f:124
cgttrs
subroutine cgttrs(trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb, info)
CGTTRS
Definition cgttrs.f:138
cgtcon
subroutine cgtcon(norm, n, dl, d, du, du2, ipiv, anorm, rcond, work, info)
CGTCON
Definition cgtcon.f:141
cgtrfs
subroutine cgtrfs(trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CGTRFS
Definition cgtrfs.f:210
clagtm
subroutine clagtm(trans, n, nrhs, alpha, dl, d, du, x, ldx, beta, b, ldb)
CLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix,...
Definition clagtm.f:145
clarnv
subroutine clarnv(idist, iseed, n, x)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition clarnv.f:99
clangt
real function clangt(norm, n, dl, d, du)
CLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition clangt.f:106
csscal
subroutine csscal(n, sa, cx, incx)
CSSCAL
Definition csscal.f:78
cgtt01
subroutine cgtt01(n, dl, d, du, dlf, df, duf, du2, ipiv, work, ldwork, rwork, resid)
CGTT01
Definition cgtt01.f:134
cgtt02
subroutine cgtt02(trans, n, nrhs, dl, d, du, x, ldx, b, ldb, resid)
CGTT02
Definition cgtt02.f:124
cgtt05
subroutine cgtt05(trans, n, nrhs, dl, d, du, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
CGTT05
Definition cgtt05.f:165
scasum
real function scasum(n, cx, incx)
SCASUM
Definition scasum.f:72

◆ cchkhe()

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

CCHKHE

Purpose:
!>
!> CCHKHE tests CHETRF, -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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchkhe.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 REAL THRESH
180* ..
181* .. Array Arguments ..
182 LOGICAL DOTYPE( * )
183 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
184 REAL RWORK( * )
185 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
186 $ WORK( * ), X( * ), XACT( * )
187* ..
188*
189* =====================================================================
190*
191* .. Parameters ..
192 REAL ZERO
193 parameter( zero = 0.0e+0 )
194 COMPLEX CZERO
195 parameter( czero = ( 0.0e+0, 0.0e+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 REAL ANORM, CNDNUM, RCOND, RCONDC
209* ..
210* .. Local Arrays ..
211 CHARACTER UPLOS( 2 )
212 INTEGER ISEED( 4 ), ISEEDY( 4 )
213 REAL RESULT( NTESTS )
214* ..
215* .. External Functions ..
216 REAL CLANHE, SGET06
217 EXTERNAL clanhe, sget06
218* ..
219* .. External Subroutines ..
220 EXTERNAL alaerh, alahd, alasum, cerrhe, cget04, checon,
221 $ cherfs, chet01, chetrf, chetri2, chetrs,
222 $ clacpy, claipd, clarhs, clatb4, clatms, cpot02,
223 $ cpot03, cpot05, xlaenv
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 ) = 'Complex 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 cerrhe( 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*
300* Set up parameters with CLATB4 for the matrix generator
301* based on the type of matrix to be generated.
302*
303 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
304 $ CNDNUM, DIST )
305*
306* Generate a matrix with CLATMS.
307*
308 srnamt = 'CLATMS'
309 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
310 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
311 $ INFO )
312*
313* Check error code from CLATMS and handle error.
314*
315 IF( info.NE.0 ) THEN
316 CALL alaerh( path, 'CLATMS', info, 0, uplo, n, n, -1,
317 $ -1, -1, imat, nfail, nerrs, nout )
318*
319* Skip all tests for this generated matrix
320*
321 GO TO 160
322 END IF
323*
324* For matrix types 3-6, zero one or more rows and
325* columns of the matrix to test that INFO is returned
326* correctly.
327*
328 IF( zerot ) THEN
329 IF( imat.EQ.3 ) THEN
330 izero = 1
331 ELSE IF( imat.EQ.4 ) THEN
332 izero = n
333 ELSE
334 izero = n / 2 + 1
335 END IF
336*
337 IF( imat.LT.6 ) THEN
338*
339* Set row and column IZERO to zero.
340*
341 IF( iuplo.EQ.1 ) THEN
342 ioff = ( izero-1 )*lda
343 DO 20 i = 1, izero - 1
344 a( ioff+i ) = czero
345 20 CONTINUE
346 ioff = ioff + izero
347 DO 30 i = izero, n
348 a( ioff ) = czero
349 ioff = ioff + lda
350 30 CONTINUE
351 ELSE
352 ioff = izero
353 DO 40 i = 1, izero - 1
354 a( ioff ) = czero
355 ioff = ioff + lda
356 40 CONTINUE
357 ioff = ioff - izero
358 DO 50 i = izero, n
359 a( ioff+i ) = czero
360 50 CONTINUE
361 END IF
362 ELSE
363 IF( iuplo.EQ.1 ) THEN
364*
365* Set the first IZERO rows and columns to zero.
366*
367 ioff = 0
368 DO 70 j = 1, n
369 i2 = min( j, izero )
370 DO 60 i = 1, i2
371 a( ioff+i ) = czero
372 60 CONTINUE
373 ioff = ioff + lda
374 70 CONTINUE
375 ELSE
376*
377* Set the last IZERO rows and columns to zero.
378*
379 ioff = 0
380 DO 90 j = 1, n
381 i1 = max( j, izero )
382 DO 80 i = i1, n
383 a( ioff+i ) = czero
384 80 CONTINUE
385 ioff = ioff + lda
386 90 CONTINUE
387 END IF
388 END IF
389 ELSE
390 izero = 0
391 END IF
392*
393* Set the imaginary part of the diagonals.
394*
395 CALL claipd( n, a, lda+1, 0 )
396*
397* End generate test matrix A.
398*
399*
400* Do for each value of NB in NBVAL
401*
402 DO 150 inb = 1, nnb
403*
404* Set the optimal blocksize, which will be later
405* returned by ILAENV.
406*
407 nb = nbval( inb )
408 CALL xlaenv( 1, nb )
409*
410* Copy the test matrix A into matrix AFAC which
411* will be factorized in place. This is needed to
412* preserve the test matrix A for subsequent tests.
413*
414 CALL clacpy( uplo, n, n, a, lda, afac, lda )
415*
416* Compute the L*D*L**T or U*D*U**T factorization of the
417* matrix. IWORK stores details of the interchanges and
418* the block structure of D. AINV is a work array for
419* block factorization, LWORK is the length of AINV.
420*
421 lwork = max( 2, nb )*lda
422 srnamt = 'CHETRF'
423 CALL chetrf( uplo, n, afac, lda, iwork, ainv, lwork,
424 $ info )
425*
426* Adjust the expected value of INFO to account for
427* pivoting.
428*
429 k = izero
430 IF( k.GT.0 ) THEN
431 100 CONTINUE
432 IF( iwork( k ).LT.0 ) THEN
433 IF( iwork( k ).NE.-k ) THEN
434 k = -iwork( k )
435 GO TO 100
436 END IF
437 ELSE IF( iwork( k ).NE.k ) THEN
438 k = iwork( k )
439 GO TO 100
440 END IF
441 END IF
442*
443* Check error code from CHETRF and handle error.
444*
445 IF( info.NE.k )
446 $ CALL alaerh( path, 'CHETRF', info, k, uplo, n, n,
447 $ -1, -1, nb, imat, nfail, nerrs, nout )
448*
449* Set the condition estimate flag if the INFO is not 0.
450*
451 IF( info.NE.0 ) THEN
452 trfcon = .true.
453 ELSE
454 trfcon = .false.
455 END IF
456*
457*+ TEST 1
458* Reconstruct matrix from factors and compute residual.
459*
460 CALL chet01( uplo, n, a, lda, afac, lda, iwork, ainv,
461 $ lda, rwork, result( 1 ) )
462 nt = 1
463*
464*+ TEST 2
465* Form the inverse and compute the residual,
466* if the factorization was competed without INFO > 0
467* (i.e. there is no zero rows and columns).
468* Do it only for the first block size.
469*
470 IF( inb.EQ.1 .AND. .NOT.trfcon ) THEN
471 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
472 srnamt = 'CHETRI2'
473 lwork = (n+nb+1)*(nb+3)
474 CALL chetri2( uplo, n, ainv, lda, iwork, work,
475 $ lwork, info )
476*
477* Check error code from CHETRI2 and handle error.
478*
479 IF( info.NE.0 )
480 $ CALL alaerh( path, 'CHETRI2', info, -1, uplo, n,
481 $ n, -1, -1, -1, imat, nfail, nerrs,
482 $ nout )
483*
484* Compute the residual for a symmetric matrix times
485* its inverse.
486*
487 CALL cpot03( uplo, n, a, lda, ainv, lda, work, lda,
488 $ rwork, rcondc, result( 2 ) )
489 nt = 2
490 END IF
491*
492* Print information about the tests that did not pass
493* the threshold.
494*
495 DO 110 k = 1, nt
496 IF( result( k ).GE.thresh ) THEN
497 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
498 $ CALL alahd( nout, path )
499 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
500 $ result( k )
501 nfail = nfail + 1
502 END IF
503 110 CONTINUE
504 nrun = nrun + nt
505*
506* Skip the other tests if this is not the first block
507* size.
508*
509 IF( inb.GT.1 )
510 $ GO TO 150
511*
512* Do only the condition estimate if INFO is not 0.
513*
514 IF( trfcon ) THEN
515 rcondc = zero
516 GO TO 140
517 END IF
518*
519* Do for each value of NRHS in NSVAL.
520*
521 DO 130 irhs = 1, nns
522 nrhs = nsval( irhs )
523*
524*+ TEST 3 (Using TRS)
525* Solve and compute residual for A * X = B.
526*
527* Choose a set of NRHS random solution vectors
528* stored in XACT and set up the right hand side B
529*
530 srnamt = 'CLARHS'
531 CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
532 $ nrhs, a, lda, xact, lda, b, lda,
533 $ iseed, info )
534 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
535*
536 srnamt = 'CHETRS'
537 CALL chetrs( uplo, n, nrhs, afac, lda, iwork, x,
538 $ lda, info )
539*
540* Check error code from CHETRS and handle error.
541*
542 IF( info.NE.0 )
543 $ CALL alaerh( path, 'CHETRS', info, 0, uplo, n,
544 $ n, -1, -1, nrhs, imat, nfail,
545 $ nerrs, nout )
546*
547 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
548*
549* Compute the residual for the solution
550*
551 CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
552 $ lda, rwork, result( 3 ) )
553*
554*+ TEST 4 (Using TRS2)
555* Solve and compute residual for A * X = B.
556*
557* Choose a set of NRHS random solution vectors
558* stored in XACT and set up the right hand side B
559*
560 srnamt = 'CLARHS'
561 CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
562 $ nrhs, a, lda, xact, lda, b, lda,
563 $ iseed, info )
564 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
565*
566 srnamt = 'CHETRS2'
567 CALL chetrs2( uplo, n, nrhs, afac, lda, iwork, x,
568 $ lda, work, info )
569*
570* Check error code from CHETRS2 and handle error.
571*
572 IF( info.NE.0 )
573 $ CALL alaerh( path, 'CHETRS2', info, 0, uplo, n,
574 $ n, -1, -1, nrhs, imat, nfail,
575 $ nerrs, nout )
576*
577 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
578*
579* Compute the residual for the solution
580*
581 CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
582 $ lda, rwork, result( 4 ) )
583*
584*+ TEST 5
585* Check solution from generated exact solution.
586*
587 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
588 $ result( 5 ) )
589*
590*+ TESTS 6, 7, and 8
591* Use iterative refinement to improve the solution.
592*
593 srnamt = 'CHERFS'
594 CALL cherfs( uplo, n, nrhs, a, lda, afac, lda,
595 $ iwork, b, lda, x, lda, rwork,
596 $ rwork( nrhs+1 ), work,
597 $ rwork( 2*nrhs+1 ), info )
598*
599* Check error code from CHERFS and handle error.
600*
601 IF( info.NE.0 )
602 $ CALL alaerh( path, 'CHERFS', info, 0, uplo, n,
603 $ n, -1, -1, nrhs, imat, nfail,
604 $ nerrs, nout )
605*
606 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
607 $ result( 6 ) )
608 CALL cpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
609 $ xact, lda, rwork, rwork( nrhs+1 ),
610 $ result( 7 ) )
611*
612* Print information about the tests that did not pass
613* the threshold.
614*
615 DO 120 k = 3, 8
616 IF( result( k ).GE.thresh ) THEN
617 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
618 $ CALL alahd( nout, path )
619 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
620 $ imat, k, result( k )
621 nfail = nfail + 1
622 END IF
623 120 CONTINUE
624 nrun = nrun + 6
625*
626* End do for each value of NRHS in NSVAL.
627*
628 130 CONTINUE
629*
630*+ TEST 9
631* Get an estimate of RCOND = 1/CNDNUM.
632*
633 140 CONTINUE
634 anorm = clanhe( '1', uplo, n, a, lda, rwork )
635 srnamt = 'CHECON'
636 CALL checon( uplo, n, afac, lda, iwork, anorm, rcond,
637 $ work, info )
638*
639* Check error code from CHECON and handle error.
640*
641 IF( info.NE.0 )
642 $ CALL alaerh( path, 'CHECON', info, 0, uplo, n, n,
643 $ -1, -1, -1, imat, nfail, nerrs, nout )
644*
645* Compute the test ratio to compare values of RCOND
646*
647 result( 9 ) = sget06( rcond, rcondc )
648*
649* Print information about the tests that did not pass
650* the threshold.
651*
652 IF( result( 9 ).GE.thresh ) THEN
653 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
654 $ CALL alahd( nout, path )
655 WRITE( nout, fmt = 9997 )uplo, n, imat, 8,
656 $ result( 9 )
657 nfail = nfail + 1
658 END IF
659 nrun = nrun + 1
660 150 CONTINUE
661 160 CONTINUE
662 170 CONTINUE
663 180 CONTINUE
664*
665* Print a summary of the results.
666*
667 CALL alasum( path, nout, nfail, nrun, nerrs )
668*
669 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
670 $ i2, ', test ', i2, ', ratio =', g12.5 )
671 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
672 $ i2, ', test(', i2, ') =', g12.5 )
673 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
674 $ ', test(', i2, ') =', g12.5 )
675 RETURN
676*
677* End of CCHKHE
678*
clanhe
real function clanhe(norm, uplo, n, a, lda, work)
CLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clanhe.f:124
chetrs
subroutine chetrs(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
CHETRS
Definition chetrs.f:120
checon
subroutine checon(uplo, n, a, lda, ipiv, anorm, rcond, work, info)
CHECON
Definition checon.f:125
chetri2
subroutine chetri2(uplo, n, a, lda, ipiv, work, lwork, info)
CHETRI2
Definition chetri2.f:127
chetrf
subroutine chetrf(uplo, n, a, lda, ipiv, work, lwork, info)
CHETRF
Definition chetrf.f:177
chetrs2
subroutine chetrs2(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, info)
CHETRS2
Definition chetrs2.f:127
cherfs
subroutine cherfs(uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CHERFS
Definition cherfs.f:192
claipd
subroutine claipd(n, a, inda, vinda)
CLAIPD
Definition claipd.f:83
chet01
subroutine chet01(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
CHET01
Definition chet01.f:126
cerrhe
subroutine cerrhe(path, nunit)
CERRHE
Definition cerrhe.f:55
cpot05
subroutine cpot05(uplo, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
CPOT05
Definition cpot05.f:165
cpot03
subroutine cpot03(uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
CPOT03
Definition cpot03.f:126
cpot02
subroutine cpot02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
CPOT02
Definition cpot02.f:127

◆ cchkhe_aa()

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

CCHKHE_AA

Purpose:
!>
!> CCHKHE_AA tests CHETRF_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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchkhe_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 REAL THRESH
182* ..
183* .. Array Arguments ..
184 LOGICAL DOTYPE( * )
185 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
186 REAL RWORK( * )
187 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
188 $ WORK( * ), X( * ), XACT( * )
189* ..
190*
191* =====================================================================
192*
193* .. Parameters ..
194 REAL ZERO
195 parameter( zero = 0.0e+0 )
196 COMPLEX CZERO
197 parameter( czero = ( 0.0e+0, 0.0e+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 REAL ANORM, CNDNUM
211* ..
212* .. Local Arrays ..
213 CHARACTER UPLOS( 2 )
214 INTEGER ISEED( 4 ), ISEEDY( 4 )
215 REAL RESULT( NTESTS )
216* ..
217* .. External Subroutines ..
218 EXTERNAL alaerh, alahd, alasum, xlaenv, cerrhe, chet01_aa,
219 $ chetrf_aa, chetrs_aa, clacpy, claipd, clarhs,
220 $ clatb4, clatms, cpot02
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*
243* Test path
244*
245 path( 1: 1 ) = 'Complex precision'
246 path( 2: 3 ) = 'HA'
247*
248* Path to generate matrices
249*
250 matpath( 1: 1 ) = 'Complex 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 cerrhe( 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 DO 170 imat = 1, nimat
287*
288* Do the tests only if DOTYPE( IMAT ) is true.
289*
290 IF( .NOT.dotype( imat ) )
291 $ GO TO 170
292*
293* Skip types 3, 4, 5, or 6 if the matrix size is too small.
294*
295 zerot = imat.GE.3 .AND. imat.LE.6
296 IF( zerot .AND. n.LT.imat-2 )
297 $ GO TO 170
298*
299* Do first for UPLO = 'U', then for UPLO = 'L'
300*
301 DO 160 iuplo = 1, 2
302 uplo = uplos( iuplo )
303*
304* Set up parameters with CLATB4 for the matrix generator
305* based on the type of matrix to be generated.
306*
307 CALL clatb4( matpath, imat, n, n, TYPE, KL, KU,
308 $ ANORM, MODE, CNDNUM, DIST )
309*
310* Generate a matrix with CLATMS.
311*
312 srnamt = 'CLATMS'
313 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
314 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
315 $ INFO )
316*
317* Check error code from CLATMS and handle error.
318*
319 IF( info.NE.0 ) THEN
320 CALL alaerh( path, 'CLATMS', info, 0, uplo, n, n, -1,
321 $ -1, -1, imat, nfail, nerrs, nout )
322*
323* Skip all tests for this generated matrix
324*
325 GO TO 160
326 END IF
327*
328* For types 3-6, zero one or more rows and columns of
329* the matrix to test that INFO is returned correctly.
330*
331 IF( zerot ) THEN
332 IF( imat.EQ.3 ) THEN
333 izero = 1
334 ELSE IF( imat.EQ.4 ) THEN
335 izero = n
336 ELSE
337 izero = n / 2 + 1
338 END IF
339*
340 IF( imat.LT.6 ) THEN
341*
342* Set row and column IZERO to zero.
343*
344 IF( iuplo.EQ.1 ) THEN
345 ioff = ( izero-1 )*lda
346 DO 20 i = 1, izero - 1
347 a( ioff+i ) = czero
348 20 CONTINUE
349 ioff = ioff + izero
350 DO 30 i = izero, n
351 a( ioff ) = czero
352 ioff = ioff + lda
353 30 CONTINUE
354 ELSE
355 ioff = izero
356 DO 40 i = 1, izero - 1
357 a( ioff ) = czero
358 ioff = ioff + lda
359 40 CONTINUE
360 ioff = ioff - izero
361 DO 50 i = izero, n
362 a( ioff+i ) = czero
363 50 CONTINUE
364 END IF
365 ELSE
366 IF( iuplo.EQ.1 ) THEN
367*
368* Set the first IZERO rows and columns to zero.
369*
370 ioff = 0
371 DO 70 j = 1, n
372 i2 = min( j, izero )
373 DO 60 i = 1, i2
374 a( ioff+i ) = czero
375 60 CONTINUE
376 ioff = ioff + lda
377 70 CONTINUE
378 izero = 1
379 ELSE
380*
381* Set the last IZERO rows and columns to zero.
382*
383 ioff = 0
384 DO 90 j = 1, n
385 i1 = max( j, izero )
386 DO 80 i = i1, n
387 a( ioff+i ) = czero
388 80 CONTINUE
389 ioff = ioff + lda
390 90 CONTINUE
391 END IF
392 END IF
393 ELSE
394 izero = 0
395 END IF
396*
397* End generate test matrix A.
398*
399*
400* Set the imaginary part of the diagonals.
401*
402 CALL claipd( n, a, lda+1, 0 )
403*
404* Do for each value of NB in NBVAL
405*
406 DO 150 inb = 1, nnb
407*
408* Set the optimal blocksize, which will be later
409* returned by ILAENV.
410*
411 nb = nbval( inb )
412 CALL xlaenv( 1, nb )
413*
414* Copy the test matrix A into matrix AFAC which
415* will be factorized in place. This is needed to
416* preserve the test matrix A for subsequent tests.
417*
418 CALL clacpy( uplo, n, n, a, lda, afac, lda )
419*
420* Compute the L*D*L**T or U*D*U**T factorization of the
421* matrix. IWORK stores details of the interchanges and
422* the block structure of D. AINV is a work array for
423* block factorization, LWORK is the length of AINV.
424*
425 lwork = max( 1, ( nb+1 )*lda )
426 srnamt = 'CHETRF_AA'
427 CALL chetrf_aa( uplo, n, afac, lda, iwork, ainv,
428 $ lwork, info )
429*
430* Adjust the expected value of INFO to account for
431* pivoting.
432*
433c IF( IZERO.GT.0 ) THEN
434c J = 1
435c K = IZERO
436c 100 CONTINUE
437c IF( J.EQ.K ) THEN
438c K = IWORK( J )
439c ELSE IF( IWORK( J ).EQ.K ) THEN
440c K = J
441c END IF
442c IF( J.LT.K ) THEN
443c J = J + 1
444c GO TO 100
445c END IF
446c ELSE
447 k = 0
448c END IF
449*
450* Check error code from CHETRF and handle error.
451*
452 IF( info.NE.k ) THEN
453 CALL alaerh( path, 'CHETRF_AA', info, k, uplo,
454 $ n, n, -1, -1, nb, imat, nfail, nerrs,
455 $ nout )
456 END IF
457*
458*+ TEST 1
459* Reconstruct matrix from factors and compute residual.
460*
461 CALL chet01_aa( uplo, n, a, lda, afac, lda, iwork,
462 $ ainv, lda, rwork, result( 1 ) )
463 nt = 1
464*
465*
466* Print information about the tests that did not pass
467* the threshold.
468*
469 DO 110 k = 1, nt
470 IF( result( k ).GE.thresh ) THEN
471 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
472 $ CALL alahd( nout, path )
473 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
474 $ result( k )
475 nfail = nfail + 1
476 END IF
477 110 CONTINUE
478 nrun = nrun + nt
479*
480* Skip solver test if INFO is not 0.
481*
482 IF( info.NE.0 ) THEN
483 GO TO 140
484 END IF
485*
486* Do for each value of NRHS in NSVAL.
487*
488 DO 130 irhs = 1, nns
489 nrhs = nsval( irhs )
490*
491*+ TEST 2 (Using TRS)
492* Solve and compute residual for A * X = B.
493*
494* Choose a set of NRHS random solution vectors
495* stored in XACT and set up the right hand side B
496*
497 srnamt = 'CLARHS'
498 CALL clarhs( matpath, xtype, uplo, ' ', n, n,
499 $ kl, ku, nrhs, a, lda, xact, lda,
500 $ b, lda, iseed, info )
501 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
502*
503 srnamt = 'CHETRS_AA'
504 lwork = max( 1, 3*n-2 )
505 CALL chetrs_aa( uplo, n, nrhs, afac, lda, iwork,
506 $ x, lda, work, lwork, info )
507*
508* Check error code from CHETRS and handle error.
509*
510 IF( info.NE.0 ) THEN
511 IF( izero.EQ.0 ) THEN
512 CALL alaerh( path, 'CHETRS_AA', info, 0,
513 $ uplo, n, n, -1, -1, nrhs, imat,
514 $ nfail, nerrs, nout )
515 END IF
516 ELSE
517 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda
518 $ )
519*
520* Compute the residual for the solution
521*
522 CALL cpot02( 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 )
557 9995 FORMAT( ' Invalid input value: ', a4, '=', i6, '; must be <=',
558 $ i6 )
559 RETURN
560*
561* End of CCHKHE_AA
562*
chetrs_aa
subroutine chetrs_aa(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
CHETRS_AA
Definition chetrs_aa.f:131
chetrf_aa
subroutine chetrf_aa(uplo, n, a, lda, ipiv, work, lwork, info)
CHETRF_AA
Definition chetrf_aa.f:132
chet01_aa
subroutine chet01_aa(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
CHET01_AA
Definition chet01_aa.f:124

◆ cchkhe_aa_2stage()

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

CCHKHE_AA_2STAGE

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

◆ cchkhe_rk()

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

CCHKHE_RK

Purpose:
!>
!> CCHKHE_RK tests CHETRF_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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]E
!>          E is COMPLEX array, dimension (NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchkhe_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 REAL THRESH
186* ..
187* .. Array Arguments ..
188 LOGICAL DOTYPE( * )
189 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
190 REAL RWORK( * )
191 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
192 $ WORK( * ), X( * ), XACT( * )
193* ..
194*
195* =====================================================================
196*
197* .. Parameters ..
198 REAL ZERO, ONE
199 parameter( zero = 0.0e+0, one = 1.0e+0 )
200 REAL ONEHALF
201 parameter( onehalf = 0.5e+0 )
202 REAL EIGHT, SEVTEN
203 parameter( eight = 8.0e+0, sevten = 17.0e+0 )
204 COMPLEX CZERO
205 parameter( czero = ( 0.0e+0, 0.0e+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 REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
220 $ SING_MIN, RCOND, RCONDC, STEMP
221* ..
222* .. Local Arrays ..
223 CHARACTER UPLOS( 2 )
224 INTEGER ISEED( 4 ), ISEEDY( 4 ), IDUMMY( 1 )
225 REAL RESULT( NTESTS )
226 COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 )
227* ..
228* .. External Functions ..
229 REAL CLANGE, CLANHE, SGET06
230 EXTERNAL clange, clanhe, sget06
231* ..
232* .. External Subroutines ..
233 EXTERNAL alaerh, alahd, alasum, cerrhe, cgesvd, cget04,
234 $ clacpy, clarhs, clatb4, clatms, cpot02, cpot03,
235 $ checon_3, chet01_3, chetrf_rk, chetri_3,
236 $ chetrs_3, xlaenv
237* ..
238* .. Intrinsic Functions ..
239 INTRINSIC conjg, 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 ) = 'Complex precision'
263 path( 2: 3 ) = 'HK'
264*
265* Path to generate matrices
266*
267 matpath( 1: 1 ) = 'Complex 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 cerrhe( 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 CLATB4 for the matrix generator
323* based on the type of matrix to be generated.
324*
325 CALL clatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
326 $ MODE, CNDNUM, DIST )
327*
328* Generate a matrix with CLATMS.
329*
330 srnamt = 'CLATMS'
331 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
332 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
333 $ WORK, INFO )
334*
335* Check error code from CLATMS and handle error.
336*
337 IF( info.NE.0 ) THEN
338 CALL alaerh( path, 'CLATMS', 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 clacpy( 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 = 'CHETRF_RK'
441 CALL chetrf_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 CHETRF_RK and handle error.
462*
463 IF( info.NE.k)
464 $ CALL alaerh( path, 'CHETRF_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 chet01_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 clacpy( uplo, n, n, afac, lda, ainv, lda )
491 srnamt = 'CHETRI_3'
492*
493* Another reason that we need to compute the inverse
494* is that CPOT03 produces RCONDC which is used later
495* in TEST6 and TEST7.
496*
497 lwork = (n+nb+1)*(nb+3)
498 CALL chetri_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, 'CHETRI_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 cpot03( 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 stemp = 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 stemp = clange( '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 stemp = clange( 'M', k-2, 2,
561 $ afac( ( k-2 )*lda+1 ), lda, rwork )
562 k = k - 1
563*
564 END IF
565*
566* STEMP should be bounded by CONST
567*
568 stemp = stemp - const + thresh
569 IF( stemp.GT.result( 3 ) )
570 $ result( 3 ) = stemp
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 stemp = clange( '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 stemp = clange( 'M', n-k-1, 2,
599 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
600 k = k + 1
601*
602 END IF
603*
604* STEMP should be bounded by CONST
605*
606 stemp = stemp - const + thresh
607 IF( stemp.GT.result( 3 ) )
608 $ result( 3 ) = stemp
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 stemp = zero
623*
624 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) )*
625 $ ( ( one + alpha ) / ( one - alpha ) )
626 CALL clacpy( 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 ) = conjg( block( 1, 2 ) )
646 block( 2, 2 ) = afac( (k-1)*lda+k )
647*
648 CALL cgesvd( 'N', 'N', 2, 2, block, 2, rwork,
649 $ cdummy, 1, cdummy, 1,
650 $ work, 6, rwork( 3 ), info )
651*
652*
653 sing_max = rwork( 1 )
654 sing_min = rwork( 2 )
655*
656 stemp = sing_max / sing_min
657*
658* STEMP should be bounded by CONST
659*
660 stemp = stemp - const + thresh
661 IF( stemp.GT.result( 4 ) )
662 $ result( 4 ) = stemp
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 ) = conjg( block( 2, 1 ) )
690 block( 2, 2 ) = afac( k*lda+k+1 )
691*
692 CALL cgesvd( 'N', 'N', 2, 2, block, 2, rwork,
693 $ cdummy, 1, cdummy, 1,
694 $ work, 6, rwork(3), info )
695*
696 sing_max = rwork( 1 )
697 sing_min = rwork( 2 )
698*
699 stemp = sing_max / sing_min
700*
701* STEMP should be bounded by CONST
702*
703 stemp = stemp - const + thresh
704 IF( stemp.GT.result( 4 ) )
705 $ result( 4 ) = stemp
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 = 'CLARHS'
758 CALL clarhs( matpath, xtype, uplo, ' ', n, n,
759 $ kl, ku, nrhs, a, lda, xact, lda,
760 $ b, lda, iseed, info )
761 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
762*
763 srnamt = 'CHETRS_3'
764 CALL chetrs_3( uplo, n, nrhs, afac, lda, e, iwork,
765 $ x, lda, info )
766*
767* Check error code from CHETRS_3 and handle error.
768*
769 IF( info.NE.0 )
770 $ CALL alaerh( path, 'CHETRS_3', info, 0,
771 $ uplo, n, n, -1, -1, nrhs, imat,
772 $ nfail, nerrs, nout )
773*
774 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
775*
776* Compute the residual for the solution
777*
778 CALL cpot02( 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 cget04( 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 = clanhe( '1', uplo, n, a, lda, rwork )
810 srnamt = 'CHECON_3'
811 CALL checon_3( uplo, n, afac, lda, e, iwork, anorm,
812 $ rcond, work, info )
813*
814* Check error code from CHECON_3 and handle error.
815*
816 IF( info.NE.0 )
817 $ CALL alaerh( path, 'CHECON_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 ) = sget06( 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 CCHKHE_RK
855*
alpha
#define alpha
Definition eval.h:35
cgesvd
subroutine cgesvd(jobu, jobvt, m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, rwork, info)
CGESVD computes the singular value decomposition (SVD) for GE matrices
Definition cgesvd.f:214
checon_3
subroutine checon_3(uplo, n, a, lda, e, ipiv, anorm, rcond, work, info)
CHECON_3
Definition checon_3.f:166
chetrs_3
subroutine chetrs_3(uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info)
CHETRS_3
Definition chetrs_3.f:165
chetri_3
subroutine chetri_3(uplo, n, a, lda, e, ipiv, work, lwork, info)
CHETRI_3
Definition chetri_3.f:170
chetrf_rk
subroutine chetrf_rk(uplo, n, a, lda, e, ipiv, work, lwork, info)
CHETRF_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch...
Definition chetrf_rk.f:259
chet01_3
subroutine chet01_3(uplo, n, a, lda, afac, ldafac, e, ipiv, c, ldc, rwork, resid)
CHET01_3
Definition chet01_3.f:141

◆ cchkhe_rook()

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

CCHKHE_ROOK

Purpose:
!>
!> CCHKHE_ROOK tests CHETRF_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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchkhe_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 REAL THRESH
181* ..
182* .. Array Arguments ..
183 LOGICAL DOTYPE( * )
184 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
185 REAL RWORK( * )
186 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
187 $ WORK( * ), X( * ), XACT( * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 REAL ZERO, ONE
194 parameter( zero = 0.0e+0, one = 1.0e+0 )
195 REAL ONEHALF
196 parameter( onehalf = 0.5e+0 )
197 REAL EIGHT, SEVTEN
198 parameter( eight = 8.0e+0, sevten = 17.0e+0 )
199 COMPLEX CZERO
200 parameter( czero = ( 0.0e+0, 0.0e+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 REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
214 $ SING_MIN, RCOND, RCONDC, STEMP
215* ..
216* .. Local Arrays ..
217 CHARACTER UPLOS( 2 )
218 INTEGER ISEED( 4 ), ISEEDY( 4 )
219 REAL RESULT( NTESTS )
220 COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 )
221* ..
222* .. External Functions ..
223 REAL CLANGE, CLANHE, SGET06
224 EXTERNAL clange, clanhe, sget06
225* ..
226* .. External Subroutines ..
227 EXTERNAL alaerh, alahd, alasum, cerrhe, cgesvd, cget04,
228 $ clacpy, clarhs, clatb4, clatms, cpot02,
229 $ cpot03, checon_rook, chet01_rook, chetrf_rook,
230 $ chetri_rook, chetrs_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 ) = 'Complex precision'
257 path( 2: 3 ) = 'HR'
258*
259* Path to generate matrices
260*
261 matpath( 1: 1 ) = 'Complex 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 cerrhe( 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 CLATB4 for the matrix generator
317* based on the type of matrix to be generated.
318*
319 CALL clatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
320 $ MODE, CNDNUM, DIST )
321*
322* Generate a matrix with CLATMS.
323*
324 srnamt = 'CLATMS'
325 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
326 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
327 $ WORK, INFO )
328*
329* Check error code from CLATMS and handle error.
330*
331 IF( info.NE.0 ) THEN
332 CALL alaerh( path, 'CLATMS', 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 clacpy( 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 = 'CHETRF_ROOK'
435 CALL chetrf_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 CHETRF_ROOK and handle error.
456*
457 IF( info.NE.k)
458 $ CALL alaerh( path, 'CHETRF_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 chet01_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 clacpy( uplo, n, n, afac, lda, ainv, lda )
485 srnamt = 'CHETRI_ROOK'
486 CALL chetri_rook( uplo, n, ainv, lda, iwork, work,
487 $ info )
488*
489* Check error code from CHETRI_ROOK and handle error.
490*
491 IF( info.NE.0 )
492 $ CALL alaerh( path, 'CHETRI_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 cpot03( 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 stemp = 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 stemp = clange( '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 stemp = clange( 'M', k-2, 2,
549 $ afac( ( k-2 )*lda+1 ), lda, rwork )
550 k = k - 1
551*
552 END IF
553*
554* STEMP should be bounded by CONST
555*
556 stemp = stemp - const + thresh
557 IF( stemp.GT.result( 3 ) )
558 $ result( 3 ) = stemp
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 stemp = clange( '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 stemp = clange( 'M', n-k-1, 2,
587 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
588 k = k + 1
589*
590 END IF
591*
592* STEMP should be bounded by CONST
593*
594 stemp = stemp - const + thresh
595 IF( stemp.GT.result( 3 ) )
596 $ result( 3 ) = stemp
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 stemp = zero
611*
612 const = ( ( alpha**2-one ) / ( alpha**2-onehalf ) )*
613 $ ( ( one + alpha ) / ( one - alpha ) )
614 CALL clacpy( 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 cgesvd( 'N', 'N', 2, 2, block, 2, rwork,
637 $ cdummy, 1, cdummy, 1,
638 $ work, 6, rwork( 3 ), info )
639*
640*
641 sing_max = rwork( 1 )
642 sing_min = rwork( 2 )
643*
644 stemp = sing_max / sing_min
645*
646* STEMP should be bounded by CONST
647*
648 stemp = stemp - const + thresh
649 IF( stemp.GT.result( 4 ) )
650 $ result( 4 ) = stemp
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 cgesvd( 'N', 'N', 2, 2, block, 2, rwork,
681 $ cdummy, 1, cdummy, 1,
682 $ work, 6, rwork(3), info )
683*
684 sing_max = rwork( 1 )
685 sing_min = rwork( 2 )
686*
687 stemp = sing_max / sing_min
688*
689* STEMP should be bounded by CONST
690*
691 stemp = stemp - const + thresh
692 IF( stemp.GT.result( 4 ) )
693 $ result( 4 ) = stemp
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 = 'CLARHS'
746 CALL clarhs( matpath, xtype, uplo, ' ', n, n,
747 $ kl, ku, nrhs, a, lda, xact, lda,
748 $ b, lda, iseed, info )
749 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
750*
751 srnamt = 'CHETRS_ROOK'
752 CALL chetrs_rook( uplo, n, nrhs, afac, lda, iwork,
753 $ x, lda, info )
754*
755* Check error code from CHETRS_ROOK and handle error.
756*
757 IF( info.NE.0 )
758 $ CALL alaerh( path, 'CHETRS_ROOK', info, 0,
759 $ uplo, n, n, -1, -1, nrhs, imat,
760 $ nfail, nerrs, nout )
761*
762 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
763*
764* Compute the residual for the solution
765*
766 CALL cpot02( 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 cget04( 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 = clanhe( '1', uplo, n, a, lda, rwork )
798 srnamt = 'CHECON_ROOK'
799 CALL checon_rook( uplo, n, afac, lda, iwork, anorm,
800 $ rcond, work, info )
801*
802* Check error code from CHECON_ROOK and handle error.
803*
804 IF( info.NE.0 )
805 $ CALL alaerh( path, 'CHECON_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 ) = sget06( 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 CCHKHE_ROOK
843*
chetrs_rook
subroutine chetrs_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
CHETRS_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using fac...
Definition chetrs_rook.f:136
checon_rook
subroutine checon_rook(uplo, n, a, lda, ipiv, anorm, rcond, work, info)
CHECON_ROOK estimates the reciprocal of the condition number fort HE matrices using factorization obt...
Definition checon_rook.f:139
chetri_rook
subroutine chetri_rook(uplo, n, a, lda, ipiv, work, info)
CHETRI_ROOK computes the inverse of HE matrix using the factorization obtained with the bounded Bunch...
Definition chetri_rook.f:128
chetrf_rook
subroutine chetrf_rook(uplo, n, a, lda, ipiv, work, lwork, info)
CHETRF_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bun...
Definition chetrf_rook.f:212
chet01_rook
subroutine chet01_rook(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
CHET01_ROOK
Definition chet01_rook.f:125

◆ cchkhp()

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

CCHKHP

Purpose:
!>
!> CCHKHP tests CHPTRF, -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 REAL
!>          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 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(2,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchkhp.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 REAL THRESH
173* ..
174* .. Array Arguments ..
175 LOGICAL DOTYPE( * )
176 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
177 REAL RWORK( * )
178 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
179 $ WORK( * ), X( * ), XACT( * )
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 REAL ZERO
186 parameter( zero = 0.0e+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 REAL ANORM, CNDNUM, RCOND, RCONDC
200* ..
201* .. Local Arrays ..
202 CHARACTER UPLOS( 2 )
203 INTEGER ISEED( 4 ), ISEEDY( 4 )
204 REAL RESULT( NTESTS )
205* ..
206* .. External Functions ..
207 LOGICAL LSAME
208 REAL CLANHP, SGET06
209 EXTERNAL lsame, clanhp, sget06
210* ..
211* .. External Subroutines ..
212 EXTERNAL alaerh, alahd, alasum, ccopy, cerrsy, cget04,
213 $ chpcon, chprfs, chpt01, chptrf, chptri, chptrs,
214 $ clacpy, claipd, clarhs, clatb4, clatms, cppt02,
215 $ cppt03, cppt05
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 ) = 'Complex 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 cerrsy( 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 CLATB4 and generate a test matrix
287* with CLATMS.
288*
289 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
290 $ CNDNUM, DIST )
291*
292 srnamt = 'CLATMS'
293 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
294 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
295 $ INFO )
296*
297* Check error code from CLATMS.
298*
299 IF( info.NE.0 ) THEN
300 CALL alaerh( path, 'CLATMS', 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 claipd( n, a, 2, 1 )
376 ELSE
377 CALL claipd( 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 ccopy( npp, a, 1, afac, 1 )
384 srnamt = 'CHPTRF'
385 CALL chptrf( 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 CHPTRF.
405*
406 IF( info.NE.k )
407 $ CALL alaerh( path, 'CHPTRF', 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 chpt01( 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 ccopy( npp, afac, 1, ainv, 1 )
427 srnamt = 'CHPTRI'
428 CALL chptri( uplo, n, ainv, iwork, work, info )
429*
430* Check error code from CHPTRI.
431*
432 IF( info.NE.0 )
433 $ CALL alaerh( path, 'CHPTRI', info, 0, uplo, n, n,
434 $ -1, -1, -1, imat, nfail, nerrs, nout )
435*
436 CALL cppt03( 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 = 'CLARHS'
469 CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
470 $ nrhs, a, lda, xact, lda, b, lda, iseed,
471 $ info )
472 xtype = 'C'
473 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
474*
475 srnamt = 'CHPTRS'
476 CALL chptrs( uplo, n, nrhs, afac, iwork, x, lda,
477 $ info )
478*
479* Check error code from CHPTRS.
480*
481 IF( info.NE.0 )
482 $ CALL alaerh( path, 'CHPTRS', info, 0, uplo, n, n,
483 $ -1, -1, nrhs, imat, nfail, nerrs,
484 $ nout )
485*
486 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
487 CALL cppt02( 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 cget04( 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 = 'CHPRFS'
500 CALL chprfs( 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 CHPRFS.
505*
506 IF( info.NE.0 )
507 $ CALL alaerh( path, 'CHPRFS', info, 0, uplo, n, n,
508 $ -1, -1, nrhs, imat, nfail, nerrs,
509 $ nout )
510*
511 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
512 $ result( 5 ) )
513 CALL cppt05( 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 = clanhp( '1', uplo, n, a, rwork )
537 srnamt = 'CHPCON'
538 CALL chpcon( uplo, n, afac, iwork, anorm, rcond, work,
539 $ info )
540*
541* Check error code from CHPCON.
542*
543 IF( info.NE.0 )
544 $ CALL alaerh( path, 'CHPCON', info, 0, uplo, n, n, -1,
545 $ -1, -1, imat, nfail, nerrs, nout )
546*
547 result( 8 ) = sget06( 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 CCHKHP
574*
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
clanhp
real function clanhp(norm, uplo, n, ap, work)
CLANHP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clanhp.f:117
chptri
subroutine chptri(uplo, n, ap, ipiv, work, info)
CHPTRI
Definition chptri.f:109
chprfs
subroutine chprfs(uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CHPRFS
Definition chprfs.f:180
chptrf
subroutine chptrf(uplo, n, ap, ipiv, info)
CHPTRF
Definition chptrf.f:159
chptrs
subroutine chptrs(uplo, n, nrhs, ap, ipiv, b, ldb, info)
CHPTRS
Definition chptrs.f:115
chpcon
subroutine chpcon(uplo, n, ap, ipiv, anorm, rcond, work, info)
CHPCON
Definition chpcon.f:118
cerrsy
subroutine cerrsy(path, nunit)
CERRSY
Definition cerrsy.f:55
cppt02
subroutine cppt02(uplo, n, nrhs, a, x, ldx, b, ldb, rwork, resid)
CPPT02
Definition cppt02.f:123
cppt05
subroutine cppt05(uplo, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
CPPT05
Definition cppt05.f:157
cppt03
subroutine cppt03(uplo, n, a, ainv, work, ldwork, rwork, rcond, resid)
CPPT03
Definition cppt03.f:110
chpt01
subroutine chpt01(uplo, n, a, afac, ipiv, c, ldc, rwork, resid)
CHPT01
Definition chpt01.f:113

◆ cchklq()

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

CCHKLQ

Purpose:
!>
!> CCHKLQ tests CGELQF, CUNGLQ and CUNMLQ.
!>
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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AQ
!>          AQ is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AL
!>          AL is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AC
!>          AC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]TAU
!>          TAU is COMPLEX array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]RWORK
!>          RWORK is REAL 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 cchklq.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 REAL THRESH
205* ..
206* .. Array Arguments ..
207 LOGICAL DOTYPE( * )
208 INTEGER MVAL( * ), NBVAL( * ), NVAL( * ),
209 $ NXVAL( * )
210 REAL RWORK( * )
211 COMPLEX 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 REAL ZERO
223 parameter( zero = 0.0e0 )
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 REAL ANORM, CNDNUM
232* ..
233* .. Local Arrays ..
234 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
235 REAL RESULT( NTESTS )
236* ..
237* .. External Subroutines ..
238 EXTERNAL alaerh, alahd, alasum, cerrlq, cgelqs, cget02,
239 $ clacpy, clarhs, clatb4, clatms, clqt01, clqt02,
240 $ clqt03, xlaenv
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 ) = 'Complex 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 cerrlq( 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 CLATB4 and generate a test matrix
298* with CLATMS.
299*
300 CALL clatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
301 $ CNDNUM, DIST )
302*
303 srnamt = 'CLATMS'
304 CALL clatms( 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 CLATMS.
309*
310 IF( info.NE.0 ) THEN
311 CALL alaerh( path, 'CLATMS', 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 CLQT01; other values are
318* used in the calls of CLQT02, 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 CGELQF
353*
354 CALL clqt01( m, n, a, af, aq, al, lda, tau,
355 $ work, lwork, rwork, result( 1 ) )
356 ELSE IF( m.LE.n ) THEN
357*
358* Test CUNGLQ, using factorization
359* returned by CLQT01
360*
361 CALL clqt02( 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 CUNMLQ, using factorization returned
367* by CLQT01
368*
369 CALL clqt03( 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 CGELQS 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 = 'CLARHS'
383 CALL clarhs( path, 'New', 'Full',
384 $ 'No transpose', m, n, 0, 0,
385 $ nrhs, a, lda, xact, lda, b, lda,
386 $ iseed, info )
387*
388 CALL clacpy( 'Full', m, nrhs, b, lda, x,
389 $ lda )
390 srnamt = 'CGELQS'
391 CALL cgelqs( m, n, nrhs, af, lda, tau, x,
392 $ lda, work, lwork, info )
393*
394* Check error code from CGELQS.
395*
396 IF( info.NE.0 )
397 $ CALL alaerh( path, 'CGELQS', info, 0, ' ',
398 $ m, n, nrhs, -1, nb, imat,
399 $ nfail, nerrs, nout )
400*
401 CALL cget02( '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 CCHKLQ
436*
cerrlq
subroutine cerrlq(path, nunit)
CERRLQ
Definition cerrlq.f:55
cgelqs
subroutine cgelqs(m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
CGELQS
Definition cgelqs.f:121
clqt01
subroutine clqt01(m, n, a, af, q, l, lda, tau, work, lwork, rwork, result)
CLQT01
Definition clqt01.f:126
clqt03
subroutine clqt03(m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
CLQT03
Definition clqt03.f:136
clqt02
subroutine clqt02(m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
CLQT02
Definition clqt02.f:135

◆ cchkpb()

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

CCHKPB

Purpose:
!>
!> CCHKPB tests CPBTRF, -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 REAL
!>          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 REAL array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is REAL array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is REAL array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is REAL array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is REAL array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is REAL array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is REAL array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchkpb.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 REAL THRESH
177* ..
178* .. Array Arguments ..
179 LOGICAL DOTYPE( * )
180 INTEGER NBVAL( * ), NSVAL( * ), NVAL( * )
181 REAL RWORK( * )
182 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
183 $ WORK( * ), X( * ), XACT( * )
184* ..
185*
186* =====================================================================
187*
188* .. Parameters ..
189 REAL ONE, ZERO
190 parameter( one = 1.0e+0, zero = 0.0e+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 REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC
205* ..
206* .. Local Arrays ..
207 INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW )
208 REAL RESULT( NTESTS )
209* ..
210* .. External Functions ..
211 REAL CLANGE, CLANHB, SGET06
212 EXTERNAL clange, clanhb, sget06
213* ..
214* .. External Subroutines ..
215 EXTERNAL alaerh, alahd, alasum, ccopy, cerrpo, cget04,
216 $ clacpy, claipd, clarhs, claset, clatb4, clatms,
217 $ cpbcon, cpbrfs, cpbt01, cpbt02, cpbt05, cpbtrf,
218 $ cpbtrs, cswap, xlaenv
219* ..
220* .. Intrinsic Functions ..
221 INTRINSIC cmplx, 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 ) = 'Complex 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 cerrpo( 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 CLATB4 and generate a test
311* matrix with CLATMS.
312*
313 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
314 $ MODE, CNDNUM, DIST )
315*
316 srnamt = 'CLATMS'
317 CALL clatms( 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 CLATMS.
322*
323 IF( info.NE.0 ) THEN
324 CALL alaerh( path, 'CLATMS', 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 ccopy( izero-i1, work( iw ), 1,
338 $ a( ioff-izero+i1 ), 1 )
339 iw = iw + izero - i1
340 CALL ccopy( i2-izero+1, work( iw ), 1,
341 $ a( ioff ), max( ldab-1, 1 ) )
342 ELSE
343 ioff = ( i1-1 )*ldab + 1
344 CALL ccopy( 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 ccopy( 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 cswap( izero-i1, a( ioff-izero+i1 ), 1,
380 $ work( iw ), 1 )
381 iw = iw + izero - i1
382 CALL cswap( i2-izero+1, a( ioff ),
383 $ max( ldab-1, 1 ), work( iw ), 1 )
384 ELSE
385 ioff = ( i1-1 )*ldab + 1
386 CALL cswap( 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 cswap( 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 claipd( n, a( kd+1 ), ldab, 0 )
399 ELSE
400 CALL claipd( 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 clacpy( 'Full', kd+1, n, a, ldab, afac, ldab )
413 srnamt = 'CPBTRF'
414 CALL cpbtrf( uplo, n, kd, afac, ldab, info )
415*
416* Check error code from CPBTRF.
417*
418 IF( info.NE.izero ) THEN
419 CALL alaerh( path, 'CPBTRF', 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 clacpy( 'Full', kd+1, n, afac, ldab, ainv,
435 $ ldab )
436 CALL cpbt01( 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 claset( 'Full', n, n, cmplx( zero ),
459 $ cmplx( one ), ainv, lda )
460 srnamt = 'CPBTRS'
461 CALL cpbtrs( uplo, n, kd, n, afac, ldab, ainv, lda,
462 $ info )
463*
464* Compute RCONDC = 1/(norm(A) * norm(inv(A))).
465*
466 anorm = clanhb( '1', uplo, n, kd, a, ldab, rwork )
467 ainvnm = clange( '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 = 'CLARHS'
481 CALL clarhs( path, xtype, uplo, ' ', n, n, kd,
482 $ kd, nrhs, a, ldab, xact, lda, b,
483 $ lda, iseed, info )
484 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
485*
486 srnamt = 'CPBTRS'
487 CALL cpbtrs( uplo, n, kd, nrhs, afac, ldab, x,
488 $ lda, info )
489*
490* Check error code from CPBTRS.
491*
492 IF( info.NE.0 )
493 $ CALL alaerh( path, 'CPBTRS', info, 0, uplo,
494 $ n, n, kd, kd, nrhs, imat, nfail,
495 $ nerrs, nout )
496*
497 CALL clacpy( 'Full', n, nrhs, b, lda, work,
498 $ lda )
499 CALL cpbt02( 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 cget04( 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 = 'CPBRFS'
512 CALL cpbrfs( 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 CPBRFS.
518*
519 IF( info.NE.0 )
520 $ CALL alaerh( path, 'CPBRFS', info, 0, uplo,
521 $ n, n, kd, kd, nrhs, imat, nfail,
522 $ nerrs, nout )
523*
524 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
525 $ result( 4 ) )
526 CALL cpbt05( 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 = 'CPBCON'
549 CALL cpbcon( uplo, n, kd, afac, ldab, anorm, rcond,
550 $ work, rwork, info )
551*
552* Check error code from CPBCON.
553*
554 IF( info.NE.0 )
555 $ CALL alaerh( path, 'CPBCON', info, 0, uplo, n,
556 $ n, kd, kd, -1, imat, nfail, nerrs,
557 $ nout )
558*
559 result( 7 ) = sget06( 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 CCHKPB
590*
clanhb
real function clanhb(norm, uplo, n, k, ab, ldab, work)
CLANHB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clanhb.f:132
cpbtrf
subroutine cpbtrf(uplo, n, kd, ab, ldab, info)
CPBTRF
Definition cpbtrf.f:142
cpbtrs
subroutine cpbtrs(uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
CPBTRS
Definition cpbtrs.f:121
cpbrfs
subroutine cpbrfs(uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CPBRFS
Definition cpbrfs.f:189
cpbcon
subroutine cpbcon(uplo, n, kd, ab, ldab, anorm, rcond, work, rwork, info)
CPBCON
Definition cpbcon.f:133
cswap
subroutine cswap(n, cx, incx, cy, incy)
CSWAP
Definition cswap.f:81
cpbt01
subroutine cpbt01(uplo, n, kd, a, lda, afac, ldafac, rwork, resid)
CPBT01
Definition cpbt01.f:120
cerrpo
subroutine cerrpo(path, nunit)
CERRPO
Definition cerrpo.f:55
cpbt02
subroutine cpbt02(uplo, n, kd, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
CPBT02
Definition cpbt02.f:136
cpbt05
subroutine cpbt05(uplo, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
CPBT05
Definition cpbt05.f:171

◆ cchkpo()

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

CCHKPO

Purpose:
!>
!> CCHKPO tests CPOTRF, -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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchkpo.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 REAL THRESH
177* ..
178* .. Array Arguments ..
179 LOGICAL DOTYPE( * )
180 INTEGER NBVAL( * ), NSVAL( * ), NVAL( * )
181 REAL RWORK( * )
182 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
183 $ WORK( * ), X( * ), XACT( * )
184* ..
185*
186* =====================================================================
187*
188* .. Parameters ..
189 COMPLEX CZERO
190 parameter( czero = ( 0.0e+0, 0.0e+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 REAL ANORM, CNDNUM, RCOND, RCONDC
204* ..
205* .. Local Arrays ..
206 CHARACTER UPLOS( 2 )
207 INTEGER ISEED( 4 ), ISEEDY( 4 )
208 REAL RESULT( NTESTS )
209* ..
210* .. External Functions ..
211 REAL CLANHE, SGET06
212 EXTERNAL clanhe, sget06
213* ..
214* .. External Subroutines ..
215 EXTERNAL alaerh, alahd, alasum, cerrpo, cget04, clacpy,
216 $ claipd, clarhs, clatb4, clatms, cpocon, cporfs,
217 $ cpot01, cpot02, cpot03, cpot05, cpotrf, cpotri,
218 $ cpotrs, xlaenv
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 ) = 'Complex 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 cerrpo( 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 CLATB4 and generate a test matrix
285* with CLATMS.
286*
287 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
288 $ CNDNUM, DIST )
289*
290 srnamt = 'CLATMS'
291 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
292 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
293 $ INFO )
294*
295* Check error code from CLATMS.
296*
297 IF( info.NE.0 ) THEN
298 CALL alaerh( path, 'CLATMS', 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 claipd( 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 clacpy( uplo, n, n, a, lda, afac, lda )
355 srnamt = 'CPOTRF'
356 CALL cpotrf( uplo, n, afac, lda, info )
357*
358* Check error code from CPOTRF.
359*
360 IF( info.NE.izero ) THEN
361 CALL alaerh( path, 'CPOTRF', 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 clacpy( uplo, n, n, afac, lda, ainv, lda )
376 CALL cpot01( 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 clacpy( uplo, n, n, afac, lda, ainv, lda )
383 srnamt = 'CPOTRI'
384 CALL cpotri( uplo, n, ainv, lda, info )
385*
386* Check error code from CPOTRI.
387*
388 IF( info.NE.0 )
389 $ CALL alaerh( path, 'CPOTRI', info, 0, uplo, n, n,
390 $ -1, -1, -1, imat, nfail, nerrs, nout )
391*
392 CALL cpot03( 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 = 'CLARHS'
422 CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
423 $ nrhs, a, lda, xact, lda, b, lda,
424 $ iseed, info )
425 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
426*
427 srnamt = 'CPOTRS'
428 CALL cpotrs( uplo, n, nrhs, afac, lda, x, lda,
429 $ info )
430*
431* Check error code from CPOTRS.
432*
433 IF( info.NE.0 )
434 $ CALL alaerh( path, 'CPOTRS', info, 0, uplo, n,
435 $ n, -1, -1, nrhs, imat, nfail,
436 $ nerrs, nout )
437*
438 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
439 CALL cpot02( 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 cget04( 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 = 'CPORFS'
452 CALL cporfs( 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 CPORFS.
457*
458 IF( info.NE.0 )
459 $ CALL alaerh( path, 'CPORFS', info, 0, uplo, n,
460 $ n, -1, -1, nrhs, imat, nfail,
461 $ nerrs, nout )
462*
463 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
464 $ result( 5 ) )
465 CALL cpot05( 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 = clanhe( '1', uplo, n, a, lda, rwork )
488 srnamt = 'CPOCON'
489 CALL cpocon( uplo, n, afac, lda, anorm, rcond, work,
490 $ rwork, info )
491*
492* Check error code from CPOCON.
493*
494 IF( info.NE.0 )
495 $ CALL alaerh( path, 'CPOCON', info, 0, uplo, n, n,
496 $ -1, -1, -1, imat, nfail, nerrs, nout )
497*
498 result( 8 ) = sget06( 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 CCHKPO
528*
cporfs
subroutine cporfs(uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CPORFS
Definition cporfs.f:183
cpocon
subroutine cpocon(uplo, n, a, lda, anorm, rcond, work, rwork, info)
CPOCON
Definition cpocon.f:121
cpotrs
subroutine cpotrs(uplo, n, nrhs, a, lda, b, ldb, info)
CPOTRS
Definition cpotrs.f:110
cpotri
subroutine cpotri(uplo, n, a, lda, info)
CPOTRI
Definition cpotri.f:95
cpotrf
subroutine cpotrf(uplo, n, a, lda, info)
CPOTRF
Definition cpotrf.f:107
cpot01
subroutine cpot01(uplo, n, a, lda, afac, ldafac, rwork, resid)
CPOT01
Definition cpot01.f:106

◆ cchkpp()

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

CCHKPP

Purpose:
!>
!> CCHKPP tests CPPTRF, -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 REAL
!>          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 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchkpp.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 REAL THRESH
168* ..
169* .. Array Arguments ..
170 LOGICAL DOTYPE( * )
171 INTEGER NSVAL( * ), NVAL( * )
172 REAL RWORK( * )
173 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
174 $ WORK( * ), X( * ), XACT( * )
175* ..
176*
177* =====================================================================
178*
179* .. Parameters ..
180 REAL ZERO
181 parameter( zero = 0.0e+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 REAL ANORM, CNDNUM, RCOND, RCONDC
195* ..
196* .. Local Arrays ..
197 CHARACTER PACKS( 2 ), UPLOS( 2 )
198 INTEGER ISEED( 4 ), ISEEDY( 4 )
199 REAL RESULT( NTESTS )
200* ..
201* .. External Functions ..
202 REAL CLANHP, SGET06
203 EXTERNAL clanhp, sget06
204* ..
205* .. External Subroutines ..
206 EXTERNAL alaerh, alahd, alasum, ccopy, cerrpo, cget04,
207 $ clacpy, claipd, clarhs, clatb4, clatms, cppcon,
208 $ cpprfs, cppt01, cppt02, cppt03, cppt05, cpptrf,
209 $ cpptri, cpptrs
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 ) = 'Complex 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 cerrpo( 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 CLATB4 and generate a test matrix
276* with CLATMS.
277*
278 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
279 $ CNDNUM, DIST )
280*
281 srnamt = 'CLATMS'
282 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
283 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
284 $ INFO )
285*
286* Check error code from CLATMS.
287*
288 IF( info.NE.0 ) THEN
289 CALL alaerh( path, 'CLATMS', 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 claipd( n, a, 2, 1 )
337 ELSE
338 CALL claipd( 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 ccopy( npp, a, 1, afac, 1 )
345 srnamt = 'CPPTRF'
346 CALL cpptrf( uplo, n, afac, info )
347*
348* Check error code from CPPTRF.
349*
350 IF( info.NE.izero ) THEN
351 CALL alaerh( path, 'CPPTRF', 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 ccopy( npp, afac, 1, ainv, 1 )
365 CALL cppt01( uplo, n, a, ainv, rwork, result( 1 ) )
366*
367*+ TEST 2
368* Form the inverse and compute the residual.
369*
370 CALL ccopy( npp, afac, 1, ainv, 1 )
371 srnamt = 'CPPTRI'
372 CALL cpptri( uplo, n, ainv, info )
373*
374* Check error code from CPPTRI.
375*
376 IF( info.NE.0 )
377 $ CALL alaerh( path, 'CPPTRI', info, 0, uplo, n, n, -1,
378 $ -1, -1, imat, nfail, nerrs, nout )
379*
380 CALL cppt03( 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 = 'CLARHS'
404 CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
405 $ nrhs, a, lda, xact, lda, b, lda, iseed,
406 $ info )
407 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
408*
409 srnamt = 'CPPTRS'
410 CALL cpptrs( uplo, n, nrhs, afac, x, lda, info )
411*
412* Check error code from CPPTRS.
413*
414 IF( info.NE.0 )
415 $ CALL alaerh( path, 'CPPTRS', info, 0, uplo, n, n,
416 $ -1, -1, nrhs, imat, nfail, nerrs,
417 $ nout )
418*
419 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
420 CALL cppt02( 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 cget04( 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 = 'CPPRFS'
433 CALL cpprfs( 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 CPPRFS.
438*
439 IF( info.NE.0 )
440 $ CALL alaerh( path, 'CPPRFS', info, 0, uplo, n, n,
441 $ -1, -1, nrhs, imat, nfail, nerrs,
442 $ nout )
443*
444 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
445 $ result( 5 ) )
446 CALL cppt05( 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 = clanhp( '1', uplo, n, a, rwork )
469 srnamt = 'CPPCON'
470 CALL cppcon( uplo, n, afac, anorm, rcond, work, rwork,
471 $ info )
472*
473* Check error code from CPPCON.
474*
475 IF( info.NE.0 )
476 $ CALL alaerh( path, 'CPPCON', info, 0, uplo, n, n, -1,
477 $ -1, -1, imat, nfail, nerrs, nout )
478*
479 result( 8 ) = sget06( 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 CCHKPP
507*
cppcon
subroutine cppcon(uplo, n, ap, anorm, rcond, work, rwork, info)
CPPCON
Definition cppcon.f:118
cpptrf
subroutine cpptrf(uplo, n, ap, info)
CPPTRF
Definition cpptrf.f:119
cpprfs
subroutine cpprfs(uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CPPRFS
Definition cpprfs.f:171
cpptrs
subroutine cpptrs(uplo, n, nrhs, ap, b, ldb, info)
CPPTRS
Definition cpptrs.f:108
cpptri
subroutine cpptri(uplo, n, ap, info)
CPPTRI
Definition cpptri.f:93
cppt01
subroutine cppt01(uplo, n, a, afac, rwork, resid)
CPPT01
Definition cppt01.f:95

◆ cchkps()

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

CCHKPS

Purpose:
!>
!> CCHKPS tests CPSTRF.
!>
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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]PERM
!>          PERM is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]PIV
!>          PIV is INTEGER array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*3)
!>
[out]RWORK
!>          RWORK is REAL 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 cchkps.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 REAL THRESH
161 INTEGER NMAX, NN, NNB, NOUT, NRANK
162 LOGICAL TSTERR
163* ..
164* .. Array Arguments ..
165 COMPLEX A( * ), AFAC( * ), PERM( * ), WORK( * )
166 REAL RWORK( * )
167 INTEGER NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * )
168 LOGICAL DOTYPE( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 REAL ONE
175 parameter( one = 1.0e+0 )
176 INTEGER NTYPES
177 parameter( ntypes = 9 )
178* ..
179* .. Local Scalars ..
180 REAL 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, cerrps, clacpy,
193 $ clatb5, clatmt, cpst01, cpstrf, xlaenv
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 max, real, 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 ) = 'Complex 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 cerrps( 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 * real( 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 CLATB5 and generate a test matrix
267* with CLATMT.
268*
269 CALL clatb5( path, imat, n, TYPE, KL, KU, ANORM,
270 $ MODE, CNDNUM, DIST )
271*
272 srnamt = 'CLATMT'
273 CALL clatmt( 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 CLATMT.
278*
279 IF( info.NE.0 ) THEN
280 CALL alaerh( path, 'CLATMT', 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 clacpy( uplo, n, n, a, lda, afac, lda )
296 srnamt = 'CPSTRF'
297*
298* Use default tolerance
299*
300 tol = -one
301 CALL cpstrf( uplo, n, afac, lda, piv, comprank,
302 $ tol, rwork, info )
303*
304* Check error code from CPSTRF.
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, 'CPSTRF', 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 cpst01( 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 CCHKPS
358*
cpstrf
subroutine cpstrf(uplo, n, a, lda, piv, rank, tol, work, info)
CPSTRF computes the Cholesky factorization with complete pivoting of complex Hermitian positive semid...
Definition cpstrf.f:142
clatb5
subroutine clatb5(path, imat, n, type, kl, ku, anorm, mode, cndnum, dist)
CLATB5
Definition clatb5.f:114
cpst01
subroutine cpst01(uplo, n, a, lda, afac, ldafac, perm, ldperm, piv, rwork, resid, rank)
CPST01
Definition cpst01.f:136
cerrps
subroutine cerrps(path, nunit)
CERRPS
Definition cerrps.f:55
clatmt
subroutine clatmt(m, n, dist, iseed, sym, d, mode, cond, dmax, rank, kl, ku, pack, a, lda, work, info)
CLATMT
Definition clatmt.f:340

◆ cchkpt()

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

CCHKPT

Purpose:
!>
!> CCHKPT tests CPTTRF, -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 REAL
!>          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 array, dimension (NMAX*2)
!>
[out]D
!>          D is REAL array, dimension (NMAX*2)
!>
[out]E
!>          E is COMPLEX array, dimension (NMAX*2)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchkpt.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 REAL THRESH
156* ..
157* .. Array Arguments ..
158 LOGICAL DOTYPE( * )
159 INTEGER NSVAL( * ), NVAL( * )
160 REAL D( * ), RWORK( * )
161 COMPLEX A( * ), B( * ), E( * ), WORK( * ), X( * ),
162 $ XACT( * )
163* ..
164*
165* =====================================================================
166*
167* .. Parameters ..
168 REAL ONE, ZERO
169 parameter( one = 1.0e+0, zero = 0.0e+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 REAL AINVNM, ANORM, COND, DMAX, RCOND, RCONDC
183* ..
184* .. Local Arrays ..
185 CHARACTER UPLOS( 2 )
186 INTEGER ISEED( 4 ), ISEEDY( 4 )
187 REAL RESULT( NTESTS )
188 COMPLEX Z( 3 )
189* ..
190* .. External Functions ..
191 INTEGER ISAMAX
192 REAL CLANHT, SCASUM, SGET06
193 EXTERNAL isamax, clanht, scasum, sget06
194* ..
195* .. External Subroutines ..
196 EXTERNAL alaerh, alahd, alasum, ccopy, cerrgt, cget04,
197 $ clacpy, claptm, clarnv, clatb4, clatms, cptcon,
198 $ cptrfs, cptt01, cptt02, cptt05, cpttrf, cpttrs,
199 $ csscal, scopy, slarnv, sscal
200* ..
201* .. Intrinsic Functions ..
202 INTRINSIC abs, max, real
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 ) = 'Complex 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 cerrgt( 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 CLATB4.
251*
252 CALL clatb4( 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 = 'CLATMS'
262 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE, COND,
263 $ ANORM, KL, KU, 'B', A, 2, WORK, INFO )
264*
265* Check the error code from CLATMS.
266*
267 IF( info.NE.0 ) THEN
268 CALL alaerh( path, 'CLATMS', 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 ) = real( a( ia ) )
279 e( i ) = a( ia+1 )
280 ia = ia + 2
281 20 CONTINUE
282 IF( n.GT.0 )
283 $ d( n ) = real( 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 slarnv( 2, iseed, n, d )
294 CALL clarnv( 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 = isamax( n, d, 1 )
312 dmax = d( ix )
313 CALL sscal( n, anorm / dmax, d, 1 )
314 CALL csscal( 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 scopy( n, d, 1, d( n+1 ), 1 )
369 IF( n.GT.1 )
370 $ CALL ccopy( 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 cpttrf( n, d( n+1 ), e( n+1 ), info )
377*
378* Check error code from CPTTRF.
379*
380 IF( info.NE.izero ) THEN
381 CALL alaerh( path, 'CPTTRF', 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 cptt01( 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 = clanht( '1', n, d, e )
409*
410* Use CPTTRS 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 cpttrs( 'Lower', n, 1, d( n+1 ), e( n+1 ), x, lda,
420 $ info )
421 ainvnm = max( ainvnm, scasum( 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 clarnv( 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 claptm( 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 clacpy( 'Full', n, nrhs, b, lda, x, lda )
451 CALL cpttrs( uplo, n, nrhs, d( n+1 ), e( n+1 ), x,
452 $ lda, info )
453*
454* Check error code from CPTTRS.
455*
456 IF( info.NE.0 )
457 $ CALL alaerh( path, 'CPTTRS', info, 0, uplo, n, n,
458 $ -1, -1, nrhs, imat, nfail, nerrs,
459 $ nout )
460*
461 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
462 CALL cptt02( 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 cget04( 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 = 'CPTRFS'
475 CALL cptrfs( 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 CPTRFS.
480*
481 IF( info.NE.0 )
482 $ CALL alaerh( path, 'CPTRFS', info, 0, uplo, n, n,
483 $ -1, -1, nrhs, imat, nfail, nerrs,
484 $ nout )
485*
486 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
487 $ result( 4 ) )
488 CALL cptt05( 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 = 'CPTCON'
514 CALL cptcon( n, d( n+1 ), e( n+1 ), anorm, rcond, rwork,
515 $ info )
516*
517* Check error code from CPTCON.
518*
519 IF( info.NE.0 )
520 $ CALL alaerh( path, 'CPTCON', info, 0, ' ', n, n, -1, -1,
521 $ -1, imat, nfail, nerrs, nout )
522*
523 result( 7 ) = sget06( 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 CCHKPT
548*
slarnv
subroutine slarnv(idist, iseed, n, x)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition slarnv.f:97
isamax
integer function isamax(n, sx, incx)
ISAMAX
Definition isamax.f:71
clanht
real function clanht(norm, n, d, e)
CLANHT returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clanht.f:101
cptrfs
subroutine cptrfs(uplo, n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CPTRFS
Definition cptrfs.f:183
cpttrf
subroutine cpttrf(n, d, e, info)
CPTTRF
Definition cpttrf.f:92
cpttrs
subroutine cpttrs(uplo, n, nrhs, d, e, b, ldb, info)
CPTTRS
Definition cpttrs.f:121
cptcon
subroutine cptcon(n, d, e, anorm, rcond, rwork, info)
CPTCON
Definition cptcon.f:119
claptm
subroutine claptm(uplo, n, nrhs, alpha, d, e, x, ldx, beta, b, ldb)
CLAPTM
Definition claptm.f:129
cptt05
subroutine cptt05(n, nrhs, d, e, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
CPTT05
Definition cptt05.f:150
cerrgt
subroutine cerrgt(path, nunit)
CERRGT
Definition cerrgt.f:55
cptt01
subroutine cptt01(n, d, e, df, ef, work, resid)
CPTT01
Definition cptt01.f:92
cptt02
subroutine cptt02(uplo, n, nrhs, d, e, x, ldx, b, ldb, resid)
CPTT02
Definition cptt02.f:115
sscal
subroutine sscal(n, sa, sx, incx)
SSCAL
Definition sscal.f:79
scopy
subroutine scopy(n, sx, incx, sy, incy)
SCOPY
Definition scopy.f:82

◆ cchkq3()

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

CCHKQ3

Purpose:
!>
!> CCHKQ3 tests CGEQP3.
!>
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 REAL
!>          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 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 array, dimension (MMAX*NMAX)
!>
[out]S
!>          S is REAL array, dimension
!>                      (min(MMAX,NMAX))
!>
[out]TAU
!>          TAU is COMPLEX array, dimension (MMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (max(M*max(M,N) + 4*min(M,N) + max(M,N)))
!>
[out]RWORK
!>          RWORK is REAL 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 cchkq3.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 REAL THRESH
166* ..
167* .. Array Arguments ..
168 LOGICAL DOTYPE( * )
169 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
170 $ NXVAL( * )
171 REAL S( * ), RWORK( * )
172 COMPLEX 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 REAL ONE, ZERO
183 COMPLEX CZERO
184 parameter( one = 1.0e+0, zero = 0.0e+0,
185 $ czero = ( 0.0e+0, 0.0e+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 REAL EPS
193* ..
194* .. Local Arrays ..
195 INTEGER ISEED( 4 ), ISEEDY( 4 )
196 REAL RESULT( NTESTS )
197* ..
198* .. External Functions ..
199 REAL CQPT01, CQRT11, CQRT12, SLAMCH
200 EXTERNAL cqpt01, cqrt11, cqrt12, slamch
201* ..
202* .. External Subroutines ..
203 EXTERNAL alahd, alasum, cgeqp3, clacpy, claset, clatms,
204 $ icopy, slaord, xlaenv
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 ) = 'Complex 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 = slamch( '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 claset( 'Full', m, n, czero, czero, copya, lda )
275 DO 30 i = 1, mnmin
276 s( i ) = zero
277 30 CONTINUE
278 ELSE
279 CALL clatms( 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 slaord( '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 clacpy( '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 = 'CGEQP3'
323 CALL cgeqp3( 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 ) = cqrt12( m, n, a, lda, s, work,
329 $ lwork, rwork )
330*
331* Compute norm( A*P - Q*R )
332*
333 result( 2 ) = cqpt01( m, n, mnmin, copya, a, lda, tau,
334 $ iwork( n+1 ), work, lwork )
335*
336* Compute Q'*Q
337*
338 result( 3 ) = cqrt11( 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 )'CGEQP3', 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 CCHKQ3
368*
icopy
subroutine icopy(n, sx, incx, sy, incy)
ICOPY
Definition icopy.f:75
cgeqp3
subroutine cgeqp3(m, n, a, lda, jpvt, tau, work, lwork, rwork, info)
CGEQP3
Definition cgeqp3.f:159
cqpt01
real function cqpt01(m, n, k, a, af, lda, tau, jpvt, work, lwork)
CQPT01
Definition cqpt01.f:120
cqrt12
real function cqrt12(m, n, a, lda, s, work, lwork, rwork)
CQRT12
Definition cqrt12.f:97
cqrt11
real function cqrt11(m, k, a, lda, tau, work, lwork)
CQRT11
Definition cqrt11.f:98
slaord
subroutine slaord(job, n, x, incx)
SLAORD
Definition slaord.f:73

◆ cchkql()

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

CCHKQL

Purpose:
!>
!> CCHKQL tests CGEQLF, CUNGQL and CUNMQL.
!>
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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AQ
!>          AQ is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AL
!>          AL is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AC
!>          AC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]TAU
!>          TAU is COMPLEX array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]RWORK
!>          RWORK is REAL 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 cchkql.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 REAL THRESH
205* ..
206* .. Array Arguments ..
207 LOGICAL DOTYPE( * )
208 INTEGER MVAL( * ), NBVAL( * ), NVAL( * ),
209 $ NXVAL( * )
210 REAL RWORK( * )
211 COMPLEX 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 REAL ZERO
223 parameter( zero = 0.0e0 )
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 REAL ANORM, CNDNUM
232* ..
233* .. Local Arrays ..
234 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
235 REAL RESULT( NTESTS )
236* ..
237* .. External Subroutines ..
238 EXTERNAL alaerh, alahd, alasum, cerrql, cgeqls, cget02,
239 $ clacpy, clarhs, clatb4, clatms, cqlt01, cqlt02,
240 $ cqlt03, xlaenv
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 ) = 'Complex 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 cerrql( 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 CLATB4 and generate a test matrix
298* with CLATMS.
299*
300 CALL clatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
301 $ CNDNUM, DIST )
302*
303 srnamt = 'CLATMS'
304 CALL clatms( 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 CLATMS.
309*
310 IF( info.NE.0 ) THEN
311 CALL alaerh( path, 'CLATMS', 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 CQLT01; other values are
318* used in the calls of CQLT02, 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 CGEQLF
353*
354 CALL cqlt01( m, n, a, af, aq, al, lda, tau,
355 $ work, lwork, rwork, result( 1 ) )
356 ELSE IF( m.GE.n ) THEN
357*
358* Test CUNGQL, using factorization
359* returned by CQLT01
360*
361 CALL cqlt02( 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 CUNMQL, using factorization returned
367* by CQLT01
368*
369 CALL cqlt03( 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 CGEQLS 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 = 'CLARHS'
383 CALL clarhs( path, 'New', 'Full',
384 $ 'No transpose', m, n, 0, 0,
385 $ nrhs, a, lda, xact, lda, b, lda,
386 $ iseed, info )
387*
388 CALL clacpy( 'Full', m, nrhs, b, lda, x,
389 $ lda )
390 srnamt = 'CGEQLS'
391 CALL cgeqls( m, n, nrhs, af, lda, tau, x,
392 $ lda, work, lwork, info )
393*
394* Check error code from CGEQLS.
395*
396 IF( info.NE.0 )
397 $ CALL alaerh( path, 'CGEQLS', info, 0, ' ',
398 $ m, n, nrhs, -1, nb, imat,
399 $ nfail, nerrs, nout )
400*
401 CALL cget02( '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 CCHKQL
436*
cerrql
subroutine cerrql(path, nunit)
CERRQL
Definition cerrql.f:55
cqlt02
subroutine cqlt02(m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
CQLT02
Definition cqlt02.f:136
cqlt03
subroutine cqlt03(m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
CQLT03
Definition cqlt03.f:136
cgeqls
subroutine cgeqls(m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
CGEQLS
Definition cgeqls.f:122
cqlt01
subroutine cqlt01(m, n, a, af, q, l, lda, tau, work, lwork, rwork, result)
CQLT01
Definition cqlt01.f:126

◆ cchkqr()

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

CCHKQR

Purpose:
!>
!> CCHKQR tests CGEQRF, CUNGQR and CUNMQR.
!>
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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AQ
!>          AQ is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AR
!>          AR is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AC
!>          AC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]TAU
!>          TAU is COMPLEX array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]RWORK
!>          RWORK is REAL 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 cchkqr.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 REAL THRESH
210* ..
211* .. Array Arguments ..
212 LOGICAL DOTYPE( * )
213 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
214 $ NXVAL( * )
215 REAL RWORK( * )
216 COMPLEX 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 REAL ZERO
228 parameter( zero = 0.0e0 )
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 REAL ANORM, CNDNUM
237* ..
238* .. Local Arrays ..
239 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
240 REAL RESULT( NTESTS )
241* ..
242* .. External Functions ..
243 LOGICAL CGENND
244 EXTERNAL cgennd
245* ..
246* .. External Subroutines ..
247 EXTERNAL alaerh, alahd, alasum, cerrqr, cgeqrs, cget02,
248 $ clacpy, clarhs, clatb4, clatms, cqrt01,
249 $ cqrt01p, cqrt02, cqrt03, xlaenv
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 ) = 'Complex 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 cerrqr( 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 CLATB4 and generate a test matrix
307* with CLATMS.
308*
309 CALL clatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
310 $ CNDNUM, DIST )
311*
312 srnamt = 'CLATMS'
313 CALL clatms( 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 CLATMS.
318*
319 IF( info.NE.0 ) THEN
320 CALL alaerh( path, 'CLATMS', 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 CQRT01; other values are
327* used in the calls of CQRT02, 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 CGEQRF
362*
363 CALL cqrt01( m, n, a, af, aq, ar, lda, tau,
364 $ work, lwork, rwork, result( 1 ) )
365*
366* Test CGEQRFP
367*
368 CALL cqrt01p( m, n, a, af, aq, ar, lda, tau,
369 $ work, lwork, rwork, result( 8 ) )
370
371 IF( .NOT. cgennd( m, n, af, lda ) )
372 $ result( 9 ) = 2*thresh
373 nt = nt + 1
374 ELSE IF( m.GE.n ) THEN
375*
376* Test CUNGQR, using factorization
377* returned by CQRT01
378*
379 CALL cqrt02( 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 CUNMQR, using factorization returned
385* by CQRT01
386*
387 CALL cqrt03( 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 CGEQRS 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 = 'CLARHS'
401 CALL clarhs( path, 'New', 'Full',
402 $ 'No transpose', m, n, 0, 0,
403 $ nrhs, a, lda, xact, lda, b, lda,
404 $ iseed, info )
405*
406 CALL clacpy( 'Full', m, nrhs, b, lda, x,
407 $ lda )
408 srnamt = 'CGEQRS'
409 CALL cgeqrs( m, n, nrhs, af, lda, tau, x,
410 $ lda, work, lwork, info )
411*
412* Check error code from CGEQRS.
413*
414 IF( info.NE.0 )
415 $ CALL alaerh( path, 'CGEQRS', info, 0, ' ',
416 $ m, n, nrhs, -1, nb, imat,
417 $ nfail, nerrs, nout )
418*
419 CALL cget02( '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 CCHKQR
454*
cqrt02
subroutine cqrt02(m, n, k, a, af, q, r, lda, tau, work, lwork, rwork, result)
CQRT02
Definition cqrt02.f:135
cqrt03
subroutine cqrt03(m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
CQRT03
Definition cqrt03.f:136
cerrqr
subroutine cerrqr(path, nunit)
CERRQR
Definition cerrqr.f:55
cqrt01
subroutine cqrt01(m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
CQRT01
Definition cqrt01.f:126
cgeqrs
subroutine cgeqrs(m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
CGEQRS
Definition cgeqrs.f:121
cqrt01p
subroutine cqrt01p(m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
CQRT01P
Definition cqrt01p.f:126
cgennd
logical function cgennd(m, n, a, lda)
CGENND
Definition cgennd.f:68

◆ cchkqrt()

subroutine cchkqrt ( real thresh,
logical tsterr,
integer nm,
integer, dimension( * ) mval,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nout )

CCHKQRT

Purpose:
!>
!> CCHKQRT tests CGEQRT and CGEMQRT.
!>
Parameters
[in]THRESH
!>          THRESH is REAL
!>          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 cchkqrt.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 REAL 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, M, N, NB, NFAIL, NERRS, NRUN,
126 $ MINMN
127* ..
128* .. Local Arrays ..
129 REAL RESULT( NTESTS )
130* ..
131* .. External Subroutines ..
132 EXTERNAL alaerh, alahd, alasum, cerrqrt, cqrt04
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 ) = 'C'
148 path( 2: 3 ) = 'QT'
149 nrun = 0
150 nfail = 0
151 nerrs = 0
152*
153* Test the error exits
154*
155 IF( tsterr ) CALL cerrqrt( path, nout )
156 infot = 0
157*
158* Do for each value of M in MVAL.
159*
160 DO i = 1, nm
161 m = mval( i )
162*
163* Do for each value of N in NVAL.
164*
165 DO j = 1, nn
166 n = nval( j )
167*
168* Do for each possible value of NB
169*
170 minmn = min( m, n )
171 DO k = 1, nnb
172 nb = nbval( k )
173*
174* Test CGEQRT and CGEMQRT
175*
176 IF( (nb.LE.minmn).AND.(nb.GT.0) ) THEN
177 CALL cqrt04( m, n, nb, result )
178*
179* Print information about the tests that did not
180* pass the threshold.
181*
182 DO t = 1, ntests
183 IF( result( t ).GE.thresh ) THEN
184 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
185 $ CALL alahd( nout, path )
186 WRITE( nout, fmt = 9999 )m, n, nb,
187 $ t, result( t )
188 nfail = nfail + 1
189 END IF
190 END DO
191 nrun = nrun + ntests
192 END IF
193 END DO
194 END DO
195 END DO
196*
197* Print a summary of the results.
198*
199 CALL alasum( path, nout, nfail, nrun, nerrs )
200*
201 9999 FORMAT( ' M=', i5, ', N=', i5, ', NB=', i4,
202 $ ' test(', i2, ')=', g12.5 )
203 RETURN
204*
205* End of CCHKQRT
206*
cerrqrt
subroutine cerrqrt(path, nunit)
CERRQRT
Definition cerrqrt.f:55
cqrt04
subroutine cqrt04(m, n, nb, result)
CQRT04
Definition cqrt04.f:73

◆ cchkqrtp()

subroutine cchkqrtp ( real thresh,
logical tsterr,
integer nm,
integer, dimension( * ) mval,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nout )

CCHKQRTP

Purpose:
!>
!> CCHKQRTP tests CTPQRT and CTPMQRT.
!>
Parameters
[in]THRESH
!>          THRESH is REAL
!>          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 cchkqrtp.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 REAL 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 REAL RESULT( NTESTS )
130* ..
131* .. External Subroutines ..
132 EXTERNAL alaerh, alahd, alasum, cerrqrtp
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 ) = 'C'
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 cerrqrtp( 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
176 DO k = 1, nnb
177 nb = nbval( k )
178*
179* Test CTPQRT and CTPMQRT
180*
181 IF( (nb.LE.n).AND.(nb.GT.0) ) THEN
182 CALL cqrt05( m, n, l, nb, result )
183*
184* Print information about the tests that did not
185* pass the threshold.
186*
187 DO t = 1, ntests
188 IF( result( t ).GE.thresh ) THEN
189 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
190 $ CALL alahd( nout, path )
191 WRITE( nout, fmt = 9999 )m, n, nb,
192 $ t, result( t )
193 nfail = nfail + 1
194 END IF
195 END DO
196 nrun = nrun + ntests
197 END IF
198 END DO
199 END DO
200 END DO
201 END DO
202*
203* Print a summary of the results.
204*
205 CALL alasum( path, nout, nfail, nrun, nerrs )
206*
207 9999 FORMAT( ' M=', i5, ', N=', i5, ', NB=', i4,
208 $ ' test(', i2, ')=', g12.5 )
209 RETURN
210*
211* End of CCHKQRTP
212*
cqrt05
subroutine cqrt05(m, n, l, nb, result)
CQRT05
Definition cqrt05.f:80
cerrqrtp
subroutine cerrqrtp(path, nunit)
CERRQRTP
Definition cerrqrtp.f:55

◆ cchkrfp()

program cchkrfp

CCHKRFP

Purpose:
!>
!> CCHKRFP is the main test program for the COMPLEX 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 cchkrfp.f.

◆ cchkrq()

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

CCHKRQ

Purpose:
!>
!> CCHKRQ tests CGERQF, CUNGRQ and CUNMRQ.
!>
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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AF
!>          AF is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AQ
!>          AQ is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AR
!>          AR is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AC
!>          AC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]TAU
!>          TAU is COMPLEX array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]RWORK
!>          RWORK is REAL 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 cchkrq.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 REAL THRESH
210* ..
211* .. Array Arguments ..
212 LOGICAL DOTYPE( * )
213 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
214 $ NXVAL( * )
215 REAL RWORK( * )
216 COMPLEX 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 REAL ZERO
228 parameter( zero = 0.0e0 )
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 REAL ANORM, CNDNUM
237* ..
238* .. Local Arrays ..
239 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
240 REAL RESULT( NTESTS )
241* ..
242* .. External Subroutines ..
243 EXTERNAL alaerh, alahd, alasum, cerrrq, cgerqs, cget02,
244 $ clacpy, clarhs, clatb4, clatms, crqt01, crqt02,
245 $ crqt03, xlaenv
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 ) = 'Complex 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 cerrrq( 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 CLATB4 and generate a test matrix
303* with CLATMS.
304*
305 CALL clatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
306 $ CNDNUM, DIST )
307*
308 srnamt = 'CLATMS'
309 CALL clatms( 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 CLATMS.
314*
315 IF( info.NE.0 ) THEN
316 CALL alaerh( path, 'CLATMS', 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 CRQT01; other values are
323* used in the calls of CRQT02, 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 CGERQF
358*
359 CALL crqt01( m, n, a, af, aq, ar, lda, tau,
360 $ work, lwork, rwork, result( 1 ) )
361 ELSE IF( m.LE.n ) THEN
362*
363* Test CUNGRQ, using factorization
364* returned by CRQT01
365*
366 CALL crqt02( 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 CUNMRQ, using factorization returned
372* by CRQT01
373*
374 CALL crqt03( 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 CGERQS 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 = 'CLARHS'
388 CALL clarhs( path, 'New', 'Full',
389 $ 'No transpose', m, n, 0, 0,
390 $ nrhs, a, lda, xact, lda, b, lda,
391 $ iseed, info )
392*
393 CALL clacpy( 'Full', m, nrhs, b, lda,
394 $ x( n-m+1 ), lda )
395 srnamt = 'CGERQS'
396 CALL cgerqs( m, n, nrhs, af, lda, tau, x,
397 $ lda, work, lwork, info )
398*
399* Check error code from CGERQS.
400*
401 IF( info.NE.0 )
402 $ CALL alaerh( path, 'CGERQS', info, 0, ' ',
403 $ m, n, nrhs, -1, nb, imat,
404 $ nfail, nerrs, nout )
405*
406 CALL cget02( '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 CCHKRQ
441*
cerrrq
subroutine cerrrq(path, nunit)
CERRRQ
Definition cerrrq.f:55
crqt01
subroutine crqt01(m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
CRQT01
Definition crqt01.f:126
crqt03
subroutine crqt03(m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
CRQT03
Definition crqt03.f:136
cgerqs
subroutine cgerqs(m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
CGERQS
Definition cgerqs.f:122
crqt02
subroutine crqt02(m, n, k, a, af, q, r, lda, tau, work, lwork, rwork, result)
CRQT02
Definition crqt02.f:136

◆ cchksp()

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

CCHKSP

Purpose:
!>
!> CCHKSP tests CSPTRF, -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 REAL
!>          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 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(2,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchksp.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 REAL THRESH
173* ..
174* .. Array Arguments ..
175 LOGICAL DOTYPE( * )
176 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
177 REAL RWORK( * )
178 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
179 $ WORK( * ), X( * ), XACT( * )
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 REAL ZERO
186 parameter( zero = 0.0e+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 REAL ANORM, CNDNUM, RCOND, RCONDC
200* ..
201* .. Local Arrays ..
202 CHARACTER UPLOS( 2 )
203 INTEGER ISEED( 4 ), ISEEDY( 4 )
204 REAL RESULT( NTESTS )
205* ..
206* .. External Functions ..
207 LOGICAL LSAME
208 REAL CLANSP, SGET06
209 EXTERNAL lsame, clansp, sget06
210* ..
211* .. External Subroutines ..
212 EXTERNAL alaerh, alahd, alasum, ccopy, cerrsy, cget04,
213 $ clacpy, clarhs, clatb4, clatms, clatsp, cppt05,
214 $ cspcon, csprfs, cspt01, cspt02, cspt03, csptrf,
215 $ csptri, csptrs
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 ) = 'Complex 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 cerrsy( 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 CLATB4 and generate a test
288* matrix with CLATMS.
289*
290 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
291 $ MODE, CNDNUM, DIST )
292*
293 srnamt = 'CLATMS'
294 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
295 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA,
296 $ WORK, INFO )
297*
298* Check error code from CLATMS.
299*
300 IF( info.NE.0 ) THEN
301 CALL alaerh( path, 'CLATMS', 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 clatsp( 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 ccopy( npp, a, 1, afac, 1 )
385 srnamt = 'CSPTRF'
386 CALL csptrf( 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 CSPTRF.
406*
407 IF( info.NE.k )
408 $ CALL alaerh( path, 'CSPTRF', 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 cspt01( 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 ccopy( npp, afac, 1, ainv, 1 )
428 srnamt = 'CSPTRI'
429 CALL csptri( uplo, n, ainv, iwork, work, info )
430*
431* Check error code from CSPTRI.
432*
433 IF( info.NE.0 )
434 $ CALL alaerh( path, 'CSPTRI', info, 0, uplo, n, n,
435 $ -1, -1, -1, imat, nfail, nerrs, nout )
436*
437 CALL cspt03( 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 = 'CLARHS'
470 CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
471 $ nrhs, a, lda, xact, lda, b, lda, iseed,
472 $ info )
473 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
474*
475 srnamt = 'CSPTRS'
476 CALL csptrs( uplo, n, nrhs, afac, iwork, x, lda,
477 $ info )
478*
479* Check error code from CSPTRS.
480*
481 IF( info.NE.0 )
482 $ CALL alaerh( path, 'CSPTRS', info, 0, uplo, n, n,
483 $ -1, -1, nrhs, imat, nfail, nerrs,
484 $ nout )
485*
486 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
487 CALL cspt02( 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 cget04( 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 = 'CSPRFS'
500 CALL csprfs( 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 CSPRFS.
505*
506 IF( info.NE.0 )
507 $ CALL alaerh( path, 'CSPRFS', info, 0, uplo, n, n,
508 $ -1, -1, nrhs, imat, nfail, nerrs,
509 $ nout )
510*
511 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
512 $ result( 5 ) )
513 CALL cppt05( 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 = clansp( '1', uplo, n, a, rwork )
537 srnamt = 'CSPCON'
538 CALL cspcon( uplo, n, afac, iwork, anorm, rcond, work,
539 $ info )
540*
541* Check error code from CSPCON.
542*
543 IF( info.NE.0 )
544 $ CALL alaerh( path, 'CSPCON', info, 0, uplo, n, n, -1,
545 $ -1, -1, imat, nfail, nerrs, nout )
546*
547 result( 8 ) = sget06( 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 CCHKSP
574*
clansp
real function clansp(norm, uplo, n, ap, work)
CLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clansp.f:115
csptri
subroutine csptri(uplo, n, ap, ipiv, work, info)
CSPTRI
Definition csptri.f:109
csptrf
subroutine csptrf(uplo, n, ap, ipiv, info)
CSPTRF
Definition csptrf.f:158
cspcon
subroutine cspcon(uplo, n, ap, ipiv, anorm, rcond, work, info)
CSPCON
Definition cspcon.f:118
csprfs
subroutine csprfs(uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CSPRFS
Definition csprfs.f:180
csptrs
subroutine csptrs(uplo, n, nrhs, ap, ipiv, b, ldb, info)
CSPTRS
Definition csptrs.f:115
cspt01
subroutine cspt01(uplo, n, a, afac, ipiv, c, ldc, rwork, resid)
CSPT01
Definition cspt01.f:112
cspt02
subroutine cspt02(uplo, n, nrhs, a, x, ldx, b, ldb, rwork, resid)
CSPT02
Definition cspt02.f:123
cspt03
subroutine cspt03(uplo, n, a, ainv, work, ldw, rwork, rcond, resid)
CSPT03
Definition cspt03.f:110
clatsp
subroutine clatsp(uplo, n, x, iseed)
CLATSP
Definition clatsp.f:84

◆ cchksy()

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

CCHKSY

Purpose:
!>
!> CCHKSY tests CSYTRF, -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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*max(2,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchksy.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 REAL THRESH
180* ..
181* .. Array Arguments ..
182 LOGICAL DOTYPE( * )
183 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
184 REAL RWORK( * )
185 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
186 $ WORK( * ), X( * ), XACT( * )
187* ..
188*
189* =====================================================================
190*
191* .. Parameters ..
192 REAL ZERO
193 parameter( zero = 0.0e+0 )
194 COMPLEX CZERO
195 parameter( czero = ( 0.0e+0, 0.0e+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 REAL ANORM, CNDNUM, RCOND, RCONDC
209* ..
210* .. Local Arrays ..
211 CHARACTER UPLOS( 2 )
212 INTEGER ISEED( 4 ), ISEEDY( 4 )
213 REAL RESULT( NTESTS )
214* ..
215* .. External Functions ..
216 REAL SGET06, CLANSY
217 EXTERNAL sget06, clansy
218* ..
219* .. External Subroutines ..
220 EXTERNAL alaerh, alahd, alasum, cerrsy, cget04, clacpy,
221 $ clarhs, clatb4, clatms, clatsy, cpot05, csycon,
222 $ csyrfs, csyt01, csyt02, csyt03, csytrf,
223 $ csytri2, csytrs, xlaenv
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 ) = 'Complex 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 cerrsy( 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 CLATB4 for the matrix generator
302* based on the type of matrix to be generated.
303*
304 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
305 $ MODE, CNDNUM, DIST )
306*
307* Generate a matrix with CLATMS.
308*
309 srnamt = 'CLATMS'
310 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
311 $ CNDNUM, ANORM, KL, KU, 'N', A, LDA, WORK,
312 $ INFO )
313*
314* Check error code from CLATMS and handle error.
315*
316 IF( info.NE.0 ) THEN
317 CALL alaerh( path, 'CLATMS', 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 clatsy( 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 clacpy( 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 = 'CSYTRF'
430 CALL csytrf( 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 CSYTRF and handle error.
451*
452 IF( info.NE.k )
453 $ CALL alaerh( path, 'CSYTRF', 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 csyt01( 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 clacpy( uplo, n, n, afac, lda, ainv, lda )
479 srnamt = 'CSYTRI2'
480 lwork = (n+nb+1)*(nb+3)
481 CALL csytri2( uplo, n, ainv, lda, iwork, work,
482 $ lwork, info )
483*
484* Check error code from CSYTRI2 and handle error.
485*
486 IF( info.NE.0 )
487 $ CALL alaerh( path, 'CSYTRI2', 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 csyt03( 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 = 'CLARHS'
538 CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
539 $ nrhs, a, lda, xact, lda, b, lda,
540 $ iseed, info )
541 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
542*
543 srnamt = 'CSYTRS'
544 CALL csytrs( uplo, n, nrhs, afac, lda, iwork, x,
545 $ lda, info )
546*
547* Check error code from CSYTRS and handle error.
548*
549 IF( info.NE.0 )
550 $ CALL alaerh( path, 'CSYTRS', info, 0, uplo, n,
551 $ n, -1, -1, nrhs, imat, nfail,
552 $ nerrs, nout )
553*
554 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
555*
556* Compute the residual for the solution
557*
558 CALL csyt02( 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 = 'CLARHS'
568 CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
569 $ nrhs, a, lda, xact, lda, b, lda,
570 $ iseed, info )
571 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
572*
573 srnamt = 'CSYTRS2'
574 CALL csytrs2( uplo, n, nrhs, afac, lda, iwork, x,
575 $ lda, work, info )
576*
577* Check error code from CSYTRS2 and handle error.
578*
579 IF( info.NE.0 )
580 $ CALL alaerh( path, 'CSYTRS2', info, 0, uplo, n,
581 $ n, -1, -1, nrhs, imat, nfail,
582 $ nerrs, nout )
583*
584 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
585*
586* Compute the residual for the solution
587*
588 CALL csyt02( uplo, n, nrhs, a, lda, x, lda, work,
589 $ lda, rwork, result( 4 ) )
590*
591*+ TEST 5
592* Check solution from generated exact solution.
593*
594 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
595 $ result( 5 ) )
596*
597*+ TESTS 6, 7, and 8
598* Use iterative refinement to improve the solution.
599*
600 srnamt = 'CSYRFS'
601 CALL csyrfs( uplo, n, nrhs, a, lda, afac, lda,
602 $ iwork, b, lda, x, lda, rwork,
603 $ rwork( nrhs+1 ), work,
604 $ rwork( 2*nrhs+1 ), info )
605*
606* Check error code from CSYRFS and handle error.
607*
608 IF( info.NE.0 )
609 $ CALL alaerh( path, 'CSYRFS', info, 0, uplo, n,
610 $ n, -1, -1, nrhs, imat, nfail,
611 $ nerrs, nout )
612*
613 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
614 $ result( 6 ) )
615 CALL cpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
616 $ xact, lda, rwork, rwork( nrhs+1 ),
617 $ result( 7 ) )
618*
619* Print information about the tests that did not pass
620* the threshold.
621*
622 DO 120 k = 3, 8
623 IF( result( k ).GE.thresh ) THEN
624 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
625 $ CALL alahd( nout, path )
626 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
627 $ imat, k, result( k )
628 nfail = nfail + 1
629 END IF
630 120 CONTINUE
631 nrun = nrun + 6
632*
633* End do for each value of NRHS in NSVAL.
634*
635 130 CONTINUE
636*
637*+ TEST 9
638* Get an estimate of RCOND = 1/CNDNUM.
639*
640 140 CONTINUE
641 anorm = clansy( '1', uplo, n, a, lda, rwork )
642 srnamt = 'CSYCON'
643 CALL csycon( uplo, n, afac, lda, iwork, anorm, rcond,
644 $ work, info )
645*
646* Check error code from CSYCON and handle error.
647*
648 IF( info.NE.0 )
649 $ CALL alaerh( path, 'CSYCON', info, 0, uplo, n, n,
650 $ -1, -1, -1, imat, nfail, nerrs, nout )
651*
652* Compute the test ratio to compare values of RCOND
653*
654 result( 9 ) = sget06( rcond, rcondc )
655*
656* Print information about the tests that did not pass
657* the threshold.
658*
659 IF( result( 9 ).GE.thresh ) THEN
660 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
661 $ CALL alahd( nout, path )
662 WRITE( nout, fmt = 9997 )uplo, n, imat, 9,
663 $ result( 9 )
664 nfail = nfail + 1
665 END IF
666 nrun = nrun + 1
667 150 CONTINUE
668 160 CONTINUE
669 170 CONTINUE
670 180 CONTINUE
671*
672* Print a summary of the results.
673*
674 CALL alasum( path, nout, nfail, nrun, nerrs )
675*
676 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
677 $ i2, ', test ', i2, ', ratio =', g12.5 )
678 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
679 $ i2, ', test(', i2, ') =', g12.5 )
680 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
681 $ ', test(', i2, ') =', g12.5 )
682 RETURN
683*
684* End of CCHKSY
685*
clansy
real function clansy(norm, uplo, n, a, lda, work)
CLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clansy.f:123
csytrs2
subroutine csytrs2(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, info)
CSYTRS2
Definition csytrs2.f:132
csytrs
subroutine csytrs(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
CSYTRS
Definition csytrs.f:120
csycon
subroutine csycon(uplo, n, a, lda, ipiv, anorm, rcond, work, info)
CSYCON
Definition csycon.f:125
csytrf
subroutine csytrf(uplo, n, a, lda, ipiv, work, lwork, info)
CSYTRF
Definition csytrf.f:182
csyrfs
subroutine csyrfs(uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CSYRFS
Definition csyrfs.f:192
csytri2
subroutine csytri2(uplo, n, a, lda, ipiv, work, lwork, info)
CSYTRI2
Definition csytri2.f:127
csyt03
subroutine csyt03(uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
CSYT03
Definition csyt03.f:126
clatsy
subroutine clatsy(uplo, n, x, ldx, iseed)
CLATSY
Definition clatsy.f:89
csyt01
subroutine csyt01(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
CSYT01
Definition csyt01.f:125
csyt02
subroutine csyt02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
CSYT02
Definition csyt02.f:127

◆ cchksy_aa()

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

CCHKSY_AA

Purpose:
!>
!> CCHKSY_AA tests CSYTRF_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 REAL
!>          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 REAL array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is REAL array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is REAL array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is REAL array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is REAL array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is REAL array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is REAL array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 167 of file cchksy_aa.f.

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

◆ cchksy_aa_2stage()

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

CCHKSY_AA_2STAGE

Purpose:
!>
!> CCHKSY_AA_2STAGE tests CSYTRF_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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is COMPLEX 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 cchksy_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 REAL THRESH
183* ..
184* .. Array Arguments ..
185 LOGICAL DOTYPE( * )
186 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
187 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
188 $ WORK( * ), X( * ), XACT( * )
189 REAL RWORK( * )
190* ..
191*
192* =====================================================================
193*
194* .. Parameters ..
195 COMPLEX CZERO
196 parameter( czero = ( 0.0e+0, 0.0e+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 REAL ANORM, CNDNUM
210* ..
211* .. Local Arrays ..
212 CHARACTER UPLOS( 2 )
213 INTEGER ISEED( 4 ), ISEEDY( 4 )
214 REAL RESULT( NTESTS )
215* ..
216* .. External Subroutines ..
217 EXTERNAL alaerh, alahd, alasum, cerrsy, clacpy, clarhs,
218 $ clatb4, clatms, csyt02, csyt01,
219 $ csytrf_aa_2stage, csytrs_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 ) = 'Complex precision'
245 path( 2: 3 ) = 'S2'
246*
247* Path to generate matrices
248*
249 matpath( 1: 1 ) = 'Complex 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 cerrsy( 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 CLATB4 for the matrix generator
310* based on the type of matrix to be generated.
311*
312 CALL clatb4( matpath, imat, n, n, TYPE, KL, KU,
313 $ ANORM, MODE, CNDNUM, DIST )
314*
315* Generate a matrix with CLATMS.
316*
317 srnamt = 'CLATMS'
318 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
319 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
320 $ INFO )
321*
322* Check error code from CLATMS and handle error.
323*
324 IF( info.NE.0 ) THEN
325 CALL alaerh( path, 'CLATMS', 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 clacpy( 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 = 'CSYTRF_AA_2STAGE'
427 lwork = min(n*nb, 3*nmax*nmax)
428 CALL csytrf_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 CSYTRF and handle error.
455*
456 IF( info.NE.k ) THEN
457 CALL alaerh( path, 'CSYTRF_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 CSYT01_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 = 'CLARHS'
503 CALL clarhs( matpath, xtype, uplo, ' ', n, n,
504 $ kl, ku, nrhs, a, lda, xact, lda,
505 $ b, lda, iseed, info )
506 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
507*
508 srnamt = 'CSYTRS_AA_2STAGE'
509 lwork = max( 1, 3*n-2 )
510 CALL csytrs_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 CSYTRS and handle error.
515*
516 IF( info.NE.0 ) THEN
517 IF( izero.EQ.0 ) THEN
518 CALL alaerh( path, 'CSYTRS_AA_2STAGE',
519 $ info, 0, uplo, n, n, -1, -1,
520 $ nrhs, imat, nfail, nerrs, nout )
521 END IF
522 ELSE
523 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda
524 $ )
525*
526* Compute the residual for the solution
527*
528 CALL csyt02( 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 CCHKSY_AA_2STAGE
569*
csytrf_aa_2stage
subroutine csytrf_aa_2stage(uplo, n, a, lda, tb, ltb, ipiv, ipiv2, work, lwork, info)
CSYTRF_AA_2STAGE
Definition csytrf_aa_2stage.f:160
csytrs_aa_2stage
subroutine csytrs_aa_2stage(uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, info)
CSYTRS_AA_2STAGE
Definition csytrs_aa_2stage.f:139

◆ cchksy_rk()

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

CCHKSY_RK

Purpose:
!>
!> CCHKSY_RK tests CSYTRF_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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]E
!>          E is COMPLEX array, dimension (NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchksy_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 REAL THRESH
186* ..
187* .. Array Arguments ..
188 LOGICAL DOTYPE( * )
189 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
190 REAL RWORK( * )
191 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
192 $ WORK( * ), X( * ), XACT( * )
193* ..
194*
195* =====================================================================
196*
197* .. Parameters ..
198 REAL ZERO, ONE
199 parameter( zero = 0.0e+0, one = 1.0e+0 )
200 REAL ONEHALF
201 parameter( onehalf = 0.5e+0 )
202 REAL EIGHT, SEVTEN
203 parameter( eight = 8.0e+0, sevten = 17.0e+0 )
204 COMPLEX CZERO
205 parameter( czero = ( 0.0e+0, 0.0e+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 REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
220 $ SING_MIN, RCOND, RCONDC, STEMP
221* ..
222* .. Local Arrays ..
223 CHARACTER UPLOS( 2 )
224 INTEGER ISEED( 4 ), ISEEDY( 4 )
225 REAL RESULT( NTESTS )
226 COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 )
227* ..
228* .. External Functions ..
229 REAL CLANGE, CLANSY, SGET06
230 EXTERNAL clange, clansy, sget06
231* ..
232* .. External Subroutines ..
233 EXTERNAL alaerh, alahd, alasum, cerrsy, cgesvd, cget04,
234 $ clacpy, clarhs, clatb4, clatms, clatsy, csyt02,
235 $ csyt03, csycon_3, csyt01_3, csytrf_rk,
236 $ csytri_3, csytrs_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 ) = 'Complex precision'
263 path( 2: 3 ) = 'SK'
264*
265* Path to generate matrices
266*
267 matpath( 1: 1 ) = 'Complex 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 cerrsy( 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 CLATB4 for the matrix generator
325* based on the type of matrix to be generated.
326*
327 CALL clatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
328 $ MODE, CNDNUM, DIST )
329*
330* Generate a matrix with CLATMS.
331*
332 srnamt = 'CLATMS'
333 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
334 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
335 $ WORK, INFO )
336*
337* Check error code from CLATMS and handle error.
338*
339 IF( info.NE.0 ) THEN
340 CALL alaerh( path, 'CLATMS', 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 clatsy( 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 clacpy( 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 = 'CSYTRF_RK'
453 CALL csytrf_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 CSYTRF_RK and handle error.
474*
475 IF( info.NE.k)
476 $ CALL alaerh( path, 'CSYTRF_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 csyt01_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 clacpy( uplo, n, n, afac, lda, ainv, lda )
503 srnamt = 'CSYTRI_3'
504*
505* Another reason that we need to compute the inverse
506* is that CSYT03 produces RCONDC which is used later
507* in TEST6 and TEST7.
508*
509 lwork = (n+nb+1)*(nb+3)
510 CALL csytri_3( uplo, n, ainv, lda, e, iwork, work,
511 $ lwork, info )
512*
513* Check error code from CSYTRI_3 and handle error.
514*
515 IF( info.NE.0 )
516 $ CALL alaerh( path, 'CSYTRI_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 csyt03( 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 stemp = 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 stemp = clange( '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 stemp = clange( 'M', k-2, 2,
573 $ afac( ( k-2 )*lda+1 ), lda, rwork )
574 k = k - 1
575*
576 END IF
577*
578* STEMP should be bounded by CONST
579*
580 stemp = stemp - const + thresh
581 IF( stemp.GT.result( 3 ) )
582 $ result( 3 ) = stemp
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 stemp = clange( '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 stemp = clange( 'M', n-k-1, 2,
611 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
612 k = k + 1
613*
614 END IF
615*
616* STEMP should be bounded by CONST
617*
618 stemp = stemp - const + thresh
619 IF( stemp.GT.result( 3 ) )
620 $ result( 3 ) = stemp
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 stemp = 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 cgesvd( 'N', 'N', 2, 2, block, 2, rwork,
660 $ cdummy, 1, cdummy, 1,
661 $ work, 6, rwork( 3 ), info )
662*
663*
664 sing_max = rwork( 1 )
665 sing_min = rwork( 2 )
666*
667 stemp = sing_max / sing_min
668*
669* STEMP should be bounded by CONST
670*
671 stemp = stemp - const + thresh
672 IF( stemp.GT.result( 4 ) )
673 $ result( 4 ) = stemp
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 cgesvd( 'N', 'N', 2, 2, block, 2, rwork,
704 $ cdummy, 1, cdummy, 1,
705 $ work, 6, rwork(3), info )
706*
707 sing_max = rwork( 1 )
708 sing_min = rwork( 2 )
709*
710 stemp = sing_max / sing_min
711*
712* STEMP should be bounded by CONST
713*
714 stemp = stemp - const + thresh
715 IF( stemp.GT.result( 4 ) )
716 $ result( 4 ) = stemp
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 = 'CLARHS'
766 CALL clarhs( matpath, xtype, uplo, ' ', n, n,
767 $ kl, ku, nrhs, a, lda, xact, lda,
768 $ b, lda, iseed, info )
769 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
770*
771 srnamt = 'CSYTRS_3'
772 CALL csytrs_3( uplo, n, nrhs, afac, lda, e, iwork,
773 $ x, lda, info )
774*
775* Check error code from CSYTRS_3 and handle error.
776*
777 IF( info.NE.0 )
778 $ CALL alaerh( path, 'CSYTRS_3', info, 0,
779 $ uplo, n, n, -1, -1, nrhs, imat,
780 $ nfail, nerrs, nout )
781*
782 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
783*
784* Compute the residual for the solution
785*
786 CALL csyt02( 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 cget04( 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 = clansy( '1', uplo, n, a, lda, rwork )
818 srnamt = 'CSYCON_3'
819 CALL csycon_3( uplo, n, afac, lda, e, iwork, anorm,
820 $ rcond, work, info )
821*
822* Check error code from CSYCON_3 and handle error.
823*
824 IF( info.NE.0 )
825 $ CALL alaerh( path, 'CSYCON_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 ) = sget06( 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 CCHKSY_RK
863*
csytrf_rk
subroutine csytrf_rk(uplo, n, a, lda, e, ipiv, work, lwork, info)
CSYTRF_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch...
Definition csytrf_rk.f:259
csytri_3
subroutine csytri_3(uplo, n, a, lda, e, ipiv, work, lwork, info)
CSYTRI_3
Definition csytri_3.f:170
csycon_3
subroutine csycon_3(uplo, n, a, lda, e, ipiv, anorm, rcond, work, info)
CSYCON_3
Definition csycon_3.f:166
csytrs_3
subroutine csytrs_3(uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info)
CSYTRS_3
Definition csytrs_3.f:165
csyt01_3
subroutine csyt01_3(uplo, n, a, lda, afac, ldafac, e, ipiv, c, ldc, rwork, resid)
CSYT01_3
Definition csyt01_3.f:141

◆ cchksy_rook()

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

CCHKSY_ROOK

Purpose:
!>
!> CCHKSY_ROOK tests CSYTRF_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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchksy_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 REAL THRESH
181* ..
182* .. Array Arguments ..
183 LOGICAL DOTYPE( * )
184 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
185 REAL RWORK( * )
186 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
187 $ WORK( * ), X( * ), XACT( * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 REAL ZERO, ONE
194 parameter( zero = 0.0e+0, one = 1.0e+0 )
195 REAL ONEHALF
196 parameter( onehalf = 0.5e+0 )
197 REAL EIGHT, SEVTEN
198 parameter( eight = 8.0e+0, sevten = 17.0e+0 )
199 COMPLEX CZERO
200 parameter( czero = ( 0.0e+0, 0.0e+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 REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
214 $ SING_MIN, RCOND, RCONDC, STEMP
215* ..
216* .. Local Arrays ..
217 CHARACTER UPLOS( 2 )
218 INTEGER ISEED( 4 ), ISEEDY( 4 )
219 REAL RESULT( NTESTS )
220 COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 )
221* ..
222* .. External Functions ..
223 REAL CLANGE, CLANSY, SGET06
224 EXTERNAL clange, clansy, sget06
225* ..
226* .. External Subroutines ..
227 EXTERNAL alaerh, alahd, alasum, cerrsy, cgesvd, cget04,
228 $ clacpy, clarhs, clatb4, clatms, clatsy, csyt02,
229 $ csyt03, csycon_rook, csyt01_rook, csytrf_rook,
230 $ csytri_rook, csytrs_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 ) = 'Complex precision'
257 path( 2: 3 ) = 'SR'
258*
259* Path to generate matrices
260*
261 matpath( 1: 1 ) = 'Complex 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 cerrsy( 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 CLATB4 for the matrix generator
319* based on the type of matrix to be generated.
320*
321 CALL clatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
322 $ MODE, CNDNUM, DIST )
323*
324* Generate a matrix with CLATMS.
325*
326 srnamt = 'CLATMS'
327 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
328 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
329 $ WORK, INFO )
330*
331* Check error code from CLATMS and handle error.
332*
333 IF( info.NE.0 ) THEN
334 CALL alaerh( path, 'CLATMS', 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 clatsy( 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 clacpy( 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 = 'CSYTRF_ROOK'
447 CALL csytrf_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 CSYTRF_ROOK and handle error.
468*
469 IF( info.NE.k)
470 $ CALL alaerh( path, 'CSYTRF_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 csyt01_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 clacpy( uplo, n, n, afac, lda, ainv, lda )
497 srnamt = 'CSYTRI_ROOK'
498 CALL csytri_rook( uplo, n, ainv, lda, iwork, work,
499 $ info )
500*
501* Check error code from CSYTRI_ROOK and handle error.
502*
503 IF( info.NE.0 )
504 $ CALL alaerh( path, 'CSYTRI_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 csyt03( 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 stemp = 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 stemp = clange( '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 stemp = clange( 'M', k-2, 2,
561 $ afac( ( k-2 )*lda+1 ), lda, rwork )
562 k = k - 1
563*
564 END IF
565*
566* STEMP should be bounded by CONST
567*
568 stemp = stemp - const + thresh
569 IF( stemp.GT.result( 3 ) )
570 $ result( 3 ) = stemp
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 stemp = clange( '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 stemp = clange( 'M', n-k-1, 2,
599 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
600 k = k + 1
601*
602 END IF
603*
604* STEMP should be bounded by CONST
605*
606 stemp = stemp - const + thresh
607 IF( stemp.GT.result( 3 ) )
608 $ result( 3 ) = stemp
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 stemp = 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 cgesvd( 'N', 'N', 2, 2, block, 2, rwork,
648 $ cdummy, 1, cdummy, 1,
649 $ work, 6, rwork( 3 ), info )
650*
651*
652 sing_max = rwork( 1 )
653 sing_min = rwork( 2 )
654*
655 stemp = sing_max / sing_min
656*
657* STEMP should be bounded by CONST
658*
659 stemp = stemp - const + thresh
660 IF( stemp.GT.result( 4 ) )
661 $ result( 4 ) = stemp
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 cgesvd( 'N', 'N', 2, 2, block, 2, rwork,
692 $ cdummy, 1, cdummy, 1,
693 $ work, 6, rwork(3), info )
694*
695 sing_max = rwork( 1 )
696 sing_min = rwork( 2 )
697*
698 stemp = sing_max / sing_min
699*
700* STEMP should be bounded by CONST
701*
702 stemp = stemp - const + thresh
703 IF( stemp.GT.result( 4 ) )
704 $ result( 4 ) = stemp
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 = 'CLARHS'
754 CALL clarhs( matpath, xtype, uplo, ' ', n, n,
755 $ kl, ku, nrhs, a, lda, xact, lda,
756 $ b, lda, iseed, info )
757 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
758*
759 srnamt = 'CSYTRS_ROOK'
760 CALL csytrs_rook( uplo, n, nrhs, afac, lda, iwork,
761 $ x, lda, info )
762*
763* Check error code from CSYTRS_ROOK and handle error.
764*
765 IF( info.NE.0 )
766 $ CALL alaerh( path, 'CSYTRS_ROOK', info, 0,
767 $ uplo, n, n, -1, -1, nrhs, imat,
768 $ nfail, nerrs, nout )
769*
770 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
771*
772* Compute the residual for the solution
773*
774 CALL csyt02( 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 cget04( 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 = clansy( '1', uplo, n, a, lda, rwork )
806 srnamt = 'CSYCON_ROOK'
807 CALL csycon_rook( uplo, n, afac, lda, iwork, anorm,
808 $ rcond, work, info )
809*
810* Check error code from CSYCON_ROOK and handle error.
811*
812 IF( info.NE.0 )
813 $ CALL alaerh( path, 'CSYCON_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 ) = sget06( 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 CCHKSY_ROOK
851*
csytrs_rook
subroutine csytrs_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
CSYTRS_ROOK
Definition csytrs_rook.f:136
csytrf_rook
subroutine csytrf_rook(uplo, n, a, lda, ipiv, work, lwork, info)
CSYTRF_ROOK
Definition csytrf_rook.f:208
csycon_rook
subroutine csycon_rook(uplo, n, a, lda, ipiv, anorm, rcond, work, info)
CSYCON_ROOK
Definition csycon_rook.f:139
csytri_rook
subroutine csytri_rook(uplo, n, a, lda, ipiv, work, info)
CSYTRI_ROOK
Definition csytri_rook.f:129
csyt01_rook
subroutine csyt01_rook(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
CSYT01_ROOK
Definition csyt01_rook.f:125

◆ cchktb()

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

CCHKTB

Purpose:
!>
!> CCHKTB tests CTBTRS, -RFS, and -CON, and CLATBS.
!>
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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchktb.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 REAL THRESH
158* ..
159* .. Array Arguments ..
160 LOGICAL DOTYPE( * )
161 INTEGER NSVAL( * ), NVAL( * )
162 REAL RWORK( * )
163 COMPLEX 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 REAL ONE, ZERO
177 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL RESULT( NTESTS )
192* ..
193* .. External Functions ..
194 LOGICAL LSAME
195 REAL CLANTB, CLANTR
196 EXTERNAL lsame, clantb, clantr
197* ..
198* .. External Subroutines ..
199 EXTERNAL alaerh, alahd, alasum, ccopy, cerrtr, cget04,
200 $ clacpy, clarhs, claset, clatbs, clattb, ctbcon,
201 $ ctbrfs, ctbsv, ctbt02, ctbt03, ctbt05, ctbt06,
202 $ ctbtrs
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 cmplx, 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 ) = 'Complex 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 cerrtr( 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 CLATTB to generate a triangular test matrix.
284*
285 srnamt = 'CLATTB'
286 CALL clattb( 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 claset( 'Full', n, n, cmplx( zero ),
301 $ cmplx( one ), ainv, lda )
302 IF( lsame( uplo, 'U' ) ) THEN
303 DO 20 j = 1, n
304 CALL ctbsv( 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 ctbsv( 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 = clantb( '1', uplo, diag, n, kd, ab, ldab,
318 $ rwork )
319 ainvnm = clantr( '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 = clantb( 'I', uplo, diag, n, kd, ab, ldab,
330 $ rwork )
331 ainvnm = clantr( '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 = 'CLARHS'
360 CALL clarhs( path, xtype, uplo, trans, n, n, kd,
361 $ idiag, nrhs, ab, ldab, xact, lda,
362 $ b, lda, iseed, info )
363 xtype = 'C'
364 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
365*
366 srnamt = 'CTBTRS'
367 CALL ctbtrs( uplo, trans, diag, n, kd, nrhs, ab,
368 $ ldab, x, lda, info )
369*
370* Check error code from CTBTRS.
371*
372 IF( info.NE.0 )
373 $ CALL alaerh( path, 'CTBTRS', info, 0,
374 $ uplo // trans // diag, n, n, kd,
375 $ kd, nrhs, imat, nfail, nerrs,
376 $ nout )
377*
378 CALL ctbt02( 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 cget04( 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 = 'CTBRFS'
393 CALL ctbrfs( 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 CTBRFS.
399*
400 IF( info.NE.0 )
401 $ CALL alaerh( path, 'CTBRFS', info, 0,
402 $ uplo // trans // diag, n, n, kd,
403 $ kd, nrhs, imat, nfail, nerrs,
404 $ nout )
405*
406 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
407 $ result( 3 ) )
408 CALL ctbt05( 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 = 'CTBCON'
441 CALL ctbcon( norm, uplo, diag, n, kd, ab, ldab,
442 $ rcond, work, rwork, info )
443*
444* Check error code from CTBCON.
445*
446 IF( info.NE.0 )
447 $ CALL alaerh( path, 'CTBCON', info, 0,
448 $ norm // uplo // diag, n, n, kd, kd,
449 $ -1, imat, nfail, nerrs, nout )
450*
451 CALL ctbt06( 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 ) 'CTBCON', 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 CLATBS.
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 CLATTB to generate a triangular test matrix.
489*
490 srnamt = 'CLATTB'
491 CALL clattb( 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 = 'CLATBS'
498 CALL ccopy( n, x, 1, b, 1 )
499 CALL clatbs( uplo, trans, diag, 'N', n, kd, ab,
500 $ ldab, b, scale, rwork, info )
501*
502* Check error code from CLATBS.
503*
504 IF( info.NE.0 )
505 $ CALL alaerh( path, 'CLATBS', info, 0,
506 $ uplo // trans // diag // 'N', n, n,
507 $ kd, kd, -1, imat, nfail, nerrs,
508 $ nout )
509*
510 CALL ctbt03( 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 ccopy( n, x, 1, b, 1 )
518 CALL clatbs( uplo, trans, diag, 'Y', n, kd, ab,
519 $ ldab, b, scale, rwork, info )
520*
521* Check error code from CLATBS.
522*
523 IF( info.NE.0 )
524 $ CALL alaerh( path, 'CLATBS', info, 0,
525 $ uplo // trans // diag // 'Y', n, n,
526 $ kd, kd, -1, imat, nfail, nerrs,
527 $ nout )
528*
529 CALL ctbt03( 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 )'CLATBS', 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 )'CLATBS', 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 CCHKTB
573*
clantr
real function clantr(norm, uplo, diag, m, n, a, lda, work)
CLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clantr.f:142
clatbs
subroutine clatbs(uplo, trans, diag, normin, n, kd, ab, ldab, x, scale, cnorm, info)
CLATBS solves a triangular banded system of equations.
Definition clatbs.f:243
clantb
real function clantb(norm, uplo, diag, n, k, ab, ldab, work)
CLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clantb.f:141
ctbcon
subroutine ctbcon(norm, uplo, diag, n, kd, ab, ldab, rcond, work, rwork, info)
CTBCON
Definition ctbcon.f:143
ctbrfs
subroutine ctbrfs(uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CTBRFS
Definition ctbrfs.f:188
ctbtrs
subroutine ctbtrs(uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, info)
CTBTRS
Definition ctbtrs.f:146
ctbsv
subroutine ctbsv(uplo, trans, diag, n, k, a, lda, x, incx)
CTBSV
Definition ctbsv.f:189
ctbt06
subroutine ctbt06(rcond, rcondc, uplo, diag, n, kd, ab, ldab, rwork, rat)
CTBT06
Definition ctbt06.f:126
cerrtr
subroutine cerrtr(path, nunit)
CERRTR
Definition cerrtr.f:54
clattb
subroutine clattb(imat, uplo, trans, diag, iseed, n, kd, ab, ldab, b, work, rwork, info)
CLATTB
Definition clattb.f:141
ctbt02
subroutine ctbt02(uplo, trans, diag, n, kd, nrhs, ab, ldab, x, ldx, b, ldb, work, rwork, resid)
CTBT02
Definition ctbt02.f:159
ctbt03
subroutine ctbt03(uplo, trans, diag, n, kd, nrhs, ab, ldab, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
CTBT03
Definition ctbt03.f:177
ctbt05
subroutine ctbt05(uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
CTBT05
Definition ctbt05.f:189

◆ cchktp()

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

CCHKTP

Purpose:
!>
!> CCHKTP tests CTPTRI, -TRS, -RFS, and -CON, and CLATPS
!>
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 REAL
!>          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 array, dimension (NMAX*(NMAX+1)/2)
!>
[out]AINVP
!>          AINVP is COMPLEX array, dimension (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchktp.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 REAL THRESH
160* ..
161* .. Array Arguments ..
162 LOGICAL DOTYPE( * )
163 INTEGER NSVAL( * ), NVAL( * )
164 REAL RWORK( * )
165 COMPLEX 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 REAL ONE, ZERO
179 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL RESULT( NTESTS )
193* ..
194* .. External Functions ..
195 LOGICAL LSAME
196 REAL CLANTP
197 EXTERNAL lsame, clantp
198* ..
199* .. External Subroutines ..
200 EXTERNAL alaerh, alahd, alasum, ccopy, cerrtr, cget04,
201 $ clacpy, clarhs, clatps, clattp, ctpcon, ctprfs,
202 $ ctpt01, ctpt02, ctpt03, ctpt05, ctpt06, ctptri,
203 $ ctptrs
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 ) = 'Complex 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 cerrtr( 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 CLATTP to generate a triangular test matrix.
263*
264 srnamt = 'CLATTP'
265 CALL clattp( 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 ccopy( lap, ap, 1, ainvp, 1 )
281 srnamt = 'CTPTRI'
282 CALL ctptri( uplo, diag, n, ainvp, info )
283*
284* Check error code from CTPTRI.
285*
286 IF( info.NE.0 )
287 $ CALL alaerh( path, 'CTPTRI', 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 = clantp( 'I', uplo, diag, n, ap, rwork )
293 ainvnm = clantp( '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 ctpt01( 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 = 'CLARHS'
338 CALL clarhs( path, xtype, uplo, trans, n, n, 0,
339 $ idiag, nrhs, ap, lap, xact, lda, b,
340 $ lda, iseed, info )
341 xtype = 'C'
342 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
343*
344 srnamt = 'CTPTRS'
345 CALL ctptrs( uplo, trans, diag, n, nrhs, ap, x,
346 $ lda, info )
347*
348* Check error code from CTPTRS.
349*
350 IF( info.NE.0 )
351 $ CALL alaerh( path, 'CTPTRS', info, 0,
352 $ uplo // trans // diag, n, n, -1,
353 $ -1, -1, imat, nfail, nerrs, nout )
354*
355 CALL ctpt02( 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 cget04( 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 = 'CTPRFS'
370 CALL ctprfs( 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 CTPRFS.
375*
376 IF( info.NE.0 )
377 $ CALL alaerh( path, 'CTPRFS', info, 0,
378 $ uplo // trans // diag, n, n, -1,
379 $ -1, nrhs, imat, nfail, nerrs,
380 $ nout )
381*
382 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
383 $ result( 4 ) )
384 CALL ctpt05( 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 = 'CTPCON'
416 CALL ctpcon( norm, uplo, diag, n, ap, rcond, work,
417 $ rwork, info )
418*
419* Check error code from CTPCON.
420*
421 IF( info.NE.0 )
422 $ CALL alaerh( path, 'CTPCON', info, 0,
423 $ norm // uplo // diag, n, n, -1, -1,
424 $ -1, imat, nfail, nerrs, nout )
425*
426 CALL ctpt06( 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 ) 'CTPCON', 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 CLATPS.
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 CLATTP to generate a triangular test matrix.
464*
465 srnamt = 'CLATTP'
466 CALL clattp( 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 = 'CLATPS'
473 CALL ccopy( n, x, 1, b, 1 )
474 CALL clatps( uplo, trans, diag, 'N', n, ap, b, scale,
475 $ rwork, info )
476*
477* Check error code from CLATPS.
478*
479 IF( info.NE.0 )
480 $ CALL alaerh( path, 'CLATPS', info, 0,
481 $ uplo // trans // diag // 'N', n, n,
482 $ -1, -1, -1, imat, nfail, nerrs, nout )
483*
484 CALL ctpt03( 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 ccopy( n, x, 1, b( n+1 ), 1 )
492 CALL clatps( uplo, trans, diag, 'Y', n, ap, b( n+1 ),
493 $ scale, rwork, info )
494*
495* Check error code from CLATPS.
496*
497 IF( info.NE.0 )
498 $ CALL alaerh( path, 'CLATPS', info, 0,
499 $ uplo // trans // diag // 'Y', n, n,
500 $ -1, -1, -1, imat, nfail, nerrs, nout )
501*
502 CALL ctpt03( 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 )'CLATPS', 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 )'CLATPS', 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 CCHKTP
546*
clatps
subroutine clatps(uplo, trans, diag, normin, n, ap, x, scale, cnorm, info)
CLATPS solves a triangular system of equations with the matrix held in packed storage.
Definition clatps.f:231
clantp
real function clantp(norm, uplo, diag, n, ap, work)
CLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clantp.f:125
ctprfs
subroutine ctprfs(uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CTPRFS
Definition ctprfs.f:174
ctptri
subroutine ctptri(uplo, diag, n, ap, info)
CTPTRI
Definition ctptri.f:117
ctptrs
subroutine ctptrs(uplo, trans, diag, n, nrhs, ap, b, ldb, info)
CTPTRS
Definition ctptrs.f:130
ctpcon
subroutine ctpcon(norm, uplo, diag, n, ap, rcond, work, rwork, info)
CTPCON
Definition ctpcon.f:130
ctpt01
subroutine ctpt01(uplo, diag, n, ap, ainvp, rcond, rwork, resid)
CTPT01
Definition ctpt01.f:109
clattp
subroutine clattp(imat, uplo, trans, diag, iseed, n, ap, b, work, rwork, info)
CLATTP
Definition clattp.f:131
ctpt05
subroutine ctpt05(uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
CTPT05
Definition ctpt05.f:175
ctpt03
subroutine ctpt03(uplo, trans, diag, n, nrhs, ap, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
CTPT03
Definition ctpt03.f:162
ctpt02
subroutine ctpt02(uplo, trans, diag, n, nrhs, ap, x, ldx, b, ldb, work, rwork, resid)
CTPT02
Definition ctpt02.f:147
ctpt06
subroutine ctpt06(rcond, rcondc, uplo, diag, n, ap, rwork, rat)
CTPT06
Definition ctpt06.f:112

◆ cchktr()

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

CCHKTR

Purpose:
!>
!> CCHKTR tests CTRTRI, -TRS, -RFS, and -CON, and CLATRS
!>
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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cchktr.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 REAL THRESH
172* ..
173* .. Array Arguments ..
174 LOGICAL DOTYPE( * )
175 INTEGER NBVAL( * ), NSVAL( * ), NVAL( * )
176 REAL RWORK( * )
177 COMPLEX 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 REAL ONE, ZERO
191 parameter( one = 1.0e0, zero = 0.0e0 )
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 REAL 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 REAL RESULT( NTESTS )
205* ..
206* .. External Functions ..
207 LOGICAL LSAME
208 REAL CLANTR
209 EXTERNAL lsame, clantr
210* ..
211* .. External Subroutines ..
212 EXTERNAL alaerh, alahd, alasum, ccopy, cerrtr, cget04,
213 $ clacpy, clarhs, clatrs, clattr, ctrcon, ctrrfs,
214 $ ctrt01, ctrt02, ctrt03, ctrt05, ctrt06, ctrtri,
215 $ ctrtrs, xlaenv
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 ) = 'Complex 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 cerrtr( 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 CLATTR to generate a triangular test matrix.
274*
275 srnamt = 'CLATTR'
276 CALL clattr( 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 clacpy( uplo, n, n, a, lda, ainv, lda )
298 srnamt = 'CTRTRI'
299 CALL ctrtri( uplo, diag, n, ainv, lda, info )
300*
301* Check error code from CTRTRI.
302*
303 IF( info.NE.0 )
304 $ CALL alaerh( path, 'CTRTRI', 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 = clantr( 'I', uplo, diag, n, n, a, lda, rwork )
311 ainvnm = clantr( '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 ctrt01( 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 = 'CLARHS'
362 CALL clarhs( path, xtype, uplo, trans, n, n, 0,
363 $ idiag, nrhs, a, lda, xact, lda, b,
364 $ lda, iseed, info )
365 xtype = 'C'
366 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
367*
368 srnamt = 'CTRTRS'
369 CALL ctrtrs( uplo, trans, diag, n, nrhs, a, lda,
370 $ x, lda, info )
371*
372* Check error code from CTRTRS.
373*
374 IF( info.NE.0 )
375 $ CALL alaerh( path, 'CTRTRS', 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 ctrt02( 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 cget04( 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 = 'CTRRFS'
400 CALL ctrrfs( 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 CTRRFS.
406*
407 IF( info.NE.0 )
408 $ CALL alaerh( path, 'CTRRFS', info, 0,
409 $ uplo // trans // diag, n, n, -1,
410 $ -1, nrhs, imat, nfail, nerrs,
411 $ nout )
412*
413 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
414 $ result( 4 ) )
415 CALL ctrt05( 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 = 'CTRCON'
447 CALL ctrcon( norm, uplo, diag, n, a, lda, rcond,
448 $ work, rwork, info )
449*
450* Check error code from CTRCON.
451*
452 IF( info.NE.0 )
453 $ CALL alaerh( path, 'CTRCON', info, 0,
454 $ norm // uplo // diag, n, n, -1, -1,
455 $ -1, imat, nfail, nerrs, nout )
456*
457 CALL ctrt06( 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 CLATRS.
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 CLATTR to generate a triangular test matrix.
496*
497 srnamt = 'CLATTR'
498 CALL clattr( 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 = 'CLATRS'
505 CALL ccopy( n, x, 1, b, 1 )
506 CALL clatrs( uplo, trans, diag, 'N', n, a, lda, b,
507 $ scale, rwork, info )
508*
509* Check error code from CLATRS.
510*
511 IF( info.NE.0 )
512 $ CALL alaerh( path, 'CLATRS', info, 0,
513 $ uplo // trans // diag // 'N', n, n,
514 $ -1, -1, -1, imat, nfail, nerrs, nout )
515*
516 CALL ctrt03( 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 ccopy( n, x, 1, b( n+1 ), 1 )
524 CALL clatrs( uplo, trans, diag, 'Y', n, a, lda,
525 $ b( n+1 ), scale, rwork, info )
526*
527* Check error code from CLATRS.
528*
529 IF( info.NE.0 )
530 $ CALL alaerh( path, 'CLATRS', info, 0,
531 $ uplo // trans // diag // 'Y', n, n,
532 $ -1, -1, -1, imat, nfail, nerrs, nout )
533*
534 CALL ctrt03( 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 )'CLATRS', 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 )'CLATRS', 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 CCHKTR
578*
clatrs
subroutine clatrs(uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info)
CLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
Definition clatrs.f:239
ctrtri
subroutine ctrtri(uplo, diag, n, a, lda, info)
CTRTRI
Definition ctrtri.f:109
ctrcon
subroutine ctrcon(norm, uplo, diag, n, a, lda, rcond, work, rwork, info)
CTRCON
Definition ctrcon.f:137
ctrrfs
subroutine ctrrfs(uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, ferr, berr, work, rwork, info)
CTRRFS
Definition ctrrfs.f:182
ctrtrs
subroutine ctrtrs(uplo, trans, diag, n, nrhs, a, lda, b, ldb, info)
CTRTRS
Definition ctrtrs.f:140
ctrt05
subroutine ctrt05(uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
CTRT05
Definition ctrt05.f:182
ctrt06
subroutine ctrt06(rcond, rcondc, uplo, diag, n, a, lda, rwork, rat)
CTRT06
Definition ctrt06.f:122
clattr
subroutine clattr(imat, uplo, trans, diag, iseed, n, a, lda, b, work, rwork, info)
CLATTR
Definition clattr.f:138
ctrt02
subroutine ctrt02(uplo, trans, diag, n, nrhs, a, lda, x, ldx, b, ldb, work, rwork, resid)
CTRT02
Definition ctrt02.f:155
ctrt01
subroutine ctrt01(uplo, diag, n, a, lda, ainv, ldainv, rcond, rwork, resid)
CTRT01
Definition ctrt01.f:125
ctrt03
subroutine ctrt03(uplo, trans, diag, n, nrhs, a, lda, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
CTRT03
Definition ctrt03.f:171

◆ cchktz()

subroutine cchktz ( logical, dimension( * ) dotype,
integer nm,
integer, dimension( * ) mval,
integer nn,
integer, dimension( * ) nval,
real thresh,
logical tsterr,
complex, dimension( * ) a,
complex, dimension( * ) copya,
real, dimension( * ) s,
complex, dimension( * ) tau,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer nout )

CCHKTZ

Purpose:
!>
!> CCHKTZ tests CTZRZF.
!>
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 REAL
!>          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 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 array, dimension (MMAX*NMAX)
!>
[out]S
!>          S is REAL array, dimension
!>                      (min(MMAX,NMAX))
!>
[out]TAU
!>          TAU is COMPLEX array, dimension (MMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (MMAX*NMAX + 4*NMAX + MMAX)
!>
[out]RWORK
!>          RWORK is REAL 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 cchktz.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 REAL THRESH
146* ..
147* .. Array Arguments ..
148 LOGICAL DOTYPE( * )
149 INTEGER MVAL( * ), NVAL( * )
150 REAL S( * ), RWORK( * )
151 COMPLEX 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 REAL ONE, ZERO
162 parameter( one = 1.0e0, zero = 0.0e0 )
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 REAL EPS
169* ..
170* .. Local Arrays ..
171 INTEGER ISEED( 4 ), ISEEDY( 4 )
172 REAL RESULT( NTESTS )
173* ..
174* .. External Functions ..
175 REAL CQRT12, CRZT01, CRZT02, SLAMCH
176 EXTERNAL cqrt12, crzt01, crzt02, slamch
177* ..
178* .. External Subroutines ..
179 EXTERNAL alahd, alasum, cerrtz, cgeqr2, clacpy, claset,
180 $ clatms, ctzrzf, slaord
181* ..
182* .. Intrinsic Functions ..
183 INTRINSIC cmplx, 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 ) = 'Complex 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 = slamch( 'Epsilon' )
210*
211* Test the error exits
212*
213 IF( tsterr )
214 $ CALL cerrtz( 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 CTZRZF
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 claset( 'Full', m, n, cmplx( zero ),
251 $ cmplx( zero ), a, lda )
252 DO 30 i = 1, mnmin
253 s( i ) = zero
254 30 CONTINUE
255 ELSE
256 CALL clatms( m, n, 'Uniform', iseed,
257 $ 'Nonsymmetric', s, imode,
258 $ one / eps, one, m, n, 'No packing', a,
259 $ lda, work, info )
260 CALL cgeqr2( m, n, a, lda, work, work( mnmin+1 ),
261 $ info )
262 CALL claset( 'Lower', m-1, n, cmplx( zero ),
263 $ cmplx( zero ), a( 2 ), lda )
264 CALL slaord( 'Decreasing', mnmin, s, 1 )
265 END IF
266*
267* Save A and its singular values
268*
269 CALL clacpy( 'All', m, n, a, lda, copya, lda )
270*
271* Call CTZRZF to reduce the upper trapezoidal matrix to
272* upper triangular form.
273*
274 srnamt = 'CTZRZF'
275 CALL ctzrzf( m, n, a, lda, tau, work, lwork, info )
276*
277* Compute norm(svd(a) - svd(r))
278*
279 result( 1 ) = cqrt12( m, m, a, lda, s, work,
280 $ lwork, rwork )
281*
282* Compute norm( A - R*Q )
283*
284 result( 2 ) = crzt01( m, n, copya, a, lda, tau, work,
285 $ lwork )
286*
287* Compute norm(Q'*Q - I).
288*
289 result( 3 ) = crzt02( 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 CCHKTZ
317*
cgeqr2
subroutine cgeqr2(m, n, a, lda, tau, work, info)
CGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
Definition cgeqr2.f:130
ctzrzf
subroutine ctzrzf(m, n, a, lda, tau, work, lwork, info)
CTZRZF
Definition ctzrzf.f:151
cerrtz
subroutine cerrtz(path, nunit)
CERRTZ
Definition cerrtz.f:54
crzt02
real function crzt02(m, n, af, lda, tau, work, lwork)
CRZT02
Definition crzt02.f:91
crzt01
real function crzt01(m, n, a, af, lda, tau, work, lwork)
CRZT01
Definition crzt01.f:98

◆ cchkunhr_col()

subroutine cchkunhr_col ( real thresh,
logical tsterr,
integer nm,
integer, dimension( * ) mval,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nout )

CCHKUNHR_COL

Purpose:
!>
!> CCHKUNHR_COL tests:
!>   1) CUNGTSQR and CUNHR_COL using CLATSQR, CGEMQRT,
!>   2) CUNGTSQR_ROW and CUNHR_COL inside CGETSQRHRT
!>      (which calls CLATSQR, CUNGTSQR_ROW and CUNHR_COL) using CGEMQRT.
!> Therefore, CLATSQR (part of CGEQR), CGEMQRT (part of CGEMQR)
!> have to be tested before this test.
!>
!>
Parameters
[in]THRESH
!>          THRESH is REAL
!>          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 cchkunhr_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 REAL 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 REAL RESULT( NTESTS )
136* ..
137* .. External Subroutines ..
138 EXTERNAL alahd, alasum, cerrunhr_col, cunhr_col01,
139 $ cunhr_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 ) = 'C'
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 cerrunhr_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 CUNHR_COL
204*
205 CALL cunhr_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 CUNHR_COL
266*
267 CALL cunhr_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( 'CUNGTSQR and CUNHR_COL: M=', i5, ', N=', i5,
297 $ ', MB1=', i5, ', NB1=', i5, ', NB2=', i5,
298 $ ' test(', i2, ')=', g12.5 )
299 9998 FORMAT( 'CUNGTSQR_ROW and CUNHR_COL: M=', i5, ', N=', i5,
300 $ ', MB1=', i5, ', NB1=', i5, ', NB2=', i5,
301 $ ' test(', i2, ')=', g12.5 )
302 RETURN
303*
304* End of CCHKUNHR_COL
305*
cerrunhr_col
subroutine cerrunhr_col(path, nunit)
CERRUNHR_COL
Definition cerrunhr_col.f:56
cunhr_col02
subroutine cunhr_col02(m, n, mb1, nb1, nb2, result)
CUNHR_COL02
Definition cunhr_col02.f:120
cunhr_col01
subroutine cunhr_col01(m, n, mb1, nb1, nb2, result)
CUNHR_COL01
Definition cunhr_col01.f:119

◆ cdrvgb()

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

CDRVGB

CDRVGBX

Purpose:
!>
!> CDRVGB tests the driver routines CGBSV 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 REAL
!>          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 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 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 array, dimension (LA)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is REAL array, dimension (2*NMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NRHS,NMAX))
!>
[out]RWORK
!>          RWORK is REAL 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:
!>
!> CDRVGB tests the driver routines CGBSV, -SVX, and -SVXX.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise cdrvgb.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 REAL
!>          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 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 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 array, dimension (LA)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is REAL array, dimension (2*NMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NRHS,NMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 cdrvgb.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 REAL THRESH
181* ..
182* .. Array Arguments ..
183 LOGICAL DOTYPE( * )
184 INTEGER IWORK( * ), NVAL( * )
185 REAL RWORK( * ), S( * )
186 COMPLEX A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
187 $ WORK( * ), X( * ), XACT( * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 REAL ONE, ZERO
194 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL RDUM( 1 ), RESULT( NTESTS )
218* ..
219* .. External Functions ..
220 LOGICAL LSAME
221 REAL CLANGB, CLANGE, CLANTB, SGET06, SLAMCH
222 EXTERNAL lsame, clangb, clange, clantb, sget06, slamch
223* ..
224* .. External Subroutines ..
225 EXTERNAL aladhd, alaerh, alasvm, cerrvx, cgbequ, cgbsv,
226 $ cgbsvx, cgbt01, cgbt02, cgbt05, cgbtrf, cgbtrs,
227 $ cget04, clacpy, claqgb, clarhs, claset, clatb4,
228 $ clatms, xlaenv
229* ..
230* .. Intrinsic Functions ..
231 INTRINSIC abs, cmplx, 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 ) = 'Complex 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 cerrvx( 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 CLATB4 and generate a
356* test matrix with CLATMS.
357*
358 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
359 $ MODE, CNDNUM, DIST )
360 rcondc = one / cndnum
361*
362 srnamt = 'CLATMS'
363 CALL clatms( 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 CLATMS.
368*
369 IF( info.NE.0 ) THEN
370 CALL alaerh( path, 'CLATMS', 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 clacpy( '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 SGESVX (FACT =
433* 'N' reuses the condition number from the
434* previous iteration with FACT = 'F').
435*
436 CALL clacpy( '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 cgbequ( 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 claqgb( 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 CGET04.
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 = clangb( '1', n, kl, ku, afb( kl+1 ),
478 $ ldafb, rwork )
479 anormi = clangb( 'I', n, kl, ku, afb( kl+1 ),
480 $ ldafb, rwork )
481*
482* Factor the matrix A.
483*
484 CALL cgbtrf( n, n, kl, ku, afb, ldafb, iwork,
485 $ info )
486*
487* Form the inverse of A.
488*
489 CALL claset( 'Full', n, n, cmplx( zero ),
490 $ cmplx( one ), work, ldb )
491 srnamt = 'CGBTRS'
492 CALL cgbtrs( '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 = clange( '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 = clange( '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 clacpy( '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 = 'CLARHS'
538 CALL clarhs( path, xtype, 'Full', trans, n,
539 $ n, kl, ku, nrhs, a, lda, xact,
540 $ ldb, b, ldb, iseed, info )
541 xtype = 'C'
542 CALL clacpy( 'Full', n, nrhs, b, ldb, bsav,
543 $ ldb )
544*
545 IF( nofact .AND. itran.EQ.1 ) THEN
546*
547* --- Test CGBSV ---
548*
549* Compute the LU factorization of the matrix
550* and solve the system.
551*
552 CALL clacpy( 'Full', kl+ku+1, n, a, lda,
553 $ afb( kl+1 ), ldafb )
554 CALL clacpy( 'Full', n, nrhs, b, ldb, x,
555 $ ldb )
556*
557 srnamt = 'CGBSV '
558 CALL cgbsv( n, kl, ku, nrhs, afb, ldafb,
559 $ iwork, x, ldb, info )
560*
561* Check error code from CGBSV .
562*
563 IF( info.NE.izero )
564 $ CALL alaerh( path, 'CGBSV ', 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 cgbt01( 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 clacpy( 'Full', n, nrhs, b, ldb,
582 $ work, ldb )
583 CALL cgbt02( '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 cget04( 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 )'CGBSV ',
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 CGBSVX ---
612*
613 IF( .NOT.prefac )
614 $ CALL claset( 'Full', 2*kl+ku+1, n,
615 $ cmplx( zero ), cmplx( zero ),
616 $ afb, ldafb )
617 CALL claset( 'Full', n, nrhs, cmplx( zero ),
618 $ cmplx( 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 claqgb( 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 CGBSVX.
631*
632 srnamt = 'CGBSVX'
633 CALL cgbsvx( 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 CGBSVX.
640*
641 IF( info.NE.izero )
642 $ CALL alaerh( path, 'CGBSVX', info, izero,
643 $ fact // trans, n, n, kl, ku,
644 $ nrhs, imat, nfail, nerrs,
645 $ nout )
646* Compare RWORK(2*NRHS+1) from CGBSVX 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 = clantb( '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 = clantb( 'M', 'U', 'N', n, kl+ku,
669 $ afb, ldafb, rdum )
670 IF( rpvgrw.EQ.zero ) THEN
671 rpvgrw = one
672 ELSE
673 rpvgrw = clangb( '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 ) / slamch( 'E' )
680*
681 IF( .NOT.prefac ) THEN
682*
683* Reconstruct matrix from factors and
684* compute residual.
685*
686 CALL cgbt01( 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 clacpy( 'Full', n, nrhs, bsav, ldb,
700 $ work, ldb )
701 CALL cgbt02( 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 cget04( 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 cget04( 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 cgbt05( 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 CGBSVX with the computed
735* value in RCONDC.
736*
737 result( 6 ) = sget06( 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 $ 'CGBSVX', fact, trans, n, kl,
750 $ ku, equed, imat, k,
751 $ result( k )
752 ELSE
753 WRITE( nout, fmt = 9996 )
754 $ 'CGBSVX', 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 )'CGBSVX',
768 $ fact, trans, n, kl, ku, equed,
769 $ imat, 1, result( 1 )
770 ELSE
771 WRITE( nout, fmt = 9996 )'CGBSVX',
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 )'CGBSVX',
783 $ fact, trans, n, kl, ku, equed,
784 $ imat, 6, result( 6 )
785 ELSE
786 WRITE( nout, fmt = 9996 )'CGBSVX',
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 )'CGBSVX',
798 $ fact, trans, n, kl, ku, equed,
799 $ imat, 7, result( 7 )
800 ELSE
801 WRITE( nout, fmt = 9996 )'CGBSVX',
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 CDRVGB, LA=', i5, ' is too small for N=', i5,
822 $ ', KU=', i5, ', KL=', i5, / ' ==> Increase LA to at least ',
823 $ i5 )
824 9998 FORMAT( ' *** In CDRVGB, 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 CDRVGB
838*
alasvm
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
Definition alasvm.f:73
aladhd
subroutine aladhd(iounit, path)
ALADHD
Definition aladhd.f:90
claqgb
subroutine claqgb(m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, equed)
CLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ.
Definition claqgb.f:160
cgbsvx
subroutine cgbsvx(fact, trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, equed, r, c, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
CGBSVX computes the solution to system of linear equations A * X = B for GB matrices
Definition cgbsvx.f:370
cgbsv
subroutine cgbsv(n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
CGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver)
Definition cgbsv.f:162
cerrvx
subroutine cerrvx(path, nunit)
CERRVX
Definition cerrvx.f:55

◆ cdrvge()

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

CDRVGE

CDRVGEX

Purpose:
!>
!> CDRVGE tests the driver routines CGESV 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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]ASAV
!>          ASAV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is REAL array, dimension (2*NMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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:
!>
!> CDRVGE tests the driver routines CGESV, -SVX, and -SVXX.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise cdrvge.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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]ASAV
!>          ASAV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is REAL array, dimension (2*NMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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 cdrvge.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 REAL THRESH
173* ..
174* .. Array Arguments ..
175 LOGICAL DOTYPE( * )
176 INTEGER IWORK( * ), NVAL( * )
177 REAL RWORK( * ), S( * )
178 COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ),
179 $ BSAV( * ), WORK( * ), X( * ), XACT( * )
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 REAL ONE, ZERO
186 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL RDUM( 1 ), RESULT( NTESTS )
209* ..
210* .. External Functions ..
211 LOGICAL LSAME
212 REAL CLANGE, CLANTR, SGET06, SLAMCH
213 EXTERNAL lsame, clange, clantr, sget06, slamch
214* ..
215* .. External Subroutines ..
216 EXTERNAL aladhd, alaerh, alasvm, cerrvx, cgeequ, cgesv,
217 $ cgesvx, cget01, cget02, cget04, cget07, cgetrf,
218 $ cgetri, clacpy, claqge, clarhs, claset, clatb4,
219 $ clatms, xlaenv
220* ..
221* .. Intrinsic Functions ..
222 INTRINSIC abs, cmplx, 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 ) = 'Complex 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 cerrvx( 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 CLATB4 and generate a test matrix
289* with CLATMS.
290*
291 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
292 $ CNDNUM, DIST )
293 rcondc = one / cndnum
294*
295 srnamt = 'CLATMS'
296 CALL clatms( 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 CLATMS.
301*
302 IF( info.NE.0 ) THEN
303 CALL alaerh( path, 'CLATMS', 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 claset( 'Full', n, n-izero+1, cmplx( zero ),
326 $ cmplx( 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 clacpy( '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 CGESVX (FACT = 'N' reuses
360* the condition number from the previous iteration
361* with FACT = 'F').
362*
363 CALL clacpy( '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 cgeequ( 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 claqge( 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 CGET04.
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 = clange( '1', n, n, afac, lda, rwork )
401 anormi = clange( 'I', n, n, afac, lda, rwork )
402*
403* Factor the matrix A.
404*
405 srnamt = 'CGETRF'
406 CALL cgetrf( n, n, afac, lda, iwork, info )
407*
408* Form the inverse of A.
409*
410 CALL clacpy( 'Full', n, n, afac, lda, a, lda )
411 lwork = nmax*max( 3, nrhs )
412 srnamt = 'CGETRI'
413 CALL cgetri( n, a, lda, iwork, work, lwork, info )
414*
415* Compute the 1-norm condition number of A.
416*
417 ainvnm = clange( '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 = clange( '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 clacpy( 'Full', n, n, asav, lda, a, lda )
448*
449* Form an exact solution and set the right hand side.
450*
451 srnamt = 'CLARHS'
452 CALL clarhs( path, xtype, 'Full', trans, n, n, kl,
453 $ ku, nrhs, a, lda, xact, lda, b, lda,
454 $ iseed, info )
455 xtype = 'C'
456 CALL clacpy( 'Full', n, nrhs, b, lda, bsav, lda )
457*
458 IF( nofact .AND. itran.EQ.1 ) THEN
459*
460* --- Test CGESV ---
461*
462* Compute the LU factorization of the matrix and
463* solve the system.
464*
465 CALL clacpy( 'Full', n, n, a, lda, afac, lda )
466 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
467*
468 srnamt = 'CGESV '
469 CALL cgesv( n, nrhs, afac, lda, iwork, x, lda,
470 $ info )
471*
472* Check error code from CGESV .
473*
474 IF( info.NE.izero )
475 $ CALL alaerh( path, 'CGESV ', 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 cget01( 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 clacpy( 'Full', n, nrhs, b, lda, work,
490 $ lda )
491 CALL cget02( '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 cget04( 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 )'CGESV ', 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 CGESVX ---
518*
519 IF( .NOT.prefac )
520 $ CALL claset( 'Full', n, n, cmplx( zero ),
521 $ cmplx( zero ), afac, lda )
522 CALL claset( 'Full', n, nrhs, cmplx( zero ),
523 $ cmplx( 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 claqge( 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 CGESVX.
535*
536 srnamt = 'CGESVX'
537 CALL cgesvx( 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 CGESVX.
544*
545 IF( info.NE.izero )
546 $ CALL alaerh( path, 'CGESVX', info, izero,
547 $ fact // trans, n, n, -1, -1, nrhs,
548 $ imat, nfail, nerrs, nout )
549*
550* Compare RWORK(2*NRHS+1) from CGESVX with the
551* computed reciprocal pivot growth factor RPVGRW
552*
553 IF( info.NE.0 .AND. info.LE.n) THEN
554 rpvgrw = clantr( 'M', 'U', 'N', info, info,
555 $ afac, lda, rdum )
556 IF( rpvgrw.EQ.zero ) THEN
557 rpvgrw = one
558 ELSE
559 rpvgrw = clange( 'M', n, info, a, lda,
560 $ rdum ) / rpvgrw
561 END IF
562 ELSE
563 rpvgrw = clantr( 'M', 'U', 'N', n, n, afac, lda,
564 $ rdum )
565 IF( rpvgrw.EQ.zero ) THEN
566 rpvgrw = one
567 ELSE
568 rpvgrw = clange( '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 $ slamch( 'E' )
575*
576 IF( .NOT.prefac ) THEN
577*
578* Reconstruct matrix from factors and compute
579* residual.
580*
581 CALL cget01( 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 clacpy( 'Full', n, nrhs, bsav, lda, work,
594 $ lda )
595 CALL cget02( 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 cget04( 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 cget04( 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 cget07( 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 CGESVX with the computed value
626* in RCONDC.
627*
628 result( 6 ) = sget06( 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 )'CGESVX',
640 $ fact, trans, n, equed, imat, k,
641 $ result( k )
642 ELSE
643 WRITE( nout, fmt = 9998 )'CGESVX',
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 )'CGESVX', fact,
657 $ trans, n, equed, imat, 1, result( 1 )
658 ELSE
659 WRITE( nout, fmt = 9998 )'CGESVX', 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 )'CGESVX', fact,
670 $ trans, n, equed, imat, 6, result( 6 )
671 ELSE
672 WRITE( nout, fmt = 9998 )'CGESVX', 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 )'CGESVX', fact,
683 $ trans, n, equed, imat, 7, result( 7 )
684 ELSE
685 WRITE( nout, fmt = 9998 )'CGESVX', 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 CDRVGE
714*
claqge
subroutine claqge(m, n, a, lda, r, c, rowcnd, colcnd, amax, equed)
CLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sgeequ.
Definition claqge.f:143
cgesv
subroutine cgesv(n, nrhs, a, lda, ipiv, b, ldb, info)
CGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver)
Definition cgesv.f:122
cgesvx
subroutine cgesvx(fact, trans, n, nrhs, a, lda, af, ldaf, ipiv, equed, r, c, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
CGESVX computes the solution to system of linear equations A * X = B for GE matrices
Definition cgesvx.f:350

◆ cdrvgt()

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

CDRVGT

Purpose:
!>
!> CDRVGT tests CGTSV 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 REAL
!>          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 array, dimension (NMAX*4)
!>
[out]AF
!>          AF is COMPLEX array, dimension (NMAX*4)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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 cdrvgt.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 REAL THRESH
148* ..
149* .. Array Arguments ..
150 LOGICAL DOTYPE( * )
151 INTEGER IWORK( * ), NVAL( * )
152 REAL RWORK( * )
153 COMPLEX A( * ), AF( * ), B( * ), WORK( * ), X( * ),
154 $ XACT( * )
155* ..
156*
157* =====================================================================
158*
159* .. Parameters ..
160 REAL ONE, ZERO
161 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL RESULT( NTESTS ), Z( 3 )
181* ..
182* .. External Functions ..
183 REAL CLANGT, SCASUM, SGET06
184 EXTERNAL clangt, scasum, sget06
185* ..
186* .. External Subroutines ..
187 EXTERNAL aladhd, alaerh, alasvm, ccopy, cerrvx, cget04,
188 $ cgtsv, cgtsvx, cgtt01, cgtt02, cgtt05, cgttrf,
189 $ cgttrs, clacpy, clagtm, clarnv, claset, clatb4,
190 $ clatms, csscal
191* ..
192* .. Intrinsic Functions ..
193 INTRINSIC cmplx, 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 ) = 'Complex 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 cerrvx( 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 CLATB4.
244*
245 CALL clatb4( 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 = 'CLATMS'
255 CALL clatms( 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 CLATMS.
260*
261 IF( info.NE.0 ) THEN
262 CALL alaerh( path, 'CLATMS', 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 ccopy( n-1, af( 4 ), 3, a, 1 )
270 CALL ccopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
271 END IF
272 CALL ccopy( 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 clarnv( 2, iseed, n+2*m, a )
283 IF( anorm.NE.one )
284 $ CALL csscal( 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 CGTSVX.
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 ccopy( n+2*m, a, 1, af, 1 )
352*
353* Compute the 1-norm and infinity-norm of A.
354*
355 anormo = clangt( '1', n, a, a( m+1 ), a( n+m+1 ) )
356 anormi = clangt( 'I', n, a, a( m+1 ), a( n+m+1 ) )
357*
358* Factor the matrix A.
359*
360 CALL cgttrf( n, af, af( m+1 ), af( n+m+1 ),
361 $ af( n+2*m+1 ), iwork, info )
362*
363* Use CGTTRS 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 cgttrs( '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, scasum( 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 CGTTRS 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 cgttrs( '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, scasum( 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 clarnv( 2, iseed, n, xact( ix ) )
423 ix = ix + lda
424 70 CONTINUE
425*
426* Set the right hand side.
427*
428 CALL clagtm( 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 CGTSV ---
434*
435* Solve the system using Gaussian elimination with
436* partial pivoting.
437*
438 CALL ccopy( n+2*m, a, 1, af, 1 )
439 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
440*
441 srnamt = 'CGTSV '
442 CALL cgtsv( n, nrhs, af, af( m+1 ), af( n+m+1 ), x,
443 $ lda, info )
444*
445* Check error code from CGTSV .
446*
447 IF( info.NE.izero )
448 $ CALL alaerh( path, 'CGTSV ', 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 clacpy( 'Full', n, nrhs, b, lda, work,
457 $ lda )
458 CALL cgtt02( 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 cget04( 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 )'CGTSV ', 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 CGTSVX ---
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 claset( 'Full', n, nrhs, cmplx( zero ),
495 $ cmplx( zero ), x, lda )
496*
497* Solve the system and compute the condition number and
498* error bounds using CGTSVX.
499*
500 srnamt = 'CGTSVX'
501 CALL cgtsvx( 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 CGTSVX.
508*
509 IF( info.NE.izero )
510 $ CALL alaerh( path, 'CGTSVX', 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 cgtt01( 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 clacpy( 'Full', n, nrhs, b, lda, work, lda )
533 CALL cgtt02( 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 cget04( n, nrhs, x, lda, xact, lda, rcondc,
540 $ result( 3 ) )
541*
542* Check the error bounds from iterative refinement.
543*
544 CALL cgtt05( 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 )'CGTSVX', 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 ) = sget06( 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 )'CGTSVX', 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 CDRVGT
591*
cgtsv
subroutine cgtsv(n, nrhs, dl, d, du, b, ldb, info)
CGTSV computes the solution to system of linear equations A * X = B for GT matrices
Definition cgtsv.f:124
cgtsvx
subroutine cgtsvx(fact, trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
CGTSVX computes the solution to system of linear equations A * X = B for GT matrices
Definition cgtsvx.f:294

◆ cdrvhe()

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

CDRVHE

CDRVHEX

Purpose:
!>
!> CDRVHE tests the driver routines CHESV 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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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:
!>
!> CDRVHE tests the driver routines CHESV, -SVX, and -SVXX.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise cdrvhe.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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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 cdrvhe.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 REAL THRESH
162* ..
163* .. Array Arguments ..
164 LOGICAL DOTYPE( * )
165 INTEGER IWORK( * ), NVAL( * )
166 REAL RWORK( * )
167 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
168 $ WORK( * ), X( * ), XACT( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 REAL ONE, ZERO
175 parameter( one = 1.0e+0, zero = 0.0e+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 REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC
189* ..
190* .. Local Arrays ..
191 CHARACTER FACTS( NFACT ), UPLOS( 2 )
192 INTEGER ISEED( 4 ), ISEEDY( 4 )
193 REAL RESULT( NTESTS )
194* ..
195* .. External Functions ..
196 REAL CLANHE, SGET06
197 EXTERNAL clanhe, sget06
198* ..
199* .. External Subroutines ..
200 EXTERNAL aladhd, alaerh, alasvm, cerrvx, cget04, chesv,
201 $ chesvx, chet01, chetrf, chetri2, clacpy,
202 $ claipd, clarhs, claset, clatb4, clatms, cpot02,
203 $ cpot05, xlaenv
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 cmplx, 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 ) = 'Complex 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 cerrvx( 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 CLATB4 and generate a test matrix
277* with CLATMS.
278*
279 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
280 $ CNDNUM, DIST )
281*
282 srnamt = 'CLATMS'
283 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
284 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
285 $ INFO )
286*
287* Check error code from CLATMS.
288*
289 IF( info.NE.0 ) THEN
290 CALL alaerh( path, 'CLATMS', 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 claipd( 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 CHESVX.
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 = clanhe( '1', uplo, n, a, lda, rwork )
385*
386* Factor the matrix A.
387*
388 CALL clacpy( uplo, n, n, a, lda, afac, lda )
389 CALL chetrf( uplo, n, afac, lda, iwork, work,
390 $ lwork, info )
391*
392* Compute inv(A) and take its norm.
393*
394 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
395 lwork = (n+nb+1)*(nb+3)
396 CALL chetri2( uplo, n, ainv, lda, iwork, work,
397 $ lwork, info )
398 ainvnm = clanhe( '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 = 'CLARHS'
412 CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
413 $ nrhs, a, lda, xact, lda, b, lda, iseed,
414 $ info )
415 xtype = 'C'
416*
417* --- Test CHESV ---
418*
419 IF( ifact.EQ.2 ) THEN
420 CALL clacpy( uplo, n, n, a, lda, afac, lda )
421 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
422*
423* Factor the matrix and solve the system using CHESV.
424*
425 srnamt = 'CHESV '
426 CALL chesv( 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 CHESV .
447*
448 IF( info.NE.k ) THEN
449 CALL alaerh( path, 'CHESV ', 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 chet01( uplo, n, a, lda, afac, lda, iwork,
461 $ ainv, lda, rwork, result( 1 ) )
462*
463* Compute residual of the computed solution.
464*
465 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
466 CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
467 $ lda, rwork, result( 2 ) )
468*
469* Check solution from generated exact solution.
470*
471 CALL cget04( 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 )'CHESV ', 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 CHESVX ---
492*
493 IF( ifact.EQ.2 )
494 $ CALL claset( uplo, n, n, cmplx( zero ),
495 $ cmplx( zero ), afac, lda )
496 CALL claset( 'Full', n, nrhs, cmplx( zero ),
497 $ cmplx( zero ), x, lda )
498*
499* Solve the system and compute the condition number and
500* error bounds using CHESVX.
501*
502 srnamt = 'CHESVX'
503 CALL chesvx( 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 CHESVX.
526*
527 IF( info.NE.k ) THEN
528 CALL alaerh( path, 'CHESVX', 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 chet01( 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 clacpy( 'Full', n, nrhs, b, lda, work, lda )
551 CALL cpot02( 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 cget04( n, nrhs, x, lda, xact, lda, rcondc,
557 $ result( 3 ) )
558*
559* Check the error bounds from iterative refinement.
560*
561 CALL cpot05( 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 CHESVX with the computed value
569* in RCONDC.
570*
571 result( 6 ) = sget06( 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 )'CHESVX', 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 CDRVHE
604*
chesvx
subroutine chesvx(fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, lwork, rwork, info)
CHESVX computes the solution to system of linear equations A * X = B for HE matrices
Definition chesvx.f:285
chesv
subroutine chesv(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
CHESV computes the solution to system of linear equations A * X = B for HE matrices
Definition chesv.f:171

◆ cdrvhe_aa()

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

CDRVHE_AA

Purpose:
!>
!> CDRVHE_AA tests the driver routine CHESV_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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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 cdrvhe_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 REAL THRESH
162* ..
163* .. Array Arguments ..
164 LOGICAL DOTYPE( * )
165 INTEGER IWORK( * ), NVAL( * )
166 REAL RWORK( * )
167 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
168 $ WORK( * ), X( * ), XACT( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 REAL ONE, ZERO
175 parameter( one = 1.0e+0, zero = 0.0e+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 REAL ANORM, CNDNUM
189* ..
190* .. Local Arrays ..
191 CHARACTER FACTS( NFACT ), UPLOS( 2 )
192 INTEGER ISEED( 4 ), ISEEDY( 4 )
193 REAL RESULT( NTESTS )
194* ..
195* .. External Functions ..
196 REAL CLANHE, SGET06
197 EXTERNAL clanhe, sget06
198* ..
199* .. External Subroutines ..
200 EXTERNAL aladhd, alaerh, alasvm, xlaenv, cerrvx,
201 $ cget04, clacpy, clarhs, clatb4, clatms,
202 $ chesv_aa, chet01_aa, cpot02,
203 $ chetrf_aa
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 cmplx, 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 ) = 'Complex precision'
228 path( 2: 3 ) = 'HA'
229*
230* Path to generate matrices
231*
232 matpath( 1: 1 ) = 'Complex 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 cerrvx( 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 CLATB4 for the matrix generator
288* based on the type of matrix to be generated.
289*
290 CALL clatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
291 $ MODE, CNDNUM, DIST )
292*
293* Generate a matrix with CLATMS.
294*
295 srnamt = 'CLATMS'
296 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
297 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
298 $ WORK, INFO )
299*
300* Check error code from CLATMS and handle error.
301*
302 IF( info.NE.0 ) THEN
303 CALL alaerh( path, 'CLATMS', 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 = 'CLARHS'
389 CALL clarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
390 $ nrhs, a, lda, xact, lda, b, lda, iseed,
391 $ info )
392 xtype = 'C'
393*
394* --- Test CHESV_AA ---
395*
396 IF( ifact.EQ.2 ) THEN
397 CALL clacpy( uplo, n, n, a, lda, afac, lda )
398 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
399*
400* Factor the matrix and solve the system using CHESV_AA.
401*
402 srnamt = 'CHESV_AA '
403 CALL chesv_aa( uplo, n, nrhs, afac, lda, iwork,
404 $ x, lda, work, lwork, info )
405*
406* Adjust the expected value of INFO to account for
407* pivoting.
408*
409 IF( izero.GT.0 ) THEN
410 j = 1
411 k = izero
412 100 CONTINUE
413 IF( j.EQ.k ) THEN
414 k = iwork( j )
415 ELSE IF( iwork( j ).EQ.k ) THEN
416 k = j
417 END IF
418 IF( j.LT.k ) THEN
419 j = j + 1
420 GO TO 100
421 END IF
422 ELSE
423 k = 0
424 END IF
425*
426* Check error code from CHESV_AA .
427*
428 IF( info.NE.k ) THEN
429 CALL alaerh( path, 'CHESV_AA', info, k,
430 $ uplo, n, n, -1, -1, nrhs,
431 $ imat, nfail, nerrs, nout )
432 GO TO 120
433 ELSE IF( info.NE.0 ) THEN
434 GO TO 120
435 END IF
436*
437* Reconstruct matrix from factors and compute
438* residual.
439*
440 CALL chet01_aa( uplo, n, a, lda, afac, lda,
441 $ iwork, ainv, lda, rwork,
442 $ result( 1 ) )
443*
444* Compute residual of the computed solution.
445*
446 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
447 CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
448 $ lda, rwork, result( 2 ) )
449 nt = 2
450*
451* Print information about the tests that did not pass
452* the threshold.
453*
454 DO 110 k = 1, nt
455 IF( result( k ).GE.thresh ) THEN
456 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
457 $ CALL aladhd( nout, path )
458 WRITE( nout, fmt = 9999 )'CHESV_AA ',
459 $ uplo, n, imat, k, result( k )
460 nfail = nfail + 1
461 END IF
462 110 CONTINUE
463 nrun = nrun + nt
464 120 CONTINUE
465 END IF
466*
467 150 CONTINUE
468*
469 160 CONTINUE
470 170 CONTINUE
471 180 CONTINUE
472*
473* Print a summary of the results.
474*
475 CALL alasvm( path, nout, nfail, nrun, nerrs )
476*
477 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
478 $ ', test ', i2, ', ratio =', g12.5 )
479 RETURN
480*
481* End of CDRVHE_AA
482*
chesv_aa
subroutine chesv_aa(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
CHESV_AA computes the solution to system of linear equations A * X = B for HE matrices
Definition chesv_aa.f:162

◆ cdrvhe_aa_2stage()

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

CDRVHE_AA_2STAGE

Purpose:
!>
!> CDRVHE_AA_2STAGE tests the driver routine CHESV_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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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 cdrvhe_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 REAL THRESH
164* ..
165* .. Array Arguments ..
166 LOGICAL DOTYPE( * )
167 INTEGER IWORK( * ), NVAL( * )
168 REAL RWORK( * )
169 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
170 $ WORK( * ), X( * ), XACT( * )
171* ..
172*
173* =====================================================================
174*
175* .. Parameters ..
176 REAL ONE, ZERO
177 parameter( one = 1.0e+0, zero = 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 REAL ANORM, CNDNUM
191* ..
192* .. Local Arrays ..
193 CHARACTER FACTS( NFACT ), UPLOS( 2 )
194 INTEGER ISEED( 4 ), ISEEDY( 4 )
195 REAL RESULT( NTESTS )
196* ..
197* .. External Functions ..
198 REAL CLANHE, SGET06
199 EXTERNAL clanhe, sget06
200* ..
201* .. External Subroutines ..
202 EXTERNAL aladhd, alaerh, alasvm, xlaenv, cerrvx,
203 $ cget04, clacpy, clarhs, clatb4, clatms,
204 $ chesv_aa_2stage, cpot02,
205 $ chetrf_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 cmplx, 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 ) = 'Complex precision'
230 path( 2: 3 ) = 'H2'
231*
232* Path to generate matrices
233*
234 matpath( 1: 1 ) = 'Complex 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 cerrvx( 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 CLATB4 for the matrix generator
288* based on the type of matrix to be generated.
289*
290 CALL clatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
291 $ MODE, CNDNUM, DIST )
292*
293* Generate a matrix with CLATMS.
294*
295 srnamt = 'CLATMS'
296 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
297 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
298 $ WORK, INFO )
299*
300* Check error code from CLATMS and handle error.
301*
302 IF( info.NE.0 ) THEN
303 CALL alaerh( path, 'CLATMS', 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 = 'CLARHS'
389 CALL clarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
390 $ nrhs, a, lda, xact, lda, b, lda, iseed,
391 $ info )
392 xtype = 'C'
393*
394* --- Test CHESV_AA_2STAGE ---
395*
396 IF( ifact.EQ.2 ) THEN
397 CALL clacpy( uplo, n, n, a, lda, afac, lda )
398 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
399*
400* Factor the matrix and solve the system using CHESV_AA.
401*
402 srnamt = 'CHESV_AA_2STAGE '
403 lwork = min(n*nb, 3*nmax*nmax)
404 CALL chesv_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 CHESV_AA .
430*
431 IF( info.NE.k ) THEN
432 CALL alaerh( path, 'CHESV_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 clacpy( 'Full', n, nrhs, b, lda, work, lda )
443 CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
444 $ lda, rwork, result( 1 ) )
445*
446* Reconstruct matrix from factors and compute
447* residual.
448*
449c CALL CHET01_AA( UPLO, N, A, LDA, AFAC, LDA,
450c $ IWORK, AINV, LDA, RWORK,
451c $ RESULT( 2 ) )
452c NT = 2
453 nt = 1
454*
455* Print information about the tests that did not pass
456* the threshold.
457*
458 DO 110 k = 1, nt
459 IF( result( k ).GE.thresh ) THEN
460 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
461 $ CALL aladhd( nout, path )
462 WRITE( nout, fmt = 9999 )'CHESV_AA ',
463 $ uplo, n, imat, k, result( k )
464 nfail = nfail + 1
465 END IF
466 110 CONTINUE
467 nrun = nrun + nt
468 120 CONTINUE
469 END IF
470*
471 150 CONTINUE
472*
473 160 CONTINUE
474 170 CONTINUE
475 180 CONTINUE
476*
477* Print a summary of the results.
478*
479 CALL alasvm( path, nout, nfail, nrun, nerrs )
480*
481 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
482 $ ', test ', i2, ', ratio =', g12.5 )
483 RETURN
484*
485* End of CDRVHE_AA_2STAGE
486*
chesv_aa_2stage
subroutine chesv_aa_2stage(uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, work, lwork, info)
CHESV_AA_2STAGE computes the solution to system of linear equations A * X = B for HE matrices
Definition chesv_aa_2stage.f:186

◆ cdrvhe_rk()

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

CDRVHE_RK

Purpose:
!>
!> CDRVHE_RK tests the driver routines CHESV_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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]E
!>          E is COMPLEX array, dimension (NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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 cdrvhe_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 REAL THRESH
167* ..
168* .. Array Arguments ..
169 LOGICAL DOTYPE( * )
170 INTEGER IWORK( * ), NVAL( * )
171 REAL RWORK( * )
172 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
173 $ WORK( * ), X( * ), XACT( * )
174* ..
175*
176* =====================================================================
177*
178* .. Parameters ..
179 REAL ONE, ZERO
180 parameter( one = 1.0e+0, zero = 0.0e+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 REAL AINVNM, ANORM, CNDNUM, RCONDC
194* ..
195* .. Local Arrays ..
196 CHARACTER FACTS( NFACT ), UPLOS( 2 )
197 INTEGER ISEED( 4 ), ISEEDY( 4 )
198 REAL RESULT( NTESTS )
199
200* ..
201* .. External Functions ..
202 REAL CLANHE
203 EXTERNAL clanhe
204* ..
205* .. External Subroutines ..
206 EXTERNAL aladhd, alaerh, alasvm, xlaenv, cerrvx, cget04,
207 $ clacpy, clarhs, clatb4, clatms, chesv_rk,
208 $ chet01_3, cpot02, chetrf_rk, chetri_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 ) = 'Complex precision'
233 path( 2: 3 ) = 'HK'
234*
235* Path to generate matrices
236*
237 matpath( 1: 1 ) = 'Complex 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 cerrvx( 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 CLATB4 for the matrix generator
293* based on the type of matrix to be generated.
294*
295 CALL clatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
296 $ MODE, CNDNUM, DIST )
297*
298* Generate a matrix with CLATMS.
299*
300 srnamt = 'CLATMS'
301 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
302 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
303 $ WORK, INFO )
304*
305* Check error code from CLATMS and handle error.
306*
307 IF( info.NE.0 ) THEN
308 CALL alaerh( path, 'CLATMS', 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 = clanhe( '1', uplo, n, a, lda, rwork )
402*
403* Factor the matrix A.
404*
405 CALL clacpy( uplo, n, n, a, lda, afac, lda )
406 CALL chetrf_rk( uplo, n, afac, lda, e, iwork, work,
407 $ lwork, info )
408*
409* Compute inv(A) and take its norm.
410*
411 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
412 lwork = (n+nb+1)*(nb+3)
413*
414* We need to compute the inverse to compute
415* RCONDC that is used later in TEST3.
416*
417 CALL csytri_3( uplo, n, ainv, lda, e, iwork,
418 $ work, lwork, info )
419 ainvnm = clanhe( '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 = 'CLARHS'
433 CALL clarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
434 $ nrhs, a, lda, xact, lda, b, lda, iseed,
435 $ info )
436 xtype = 'C'
437*
438* --- Test CHESV_RK ---
439*
440 IF( ifact.EQ.2 ) THEN
441 CALL clacpy( uplo, n, n, a, lda, afac, lda )
442 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
443*
444* Factor the matrix and solve the system using
445* CHESV_RK.
446*
447 srnamt = 'CHESV_RK'
448 CALL chesv_rk( uplo, n, nrhs, afac, lda, e, 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 CHESV_RK and handle error.
469*
470 IF( info.NE.k ) THEN
471 CALL alaerh( path, 'CHESV_RK', 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 chet01_3( uplo, n, a, lda, afac, lda, e,
483 $ iwork, ainv, lda, rwork,
484 $ result( 1 ) )
485*
486*+ TEST 2 Compute residual of the computed solution.
487*
488 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
489 CALL cpot02( 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 cget04( 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 )'CHESV_RK', 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 CDRVHE_RK
530*
chesv_rk
subroutine chesv_rk(uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work, lwork, info)
CHESV_RK computes the solution to system of linear equations A * X = B for SY matrices
Definition chesv_rk.f:228

◆ cdrvhe_rook()

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

CDRVHE_ROOK

Purpose:
!>
!> CDRVHE_ROOK tests the driver routines CHESV_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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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 cdrvhe_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 REAL THRESH
162* ..
163* .. Array Arguments ..
164 LOGICAL DOTYPE( * )
165 INTEGER IWORK( * ), NVAL( * )
166 REAL RWORK( * )
167 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
168 $ WORK( * ), X( * ), XACT( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 REAL ONE, ZERO
175 parameter( one = 1.0e+0, zero = 0.0e+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 REAL AINVNM, ANORM, CNDNUM, RCONDC
189* ..
190* .. Local Arrays ..
191 CHARACTER FACTS( NFACT ), UPLOS( 2 )
192 INTEGER ISEED( 4 ), ISEEDY( 4 )
193 REAL RESULT( NTESTS )
194
195* ..
196* .. External Functions ..
197 REAL CLANHE
198 EXTERNAL clanhe
199* ..
200* .. External Subroutines ..
201 EXTERNAL aladhd, alaerh, alasvm, xlaenv, cerrvx,
202 $ cget04, clacpy, clarhs, clatb4, clatms,
203 $ chesv_rook, chet01_rook, cpot02,
204 $ chetrf_rook, chetri_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 ) = 'Complex precision'
229 path( 2: 3 ) = 'HR'
230*
231* Path to generate matrices
232*
233 matpath( 1: 1 ) = 'Complex 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 cerrvx( 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 CLATB4 for the matrix generator
289* based on the type of matrix to be generated.
290*
291 CALL clatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
292 $ MODE, CNDNUM, DIST )
293*
294* Generate a matrix with CLATMS.
295*
296 srnamt = 'CLATMS'
297 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
298 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
299 $ WORK, INFO )
300*
301* Check error code from CLATMS and handle error.
302*
303 IF( info.NE.0 ) THEN
304 CALL alaerh( path, 'CLATMS', 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 CHESVX_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 = clanhe( '1', uplo, n, a, lda, rwork )
399*
400* Factor the matrix A.
401*
402 CALL clacpy( uplo, n, n, a, lda, afac, lda )
403 CALL chetrf_rook( uplo, n, afac, lda, iwork, work,
404 $ lwork, info )
405*
406* Compute inv(A) and take its norm.
407*
408 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
409 lwork = (n+nb+1)*(nb+3)
410 CALL chetri_rook( uplo, n, ainv, lda, iwork,
411 $ work, info )
412 ainvnm = clanhe( '1', uplo, n, ainv, lda, rwork )
413*
414* Compute the 1-norm condition number of A.
415*
416 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
417 rcondc = one
418 ELSE
419 rcondc = ( one / anorm ) / ainvnm
420 END IF
421 END IF
422*
423* Form an exact solution and set the right hand side.
424*
425 srnamt = 'CLARHS'
426 CALL clarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
427 $ nrhs, a, lda, xact, lda, b, lda, iseed,
428 $ info )
429 xtype = 'C'
430*
431* --- Test CHESV_ROOK ---
432*
433 IF( ifact.EQ.2 ) THEN
434 CALL clacpy( uplo, n, n, a, lda, afac, lda )
435 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
436*
437* Factor the matrix and solve the system using
438* CHESV_ROOK.
439*
440 srnamt = 'CHESV_ROOK'
441 CALL chesv_rook( uplo, n, nrhs, afac, lda, iwork,
442 $ x, lda, work, 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 CHESV_ROOK and handle error.
462*
463 IF( info.NE.k ) THEN
464 CALL alaerh( path, 'CHESV_ROOK', info, k, uplo,
465 $ n, n, -1, -1, nrhs, imat, nfail,
466 $ nerrs, nout )
467 GO TO 120
468 ELSE IF( info.NE.0 ) THEN
469 GO TO 120
470 END IF
471*
472*+ TEST 1 Reconstruct matrix from factors and compute
473* residual.
474*
475 CALL chet01_rook( uplo, n, a, lda, afac, lda,
476 $ iwork, ainv, lda, rwork,
477 $ result( 1 ) )
478*
479*+ TEST 2 Compute residual of the computed solution.
480*
481 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
482 CALL cpot02( uplo, n, nrhs, a, lda, x, lda, work,
483 $ lda, rwork, result( 2 ) )
484*
485*+ TEST 3
486* Check solution from generated exact solution.
487*
488 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
489 $ result( 3 ) )
490 nt = 3
491*
492* Print information about the tests that did not pass
493* the threshold.
494*
495 DO 110 k = 1, nt
496 IF( result( k ).GE.thresh ) THEN
497 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
498 $ CALL aladhd( nout, path )
499 WRITE( nout, fmt = 9999 )'CHESV_ROOK', uplo,
500 $ n, imat, k, result( k )
501 nfail = nfail + 1
502 END IF
503 110 CONTINUE
504 nrun = nrun + nt
505 120 CONTINUE
506 END IF
507*
508 150 CONTINUE
509*
510 160 CONTINUE
511 170 CONTINUE
512 180 CONTINUE
513*
514* Print a summary of the results.
515*
516 CALL alasvm( path, nout, nfail, nrun, nerrs )
517*
518 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
519 $ ', test ', i2, ', ratio =', g12.5 )
520 RETURN
521*
522* End of CDRVHE_ROOK
523*
chesv_rook
subroutine chesv_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
CHESV_ROOK computes the solution to a system of linear equations A * X = B for HE matrices using the ...
Definition chesv_rook.f:205

◆ cdrvhp()

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

CDRVHP

Purpose:
!>
!> CDRVHP tests the driver routines CHPSV 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 REAL
!>          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 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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 cdrvhp.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 REAL THRESH
166* ..
167* .. Array Arguments ..
168 LOGICAL DOTYPE( * )
169 INTEGER IWORK( * ), NVAL( * )
170 REAL RWORK( * )
171 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
172 $ WORK( * ), X( * ), XACT( * )
173* ..
174*
175* =====================================================================
176*
177* .. Parameters ..
178 REAL ONE, ZERO
179 parameter( one = 1.0e+0, zero = 0.0e+0 )
180 INTEGER NTYPES, NTESTS
181 parameter( ntypes = 10, ntests = 6 )
182 INTEGER NFACT
183 parameter( nfact = 2 )
184* ..
185* .. 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 REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC
193* ..
194* .. Local Arrays ..
195 CHARACTER FACTS( NFACT )
196 INTEGER ISEED( 4 ), ISEEDY( 4 )
197 REAL RESULT( NTESTS )
198* ..
199* .. External Functions ..
200 REAL CLANHP, SGET06
201 EXTERNAL clanhp, sget06
202* ..
203* .. External Subroutines ..
204 EXTERNAL aladhd, alaerh, alasvm, ccopy, cerrvx, cget04,
205 $ chpsv, chpsvx, chpt01, chptrf, chptri, clacpy,
206 $ claipd, clarhs, claset, clatb4, clatms, cppt02,
207 $ cppt05, xlaenv
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 facts / 'F', 'N' /
224* ..
225* .. Executable Statements ..
226*
227* Initialize constants and the random number seed.
228*
229 path( 1: 1 ) = 'C'
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 cerrvx( 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 CLATB4 and generate a test matrix
287* with CLATMS.
288*
289 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
290 $ CNDNUM, DIST )
291*
292 srnamt = 'CLATMS'
293 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
294 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
295 $ INFO )
296*
297* Check error code from CLATMS.
298*
299 IF( info.NE.0 ) THEN
300 CALL alaerh( path, 'CLATMS', 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 claipd( n, a, 2, 1 )
376 ELSE
377 CALL claipd( 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 CHPSVX.
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 = clanhp( '1', uplo, n, a, rwork )
399*
400* Factor the matrix A.
401*
402 CALL ccopy( npp, a, 1, afac, 1 )
403 CALL chptrf( uplo, n, afac, iwork, info )
404*
405* Compute inv(A) and take its norm.
406*
407 CALL ccopy( npp, afac, 1, ainv, 1 )
408 CALL chptri( uplo, n, ainv, iwork, work, info )
409 ainvnm = clanhp( '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 = 'CLARHS'
423 CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
424 $ nrhs, a, lda, xact, lda, b, lda, iseed,
425 $ info )
426 xtype = 'C'
427*
428* --- Test CHPSV ---
429*
430 IF( ifact.EQ.2 ) THEN
431 CALL ccopy( npp, a, 1, afac, 1 )
432 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
433*
434* Factor the matrix and solve the system using CHPSV.
435*
436 srnamt = 'CHPSV '
437 CALL chpsv( 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 CHPSV .
458*
459 IF( info.NE.k ) THEN
460 CALL alaerh( path, 'CHPSV ', 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 chpt01( uplo, n, a, afac, iwork, ainv, lda,
472 $ rwork, result( 1 ) )
473*
474* Compute residual of the computed solution.
475*
476 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
477 CALL cppt02( uplo, n, nrhs, a, x, lda, work, lda,
478 $ rwork, result( 2 ) )
479*
480* Check solution from generated exact solution.
481*
482 CALL cget04( 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 )'CHPSV ', 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 CHPSVX ---
503*
504 IF( ifact.EQ.2 .AND. npp.GT.0 )
505 $ CALL claset( 'Full', npp, 1, cmplx( zero ),
506 $ cmplx( zero ), afac, npp )
507 CALL claset( 'Full', n, nrhs, cmplx( zero ),
508 $ cmplx( zero ), x, lda )
509*
510* Solve the system and compute the condition number and
511* error bounds using CHPSVX.
512*
513 srnamt = 'CHPSVX'
514 CALL chpsvx( 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 CHPSVX.
537*
538 IF( info.NE.k ) THEN
539 CALL alaerh( path, 'CHPSVX', 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 chpt01( 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 clacpy( 'Full', n, nrhs, b, lda, work, lda )
561 CALL cppt02( 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 cget04( n, nrhs, x, lda, xact, lda, rcondc,
567 $ result( 3 ) )
568*
569* Check the error bounds from iterative refinement.
570*
571 CALL cppt05( 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 CHPSVX with the computed value
579* in RCONDC.
580*
581 result( 6 ) = sget06( 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 )'CHPSVX', 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 CDRVHP
614*
chpsv
subroutine chpsv(uplo, n, nrhs, ap, ipiv, b, ldb, info)
CHPSV computes the solution to system of linear equations A * X = B for OTHER matrices
Definition chpsv.f:162
chpsvx
subroutine chpsvx(fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
CHPSVX computes the solution to system of linear equations A * X = B for OTHER matrices
Definition chpsvx.f:277

◆ cdrvls()

subroutine cdrvls ( 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,
real thresh,
logical tsterr,
complex, dimension( * ) a,
complex, dimension( * ) copya,
complex, dimension( * ) b,
complex, dimension( * ) copyb,
complex, dimension( * ) c,
real, dimension( * ) s,
real, dimension( * ) copys,
integer nout )

CDRVLS

Purpose:
!>
!> CDRVLS tests the least squares driver routines CGELS, CGETSLS, CGELSS, CGELSY
!> and CGELSD.
!>
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 REAL
!>          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 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 array, dimension (MMAX*NMAX)
!>
[out]B
!>          B is COMPLEX 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 array, dimension (MMAX*NSMAX)
!>
[out]C
!>          C is COMPLEX array, dimension (MMAX*NSMAX)
!>
[out]S
!>          S is REAL array, dimension
!>                      (min(MMAX,NMAX))
!>
[out]COPYS
!>          COPYS is REAL 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 cdrvls.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 REAL THRESH
201* ..
202* .. Array Arguments ..
203 LOGICAL DOTYPE( * )
204 INTEGER MVAL( * ), NBVAL( * ), NSVAL( * ),
205 $ NVAL( * ), NXVAL( * )
206 REAL COPYS( * ), S( * )
207 COMPLEX 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 REAL ONE, ZERO
218 parameter( one = 1.0e+0, zero = 0.0e+0 )
219 COMPLEX CONE, CZERO
220 parameter( cone = ( 1.0e+0, 0.0e+0 ),
221 $ czero = ( 0.0e+0, 0.0e+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_CGELS, LWORK_CGETSLS, LWORK_CGELSS,
232 $ LWORK_CGELSY, LWORK_CGELSD,
233 $ LRWORK_CGELSY, LRWORK_CGELSS, LRWORK_CGELSD
234 REAL EPS, NORMA, NORMB, RCOND
235* ..
236* .. Local Arrays ..
237 INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ( 1 )
238 REAL RESULT( NTESTS ), RWQ( 1 )
239 COMPLEX WQ( 1 )
240* ..
241* .. Allocatable Arrays ..
242 COMPLEX, ALLOCATABLE :: WORK (:)
243 REAL, ALLOCATABLE :: RWORK (:), WORK2 (:)
244 INTEGER, ALLOCATABLE :: IWORK (:)
245* ..
246* .. External Functions ..
247 REAL CQRT12, CQRT14, CQRT17, SASUM, SLAMCH
248 EXTERNAL cqrt12, cqrt14, cqrt17, sasum, slamch
249* ..
250* .. External Subroutines ..
251 EXTERNAL alaerh, alahd, alasvm, cerrls, cgels, cgelsd,
252 $ cgelss, cgelsy, cgemm, cgetsls, clacpy,
253 $ clarnv, cqrt13, cqrt15, cqrt16, csscal,
254 $ saxpy, xlaenv
255* ..
256* .. Intrinsic Functions ..
257 INTRINSIC max, min, int, real, 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 ) = 'Complex 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 = slamch( '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 cerrls( 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* CQRT14, CQRT17 (two side cases), CQRT15 and CQRT12
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 CGELS
361 CALL cgels( trans, m, n, nrhs, a, lda,
362 $ b, ldb, wq, -1, info )
363 lwork_cgels = int( wq( 1 ) )
364* Compute workspace needed for CGETSLS
365 CALL cgetsls( trans, m, n, nrhs, a, lda,
366 $ b, ldb, wq, -1, info )
367 lwork_cgetsls = int( wq( 1 ) )
368 ENDDO
369 END IF
370* Compute workspace needed for CGELSY
371 CALL cgelsy( m, n, nrhs, a, lda, b, ldb,
372 $ iwq, rcond, crank, wq, -1, rwq,
373 $ info )
374 lwork_cgelsy = int( wq( 1 ) )
375 lrwork_cgelsy = 2*n
376* Compute workspace needed for CGELSS
377 CALL cgelss( m, n, nrhs, a, lda, b, ldb, s,
378 $ rcond, crank, wq, -1, rwq, info )
379 lwork_cgelss = int( wq( 1 ) )
380 lrwork_cgelss = 5*mnmin
381* Compute workspace needed for CGELSD
382 CALL cgelsd( m, n, nrhs, a, lda, b, ldb, s,
383 $ rcond, crank, wq, -1, rwq, iwq,
384 $ info )
385 lwork_cgelsd = int( wq( 1 ) )
386 lrwork_cgelsd = int( rwq( 1 ) )
387* Compute LIWORK workspace needed for CGELSY and CGELSD
388 liwork = max( liwork, n, iwq( 1 ) )
389* Compute LRWORK workspace needed for CGELSY, CGELSS and CGELSD
390 lrwork = max( lrwork, lrwork_cgelsy,
391 $ lrwork_cgelss, lrwork_cgelsd )
392* Compute LWORK workspace needed for all functions
393 lwork = max( lwork, lwork_cgels, lwork_cgetsls,
394 $ lwork_cgelsy, lwork_cgelss,
395 $ lwork_cgelsd )
396 END IF
397 ENDDO
398 ENDDO
399 ENDDO
400 ENDDO
401 ENDDO
402*
403 lwlsy = lwork
404*
405 ALLOCATE( work( lwork ) )
406 ALLOCATE( iwork( liwork ) )
407 ALLOCATE( rwork( lrwork ) )
408 ALLOCATE( work2( 2 * lwork ) )
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 CGELS
432*
433* Generate a matrix of scaling type ISCALE
434*
435 CALL cqrt13( 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 clarnv( 2, iseed, ncols*nrhs,
458 $ work )
459 CALL csscal( ncols*nrhs,
460 $ one / real( ncols ), work,
461 $ 1 )
462 END IF
463 CALL cgemm( trans, 'No transpose', nrows,
464 $ nrhs, ncols, cone, copya, lda,
465 $ work, ldwork, czero, b, ldb )
466 CALL clacpy( '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 clacpy( 'Full', m, n, copya, lda,
473 $ a, lda )
474 CALL clacpy( 'Full', nrows, nrhs,
475 $ copyb, ldb, b, ldb )
476 END IF
477 srnamt = 'CGELS '
478 CALL cgels( trans, m, n, nrhs, a, lda, b,
479 $ ldb, work, lwork, info )
480*
481 IF( info.NE.0 )
482 $ CALL alaerh( path, 'CGELS ', 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 clacpy( 'Full', nrows, nrhs,
492 $ copyb, ldb, c, ldb )
493 CALL cqrt16( 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 ) = cqrt17( 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 ) = cqrt14( 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 CGETSLS
534*
535* Generate a matrix of scaling type ISCALE
536*
537 CALL cqrt13( 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 clarnv( 2, iseed, ncols*nrhs,
562 $ work )
563 CALL cscal( ncols*nrhs,
564 $ cone / real( ncols ), work,
565 $ 1 )
566 END IF
567 CALL cgemm( trans, 'No transpose', nrows,
568 $ nrhs, ncols, cone, copya, lda,
569 $ work, ldwork, czero, b, ldb )
570 CALL clacpy( '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 clacpy( 'Full', m, n, copya, lda,
577 $ a, lda )
578 CALL clacpy( 'Full', nrows, nrhs,
579 $ copyb, ldb, b, ldb )
580 END IF
581 srnamt = 'CGETSLS '
582 CALL cgetsls( trans, m, n, nrhs, a,
583 $ lda, b, ldb, work, lwork, info )
584 IF( info.NE.0 )
585 $ CALL alaerh( path, 'CGETSLS ', 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 clacpy( 'Full', nrows, nrhs,
595 $ copyb, ldb, c, ldb )
596 CALL cqrt16( 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 ) = cqrt17( 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 ) = cqrt14( 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 cqrt15( 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 CGELSY
656*
657* CGELSY: Compute the minimum-norm solution
658* X to min( norm( A * X - B ) )
659* using the rank-revealing orthogonal
660* factorization.
661*
662 CALL clacpy( 'Full', m, n, copya, lda, a, lda )
663 CALL clacpy( '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 = 'CGELSY'
673 CALL cgelsy( 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, 'CGELSY', 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 ) = cqrt12( 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 clacpy( 'Full', m, nrhs, copyb, ldb, work,
693 $ ldwork )
694 CALL cqrt16( '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 ) = cqrt17( '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 ) = cqrt14( 'No transpose', m, n,
714 $ nrhs, copya, lda, b, ldb,
715 $ work, lwork )
716*
717* Test CGELSS
718*
719* CGELSS: Compute the minimum-norm solution
720* X to min( norm( A * X - B ) )
721* using the SVD.
722*
723 CALL clacpy( 'Full', m, n, copya, lda, a, lda )
724 CALL clacpy( 'Full', m, nrhs, copyb, ldb, b,
725 $ ldb )
726 srnamt = 'CGELSS'
727 CALL cgelss( 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, 'CGELSS', 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 saxpy( mnmin, -one, copys, 1, s, 1 )
743 result( 7 ) = sasum( mnmin, s, 1 ) /
744 $ sasum( mnmin, copys, 1 ) /
745 $ ( eps*real( mnmin ) )
746 ELSE
747 result( 7 ) = zero
748 END IF
749*
750* Test 8: Compute error in solution
751*
752 CALL clacpy( 'Full', m, nrhs, copyb, ldb, work,
753 $ ldwork )
754 CALL cqrt16( '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 ) = cqrt17( '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 ) = cqrt14( 'No transpose', m, n,
771 $ nrhs, copya, lda, b, ldb,
772 $ work, lwork )
773*
774* Test CGELSD
775*
776* CGELSD: 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 clacpy( 'Full', m, n, copya, lda, a, lda )
783 CALL clacpy( 'Full', m, nrhs, copyb, ldb, b,
784 $ ldb )
785*
786 srnamt = 'CGELSD'
787 CALL cgelsd( 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, 'CGELSD', 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 saxpy( mnmin, -one, copys, 1, s, 1 )
799 result( 11 ) = sasum( mnmin, s, 1 ) /
800 $ sasum( mnmin, copys, 1 ) /
801 $ ( eps*real( mnmin ) )
802 ELSE
803 result( 11 ) = zero
804 END IF
805*
806* Test 12: Compute error in solution
807*
808 CALL clacpy( 'Full', m, nrhs, copyb, ldb, work,
809 $ ldwork )
810 CALL cqrt16( '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 ) = cqrt17( '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 ) = cqrt14( '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( rwork )
865 DEALLOCATE( iwork )
866 RETURN
867*
868* End of CDRVLS
869*
cgels
subroutine cgels(trans, m, n, nrhs, a, lda, b, ldb, work, lwork, info)
CGELS solves overdetermined or underdetermined systems for GE matrices
Definition cgels.f:182
cgelsy
subroutine cgelsy(m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank, work, lwork, rwork, info)
CGELSY solves overdetermined or underdetermined systems for GE matrices
Definition cgelsy.f:210
cgetsls
subroutine cgetsls(trans, m, n, nrhs, a, lda, b, ldb, work, lwork, info)
CGETSLS
Definition cgetsls.f:162
cgelss
subroutine cgelss(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, work, lwork, rwork, info)
CGELSS solves overdetermined or underdetermined systems for GE matrices
Definition cgelss.f:178
cgelsd
subroutine cgelsd(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, work, lwork, rwork, iwork, info)
CGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices
Definition cgelsd.f:225
cscal
subroutine cscal(n, ca, cx, incx)
CSCAL
Definition cscal.f:78
cgemm
subroutine cgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
CGEMM
Definition cgemm.f:187
cqrt13
subroutine cqrt13(scale, m, n, a, lda, norma, iseed)
CQRT13
Definition cqrt13.f:91
cqrt16
subroutine cqrt16(trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
CQRT16
Definition cqrt16.f:133
cerrls
subroutine cerrls(path, nunit)
CERRLS
Definition cerrls.f:55
cqrt15
subroutine cqrt15(scale, rksel, m, n, nrhs, a, lda, b, ldb, s, rank, norma, normb, iseed, work, lwork)
CQRT15
Definition cqrt15.f:149
cqrt17
real function cqrt17(trans, iresid, m, n, nrhs, a, lda, x, ldx, b, ldb, c, work, lwork)
CQRT17
Definition cqrt17.f:153
cqrt14
real function cqrt14(trans, m, n, nrhs, a, lda, x, ldx, work, lwork)
CQRT14
Definition cqrt14.f:116
sasum
real function sasum(n, sx, incx)
SASUM
Definition sasum.f:72
saxpy
subroutine saxpy(n, sa, sx, incx, sy, incy)
SAXPY
Definition saxpy.f:89

◆ cdrvpb()

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

CDRVPB

Purpose:
!>
!> CDRVPB tests the driver routines CPBSV 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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]ASAV
!>          ASAV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is REAL array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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 cdrvpb.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 REAL THRESH
168* ..
169* .. Array Arguments ..
170 LOGICAL DOTYPE( * )
171 INTEGER NVAL( * )
172 REAL RWORK( * ), S( * )
173 COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ),
174 $ BSAV( * ), WORK( * ), X( * ), XACT( * )
175* ..
176*
177* =====================================================================
178*
179* .. Parameters ..
180 REAL ONE, ZERO
181 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL RESULT( NTESTS )
202* ..
203* .. External Functions ..
204 LOGICAL LSAME
205 REAL CLANGE, CLANHB, SGET06
206 EXTERNAL lsame, clange, clanhb, sget06
207* ..
208* .. External Subroutines ..
209 EXTERNAL aladhd, alaerh, alasvm, ccopy, cerrvx, cget04,
210 $ clacpy, claipd, claqhb, clarhs, claset, clatb4,
211 $ clatms, cpbequ, cpbsv, cpbsvx, cpbt01, cpbt02,
212 $ cpbt05, cpbtrf, cpbtrs, cswap, xlaenv
213* ..
214* .. Intrinsic Functions ..
215 INTRINSIC cmplx, 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 ) = 'Complex 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 cerrvx( 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 CLATB4 and generate a test
313* matrix with CLATMS.
314*
315 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
316 $ MODE, CNDNUM, DIST )
317*
318 srnamt = 'CLATMS'
319 CALL clatms( 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 CLATMS.
324*
325 IF( info.NE.0 ) THEN
326 CALL alaerh( path, 'CLATMS', 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 ccopy( izero-i1, work( iw ), 1,
340 $ a( ioff-izero+i1 ), 1 )
341 iw = iw + izero - i1
342 CALL ccopy( i2-izero+1, work( iw ), 1,
343 $ a( ioff ), max( ldab-1, 1 ) )
344 ELSE
345 ioff = ( i1-1 )*ldab + 1
346 CALL ccopy( 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 ccopy( 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 cswap( izero-i1, a( ioff-izero+i1 ), 1,
382 $ work( iw ), 1 )
383 iw = iw + izero - i1
384 CALL cswap( i2-izero+1, a( ioff ),
385 $ max( ldab-1, 1 ), work( iw ), 1 )
386 ELSE
387 ioff = ( i1-1 )*ldab + 1
388 CALL cswap( 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 cswap( 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 claipd( n, a( kd+1 ), ldab, 0 )
401 ELSE
402 CALL claipd( n, a( 1 ), ldab, 0 )
403 END IF
404*
405* Save a copy of the matrix A in ASAV.
406*
407 CALL clacpy( '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 CPBSVX (FACT =
432* 'N' reuses the condition number from the
433* previous iteration with FACT = 'F').
434*
435 CALL clacpy( '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 cpbequ( 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 claqhb( 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 CGET04.
457*
458 IF( equil )
459 $ roldc = rcondc
460*
461* Compute the 1-norm of A.
462*
463 anorm = clanhb( '1', uplo, n, kd, afac, ldab,
464 $ rwork )
465*
466* Factor the matrix A.
467*
468 CALL cpbtrf( uplo, n, kd, afac, ldab, info )
469*
470* Form the inverse of A.
471*
472 CALL claset( 'Full', n, n, cmplx( zero ),
473 $ cmplx( one ), a, lda )
474 srnamt = 'CPBTRS'
475 CALL cpbtrs( uplo, n, kd, n, afac, ldab, a,
476 $ lda, info )
477*
478* Compute the 1-norm condition number of A.
479*
480 ainvnm = clange( '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 clacpy( '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 = 'CLARHS'
497 CALL clarhs( path, xtype, uplo, ' ', n, n, kd,
498 $ kd, nrhs, a, ldab, xact, lda, b,
499 $ lda, iseed, info )
500 xtype = 'C'
501 CALL clacpy( 'Full', n, nrhs, b, lda, bsav,
502 $ lda )
503*
504 IF( nofact ) THEN
505*
506* --- Test CPBSV ---
507*
508* Compute the L*L' or U'*U factorization of the
509* matrix and solve the system.
510*
511 CALL clacpy( 'Full', kd+1, n, a, ldab, afac,
512 $ ldab )
513 CALL clacpy( 'Full', n, nrhs, b, lda, x,
514 $ lda )
515*
516 srnamt = 'CPBSV '
517 CALL cpbsv( uplo, n, kd, nrhs, afac, ldab, x,
518 $ lda, info )
519*
520* Check error code from CPBSV .
521*
522 IF( info.NE.izero ) THEN
523 CALL alaerh( path, 'CPBSV ', 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 cpbt01( uplo, n, kd, a, ldab, afac,
535 $ ldab, rwork, result( 1 ) )
536*
537* Compute residual of the computed solution.
538*
539 CALL clacpy( 'Full', n, nrhs, b, lda, work,
540 $ lda )
541 CALL cpbt02( 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 cget04( 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 )'CPBSV ',
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 CPBSVX ---
568*
569 IF( .NOT.prefac )
570 $ CALL claset( 'Full', kd+1, n, cmplx( zero ),
571 $ cmplx( zero ), afac, ldab )
572 CALL claset( 'Full', n, nrhs, cmplx( zero ),
573 $ cmplx( 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 claqhb( 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 CPBSVX.
585*
586 srnamt = 'CPBSVX'
587 CALL cpbsvx( 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 CPBSVX.
593*
594 IF( info.NE.izero ) THEN
595 CALL alaerh( path, 'CPBSVX', 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 cpbt01( 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 clacpy( 'Full', n, nrhs, bsav, lda,
618 $ work, lda )
619 CALL cpbt02( 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 cget04( n, nrhs, x, lda, xact, lda,
628 $ rcondc, result( 3 ) )
629 ELSE
630 CALL cget04( 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 cpbt05( 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 CPBSVX with the computed
646* value in RCONDC.
647*
648 result( 6 ) = sget06( 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 )'CPBSVX',
659 $ fact, uplo, n, kd, equed, imat, k,
660 $ result( k )
661 ELSE
662 WRITE( nout, fmt = 9998 )'CPBSVX',
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 CDRVPB
691*
claqhb
subroutine claqhb(uplo, n, kd, ab, ldab, s, scond, amax, equed)
CLAQHB scales a Hermitian band matrix, using scaling factors computed by cpbequ.
Definition claqhb.f:141
cpbsv
subroutine cpbsv(uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
CPBSV computes the solution to system of linear equations A * X = B for OTHER matrices
Definition cpbsv.f:164
cpbsvx
subroutine cpbsvx(fact, uplo, n, kd, nrhs, ab, ldab, afb, ldafb, equed, s, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
CPBSVX computes the solution to system of linear equations A * X = B for OTHER matrices
Definition cpbsvx.f:342

◆ cdrvpo()

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

CDRVPO

CDRVPOX

Purpose:
!>
!> CDRVPO tests the driver routines CPOSV 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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]ASAV
!>          ASAV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is REAL array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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:
!>
!> CDRVPO tests the driver routines CPOSV, -SVX, and -SVXX.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise cdrvpo.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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]ASAV
!>          ASAV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is REAL array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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 cdrvpo.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 REAL THRESH
168* ..
169* .. Array Arguments ..
170 LOGICAL DOTYPE( * )
171 INTEGER NVAL( * )
172 REAL RWORK( * ), S( * )
173 COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ),
174 $ BSAV( * ), WORK( * ), X( * ), XACT( * )
175* ..
176*
177* =====================================================================
178*
179* .. Parameters ..
180 REAL ONE, ZERO
181 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL RESULT( NTESTS )
201* ..
202* .. External Functions ..
203 LOGICAL LSAME
204 REAL CLANHE, SGET06
205 EXTERNAL lsame, clanhe, sget06
206* ..
207* .. External Subroutines ..
208 EXTERNAL aladhd, alaerh, alasvm, cerrvx, cget04, clacpy,
209 $ claipd, claqhe, clarhs, claset, clatb4, clatms,
210 $ cpoequ, cposv, cposvx, cpot01, cpot02, cpot05,
211 $ cpotrf, cpotri, xlaenv
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 cmplx, 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 ) = 'Complex 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 cerrvx( 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 CLATB4 and generate a test matrix
286* with CLATMS.
287*
288 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
289 $ CNDNUM, DIST )
290*
291 srnamt = 'CLATMS'
292 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
293 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
294 $ INFO )
295*
296* Check error code from CLATMS.
297*
298 IF( info.NE.0 ) THEN
299 CALL alaerh( path, 'CLATMS', 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 claipd( n, a, lda+1, 0 )
346*
347* Save a copy of the matrix A in ASAV.
348*
349 CALL clacpy( 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 CPOSVX (FACT = 'N' reuses
374* the condition number from the previous iteration
375* with FACT = 'F').
376*
377 CALL clacpy( 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 cpoequ( 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 claqhe( 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 CGET04.
398*
399 IF( equil )
400 $ roldc = rcondc
401*
402* Compute the 1-norm of A.
403*
404 anorm = clanhe( '1', uplo, n, afac, lda, rwork )
405*
406* Factor the matrix A.
407*
408 CALL cpotrf( uplo, n, afac, lda, info )
409*
410* Form the inverse of A.
411*
412 CALL clacpy( uplo, n, n, afac, lda, a, lda )
413 CALL cpotri( uplo, n, a, lda, info )
414*
415* Compute the 1-norm condition number of A.
416*
417 ainvnm = clanhe( '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 clacpy( uplo, n, n, asav, lda, a, lda )
428*
429* Form an exact solution and set the right hand side.
430*
431 srnamt = 'CLARHS'
432 CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
433 $ nrhs, a, lda, xact, lda, b, lda,
434 $ iseed, info )
435 xtype = 'C'
436 CALL clacpy( 'Full', n, nrhs, b, lda, bsav, lda )
437*
438 IF( nofact ) THEN
439*
440* --- Test CPOSV ---
441*
442* Compute the L*L' or U'*U factorization of the
443* matrix and solve the system.
444*
445 CALL clacpy( uplo, n, n, a, lda, afac, lda )
446 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
447*
448 srnamt = 'CPOSV '
449 CALL cposv( uplo, n, nrhs, afac, lda, x, lda,
450 $ info )
451*
452* Check error code from CPOSV .
453*
454 IF( info.NE.izero ) THEN
455 CALL alaerh( path, 'CPOSV ', 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 cpot01( uplo, n, a, lda, afac, lda, rwork,
467 $ result( 1 ) )
468*
469* Compute residual of the computed solution.
470*
471 CALL clacpy( 'Full', n, nrhs, b, lda, work,
472 $ lda )
473 CALL cpot02( uplo, n, nrhs, a, lda, x, lda,
474 $ work, lda, rwork, result( 2 ) )
475*
476* Check solution from generated exact solution.
477*
478 CALL cget04( 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 )'CPOSV ', 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 CPOSVX ---
499*
500 IF( .NOT.prefac )
501 $ CALL claset( uplo, n, n, cmplx( zero ),
502 $ cmplx( zero ), afac, lda )
503 CALL claset( 'Full', n, nrhs, cmplx( zero ),
504 $ cmplx( zero ), x, lda )
505 IF( iequed.GT.1 .AND. n.GT.0 ) THEN
506*
507* Equilibrate the matrix if FACT='F' and
508* EQUED='Y'.
509*
510 CALL claqhe( 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 CPOSVX.
516*
517 srnamt = 'CPOSVX'
518 CALL cposvx( 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 CPOSVX.
524*
525 IF( info.NE.izero ) THEN
526 CALL alaerh( path, 'CPOSVX', 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 cpot01( 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 clacpy( 'Full', n, nrhs, bsav, lda, work,
548 $ lda )
549 CALL cpot02( 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 cget04( n, nrhs, x, lda, xact, lda,
558 $ rcondc, result( 3 ) )
559 ELSE
560 CALL cget04( 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 cpot05( 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 CPOSVX with the computed value
575* in RCONDC.
576*
577 result( 6 ) = sget06( 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 )'CPOSVX', fact,
588 $ uplo, n, equed, imat, k, result( k )
589 ELSE
590 WRITE( nout, fmt = 9998 )'CPOSVX', 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 CDRVPO
617*
claqhe
subroutine claqhe(uplo, n, a, lda, s, scond, amax, equed)
CLAQHE scales a Hermitian matrix.
Definition claqhe.f:134
cposv
subroutine cposv(uplo, n, nrhs, a, lda, b, ldb, info)
CPOSV computes the solution to system of linear equations A * X = B for PO matrices
Definition cposv.f:130
cposvx
subroutine cposvx(fact, uplo, n, nrhs, a, lda, af, ldaf, equed, s, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
CPOSVX computes the solution to system of linear equations A * X = B for PO matrices
Definition cposvx.f:306

◆ cdrvpp()

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

CDRVPP

Purpose:
!>
!> CDRVPP tests the driver routines CPPSV 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 REAL
!>          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 array, dimension (NMAX*(NMAX+1)/2)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*(NMAX+1)/2)
!>
[out]ASAV
!>          ASAV is COMPLEX array, dimension (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is REAL array, dimension (NMAX)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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 cdrvpp.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 REAL THRESH
168* ..
169* .. Array Arguments ..
170 LOGICAL DOTYPE( * )
171 INTEGER NVAL( * )
172 REAL RWORK( * ), S( * )
173 COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ),
174 $ BSAV( * ), WORK( * ), X( * ), XACT( * )
175* ..
176*
177* =====================================================================
178*
179* .. Parameters ..
180 REAL ONE, ZERO
181 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL RESULT( NTESTS )
201* ..
202* .. External Functions ..
203 LOGICAL LSAME
204 REAL CLANHP, SGET06
205 EXTERNAL lsame, clanhp, sget06
206* ..
207* .. External Subroutines ..
208 EXTERNAL aladhd, alaerh, alasvm, ccopy, cerrvx, cget04,
209 $ clacpy, claipd, claqhp, clarhs, claset, clatb4,
210 $ clatms, cppequ, cppsv, cppsvx, cppt01, cppt02,
211 $ cppt05, cpptrf, cpptri
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 cmplx, 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 ) = 'Complex 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 cerrvx( 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 CLATB4 and generate a test matrix
280* with CLATMS.
281*
282 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
283 $ CNDNUM, DIST )
284 rcondc = one / cndnum
285*
286 srnamt = 'CLATMS'
287 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
288 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
289 $ INFO )
290*
291* Check error code from CLATMS.
292*
293 IF( info.NE.0 ) THEN
294 CALL alaerh( path, 'CLATMS', 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 claipd( n, a, 2, 1 )
342 ELSE
343 CALL claipd( n, a, n, -1 )
344 END IF
345*
346* Save a copy of the matrix A in ASAV.
347*
348 CALL ccopy( 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 CPPSVX (FACT = 'N' reuses
373* the condition number from the previous iteration
374* with FACT = 'F').
375*
376 CALL ccopy( 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 cppequ( 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 claqhp( 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 CGET04.
397*
398 IF( equil )
399 $ roldc = rcondc
400*
401* Compute the 1-norm of A.
402*
403 anorm = clanhp( '1', uplo, n, afac, rwork )
404*
405* Factor the matrix A.
406*
407 CALL cpptrf( uplo, n, afac, info )
408*
409* Form the inverse of A.
410*
411 CALL ccopy( npp, afac, 1, a, 1 )
412 CALL cpptri( uplo, n, a, info )
413*
414* Compute the 1-norm condition number of A.
415*
416 ainvnm = clanhp( '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 ccopy( npp, asav, 1, a, 1 )
427*
428* Form an exact solution and set the right hand side.
429*
430 srnamt = 'CLARHS'
431 CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
432 $ nrhs, a, lda, xact, lda, b, lda,
433 $ iseed, info )
434 xtype = 'C'
435 CALL clacpy( 'Full', n, nrhs, b, lda, bsav, lda )
436*
437 IF( nofact ) THEN
438*
439* --- Test CPPSV ---
440*
441* Compute the L*L' or U'*U factorization of the
442* matrix and solve the system.
443*
444 CALL ccopy( npp, a, 1, afac, 1 )
445 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
446*
447 srnamt = 'CPPSV '
448 CALL cppsv( uplo, n, nrhs, afac, x, lda, info )
449*
450* Check error code from CPPSV .
451*
452 IF( info.NE.izero ) THEN
453 CALL alaerh( path, 'CPPSV ', 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 cppt01( uplo, n, a, afac, rwork,
465 $ result( 1 ) )
466*
467* Compute residual of the computed solution.
468*
469 CALL clacpy( 'Full', n, nrhs, b, lda, work,
470 $ lda )
471 CALL cppt02( uplo, n, nrhs, a, x, lda, work,
472 $ lda, rwork, result( 2 ) )
473*
474* Check solution from generated exact solution.
475*
476 CALL cget04( 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 )'CPPSV ', 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 CPPSVX ---
497*
498 IF( .NOT.prefac .AND. npp.GT.0 )
499 $ CALL claset( 'Full', npp, 1, cmplx( zero ),
500 $ cmplx( zero ), afac, npp )
501 CALL claset( 'Full', n, nrhs, cmplx( zero ),
502 $ cmplx( 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 claqhp( 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 CPPSVX.
513*
514 srnamt = 'CPPSVX'
515 CALL cppsvx( 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 CPPSVX.
521*
522 IF( info.NE.izero ) THEN
523 CALL alaerh( path, 'CPPSVX', 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 cppt01( 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 clacpy( 'Full', n, nrhs, bsav, lda, work,
545 $ lda )
546 CALL cppt02( 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 cget04( n, nrhs, x, lda, xact, lda,
555 $ rcondc, result( 3 ) )
556 ELSE
557 CALL cget04( 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 cppt05( 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 CPPSVX with the computed value
572* in RCONDC.
573*
574 result( 6 ) = sget06( 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 )'CPPSVX', fact,
585 $ uplo, n, equed, imat, k, result( k )
586 ELSE
587 WRITE( nout, fmt = 9998 )'CPPSVX', 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 CDRVPP
615*
claqhp
subroutine claqhp(uplo, n, ap, s, scond, amax, equed)
CLAQHP scales a Hermitian matrix stored in packed form.
Definition claqhp.f:126
cppsvx
subroutine cppsvx(fact, uplo, n, nrhs, ap, afp, equed, s, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
CPPSVX computes the solution to system of linear equations A * X = B for OTHER matrices
Definition cppsvx.f:311
cppsv
subroutine cppsv(uplo, n, nrhs, ap, b, ldb, info)
CPPSV computes the solution to system of linear equations A * X = B for OTHER matrices
Definition cppsv.f:144

◆ cdrvpt()

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

CDRVPT

Purpose:
!>
!> CDRVPT tests CPTSV 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 REAL
!>          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 array, dimension (NMAX*2)
!>
[out]D
!>          D is REAL array, dimension (NMAX*2)
!>
[out]E
!>          E is COMPLEX array, dimension (NMAX*2)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(3,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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 cdrvpt.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 REAL THRESH
149* ..
150* .. Array Arguments ..
151 LOGICAL DOTYPE( * )
152 INTEGER NVAL( * )
153 REAL D( * ), RWORK( * )
154 COMPLEX A( * ), B( * ), E( * ), WORK( * ), X( * ),
155 $ XACT( * )
156* ..
157*
158* =====================================================================
159*
160* .. Parameters ..
161 REAL ONE, ZERO
162 parameter( one = 1.0e+0, zero = 0.0e+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 REAL AINVNM, ANORM, COND, DMAX, RCOND, RCONDC
176* ..
177* .. Local Arrays ..
178 INTEGER ISEED( 4 ), ISEEDY( 4 )
179 REAL RESULT( NTESTS ), Z( 3 )
180* ..
181* .. External Functions ..
182 INTEGER ISAMAX
183 REAL CLANHT, SCASUM, SGET06
184 EXTERNAL isamax, clanht, scasum, sget06
185* ..
186* .. External Subroutines ..
187 EXTERNAL aladhd, alaerh, alasvm, ccopy, cerrvx, cget04,
188 $ clacpy, claptm, clarnv, claset, clatb4, clatms,
189 $ cptsv, cptsvx, cptt01, cptt02, cptt05, cpttrf,
190 $ cpttrs, csscal, scopy, slarnv, sscal
191* ..
192* .. Intrinsic Functions ..
193 INTRINSIC abs, cmplx, 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 ) = 'Complex 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 cerrvx( 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 CLATB4.
242*
243 CALL clatb4( 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 = 'CLATMS'
253 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE, COND,
254 $ ANORM, KL, KU, 'B', A, 2, WORK, INFO )
255*
256* Check the error code from CLATMS.
257*
258 IF( info.NE.0 ) THEN
259 CALL alaerh( path, 'CLATMS', 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 slarnv( 2, iseed, n, d )
285 CALL clarnv( 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 = isamax( n, d, 1 )
303 dmax = d( ix )
304 CALL sscal( n, anorm / dmax, d, 1 )
305 IF( n.GT.1 )
306 $ CALL csscal( 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 clarnv( 2, iseed, n, xact( ix ) )
365 ix = ix + lda
366 40 CONTINUE
367*
368* Set the right hand side.
369*
370 CALL claptm( '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 CPTSVX.
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 = clanht( '1', n, d, e )
393*
394 CALL scopy( n, d, 1, d( n+1 ), 1 )
395 IF( n.GT.1 )
396 $ CALL ccopy( n-1, e, 1, e( n+1 ), 1 )
397*
398* Factor the matrix A.
399*
400 CALL cpttrf( n, d( n+1 ), e( n+1 ), info )
401*
402* Use CPTTRS 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 cpttrs( 'Lower', n, 1, d( n+1 ), e( n+1 ), x,
412 $ lda, info )
413 ainvnm = max( ainvnm, scasum( 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 CPTSV --
428*
429 CALL scopy( n, d, 1, d( n+1 ), 1 )
430 IF( n.GT.1 )
431 $ CALL ccopy( n-1, e, 1, e( n+1 ), 1 )
432 CALL clacpy( '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 = 'CPTSV '
437 CALL cptsv( n, nrhs, d( n+1 ), e( n+1 ), x, lda,
438 $ info )
439*
440* Check error code from CPTSV .
441*
442 IF( info.NE.izero )
443 $ CALL alaerh( path, 'CPTSV ', 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 cptt01( n, d, e, d( n+1 ), e( n+1 ), work,
453 $ result( 1 ) )
454*
455* Compute the residual in the solution.
456*
457 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
458 CALL cptt02( 'Lower', n, nrhs, d, e, x, lda, work,
459 $ lda, result( 2 ) )
460*
461* Check solution from generated exact solution.
462*
463 CALL cget04( 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 )'CPTSV ', 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 CPTSVX ---
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 claset( 'Full', n, nrhs, cmplx( zero ),
498 $ cmplx( zero ), x, lda )
499*
500* Solve the system and compute the condition number and
501* error bounds using CPTSVX.
502*
503 srnamt = 'CPTSVX'
504 CALL cptsvx( 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 CPTSVX.
509*
510 IF( info.NE.izero )
511 $ CALL alaerh( path, 'CPTSVX', 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 cptt01( 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 clacpy( 'Full', n, nrhs, b, lda, work, lda )
529 CALL cptt02( 'Lower', n, nrhs, d, e, x, lda, work,
530 $ lda, result( 2 ) )
531*
532* Check solution from generated exact solution.
533*
534 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
535 $ result( 3 ) )
536*
537* Check error bounds from iterative refinement.
538*
539 CALL cptt05( 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 ) = sget06( 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 )'CPTSVX', 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 CDRVPT
577*
cptsvx
subroutine cptsvx(fact, n, nrhs, d, e, df, ef, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
CPTSVX computes the solution to system of linear equations A * X = B for PT matrices
Definition cptsvx.f:234
cptsv
subroutine cptsv(n, nrhs, d, e, b, ldb, info)
CPTSV computes the solution to system of linear equations A * X = B for PT matrices
Definition cptsv.f:115

◆ cdrvrf1()

subroutine cdrvrf1 ( integer nout,
integer nn,
integer, dimension( nn ) nval,
real thresh,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) arf,
real, dimension( * ) work )

CDRVRF1

Purpose:
!>
!> CDRVRF1 tests the LAPACK RFP routines:
!>     CLANHF.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 REAL
!>                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 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 array, dimension ((NMAX*(NMAX+1))/2).
!>
[out]WORK
!>          WORK is COMPLEX array, dimension ( NMAX )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 94 of file cdrvrf1.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 REAL THRESH
103* ..
104* .. Array Arguments ..
105 INTEGER NVAL( NN )
106 REAL WORK( * )
107 COMPLEX A( LDA, * ), ARF( * )
108* ..
109*
110* =====================================================================
111* ..
112* .. Parameters ..
113 REAL ONE
114 parameter( one = 1.0e+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 REAL EPS, LARGE, NORMA, NORMARF, SMALL
123* ..
124* .. Local Arrays ..
125 CHARACTER UPLOS( 2 ), FORMS( 2 ), NORMS( 4 )
126 INTEGER ISEED( 4 ), ISEEDY( 4 )
127 REAL RESULT( NTESTS )
128* ..
129* .. External Functions ..
130 COMPLEX CLARND
131 REAL SLAMCH, CLANHE, CLANHF
132 EXTERNAL slamch, clarnd, clanhe, clanhf
133* ..
134* .. External Subroutines ..
135 EXTERNAL ctrttf
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 = slamch( 'Precision' )
162 small = slamch( '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) = clarnd( 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 = 'CTRTTF'
214 CALL ctrttf( cform, uplo, n, a, lda, arf, info )
215*
216* Check error code from CTRTTF
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 = clanhf( norm, cform, uplo, n, arf, work )
234 norma = clanhe( 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 ) 'CLANHF',
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 )'CLANHF', nrun
258 ELSE
259 WRITE( nout, fmt = 9995 ) 'CLANHF', nfail, nrun
260 END IF
261 IF ( nerrs.NE.0 ) THEN
262 WRITE( nout, fmt = 9994 ) nerrs, 'CLANHF'
263 END IF
264*
265 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing CLANHF
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 CDRVRF1
280*
ctrttf
subroutine ctrttf(transr, uplo, n, a, lda, arf, info)
CTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed f...
Definition ctrttf.f:216
clanhf
real function clanhf(norm, transr, uplo, n, a, work)
CLANHF returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition clanhf.f:246
clarnd
complex function clarnd(idist, iseed)
CLARND
Definition clarnd.f:75

◆ cdrvrf2()

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

CDRVRF2

Purpose:
!>
!> CDRVRF2 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 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 array, dimension ((NMAX*(NMAX+1))/2).
!>
[out]AP
!>          AP is COMPLEX array, dimension ((NMAX*(NMAX+1))/2).
!>
[out]ASAV
!>          ASAV is COMPLEX6 array, dimension (LDA,NMAX)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 88 of file cdrvrf2.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 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 CLARND
116 EXTERNAL clarnd
117* ..
118* .. External Subroutines ..
119 EXTERNAL ctfttr, ctfttp, ctrttf, ctrttp, ctpttr, ctpttf
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) = clarnd( 4, iseed )
166 END DO
167 END DO
168*
169 srnamt = 'CTRTTF'
170 CALL ctrttf( cform, uplo, n, a, lda, arf, info )
171*
172 srnamt = 'CTFTTP'
173 CALL ctfttp( cform, uplo, n, arf, ap, info )
174*
175 srnamt = 'CTPTTR'
176 CALL ctpttr( 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 = 'CTRTTP'
200 CALL ctrttp( uplo, n, a, lda, ap, info )
201*
202 srnamt = 'CTPTTF'
203 CALL ctpttf( cform, uplo, n, ap, arf, info )
204*
205 srnamt = 'CTFTTR'
206 CALL ctfttr( 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 CDRVRF2
260*
ctfttr
subroutine ctfttr(transr, uplo, n, arf, a, lda, info)
CTFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full f...
Definition ctfttr.f:216
ctpttr
subroutine ctpttr(uplo, n, ap, a, lda, info)
CTPTTR copies a triangular matrix from the standard packed format (TP) to the standard full format (T...
Definition ctpttr.f:104
ctpttf
subroutine ctpttf(transr, uplo, n, ap, arf, info)
CTPTTF copies a triangular matrix from the standard packed format (TP) to the rectangular full packed...
Definition ctpttf.f:207
ctfttp
subroutine ctfttp(transr, uplo, n, arf, ap, info)
CTFTTP copies a triangular matrix from the rectangular full packed format (TF) to the standard packed...
Definition ctfttp.f:208
ctrttp
subroutine ctrttp(uplo, n, a, lda, ap, info)
CTRTTP copies a triangular matrix from the standard full format (TR) to the standard packed format (T...
Definition ctrttp.f:104

◆ cdrvrf3()

subroutine cdrvrf3 ( integer nout,
integer nn,
integer, dimension( nn ) nval,
real thresh,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) arf,
complex, dimension( lda, * ) b1,
complex, dimension( lda, * ) b2,
real, dimension( * ) s_work_clange,
complex, dimension( * ) c_work_cgeqrf,
complex, dimension( * ) tau )

CDRVRF3

Purpose:
!>
!> CDRVRF3 tests the LAPACK RFP routines:
!>     CTFSM
!>
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 array, dimension ((NMAX*(NMAX+1))/2).
!>
[out]B1
!>          B1 is COMPLEX array, dimension (LDA,NMAX)
!>
[out]B2
!>          B2 is COMPLEX array, dimension (LDA,NMAX)
!>
[out]S_WORK_CLANGE
!>          S_WORK_CLANGE is REAL array, dimension (NMAX)
!>
[out]C_WORK_CGEQRF
!>          C_WORK_CGEQRF is COMPLEX array, dimension (NMAX)
!>
[out]TAU
!>          TAU is COMPLEX array, dimension (NMAX)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 117 of file cdrvrf3.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 REAL THRESH
127* ..
128* .. Array Arguments ..
129 INTEGER NVAL( NN )
130 REAL S_WORK_CLANGE( * )
131 COMPLEX A( LDA, * ), ARF( * ), B1( LDA, * ),
132 + B2( LDA, * )
133 COMPLEX C_WORK_CGEQRF( * ), TAU( * )
134* ..
135*
136* =====================================================================
137* ..
138* .. Parameters ..
139 COMPLEX ZERO, ONE
140 parameter( zero = ( 0.0e+0, 0.0e+0 ) ,
141 + one = ( 1.0e+0, 0.0e+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 ALPHA
150 REAL 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 REAL RESULT( NTESTS )
157* ..
158* .. External Functions ..
159 REAL SLAMCH, CLANGE
160 COMPLEX CLARND
161 EXTERNAL slamch, clarnd, clange
162* ..
163* .. External Subroutines ..
164 EXTERNAL ctrttf, cgeqrf, cgeqlf, ctfsm, ctrsm
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 = slamch( '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 = clarnd( 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) = clarnd( 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 = 'CGEQRF'
276 CALL cgeqrf( na, na, a, lda, tau,
277 + c_work_cgeqrf, lda,
278 + info )
279 ELSE
280*
281* The case IUPLO.EQ.2 is when SIDE.EQ.'L'
282* -> QL factorization.
283*
284 srnamt = 'CGELQF'
285 CALL cgelqf( na, na, a, lda, tau,
286 + c_work_cgeqrf, 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) * clarnd( 5, iseed )
297 END DO
298*
299* Store a copy of A in RFP format (in ARF).
300*
301 srnamt = 'CTRTTF'
302 CALL ctrttf( 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) = clarnd( 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 CTRSM
317*
318 srnamt = 'CTRSM'
319 CALL ctrsm( 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 CTFSM
324*
325 srnamt = 'CTFSM'
326 CALL ctfsm( 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) = clange( 'I', m, n, b1, lda,
339 + s_work_clange )
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 ) 'CTFSM',
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 ) 'CTFSM', nrun
368 ELSE
369 WRITE( nout, fmt = 9995 ) 'CTFSM', nfail, nrun
370 END IF
371*
372 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing CTFSM
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 CDRVRF3
385*
cgeqrf
subroutine cgeqrf(m, n, a, lda, tau, work, lwork, info)
CGEQRF
Definition cgeqrf.f:146
cgeqlf
subroutine cgeqlf(m, n, a, lda, tau, work, lwork, info)
CGEQLF
Definition cgeqlf.f:138
cgelqf
subroutine cgelqf(m, n, a, lda, tau, work, lwork, info)
CGELQF
Definition cgelqf.f:143
ctfsm
subroutine ctfsm(transr, side, uplo, trans, diag, m, n, alpha, a, b, ldb)
CTFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
Definition ctfsm.f:298
ctrsm
subroutine ctrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
CTRSM
Definition ctrsm.f:180

◆ cdrvrf4()

subroutine cdrvrf4 ( integer nout,
integer nn,
integer, dimension( nn ) nval,
real thresh,
complex, dimension( ldc, * ) c1,
complex, dimension( ldc, *) c2,
integer ldc,
complex, dimension( * ) crf,
complex, dimension( lda, * ) a,
integer lda,
real, dimension( * ) s_work_clange )

CDRVRF4

Purpose:
!>
!> CDRVRF4 tests the LAPACK RFP routines:
!>     CHFRK
!>
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 REAL
!>                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 array, dimension (LDC,NMAX)
!>
[out]C2
!>          C2 is COMPLEX 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 array, dimension ((NMAX*(NMAX+1))/2).
!>
[out]A
!>          A is COMPLEX array, dimension (LDA,NMAX)
!>
[in]LDA
!>          LDA is INTEGER
!>                The leading dimension of the array A.  LDA >= max(1,NMAX).
!>
[out]S_WORK_CLANGE
!>          S_WORK_CLANGE is REAL array, dimension (NMAX)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 112 of file cdrvrf4.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 REAL THRESH
122* ..
123* .. Array Arguments ..
124 INTEGER NVAL( NN )
125 REAL S_WORK_CLANGE( * )
126 COMPLEX A( LDA, * ), C1( LDC, * ), C2( LDC, *),
127 + CRF( * )
128* ..
129*
130* =====================================================================
131* ..
132* .. Parameters ..
133 REAL ZERO, ONE
134 parameter( zero = 0.0e+0, one = 1.0e+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 REAL ALPHA, BETA, EPS, NORMA, NORMC
143* ..
144* .. Local Arrays ..
145 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 )
146 INTEGER ISEED( 4 ), ISEEDY( 4 )
147 REAL RESULT( NTESTS )
148* ..
149* .. External Functions ..
150 REAL SLAMCH, SLARND, CLANGE
151 COMPLEX CLARND
152 EXTERNAL slamch, slarnd, clange, clarnd
153* ..
154* .. External Subroutines ..
155 EXTERNAL cherk, chfrk, ctfttr, ctrttf
156* ..
157* .. Intrinsic Functions ..
158 INTRINSIC abs, 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 = slamch( '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 = slarnd( 2, iseed )
217 beta = slarnd( 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) = clarnd( 4, iseed )
234 END DO
235 END DO
236*
237 norma = clange( 'I', n, k, a, lda,
238 + s_work_clange )
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) = clarnd( 4, iseed )
247 END DO
248 END DO
249*
250 norma = clange( 'I', k, n, a, lda,
251 + s_work_clange )
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) = clarnd( 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 CLANGE and
269* not CLANHE for C1.)
270*
271 normc = clange( 'I', n, n, c1, ldc,
272 + s_work_clange )
273*
274 srnamt = 'CTRTTF'
275 CALL ctrttf( cform, uplo, n, c1, ldc, crf,
276 + info )
277*
278* call zherk the BLAS routine -> gives C1
279*
280 srnamt = 'CHERK '
281 CALL cherk( uplo, trans, n, k, alpha, a, lda,
282 + beta, c1, ldc )
283*
284* call zhfrk the RFP routine -> gives CRF
285*
286 srnamt = 'CHFRK '
287 CALL chfrk( cform, uplo, trans, n, k, alpha, a,
288 + lda, beta, crf )
289*
290* convert CRF in full format -> gives C2
291*
292 srnamt = 'CTFTTR'
293 CALL ctfttr( 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 CLANHE,
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 -> CLANGE
308*
309 result(1) = clange( 'I', n, n, c1, ldc,
310 + s_work_clange )
311 result(1) = result(1)
312 + / max( abs( alpha ) * norma * norma
313 + + abs( 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 ) 'CHFRK',
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 ) 'CHFRK', nrun
337 ELSE
338 WRITE( nout, fmt = 9995 ) 'CHFRK', nfail, nrun
339 END IF
340*
341 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing CHFRK
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 ( ',i5,' tests run)')
348 9995 FORMAT( 1x, a6, ' auxiliary routine: ',i5,' out of ',i5,
349 + ' tests failed to pass the threshold')
350*
351 RETURN
352*
353* End of CDRVRF4
354*
chfrk
subroutine chfrk(transr, uplo, trans, n, k, alpha, a, lda, beta, c)
CHFRK performs a Hermitian rank-k operation for matrix in RFP format.
Definition chfrk.f:168
cherk
subroutine cherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
CHERK
Definition cherk.f:173
slarnd
real function slarnd(idist, iseed)
SLARND
Definition slarnd.f:73

◆ cdrvrfp()

subroutine cdrvrfp ( integer nout,
integer nn,
integer, dimension( nn ) nval,
integer nns,
integer, dimension( nns ) nsval,
integer nnt,
integer, dimension( nnt ) ntval,
real thresh,
complex, dimension( * ) a,
complex, dimension( * ) asav,
complex, dimension( * ) afac,
complex, dimension( * ) ainv,
complex, dimension( * ) b,
complex, dimension( * ) bsav,
complex, dimension( * ) xact,
complex, dimension( * ) x,
complex, dimension( * ) arf,
complex, dimension( * ) arfinv,
complex, dimension( * ) c_work_clatms,
complex, dimension( * ) c_work_cpot02,
complex, dimension( * ) c_work_cpot03,
real, dimension( * ) s_work_clatms,
real, dimension( * ) s_work_clanhe,
real, dimension( * ) s_work_cpot01,
real, dimension( * ) s_work_cpot02,
real, dimension( * ) s_work_cpot03 )

CDRVRFP

Purpose:
!>
!> CDRVRFP tests the LAPACK RFP routines:
!>     CPFTRF, CPFTRS, and CPFTRI.
!>
!> This testing routine follow the same tests as CDRVPO (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 CTRTTF and
!> CTFTTR.
!>
!> 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 CPFTRF, 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 CPFTRF 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 REAL
!>                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 array, dimension (NMAX*NMAX)
!>
[out]ASAV
!>          ASAV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*MAXRHS)
!>
[out]BSAV
!>          BSAV is COMPLEX array, dimension (NMAX*MAXRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*MAXRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*MAXRHS)
!>
[out]ARF
!>          ARF is COMPLEX array, dimension ((NMAX*(NMAX+1))/2)
!>
[out]ARFINV
!>          ARFINV is COMPLEX array, dimension ((NMAX*(NMAX+1))/2)
!>
[out]C_WORK_CLATMS
!>          C_WORK_CLATMS is COMPLEX array, dimension ( 3*NMAX )
!>
[out]C_WORK_CPOT02
!>          C_WORK_CPOT02 is COMPLEX array, dimension ( NMAX*MAXRHS )
!>
[out]C_WORK_CPOT03
!>          C_WORK_CPOT03 is COMPLEX array, dimension ( NMAX*NMAX )
!>
[out]S_WORK_CLATMS
!>          S_WORK_CLATMS is REAL array, dimension ( NMAX )
!>
[out]S_WORK_CLANHE
!>          S_WORK_CLANHE is REAL array, dimension ( NMAX )
!>
[out]S_WORK_CPOT01
!>          S_WORK_CPOT01 is REAL array, dimension ( NMAX )
!>
[out]S_WORK_CPOT02
!>          S_WORK_CPOT02 is REAL array, dimension ( NMAX )
!>
[out]S_WORK_CPOT03
!>          S_WORK_CPOT03 is REAL array, dimension ( NMAX )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 238 of file cdrvrfp.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 REAL THRESH
252* ..
253* .. Array Arguments ..
254 INTEGER NVAL( NN ), NSVAL( NNS ), NTVAL( NNT )
255 COMPLEX A( * )
256 COMPLEX AINV( * )
257 COMPLEX ASAV( * )
258 COMPLEX B( * )
259 COMPLEX BSAV( * )
260 COMPLEX AFAC( * )
261 COMPLEX ARF( * )
262 COMPLEX ARFINV( * )
263 COMPLEX XACT( * )
264 COMPLEX X( * )
265 COMPLEX C_WORK_CLATMS( * )
266 COMPLEX C_WORK_CPOT02( * )
267 COMPLEX C_WORK_CPOT03( * )
268 REAL S_WORK_CLATMS( * )
269 REAL S_WORK_CLANHE( * )
270 REAL S_WORK_CPOT01( * )
271 REAL S_WORK_CPOT02( * )
272 REAL S_WORK_CPOT03( * )
273* ..
274*
275* =====================================================================
276*
277* .. Parameters ..
278 REAL ONE, ZERO
279 parameter( one = 1.0e+0, zero = 0.0e+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 REAL ANORM, AINVNM, CNDNUM, RCONDC
291* ..
292* .. Local Arrays ..
293 CHARACTER UPLOS( 2 ), FORMS( 2 )
294 INTEGER ISEED( 4 ), ISEEDY( 4 )
295 REAL RESULT( NTESTS )
296* ..
297* .. External Functions ..
298 REAL CLANHE
299 EXTERNAL clanhe
300* ..
301* .. External Subroutines ..
302 EXTERNAL aladhd, alaerh, alasvm, cget04, ctfttr, clacpy,
303 + claipd, clarhs, clatb4, clatms, cpftri, cpftrf,
304 + cpftrs, cpot01, cpot02, cpot03, cpotri, cpotrf,
305 + ctrttf
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 CLATB4 and generate a test
363* matrix with CLATMS.
364*
365 CALL clatb4( 'CPO', imat, n, n, ctype, kl, ku,
366 + anorm, mode, cndnum, dist )
367*
368 srnamt = 'CLATMS'
369 CALL clatms( n, n, dist, iseed, ctype,
370 + s_work_clatms,
371 + mode, cndnum, anorm, kl, ku, uplo, a,
372 + lda, c_work_clatms, info )
373*
374* Check error code from CLATMS.
375*
376 IF( info.NE.0 ) THEN
377 CALL alaerh( 'CPF', 'CLATMS', 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 claipd( n, a, lda+1, 0 )
426*
427* Save a copy of the matrix A in ASAV.
428*
429 CALL clacpy( 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 = clanhe( '1', uplo, n, a, lda,
440 + s_work_clanhe )
441*
442* Factor the matrix A.
443*
444 CALL cpotrf( uplo, n, a, lda, info )
445*
446* Form the inverse of A.
447*
448 CALL cpotri( 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 = clanhe( '1', uplo, n, a, lda,
455 + s_work_clanhe )
456 rcondc = ( one / anorm ) / ainvnm
457*
458* Restore the matrix A.
459*
460 CALL clacpy( 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 = 'CLARHS'
468 CALL clarhs( 'CPO', 'N', uplo, ' ', n, n, kl, ku,
469 + nrhs, a, lda, xact, lda, b, lda,
470 + iseed, info )
471 CALL clacpy( '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 clacpy( uplo, n, n, a, lda, afac, lda )
477 CALL clacpy( 'Full', n, nrhs, b, ldb, x, ldb )
478*
479 srnamt = 'CTRTTF'
480 CALL ctrttf( cform, uplo, n, afac, lda, arf, info )
481 srnamt = 'CPFTRF'
482 CALL cpftrf( cform, uplo, n, arf, info )
483*
484* Check error code from CPFTRF.
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( 'CPF', 'CPFSV ', 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 = 'CPFTRS'
505 CALL cpftrs( cform, uplo, n, nrhs, arf, x, ldb,
506 + info )
507*
508 srnamt = 'CTFTTR'
509 CALL ctfttr( cform, uplo, n, arf, afac, lda, info )
510*
511* Reconstruct matrix from factors and compute
512* residual.
513*
514 CALL clacpy( uplo, n, n, afac, lda, asav, lda )
515 CALL cpot01( uplo, n, a, lda, afac, lda,
516 + s_work_cpot01, result( 1 ) )
517 CALL clacpy( 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 clacpy( 'A', n+1, n/2, arf, n+1, arfinv,
523 + n+1 )
524 ELSE
525 CALL clacpy( 'A', n, (n+1)/2, arf, n, arfinv,
526 + n )
527 END IF
528*
529 srnamt = 'CPFTRI'
530 CALL cpftri( cform, uplo, n, arfinv , info )
531*
532 srnamt = 'CTFTTR'
533 CALL ctfttr( cform, uplo, n, arfinv, ainv, lda,
534 + info )
535*
536* Check error code from CPFTRI.
537*
538 IF( info.NE.0 )
539 + CALL alaerh( 'CPO', 'CPFTRI', info, 0, uplo, n,
540 + n, -1, -1, -1, imat, nfail, nerrs,
541 + nout )
542*
543 CALL cpot03( uplo, n, a, lda, ainv, lda,
544 + c_work_cpot03, lda, s_work_cpot03,
545 + rcondc, result( 2 ) )
546*
547* Compute residual of the computed solution.
548*
549 CALL clacpy( 'Full', n, nrhs, b, lda,
550 + c_work_cpot02, lda )
551 CALL cpot02( uplo, n, nrhs, a, lda, x, lda,
552 + c_work_cpot02, lda, s_work_cpot02,
553 + result( 3 ) )
554*
555* Check solution from generated exact solution.
556*
557 CALL cget04( 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, 'CPF' )
568 WRITE( nout, fmt = 9999 )'CPFSV ', 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( 'CPF', 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 CDRVRFP
590*
cpftrs
subroutine cpftrs(transr, uplo, n, nrhs, a, b, ldb, info)
CPFTRS
Definition cpftrs.f:220
cpftrf
subroutine cpftrf(transr, uplo, n, a, info)
CPFTRF
Definition cpftrf.f:211
cpftri
subroutine cpftri(transr, uplo, n, a, info)
CPFTRI
Definition cpftri.f:212

◆ cdrvsp()

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

CDRVSP

Purpose:
!>
!> CDRVSP tests the driver routines CSPSV 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 REAL
!>          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 array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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 cdrvsp.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 REAL THRESH
166* ..
167* .. Array Arguments ..
168 LOGICAL DOTYPE( * )
169 INTEGER IWORK( * ), NVAL( * )
170 REAL RWORK( * )
171 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
172 $ WORK( * ), X( * ), XACT( * )
173* ..
174*
175* =====================================================================
176*
177* .. Parameters ..
178 REAL ONE, ZERO
179 parameter( one = 1.0e+0, zero = 0.0e+0 )
180 INTEGER NTYPES, NTESTS
181 parameter( ntypes = 11, ntests = 6 )
182 INTEGER NFACT
183 parameter( nfact = 2 )
184* ..
185* .. 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 REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC
193* ..
194* .. Local Arrays ..
195 CHARACTER FACTS( NFACT )
196 INTEGER ISEED( 4 ), ISEEDY( 4 )
197 REAL RESULT( NTESTS )
198* ..
199* .. External Functions ..
200 REAL CLANSP, SGET06
201 EXTERNAL clansp, sget06
202* ..
203* .. External Subroutines ..
204 EXTERNAL aladhd, alaerh, alasvm, ccopy, cerrvx, cget04,
205 $ clacpy, clarhs, claset, clatb4, clatms, clatsp,
206 $ cppt05, cspsv, cspsvx, cspt01, cspt02, csptrf,
207 $ csptri, xlaenv
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 facts / 'F', 'N' /
224* ..
225* .. Executable Statements ..
226*
227* Initialize constants and the random number seed.
228*
229 path( 1: 1 ) = 'Complex 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 cerrvx( 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 CLATB4 and generate a test
289* matrix with CLATMS.
290*
291 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
292 $ MODE, CNDNUM, DIST )
293*
294 srnamt = 'CLATMS'
295 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
296 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA,
297 $ WORK, INFO )
298*
299* Check error code from CLATMS.
300*
301 IF( info.NE.0 ) THEN
302 CALL alaerh( path, 'CLATMS', 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 clatsp( 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 CSPSVX.
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 = clansp( '1', uplo, n, a, rwork )
401*
402* Factor the matrix A.
403*
404 CALL ccopy( npp, a, 1, afac, 1 )
405 CALL csptrf( uplo, n, afac, iwork, info )
406*
407* Compute inv(A) and take its norm.
408*
409 CALL ccopy( npp, afac, 1, ainv, 1 )
410 CALL csptri( uplo, n, ainv, iwork, work, info )
411 ainvnm = clansp( '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 = 'CLARHS'
425 CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
426 $ nrhs, a, lda, xact, lda, b, lda, iseed,
427 $ info )
428 xtype = 'C'
429*
430* --- Test CSPSV ---
431*
432 IF( ifact.EQ.2 ) THEN
433 CALL ccopy( npp, a, 1, afac, 1 )
434 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
435*
436* Factor the matrix and solve the system using CSPSV.
437*
438 srnamt = 'CSPSV '
439 CALL cspsv( 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 CSPSV .
460*
461 IF( info.NE.k ) THEN
462 CALL alaerh( path, 'CSPSV ', 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 cspt01( uplo, n, a, afac, iwork, ainv, lda,
474 $ rwork, result( 1 ) )
475*
476* Compute residual of the computed solution.
477*
478 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
479 CALL cspt02( uplo, n, nrhs, a, x, lda, work, lda,
480 $ rwork, result( 2 ) )
481*
482* Check solution from generated exact solution.
483*
484 CALL cget04( 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 )'CSPSV ', 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 CSPSVX ---
505*
506 IF( ifact.EQ.2 .AND. npp.GT.0 )
507 $ CALL claset( 'Full', npp, 1, cmplx( zero ),
508 $ cmplx( zero ), afac, npp )
509 CALL claset( 'Full', n, nrhs, cmplx( zero ),
510 $ cmplx( zero ), x, lda )
511*
512* Solve the system and compute the condition number and
513* error bounds using CSPSVX.
514*
515 srnamt = 'CSPSVX'
516 CALL cspsvx( 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 CSPSVX.
539*
540 IF( info.NE.k ) THEN
541 CALL alaerh( path, 'CSPSVX', 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 cspt01( 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 clacpy( 'Full', n, nrhs, b, lda, work, lda )
563 CALL cspt02( 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 cget04( n, nrhs, x, lda, xact, lda, rcondc,
569 $ result( 3 ) )
570*
571* Check the error bounds from iterative refinement.
572*
573 CALL cppt05( 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 CSPSVX with the computed value
581* in RCONDC.
582*
583 result( 6 ) = sget06( 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 )'CSPSVX', 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 CDRVSP
616*
cspsvx
subroutine cspsvx(fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
CSPSVX computes the solution to system of linear equations A * X = B for OTHER matrices
Definition cspsvx.f:277
cspsv
subroutine cspsv(uplo, n, nrhs, ap, ipiv, b, ldb, info)
CSPSV computes the solution to system of linear equations A * X = B for OTHER matrices
Definition cspsv.f:162

◆ cdrvsy()

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

CDRVSY

CDRVSYX

Purpose:
!>
!> CDRVSY tests the driver routines CSYSV 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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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:
!>
!> CDRVSY tests the driver routines CSYSV, -SVX, and -SVXX.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise cdrvsy.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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension
!>                      (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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 cdrvsy.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 REAL THRESH
162* ..
163* .. Array Arguments ..
164 LOGICAL DOTYPE( * )
165 INTEGER IWORK( * ), NVAL( * )
166 REAL RWORK( * )
167 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
168 $ WORK( * ), X( * ), XACT( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 REAL ONE, ZERO
175 parameter( one = 1.0e+0, zero = 0.0e+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 REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC
189* ..
190* .. Local Arrays ..
191 CHARACTER FACTS( NFACT ), UPLOS( 2 )
192 INTEGER ISEED( 4 ), ISEEDY( 4 )
193 REAL RESULT( NTESTS )
194* ..
195* .. External Functions ..
196 REAL CLANSY, SGET06
197 EXTERNAL clansy, sget06
198* ..
199* .. External Subroutines ..
200 EXTERNAL aladhd, alaerh, alasvm, cerrvx, cget04, clacpy,
201 $ clarhs, claset, clatb4, clatms, clatsy, cpot05,
202 $ csysv, csysvx, csyt01, csyt02, csytrf, csytri2,
203 $ xlaenv
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 cmplx, 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 ) = 'Complex 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 cerrvx( 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 CLATB4 and generate a test
279* matrix with CLATMS.
280*
281 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
282 $ MODE, CNDNUM, DIST )
283*
284 srnamt = 'CLATMS'
285 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
286 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
287 $ WORK, INFO )
288*
289* Check error code from CLATMS.
290*
291 IF( info.NE.0 ) THEN
292 CALL alaerh( path, 'CLATMS', 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 clatsy( 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 CSYSVX.
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 = clansy( '1', uplo, n, a, lda, rwork )
391*
392* Factor the matrix A.
393*
394 CALL clacpy( uplo, n, n, a, lda, afac, lda )
395 CALL csytrf( uplo, n, afac, lda, iwork, work,
396 $ lwork, info )
397*
398* Compute inv(A) and take its norm.
399*
400 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
401 lwork = (n+nb+1)*(nb+3)
402 CALL csytri2( uplo, n, ainv, lda, iwork, work,
403 $ lwork, info )
404 ainvnm = clansy( '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 = 'CLARHS'
418 CALL clarhs( path, xtype, uplo, ' ', n, n, kl, ku,
419 $ nrhs, a, lda, xact, lda, b, lda, iseed,
420 $ info )
421 xtype = 'C'
422*
423* --- Test CSYSV ---
424*
425 IF( ifact.EQ.2 ) THEN
426 CALL clacpy( uplo, n, n, a, lda, afac, lda )
427 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
428*
429* Factor the matrix and solve the system using CSYSV.
430*
431 srnamt = 'CSYSV '
432 CALL csysv( 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 CSYSV .
453*
454 IF( info.NE.k ) THEN
455 CALL alaerh( path, 'CSYSV ', 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 csyt01( uplo, n, a, lda, afac, lda, iwork,
467 $ ainv, lda, rwork, result( 1 ) )
468*
469* Compute residual of the computed solution.
470*
471 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
472 CALL csyt02( uplo, n, nrhs, a, lda, x, lda, work,
473 $ lda, rwork, result( 2 ) )
474*
475* Check solution from generated exact solution.
476*
477 CALL cget04( 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 )'CSYSV ', 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 CSYSVX ---
498*
499 IF( ifact.EQ.2 )
500 $ CALL claset( uplo, n, n, cmplx( zero ),
501 $ cmplx( zero ), afac, lda )
502 CALL claset( 'Full', n, nrhs, cmplx( zero ),
503 $ cmplx( zero ), x, lda )
504*
505* Solve the system and compute the condition number and
506* error bounds using CSYSVX.
507*
508 srnamt = 'CSYSVX'
509 CALL csysvx( 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 CSYSVX.
532*
533 IF( info.NE.k ) THEN
534 CALL alaerh( path, 'CSYSVX', 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 csyt01( 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 clacpy( 'Full', n, nrhs, b, lda, work, lda )
557 CALL csyt02( 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 cget04( n, nrhs, x, lda, xact, lda, rcondc,
563 $ result( 3 ) )
564*
565* Check the error bounds from iterative refinement.
566*
567 CALL cpot05( 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 CSYSVX with the computed value
575* in RCONDC.
576*
577 result( 6 ) = sget06( 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 )'CSYSVX', 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 CDRVSY
610*
csysv
subroutine csysv(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
CSYSV computes the solution to system of linear equations A * X = B for SY matrices
Definition csysv.f:171
csysvx
subroutine csysvx(fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, lwork, rwork, info)
CSYSVX computes the solution to system of linear equations A * X = B for SY matrices
Definition csysvx.f:285

◆ cdrvsy_aa()

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

CDRVSY_AA

Purpose:
!>
!> CDRVSY_AA tests the driver routine CSYSV_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 REAL
!>          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 REAL array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is REAL array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is REAL array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is REAL array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is REAL array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is REAL array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is REAL array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is REAL 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 cdrvsy_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 REAL THRESH
162* ..
163* .. Array Arguments ..
164 LOGICAL DOTYPE( * )
165 INTEGER IWORK( * ), NVAL( * )
166 REAL RWORK( * )
167 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
168 $ WORK( * ), X( * ), XACT( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 REAL ZERO
175 parameter( zero = 0.0d+0 )
176 COMPLEX 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 REAL ANORM, CNDNUM
191* ..
192* .. Local Arrays ..
193 CHARACTER FACTS( NFACT ), UPLOS( 2 )
194 INTEGER ISEED( 4 ), ISEEDY( 4 )
195 REAL RESULT( NTESTS )
196* ..
197* .. External Functions ..
198 REAL DGET06, CLANSY
199 EXTERNAL dget06, clansy
200* ..
201* .. External Subroutines ..
202 EXTERNAL aladhd, alaerh, alasvm, cerrvx, cget04, clacpy,
203 $ clarhs, claset, clatb4, clatms, csyt02,
204 $ csysv_aa, csyt01_aa, csytrf_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 ) = 'Complex precision'
229 path( 2: 3 ) = 'SA'
230*
231* Path to generate matrices
232*
233 matpath( 1: 1 ) = 'Complex 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 cerrvx( 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 CLATB4 and generate a test matrix
287* with CLATMS.
288*
289 CALL clatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
290 $ MODE, CNDNUM, DIST )
291*
292 srnamt = 'CLATMS'
293 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
294 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
295 $ INFO )
296*
297* Check error code from CLATMS.
298*
299 IF( info.NE.0 ) THEN
300 CALL alaerh( path, 'CLATMS', 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 = 'CLARHS'
382 CALL clarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
383 $ nrhs, a, lda, xact, lda, b, lda, iseed,
384 $ info )
385 xtype = 'C'
386*
387* --- Test CSYSV_AA ---
388*
389 IF( ifact.EQ.2 ) THEN
390 CALL clacpy( uplo, n, n, a, lda, afac, lda )
391 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
392*
393* Factor the matrix and solve the system using CSYSV_AA.
394*
395 srnamt = 'CSYSV_AA'
396 CALL csysv_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 CSYSV_AA .
420*
421 IF( info.NE.k ) THEN
422 CALL alaerh( path, 'CSYSV_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 csyt01_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 clacpy( 'Full', n, nrhs, b, lda, work, lda )
440 CALL csyt02( 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 )'CSYSV_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 CDRVSY_AA
475*
csysv_aa
subroutine csysv_aa(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
CSYSV_AA computes the solution to system of linear equations A * X = B for SY matrices
Definition csysv_aa.f:162
dget06
double precision function dget06(rcond, rcondc)
DGET06
Definition dget06.f:55

◆ cdrvsy_aa_2stage()

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

CDRVSY_AA_2STAGE

Purpose:
!>
!> CDRVSY_AA_2STAGE tests the driver routine CSYSV_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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (NMAX*max(2,NRHS))
!>
[out]RWORK
!>          RWORK is COMPLEX 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 cdrvsy_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 REAL THRESH
164* ..
165* .. Array Arguments ..
166 LOGICAL DOTYPE( * )
167 INTEGER IWORK( * ), NVAL( * )
168 REAL RWORK( * )
169 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
170 $ WORK( * ), X( * ), XACT( * )
171* ..
172*
173* =====================================================================
174*
175* .. Parameters ..
176 COMPLEX CZERO
177 parameter( czero = ( 0.0e+0, 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 REAL ANORM, CNDNUM
191* ..
192* .. Local Arrays ..
193 CHARACTER FACTS( NFACT ), UPLOS( 2 )
194 INTEGER ISEED( 4 ), ISEEDY( 4 )
195 REAL RESULT( NTESTS )
196* ..
197* .. External Functions ..
198 COMPLEX CLANSY, SGET06
199 EXTERNAL clansy, sget06
200* ..
201* .. External Subroutines ..
202 EXTERNAL aladhd, alaerh, alasvm, xlaenv, cerrvx,
203 $ cget04, clacpy, clarhs, clatb4, clatms,
204 $ csysv_aa_2stage, csyt01_aa, csyt02,
205 $ csytrf_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 cmplx, 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 ) = 'Complex precision'
230 path( 2: 3 ) = 'S2'
231*
232* Path to generate matrices
233*
234 matpath( 1: 1 ) = 'Complex precision'
235 matpath( 2: 3 ) = 'SY'
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 cerrvx( 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 CLATB4 for the matrix generator
288* based on the type of matrix to be generated.
289*
290 CALL clatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
291 $ MODE, CNDNUM, DIST )
292*
293* Generate a matrix with CLATMS.
294*
295 srnamt = 'CLATMS'
296 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
297 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
298 $ WORK, INFO )
299*
300* Check error code from CLATMS and handle error.
301*
302 IF( info.NE.0 ) THEN
303 CALL alaerh( path, 'CLATMS', 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 ) = czero
328 20 CONTINUE
329 ioff = ioff + izero
330 DO 30 i = izero, n
331 a( ioff ) = czero
332 ioff = ioff + lda
333 30 CONTINUE
334 ELSE
335 ioff = izero
336 DO 40 i = 1, izero - 1
337 a( ioff ) = czero
338 ioff = ioff + lda
339 40 CONTINUE
340 ioff = ioff - izero
341 DO 50 i = izero, n
342 a( ioff+i ) = czero
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 ) = czero
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 ) = czero
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 = 'CLARHS'
389 CALL clarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
390 $ nrhs, a, lda, xact, lda, b, lda, iseed,
391 $ info )
392 xtype = 'C'
393*
394* --- Test CSYSV_AA_2STAGE ---
395*
396 IF( ifact.EQ.2 ) THEN
397 CALL clacpy( uplo, n, n, a, lda, afac, lda )
398 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
399*
400* Factor the matrix and solve the system using CSYSV_AA.
401*
402 srnamt = 'CSYSV_AA_2STAGE '
403 lwork = min(n*nb, 3*nmax*nmax)
404 CALL csysv_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 CSYSV_AA .
430*
431 IF( info.NE.k ) THEN
432 CALL alaerh( path, 'CSYSV_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 clacpy( 'Full', n, nrhs, b, lda, work, lda )
443 CALL csyt02( uplo, n, nrhs, a, lda, x, lda, work,
444 $ lda, rwork, result( 1 ) )
445*
446* Reconstruct matrix from factors and compute
447* residual.
448*
449c CALL CSY01_AA( UPLO, N, A, LDA, AFAC, LDA,
450c $ IWORK, AINV, LDA, RWORK,
451c $ RESULT( 2 ) )
452c NT = 2
453 nt = 1
454*
455* Print information about the tests that did not pass
456* the threshold.
457*
458 DO 110 k = 1, nt
459 IF( result( k ).GE.thresh ) THEN
460 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
461 $ CALL aladhd( nout, path )
462 WRITE( nout, fmt = 9999 )'CSYSV_AA_2STAGE ',
463 $ uplo, n, imat, k, result( k )
464 nfail = nfail + 1
465 END IF
466 110 CONTINUE
467 nrun = nrun + nt
468 120 CONTINUE
469 END IF
470*
471 150 CONTINUE
472*
473 160 CONTINUE
474 170 CONTINUE
475 180 CONTINUE
476*
477* Print a summary of the results.
478*
479 CALL alasvm( path, nout, nfail, nrun, nerrs )
480*
481 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
482 $ ', test ', i2, ', ratio =', g12.5 )
483 RETURN
484*
485* End of CSDRVSY_AA_2STAGE
486*
csysv_aa_2stage
subroutine csysv_aa_2stage(uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, work, lwork, info)
CSYSV_AA_2STAGE computes the solution to system of linear equations A * X = B for SY matrices
Definition csysv_aa_2stage.f:186

◆ cdrvsy_rk()

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

CDRVSY_RK

Purpose:
!>
!> CDRVSY_RK tests the driver routines CSYSV_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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]E
!>          E is COMPLEX array, dimension (NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]WORK
!>
[out]RWORK
!>          RWORK is REAL 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 cdrvsy_rk.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 REAL THRESH
166* ..
167* .. Array Arguments ..
168 LOGICAL DOTYPE( * )
169 INTEGER IWORK( * ), NVAL( * )
170 REAL RWORK( * )
171 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
172 $ WORK( * ), X( * ), XACT( * )
173* ..
174*
175* =====================================================================
176*
177* .. Parameters ..
178 REAL ONE, ZERO
179 parameter( one = 1.0e+0, zero = 0.0e+0 )
180 INTEGER NTYPES, NTESTS
181 parameter( ntypes = 11, 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 REAL AINVNM, ANORM, CNDNUM, RCONDC
193* ..
194* .. Local Arrays ..
195 CHARACTER FACTS( NFACT ), UPLOS( 2 )
196 INTEGER ISEED( 4 ), ISEEDY( 4 )
197 REAL RESULT( NTESTS )
198
199* ..
200* .. External Functions ..
201 REAL CLANSY
202 EXTERNAL clansy
203* ..
204* .. External Subroutines ..
205 EXTERNAL aladhd, alaerh, alasvm, xlaenv, cerrvx, cget04,
206 $ clacpy, clarhs, clatb4, clatms, clatsy,
207 $ csysv_rk, csyt01_3, csyt02, csytrf_rk, csytri_3
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 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 ) = 'Complex precision'
232 path( 2: 3 ) = 'SK'
233*
234* Path to generate matrices
235*
236 matpath( 1: 1 ) = 'Complex 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 lwork = max( 2*nmax, nmax*nrhs )
246*
247* Test the error exits
248*
249 IF( tsterr )
250 $ CALL cerrvx( path, nout )
251 infot = 0
252*
253* Set the block size and minimum block size for which the block
254* routine should be used, which will be later returned by ILAENV.
255*
256 nb = 1
257 nbmin = 2
258 CALL xlaenv( 1, nb )
259 CALL xlaenv( 2, nbmin )
260*
261* Do for each value of N in NVAL
262*
263 DO 180 in = 1, nn
264 n = nval( in )
265 lda = max( n, 1 )
266 xtype = 'N'
267 nimat = ntypes
268 IF( n.LE.0 )
269 $ nimat = 1
270*
271 DO 170 imat = 1, nimat
272*
273* Do the tests only if DOTYPE( IMAT ) is true.
274*
275 IF( .NOT.dotype( imat ) )
276 $ GO TO 170
277*
278* Skip types 3, 4, 5, or 6 if the matrix size is too small.
279*
280 zerot = imat.GE.3 .AND. imat.LE.6
281 IF( zerot .AND. n.LT.imat-2 )
282 $ GO TO 170
283*
284* Do first for UPLO = 'U', then for UPLO = 'L'
285*
286 DO 160 iuplo = 1, 2
287 uplo = uplos( iuplo )
288*
289 IF( imat.NE.ntypes ) THEN
290*
291* Begin generate the test matrix A.
292*
293* Set up parameters with CLATB4 for the matrix generator
294* based on the type of matrix to be generated.
295*
296 CALL clatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
297 $ MODE, CNDNUM, DIST )
298*
299* Generate a matrix with CLATMS.
300*
301 srnamt = 'CLATMS'
302 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
303 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
304 $ WORK, INFO )
305*
306* Check error code from CLATMS and handle error.
307*
308 IF( info.NE.0 ) THEN
309 CALL alaerh( path, 'CLATMS', info, 0, uplo, n, n,
310 $ -1, -1, -1, imat, nfail, nerrs, nout )
311 GO TO 160
312 END IF
313*
314* For types 3-6, zero one or more rows and columns of
315* the matrix to test that INFO is returned correctly.
316*
317 IF( zerot ) THEN
318 IF( imat.EQ.3 ) THEN
319 izero = 1
320 ELSE IF( imat.EQ.4 ) THEN
321 izero = n
322 ELSE
323 izero = n / 2 + 1
324 END IF
325*
326 IF( imat.LT.6 ) THEN
327*
328* Set row and column IZERO to zero.
329*
330 IF( iuplo.EQ.1 ) THEN
331 ioff = ( izero-1 )*lda
332 DO 20 i = 1, izero - 1
333 a( ioff+i ) = zero
334 20 CONTINUE
335 ioff = ioff + izero
336 DO 30 i = izero, n
337 a( ioff ) = zero
338 ioff = ioff + lda
339 30 CONTINUE
340 ELSE
341 ioff = izero
342 DO 40 i = 1, izero - 1
343 a( ioff ) = zero
344 ioff = ioff + lda
345 40 CONTINUE
346 ioff = ioff - izero
347 DO 50 i = izero, n
348 a( ioff+i ) = zero
349 50 CONTINUE
350 END IF
351 ELSE
352 IF( iuplo.EQ.1 ) THEN
353*
354* Set the first IZERO rows and columns to zero.
355*
356 ioff = 0
357 DO 70 j = 1, n
358 i2 = min( j, izero )
359 DO 60 i = 1, i2
360 a( ioff+i ) = zero
361 60 CONTINUE
362 ioff = ioff + lda
363 70 CONTINUE
364 ELSE
365*
366* Set the first IZERO rows and columns to zero.
367*
368 ioff = 0
369 DO 90 j = 1, n
370 i1 = max( j, izero )
371 DO 80 i = i1, n
372 a( ioff+i ) = zero
373 80 CONTINUE
374 ioff = ioff + lda
375 90 CONTINUE
376 END IF
377 END IF
378 ELSE
379 izero = 0
380 END IF
381*
382* End generate the test matrix A.
383*
384 ELSE
385*
386* IMAT = NTYPES: Use a special block diagonal matrix to
387* test alternate code for the 2-by-2 blocks.
388*
389 CALL clatsy( uplo, n, a, lda, iseed )
390 END IF
391*
392 DO 150 ifact = 1, nfact
393*
394* Do first for FACT = 'F', then for other values.
395*
396 fact = facts( ifact )
397*
398* Compute the condition number
399*
400 IF( zerot ) THEN
401 IF( ifact.EQ.1 )
402 $ GO TO 150
403 rcondc = zero
404*
405 ELSE IF( ifact.EQ.1 ) THEN
406*
407* Compute the 1-norm of A.
408*
409 anorm = clansy( '1', uplo, n, a, lda, rwork )
410*
411* Factor the matrix A.
412*
413
414 CALL clacpy( uplo, n, n, a, lda, afac, lda )
415 CALL csytrf_rk( uplo, n, afac, lda, e, iwork, work,
416 $ lwork, info )
417*
418* Compute inv(A) and take its norm.
419*
420 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
421 lwork = (n+nb+1)*(nb+3)
422*
423* We need to compute the inverse to compute
424* RCONDC that is used later in TEST3.
425*
426 CALL csytri_3( uplo, n, ainv, lda, e, iwork,
427 $ work, lwork, info )
428 ainvnm = clansy( '1', uplo, n, ainv, lda, rwork )
429*
430* Compute the 1-norm condition number of A.
431*
432 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
433 rcondc = one
434 ELSE
435 rcondc = ( one / anorm ) / ainvnm
436 END IF
437 END IF
438*
439* Form an exact solution and set the right hand side.
440*
441 srnamt = 'CLARHS'
442 CALL clarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
443 $ nrhs, a, lda, xact, lda, b, lda, iseed,
444 $ info )
445 xtype = 'C'
446*
447* --- Test CSYSV_RK ---
448*
449 IF( ifact.EQ.2 ) THEN
450 CALL clacpy( uplo, n, n, a, lda, afac, lda )
451 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
452*
453* Factor the matrix and solve the system using
454* CSYSV_RK.
455*
456 srnamt = 'CSYSV_RK'
457 CALL csysv_rk( uplo, n, nrhs, afac, lda, e, iwork,
458 $ x, lda, work, lwork, info )
459*
460* Adjust the expected value of INFO to account for
461* pivoting.
462*
463 k = izero
464 IF( k.GT.0 ) THEN
465 100 CONTINUE
466 IF( iwork( k ).LT.0 ) THEN
467 IF( iwork( k ).NE.-k ) THEN
468 k = -iwork( k )
469 GO TO 100
470 END IF
471 ELSE IF( iwork( k ).NE.k ) THEN
472 k = iwork( k )
473 GO TO 100
474 END IF
475 END IF
476*
477* Check error code from CSYSV_RK and handle error.
478*
479 IF( info.NE.k ) THEN
480 CALL alaerh( path, 'CSYSV_RK', info, k, uplo,
481 $ n, n, -1, -1, nrhs, imat, nfail,
482 $ nerrs, nout )
483 GO TO 120
484 ELSE IF( info.NE.0 ) THEN
485 GO TO 120
486 END IF
487*
488*+ TEST 1 Reconstruct matrix from factors and compute
489* residual.
490*
491 CALL csyt01_3( uplo, n, a, lda, afac, lda, e,
492 $ iwork, ainv, lda, rwork,
493 $ result( 1 ) )
494*
495*+ TEST 2 Compute residual of the computed solution.
496*
497 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
498 CALL csyt02( uplo, n, nrhs, a, lda, x, lda, work,
499 $ lda, rwork, result( 2 ) )
500*
501*+ TEST 3
502* Check solution from generated exact solution.
503*
504 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
505 $ result( 3 ) )
506 nt = 3
507*
508* Print information about the tests that did not pass
509* the threshold.
510*
511 DO 110 k = 1, nt
512 IF( result( k ).GE.thresh ) THEN
513 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
514 $ CALL aladhd( nout, path )
515 WRITE( nout, fmt = 9999 )'CSYSV_RK', uplo,
516 $ n, imat, k, result( k )
517 nfail = nfail + 1
518 END IF
519 110 CONTINUE
520 nrun = nrun + nt
521 120 CONTINUE
522 END IF
523*
524 150 CONTINUE
525*
526 160 CONTINUE
527 170 CONTINUE
528 180 CONTINUE
529*
530* Print a summary of the results.
531*
532 CALL alasvm( path, nout, nfail, nrun, nerrs )
533*
534 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
535 $ ', test ', i2, ', ratio =', g12.5 )
536 RETURN
537*
538* End of CDRVSY_RK
539*
csysv_rk
subroutine csysv_rk(uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work, lwork, info)
CSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices
Definition csysv_rk.f:228

◆ cdrvsy_rook()

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

CDRVSY_ROOK

Purpose:
!>
!> CDRVSY_ROOK tests the driver routines CSYSV_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 REAL
!>          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 array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is COMPLEX array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is COMPLEX array, dimension (NMAX*NRHS)
!>
[out]WORK
!>
[out]RWORK
!>          RWORK is REAL 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 149 of file cdrvsy_rook.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 LOGICAL TSTERR
159 INTEGER NMAX, NN, NOUT, NRHS
160 REAL THRESH
161* ..
162* .. Array Arguments ..
163 LOGICAL DOTYPE( * )
164 INTEGER IWORK( * ), NVAL( * )
165 REAL RWORK( * )
166 COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ),
167 $ WORK( * ), X( * ), XACT( * )
168* ..
169*
170* =====================================================================
171*
172* .. Parameters ..
173 REAL ONE, ZERO
174 parameter( one = 1.0e+0, zero = 0.0e+0 )
175 INTEGER NTYPES, NTESTS
176 parameter( ntypes = 11, ntests = 3 )
177 INTEGER NFACT
178 parameter( nfact = 2 )
179* ..
180* .. Local Scalars ..
181 LOGICAL ZEROT
182 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
183 CHARACTER*3 MATPATH, PATH
184 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
185 $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
186 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
187 REAL AINVNM, ANORM, CNDNUM, RCONDC
188* ..
189* .. Local Arrays ..
190 CHARACTER FACTS( NFACT ), UPLOS( 2 )
191 INTEGER ISEED( 4 ), ISEEDY( 4 )
192 REAL RESULT( NTESTS )
193
194* ..
195* .. External Functions ..
196 REAL CLANSY
197 EXTERNAL clansy
198* ..
199* .. External Subroutines ..
200 EXTERNAL aladhd, alaerh, alasvm, xlaenv, cerrvx, cget04,
201 $ clacpy, clarhs, claset, clatb4, clatms, clatsy,
202 $ cpot05, csysv_rook, csyt01_rook, csyt02,
203 $ csytrf_rook, csytri_rook
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 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 ) = 'Complex precision'
228 path( 2: 3 ) = 'SR'
229*
230* Path to generate matrices
231*
232 matpath( 1: 1 ) = 'Complex precision'
233 matpath( 2: 3 ) = 'SY'
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 lwork = max( 2*nmax, nmax*nrhs )
242*
243* Test the error exits
244*
245 IF( tsterr )
246 $ CALL cerrvx( path, nout )
247 infot = 0
248*
249* Set the block size and minimum block size for which the block
250* routine should be used, which will be later returned by ILAENV.
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 IF( imat.NE.ntypes ) THEN
286*
287* Begin generate the test matrix A.
288*
289* Set up parameters with CLATB4 for the matrix generator
290* based on the type of matrix to be generated.
291*
292 CALL clatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
293 $ MODE, CNDNUM, DIST )
294*
295* Generate a matrix with CLATMS.
296*
297 srnamt = 'CLATMS'
298 CALL clatms( n, n, dist, iseed, TYPE, RWORK, MODE,
299 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
300 $ WORK, INFO )
301*
302* Check error code from CLATMS and handle error.
303*
304 IF( info.NE.0 ) THEN
305 CALL alaerh( path, 'CLATMS', 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 ) = zero
330 20 CONTINUE
331 ioff = ioff + izero
332 DO 30 i = izero, n
333 a( ioff ) = zero
334 ioff = ioff + lda
335 30 CONTINUE
336 ELSE
337 ioff = izero
338 DO 40 i = 1, izero - 1
339 a( ioff ) = zero
340 ioff = ioff + lda
341 40 CONTINUE
342 ioff = ioff - izero
343 DO 50 i = izero, n
344 a( ioff+i ) = zero
345 50 CONTINUE
346 END IF
347 ELSE
348 IF( iuplo.EQ.1 ) THEN
349*
350* Set the first IZERO rows and columns to zero.
351*
352 ioff = 0
353 DO 70 j = 1, n
354 i2 = min( j, izero )
355 DO 60 i = 1, i2
356 a( ioff+i ) = zero
357 60 CONTINUE
358 ioff = ioff + lda
359 70 CONTINUE
360 ELSE
361*
362* Set the first IZERO rows and columns to zero.
363*
364 ioff = 0
365 DO 90 j = 1, n
366 i1 = max( j, izero )
367 DO 80 i = i1, n
368 a( ioff+i ) = zero
369 80 CONTINUE
370 ioff = ioff + lda
371 90 CONTINUE
372 END IF
373 END IF
374 ELSE
375 izero = 0
376 END IF
377*
378* End generate the test matrix A.
379*
380 ELSE
381*
382* IMAT = NTYPES: Use a special block diagonal matrix to
383* test alternate code for the 2-by-2 blocks.
384*
385 CALL clatsy( uplo, n, a, lda, iseed )
386 END IF
387*
388 DO 150 ifact = 1, nfact
389*
390* Do first for FACT = 'F', then for other values.
391*
392 fact = facts( ifact )
393*
394* Compute the condition number for comparison with
395* the value returned by CSYSVX_ROOK.
396*
397 IF( zerot ) THEN
398 IF( ifact.EQ.1 )
399 $ GO TO 150
400 rcondc = zero
401*
402 ELSE IF( ifact.EQ.1 ) THEN
403*
404* Compute the 1-norm of A.
405*
406 anorm = clansy( '1', uplo, n, a, lda, rwork )
407*
408* Factor the matrix A.
409*
410
411 CALL clacpy( uplo, n, n, a, lda, afac, lda )
412 CALL csytrf_rook( uplo, n, afac, lda, iwork, work,
413 $ lwork, info )
414*
415* Compute inv(A) and take its norm.
416*
417 CALL clacpy( uplo, n, n, afac, lda, ainv, lda )
418 lwork = (n+nb+1)*(nb+3)
419 CALL csytri_rook( uplo, n, ainv, lda, iwork,
420 $ work, info )
421 ainvnm = clansy( '1', uplo, n, ainv, lda, rwork )
422*
423* Compute the 1-norm condition number of A.
424*
425 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
426 rcondc = one
427 ELSE
428 rcondc = ( one / anorm ) / ainvnm
429 END IF
430 END IF
431*
432* Form an exact solution and set the right hand side.
433*
434 srnamt = 'CLARHS'
435 CALL clarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
436 $ nrhs, a, lda, xact, lda, b, lda, iseed,
437 $ info )
438 xtype = 'C'
439*
440* --- Test CSYSV_ROOK ---
441*
442 IF( ifact.EQ.2 ) THEN
443 CALL clacpy( uplo, n, n, a, lda, afac, lda )
444 CALL clacpy( 'Full', n, nrhs, b, lda, x, lda )
445*
446* Factor the matrix and solve the system using
447* CSYSV_ROOK.
448*
449 srnamt = 'CSYSV_ROOK'
450 CALL csysv_rook( uplo, n, nrhs, afac, lda, iwork,
451 $ x, lda, work, lwork, info )
452*
453* Adjust the expected value of INFO to account for
454* pivoting.
455*
456 k = izero
457 IF( k.GT.0 ) THEN
458 100 CONTINUE
459 IF( iwork( k ).LT.0 ) THEN
460 IF( iwork( k ).NE.-k ) THEN
461 k = -iwork( k )
462 GO TO 100
463 END IF
464 ELSE IF( iwork( k ).NE.k ) THEN
465 k = iwork( k )
466 GO TO 100
467 END IF
468 END IF
469*
470* Check error code from CSYSV_ROOK and handle error.
471*
472 IF( info.NE.k ) THEN
473 CALL alaerh( path, 'CSYSV_ROOK', info, k, uplo,
474 $ n, n, -1, -1, nrhs, imat, nfail,
475 $ nerrs, nout )
476 GO TO 120
477 ELSE IF( info.NE.0 ) THEN
478 GO TO 120
479 END IF
480*
481*+ TEST 1 Reconstruct matrix from factors and compute
482* residual.
483*
484 CALL csyt01_rook( uplo, n, a, lda, afac, lda,
485 $ iwork, ainv, lda, rwork,
486 $ result( 1 ) )
487*
488*+ TEST 2 Compute residual of the computed solution.
489*
490 CALL clacpy( 'Full', n, nrhs, b, lda, work, lda )
491 CALL csyt02( uplo, n, nrhs, a, lda, x, lda, work,
492 $ lda, rwork, result( 2 ) )
493*
494*+ TEST 3
495* Check solution from generated exact solution.
496*
497 CALL cget04( n, nrhs, x, lda, xact, lda, rcondc,
498 $ result( 3 ) )
499 nt = 3
500*
501* Print information about the tests that did not pass
502* the threshold.
503*
504 DO 110 k = 1, nt
505 IF( result( k ).GE.thresh ) THEN
506 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
507 $ CALL aladhd( nout, path )
508 WRITE( nout, fmt = 9999 )'CSYSV_ROOK', uplo,
509 $ n, imat, k, result( k )
510 nfail = nfail + 1
511 END IF
512 110 CONTINUE
513 nrun = nrun + nt
514 120 CONTINUE
515 END IF
516*
517 150 CONTINUE
518*
519 160 CONTINUE
520 170 CONTINUE
521 180 CONTINUE
522*
523* Print a summary of the results.
524*
525 CALL alasvm( path, nout, nfail, nrun, nerrs )
526*
527 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
528 $ ', test ', i2, ', ratio =', g12.5 )
529 RETURN
530*
531* End of CDRVSY_ROOK
532*
csysv_rook
subroutine csysv_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
CSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices
Definition csysv_rook.f:204

◆ cebchvxx()

subroutine cebchvxx ( real thresh,
character*3 path )

CEBCHVXX

Purpose: 

!>
!>  CEBCHVXX will run CGESVXX on a series of Hilbert matrices and then
!>  compare the error bounds returned by CGESVXX 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 cebchvxx.f.

96 IMPLICIT NONE
97* .. Scalar Arguments ..
98 REAL THRESH
99 CHARACTER*3 PATH
100
101 INTEGER NMAX, NPARAMS, NERRBND, NTESTS, KL, KU
102 parameter(nmax = 6, 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 REAL 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 ZDUM
119
120* .. Local Arrays ..
121 REAL 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 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 REAL SLAMCH
135
136* .. External Subroutines ..
137 EXTERNAL clahilb, cgesvxx, csysvxx, cposvxx,
138 $ cgbsvxx, clacpy, lsamen
139 LOGICAL LSAMEN
140
141* .. Intrinsic Functions ..
142 INTRINSIC sqrt, max, abs, real, aimag
143
144* .. Statement Functions ..
145 REAL CABS1
146* ..
147* .. Statement Function Definitions ..
148 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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 = slamch('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(real(n)), 10.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 clahilb(n, n, a, lda, invhilb, lda, b,
186 $ lda, work, info, path)
187
188* Copy A into ACOPY.
189 CALL clacpy('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.0e+0,0.0e+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.0e+0,0.0e+0)
207 END DO
208 END DO
209 CALL clacpy('ALL', kl+ku+1, n, ab, ldab, abcopy, ldab)
210
211* Call C**SVXX with default PARAMS and N_ERR_BND = 3.
212 IF ( lsamen( 2, c2, 'SY' ) ) THEN
213 CALL csysvxx(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 cposvxx(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 chesvxx(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 cgbsvxx(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 cgesvxx(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 C**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.0/(rnorm * rinorm)
295
296* Calculating the R for normwise rcond.
297 DO i = 1, n
298 rinv(i) = 0.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.0
308 DO i = 1, n
309 sumri = 0.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.0
325 normdif = 0.0
326 cwise_err = 0.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.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.0) THEN
334 cwise_err = slamch('OVERFLOW')
335 END IF
336 END DO
337 IF (normt .NE. 0.0) THEN
338 nwise_err = normdif / normt
339 ELSE IF (normdif .NE. 0.0) THEN
340 nwise_err = slamch('OVERFLOW')
341 ELSE
342 nwise_err = 0.0
343 ENDIF
344
345 DO i = 1, n
346 rinv(i) = 0.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.0
354 DO i = 1, n
355 sumri = 0.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.0*eps)
378 ELSE
379 IF (nwise_bnd .NE. 0.0) THEN
380 tstrat(1) = nwise_err / nwise_bnd
381 ELSE IF (nwise_err .NE. 0.0) THEN
382 tstrat(1) = 1/(16.0*eps)
383 ELSE
384 tstrat(1) = 0.0
385 END IF
386 IF (tstrat(1) .GT. 1.0) THEN
387 tstrat(1) = 1/(4.0*eps)
388 END IF
389 END IF
390 ELSE
391 nguar = 'NO'
392 IF (nwise_bnd .LT. 1.0) THEN
393 tstrat(1) = 1/(8.0*eps)
394 ELSE
395 tstrat(1) = 1.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.0*eps)
405 ELSE
406 IF (cwise_bnd .NE. 0.0) THEN
407 tstrat(2) = cwise_err / cwise_bnd
408 ELSE IF (cwise_err .NE. 0.0) THEN
409 tstrat(2) = 1/(16.0*eps)
410 ELSE
411 tstrat(2) = 0.0
412 END IF
413 IF (tstrat(2) .GT. 1.0) tstrat(2) = 1/(4.0*eps)
414 END IF
415 ELSE
416 cguar = 'NO'
417 IF (cwise_bnd .LT. 1.0) THEN
418 tstrat(2) = 1/(8.0*eps)
419 ELSE
420 tstrat(2) = 1.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.0)
430 $ tstrat(4) = 1.0 / tstrat(4)
431
432 tstrat(5) = ncond / nwise_rcond
433 IF (ncond .GE. condthresh .AND. tstrat(5) .LT. 1.0)
434 $ tstrat(5) = 1.0 / tstrat(5)
435
436 tstrat(6) = ccond / nwise_rcond
437 IF (ccond .GE. condthresh .AND. tstrat(6) .LT. 1.0)
438 $ tstrat(6) = 1.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( ' C', a2, 'SVXX: N =', i2, ', RHS = ', i2,
484 $ ', NWISE GUAR. = ', a, ', CWISE GUAR. = ', a,
485 $ ' test(',i1,') =', g12.5 )
486 9998 FORMAT( ' C', a2, 'SVXX: ', i6, ' out of ', i6,
487 $ ' tests failed to pass the threshold' )
488 9997 FORMAT( ' C', 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( ' C', a2, 'SVXX: N =', i2, ', INFO = ', i3,
504 $ ', ORCOND = ', g12.5, ', real RCOND = ', g12.5 )
505*
506* End of CEBCHVXX
507*
lsamen
logical function lsamen(n, ca, cb)
LSAMEN
Definition lsamen.f:74
cgbsvxx
subroutine cgbsvxx(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)
CGBSVXX computes the solution to system of linear equations A * X = B for GB matrices
Definition cgbsvxx.f:563
cgesvxx
subroutine cgesvxx(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)
CGESVXX computes the solution to system of linear equations A * X = B for GE matrices
Definition cgesvxx.f:543
chesvxx
subroutine chesvxx(fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, equed, s, b, ldb, x, ldx, rcond, rpvgrw, berr, n_err_bnds, err_bnds_norm, err_bnds_comp, nparams, params, work, rwork, info)
CHESVXX computes the solution to system of linear equations A * X = B for HE matrices
Definition chesvxx.f:509
cposvxx
subroutine cposvxx(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)
CPOSVXX computes the solution to system of linear equations A * X = B for PO matrices
Definition cposvxx.f:496
csysvxx
subroutine csysvxx(fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, equed, s, b, ldb, x, ldx, rcond, rpvgrw, berr, n_err_bnds, err_bnds_norm, err_bnds_comp, nparams, params, work, rwork, info)
CSYSVXX computes the solution to system of linear equations A * X = B for SY matrices
Definition csysvxx.f:509
clahilb
subroutine clahilb(n, nrhs, a, lda, x, ldx, b, ldb, work, info, path)
CLAHILB
Definition clahilb.f:134

◆ cerrge()

subroutine cerrge ( character*3 path,
integer nunit )

CERRGE

CERRGEX

Purpose:
!>
!> CERRGE tests the error exits for the COMPLEX 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:
!>
!> CERRGE tests the error exits for the COMPLEX routines
!> for general matrices.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise cerrge.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 cerrge.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 REAL ANRM, CCOND, RCOND
75* ..
76* .. Local Arrays ..
77 INTEGER IP( NMAX )
78 REAL R( NMAX ), R1( NMAX ), R2( NMAX )
79 COMPLEX 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, cgbcon, cgbequ, cgbrfs, cgbtf2, cgbtrf,
88 $ cgbtrs, cgecon, cgeequ, cgerfs, cgetf2, cgetrf,
89 $ cgetri, cgetrs, chkxer
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 cmplx, real
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 ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
114 af( i, j ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
115 10 CONTINUE
116 b( j ) = 0.
117 r1( j ) = 0.
118 r2( j ) = 0.
119 w( j ) = 0.
120 x( j ) = 0.
121 ip( j ) = j
122 20 CONTINUE
123 ok = .true.
124*
125* Test error exits of the routines that use the LU decomposition
126* of a general matrix.
127*
128 IF( lsamen( 2, c2, 'GE' ) ) THEN
129*
130* CGETRF
131*
132 srnamt = 'CGETRF'
133 infot = 1
134 CALL cgetrf( -1, 0, a, 1, ip, info )
135 CALL chkxer( 'CGETRF', infot, nout, lerr, ok )
136 infot = 2
137 CALL cgetrf( 0, -1, a, 1, ip, info )
138 CALL chkxer( 'CGETRF', infot, nout, lerr, ok )
139 infot = 4
140 CALL cgetrf( 2, 1, a, 1, ip, info )
141 CALL chkxer( 'CGETRF', infot, nout, lerr, ok )
142*
143* CGETF2
144*
145 srnamt = 'CGETF2'
146 infot = 1
147 CALL cgetf2( -1, 0, a, 1, ip, info )
148 CALL chkxer( 'CGETF2', infot, nout, lerr, ok )
149 infot = 2
150 CALL cgetf2( 0, -1, a, 1, ip, info )
151 CALL chkxer( 'CGETF2', infot, nout, lerr, ok )
152 infot = 4
153 CALL cgetf2( 2, 1, a, 1, ip, info )
154 CALL chkxer( 'CGETF2', infot, nout, lerr, ok )
155*
156* CGETRI
157*
158 srnamt = 'CGETRI'
159 infot = 1
160 CALL cgetri( -1, a, 1, ip, w, 1, info )
161 CALL chkxer( 'CGETRI', infot, nout, lerr, ok )
162 infot = 3
163 CALL cgetri( 2, a, 1, ip, w, 2, info )
164 CALL chkxer( 'CGETRI', infot, nout, lerr, ok )
165 infot = 6
166 CALL cgetri( 2, a, 2, ip, w, 1, info )
167 CALL chkxer( 'CGETRI', infot, nout, lerr, ok )
168*
169* CGETRS
170*
171 srnamt = 'CGETRS'
172 infot = 1
173 CALL cgetrs( '/', 0, 0, a, 1, ip, b, 1, info )
174 CALL chkxer( 'CGETRS', infot, nout, lerr, ok )
175 infot = 2
176 CALL cgetrs( 'N', -1, 0, a, 1, ip, b, 1, info )
177 CALL chkxer( 'CGETRS', infot, nout, lerr, ok )
178 infot = 3
179 CALL cgetrs( 'N', 0, -1, a, 1, ip, b, 1, info )
180 CALL chkxer( 'CGETRS', infot, nout, lerr, ok )
181 infot = 5
182 CALL cgetrs( 'N', 2, 1, a, 1, ip, b, 2, info )
183 CALL chkxer( 'CGETRS', infot, nout, lerr, ok )
184 infot = 8
185 CALL cgetrs( 'N', 2, 1, a, 2, ip, b, 1, info )
186 CALL chkxer( 'CGETRS', infot, nout, lerr, ok )
187*
188* CGERFS
189*
190 srnamt = 'CGERFS'
191 infot = 1
192 CALL cgerfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
193 $ r, info )
194 CALL chkxer( 'CGERFS', infot, nout, lerr, ok )
195 infot = 2
196 CALL cgerfs( 'N', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
197 $ w, r, info )
198 CALL chkxer( 'CGERFS', infot, nout, lerr, ok )
199 infot = 3
200 CALL cgerfs( 'N', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
201 $ w, r, info )
202 CALL chkxer( 'CGERFS', infot, nout, lerr, ok )
203 infot = 5
204 CALL cgerfs( 'N', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
205 $ r, info )
206 CALL chkxer( 'CGERFS', infot, nout, lerr, ok )
207 infot = 7
208 CALL cgerfs( 'N', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
209 $ r, info )
210 CALL chkxer( 'CGERFS', infot, nout, lerr, ok )
211 infot = 10
212 CALL cgerfs( 'N', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
213 $ r, info )
214 CALL chkxer( 'CGERFS', infot, nout, lerr, ok )
215 infot = 12
216 CALL cgerfs( 'N', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
217 $ r, info )
218 CALL chkxer( 'CGERFS', infot, nout, lerr, ok )
219*
220* CGECON
221*
222 srnamt = 'CGECON'
223 infot = 1
224 CALL cgecon( '/', 0, a, 1, anrm, rcond, w, r, info )
225 CALL chkxer( 'CGECON', infot, nout, lerr, ok )
226 infot = 2
227 CALL cgecon( '1', -1, a, 1, anrm, rcond, w, r, info )
228 CALL chkxer( 'CGECON', infot, nout, lerr, ok )
229 infot = 4
230 CALL cgecon( '1', 2, a, 1, anrm, rcond, w, r, info )
231 CALL chkxer( 'CGECON', infot, nout, lerr, ok )
232*
233* CGEEQU
234*
235 srnamt = 'CGEEQU'
236 infot = 1
237 CALL cgeequ( -1, 0, a, 1, r1, r2, rcond, ccond, anrm, info )
238 CALL chkxer( 'CGEEQU', infot, nout, lerr, ok )
239 infot = 2
240 CALL cgeequ( 0, -1, a, 1, r1, r2, rcond, ccond, anrm, info )
241 CALL chkxer( 'CGEEQU', infot, nout, lerr, ok )
242 infot = 4
243 CALL cgeequ( 2, 2, a, 1, r1, r2, rcond, ccond, anrm, info )
244 CALL chkxer( 'CGEEQU', infot, nout, lerr, ok )
245*
246* Test error exits of the routines that use the LU decomposition
247* of a general band matrix.
248*
249 ELSE IF( lsamen( 2, c2, 'GB' ) ) THEN
250*
251* CGBTRF
252*
253 srnamt = 'CGBTRF'
254 infot = 1
255 CALL cgbtrf( -1, 0, 0, 0, a, 1, ip, info )
256 CALL chkxer( 'CGBTRF', infot, nout, lerr, ok )
257 infot = 2
258 CALL cgbtrf( 0, -1, 0, 0, a, 1, ip, info )
259 CALL chkxer( 'CGBTRF', infot, nout, lerr, ok )
260 infot = 3
261 CALL cgbtrf( 1, 1, -1, 0, a, 1, ip, info )
262 CALL chkxer( 'CGBTRF', infot, nout, lerr, ok )
263 infot = 4
264 CALL cgbtrf( 1, 1, 0, -1, a, 1, ip, info )
265 CALL chkxer( 'CGBTRF', infot, nout, lerr, ok )
266 infot = 6
267 CALL cgbtrf( 2, 2, 1, 1, a, 3, ip, info )
268 CALL chkxer( 'CGBTRF', infot, nout, lerr, ok )
269*
270* CGBTF2
271*
272 srnamt = 'CGBTF2'
273 infot = 1
274 CALL cgbtf2( -1, 0, 0, 0, a, 1, ip, info )
275 CALL chkxer( 'CGBTF2', infot, nout, lerr, ok )
276 infot = 2
277 CALL cgbtf2( 0, -1, 0, 0, a, 1, ip, info )
278 CALL chkxer( 'CGBTF2', infot, nout, lerr, ok )
279 infot = 3
280 CALL cgbtf2( 1, 1, -1, 0, a, 1, ip, info )
281 CALL chkxer( 'CGBTF2', infot, nout, lerr, ok )
282 infot = 4
283 CALL cgbtf2( 1, 1, 0, -1, a, 1, ip, info )
284 CALL chkxer( 'CGBTF2', infot, nout, lerr, ok )
285 infot = 6
286 CALL cgbtf2( 2, 2, 1, 1, a, 3, ip, info )
287 CALL chkxer( 'CGBTF2', infot, nout, lerr, ok )
288*
289* CGBTRS
290*
291 srnamt = 'CGBTRS'
292 infot = 1
293 CALL cgbtrs( '/', 0, 0, 0, 1, a, 1, ip, b, 1, info )
294 CALL chkxer( 'CGBTRS', infot, nout, lerr, ok )
295 infot = 2
296 CALL cgbtrs( 'N', -1, 0, 0, 1, a, 1, ip, b, 1, info )
297 CALL chkxer( 'CGBTRS', infot, nout, lerr, ok )
298 infot = 3
299 CALL cgbtrs( 'N', 1, -1, 0, 1, a, 1, ip, b, 1, info )
300 CALL chkxer( 'CGBTRS', infot, nout, lerr, ok )
301 infot = 4
302 CALL cgbtrs( 'N', 1, 0, -1, 1, a, 1, ip, b, 1, info )
303 CALL chkxer( 'CGBTRS', infot, nout, lerr, ok )
304 infot = 5
305 CALL cgbtrs( 'N', 1, 0, 0, -1, a, 1, ip, b, 1, info )
306 CALL chkxer( 'CGBTRS', infot, nout, lerr, ok )
307 infot = 7
308 CALL cgbtrs( 'N', 2, 1, 1, 1, a, 3, ip, b, 2, info )
309 CALL chkxer( 'CGBTRS', infot, nout, lerr, ok )
310 infot = 10
311 CALL cgbtrs( 'N', 2, 0, 0, 1, a, 1, ip, b, 1, info )
312 CALL chkxer( 'CGBTRS', infot, nout, lerr, ok )
313*
314* CGBRFS
315*
316 srnamt = 'CGBRFS'
317 infot = 1
318 CALL cgbrfs( '/', 0, 0, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
319 $ r2, w, r, info )
320 CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
321 infot = 2
322 CALL cgbrfs( 'N', -1, 0, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
323 $ r2, w, r, info )
324 CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
325 infot = 3
326 CALL cgbrfs( 'N', 1, -1, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
327 $ r2, w, r, info )
328 CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
329 infot = 4
330 CALL cgbrfs( 'N', 1, 0, -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
331 $ r2, w, r, info )
332 CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
333 infot = 5
334 CALL cgbrfs( 'N', 1, 0, 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1,
335 $ r2, w, r, info )
336 CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
337 infot = 7
338 CALL cgbrfs( 'N', 2, 1, 1, 1, a, 2, af, 4, ip, b, 2, x, 2, r1,
339 $ r2, w, r, info )
340 CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
341 infot = 9
342 CALL cgbrfs( 'N', 2, 1, 1, 1, a, 3, af, 3, ip, b, 2, x, 2, r1,
343 $ r2, w, r, info )
344 CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
345 infot = 12
346 CALL cgbrfs( 'N', 2, 0, 0, 1, a, 1, af, 1, ip, b, 1, x, 2, r1,
347 $ r2, w, r, info )
348 CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
349 infot = 14
350 CALL cgbrfs( 'N', 2, 0, 0, 1, a, 1, af, 1, ip, b, 2, x, 1, r1,
351 $ r2, w, r, info )
352 CALL chkxer( 'CGBRFS', infot, nout, lerr, ok )
353*
354* CGBCON
355*
356 srnamt = 'CGBCON'
357 infot = 1
358 CALL cgbcon( '/', 0, 0, 0, a, 1, ip, anrm, rcond, w, r, info )
359 CALL chkxer( 'CGBCON', infot, nout, lerr, ok )
360 infot = 2
361 CALL cgbcon( '1', -1, 0, 0, a, 1, ip, anrm, rcond, w, r, info )
362 CALL chkxer( 'CGBCON', infot, nout, lerr, ok )
363 infot = 3
364 CALL cgbcon( '1', 1, -1, 0, a, 1, ip, anrm, rcond, w, r, info )
365 CALL chkxer( 'CGBCON', infot, nout, lerr, ok )
366 infot = 4
367 CALL cgbcon( '1', 1, 0, -1, a, 1, ip, anrm, rcond, w, r, info )
368 CALL chkxer( 'CGBCON', infot, nout, lerr, ok )
369 infot = 6
370 CALL cgbcon( '1', 2, 1, 1, a, 3, ip, anrm, rcond, w, r, info )
371 CALL chkxer( 'CGBCON', infot, nout, lerr, ok )
372*
373* CGBEQU
374*
375 srnamt = 'CGBEQU'
376 infot = 1
377 CALL cgbequ( -1, 0, 0, 0, a, 1, r1, r2, rcond, ccond, anrm,
378 $ info )
379 CALL chkxer( 'CGBEQU', infot, nout, lerr, ok )
380 infot = 2
381 CALL cgbequ( 0, -1, 0, 0, a, 1, r1, r2, rcond, ccond, anrm,
382 $ info )
383 CALL chkxer( 'CGBEQU', infot, nout, lerr, ok )
384 infot = 3
385 CALL cgbequ( 1, 1, -1, 0, a, 1, r1, r2, rcond, ccond, anrm,
386 $ info )
387 CALL chkxer( 'CGBEQU', infot, nout, lerr, ok )
388 infot = 4
389 CALL cgbequ( 1, 1, 0, -1, a, 1, r1, r2, rcond, ccond, anrm,
390 $ info )
391 CALL chkxer( 'CGBEQU', infot, nout, lerr, ok )
392 infot = 6
393 CALL cgbequ( 2, 2, 1, 1, a, 2, r1, r2, rcond, ccond, anrm,
394 $ info )
395 CALL chkxer( 'CGBEQU', infot, nout, lerr, ok )
396 END IF
397*
398* Print a summary line.
399*
400 CALL alaesm( path, ok, nout )
401*
402 RETURN
403*
404* End of CERRGE
405*
chkxer
subroutine chkxer(srnamt, infot, nout, lerr, ok)
Definition cblat2.f:3196
alaesm
subroutine alaesm(path, ok, nout)
ALAESM
Definition alaesm.f:63
cgbtf2
subroutine cgbtf2(m, n, kl, ku, ab, ldab, ipiv, info)
CGBTF2 computes the LU factorization of a general band matrix using the unblocked version of the algo...
Definition cgbtf2.f:145
cgetf2
subroutine cgetf2(m, n, a, lda, ipiv, info)
CGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row inter...
Definition cgetf2.f:108

◆ cerrgt()

subroutine cerrgt ( character*3 path,
integer nunit )

CERRGT

Purpose:
!>
!> CERRGT tests the error exits for the COMPLEX 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 cerrgt.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 REAL ANORM, RCOND
75* ..
76* .. Local Arrays ..
77 INTEGER IP( NMAX )
78 REAL D( NMAX ), DF( NMAX ), R1( NMAX ), R2( NMAX ),
79 $ RW( NMAX )
80 COMPLEX 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, cgtcon, cgtrfs, cgttrf, cgttrs, chkxer,
90 $ cptcon, cptrfs, cpttrf, cpttrs
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.
108 e( i ) = 2.
109 dl( i ) = 3.
110 du( i ) = 4.
111 10 CONTINUE
112 anorm = 1.0
113 ok = .true.
114*
115 IF( lsamen( 2, c2, 'GT' ) ) THEN
116*
117* Test error exits for the general tridiagonal routines.
118*
119* CGTTRF
120*
121 srnamt = 'CGTTRF'
122 infot = 1
123 CALL cgttrf( -1, dl, e, du, du2, ip, info )
124 CALL chkxer( 'CGTTRF', infot, nout, lerr, ok )
125*
126* CGTTRS
127*
128 srnamt = 'CGTTRS'
129 infot = 1
130 CALL cgttrs( '/', 0, 0, dl, e, du, du2, ip, x, 1, info )
131 CALL chkxer( 'CGTTRS', infot, nout, lerr, ok )
132 infot = 2
133 CALL cgttrs( 'N', -1, 0, dl, e, du, du2, ip, x, 1, info )
134 CALL chkxer( 'CGTTRS', infot, nout, lerr, ok )
135 infot = 3
136 CALL cgttrs( 'N', 0, -1, dl, e, du, du2, ip, x, 1, info )
137 CALL chkxer( 'CGTTRS', infot, nout, lerr, ok )
138 infot = 10
139 CALL cgttrs( 'N', 2, 1, dl, e, du, du2, ip, x, 1, info )
140 CALL chkxer( 'CGTTRS', infot, nout, lerr, ok )
141*
142* CGTRFS
143*
144 srnamt = 'CGTRFS'
145 infot = 1
146 CALL cgtrfs( '/', 0, 0, dl, e, du, dlf, ef, duf, du2, ip, b, 1,
147 $ x, 1, r1, r2, w, rw, info )
148 CALL chkxer( 'CGTRFS', infot, nout, lerr, ok )
149 infot = 2
150 CALL cgtrfs( 'N', -1, 0, dl, e, du, dlf, ef, duf, du2, ip, b,
151 $ 1, x, 1, r1, r2, w, rw, info )
152 CALL chkxer( 'CGTRFS', infot, nout, lerr, ok )
153 infot = 3
154 CALL cgtrfs( 'N', 0, -1, dl, e, du, dlf, ef, duf, du2, ip, b,
155 $ 1, x, 1, r1, r2, w, rw, info )
156 CALL chkxer( 'CGTRFS', infot, nout, lerr, ok )
157 infot = 13
158 CALL cgtrfs( 'N', 2, 1, dl, e, du, dlf, ef, duf, du2, ip, b, 1,
159 $ x, 2, r1, r2, w, rw, info )
160 CALL chkxer( 'CGTRFS', infot, nout, lerr, ok )
161 infot = 15
162 CALL cgtrfs( 'N', 2, 1, dl, e, du, dlf, ef, duf, du2, ip, b, 2,
163 $ x, 1, r1, r2, w, rw, info )
164 CALL chkxer( 'CGTRFS', infot, nout, lerr, ok )
165*
166* CGTCON
167*
168 srnamt = 'CGTCON'
169 infot = 1
170 CALL cgtcon( '/', 0, dl, e, du, du2, ip, anorm, rcond, w,
171 $ info )
172 CALL chkxer( 'CGTCON', infot, nout, lerr, ok )
173 infot = 2
174 CALL cgtcon( 'I', -1, dl, e, du, du2, ip, anorm, rcond, w,
175 $ info )
176 CALL chkxer( 'CGTCON', infot, nout, lerr, ok )
177 infot = 8
178 CALL cgtcon( 'I', 0, dl, e, du, du2, ip, -anorm, rcond, w,
179 $ info )
180 CALL chkxer( 'CGTCON', 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* CPTTRF
188*
189 srnamt = 'CPTTRF'
190 infot = 1
191 CALL cpttrf( -1, d, e, info )
192 CALL chkxer( 'CPTTRF', infot, nout, lerr, ok )
193*
194* CPTTRS
195*
196 srnamt = 'CPTTRS'
197 infot = 1
198 CALL cpttrs( '/', 1, 0, d, e, x, 1, info )
199 CALL chkxer( 'CPTTRS', infot, nout, lerr, ok )
200 infot = 2
201 CALL cpttrs( 'U', -1, 0, d, e, x, 1, info )
202 CALL chkxer( 'CPTTRS', infot, nout, lerr, ok )
203 infot = 3
204 CALL cpttrs( 'U', 0, -1, d, e, x, 1, info )
205 CALL chkxer( 'CPTTRS', infot, nout, lerr, ok )
206 infot = 7
207 CALL cpttrs( 'U', 2, 1, d, e, x, 1, info )
208 CALL chkxer( 'CPTTRS', infot, nout, lerr, ok )
209*
210* CPTRFS
211*
212 srnamt = 'CPTRFS'
213 infot = 1
214 CALL cptrfs( '/', 1, 0, d, e, df, ef, b, 1, x, 1, r1, r2, w,
215 $ rw, info )
216 CALL chkxer( 'CPTRFS', infot, nout, lerr, ok )
217 infot = 2
218 CALL cptrfs( 'U', -1, 0, d, e, df, ef, b, 1, x, 1, r1, r2, w,
219 $ rw, info )
220 CALL chkxer( 'CPTRFS', infot, nout, lerr, ok )
221 infot = 3
222 CALL cptrfs( 'U', 0, -1, d, e, df, ef, b, 1, x, 1, r1, r2, w,
223 $ rw, info )
224 CALL chkxer( 'CPTRFS', infot, nout, lerr, ok )
225 infot = 9
226 CALL cptrfs( 'U', 2, 1, d, e, df, ef, b, 1, x, 2, r1, r2, w,
227 $ rw, info )
228 CALL chkxer( 'CPTRFS', infot, nout, lerr, ok )
229 infot = 11
230 CALL cptrfs( 'U', 2, 1, d, e, df, ef, b, 2, x, 1, r1, r2, w,
231 $ rw, info )
232 CALL chkxer( 'CPTRFS', infot, nout, lerr, ok )
233*
234* CPTCON
235*
236 srnamt = 'CPTCON'
237 infot = 1
238 CALL cptcon( -1, d, e, anorm, rcond, rw, info )
239 CALL chkxer( 'CPTCON', infot, nout, lerr, ok )
240 infot = 4
241 CALL cptcon( 0, d, e, -anorm, rcond, rw, info )
242 CALL chkxer( 'CPTCON', 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 CERRGT
252*

◆ cerrhe()

subroutine cerrhe ( character*3 path,
integer nunit )

CERRHE

CERRHEX

Purpose:
!>
!> CERRHE tests the error exits for the COMPLEX 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:
!>
!> CERRHE tests the error exits for the COMPLEX routines
!> for Hermitian indefinite matrices.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise cerrhe.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 cerrhe.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 REAL ANRM, RCOND
76* ..
77* .. Local Arrays ..
78 INTEGER IP( NMAX )
79 REAL R( NMAX ), R1( NMAX ), R2( NMAX )
80 COMPLEX 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, checon, csycon_3, checon_rook, cherfs,
89 $ chetf2, chetf2_rk, chetf2_rook, chetrf_aa,
90 $ chetrf, chetrf_rk, chetrf_rook, chetri,
91 $ chetri_3, chetri_3x, chetri_rook, chetri2,
92 $ chetri2x, chetrs, chetrs_3, chetrs_rook,
93 $ chetrs_aa, chkxer, chpcon, chprfs, chptrf,
94 $ chetrf_aa_2stage, chetrs_aa_2stage,
95 $ chptri, chptrs
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 cmplx, real
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 ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
120 af( i, j ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
121 10 CONTINUE
122 b( j ) = 0.e+0
123 e( j ) = 0.e+0
124 r1( j ) = 0.e+0
125 r2( j ) = 0.e+0
126 w( j ) = 0.e+0
127 x( j ) = 0.e+0
128 ip( j ) = j
129 20 CONTINUE
130 anrm = 1.0
131 ok = .true.
132*
133 IF( lsamen( 2, c2, 'HE' ) ) THEN
134*
135* Test error exits of the routines that use factorization
136* of a Hermitian indefinite matrix with patrial
137* (Bunch-Kaufman) diagonal pivoting method.
138*
139* CHETRF
140*
141 srnamt = 'CHETRF'
142 infot = 1
143 CALL chetrf( '/', 0, a, 1, ip, w, 1, info )
144 CALL chkxer( 'CHETRF', infot, nout, lerr, ok )
145 infot = 2
146 CALL chetrf( 'U', -1, a, 1, ip, w, 1, info )
147 CALL chkxer( 'CHETRF', infot, nout, lerr, ok )
148 infot = 4
149 CALL chetrf( 'U', 2, a, 1, ip, w, 4, info )
150 CALL chkxer( 'CHETRF', infot, nout, lerr, ok )
151 infot = 7
152 CALL chetrf( 'U', 0, a, 1, ip, w, 0, info )
153 CALL chkxer( 'CHETRF', infot, nout, lerr, ok )
154 infot = 7
155 CALL chetrf( 'U', 0, a, 1, ip, w, -2, info )
156 CALL chkxer( 'CHETRF', infot, nout, lerr, ok )
157*
158* CHETF2
159*
160 srnamt = 'CHETF2'
161 infot = 1
162 CALL chetf2( '/', 0, a, 1, ip, info )
163 CALL chkxer( 'CHETF2', infot, nout, lerr, ok )
164 infot = 2
165 CALL chetf2( 'U', -1, a, 1, ip, info )
166 CALL chkxer( 'CHETF2', infot, nout, lerr, ok )
167 infot = 4
168 CALL chetf2( 'U', 2, a, 1, ip, info )
169 CALL chkxer( 'CHETF2', infot, nout, lerr, ok )
170*
171* CHETRI
172*
173 srnamt = 'CHETRI'
174 infot = 1
175 CALL chetri( '/', 0, a, 1, ip, w, info )
176 CALL chkxer( 'CHETRI', infot, nout, lerr, ok )
177 infot = 2
178 CALL chetri( 'U', -1, a, 1, ip, w, info )
179 CALL chkxer( 'CHETRI', infot, nout, lerr, ok )
180 infot = 4
181 CALL chetri( 'U', 2, a, 1, ip, w, info )
182 CALL chkxer( 'CHETRI', infot, nout, lerr, ok )
183*
184* CHETRI2
185*
186 srnamt = 'CHETRI2'
187 infot = 1
188 CALL chetri2( '/', 0, a, 1, ip, w, 1, info )
189 CALL chkxer( 'CHETRI2', infot, nout, lerr, ok )
190 infot = 2
191 CALL chetri2( 'U', -1, a, 1, ip, w, 1, info )
192 CALL chkxer( 'CHETRI2', infot, nout, lerr, ok )
193 infot = 4
194 CALL chetri2( 'U', 2, a, 1, ip, w, 1, info )
195 CALL chkxer( 'CHETRI2', infot, nout, lerr, ok )
196*
197* CHETRI2X
198*
199 srnamt = 'CHETRI2X'
200 infot = 1
201 CALL chetri2x( '/', 0, a, 1, ip, w, 1, info )
202 CALL chkxer( 'CHETRI2X', infot, nout, lerr, ok )
203 infot = 2
204 CALL chetri2x( 'U', -1, a, 1, ip, w, 1, info )
205 CALL chkxer( 'CHETRI2X', infot, nout, lerr, ok )
206 infot = 4
207 CALL chetri2x( 'U', 2, a, 1, ip, w, 1, info )
208 CALL chkxer( 'CHETRI2X', infot, nout, lerr, ok )
209*
210* CHETRS
211*
212 srnamt = 'CHETRS'
213 infot = 1
214 CALL chetrs( '/', 0, 0, a, 1, ip, b, 1, info )
215 CALL chkxer( 'CHETRS', infot, nout, lerr, ok )
216 infot = 2
217 CALL chetrs( 'U', -1, 0, a, 1, ip, b, 1, info )
218 CALL chkxer( 'CHETRS', infot, nout, lerr, ok )
219 infot = 3
220 CALL chetrs( 'U', 0, -1, a, 1, ip, b, 1, info )
221 CALL chkxer( 'CHETRS', infot, nout, lerr, ok )
222 infot = 5
223 CALL chetrs( 'U', 2, 1, a, 1, ip, b, 2, info )
224 CALL chkxer( 'CHETRS', infot, nout, lerr, ok )
225 infot = 8
226 CALL chetrs( 'U', 2, 1, a, 2, ip, b, 1, info )
227 CALL chkxer( 'CHETRS', infot, nout, lerr, ok )
228*
229* CHERFS
230*
231 srnamt = 'CHERFS'
232 infot = 1
233 CALL cherfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
234 $ r, info )
235 CALL chkxer( 'CHERFS', infot, nout, lerr, ok )
236 infot = 2
237 CALL cherfs( 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
238 $ w, r, info )
239 CALL chkxer( 'CHERFS', infot, nout, lerr, ok )
240 infot = 3
241 CALL cherfs( 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
242 $ w, r, info )
243 CALL chkxer( 'CHERFS', infot, nout, lerr, ok )
244 infot = 5
245 CALL cherfs( 'U', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
246 $ r, info )
247 CALL chkxer( 'CHERFS', infot, nout, lerr, ok )
248 infot = 7
249 CALL cherfs( 'U', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
250 $ r, info )
251 CALL chkxer( 'CHERFS', infot, nout, lerr, ok )
252 infot = 10
253 CALL cherfs( 'U', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
254 $ r, info )
255 CALL chkxer( 'CHERFS', infot, nout, lerr, ok )
256 infot = 12
257 CALL cherfs( 'U', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
258 $ r, info )
259 CALL chkxer( 'CHERFS', infot, nout, lerr, ok )
260*
261* CHECON
262*
263 srnamt = 'CHECON'
264 infot = 1
265 CALL checon( '/', 0, a, 1, ip, anrm, rcond, w, info )
266 CALL chkxer( 'CHECON', infot, nout, lerr, ok )
267 infot = 2
268 CALL checon( 'U', -1, a, 1, ip, anrm, rcond, w, info )
269 CALL chkxer( 'CHECON', infot, nout, lerr, ok )
270 infot = 4
271 CALL checon( 'U', 2, a, 1, ip, anrm, rcond, w, info )
272 CALL chkxer( 'CHECON', infot, nout, lerr, ok )
273 infot = 6
274 CALL checon( 'U', 1, a, 1, ip, -anrm, rcond, w, info )
275 CALL chkxer( 'CHECON', infot, nout, lerr, ok )
276*
277 ELSE IF( lsamen( 2, c2, 'HR' ) ) THEN
278*
279* Test error exits of the routines that use factorization
280* of a Hermitian indefinite matrix with rook
281* (bounded Bunch-Kaufman) diagonal pivoting method.
282*
283* CHETRF_ROOK
284*
285 srnamt = 'CHETRF_ROOK'
286 infot = 1
287 CALL chetrf_rook( '/', 0, a, 1, ip, w, 1, info )
288 CALL chkxer( 'CHETRF_ROOK', infot, nout, lerr, ok )
289 infot = 2
290 CALL chetrf_rook( 'U', -1, a, 1, ip, w, 1, info )
291 CALL chkxer( 'CHETRF_ROOK', infot, nout, lerr, ok )
292 infot = 4
293 CALL chetrf_rook( 'U', 2, a, 1, ip, w, 4, info )
294 CALL chkxer( 'CHETRF_ROOK', infot, nout, lerr, ok )
295 infot = 7
296 CALL chetrf_rook( 'U', 0, a, 1, ip, w, 0, info )
297 CALL chkxer( 'CHETRF_ROOK', infot, nout, lerr, ok )
298 infot = 7
299 CALL chetrf_rook( 'U', 0, a, 1, ip, w, -2, info )
300 CALL chkxer( 'CHETRF_ROOK', infot, nout, lerr, ok )
301*
302* CHETF2_ROOK
303*
304 srnamt = 'CHETF2_ROOK'
305 infot = 1
306 CALL chetf2_rook( '/', 0, a, 1, ip, info )
307 CALL chkxer( 'CHETF2_ROOK', infot, nout, lerr, ok )
308 infot = 2
309 CALL chetf2_rook( 'U', -1, a, 1, ip, info )
310 CALL chkxer( 'CHETF2_ROOK', infot, nout, lerr, ok )
311 infot = 4
312 CALL chetf2_rook( 'U', 2, a, 1, ip, info )
313 CALL chkxer( 'CHETF2_ROOK', infot, nout, lerr, ok )
314*
315* CHETRI_ROOK
316*
317 srnamt = 'CHETRI_ROOK'
318 infot = 1
319 CALL chetri_rook( '/', 0, a, 1, ip, w, info )
320 CALL chkxer( 'CHETRI_ROOK', infot, nout, lerr, ok )
321 infot = 2
322 CALL chetri_rook( 'U', -1, a, 1, ip, w, info )
323 CALL chkxer( 'CHETRI_ROOK', infot, nout, lerr, ok )
324 infot = 4
325 CALL chetri_rook( 'U', 2, a, 1, ip, w, info )
326 CALL chkxer( 'CHETRI_ROOK', infot, nout, lerr, ok )
327*
328* CHETRS_ROOK
329*
330 srnamt = 'CHETRS_ROOK'
331 infot = 1
332 CALL chetrs_rook( '/', 0, 0, a, 1, ip, b, 1, info )
333 CALL chkxer( 'CHETRS_ROOK', infot, nout, lerr, ok )
334 infot = 2
335 CALL chetrs_rook( 'U', -1, 0, a, 1, ip, b, 1, info )
336 CALL chkxer( 'CHETRS_ROOK', infot, nout, lerr, ok )
337 infot = 3
338 CALL chetrs_rook( 'U', 0, -1, a, 1, ip, b, 1, info )
339 CALL chkxer( 'CHETRS_ROOK', infot, nout, lerr, ok )
340 infot = 5
341 CALL chetrs_rook( 'U', 2, 1, a, 1, ip, b, 2, info )
342 CALL chkxer( 'CHETRS_ROOK', infot, nout, lerr, ok )
343 infot = 8
344 CALL chetrs_rook( 'U', 2, 1, a, 2, ip, b, 1, info )
345 CALL chkxer( 'CHETRS_ROOK', infot, nout, lerr, ok )
346*
347* CHECON_ROOK
348*
349 srnamt = 'CHECON_ROOK'
350 infot = 1
351 CALL checon_rook( '/', 0, a, 1, ip, anrm, rcond, w, info )
352 CALL chkxer( 'CHECON_ROOK', infot, nout, lerr, ok )
353 infot = 2
354 CALL checon_rook( 'U', -1, a, 1, ip, anrm, rcond, w, info )
355 CALL chkxer( 'CHECON_ROOK', infot, nout, lerr, ok )
356 infot = 4
357 CALL checon_rook( 'U', 2, a, 1, ip, anrm, rcond, w, info )
358 CALL chkxer( 'CHECON_ROOK', infot, nout, lerr, ok )
359 infot = 6
360 CALL checon_rook( 'U', 1, a, 1, ip, -anrm, rcond, w, info )
361 CALL chkxer( 'CHECON_ROOK', infot, nout, lerr, ok )
362*
363 ELSE IF( lsamen( 2, c2, 'HK' ) ) THEN
364*
365* Test error exits of the routines that use factorization
366* of a Hermitian indefinite matrix with rook
367* (bounded Bunch-Kaufman) pivoting with the new storage
368* format for factors L ( or U) and D.
369*
370* L (or U) is stored in A, diagonal of D is stored on the
371* diagonal of A, subdiagonal of D is stored in a separate array E.
372*
373* CHETRF_RK
374*
375 srnamt = 'CHETRF_RK'
376 infot = 1
377 CALL chetrf_rk( '/', 0, a, 1, e, ip, w, 1, info )
378 CALL chkxer( 'CHETRF_RK', infot, nout, lerr, ok )
379 infot = 2
380 CALL chetrf_rk( 'U', -1, a, 1, e, ip, w, 1, info )
381 CALL chkxer( 'CHETRF_RK', infot, nout, lerr, ok )
382 infot = 4
383 CALL chetrf_rk( 'U', 2, a, 1, e, ip, w, 4, info )
384 CALL chkxer( 'CHETRF_RK', infot, nout, lerr, ok )
385 infot = 8
386 CALL chetrf_rk( 'U', 0, a, 1, e, ip, w, 0, info )
387 CALL chkxer( 'CHETRF_RK', infot, nout, lerr, ok )
388 infot = 8
389 CALL chetrf_rk( 'U', 0, a, 1, e, ip, w, -2, info )
390 CALL chkxer( 'CHETRF_RK', infot, nout, lerr, ok )
391*
392* CHETF2_RK
393*
394 srnamt = 'CHETF2_RK'
395 infot = 1
396 CALL chetf2_rk( '/', 0, a, 1, e, ip, info )
397 CALL chkxer( 'CHETF2_RK', infot, nout, lerr, ok )
398 infot = 2
399 CALL chetf2_rk( 'U', -1, a, 1, e, ip, info )
400 CALL chkxer( 'CHETF2_RK', infot, nout, lerr, ok )
401 infot = 4
402 CALL chetf2_rk( 'U', 2, a, 1, e, ip, info )
403 CALL chkxer( 'CHETF2_RK', infot, nout, lerr, ok )
404*
405* CHETRI_3
406*
407 srnamt = 'CHETRI_3'
408 infot = 1
409 CALL chetri_3( '/', 0, a, 1, e, ip, w, 1, info )
410 CALL chkxer( 'CHETRI_3', infot, nout, lerr, ok )
411 infot = 2
412 CALL chetri_3( 'U', -1, a, 1, e, ip, w, 1, info )
413 CALL chkxer( 'CHETRI_3', infot, nout, lerr, ok )
414 infot = 4
415 CALL chetri_3( 'U', 2, a, 1, e, ip, w, 1, info )
416 CALL chkxer( 'CHETRI_3', infot, nout, lerr, ok )
417 infot = 8
418 CALL chetri_3( 'U', 0, a, 1, e, ip, w, 0, info )
419 CALL chkxer( 'CHETRI_3', infot, nout, lerr, ok )
420 infot = 8
421 CALL chetri_3( 'U', 0, a, 1, e, ip, w, -2, info )
422 CALL chkxer( 'CHETRI_3', infot, nout, lerr, ok )
423*
424* CHETRI_3X
425*
426 srnamt = 'CHETRI_3X'
427 infot = 1
428 CALL chetri_3x( '/', 0, a, 1, e, ip, w, 1, info )
429 CALL chkxer( 'CHETRI_3X', infot, nout, lerr, ok )
430 infot = 2
431 CALL chetri_3x( 'U', -1, a, 1, e, ip, w, 1, info )
432 CALL chkxer( 'CHETRI_3X', infot, nout, lerr, ok )
433 infot = 4
434 CALL chetri_3x( 'U', 2, a, 1, e, ip, w, 1, info )
435 CALL chkxer( 'CHETRI_3X', infot, nout, lerr, ok )
436*
437* CHETRS_3
438*
439 srnamt = 'CHETRS_3'
440 infot = 1
441 CALL chetrs_3( '/', 0, 0, a, 1, e, ip, b, 1, info )
442 CALL chkxer( 'CHETRS_3', infot, nout, lerr, ok )
443 infot = 2
444 CALL chetrs_3( 'U', -1, 0, a, 1, e, ip, b, 1, info )
445 CALL chkxer( 'CHETRS_3', infot, nout, lerr, ok )
446 infot = 3
447 CALL chetrs_3( 'U', 0, -1, a, 1, e, ip, b, 1, info )
448 CALL chkxer( 'CHETRS_3', infot, nout, lerr, ok )
449 infot = 5
450 CALL chetrs_3( 'U', 2, 1, a, 1, e, ip, b, 2, info )
451 CALL chkxer( 'CHETRS_3', infot, nout, lerr, ok )
452 infot = 9
453 CALL chetrs_3( 'U', 2, 1, a, 2, e, ip, b, 1, info )
454 CALL chkxer( 'CHETRS_3', infot, nout, lerr, ok )
455*
456* CHECON_3
457*
458 srnamt = 'CHECON_3'
459 infot = 1
460 CALL checon_3( '/', 0, a, 1, e, ip, anrm, rcond, w, info )
461 CALL chkxer( 'CHECON_3', infot, nout, lerr, ok )
462 infot = 2
463 CALL checon_3( 'U', -1, a, 1, e, ip, anrm, rcond, w, info )
464 CALL chkxer( 'CHECON_3', infot, nout, lerr, ok )
465 infot = 4
466 CALL checon_3( 'U', 2, a, 1, e, ip, anrm, rcond, w, info )
467 CALL chkxer( 'CHECON_3', infot, nout, lerr, ok )
468 infot = 7
469 CALL checon_3( 'U', 1, a, 1, e, ip, -1.0e0, rcond, w, info)
470 CALL chkxer( 'CHECON_3', infot, nout, lerr, ok )
471*
472 ELSE IF( lsamen( 2, c2, 'HA' ) ) THEN
473*
474* Test error exits of the routines that use factorization
475* of a Hermitian indefinite matrix with Aasen's algorithm.
476*
477* CHETRF_AA
478*
479 srnamt = 'CHETRF_AA'
480 infot = 1
481 CALL chetrf_aa( '/', 0, a, 1, ip, w, 1, info )
482 CALL chkxer( 'CHETRF_AA', infot, nout, lerr, ok )
483 infot = 2
484 CALL chetrf_aa( 'U', -1, a, 1, ip, w, 1, info )
485 CALL chkxer( 'CHETRF_AA', infot, nout, lerr, ok )
486 infot = 4
487 CALL chetrf_aa( 'U', 2, a, 1, ip, w, 4, info )
488 CALL chkxer( 'CHETRF_AA', infot, nout, lerr, ok )
489 infot = 7
490 CALL chetrf_aa( 'U', 2, a, 2, ip, w, 0, info )
491 CALL chkxer( 'CHETRF_AA', infot, nout, lerr, ok )
492 infot = 7
493 CALL chetrf_aa( 'U', 2, a, 2, ip, w, -2, info )
494 CALL chkxer( 'CHETRF_AA', infot, nout, lerr, ok )
495*
496* CHETRS_AA
497*
498 srnamt = 'CHETRS_AA'
499 infot = 1
500 CALL chetrs_aa( '/', 0, 0, a, 1, ip, b, 1, w, 1, info )
501 CALL chkxer( 'CHETRS_AA', infot, nout, lerr, ok )
502 infot = 2
503 CALL chetrs_aa( 'U', -1, 0, a, 1, ip, b, 1, w, 1, info )
504 CALL chkxer( 'CHETRS_AA', infot, nout, lerr, ok )
505 infot = 3
506 CALL chetrs_aa( 'U', 0, -1, a, 1, ip, b, 1, w, 1, info )
507 CALL chkxer( 'CHETRS_AA', infot, nout, lerr, ok )
508 infot = 5
509 CALL chetrs_aa( 'U', 2, 1, a, 1, ip, b, 2, w, 1, info )
510 CALL chkxer( 'CHETRS_AA', infot, nout, lerr, ok )
511 infot = 8
512 CALL chetrs_aa( 'U', 2, 1, a, 2, ip, b, 1, w, 1, info )
513 CALL chkxer( 'CHETRS_AA', infot, nout, lerr, ok )
514 infot = 10
515 CALL chetrs_aa( 'U', 2, 1, a, 2, ip, b, 2, w, 0, info )
516 CALL chkxer( 'CHETRS_AA', infot, nout, lerr, ok )
517 infot = 10
518 CALL chetrs_aa( 'U', 2, 1, a, 2, ip, b, 2, w, -2, info )
519 CALL chkxer( 'CHETRS_AA', infot, nout, lerr, ok )
520*
521 ELSE IF( lsamen( 2, c2, 'H2' ) ) THEN
522*
523* Test error exits of the routines that use factorization
524* of a symmetric indefinite matrix with Aasen's algorithm.
525*
526* CHETRF_AA_2STAGE
527*
528 srnamt = 'CHETRF_AA_2STAGE'
529 infot = 1
530 CALL chetrf_aa_2stage( '/', 0, a, 1, a, 1, ip, ip, w, 1,
531 $ info )
532 CALL chkxer( 'CHETRF_AA_2STAGE', infot, nout, lerr, ok )
533 infot = 2
534 CALL chetrf_aa_2stage( 'U', -1, a, 1, a, 1, ip, ip, w, 1,
535 $ info )
536 CALL chkxer( 'CHETRF_AA_2STAGE', infot, nout, lerr, ok )
537 infot = 4
538 CALL chetrf_aa_2stage( 'U', 2, a, 1, a, 2, ip, ip, w, 1,
539 $ info )
540 CALL chkxer( 'CHETRF_AA_2STAGE', infot, nout, lerr, ok )
541 infot = 6
542 CALL chetrf_aa_2stage( 'U', 2, a, 2, a, 1, ip, ip, w, 1,
543 $ info )
544 CALL chkxer( 'CHETRF_AA_2STAGE', infot, nout, lerr, ok )
545 infot = 10
546 CALL chetrf_aa_2stage( 'U', 2, a, 2, a, 8, ip, ip, w, 0,
547 $ info )
548 CALL chkxer( 'CHETRF_AA_2STAGE', infot, nout, lerr, ok )
549*
550* CHETRS_AA_2STAGE
551*
552 srnamt = 'CHETRS_AA_2STAGE'
553 infot = 1
554 CALL chetrs_aa_2stage( '/', 0, 0, a, 1, a, 1, ip, ip,
555 $ b, 1, info )
556 CALL chkxer( 'CHETRS_AA_2STAGE', infot, nout, lerr, ok )
557 infot = 2
558 CALL chetrs_aa_2stage( 'U', -1, 0, a, 1, a, 1, ip, ip,
559 $ b, 1, info )
560 CALL chkxer( 'CHETRS_AA_2STAGE', infot, nout, lerr, ok )
561 infot = 3
562 CALL chetrs_aa_2stage( 'U', 0, -1, a, 1, a, 1, ip, ip,
563 $ b, 1, info )
564 CALL chkxer( 'CHETRS_AA_2STAGE', infot, nout, lerr, ok )
565 infot = 5
566 CALL chetrs_aa_2stage( 'U', 2, 1, a, 1, a, 1, ip, ip,
567 $ b, 1, info )
568 CALL chkxer( 'CHETRS_AA_2STAGE', infot, nout, lerr, ok )
569 infot = 7
570 CALL chetrs_aa_2stage( 'U', 2, 1, a, 2, a, 1, ip, ip,
571 $ b, 1, info )
572 CALL chkxer( 'CHETRS_AA_2STAGE', infot, nout, lerr, ok )
573 infot = 11
574 CALL chetrs_aa_2stage( 'U', 2, 1, a, 2, a, 8, ip, ip,
575 $ b, 1, info )
576 CALL chkxer( 'CHETRS_AA_STAGE', infot, nout, lerr, ok )
577*
578* Test error exits of the routines that use factorization
579* of a Hermitian indefinite packed matrix with patrial
580* (Bunch-Kaufman) diagonal pivoting method.
581*
582 ELSE IF( lsamen( 2, c2, 'HP' ) ) THEN
583*
584* CHPTRF
585*
586 srnamt = 'CHPTRF'
587 infot = 1
588 CALL chptrf( '/', 0, a, ip, info )
589 CALL chkxer( 'CHPTRF', infot, nout, lerr, ok )
590 infot = 2
591 CALL chptrf( 'U', -1, a, ip, info )
592 CALL chkxer( 'CHPTRF', infot, nout, lerr, ok )
593*
594* CHPTRI
595*
596 srnamt = 'CHPTRI'
597 infot = 1
598 CALL chptri( '/', 0, a, ip, w, info )
599 CALL chkxer( 'CHPTRI', infot, nout, lerr, ok )
600 infot = 2
601 CALL chptri( 'U', -1, a, ip, w, info )
602 CALL chkxer( 'CHPTRI', infot, nout, lerr, ok )
603*
604* CHPTRS
605*
606 srnamt = 'CHPTRS'
607 infot = 1
608 CALL chptrs( '/', 0, 0, a, ip, b, 1, info )
609 CALL chkxer( 'CHPTRS', infot, nout, lerr, ok )
610 infot = 2
611 CALL chptrs( 'U', -1, 0, a, ip, b, 1, info )
612 CALL chkxer( 'CHPTRS', infot, nout, lerr, ok )
613 infot = 3
614 CALL chptrs( 'U', 0, -1, a, ip, b, 1, info )
615 CALL chkxer( 'CHPTRS', infot, nout, lerr, ok )
616 infot = 7
617 CALL chptrs( 'U', 2, 1, a, ip, b, 1, info )
618 CALL chkxer( 'CHPTRS', infot, nout, lerr, ok )
619*
620* CHPRFS
621*
622 srnamt = 'CHPRFS'
623 infot = 1
624 CALL chprfs( '/', 0, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
625 $ info )
626 CALL chkxer( 'CHPRFS', infot, nout, lerr, ok )
627 infot = 2
628 CALL chprfs( 'U', -1, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
629 $ info )
630 CALL chkxer( 'CHPRFS', infot, nout, lerr, ok )
631 infot = 3
632 CALL chprfs( 'U', 0, -1, a, af, ip, b, 1, x, 1, r1, r2, w, r,
633 $ info )
634 CALL chkxer( 'CHPRFS', infot, nout, lerr, ok )
635 infot = 8
636 CALL chprfs( 'U', 2, 1, a, af, ip, b, 1, x, 2, r1, r2, w, r,
637 $ info )
638 CALL chkxer( 'CHPRFS', infot, nout, lerr, ok )
639 infot = 10
640 CALL chprfs( 'U', 2, 1, a, af, ip, b, 2, x, 1, r1, r2, w, r,
641 $ info )
642 CALL chkxer( 'CHPRFS', infot, nout, lerr, ok )
643*
644* CHPCON
645*
646 srnamt = 'CHPCON'
647 infot = 1
648 CALL chpcon( '/', 0, a, ip, anrm, rcond, w, info )
649 CALL chkxer( 'CHPCON', infot, nout, lerr, ok )
650 infot = 2
651 CALL chpcon( 'U', -1, a, ip, anrm, rcond, w, info )
652 CALL chkxer( 'CHPCON', infot, nout, lerr, ok )
653 infot = 5
654 CALL chpcon( 'U', 1, a, ip, -anrm, rcond, w, info )
655 CALL chkxer( 'CHPCON', infot, nout, lerr, ok )
656 END IF
657*
658* Print a summary line.
659*
660 CALL alaesm( path, ok, nout )
661*
662 RETURN
663*
664* End of CERRHE
665*
chetf2_rook
subroutine chetf2_rook(uplo, n, a, lda, ipiv, info)
CHETF2_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bun...
Definition chetf2_rook.f:194
chetri_3x
subroutine chetri_3x(uplo, n, a, lda, e, ipiv, work, nb, info)
CHETRI_3X
Definition chetri_3x.f:159
chetf2
subroutine chetf2(uplo, n, a, lda, ipiv, info)
CHETF2 computes the factorization of a complex Hermitian matrix, using the diagonal pivoting method (...
Definition chetf2.f:186
chetri2x
subroutine chetri2x(uplo, n, a, lda, ipiv, work, nb, info)
CHETRI2X
Definition chetri2x.f:120
chetri
subroutine chetri(uplo, n, a, lda, ipiv, work, info)
CHETRI
Definition chetri.f:114
chetf2_rk
subroutine chetf2_rk(uplo, n, a, lda, e, ipiv, info)
CHETF2_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded Bunch...
Definition chetf2_rk.f:241

◆ cerrlq()

subroutine cerrlq ( character*3 path,
integer nunit )

CERRLQ

Purpose:
!>
!> CERRLQ tests the error exits for the COMPLEX 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 cerrlq.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 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
76 $ W( NMAX ), X( NMAX )
77* ..
78* .. External Subroutines ..
79 EXTERNAL alaesm, cgelq2, cgelqf, cgelqs, chkxer, cungl2,
80 $ cunglq, cunml2, cunmlq
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 cmplx, real
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 ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
104 af( i, j ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
105 10 CONTINUE
106 b( j ) = 0.
107 w( j ) = 0.
108 x( j ) = 0.
109 20 CONTINUE
110 ok = .true.
111*
112* Error exits for LQ factorization
113*
114* CGELQF
115*
116 srnamt = 'CGELQF'
117 infot = 1
118 CALL cgelqf( -1, 0, a, 1, b, w, 1, info )
119 CALL chkxer( 'CGELQF', infot, nout, lerr, ok )
120 infot = 2
121 CALL cgelqf( 0, -1, a, 1, b, w, 1, info )
122 CALL chkxer( 'CGELQF', infot, nout, lerr, ok )
123 infot = 4
124 CALL cgelqf( 2, 1, a, 1, b, w, 2, info )
125 CALL chkxer( 'CGELQF', infot, nout, lerr, ok )
126 infot = 7
127 CALL cgelqf( 2, 1, a, 2, b, w, 1, info )
128 CALL chkxer( 'CGELQF', infot, nout, lerr, ok )
129*
130* CGELQ2
131*
132 srnamt = 'CGELQ2'
133 infot = 1
134 CALL cgelq2( -1, 0, a, 1, b, w, info )
135 CALL chkxer( 'CGELQ2', infot, nout, lerr, ok )
136 infot = 2
137 CALL cgelq2( 0, -1, a, 1, b, w, info )
138 CALL chkxer( 'CGELQ2', infot, nout, lerr, ok )
139 infot = 4
140 CALL cgelq2( 2, 1, a, 1, b, w, info )
141 CALL chkxer( 'CGELQ2', infot, nout, lerr, ok )
142*
143* CGELQS
144*
145 srnamt = 'CGELQS'
146 infot = 1
147 CALL cgelqs( -1, 0, 0, a, 1, x, b, 1, w, 1, info )
148 CALL chkxer( 'CGELQS', infot, nout, lerr, ok )
149 infot = 2
150 CALL cgelqs( 0, -1, 0, a, 1, x, b, 1, w, 1, info )
151 CALL chkxer( 'CGELQS', infot, nout, lerr, ok )
152 infot = 2
153 CALL cgelqs( 2, 1, 0, a, 2, x, b, 1, w, 1, info )
154 CALL chkxer( 'CGELQS', infot, nout, lerr, ok )
155 infot = 3
156 CALL cgelqs( 0, 0, -1, a, 1, x, b, 1, w, 1, info )
157 CALL chkxer( 'CGELQS', infot, nout, lerr, ok )
158 infot = 5
159 CALL cgelqs( 2, 2, 0, a, 1, x, b, 2, w, 1, info )
160 CALL chkxer( 'CGELQS', infot, nout, lerr, ok )
161 infot = 8
162 CALL cgelqs( 1, 2, 0, a, 1, x, b, 1, w, 1, info )
163 CALL chkxer( 'CGELQS', infot, nout, lerr, ok )
164 infot = 10
165 CALL cgelqs( 1, 1, 2, a, 1, x, b, 1, w, 1, info )
166 CALL chkxer( 'CGELQS', infot, nout, lerr, ok )
167*
168* CUNGLQ
169*
170 srnamt = 'CUNGLQ'
171 infot = 1
172 CALL cunglq( -1, 0, 0, a, 1, x, w, 1, info )
173 CALL chkxer( 'CUNGLQ', infot, nout, lerr, ok )
174 infot = 2
175 CALL cunglq( 0, -1, 0, a, 1, x, w, 1, info )
176 CALL chkxer( 'CUNGLQ', infot, nout, lerr, ok )
177 infot = 2
178 CALL cunglq( 2, 1, 0, a, 2, x, w, 2, info )
179 CALL chkxer( 'CUNGLQ', infot, nout, lerr, ok )
180 infot = 3
181 CALL cunglq( 0, 0, -1, a, 1, x, w, 1, info )
182 CALL chkxer( 'CUNGLQ', infot, nout, lerr, ok )
183 infot = 3
184 CALL cunglq( 1, 1, 2, a, 1, x, w, 1, info )
185 CALL chkxer( 'CUNGLQ', infot, nout, lerr, ok )
186 infot = 5
187 CALL cunglq( 2, 2, 0, a, 1, x, w, 2, info )
188 CALL chkxer( 'CUNGLQ', infot, nout, lerr, ok )
189 infot = 8
190 CALL cunglq( 2, 2, 0, a, 2, x, w, 1, info )
191 CALL chkxer( 'CUNGLQ', infot, nout, lerr, ok )
192*
193* CUNGL2
194*
195 srnamt = 'CUNGL2'
196 infot = 1
197 CALL cungl2( -1, 0, 0, a, 1, x, w, info )
198 CALL chkxer( 'CUNGL2', infot, nout, lerr, ok )
199 infot = 2
200 CALL cungl2( 0, -1, 0, a, 1, x, w, info )
201 CALL chkxer( 'CUNGL2', infot, nout, lerr, ok )
202 infot = 2
203 CALL cungl2( 2, 1, 0, a, 2, x, w, info )
204 CALL chkxer( 'CUNGL2', infot, nout, lerr, ok )
205 infot = 3
206 CALL cungl2( 0, 0, -1, a, 1, x, w, info )
207 CALL chkxer( 'CUNGL2', infot, nout, lerr, ok )
208 infot = 3
209 CALL cungl2( 1, 1, 2, a, 1, x, w, info )
210 CALL chkxer( 'CUNGL2', infot, nout, lerr, ok )
211 infot = 5
212 CALL cungl2( 2, 2, 0, a, 1, x, w, info )
213 CALL chkxer( 'CUNGL2', infot, nout, lerr, ok )
214*
215* CUNMLQ
216*
217 srnamt = 'CUNMLQ'
218 infot = 1
219 CALL cunmlq( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
220 CALL chkxer( 'CUNMLQ', infot, nout, lerr, ok )
221 infot = 2
222 CALL cunmlq( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
223 CALL chkxer( 'CUNMLQ', infot, nout, lerr, ok )
224 infot = 3
225 CALL cunmlq( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, 1, info )
226 CALL chkxer( 'CUNMLQ', infot, nout, lerr, ok )
227 infot = 4
228 CALL cunmlq( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, 1, info )
229 CALL chkxer( 'CUNMLQ', infot, nout, lerr, ok )
230 infot = 5
231 CALL cunmlq( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, 1, info )
232 CALL chkxer( 'CUNMLQ', infot, nout, lerr, ok )
233 infot = 5
234 CALL cunmlq( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, 1, info )
235 CALL chkxer( 'CUNMLQ', infot, nout, lerr, ok )
236 infot = 5
237 CALL cunmlq( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, 1, info )
238 CALL chkxer( 'CUNMLQ', infot, nout, lerr, ok )
239 infot = 7
240 CALL cunmlq( 'L', 'N', 2, 0, 2, a, 1, x, af, 2, w, 1, info )
241 CALL chkxer( 'CUNMLQ', infot, nout, lerr, ok )
242 infot = 7
243 CALL cunmlq( 'R', 'N', 0, 2, 2, a, 1, x, af, 1, w, 1, info )
244 CALL chkxer( 'CUNMLQ', infot, nout, lerr, ok )
245 infot = 10
246 CALL cunmlq( 'L', 'N', 2, 1, 0, a, 2, x, af, 1, w, 1, info )
247 CALL chkxer( 'CUNMLQ', infot, nout, lerr, ok )
248 infot = 12
249 CALL cunmlq( 'L', 'N', 1, 2, 0, a, 1, x, af, 1, w, 1, info )
250 CALL chkxer( 'CUNMLQ', infot, nout, lerr, ok )
251 infot = 12
252 CALL cunmlq( 'R', 'N', 2, 1, 0, a, 1, x, af, 2, w, 1, info )
253 CALL chkxer( 'CUNMLQ', infot, nout, lerr, ok )
254*
255* CUNML2
256*
257 srnamt = 'CUNML2'
258 infot = 1
259 CALL cunml2( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, info )
260 CALL chkxer( 'CUNML2', infot, nout, lerr, ok )
261 infot = 2
262 CALL cunml2( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, info )
263 CALL chkxer( 'CUNML2', infot, nout, lerr, ok )
264 infot = 3
265 CALL cunml2( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, info )
266 CALL chkxer( 'CUNML2', infot, nout, lerr, ok )
267 infot = 4
268 CALL cunml2( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, info )
269 CALL chkxer( 'CUNML2', infot, nout, lerr, ok )
270 infot = 5
271 CALL cunml2( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, info )
272 CALL chkxer( 'CUNML2', infot, nout, lerr, ok )
273 infot = 5
274 CALL cunml2( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, info )
275 CALL chkxer( 'CUNML2', infot, nout, lerr, ok )
276 infot = 5
277 CALL cunml2( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, info )
278 CALL chkxer( 'CUNML2', infot, nout, lerr, ok )
279 infot = 7
280 CALL cunml2( 'L', 'N', 2, 1, 2, a, 1, x, af, 2, w, info )
281 CALL chkxer( 'CUNML2', infot, nout, lerr, ok )
282 infot = 7
283 CALL cunml2( 'R', 'N', 1, 2, 2, a, 1, x, af, 1, w, info )
284 CALL chkxer( 'CUNML2', infot, nout, lerr, ok )
285 infot = 10
286 CALL cunml2( 'L', 'N', 2, 1, 0, a, 2, x, af, 1, w, info )
287 CALL chkxer( 'CUNML2', infot, nout, lerr, ok )
288*
289* Print a summary line.
290*
291 CALL alaesm( path, ok, nout )
292*
293 RETURN
294*
295* End of CERRLQ
296*
cgelq2
subroutine cgelq2(m, n, a, lda, tau, work, info)
CGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.
Definition cgelq2.f:129
cungl2
subroutine cungl2(m, n, k, a, lda, tau, work, info)
CUNGL2 generates all or part of the unitary matrix Q from an LQ factorization determined by cgelqf (u...
Definition cungl2.f:113
cunglq
subroutine cunglq(m, n, k, a, lda, tau, work, lwork, info)
CUNGLQ
Definition cunglq.f:127
cunmlq
subroutine cunmlq(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
CUNMLQ
Definition cunmlq.f:168
cunml2
subroutine cunml2(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
CUNML2 multiplies a general matrix by the unitary matrix from a LQ factorization determined by cgelqf...
Definition cunml2.f:159

◆ cerrls()

subroutine cerrls ( character*3 path,
integer nunit )

CERRLS

Purpose:
!>
!> CERRLS tests the error exits for the COMPLEX least squares
!> driver routines (CGELS, 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 cerrls.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 REAL RCOND
75* ..
76* .. Local Arrays ..
77 INTEGER IP( NMAX )
78 REAL RW( NMAX ), S( NMAX )
79 COMPLEX 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, cgels, cgelsd, cgelss, cgelsy, chkxer
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.0e+0, 0.0e+0 )
102 a( 1, 2 ) = ( 2.0e+0, 0.0e+0 )
103 a( 2, 2 ) = ( 3.0e+0, 0.0e+0 )
104 a( 2, 1 ) = ( 4.0e+0, 0.0e+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* CGELS
113*
114 srnamt = 'CGELS '
115 infot = 1
116 CALL cgels( '/', 0, 0, 0, a, 1, b, 1, w, 1, info )
117 CALL chkxer( 'CGELS ', infot, nout, lerr, ok )
118 infot = 2
119 CALL cgels( 'N', -1, 0, 0, a, 1, b, 1, w, 1, info )
120 CALL chkxer( 'CGELS ', infot, nout, lerr, ok )
121 infot = 3
122 CALL cgels( 'N', 0, -1, 0, a, 1, b, 1, w, 1, info )
123 CALL chkxer( 'CGELS ', infot, nout, lerr, ok )
124 infot = 4
125 CALL cgels( 'N', 0, 0, -1, a, 1, b, 1, w, 1, info )
126 CALL chkxer( 'CGELS ', infot, nout, lerr, ok )
127 infot = 6
128 CALL cgels( 'N', 2, 0, 0, a, 1, b, 2, w, 2, info )
129 CALL chkxer( 'CGELS ', infot, nout, lerr, ok )
130 infot = 8
131 CALL cgels( 'N', 2, 0, 0, a, 2, b, 1, w, 2, info )
132 CALL chkxer( 'CGELS ', infot, nout, lerr, ok )
133 infot = 10
134 CALL cgels( 'N', 1, 1, 0, a, 1, b, 1, w, 1, info )
135 CALL chkxer( 'CGELS ', infot, nout, lerr, ok )
136*
137* CGELSS
138*
139 srnamt = 'CGELSS'
140 infot = 1
141 CALL cgelss( -1, 0, 0, a, 1, b, 1, s, rcond, irnk, w, 1, rw,
142 $ info )
143 CALL chkxer( 'CGELSS', infot, nout, lerr, ok )
144 infot = 2
145 CALL cgelss( 0, -1, 0, a, 1, b, 1, s, rcond, irnk, w, 1, rw,
146 $ info )
147 CALL chkxer( 'CGELSS', infot, nout, lerr, ok )
148 infot = 3
149 CALL cgelss( 0, 0, -1, a, 1, b, 1, s, rcond, irnk, w, 1, rw,
150 $ info )
151 CALL chkxer( 'CGELSS', infot, nout, lerr, ok )
152 infot = 5
153 CALL cgelss( 2, 0, 0, a, 1, b, 2, s, rcond, irnk, w, 2, rw,
154 $ info )
155 CALL chkxer( 'CGELSS', infot, nout, lerr, ok )
156 infot = 7
157 CALL cgelss( 2, 0, 0, a, 2, b, 1, s, rcond, irnk, w, 2, rw,
158 $ info )
159 CALL chkxer( 'CGELSS', infot, nout, lerr, ok )
160*
161* CGELSY
162*
163 srnamt = 'CGELSY'
164 infot = 1
165 CALL cgelsy( -1, 0, 0, a, 1, b, 1, ip, rcond, irnk, w, 10, rw,
166 $ info )
167 CALL chkxer( 'CGELSY', infot, nout, lerr, ok )
168 infot = 2
169 CALL cgelsy( 0, -1, 0, a, 1, b, 1, ip, rcond, irnk, w, 10, rw,
170 $ info )
171 CALL chkxer( 'CGELSY', infot, nout, lerr, ok )
172 infot = 3
173 CALL cgelsy( 0, 0, -1, a, 1, b, 1, ip, rcond, irnk, w, 10, rw,
174 $ info )
175 CALL chkxer( 'CGELSY', infot, nout, lerr, ok )
176 infot = 5
177 CALL cgelsy( 2, 0, 0, a, 1, b, 2, ip, rcond, irnk, w, 10, rw,
178 $ info )
179 CALL chkxer( 'CGELSY', infot, nout, lerr, ok )
180 infot = 7
181 CALL cgelsy( 2, 0, 0, a, 2, b, 1, ip, rcond, irnk, w, 10, rw,
182 $ info )
183 CALL chkxer( 'CGELSY', infot, nout, lerr, ok )
184 infot = 12
185 CALL cgelsy( 0, 3, 0, a, 1, b, 3, ip, rcond, irnk, w, 1, rw,
186 $ info )
187 CALL chkxer( 'CGELSY', infot, nout, lerr, ok )
188*
189* CGELSD
190*
191 srnamt = 'CGELSD'
192 infot = 1
193 CALL cgelsd( -1, 0, 0, a, 1, b, 1, s, rcond, irnk, w, 10,
194 $ rw, ip, info )
195 CALL chkxer( 'CGELSD', infot, nout, lerr, ok )
196 infot = 2
197 CALL cgelsd( 0, -1, 0, a, 1, b, 1, s, rcond, irnk, w, 10,
198 $ rw, ip, info )
199 CALL chkxer( 'CGELSD', infot, nout, lerr, ok )
200 infot = 3
201 CALL cgelsd( 0, 0, -1, a, 1, b, 1, s, rcond, irnk, w, 10,
202 $ rw, ip, info )
203 CALL chkxer( 'CGELSD', infot, nout, lerr, ok )
204 infot = 5
205 CALL cgelsd( 2, 0, 0, a, 1, b, 2, s, rcond, irnk, w, 10,
206 $ rw, ip, info )
207 CALL chkxer( 'CGELSD', infot, nout, lerr, ok )
208 infot = 7
209 CALL cgelsd( 2, 0, 0, a, 2, b, 1, s, rcond, irnk, w, 10,
210 $ rw, ip, info )
211 CALL chkxer( 'CGELSD', infot, nout, lerr, ok )
212 infot = 12
213 CALL cgelsd( 2, 2, 1, a, 2, b, 2, s, rcond, irnk, w, 1,
214 $ rw, ip, info )
215 CALL chkxer( 'CGELSD', 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 CERRLS
225*

◆ cerrpo()

subroutine cerrpo ( character*3 path,
integer nunit )

CERRPO

CERRPOX

Purpose:
!>
!> CERRPO tests the error exits for the COMPLEX 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:
!>
!> CERRPO tests the error exits for the COMPLEX routines
!> for Hermitian positive definite matrices.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise cerrpo.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 cerrpo.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 REAL ANRM, RCOND
75* ..
76* .. Local Arrays ..
77 REAL R( NMAX ), R1( NMAX ), R2( NMAX )
78 COMPLEX 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, cpbcon, cpbequ, cpbrfs, cpbtf2,
87 $ cpbtrf, cpbtrs, cpocon, cpoequ, cporfs, cpotf2,
88 $ cpotrf, cpotri, cpotrs, cppcon, cppequ, cpprfs,
89 $ cpptrf, cpptri, cpptrs
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 cmplx, real
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 ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
114 af( i, j ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
115 10 CONTINUE
116 b( j ) = 0.
117 r1( j ) = 0.
118 r2( j ) = 0.
119 w( j ) = 0.
120 x( j ) = 0.
121 20 CONTINUE
122 anrm = 1.
123 ok = .true.
124*
125* Test error exits of the routines that use the Cholesky
126* decomposition of a Hermitian positive definite matrix.
127*
128 IF( lsamen( 2, c2, 'PO' ) ) THEN
129*
130* CPOTRF
131*
132 srnamt = 'CPOTRF'
133 infot = 1
134 CALL cpotrf( '/', 0, a, 1, info )
135 CALL chkxer( 'CPOTRF', infot, nout, lerr, ok )
136 infot = 2
137 CALL cpotrf( 'U', -1, a, 1, info )
138 CALL chkxer( 'CPOTRF', infot, nout, lerr, ok )
139 infot = 4
140 CALL cpotrf( 'U', 2, a, 1, info )
141 CALL chkxer( 'CPOTRF', infot, nout, lerr, ok )
142*
143* CPOTF2
144*
145 srnamt = 'CPOTF2'
146 infot = 1
147 CALL cpotf2( '/', 0, a, 1, info )
148 CALL chkxer( 'CPOTF2', infot, nout, lerr, ok )
149 infot = 2
150 CALL cpotf2( 'U', -1, a, 1, info )
151 CALL chkxer( 'CPOTF2', infot, nout, lerr, ok )
152 infot = 4
153 CALL cpotf2( 'U', 2, a, 1, info )
154 CALL chkxer( 'CPOTF2', infot, nout, lerr, ok )
155*
156* CPOTRI
157*
158 srnamt = 'CPOTRI'
159 infot = 1
160 CALL cpotri( '/', 0, a, 1, info )
161 CALL chkxer( 'CPOTRI', infot, nout, lerr, ok )
162 infot = 2
163 CALL cpotri( 'U', -1, a, 1, info )
164 CALL chkxer( 'CPOTRI', infot, nout, lerr, ok )
165 infot = 4
166 CALL cpotri( 'U', 2, a, 1, info )
167 CALL chkxer( 'CPOTRI', infot, nout, lerr, ok )
168*
169* CPOTRS
170*
171 srnamt = 'CPOTRS'
172 infot = 1
173 CALL cpotrs( '/', 0, 0, a, 1, b, 1, info )
174 CALL chkxer( 'CPOTRS', infot, nout, lerr, ok )
175 infot = 2
176 CALL cpotrs( 'U', -1, 0, a, 1, b, 1, info )
177 CALL chkxer( 'CPOTRS', infot, nout, lerr, ok )
178 infot = 3
179 CALL cpotrs( 'U', 0, -1, a, 1, b, 1, info )
180 CALL chkxer( 'CPOTRS', infot, nout, lerr, ok )
181 infot = 5
182 CALL cpotrs( 'U', 2, 1, a, 1, b, 2, info )
183 CALL chkxer( 'CPOTRS', infot, nout, lerr, ok )
184 infot = 7
185 CALL cpotrs( 'U', 2, 1, a, 2, b, 1, info )
186 CALL chkxer( 'CPOTRS', infot, nout, lerr, ok )
187*
188* CPORFS
189*
190 srnamt = 'CPORFS'
191 infot = 1
192 CALL cporfs( '/', 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w, r,
193 $ info )
194 CALL chkxer( 'CPORFS', infot, nout, lerr, ok )
195 infot = 2
196 CALL cporfs( 'U', -1, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w, r,
197 $ info )
198 CALL chkxer( 'CPORFS', infot, nout, lerr, ok )
199 infot = 3
200 CALL cporfs( 'U', 0, -1, a, 1, af, 1, b, 1, x, 1, r1, r2, w, r,
201 $ info )
202 CALL chkxer( 'CPORFS', infot, nout, lerr, ok )
203 infot = 5
204 CALL cporfs( 'U', 2, 1, a, 1, af, 2, b, 2, x, 2, r1, r2, w, r,
205 $ info )
206 CALL chkxer( 'CPORFS', infot, nout, lerr, ok )
207 infot = 7
208 CALL cporfs( 'U', 2, 1, a, 2, af, 1, b, 2, x, 2, r1, r2, w, r,
209 $ info )
210 CALL chkxer( 'CPORFS', infot, nout, lerr, ok )
211 infot = 9
212 CALL cporfs( 'U', 2, 1, a, 2, af, 2, b, 1, x, 2, r1, r2, w, r,
213 $ info )
214 CALL chkxer( 'CPORFS', infot, nout, lerr, ok )
215 infot = 11
216 CALL cporfs( 'U', 2, 1, a, 2, af, 2, b, 2, x, 1, r1, r2, w, r,
217 $ info )
218 CALL chkxer( 'CPORFS', infot, nout, lerr, ok )
219*
220* CPOCON
221*
222 srnamt = 'CPOCON'
223 infot = 1
224 CALL cpocon( '/', 0, a, 1, anrm, rcond, w, r, info )
225 CALL chkxer( 'CPOCON', infot, nout, lerr, ok )
226 infot = 2
227 CALL cpocon( 'U', -1, a, 1, anrm, rcond, w, r, info )
228 CALL chkxer( 'CPOCON', infot, nout, lerr, ok )
229 infot = 4
230 CALL cpocon( 'U', 2, a, 1, anrm, rcond, w, r, info )
231 CALL chkxer( 'CPOCON', infot, nout, lerr, ok )
232 infot = 5
233 CALL cpocon( 'U', 1, a, 1, -anrm, rcond, w, r, info )
234 CALL chkxer( 'CPOCON', infot, nout, lerr, ok )
235*
236* CPOEQU
237*
238 srnamt = 'CPOEQU'
239 infot = 1
240 CALL cpoequ( -1, a, 1, r1, rcond, anrm, info )
241 CALL chkxer( 'CPOEQU', infot, nout, lerr, ok )
242 infot = 3
243 CALL cpoequ( 2, a, 1, r1, rcond, anrm, info )
244 CALL chkxer( 'CPOEQU', infot, nout, lerr, ok )
245*
246* Test error exits of the routines that use the Cholesky
247* decomposition of a Hermitian positive definite packed matrix.
248*
249 ELSE IF( lsamen( 2, c2, 'PP' ) ) THEN
250*
251* CPPTRF
252*
253 srnamt = 'CPPTRF'
254 infot = 1
255 CALL cpptrf( '/', 0, a, info )
256 CALL chkxer( 'CPPTRF', infot, nout, lerr, ok )
257 infot = 2
258 CALL cpptrf( 'U', -1, a, info )
259 CALL chkxer( 'CPPTRF', infot, nout, lerr, ok )
260*
261* CPPTRI
262*
263 srnamt = 'CPPTRI'
264 infot = 1
265 CALL cpptri( '/', 0, a, info )
266 CALL chkxer( 'CPPTRI', infot, nout, lerr, ok )
267 infot = 2
268 CALL cpptri( 'U', -1, a, info )
269 CALL chkxer( 'CPPTRI', infot, nout, lerr, ok )
270*
271* CPPTRS
272*
273 srnamt = 'CPPTRS'
274 infot = 1
275 CALL cpptrs( '/', 0, 0, a, b, 1, info )
276 CALL chkxer( 'CPPTRS', infot, nout, lerr, ok )
277 infot = 2
278 CALL cpptrs( 'U', -1, 0, a, b, 1, info )
279 CALL chkxer( 'CPPTRS', infot, nout, lerr, ok )
280 infot = 3
281 CALL cpptrs( 'U', 0, -1, a, b, 1, info )
282 CALL chkxer( 'CPPTRS', infot, nout, lerr, ok )
283 infot = 6
284 CALL cpptrs( 'U', 2, 1, a, b, 1, info )
285 CALL chkxer( 'CPPTRS', infot, nout, lerr, ok )
286*
287* CPPRFS
288*
289 srnamt = 'CPPRFS'
290 infot = 1
291 CALL cpprfs( '/', 0, 0, a, af, b, 1, x, 1, r1, r2, w, r, info )
292 CALL chkxer( 'CPPRFS', infot, nout, lerr, ok )
293 infot = 2
294 CALL cpprfs( 'U', -1, 0, a, af, b, 1, x, 1, r1, r2, w, r,
295 $ info )
296 CALL chkxer( 'CPPRFS', infot, nout, lerr, ok )
297 infot = 3
298 CALL cpprfs( 'U', 0, -1, a, af, b, 1, x, 1, r1, r2, w, r,
299 $ info )
300 CALL chkxer( 'CPPRFS', infot, nout, lerr, ok )
301 infot = 7
302 CALL cpprfs( 'U', 2, 1, a, af, b, 1, x, 2, r1, r2, w, r, info )
303 CALL chkxer( 'CPPRFS', infot, nout, lerr, ok )
304 infot = 9
305 CALL cpprfs( 'U', 2, 1, a, af, b, 2, x, 1, r1, r2, w, r, info )
306 CALL chkxer( 'CPPRFS', infot, nout, lerr, ok )
307*
308* CPPCON
309*
310 srnamt = 'CPPCON'
311 infot = 1
312 CALL cppcon( '/', 0, a, anrm, rcond, w, r, info )
313 CALL chkxer( 'CPPCON', infot, nout, lerr, ok )
314 infot = 2
315 CALL cppcon( 'U', -1, a, anrm, rcond, w, r, info )
316 CALL chkxer( 'CPPCON', infot, nout, lerr, ok )
317 infot = 4
318 CALL cppcon( 'U', 1, a, -anrm, rcond, w, r, info )
319 CALL chkxer( 'CPPCON', infot, nout, lerr, ok )
320*
321* CPPEQU
322*
323 srnamt = 'CPPEQU'
324 infot = 1
325 CALL cppequ( '/', 0, a, r1, rcond, anrm, info )
326 CALL chkxer( 'CPPEQU', infot, nout, lerr, ok )
327 infot = 2
328 CALL cppequ( 'U', -1, a, r1, rcond, anrm, info )
329 CALL chkxer( 'CPPEQU', infot, nout, lerr, ok )
330*
331* Test error exits of the routines that use the Cholesky
332* decomposition of a Hermitian positive definite band matrix.
333*
334 ELSE IF( lsamen( 2, c2, 'PB' ) ) THEN
335*
336* CPBTRF
337*
338 srnamt = 'CPBTRF'
339 infot = 1
340 CALL cpbtrf( '/', 0, 0, a, 1, info )
341 CALL chkxer( 'CPBTRF', infot, nout, lerr, ok )
342 infot = 2
343 CALL cpbtrf( 'U', -1, 0, a, 1, info )
344 CALL chkxer( 'CPBTRF', infot, nout, lerr, ok )
345 infot = 3
346 CALL cpbtrf( 'U', 1, -1, a, 1, info )
347 CALL chkxer( 'CPBTRF', infot, nout, lerr, ok )
348 infot = 5
349 CALL cpbtrf( 'U', 2, 1, a, 1, info )
350 CALL chkxer( 'CPBTRF', infot, nout, lerr, ok )
351*
352* CPBTF2
353*
354 srnamt = 'CPBTF2'
355 infot = 1
356 CALL cpbtf2( '/', 0, 0, a, 1, info )
357 CALL chkxer( 'CPBTF2', infot, nout, lerr, ok )
358 infot = 2
359 CALL cpbtf2( 'U', -1, 0, a, 1, info )
360 CALL chkxer( 'CPBTF2', infot, nout, lerr, ok )
361 infot = 3
362 CALL cpbtf2( 'U', 1, -1, a, 1, info )
363 CALL chkxer( 'CPBTF2', infot, nout, lerr, ok )
364 infot = 5
365 CALL cpbtf2( 'U', 2, 1, a, 1, info )
366 CALL chkxer( 'CPBTF2', infot, nout, lerr, ok )
367*
368* CPBTRS
369*
370 srnamt = 'CPBTRS'
371 infot = 1
372 CALL cpbtrs( '/', 0, 0, 0, a, 1, b, 1, info )
373 CALL chkxer( 'CPBTRS', infot, nout, lerr, ok )
374 infot = 2
375 CALL cpbtrs( 'U', -1, 0, 0, a, 1, b, 1, info )
376 CALL chkxer( 'CPBTRS', infot, nout, lerr, ok )
377 infot = 3
378 CALL cpbtrs( 'U', 1, -1, 0, a, 1, b, 1, info )
379 CALL chkxer( 'CPBTRS', infot, nout, lerr, ok )
380 infot = 4
381 CALL cpbtrs( 'U', 0, 0, -1, a, 1, b, 1, info )
382 CALL chkxer( 'CPBTRS', infot, nout, lerr, ok )
383 infot = 6
384 CALL cpbtrs( 'U', 2, 1, 1, a, 1, b, 1, info )
385 CALL chkxer( 'CPBTRS', infot, nout, lerr, ok )
386 infot = 8
387 CALL cpbtrs( 'U', 2, 0, 1, a, 1, b, 1, info )
388 CALL chkxer( 'CPBTRS', infot, nout, lerr, ok )
389*
390* CPBRFS
391*
392 srnamt = 'CPBRFS'
393 infot = 1
394 CALL cpbrfs( '/', 0, 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
395 $ r, info )
396 CALL chkxer( 'CPBRFS', infot, nout, lerr, ok )
397 infot = 2
398 CALL cpbrfs( 'U', -1, 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
399 $ r, info )
400 CALL chkxer( 'CPBRFS', infot, nout, lerr, ok )
401 infot = 3
402 CALL cpbrfs( 'U', 1, -1, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
403 $ r, info )
404 CALL chkxer( 'CPBRFS', infot, nout, lerr, ok )
405 infot = 4
406 CALL cpbrfs( 'U', 0, 0, -1, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
407 $ r, info )
408 CALL chkxer( 'CPBRFS', infot, nout, lerr, ok )
409 infot = 6
410 CALL cpbrfs( 'U', 2, 1, 1, a, 1, af, 2, b, 2, x, 2, r1, r2, w,
411 $ r, info )
412 CALL chkxer( 'CPBRFS', infot, nout, lerr, ok )
413 infot = 8
414 CALL cpbrfs( 'U', 2, 1, 1, a, 2, af, 1, b, 2, x, 2, r1, r2, w,
415 $ r, info )
416 CALL chkxer( 'CPBRFS', infot, nout, lerr, ok )
417 infot = 10
418 CALL cpbrfs( 'U', 2, 0, 1, a, 1, af, 1, b, 1, x, 2, r1, r2, w,
419 $ r, info )
420 CALL chkxer( 'CPBRFS', infot, nout, lerr, ok )
421 infot = 12
422 CALL cpbrfs( 'U', 2, 0, 1, a, 1, af, 1, b, 2, x, 1, r1, r2, w,
423 $ r, info )
424 CALL chkxer( 'CPBRFS', infot, nout, lerr, ok )
425*
426* CPBCON
427*
428 srnamt = 'CPBCON'
429 infot = 1
430 CALL cpbcon( '/', 0, 0, a, 1, anrm, rcond, w, r, info )
431 CALL chkxer( 'CPBCON', infot, nout, lerr, ok )
432 infot = 2
433 CALL cpbcon( 'U', -1, 0, a, 1, anrm, rcond, w, r, info )
434 CALL chkxer( 'CPBCON', infot, nout, lerr, ok )
435 infot = 3
436 CALL cpbcon( 'U', 1, -1, a, 1, anrm, rcond, w, r, info )
437 CALL chkxer( 'CPBCON', infot, nout, lerr, ok )
438 infot = 5
439 CALL cpbcon( 'U', 2, 1, a, 1, anrm, rcond, w, r, info )
440 CALL chkxer( 'CPBCON', infot, nout, lerr, ok )
441 infot = 6
442 CALL cpbcon( 'U', 1, 0, a, 1, -anrm, rcond, w, r, info )
443 CALL chkxer( 'CPBCON', infot, nout, lerr, ok )
444*
445* CPBEQU
446*
447 srnamt = 'CPBEQU'
448 infot = 1
449 CALL cpbequ( '/', 0, 0, a, 1, r1, rcond, anrm, info )
450 CALL chkxer( 'CPBEQU', infot, nout, lerr, ok )
451 infot = 2
452 CALL cpbequ( 'U', -1, 0, a, 1, r1, rcond, anrm, info )
453 CALL chkxer( 'CPBEQU', infot, nout, lerr, ok )
454 infot = 3
455 CALL cpbequ( 'U', 1, -1, a, 1, r1, rcond, anrm, info )
456 CALL chkxer( 'CPBEQU', infot, nout, lerr, ok )
457 infot = 5
458 CALL cpbequ( 'U', 2, 1, a, 1, r1, rcond, anrm, info )
459 CALL chkxer( 'CPBEQU', infot, nout, lerr, ok )
460 END IF
461*
462* Print a summary line.
463*
464 CALL alaesm( path, ok, nout )
465*
466 RETURN
467*
468* End of CERRPO
469*
cpbtf2
subroutine cpbtf2(uplo, n, kd, ab, ldab, info)
CPBTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite band matrix (un...
Definition cpbtf2.f:142
cpotf2
subroutine cpotf2(uplo, n, a, lda, info)
CPOTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite matrix (unblock...
Definition cpotf2.f:109

◆ cerrps()

subroutine cerrps ( character*3 path,
integer nunit )

CERRPS

Purpose:
!>
!> CERRPS tests the error exits for the COMPLEX routines
!> for CPSTRF..
!>
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 cerrps.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 A( NMAX, NMAX )
76 REAL RWORK( 2*NMAX )
77 INTEGER PIV( NMAX )
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, cpstf2, cpstrf
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 real
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.0 / real( i+j )
104*
105 100 CONTINUE
106 piv( j ) = j
107 rwork( j ) = 0.
108 rwork( nmax+j ) = 0.
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* CPSTRF
118*
119 srnamt = 'CPSTRF'
120 infot = 1
121 CALL cpstrf( '/', 0, a, 1, piv, rank, -1.0, rwork, info )
122 CALL chkxer( 'CPSTRF', infot, nout, lerr, ok )
123 infot = 2
124 CALL cpstrf( 'U', -1, a, 1, piv, rank, -1.0, rwork, info )
125 CALL chkxer( 'CPSTRF', infot, nout, lerr, ok )
126 infot = 4
127 CALL cpstrf( 'U', 2, a, 1, piv, rank, -1.0, rwork, info )
128 CALL chkxer( 'CPSTRF', infot, nout, lerr, ok )
129*
130* CPSTF2
131*
132 srnamt = 'CPSTF2'
133 infot = 1
134 CALL cpstf2( '/', 0, a, 1, piv, rank, -1.0, rwork, info )
135 CALL chkxer( 'CPSTF2', infot, nout, lerr, ok )
136 infot = 2
137 CALL cpstf2( 'U', -1, a, 1, piv, rank, -1.0, rwork, info )
138 CALL chkxer( 'CPSTF2', infot, nout, lerr, ok )
139 infot = 4
140 CALL cpstf2( 'U', 2, a, 1, piv, rank, -1.0, rwork, info )
141 CALL chkxer( 'CPSTF2', 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 CERRPS
151*
cpstf2
subroutine cpstf2(uplo, n, a, lda, piv, rank, tol, work, info)
CPSTF2 computes the Cholesky factorization with complete pivoting of complex Hermitian positive semid...
Definition cpstf2.f:142

◆ cerrql()

subroutine cerrql ( character*3 path,
integer nunit )

CERRQL

Purpose:
!>
!> CERRQL tests the error exits for the COMPLEX 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 cerrql.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 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
76 $ W( NMAX ), X( NMAX )
77* ..
78* .. External Subroutines ..
79 EXTERNAL alaesm, cgeql2, cgeqlf, cgeqls, chkxer, cung2l,
80 $ cungql, cunm2l, cunmql
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 cmplx, real
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 ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
104 af( i, j ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
105 10 CONTINUE
106 b( j ) = 0.
107 w( j ) = 0.
108 x( j ) = 0.
109 20 CONTINUE
110 ok = .true.
111*
112* Error exits for QL factorization
113*
114* CGEQLF
115*
116 srnamt = 'CGEQLF'
117 infot = 1
118 CALL cgeqlf( -1, 0, a, 1, b, w, 1, info )
119 CALL chkxer( 'CGEQLF', infot, nout, lerr, ok )
120 infot = 2
121 CALL cgeqlf( 0, -1, a, 1, b, w, 1, info )
122 CALL chkxer( 'CGEQLF', infot, nout, lerr, ok )
123 infot = 4
124 CALL cgeqlf( 2, 1, a, 1, b, w, 1, info )
125 CALL chkxer( 'CGEQLF', infot, nout, lerr, ok )
126 infot = 7
127 CALL cgeqlf( 1, 2, a, 1, b, w, 1, info )
128 CALL chkxer( 'CGEQLF', infot, nout, lerr, ok )
129*
130* CGEQL2
131*
132 srnamt = 'CGEQL2'
133 infot = 1
134 CALL cgeql2( -1, 0, a, 1, b, w, info )
135 CALL chkxer( 'CGEQL2', infot, nout, lerr, ok )
136 infot = 2
137 CALL cgeql2( 0, -1, a, 1, b, w, info )
138 CALL chkxer( 'CGEQL2', infot, nout, lerr, ok )
139 infot = 4
140 CALL cgeql2( 2, 1, a, 1, b, w, info )
141 CALL chkxer( 'CGEQL2', infot, nout, lerr, ok )
142*
143* CGEQLS
144*
145 srnamt = 'CGEQLS'
146 infot = 1
147 CALL cgeqls( -1, 0, 0, a, 1, x, b, 1, w, 1, info )
148 CALL chkxer( 'CGEQLS', infot, nout, lerr, ok )
149 infot = 2
150 CALL cgeqls( 0, -1, 0, a, 1, x, b, 1, w, 1, info )
151 CALL chkxer( 'CGEQLS', infot, nout, lerr, ok )
152 infot = 2
153 CALL cgeqls( 1, 2, 0, a, 1, x, b, 1, w, 1, info )
154 CALL chkxer( 'CGEQLS', infot, nout, lerr, ok )
155 infot = 3
156 CALL cgeqls( 0, 0, -1, a, 1, x, b, 1, w, 1, info )
157 CALL chkxer( 'CGEQLS', infot, nout, lerr, ok )
158 infot = 5
159 CALL cgeqls( 2, 1, 0, a, 1, x, b, 2, w, 1, info )
160 CALL chkxer( 'CGEQLS', infot, nout, lerr, ok )
161 infot = 8
162 CALL cgeqls( 2, 1, 0, a, 2, x, b, 1, w, 1, info )
163 CALL chkxer( 'CGEQLS', infot, nout, lerr, ok )
164 infot = 10
165 CALL cgeqls( 1, 1, 2, a, 1, x, b, 1, w, 1, info )
166 CALL chkxer( 'CGEQLS', infot, nout, lerr, ok )
167*
168* CUNGQL
169*
170 srnamt = 'CUNGQL'
171 infot = 1
172 CALL cungql( -1, 0, 0, a, 1, x, w, 1, info )
173 CALL chkxer( 'CUNGQL', infot, nout, lerr, ok )
174 infot = 2
175 CALL cungql( 0, -1, 0, a, 1, x, w, 1, info )
176 CALL chkxer( 'CUNGQL', infot, nout, lerr, ok )
177 infot = 2
178 CALL cungql( 1, 2, 0, a, 1, x, w, 2, info )
179 CALL chkxer( 'CUNGQL', infot, nout, lerr, ok )
180 infot = 3
181 CALL cungql( 0, 0, -1, a, 1, x, w, 1, info )
182 CALL chkxer( 'CUNGQL', infot, nout, lerr, ok )
183 infot = 3
184 CALL cungql( 1, 1, 2, a, 1, x, w, 1, info )
185 CALL chkxer( 'CUNGQL', infot, nout, lerr, ok )
186 infot = 5
187 CALL cungql( 2, 1, 0, a, 1, x, w, 1, info )
188 CALL chkxer( 'CUNGQL', infot, nout, lerr, ok )
189 infot = 8
190 CALL cungql( 2, 2, 0, a, 2, x, w, 1, info )
191 CALL chkxer( 'CUNGQL', infot, nout, lerr, ok )
192*
193* CUNG2L
194*
195 srnamt = 'CUNG2L'
196 infot = 1
197 CALL cung2l( -1, 0, 0, a, 1, x, w, info )
198 CALL chkxer( 'CUNG2L', infot, nout, lerr, ok )
199 infot = 2
200 CALL cung2l( 0, -1, 0, a, 1, x, w, info )
201 CALL chkxer( 'CUNG2L', infot, nout, lerr, ok )
202 infot = 2
203 CALL cung2l( 1, 2, 0, a, 1, x, w, info )
204 CALL chkxer( 'CUNG2L', infot, nout, lerr, ok )
205 infot = 3
206 CALL cung2l( 0, 0, -1, a, 1, x, w, info )
207 CALL chkxer( 'CUNG2L', infot, nout, lerr, ok )
208 infot = 3
209 CALL cung2l( 2, 1, 2, a, 2, x, w, info )
210 CALL chkxer( 'CUNG2L', infot, nout, lerr, ok )
211 infot = 5
212 CALL cung2l( 2, 1, 0, a, 1, x, w, info )
213 CALL chkxer( 'CUNG2L', infot, nout, lerr, ok )
214*
215* CUNMQL
216*
217 srnamt = 'CUNMQL'
218 infot = 1
219 CALL cunmql( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
220 CALL chkxer( 'CUNMQL', infot, nout, lerr, ok )
221 infot = 2
222 CALL cunmql( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
223 CALL chkxer( 'CUNMQL', infot, nout, lerr, ok )
224 infot = 3
225 CALL cunmql( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, 1, info )
226 CALL chkxer( 'CUNMQL', infot, nout, lerr, ok )
227 infot = 4
228 CALL cunmql( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, 1, info )
229 CALL chkxer( 'CUNMQL', infot, nout, lerr, ok )
230 infot = 5
231 CALL cunmql( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, 1, info )
232 CALL chkxer( 'CUNMQL', infot, nout, lerr, ok )
233 infot = 5
234 CALL cunmql( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, 1, info )
235 CALL chkxer( 'CUNMQL', infot, nout, lerr, ok )
236 infot = 5
237 CALL cunmql( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, 1, info )
238 CALL chkxer( 'CUNMQL', infot, nout, lerr, ok )
239 infot = 7
240 CALL cunmql( 'L', 'N', 2, 1, 0, a, 1, x, af, 2, w, 1, info )
241 CALL chkxer( 'CUNMQL', infot, nout, lerr, ok )
242 infot = 7
243 CALL cunmql( 'R', 'N', 1, 2, 0, a, 1, x, af, 1, w, 1, info )
244 CALL chkxer( 'CUNMQL', infot, nout, lerr, ok )
245 infot = 10
246 CALL cunmql( 'L', 'N', 2, 1, 0, a, 2, x, af, 1, w, 1, info )
247 CALL chkxer( 'CUNMQL', infot, nout, lerr, ok )
248 infot = 12
249 CALL cunmql( 'L', 'N', 1, 2, 0, a, 1, x, af, 1, w, 1, info )
250 CALL chkxer( 'CUNMQL', infot, nout, lerr, ok )
251 infot = 12
252 CALL cunmql( 'R', 'N', 2, 1, 0, a, 1, x, af, 2, w, 1, info )
253 CALL chkxer( 'CUNMQL', infot, nout, lerr, ok )
254*
255* CUNM2L
256*
257 srnamt = 'CUNM2L'
258 infot = 1
259 CALL cunm2l( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, info )
260 CALL chkxer( 'CUNM2L', infot, nout, lerr, ok )
261 infot = 2
262 CALL cunm2l( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, info )
263 CALL chkxer( 'CUNM2L', infot, nout, lerr, ok )
264 infot = 3
265 CALL cunm2l( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, info )
266 CALL chkxer( 'CUNM2L', infot, nout, lerr, ok )
267 infot = 4
268 CALL cunm2l( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, info )
269 CALL chkxer( 'CUNM2L', infot, nout, lerr, ok )
270 infot = 5
271 CALL cunm2l( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, info )
272 CALL chkxer( 'CUNM2L', infot, nout, lerr, ok )
273 infot = 5
274 CALL cunm2l( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, info )
275 CALL chkxer( 'CUNM2L', infot, nout, lerr, ok )
276 infot = 5
277 CALL cunm2l( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, info )
278 CALL chkxer( 'CUNM2L', infot, nout, lerr, ok )
279 infot = 7
280 CALL cunm2l( 'L', 'N', 2, 1, 0, a, 1, x, af, 2, w, info )
281 CALL chkxer( 'CUNM2L', infot, nout, lerr, ok )
282 infot = 7
283 CALL cunm2l( 'R', 'N', 1, 2, 0, a, 1, x, af, 1, w, info )
284 CALL chkxer( 'CUNM2L', infot, nout, lerr, ok )
285 infot = 10
286 CALL cunm2l( 'L', 'N', 2, 1, 0, a, 2, x, af, 1, w, info )
287 CALL chkxer( 'CUNM2L', infot, nout, lerr, ok )
288*
289* Print a summary line.
290*
291 CALL alaesm( path, ok, nout )
292*
293 RETURN
294*
295* End of CERRQL
296*
cgeql2
subroutine cgeql2(m, n, a, lda, tau, work, info)
CGEQL2 computes the QL factorization of a general rectangular matrix using an unblocked algorithm.
Definition cgeql2.f:123
cunm2l
subroutine cunm2l(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
CUNM2L multiplies a general matrix by the unitary matrix from a QL factorization determined by cgeqlf...
Definition cunm2l.f:159
cunmql
subroutine cunmql(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
CUNMQL
Definition cunmql.f:168
cungql
subroutine cungql(m, n, k, a, lda, tau, work, lwork, info)
CUNGQL
Definition cungql.f:128
cung2l
subroutine cung2l(m, n, k, a, lda, tau, work, info)
CUNG2L generates all or part of the unitary matrix Q from a QL factorization determined by cgeqlf (un...
Definition cung2l.f:114

◆ cerrqp()

subroutine cerrqp ( character*3 path,
integer nunit )

CERRQP

Purpose:
!>
!> CERRQP tests the error exits for CGEQP3.
!>
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 cerrqp.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 REAL RW( 2*NMAX )
77 COMPLEX 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, cgeqp3, chkxer
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 cmplx
98* ..
99* .. Executable Statements ..
100*
101 nout = nunit
102 c2 = path( 2: 3 )
103 lw = nmax + 1
104 a( 1, 1 ) = cmplx( 1.0e+0, -1.0e+0 )
105 a( 1, 2 ) = cmplx( 2.0e+0, -2.0e+0 )
106 a( 2, 2 ) = cmplx( 3.0e+0, -3.0e+0 )
107 a( 2, 1 ) = cmplx( 4.0e+0, -4.0e+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* CGEQP3
116*
117 srnamt = 'CGEQP3'
118 infot = 1
119 CALL cgeqp3( -1, 0, a, 1, ip, tau, w, lw, rw, info )
120 CALL chkxer( 'CGEQP3', infot, nout, lerr, ok )
121 infot = 2
122 CALL cgeqp3( 1, -1, a, 1, ip, tau, w, lw, rw, info )
123 CALL chkxer( 'CGEQP3', infot, nout, lerr, ok )
124 infot = 4
125 CALL cgeqp3( 2, 3, a, 1, ip, tau, w, lw, rw, info )
126 CALL chkxer( 'CGEQP3', infot, nout, lerr, ok )
127 infot = 8
128 CALL cgeqp3( 2, 2, a, 2, ip, tau, w, lw-10, rw, info )
129 CALL chkxer( 'CGEQP3', 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 CERRQP
139*

◆ cerrqr()

subroutine cerrqr ( character*3 path,
integer nunit )

CERRQR

Purpose:
!>
!> CERRQR tests the error exits for the COMPLEX 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 cerrqr.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 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
76 $ W( NMAX ), X( NMAX )
77* ..
78* .. External Subroutines ..
79 EXTERNAL alaesm, cgeqr2, cgeqr2p, cgeqrf, cgeqrfp,
80 $ cgeqrs, chkxer, cung2r, cungqr, cunm2r,
81 $ cunmqr
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 cmplx, real
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 ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
105 af( i, j ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
106 10 CONTINUE
107 b( j ) = 0.
108 w( j ) = 0.
109 x( j ) = 0.
110 20 CONTINUE
111 ok = .true.
112*
113* Error exits for QR factorization
114*
115* CGEQRF
116*
117 srnamt = 'CGEQRF'
118 infot = 1
119 CALL cgeqrf( -1, 0, a, 1, b, w, 1, info )
120 CALL chkxer( 'CGEQRF', infot, nout, lerr, ok )
121 infot = 2
122 CALL cgeqrf( 0, -1, a, 1, b, w, 1, info )
123 CALL chkxer( 'CGEQRF', infot, nout, lerr, ok )
124 infot = 4
125 CALL cgeqrf( 2, 1, a, 1, b, w, 1, info )
126 CALL chkxer( 'CGEQRF', infot, nout, lerr, ok )
127 infot = 7
128 CALL cgeqrf( 1, 2, a, 1, b, w, 1, info )
129 CALL chkxer( 'CGEQRF', infot, nout, lerr, ok )
130*
131* CGEQRFP
132*
133 srnamt = 'CGEQRFP'
134 infot = 1
135 CALL cgeqrfp( -1, 0, a, 1, b, w, 1, info )
136 CALL chkxer( 'CGEQRFP', infot, nout, lerr, ok )
137 infot = 2
138 CALL cgeqrfp( 0, -1, a, 1, b, w, 1, info )
139 CALL chkxer( 'CGEQRFP', infot, nout, lerr, ok )
140 infot = 4
141 CALL cgeqrfp( 2, 1, a, 1, b, w, 1, info )
142 CALL chkxer( 'CGEQRFP', infot, nout, lerr, ok )
143 infot = 7
144 CALL cgeqrfp( 1, 2, a, 1, b, w, 1, info )
145 CALL chkxer( 'CGEQRFP', infot, nout, lerr, ok )
146*
147* CGEQR2
148*
149 srnamt = 'CGEQR2'
150 infot = 1
151 CALL cgeqr2( -1, 0, a, 1, b, w, info )
152 CALL chkxer( 'CGEQR2', infot, nout, lerr, ok )
153 infot = 2
154 CALL cgeqr2( 0, -1, a, 1, b, w, info )
155 CALL chkxer( 'CGEQR2', infot, nout, lerr, ok )
156 infot = 4
157 CALL cgeqr2( 2, 1, a, 1, b, w, info )
158 CALL chkxer( 'CGEQR2', infot, nout, lerr, ok )
159*
160* CGEQR2P
161*
162 srnamt = 'CGEQR2P'
163 infot = 1
164 CALL cgeqr2p( -1, 0, a, 1, b, w, info )
165 CALL chkxer( 'CGEQR2P', infot, nout, lerr, ok )
166 infot = 2
167 CALL cgeqr2p( 0, -1, a, 1, b, w, info )
168 CALL chkxer( 'CGEQR2P', infot, nout, lerr, ok )
169 infot = 4
170 CALL cgeqr2p( 2, 1, a, 1, b, w, info )
171 CALL chkxer( 'CGEQR2P', infot, nout, lerr, ok )
172*
173* CGEQRS
174*
175 srnamt = 'CGEQRS'
176 infot = 1
177 CALL cgeqrs( -1, 0, 0, a, 1, x, b, 1, w, 1, info )
178 CALL chkxer( 'CGEQRS', infot, nout, lerr, ok )
179 infot = 2
180 CALL cgeqrs( 0, -1, 0, a, 1, x, b, 1, w, 1, info )
181 CALL chkxer( 'CGEQRS', infot, nout, lerr, ok )
182 infot = 2
183 CALL cgeqrs( 1, 2, 0, a, 2, x, b, 2, w, 1, info )
184 CALL chkxer( 'CGEQRS', infot, nout, lerr, ok )
185 infot = 3
186 CALL cgeqrs( 0, 0, -1, a, 1, x, b, 1, w, 1, info )
187 CALL chkxer( 'CGEQRS', infot, nout, lerr, ok )
188 infot = 5
189 CALL cgeqrs( 2, 1, 0, a, 1, x, b, 2, w, 1, info )
190 CALL chkxer( 'CGEQRS', infot, nout, lerr, ok )
191 infot = 8
192 CALL cgeqrs( 2, 1, 0, a, 2, x, b, 1, w, 1, info )
193 CALL chkxer( 'CGEQRS', infot, nout, lerr, ok )
194 infot = 10
195 CALL cgeqrs( 1, 1, 2, a, 1, x, b, 1, w, 1, info )
196 CALL chkxer( 'CGEQRS', infot, nout, lerr, ok )
197*
198* CUNGQR
199*
200 srnamt = 'CUNGQR'
201 infot = 1
202 CALL cungqr( -1, 0, 0, a, 1, x, w, 1, info )
203 CALL chkxer( 'CUNGQR', infot, nout, lerr, ok )
204 infot = 2
205 CALL cungqr( 0, -1, 0, a, 1, x, w, 1, info )
206 CALL chkxer( 'CUNGQR', infot, nout, lerr, ok )
207 infot = 2
208 CALL cungqr( 1, 2, 0, a, 1, x, w, 2, info )
209 CALL chkxer( 'CUNGQR', infot, nout, lerr, ok )
210 infot = 3
211 CALL cungqr( 0, 0, -1, a, 1, x, w, 1, info )
212 CALL chkxer( 'CUNGQR', infot, nout, lerr, ok )
213 infot = 3
214 CALL cungqr( 1, 1, 2, a, 1, x, w, 1, info )
215 CALL chkxer( 'CUNGQR', infot, nout, lerr, ok )
216 infot = 5
217 CALL cungqr( 2, 2, 0, a, 1, x, w, 2, info )
218 CALL chkxer( 'CUNGQR', infot, nout, lerr, ok )
219 infot = 8
220 CALL cungqr( 2, 2, 0, a, 2, x, w, 1, info )
221 CALL chkxer( 'CUNGQR', infot, nout, lerr, ok )
222*
223* CUNG2R
224*
225 srnamt = 'CUNG2R'
226 infot = 1
227 CALL cung2r( -1, 0, 0, a, 1, x, w, info )
228 CALL chkxer( 'CUNG2R', infot, nout, lerr, ok )
229 infot = 2
230 CALL cung2r( 0, -1, 0, a, 1, x, w, info )
231 CALL chkxer( 'CUNG2R', infot, nout, lerr, ok )
232 infot = 2
233 CALL cung2r( 1, 2, 0, a, 1, x, w, info )
234 CALL chkxer( 'CUNG2R', infot, nout, lerr, ok )
235 infot = 3
236 CALL cung2r( 0, 0, -1, a, 1, x, w, info )
237 CALL chkxer( 'CUNG2R', infot, nout, lerr, ok )
238 infot = 3
239 CALL cung2r( 2, 1, 2, a, 2, x, w, info )
240 CALL chkxer( 'CUNG2R', infot, nout, lerr, ok )
241 infot = 5
242 CALL cung2r( 2, 1, 0, a, 1, x, w, info )
243 CALL chkxer( 'CUNG2R', infot, nout, lerr, ok )
244*
245* CUNMQR
246*
247 srnamt = 'CUNMQR'
248 infot = 1
249 CALL cunmqr( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
250 CALL chkxer( 'CUNMQR', infot, nout, lerr, ok )
251 infot = 2
252 CALL cunmqr( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
253 CALL chkxer( 'CUNMQR', infot, nout, lerr, ok )
254 infot = 3
255 CALL cunmqr( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, 1, info )
256 CALL chkxer( 'CUNMQR', infot, nout, lerr, ok )
257 infot = 4
258 CALL cunmqr( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, 1, info )
259 CALL chkxer( 'CUNMQR', infot, nout, lerr, ok )
260 infot = 5
261 CALL cunmqr( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, 1, info )
262 CALL chkxer( 'CUNMQR', infot, nout, lerr, ok )
263 infot = 5
264 CALL cunmqr( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, 1, info )
265 CALL chkxer( 'CUNMQR', infot, nout, lerr, ok )
266 infot = 5
267 CALL cunmqr( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, 1, info )
268 CALL chkxer( 'CUNMQR', infot, nout, lerr, ok )
269 infot = 7
270 CALL cunmqr( 'L', 'N', 2, 1, 0, a, 1, x, af, 2, w, 1, info )
271 CALL chkxer( 'CUNMQR', infot, nout, lerr, ok )
272 infot = 7
273 CALL cunmqr( 'R', 'N', 1, 2, 0, a, 1, x, af, 1, w, 1, info )
274 CALL chkxer( 'CUNMQR', infot, nout, lerr, ok )
275 infot = 10
276 CALL cunmqr( 'L', 'N', 2, 1, 0, a, 2, x, af, 1, w, 1, info )
277 CALL chkxer( 'CUNMQR', infot, nout, lerr, ok )
278 infot = 12
279 CALL cunmqr( 'L', 'N', 1, 2, 0, a, 1, x, af, 1, w, 1, info )
280 CALL chkxer( 'CUNMQR', infot, nout, lerr, ok )
281 infot = 12
282 CALL cunmqr( 'R', 'N', 2, 1, 0, a, 1, x, af, 2, w, 1, info )
283 CALL chkxer( 'CUNMQR', infot, nout, lerr, ok )
284*
285* CUNM2R
286*
287 srnamt = 'CUNM2R'
288 infot = 1
289 CALL cunm2r( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, info )
290 CALL chkxer( 'CUNM2R', infot, nout, lerr, ok )
291 infot = 2
292 CALL cunm2r( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, info )
293 CALL chkxer( 'CUNM2R', infot, nout, lerr, ok )
294 infot = 3
295 CALL cunm2r( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, info )
296 CALL chkxer( 'CUNM2R', infot, nout, lerr, ok )
297 infot = 4
298 CALL cunm2r( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, info )
299 CALL chkxer( 'CUNM2R', infot, nout, lerr, ok )
300 infot = 5
301 CALL cunm2r( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, info )
302 CALL chkxer( 'CUNM2R', infot, nout, lerr, ok )
303 infot = 5
304 CALL cunm2r( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, info )
305 CALL chkxer( 'CUNM2R', infot, nout, lerr, ok )
306 infot = 5
307 CALL cunm2r( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, info )
308 CALL chkxer( 'CUNM2R', infot, nout, lerr, ok )
309 infot = 7
310 CALL cunm2r( 'L', 'N', 2, 1, 0, a, 1, x, af, 2, w, info )
311 CALL chkxer( 'CUNM2R', infot, nout, lerr, ok )
312 infot = 7
313 CALL cunm2r( 'R', 'N', 1, 2, 0, a, 1, x, af, 1, w, info )
314 CALL chkxer( 'CUNM2R', infot, nout, lerr, ok )
315 infot = 10
316 CALL cunm2r( 'L', 'N', 2, 1, 0, a, 2, x, af, 1, w, info )
317 CALL chkxer( 'CUNM2R', infot, nout, lerr, ok )
318*
319* Print a summary line.
320*
321 CALL alaesm( path, ok, nout )
322*
323 RETURN
324*
325* End of CERRQR
326*
cgeqrfp
subroutine cgeqrfp(m, n, a, lda, tau, work, lwork, info)
CGEQRFP
Definition cgeqrfp.f:149
cgeqr2p
subroutine cgeqr2p(m, n, a, lda, tau, work, info)
CGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagonal elem...
Definition cgeqr2p.f:134
cung2r
subroutine cung2r(m, n, k, a, lda, tau, work, info)
CUNG2R
Definition cung2r.f:114
cunmqr
subroutine cunmqr(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
CUNMQR
Definition cunmqr.f:168
cunm2r
subroutine cunm2r(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
CUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf...
Definition cunm2r.f:159
cungqr
subroutine cungqr(m, n, k, a, lda, tau, work, lwork, info)
CUNGQR
Definition cungqr.f:128

◆ cerrqrt()

subroutine cerrqrt ( character*3 path,
integer nunit )

CERRQRT

Purpose:
!>
!> CERRQRT tests the error exits for the COMPLEX 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 cerrqrt.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 A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
77 $ C( NMAX, NMAX )
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, cgeqrt2, cgeqrt3, cgeqrt,
81 $ cgemqrt
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 float, cmplx
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.0 / cmplx( float(i+j), 0.0 )
105 c( i, j ) = 1.0 / cmplx( float(i+j), 0.0 )
106 t( i, j ) = 1.0 / cmplx( float(i+j), 0.0 )
107 END DO
108 w( j ) = 0.0
109 END DO
110 ok = .true.
111*
112* Error exits for QRT factorization
113*
114* CGEQRT
115*
116 srnamt = 'CGEQRT'
117 infot = 1
118 CALL cgeqrt( -1, 0, 1, a, 1, t, 1, w, info )
119 CALL chkxer( 'CGEQRT', infot, nout, lerr, ok )
120 infot = 2
121 CALL cgeqrt( 0, -1, 1, a, 1, t, 1, w, info )
122 CALL chkxer( 'CGEQRT', infot, nout, lerr, ok )
123 infot = 3
124 CALL cgeqrt( 0, 0, 0, a, 1, t, 1, w, info )
125 CALL chkxer( 'CGEQRT', infot, nout, lerr, ok )
126 infot = 5
127 CALL cgeqrt( 2, 1, 1, a, 1, t, 1, w, info )
128 CALL chkxer( 'CGEQRT', infot, nout, lerr, ok )
129 infot = 7
130 CALL cgeqrt( 2, 2, 2, a, 2, t, 1, w, info )
131 CALL chkxer( 'CGEQRT', infot, nout, lerr, ok )
132*
133* CGEQRT2
134*
135 srnamt = 'CGEQRT2'
136 infot = 1
137 CALL cgeqrt2( -1, 0, a, 1, t, 1, info )
138 CALL chkxer( 'CGEQRT2', infot, nout, lerr, ok )
139 infot = 2
140 CALL cgeqrt2( 0, -1, a, 1, t, 1, info )
141 CALL chkxer( 'CGEQRT2', infot, nout, lerr, ok )
142 infot = 4
143 CALL cgeqrt2( 2, 1, a, 1, t, 1, info )
144 CALL chkxer( 'CGEQRT2', infot, nout, lerr, ok )
145 infot = 6
146 CALL cgeqrt2( 2, 2, a, 2, t, 1, info )
147 CALL chkxer( 'CGEQRT2', infot, nout, lerr, ok )
148*
149* CGEQRT3
150*
151 srnamt = 'CGEQRT3'
152 infot = 1
153 CALL cgeqrt3( -1, 0, a, 1, t, 1, info )
154 CALL chkxer( 'CGEQRT3', infot, nout, lerr, ok )
155 infot = 2
156 CALL cgeqrt3( 0, -1, a, 1, t, 1, info )
157 CALL chkxer( 'CGEQRT3', infot, nout, lerr, ok )
158 infot = 4
159 CALL cgeqrt3( 2, 1, a, 1, t, 1, info )
160 CALL chkxer( 'CGEQRT3', infot, nout, lerr, ok )
161 infot = 6
162 CALL cgeqrt3( 2, 2, a, 2, t, 1, info )
163 CALL chkxer( 'CGEQRT3', infot, nout, lerr, ok )
164*
165* CGEMQRT
166*
167 srnamt = 'CGEMQRT'
168 infot = 1
169 CALL cgemqrt( '/', 'N', 0, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
170 CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
171 infot = 2
172 CALL cgemqrt( 'L', '/', 0, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
173 CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
174 infot = 3
175 CALL cgemqrt( 'L', 'N', -1, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
176 CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
177 infot = 4
178 CALL cgemqrt( 'L', 'N', 0, -1, 0, 1, a, 1, t, 1, c, 1, w, info )
179 CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
180 infot = 5
181 CALL cgemqrt( 'L', 'N', 0, 0, -1, 1, a, 1, t, 1, c, 1, w, info )
182 CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
183 infot = 5
184 CALL cgemqrt( 'R', 'N', 0, 0, -1, 1, a, 1, t, 1, c, 1, w, info )
185 CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
186 infot = 6
187 CALL cgemqrt( 'L', 'N', 0, 0, 0, 0, a, 1, t, 1, c, 1, w, info )
188 CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
189 infot = 8
190 CALL cgemqrt( 'R', 'N', 1, 2, 1, 1, a, 1, t, 1, c, 1, w, info )
191 CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
192 infot = 8
193 CALL cgemqrt( 'L', 'N', 2, 1, 1, 1, a, 1, t, 1, c, 1, w, info )
194 CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
195 infot = 10
196 CALL cgemqrt( 'R', 'N', 1, 1, 1, 1, a, 1, t, 0, c, 1, w, info )
197 CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
198 infot = 12
199 CALL cgemqrt( 'L', 'N', 1, 1, 1, 1, a, 1, t, 1, c, 0, w, info )
200 CALL chkxer( 'CGEMQRT', infot, nout, lerr, ok )
201*
202* Print a summary line.
203*
204 CALL alaesm( path, ok, nout )
205*
206 RETURN
207*
208* End of CERRQRT
209*
cgeqrt2
subroutine cgeqrt2(m, n, a, lda, t, ldt, info)
CGEQRT2 computes a QR factorization of a general real or complex matrix using the compact WY represen...
Definition cgeqrt2.f:127
cgeqrt
subroutine cgeqrt(m, n, nb, a, lda, t, ldt, work, info)
CGEQRT
Definition cgeqrt.f:141
cgeqrt3
recursive subroutine cgeqrt3(m, n, a, lda, t, ldt, info)
CGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact...
Definition cgeqrt3.f:132
cgemqrt
subroutine cgemqrt(side, trans, m, n, k, nb, v, ldv, t, ldt, c, ldc, work, info)
CGEMQRT
Definition cgemqrt.f:168

◆ cerrqrtp()

subroutine cerrqrtp ( character*3 path,
integer nunit )

CERRQRTP

Purpose:
!>
!> CERRQRTP tests the error exits for the REAL 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 cerrqrtp.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 A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
77 $ B( NMAX, NMAX ), C( NMAX, NMAX )
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, ctpqrt2, ctpqrt,
81 $ ctpmqrt
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 float, cmplx
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.0 / cmplx(float( i+j ),0.0)
105 c( i, j ) = 1.0 / cmplx(float( i+j ),0.0)
106 t( i, j ) = 1.0 / cmplx(float( i+j ),0.0)
107 END DO
108 w( j ) = cmplx(0.0,0.0)
109 END DO
110 ok = .true.
111*
112* Error exits for TPQRT factorization
113*
114* CTPQRT
115*
116 srnamt = 'CTPQRT'
117 infot = 1
118 CALL ctpqrt( -1, 1, 0, 1, a, 1, b, 1, t, 1, w, info )
119 CALL chkxer( 'CTPQRT', infot, nout, lerr, ok )
120 infot = 2
121 CALL ctpqrt( 1, -1, 0, 1, a, 1, b, 1, t, 1, w, info )
122 CALL chkxer( 'CTPQRT', infot, nout, lerr, ok )
123 infot = 3
124 CALL ctpqrt( 0, 1, -1, 1, a, 1, b, 1, t, 1, w, info )
125 CALL chkxer( 'CTPQRT', infot, nout, lerr, ok )
126 infot = 3
127 CALL ctpqrt( 0, 1, 1, 1, a, 1, b, 1, t, 1, w, info )
128 CALL chkxer( 'CTPQRT', infot, nout, lerr, ok )
129 infot = 4
130 CALL ctpqrt( 0, 1, 0, 0, a, 1, b, 1, t, 1, w, info )
131 CALL chkxer( 'CTPQRT', infot, nout, lerr, ok )
132 infot = 4
133 CALL ctpqrt( 0, 1, 0, 2, a, 1, b, 1, t, 1, w, info )
134 CALL chkxer( 'CTPQRT', infot, nout, lerr, ok )
135 infot = 6
136 CALL ctpqrt( 1, 2, 0, 2, a, 1, b, 1, t, 1, w, info )
137 CALL chkxer( 'CTPQRT', infot, nout, lerr, ok )
138 infot = 8
139 CALL ctpqrt( 2, 1, 0, 1, a, 1, b, 1, t, 1, w, info )
140 CALL chkxer( 'CTPQRT', infot, nout, lerr, ok )
141 infot = 10
142 CALL ctpqrt( 2, 2, 1, 2, a, 2, b, 2, t, 1, w, info )
143 CALL chkxer( 'CTPQRT', infot, nout, lerr, ok )
144*
145* CTPQRT2
146*
147 srnamt = 'CTPQRT2'
148 infot = 1
149 CALL ctpqrt2( -1, 0, 0, a, 1, b, 1, t, 1, info )
150 CALL chkxer( 'CTPQRT2', infot, nout, lerr, ok )
151 infot = 2
152 CALL ctpqrt2( 0, -1, 0, a, 1, b, 1, t, 1, info )
153 CALL chkxer( 'CTPQRT2', infot, nout, lerr, ok )
154 infot = 3
155 CALL ctpqrt2( 0, 0, -1, a, 1, b, 1, t, 1, info )
156 CALL chkxer( 'CTPQRT2', infot, nout, lerr, ok )
157 infot = 5
158 CALL ctpqrt2( 2, 2, 0, a, 1, b, 2, t, 2, info )
159 CALL chkxer( 'CTPQRT2', infot, nout, lerr, ok )
160 infot = 7
161 CALL ctpqrt2( 2, 2, 0, a, 2, b, 1, t, 2, info )
162 CALL chkxer( 'CTPQRT2', infot, nout, lerr, ok )
163 infot = 9
164 CALL ctpqrt2( 2, 2, 0, a, 2, b, 2, t, 1, info )
165 CALL chkxer( 'CTPQRT2', infot, nout, lerr, ok )
166*
167* CTPMQRT
168*
169 srnamt = 'CTPMQRT'
170 infot = 1
171 CALL ctpmqrt( '/', 'N', 0, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
172 $ w, info )
173 CALL chkxer( 'CTPMQRT', infot, nout, lerr, ok )
174 infot = 2
175 CALL ctpmqrt( 'L', '/', 0, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
176 $ w, info )
177 CALL chkxer( 'CTPMQRT', infot, nout, lerr, ok )
178 infot = 3
179 CALL ctpmqrt( 'L', 'N', -1, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
180 $ w, info )
181 CALL chkxer( 'CTPMQRT', infot, nout, lerr, ok )
182 infot = 4
183 CALL ctpmqrt( 'L', 'N', 0, -1, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
184 $ w, info )
185 CALL chkxer( 'CTPMQRT', infot, nout, lerr, ok )
186 infot = 5
187 CALL ctpmqrt( 'L', 'N', 0, 0, -1, 0, 1, a, 1, t, 1, b, 1, c, 1,
188 $ w, info )
189 infot = 6
190 CALL ctpmqrt( 'L', 'N', 0, 0, 0, -1, 1, a, 1, t, 1, b, 1, c, 1,
191 $ w, info )
192 CALL chkxer( 'CTPMQRT', infot, nout, lerr, ok )
193 infot = 7
194 CALL ctpmqrt( 'L', 'N', 0, 0, 0, 0, 0, a, 1, t, 1, b, 1, c, 1,
195 $ w, info )
196 CALL chkxer( 'CTPMQRT', infot, nout, lerr, ok )
197 infot = 9
198 CALL ctpmqrt( 'R', 'N', 1, 2, 1, 1, 1, a, 1, t, 1, b, 1, c, 1,
199 $ w, info )
200 CALL chkxer( 'CTPMQRT', infot, nout, lerr, ok )
201 infot = 9
202 CALL ctpmqrt( 'L', 'N', 2, 1, 1, 1, 1, a, 1, t, 1, b, 1, c, 1,
203 $ w, info )
204 CALL chkxer( 'CTPMQRT', infot, nout, lerr, ok )
205 infot = 11
206 CALL ctpmqrt( 'R', 'N', 1, 1, 1, 1, 1, a, 1, t, 0, b, 1, c, 1,
207 $ w, info )
208 CALL chkxer( 'CTPMQRT', infot, nout, lerr, ok )
209 infot = 13
210 CALL ctpmqrt( 'L', 'N', 1, 1, 1, 1, 1, a, 1, t, 1, b, 0, c, 1,
211 $ w, info )
212 CALL chkxer( 'CTPMQRT', infot, nout, lerr, ok )
213 infot = 15
214 CALL ctpmqrt( 'L', 'N', 1, 1, 1, 1, 1, a, 1, t, 1, b, 1, c, 0,
215 $ w, info )
216 CALL chkxer( 'CTPMQRT', infot, nout, lerr, ok )
217*
218* Print a summary line.
219*
220 CALL alaesm( path, ok, nout )
221*
222 RETURN
223*
224* End of CERRQRTP
225*
ctpmqrt
subroutine ctpmqrt(side, trans, m, n, k, l, nb, v, ldv, t, ldt, a, lda, b, ldb, work, info)
CTPMQRT
Definition ctpmqrt.f:216
ctpqrt2
subroutine ctpqrt2(m, n, l, a, lda, b, ldb, t, ldt, info)
CTPQRT2 computes a QR factorization of a real or complex "triangular-pentagonal" matrix,...
Definition ctpqrt2.f:173
ctpqrt
subroutine ctpqrt(m, n, l, nb, a, lda, b, ldb, t, ldt, work, info)
CTPQRT
Definition ctpqrt.f:189

◆ cerrrfp()

subroutine cerrrfp ( integer nunit)

CERRRFP

Purpose:
!>
!> CERRRFP tests the error exits for the COMPLEX driver routines
!> for solving linear systems of equations.
!>
!> CDRVRFP tests the COMPLEX LAPACK RFP routines:
!>     CTFSM, CTFTRI, CHFRK, CTFTTP, CTFTTR, CPFTRF, CPFTRS, CTPTTF,
!>     CTPTTR, CTRTTF, and CTRTTP
!>
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 cerrrfp.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 COMPLEX ALPHA, BETA
67* ..
68* .. Local Arrays ..
69 COMPLEX A( 1, 1), B( 1, 1)
70* ..
71* .. External Subroutines ..
72 EXTERNAL chkxer, ctfsm, ctftri, chfrk, ctfttp, ctfttr,
73 + cpftri, cpftrf, cpftrs, ctpttf, ctpttr, ctrttf,
74 + ctrttp
75* ..
76* .. Scalars in Common ..
77 LOGICAL LERR, OK
78 CHARACTER*32 SRNAMT
79 INTEGER INFOT, NOUT
80* ..
81* .. Intrinsic Functions ..
82 INTRINSIC cmplx
83* ..
84* .. Common blocks ..
85 COMMON / infoc / infot, nout, ok, lerr
86 COMMON / srnamc / srnamt
87* ..
88* .. Executable Statements ..
89*
90 nout = nunit
91 ok = .true.
92 a( 1, 1 ) = cmplx( 1.d0 , 1.d0 )
93 b( 1, 1 ) = cmplx( 1.d0 , 1.d0 )
94 alpha = cmplx( 1.d0 , 1.d0 )
95 beta = cmplx( 1.d0 , 1.d0 )
96*
97 srnamt = 'CPFTRF'
98 infot = 1
99 CALL cpftrf( '/', 'U', 0, a, info )
100 CALL chkxer( 'CPFTRF', infot, nout, lerr, ok )
101 infot = 2
102 CALL cpftrf( 'N', '/', 0, a, info )
103 CALL chkxer( 'CPFTRF', infot, nout, lerr, ok )
104 infot = 3
105 CALL cpftrf( 'N', 'U', -1, a, info )
106 CALL chkxer( 'CPFTRF', infot, nout, lerr, ok )
107*
108 srnamt = 'CPFTRS'
109 infot = 1
110 CALL cpftrs( '/', 'U', 0, 0, a, b, 1, info )
111 CALL chkxer( 'CPFTRS', infot, nout, lerr, ok )
112 infot = 2
113 CALL cpftrs( 'N', '/', 0, 0, a, b, 1, info )
114 CALL chkxer( 'CPFTRS', infot, nout, lerr, ok )
115 infot = 3
116 CALL cpftrs( 'N', 'U', -1, 0, a, b, 1, info )
117 CALL chkxer( 'CPFTRS', infot, nout, lerr, ok )
118 infot = 4
119 CALL cpftrs( 'N', 'U', 0, -1, a, b, 1, info )
120 CALL chkxer( 'CPFTRS', infot, nout, lerr, ok )
121 infot = 7
122 CALL cpftrs( 'N', 'U', 0, 0, a, b, 0, info )
123 CALL chkxer( 'CPFTRS', infot, nout, lerr, ok )
124*
125 srnamt = 'CPFTRI'
126 infot = 1
127 CALL cpftri( '/', 'U', 0, a, info )
128 CALL chkxer( 'CPFTRI', infot, nout, lerr, ok )
129 infot = 2
130 CALL cpftri( 'N', '/', 0, a, info )
131 CALL chkxer( 'CPFTRI', infot, nout, lerr, ok )
132 infot = 3
133 CALL cpftri( 'N', 'U', -1, a, info )
134 CALL chkxer( 'CPFTRI', infot, nout, lerr, ok )
135*
136 srnamt = 'CTFSM '
137 infot = 1
138 CALL ctfsm( '/', 'L', 'U', 'C', 'U', 0, 0, alpha, a, b, 1 )
139 CALL chkxer( 'CTFSM ', infot, nout, lerr, ok )
140 infot = 2
141 CALL ctfsm( 'N', '/', 'U', 'C', 'U', 0, 0, alpha, a, b, 1 )
142 CALL chkxer( 'CTFSM ', infot, nout, lerr, ok )
143 infot = 3
144 CALL ctfsm( 'N', 'L', '/', 'C', 'U', 0, 0, alpha, a, b, 1 )
145 CALL chkxer( 'CTFSM ', infot, nout, lerr, ok )
146 infot = 4
147 CALL ctfsm( 'N', 'L', 'U', '/', 'U', 0, 0, alpha, a, b, 1 )
148 CALL chkxer( 'CTFSM ', infot, nout, lerr, ok )
149 infot = 5
150 CALL ctfsm( 'N', 'L', 'U', 'C', '/', 0, 0, alpha, a, b, 1 )
151 CALL chkxer( 'CTFSM ', infot, nout, lerr, ok )
152 infot = 6
153 CALL ctfsm( 'N', 'L', 'U', 'C', 'U', -1, 0, alpha, a, b, 1 )
154 CALL chkxer( 'CTFSM ', infot, nout, lerr, ok )
155 infot = 7
156 CALL ctfsm( 'N', 'L', 'U', 'C', 'U', 0, -1, alpha, a, b, 1 )
157 CALL chkxer( 'CTFSM ', infot, nout, lerr, ok )
158 infot = 11
159 CALL ctfsm( 'N', 'L', 'U', 'C', 'U', 0, 0, alpha, a, b, 0 )
160 CALL chkxer( 'CTFSM ', infot, nout, lerr, ok )
161*
162 srnamt = 'CTFTRI'
163 infot = 1
164 CALL ctftri( '/', 'L', 'N', 0, a, info )
165 CALL chkxer( 'CTFTRI', infot, nout, lerr, ok )
166 infot = 2
167 CALL ctftri( 'N', '/', 'N', 0, a, info )
168 CALL chkxer( 'CTFTRI', infot, nout, lerr, ok )
169 infot = 3
170 CALL ctftri( 'N', 'L', '/', 0, a, info )
171 CALL chkxer( 'CTFTRI', infot, nout, lerr, ok )
172 infot = 4
173 CALL ctftri( 'N', 'L', 'N', -1, a, info )
174 CALL chkxer( 'CTFTRI', infot, nout, lerr, ok )
175*
176 srnamt = 'CTFTTR'
177 infot = 1
178 CALL ctfttr( '/', 'U', 0, a, b, 1, info )
179 CALL chkxer( 'CTFTTR', infot, nout, lerr, ok )
180 infot = 2
181 CALL ctfttr( 'N', '/', 0, a, b, 1, info )
182 CALL chkxer( 'CTFTTR', infot, nout, lerr, ok )
183 infot = 3
184 CALL ctfttr( 'N', 'U', -1, a, b, 1, info )
185 CALL chkxer( 'CTFTTR', infot, nout, lerr, ok )
186 infot = 6
187 CALL ctfttr( 'N', 'U', 0, a, b, 0, info )
188 CALL chkxer( 'CTFTTR', infot, nout, lerr, ok )
189*
190 srnamt = 'CTRTTF'
191 infot = 1
192 CALL ctrttf( '/', 'U', 0, a, 1, b, info )
193 CALL chkxer( 'CTRTTF', infot, nout, lerr, ok )
194 infot = 2
195 CALL ctrttf( 'N', '/', 0, a, 1, b, info )
196 CALL chkxer( 'CTRTTF', infot, nout, lerr, ok )
197 infot = 3
198 CALL ctrttf( 'N', 'U', -1, a, 1, b, info )
199 CALL chkxer( 'CTRTTF', infot, nout, lerr, ok )
200 infot = 5
201 CALL ctrttf( 'N', 'U', 0, a, 0, b, info )
202 CALL chkxer( 'CTRTTF', infot, nout, lerr, ok )
203*
204 srnamt = 'CTFTTP'
205 infot = 1
206 CALL ctfttp( '/', 'U', 0, a, b, info )
207 CALL chkxer( 'CTFTTP', infot, nout, lerr, ok )
208 infot = 2
209 CALL ctfttp( 'N', '/', 0, a, b, info )
210 CALL chkxer( 'CTFTTP', infot, nout, lerr, ok )
211 infot = 3
212 CALL ctfttp( 'N', 'U', -1, a, b, info )
213 CALL chkxer( 'CTFTTP', infot, nout, lerr, ok )
214*
215 srnamt = 'CTPTTF'
216 infot = 1
217 CALL ctpttf( '/', 'U', 0, a, b, info )
218 CALL chkxer( 'CTPTTF', infot, nout, lerr, ok )
219 infot = 2
220 CALL ctpttf( 'N', '/', 0, a, b, info )
221 CALL chkxer( 'CTPTTF', infot, nout, lerr, ok )
222 infot = 3
223 CALL ctpttf( 'N', 'U', -1, a, b, info )
224 CALL chkxer( 'CTPTTF', infot, nout, lerr, ok )
225*
226 srnamt = 'CTRTTP'
227 infot = 1
228 CALL ctrttp( '/', 0, a, 1, b, info )
229 CALL chkxer( 'CTRTTP', infot, nout, lerr, ok )
230 infot = 2
231 CALL ctrttp( 'U', -1, a, 1, b, info )
232 CALL chkxer( 'CTRTTP', infot, nout, lerr, ok )
233 infot = 4
234 CALL ctrttp( 'U', 0, a, 0, b, info )
235 CALL chkxer( 'CTRTTP', infot, nout, lerr, ok )
236*
237 srnamt = 'CTPTTR'
238 infot = 1
239 CALL ctpttr( '/', 0, a, b, 1, info )
240 CALL chkxer( 'CTPTTR', infot, nout, lerr, ok )
241 infot = 2
242 CALL ctpttr( 'U', -1, a, b, 1, info )
243 CALL chkxer( 'CTPTTR', infot, nout, lerr, ok )
244 infot = 5
245 CALL ctpttr( 'U', 0, a, b, 0, info )
246 CALL chkxer( 'CTPTTR', infot, nout, lerr, ok )
247*
248 srnamt = 'CHFRK '
249 infot = 1
250 CALL chfrk( '/', 'U', 'N', 0, 0, alpha, a, 1, beta, b )
251 CALL chkxer( 'CHFRK ', infot, nout, lerr, ok )
252 infot = 2
253 CALL chfrk( 'N', '/', 'N', 0, 0, alpha, a, 1, beta, b )
254 CALL chkxer( 'CHFRK ', infot, nout, lerr, ok )
255 infot = 3
256 CALL chfrk( 'N', 'U', '/', 0, 0, alpha, a, 1, beta, b )
257 CALL chkxer( 'CHFRK ', infot, nout, lerr, ok )
258 infot = 4
259 CALL chfrk( 'N', 'U', 'N', -1, 0, alpha, a, 1, beta, b )
260 CALL chkxer( 'CHFRK ', infot, nout, lerr, ok )
261 infot = 5
262 CALL chfrk( 'N', 'U', 'N', 0, -1, alpha, a, 1, beta, b )
263 CALL chkxer( 'CHFRK ', infot, nout, lerr, ok )
264 infot = 8
265 CALL chfrk( 'N', 'U', 'N', 0, 0, alpha, a, 0, beta, b )
266 CALL chkxer( 'CHFRK ', infot, nout, lerr, ok )
267*
268* Print a summary line.
269*
270 IF( ok ) THEN
271 WRITE( nout, fmt = 9999 )
272 ELSE
273 WRITE( nout, fmt = 9998 )
274 END IF
275*
276 9999 FORMAT( 1x, 'COMPLEX RFP routines passed the tests of the ',
277 $ 'error exits' )
278 9998 FORMAT( ' *** RFP routines failed the tests of the error ',
279 $ 'exits ***' )
280 RETURN
281*
282* End of CERRRFP
283*
ctftri
subroutine ctftri(transr, uplo, diag, n, a, info)
CTFTRI
Definition ctftri.f:221

◆ cerrrq()

subroutine cerrrq ( character*3 path,
integer nunit )

CERRRQ

Purpose:
!>
!> CERRRQ tests the error exits for the COMPLEX 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 cerrrq.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 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
76 $ W( NMAX ), X( NMAX )
77* ..
78* .. External Subroutines ..
79 EXTERNAL alaesm, cgerq2, cgerqf, cgerqs, chkxer, cungr2,
80 $ cungrq, cunmr2, cunmrq
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 cmplx, real
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 ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
104 af( i, j ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
105 10 CONTINUE
106 b( j ) = 0.
107 w( j ) = 0.
108 x( j ) = 0.
109 20 CONTINUE
110 ok = .true.
111*
112* Error exits for RQ factorization
113*
114* CGERQF
115*
116 srnamt = 'CGERQF'
117 infot = 1
118 CALL cgerqf( -1, 0, a, 1, b, w, 1, info )
119 CALL chkxer( 'CGERQF', infot, nout, lerr, ok )
120 infot = 2
121 CALL cgerqf( 0, -1, a, 1, b, w, 1, info )
122 CALL chkxer( 'CGERQF', infot, nout, lerr, ok )
123 infot = 4
124 CALL cgerqf( 2, 1, a, 1, b, w, 2, info )
125 CALL chkxer( 'CGERQF', infot, nout, lerr, ok )
126 infot = 7
127 CALL cgerqf( 2, 1, a, 2, b, w, 1, info )
128 CALL chkxer( 'CGERQF', infot, nout, lerr, ok )
129*
130* CGERQ2
131*
132 srnamt = 'CGERQ2'
133 infot = 1
134 CALL cgerq2( -1, 0, a, 1, b, w, info )
135 CALL chkxer( 'CGERQ2', infot, nout, lerr, ok )
136 infot = 2
137 CALL cgerq2( 0, -1, a, 1, b, w, info )
138 CALL chkxer( 'CGERQ2', infot, nout, lerr, ok )
139 infot = 4
140 CALL cgerq2( 2, 1, a, 1, b, w, info )
141 CALL chkxer( 'CGERQ2', infot, nout, lerr, ok )
142*
143* CGERQS
144*
145 srnamt = 'CGERQS'
146 infot = 1
147 CALL cgerqs( -1, 0, 0, a, 1, x, b, 1, w, 1, info )
148 CALL chkxer( 'CGERQS', infot, nout, lerr, ok )
149 infot = 2
150 CALL cgerqs( 0, -1, 0, a, 1, x, b, 1, w, 1, info )
151 CALL chkxer( 'CGERQS', infot, nout, lerr, ok )
152 infot = 2
153 CALL cgerqs( 2, 1, 0, a, 2, x, b, 1, w, 1, info )
154 CALL chkxer( 'CGERQS', infot, nout, lerr, ok )
155 infot = 3
156 CALL cgerqs( 0, 0, -1, a, 1, x, b, 1, w, 1, info )
157 CALL chkxer( 'CGERQS', infot, nout, lerr, ok )
158 infot = 5
159 CALL cgerqs( 2, 2, 0, a, 1, x, b, 2, w, 1, info )
160 CALL chkxer( 'CGERQS', infot, nout, lerr, ok )
161 infot = 8
162 CALL cgerqs( 2, 2, 0, a, 2, x, b, 1, w, 1, info )
163 CALL chkxer( 'CGERQS', infot, nout, lerr, ok )
164 infot = 10
165 CALL cgerqs( 1, 1, 2, a, 1, x, b, 1, w, 1, info )
166 CALL chkxer( 'CGERQS', infot, nout, lerr, ok )
167*
168* CUNGRQ
169*
170 srnamt = 'CUNGRQ'
171 infot = 1
172 CALL cungrq( -1, 0, 0, a, 1, x, w, 1, info )
173 CALL chkxer( 'CUNGRQ', infot, nout, lerr, ok )
174 infot = 2
175 CALL cungrq( 0, -1, 0, a, 1, x, w, 1, info )
176 CALL chkxer( 'CUNGRQ', infot, nout, lerr, ok )
177 infot = 2
178 CALL cungrq( 2, 1, 0, a, 2, x, w, 2, info )
179 CALL chkxer( 'CUNGRQ', infot, nout, lerr, ok )
180 infot = 3
181 CALL cungrq( 0, 0, -1, a, 1, x, w, 1, info )
182 CALL chkxer( 'CUNGRQ', infot, nout, lerr, ok )
183 infot = 3
184 CALL cungrq( 1, 2, 2, a, 1, x, w, 1, info )
185 CALL chkxer( 'CUNGRQ', infot, nout, lerr, ok )
186 infot = 5
187 CALL cungrq( 2, 2, 0, a, 1, x, w, 2, info )
188 CALL chkxer( 'CUNGRQ', infot, nout, lerr, ok )
189 infot = 8
190 CALL cungrq( 2, 2, 0, a, 2, x, w, 1, info )
191 CALL chkxer( 'CUNGRQ', infot, nout, lerr, ok )
192*
193* CUNGR2
194*
195 srnamt = 'CUNGR2'
196 infot = 1
197 CALL cungr2( -1, 0, 0, a, 1, x, w, info )
198 CALL chkxer( 'CUNGR2', infot, nout, lerr, ok )
199 infot = 2
200 CALL cungr2( 0, -1, 0, a, 1, x, w, info )
201 CALL chkxer( 'CUNGR2', infot, nout, lerr, ok )
202 infot = 2
203 CALL cungr2( 2, 1, 0, a, 2, x, w, info )
204 CALL chkxer( 'CUNGR2', infot, nout, lerr, ok )
205 infot = 3
206 CALL cungr2( 0, 0, -1, a, 1, x, w, info )
207 CALL chkxer( 'CUNGR2', infot, nout, lerr, ok )
208 infot = 3
209 CALL cungr2( 1, 2, 2, a, 2, x, w, info )
210 CALL chkxer( 'CUNGR2', infot, nout, lerr, ok )
211 infot = 5
212 CALL cungr2( 2, 2, 0, a, 1, x, w, info )
213 CALL chkxer( 'CUNGR2', infot, nout, lerr, ok )
214*
215* CUNMRQ
216*
217 srnamt = 'CUNMRQ'
218 infot = 1
219 CALL cunmrq( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
220 CALL chkxer( 'CUNMRQ', infot, nout, lerr, ok )
221 infot = 2
222 CALL cunmrq( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
223 CALL chkxer( 'CUNMRQ', infot, nout, lerr, ok )
224 infot = 3
225 CALL cunmrq( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, 1, info )
226 CALL chkxer( 'CUNMRQ', infot, nout, lerr, ok )
227 infot = 4
228 CALL cunmrq( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, 1, info )
229 CALL chkxer( 'CUNMRQ', infot, nout, lerr, ok )
230 infot = 5
231 CALL cunmrq( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, 1, info )
232 CALL chkxer( 'CUNMRQ', infot, nout, lerr, ok )
233 infot = 5
234 CALL cunmrq( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, 1, info )
235 CALL chkxer( 'CUNMRQ', infot, nout, lerr, ok )
236 infot = 5
237 CALL cunmrq( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, 1, info )
238 CALL chkxer( 'CUNMRQ', infot, nout, lerr, ok )
239 infot = 7
240 CALL cunmrq( 'L', 'N', 2, 1, 2, a, 1, x, af, 2, w, 1, info )
241 CALL chkxer( 'CUNMRQ', infot, nout, lerr, ok )
242 infot = 7
243 CALL cunmrq( 'R', 'N', 1, 2, 2, a, 1, x, af, 1, w, 1, info )
244 CALL chkxer( 'CUNMRQ', infot, nout, lerr, ok )
245 infot = 10
246 CALL cunmrq( 'L', 'N', 2, 1, 0, a, 1, x, af, 1, w, 1, info )
247 CALL chkxer( 'CUNMRQ', infot, nout, lerr, ok )
248 infot = 12
249 CALL cunmrq( 'L', 'N', 1, 2, 0, a, 1, x, af, 1, w, 1, info )
250 CALL chkxer( 'CUNMRQ', infot, nout, lerr, ok )
251 infot = 12
252 CALL cunmrq( 'R', 'N', 2, 1, 0, a, 1, x, af, 2, w, 1, info )
253 CALL chkxer( 'CUNMRQ', infot, nout, lerr, ok )
254*
255* CUNMR2
256*
257 srnamt = 'CUNMR2'
258 infot = 1
259 CALL cunmr2( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, info )
260 CALL chkxer( 'CUNMR2', infot, nout, lerr, ok )
261 infot = 2
262 CALL cunmr2( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, info )
263 CALL chkxer( 'CUNMR2', infot, nout, lerr, ok )
264 infot = 3
265 CALL cunmr2( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, info )
266 CALL chkxer( 'CUNMR2', infot, nout, lerr, ok )
267 infot = 4
268 CALL cunmr2( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, info )
269 CALL chkxer( 'CUNMR2', infot, nout, lerr, ok )
270 infot = 5
271 CALL cunmr2( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, info )
272 CALL chkxer( 'CUNMR2', infot, nout, lerr, ok )
273 infot = 5
274 CALL cunmr2( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, info )
275 CALL chkxer( 'CUNMR2', infot, nout, lerr, ok )
276 infot = 5
277 CALL cunmr2( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, info )
278 CALL chkxer( 'CUNMR2', infot, nout, lerr, ok )
279 infot = 7
280 CALL cunmr2( 'L', 'N', 2, 1, 2, a, 1, x, af, 2, w, info )
281 CALL chkxer( 'CUNMR2', infot, nout, lerr, ok )
282 infot = 7
283 CALL cunmr2( 'R', 'N', 1, 2, 2, a, 1, x, af, 1, w, info )
284 CALL chkxer( 'CUNMR2', infot, nout, lerr, ok )
285 infot = 10
286 CALL cunmr2( 'L', 'N', 2, 1, 0, a, 1, x, af, 1, w, info )
287 CALL chkxer( 'CUNMR2', infot, nout, lerr, ok )
288*
289* Print a summary line.
290*
291 CALL alaesm( path, ok, nout )
292*
293 RETURN
294*
295* End of CERRRQ
296*
cgerq2
subroutine cgerq2(m, n, a, lda, tau, work, info)
CGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm.
Definition cgerq2.f:123
cgerqf
subroutine cgerqf(m, n, a, lda, tau, work, lwork, info)
CGERQF
Definition cgerqf.f:139
cunmrq
subroutine cunmrq(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
CUNMRQ
Definition cunmrq.f:168
cungr2
subroutine cungr2(m, n, k, a, lda, tau, work, info)
CUNGR2 generates all or part of the unitary matrix Q from an RQ factorization determined by cgerqf (u...
Definition cungr2.f:114
cunmr2
subroutine cunmr2(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
CUNMR2 multiplies a general matrix by the unitary matrix from a RQ factorization determined by cgerqf...
Definition cunmr2.f:159
cungrq
subroutine cungrq(m, n, k, a, lda, tau, work, lwork, info)
CUNGRQ
Definition cungrq.f:128

◆ cerrsy()

subroutine cerrsy ( character*3 path,
integer nunit )

CERRSY

CERRSYX

Purpose:
!>
!> CERRSY tests the error exits for the COMPLEX 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:
!>
!> CERRSY tests the error exits for the COMPLEX routines
!> for symmetric indefinite matrices.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise cerrsy.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 cerrsy.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 REAL ANRM, RCOND
75* ..
76* .. Local Arrays ..
77 INTEGER IP( NMAX )
78 REAL R( NMAX ), R1( NMAX ), R2( NMAX )
79 COMPLEX 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, cspcon, csprfs, csptrf, csptri,
88 $ csptrs, csycon, csycon_3, csycon_rook, csyrfs,
89 $ csytf2, csytf2_rk, csytf2_rook, csytrf,
90 $ csytrf_rk, csytrf_rook, csytri, csytri_3,
91 $ csytri_3x, csytri_rook, csytri2, csytri2x,
92 $ csytrs, csytrs_3, csytrs_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 cmplx, real
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 ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
117 af( i, j ) = cmplx( 1. / real( i+j ), -1. / real( i+j ) )
118 10 CONTINUE
119 b( j ) = 0.e0
120 e( j ) = 0.e0
121 r1( j ) = 0.e0
122 r2( j ) = 0.e0
123 w( j ) = 0.e0
124 x( j ) = 0.e0
125 ip( j ) = j
126 20 CONTINUE
127 anrm = 1.0
128 ok = .true.
129*
130 IF( lsamen( 2, c2, 'SY' ) ) THEN
131*
132* Test error exits of the routines that use factorization
133* of a symmetric indefinite matrix with patrial
134* (Bunch-Kaufman) diagonal pivoting method.
135*
136* CSYTRF
137*
138 srnamt = 'CSYTRF'
139 infot = 1
140 CALL csytrf( '/', 0, a, 1, ip, w, 1, info )
141 CALL chkxer( 'CSYTRF', infot, nout, lerr, ok )
142 infot = 2
143 CALL csytrf( 'U', -1, a, 1, ip, w, 1, info )
144 CALL chkxer( 'CSYTRF', infot, nout, lerr, ok )
145 infot = 4
146 CALL csytrf( 'U', 2, a, 1, ip, w, 4, info )
147 CALL chkxer( 'CSYTRF', infot, nout, lerr, ok )
148 infot = 7
149 CALL csytrf( 'U', 0, a, 1, ip, w, 0, info )
150 CALL chkxer( 'CSYTRF', infot, nout, lerr, ok )
151 infot = 7
152 CALL csytrf( 'U', 0, a, 1, ip, w, -2, info )
153 CALL chkxer( 'CSYTRF', infot, nout, lerr, ok )
154*
155* CSYTF2
156*
157 srnamt = 'CSYTF2'
158 infot = 1
159 CALL csytf2( '/', 0, a, 1, ip, info )
160 CALL chkxer( 'CSYTF2', infot, nout, lerr, ok )
161 infot = 2
162 CALL csytf2( 'U', -1, a, 1, ip, info )
163 CALL chkxer( 'CSYTF2', infot, nout, lerr, ok )
164 infot = 4
165 CALL csytf2( 'U', 2, a, 1, ip, info )
166 CALL chkxer( 'CSYTF2', infot, nout, lerr, ok )
167*
168* CSYTRI
169*
170 srnamt = 'CSYTRI'
171 infot = 1
172 CALL csytri( '/', 0, a, 1, ip, w, info )
173 CALL chkxer( 'CSYTRI', infot, nout, lerr, ok )
174 infot = 2
175 CALL csytri( 'U', -1, a, 1, ip, w, info )
176 CALL chkxer( 'CSYTRI', infot, nout, lerr, ok )
177 infot = 4
178 CALL csytri( 'U', 2, a, 1, ip, w, info )
179 CALL chkxer( 'CSYTRI', infot, nout, lerr, ok )
180*
181* CSYTRI2
182*
183 srnamt = 'CSYTRI2'
184 infot = 1
185 CALL csytri2( '/', 0, a, 1, ip, w, 1, info )
186 CALL chkxer( 'CSYTRI2', infot, nout, lerr, ok )
187 infot = 2
188 CALL csytri2( 'U', -1, a, 1, ip, w, 1, info )
189 CALL chkxer( 'CSYTRI2', infot, nout, lerr, ok )
190 infot = 4
191 CALL csytri2( 'U', 2, a, 1, ip, w, 1, info )
192 CALL chkxer( 'CSYTRI2', infot, nout, lerr, ok )
193*
194* CSYTRI2X
195*
196 srnamt = 'CSYTRI2X'
197 infot = 1
198 CALL csytri2x( '/', 0, a, 1, ip, w, 1, info )
199 CALL chkxer( 'CSYTRI2X', infot, nout, lerr, ok )
200 infot = 2
201 CALL csytri2x( 'U', -1, a, 1, ip, w, 1, info )
202 CALL chkxer( 'CSYTRI2X', infot, nout, lerr, ok )
203 infot = 4
204 CALL csytri2x( 'U', 2, a, 1, ip, w, 1, info )
205 CALL chkxer( 'CSYTRI2X', infot, nout, lerr, ok )
206*
207* CSYTRS
208*
209 srnamt = 'CSYTRS'
210 infot = 1
211 CALL csytrs( '/', 0, 0, a, 1, ip, b, 1, info )
212 CALL chkxer( 'CSYTRS', infot, nout, lerr, ok )
213 infot = 2
214 CALL csytrs( 'U', -1, 0, a, 1, ip, b, 1, info )
215 CALL chkxer( 'CSYTRS', infot, nout, lerr, ok )
216 infot = 3
217 CALL csytrs( 'U', 0, -1, a, 1, ip, b, 1, info )
218 CALL chkxer( 'CSYTRS', infot, nout, lerr, ok )
219 infot = 5
220 CALL csytrs( 'U', 2, 1, a, 1, ip, b, 2, info )
221 CALL chkxer( 'CSYTRS', infot, nout, lerr, ok )
222 infot = 8
223 CALL csytrs( 'U', 2, 1, a, 2, ip, b, 1, info )
224 CALL chkxer( 'CSYTRS', infot, nout, lerr, ok )
225*
226* CSYRFS
227*
228 srnamt = 'CSYRFS'
229 infot = 1
230 CALL csyrfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
231 $ r, info )
232 CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
233 infot = 2
234 CALL csyrfs( 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
235 $ w, r, info )
236 CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
237 infot = 3
238 CALL csyrfs( 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
239 $ w, r, info )
240 CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
241 infot = 5
242 CALL csyrfs( 'U', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
243 $ r, info )
244 CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
245 infot = 7
246 CALL csyrfs( 'U', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
247 $ r, info )
248 CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
249 infot = 10
250 CALL csyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
251 $ r, info )
252 CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
253 infot = 12
254 CALL csyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
255 $ r, info )
256 CALL chkxer( 'CSYRFS', infot, nout, lerr, ok )
257*
258* CSYCON
259*
260 srnamt = 'CSYCON'
261 infot = 1
262 CALL csycon( '/', 0, a, 1, ip, anrm, rcond, w, info )
263 CALL chkxer( 'CSYCON', infot, nout, lerr, ok )
264 infot = 2
265 CALL csycon( 'U', -1, a, 1, ip, anrm, rcond, w, info )
266 CALL chkxer( 'CSYCON', infot, nout, lerr, ok )
267 infot = 4
268 CALL csycon( 'U', 2, a, 1, ip, anrm, rcond, w, info )
269 CALL chkxer( 'CSYCON', infot, nout, lerr, ok )
270 infot = 6
271 CALL csycon( 'U', 1, a, 1, ip, -anrm, rcond, w, info )
272 CALL chkxer( 'CSYCON', infot, nout, lerr, ok )
273*
274 ELSE IF( lsamen( 2, c2, 'SR' ) ) THEN
275*
276* Test error exits of the routines that use factorization
277* of a symmetric indefinite matrix with rook
278* (bounded Bunch-Kaufman) diagonal pivoting method.
279*
280* CSYTRF_ROOK
281*
282 srnamt = 'CSYTRF_ROOK'
283 infot = 1
284 CALL csytrf_rook( '/', 0, a, 1, ip, w, 1, info )
285 CALL chkxer( 'CSYTRF_ROOK', infot, nout, lerr, ok )
286 infot = 2
287 CALL csytrf_rook( 'U', -1, a, 1, ip, w, 1, info )
288 CALL chkxer( 'CSYTRF_ROOK', infot, nout, lerr, ok )
289 infot = 4
290 CALL csytrf_rook( 'U', 2, a, 1, ip, w, 4, info )
291 CALL chkxer( 'CSYTRF_ROOK', infot, nout, lerr, ok )
292 infot = 7
293 CALL csytrf_rook( 'U', 0, a, 1, ip, w, 0, info )
294 CALL chkxer( 'CSYTRF_ROOK', infot, nout, lerr, ok )
295 infot = 7
296 CALL csytrf_rook( 'U', 0, a, 1, ip, w, -2, info )
297 CALL chkxer( 'CSYTRF_ROOK', infot, nout, lerr, ok )
298*
299* CSYTF2_ROOK
300*
301 srnamt = 'CSYTF2_ROOK'
302 infot = 1
303 CALL csytf2_rook( '/', 0, a, 1, ip, info )
304 CALL chkxer( 'CSYTF2_ROOK', infot, nout, lerr, ok )
305 infot = 2
306 CALL csytf2_rook( 'U', -1, a, 1, ip, info )
307 CALL chkxer( 'CSYTF2_ROOK', infot, nout, lerr, ok )
308 infot = 4
309 CALL csytf2_rook( 'U', 2, a, 1, ip, info )
310 CALL chkxer( 'CSYTF2_ROOK', infot, nout, lerr, ok )
311*
312* CSYTRI_ROOK
313*
314 srnamt = 'CSYTRI_ROOK'
315 infot = 1
316 CALL csytri_rook( '/', 0, a, 1, ip, w, info )
317 CALL chkxer( 'CSYTRI_ROOK', infot, nout, lerr, ok )
318 infot = 2
319 CALL csytri_rook( 'U', -1, a, 1, ip, w, info )
320 CALL chkxer( 'CSYTRI_ROOK', infot, nout, lerr, ok )
321 infot = 4
322 CALL csytri_rook( 'U', 2, a, 1, ip, w, info )
323 CALL chkxer( 'CSYTRI_ROOK', infot, nout, lerr, ok )
324*
325* CSYTRS_ROOK
326*
327 srnamt = 'CSYTRS_ROOK'
328 infot = 1
329 CALL csytrs_rook( '/', 0, 0, a, 1, ip, b, 1, info )
330 CALL chkxer( 'CSYTRS_ROOK', infot, nout, lerr, ok )
331 infot = 2
332 CALL csytrs_rook( 'U', -1, 0, a, 1, ip, b, 1, info )
333 CALL chkxer( 'CSYTRS_ROOK', infot, nout, lerr, ok )
334 infot = 3
335 CALL csytrs_rook( 'U', 0, -1, a, 1, ip, b, 1, info )
336 CALL chkxer( 'CSYTRS_ROOK', infot, nout, lerr, ok )
337 infot = 5
338 CALL csytrs_rook( 'U', 2, 1, a, 1, ip, b, 2, info )
339 CALL chkxer( 'CSYTRS_ROOK', infot, nout, lerr, ok )
340 infot = 8
341 CALL csytrs_rook( 'U', 2, 1, a, 2, ip, b, 1, info )
342 CALL chkxer( 'CSYTRS_ROOK', infot, nout, lerr, ok )
343*
344* CSYCON_ROOK
345*
346 srnamt = 'CSYCON_ROOK'
347 infot = 1
348 CALL csycon_rook( '/', 0, a, 1, ip, anrm, rcond, w, info )
349 CALL chkxer( 'CSYCON_ROOK', infot, nout, lerr, ok )
350 infot = 2
351 CALL csycon_rook( 'U', -1, a, 1, ip, anrm, rcond, w, info )
352 CALL chkxer( 'CSYCON_ROOK', infot, nout, lerr, ok )
353 infot = 4
354 CALL csycon_rook( 'U', 2, a, 1, ip, anrm, rcond, w, info )
355 CALL chkxer( 'CSYCON_ROOK', infot, nout, lerr, ok )
356 infot = 6
357 CALL csycon_rook( 'U', 1, a, 1, ip, -anrm, rcond, w, info )
358 CALL chkxer( 'CSYCON_ROOK', infot, nout, lerr, ok )
359*
360 ELSE IF( lsamen( 2, c2, 'SK' ) ) THEN
361*
362* Test error exits of the routines that use factorization
363* of a symmetric indefinite matrix with rook
364* (bounded Bunch-Kaufman) pivoting with the new storage
365* format for factors L ( or U) and D.
366*
367* L (or U) is stored in A, diagonal of D is stored on the
368* diagonal of A, subdiagonal of D is stored in a separate array E.
369*
370* CSYTRF_RK
371*
372 srnamt = 'CSYTRF_RK'
373 infot = 1
374 CALL csytrf_rk( '/', 0, a, 1, e, ip, w, 1, info )
375 CALL chkxer( 'CSYTRF_RK', infot, nout, lerr, ok )
376 infot = 2
377 CALL csytrf_rk( 'U', -1, a, 1, e, ip, w, 1, info )
378 CALL chkxer( 'CSYTRF_RK', infot, nout, lerr, ok )
379 infot = 4
380 CALL csytrf_rk( 'U', 2, a, 1, e, ip, w, 4, info )
381 CALL chkxer( 'CSYTRF_RK', infot, nout, lerr, ok )
382 infot = 8
383 CALL csytrf_rk( 'U', 0, a, 1, e, ip, w, 0, info )
384 CALL chkxer( 'CSYTRF_RK', infot, nout, lerr, ok )
385 infot = 8
386 CALL csytrf_rk( 'U', 0, a, 1, e, ip, w, -2, info )
387 CALL chkxer( 'CSYTRF_RK', infot, nout, lerr, ok )
388*
389* CSYTF2_RK
390*
391 srnamt = 'CSYTF2_RK'
392 infot = 1
393 CALL csytf2_rk( '/', 0, a, 1, e, ip, info )
394 CALL chkxer( 'CSYTF2_RK', infot, nout, lerr, ok )
395 infot = 2
396 CALL csytf2_rk( 'U', -1, a, 1, e, ip, info )
397 CALL chkxer( 'CSYTF2_RK', infot, nout, lerr, ok )
398 infot = 4
399 CALL csytf2_rk( 'U', 2, a, 1, e, ip, info )
400 CALL chkxer( 'CSYTF2_RK', infot, nout, lerr, ok )
401*
402* CSYTRI_3
403*
404 srnamt = 'CSYTRI_3'
405 infot = 1
406 CALL csytri_3( '/', 0, a, 1, e, ip, w, 1, info )
407 CALL chkxer( 'CSYTRI_3', infot, nout, lerr, ok )
408 infot = 2
409 CALL csytri_3( 'U', -1, a, 1, e, ip, w, 1, info )
410 CALL chkxer( 'CSYTRI_3', infot, nout, lerr, ok )
411 infot = 4
412 CALL csytri_3( 'U', 2, a, 1, e, ip, w, 1, info )
413 CALL chkxer( 'CSYTRI_3', infot, nout, lerr, ok )
414 infot = 8
415 CALL csytri_3( 'U', 0, a, 1, e, ip, w, 0, info )
416 CALL chkxer( 'CSYTRI_3', infot, nout, lerr, ok )
417 infot = 8
418 CALL csytri_3( 'U', 0, a, 1, e, ip, w, -2, info )
419 CALL chkxer( 'CSYTRI_3', infot, nout, lerr, ok )
420*
421* CSYTRI_3X
422*
423 srnamt = 'CSYTRI_3X'
424 infot = 1
425 CALL csytri_3x( '/', 0, a, 1, e, ip, w, 1, info )
426 CALL chkxer( 'CSYTRI_3X', infot, nout, lerr, ok )
427 infot = 2
428 CALL csytri_3x( 'U', -1, a, 1, e, ip, w, 1, info )
429 CALL chkxer( 'CSYTRI_3X', infot, nout, lerr, ok )
430 infot = 4
431 CALL csytri_3x( 'U', 2, a, 1, e, ip, w, 1, info )
432 CALL chkxer( 'CSYTRI_3X', infot, nout, lerr, ok )
433*
434* CSYTRS_3
435*
436 srnamt = 'CSYTRS_3'
437 infot = 1
438 CALL csytrs_3( '/', 0, 0, a, 1, e, ip, b, 1, info )
439 CALL chkxer( 'CSYTRS_3', infot, nout, lerr, ok )
440 infot = 2
441 CALL csytrs_3( 'U', -1, 0, a, 1, e, ip, b, 1, info )
442 CALL chkxer( 'CSYTRS_3', infot, nout, lerr, ok )
443 infot = 3
444 CALL csytrs_3( 'U', 0, -1, a, 1, e, ip, b, 1, info )
445 CALL chkxer( 'CSYTRS_3', infot, nout, lerr, ok )
446 infot = 5
447 CALL csytrs_3( 'U', 2, 1, a, 1, e, ip, b, 2, info )
448 CALL chkxer( 'CSYTRS_3', infot, nout, lerr, ok )
449 infot = 9
450 CALL csytrs_3( 'U', 2, 1, a, 2, e, ip, b, 1, info )
451 CALL chkxer( 'CSYTRS_3', infot, nout, lerr, ok )
452*
453* CSYCON_3
454*
455 srnamt = 'CSYCON_3'
456 infot = 1
457 CALL csycon_3( '/', 0, a, 1, e, ip, anrm, rcond, w, info )
458 CALL chkxer( 'CSYCON_3', infot, nout, lerr, ok )
459 infot = 2
460 CALL csycon_3( 'U', -1, a, 1, e, ip, anrm, rcond, w, info )
461 CALL chkxer( 'CSYCON_3', infot, nout, lerr, ok )
462 infot = 4
463 CALL csycon_3( 'U', 2, a, 1, e, ip, anrm, rcond, w, info )
464 CALL chkxer( 'CSYCON_3', infot, nout, lerr, ok )
465 infot = 7
466 CALL csycon_3( 'U', 1, a, 1, e, ip, -1.0e0, rcond, w, info)
467 CALL chkxer( 'CSYCON_3', infot, nout, lerr, ok )
468*
469 ELSE IF( lsamen( 2, c2, 'SP' ) ) THEN
470*
471* Test error exits of the routines that use factorization
472* of a symmetric indefinite packed matrix with patrial
473* (Bunch-Kaufman) diagonal pivoting method.
474*
475* CSPTRF
476*
477 srnamt = 'CSPTRF'
478 infot = 1
479 CALL csptrf( '/', 0, a, ip, info )
480 CALL chkxer( 'CSPTRF', infot, nout, lerr, ok )
481 infot = 2
482 CALL csptrf( 'U', -1, a, ip, info )
483 CALL chkxer( 'CSPTRF', infot, nout, lerr, ok )
484*
485* CSPTRI
486*
487 srnamt = 'CSPTRI'
488 infot = 1
489 CALL csptri( '/', 0, a, ip, w, info )
490 CALL chkxer( 'CSPTRI', infot, nout, lerr, ok )
491 infot = 2
492 CALL csptri( 'U', -1, a, ip, w, info )
493 CALL chkxer( 'CSPTRI', infot, nout, lerr, ok )
494*
495* CSPTRS
496*
497 srnamt = 'CSPTRS'
498 infot = 1
499 CALL csptrs( '/', 0, 0, a, ip, b, 1, info )
500 CALL chkxer( 'CSPTRS', infot, nout, lerr, ok )
501 infot = 2
502 CALL csptrs( 'U', -1, 0, a, ip, b, 1, info )
503 CALL chkxer( 'CSPTRS', infot, nout, lerr, ok )
504 infot = 3
505 CALL csptrs( 'U', 0, -1, a, ip, b, 1, info )
506 CALL chkxer( 'CSPTRS', infot, nout, lerr, ok )
507 infot = 7
508 CALL csptrs( 'U', 2, 1, a, ip, b, 1, info )
509 CALL chkxer( 'CSPTRS', infot, nout, lerr, ok )
510*
511* CSPRFS
512*
513 srnamt = 'CSPRFS'
514 infot = 1
515 CALL csprfs( '/', 0, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
516 $ info )
517 CALL chkxer( 'CSPRFS', infot, nout, lerr, ok )
518 infot = 2
519 CALL csprfs( 'U', -1, 0, a, af, ip, b, 1, x, 1, r1, r2, w, r,
520 $ info )
521 CALL chkxer( 'CSPRFS', infot, nout, lerr, ok )
522 infot = 3
523 CALL csprfs( 'U', 0, -1, a, af, ip, b, 1, x, 1, r1, r2, w, r,
524 $ info )
525 CALL chkxer( 'CSPRFS', infot, nout, lerr, ok )
526 infot = 8
527 CALL csprfs( 'U', 2, 1, a, af, ip, b, 1, x, 2, r1, r2, w, r,
528 $ info )
529 CALL chkxer( 'CSPRFS', infot, nout, lerr, ok )
530 infot = 10
531 CALL csprfs( 'U', 2, 1, a, af, ip, b, 2, x, 1, r1, r2, w, r,
532 $ info )
533 CALL chkxer( 'CSPRFS', infot, nout, lerr, ok )
534*
535* CSPCON
536*
537 srnamt = 'CSPCON'
538 infot = 1
539 CALL cspcon( '/', 0, a, ip, anrm, rcond, w, info )
540 CALL chkxer( 'CSPCON', infot, nout, lerr, ok )
541 infot = 2
542 CALL cspcon( 'U', -1, a, ip, anrm, rcond, w, info )
543 CALL chkxer( 'CSPCON', infot, nout, lerr, ok )
544 infot = 5
545 CALL cspcon( 'U', 1, a, ip, -anrm, rcond, w, info )
546 CALL chkxer( 'CSPCON', infot, nout, lerr, ok )
547*
548 ELSE IF( lsamen( 2, c2, 'SA' ) ) THEN
549*
550* Test error exits of the routines that use factorization
551* of a symmetric indefinite matrix with Aasen's algorithm
552*
553* CSYTRF_AA
554*
555 srnamt = 'CSYTRF_AA'
556 infot = 1
557 CALL csytrf_aa( '/', 0, a, 1, ip, w, 1, info )
558 CALL chkxer( 'CSYTRF_AA', infot, nout, lerr, ok )
559 infot = 2
560 CALL csytrf_aa( 'U', -1, a, 1, ip, w, 1, info )
561 CALL chkxer( 'CSYTRF_AA', infot, nout, lerr, ok )
562 infot = 4
563 CALL csytrf_aa( 'U', 2, a, 1, ip, w, 4, info )
564 CALL chkxer( 'CSYTRF_AA', infot, nout, lerr, ok )
565 infot = 7
566 CALL csytrf_aa( 'U', 0, a, 1, ip, w, 0, info )
567 CALL chkxer( 'CSYTRF_AA', infot, nout, lerr, ok )
568 infot = 7
569 CALL csytrf_aa( 'U', 0, a, 1, ip, w, -2, info )
570 CALL chkxer( 'CSYTRF_AA', infot, nout, lerr, ok )
571*
572* CSYTRS_AA
573*
574 srnamt = 'CSYTRS_AA'
575 infot = 1
576 CALL csytrs_aa( '/', 0, 0, a, 1, ip, b, 1, w, 1, info )
577 CALL chkxer( 'CSYTRS_AA', infot, nout, lerr, ok )
578 infot = 2
579 CALL csytrs_aa( 'U', -1, 0, a, 1, ip, b, 1, w, 1, info )
580 CALL chkxer( 'CSYTRS_AA', infot, nout, lerr, ok )
581 infot = 3
582 CALL csytrs_aa( 'U', 0, -1, a, 1, ip, b, 1, w, 1, info )
583 CALL chkxer( 'CSYTRS_AA', infot, nout, lerr, ok )
584 infot = 5
585 CALL csytrs_aa( 'U', 2, 1, a, 1, ip, b, 2, w, 1, info )
586 CALL chkxer( 'CSYTRS_AA', infot, nout, lerr, ok )
587 infot = 8
588 CALL csytrs_aa( 'U', 2, 1, a, 2, ip, b, 1, w, 1, info )
589 CALL chkxer( 'CSYTRS_AA', infot, nout, lerr, ok )
590 infot = 10
591 CALL csytrs_aa( 'U', 0, 1, a, 1, ip, b, 1, w, 0, info )
592 CALL chkxer( 'CSYTRS_AA', infot, nout, lerr, ok )
593 infot = 10
594 CALL csytrs_aa( 'U', 0, 1, a, 1, ip, b, 1, w, -2, info )
595 CALL chkxer( 'CSYTRS_AA', infot, nout, lerr, ok )
596*
597 ELSE IF( lsamen( 2, c2, 'S2' ) ) THEN
598*
599* Test error exits of the routines that use factorization
600* of a symmetric indefinite matrix with Aasen's algorithm.
601*
602* CSYTRF_AA_2STAGE
603*
604 srnamt = 'CSYTRF_AA_2STAGE'
605 infot = 1
606 CALL csytrf_aa_2stage( '/', 0, a, 1, a, 1, ip, ip, w, 1,
607 $ info )
608 CALL chkxer( 'CSYTRF_AA_2STAGE', infot, nout, lerr, ok )
609 infot = 2
610 CALL csytrf_aa_2stage( 'U', -1, a, 1, a, 1, ip, ip, w, 1,
611 $ info )
612 CALL chkxer( 'CSYTRF_AA_2STAGE', infot, nout, lerr, ok )
613 infot = 4
614 CALL csytrf_aa_2stage( 'U', 2, a, 1, a, 2, ip, ip, w, 1,
615 $ info )
616 CALL chkxer( 'CSYTRF_AA_2STAGE', infot, nout, lerr, ok )
617 infot = 6
618 CALL csytrf_aa_2stage( 'U', 2, a, 2, a, 1, ip, ip, w, 1,
619 $ info )
620 CALL chkxer( 'CSYTRF_AA_2STAGE', infot, nout, lerr, ok )
621 infot = 10
622 CALL csytrf_aa_2stage( 'U', 2, a, 2, a, 8, ip, ip, w, 0,
623 $ info )
624 CALL chkxer( 'CSYTRF_AA_2STAGE', infot, nout, lerr, ok )
625*
626* CHETRS_AA_2STAGE
627*
628 srnamt = 'CSYTRS_AA_2STAGE'
629 infot = 1
630 CALL csytrs_aa_2stage( '/', 0, 0, a, 1, a, 1, ip, ip,
631 $ b, 1, info )
632 CALL chkxer( 'CSYTRS_AA_2STAGE', infot, nout, lerr, ok )
633 infot = 2
634 CALL csytrs_aa_2stage( 'U', -1, 0, a, 1, a, 1, ip, ip,
635 $ b, 1, info )
636 CALL chkxer( 'CSYTRS_AA_2STAGE', infot, nout, lerr, ok )
637 infot = 3
638 CALL csytrs_aa_2stage( 'U', 0, -1, a, 1, a, 1, ip, ip,
639 $ b, 1, info )
640 CALL chkxer( 'CSYTRS_AA_2STAGE', infot, nout, lerr, ok )
641 infot = 5
642 CALL csytrs_aa_2stage( 'U', 2, 1, a, 1, a, 1, ip, ip,
643 $ b, 1, info )
644 CALL chkxer( 'CSYTRS_AA_2STAGE', infot, nout, lerr, ok )
645 infot = 7
646 CALL csytrs_aa_2stage( 'U', 2, 1, a, 2, a, 1, ip, ip,
647 $ b, 1, info )
648 CALL chkxer( 'CSYTRS_AA_2STAGE', infot, nout, lerr, ok )
649 infot = 11
650 CALL csytrs_aa_2stage( 'U', 2, 1, a, 2, a, 8, ip, ip,
651 $ b, 1, info )
652 CALL chkxer( 'CSYTRS_AA_STAGE', infot, nout, lerr, ok )
653*
654 END IF
655*
656* Print a summary line.
657*
658 CALL alaesm( path, ok, nout )
659*
660 RETURN
661*
662* End of CERRSY
663*
csytf2_rk
subroutine csytf2_rk(uplo, n, a, lda, e, ipiv, info)
CSYTF2_RK computes the factorization of a complex symmetric indefinite matrix using the bounded Bunch...
Definition csytf2_rk.f:241
csytri2x
subroutine csytri2x(uplo, n, a, lda, ipiv, work, nb, info)
CSYTRI2X
Definition csytri2x.f:120
csytf2_rook
subroutine csytf2_rook(uplo, n, a, lda, ipiv, info)
CSYTF2_ROOK computes the factorization of a complex symmetric indefinite matrix using the bounded Bun...
Definition csytf2_rook.f:194
csytri
subroutine csytri(uplo, n, a, lda, ipiv, work, info)
CSYTRI
Definition csytri.f:114
csytf2
subroutine csytf2(uplo, n, a, lda, ipiv, info)
CSYTF2 computes the factorization of a real symmetric indefinite matrix, using the diagonal pivoting ...
Definition csytf2.f:191
csytri_3x
subroutine csytri_3x(uplo, n, a, lda, e, ipiv, work, nb, info)
CSYTRI_3X
Definition csytri_3x.f:159

◆ cerrtr()

subroutine cerrtr ( character*3 path,
integer nunit )

CERRTR

Purpose:
!>
!> CERRTR tests the error exits for the COMPLEX 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 cerrtr.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 REAL RCOND, SCALE
74* ..
75* .. Local Arrays ..
76 REAL R1( NMAX ), R2( NMAX ), RW( NMAX )
77 COMPLEX 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, clatbs, clatps, clatrs, ctbcon,
86 $ ctbrfs, ctbtrs, ctpcon, ctprfs, ctptri, ctptrs,
87 $ ctrcon, ctrrfs, ctrti2, ctrtri, ctrtrs
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.
104 a( 1, 2 ) = 2.
105 a( 2, 2 ) = 3.
106 a( 2, 1 ) = 4.
107 ok = .true.
108*
109* Test error exits for the general triangular routines.
110*
111 IF( lsamen( 2, c2, 'TR' ) ) THEN
112*
113* CTRTRI
114*
115 srnamt = 'CTRTRI'
116 infot = 1
117 CALL ctrtri( '/', 'N', 0, a, 1, info )
118 CALL chkxer( 'CTRTRI', infot, nout, lerr, ok )
119 infot = 2
120 CALL ctrtri( 'U', '/', 0, a, 1, info )
121 CALL chkxer( 'CTRTRI', infot, nout, lerr, ok )
122 infot = 3
123 CALL ctrtri( 'U', 'N', -1, a, 1, info )
124 CALL chkxer( 'CTRTRI', infot, nout, lerr, ok )
125 infot = 5
126 CALL ctrtri( 'U', 'N', 2, a, 1, info )
127 CALL chkxer( 'CTRTRI', infot, nout, lerr, ok )
128*
129* CTRTI2
130*
131 srnamt = 'CTRTI2'
132 infot = 1
133 CALL ctrti2( '/', 'N', 0, a, 1, info )
134 CALL chkxer( 'CTRTI2', infot, nout, lerr, ok )
135 infot = 2
136 CALL ctrti2( 'U', '/', 0, a, 1, info )
137 CALL chkxer( 'CTRTI2', infot, nout, lerr, ok )
138 infot = 3
139 CALL ctrti2( 'U', 'N', -1, a, 1, info )
140 CALL chkxer( 'CTRTI2', infot, nout, lerr, ok )
141 infot = 5
142 CALL ctrti2( 'U', 'N', 2, a, 1, info )
143 CALL chkxer( 'CTRTI2', infot, nout, lerr, ok )
144*
145*
146* CTRTRS
147*
148 srnamt = 'CTRTRS'
149 infot = 1
150 CALL ctrtrs( '/', 'N', 'N', 0, 0, a, 1, x, 1, info )
151 CALL chkxer( 'CTRTRS', infot, nout, lerr, ok )
152 infot = 2
153 CALL ctrtrs( 'U', '/', 'N', 0, 0, a, 1, x, 1, info )
154 CALL chkxer( 'CTRTRS', infot, nout, lerr, ok )
155 infot = 3
156 CALL ctrtrs( 'U', 'N', '/', 0, 0, a, 1, x, 1, info )
157 CALL chkxer( 'CTRTRS', infot, nout, lerr, ok )
158 infot = 4
159 CALL ctrtrs( 'U', 'N', 'N', -1, 0, a, 1, x, 1, info )
160 CALL chkxer( 'CTRTRS', infot, nout, lerr, ok )
161 infot = 5
162 CALL ctrtrs( 'U', 'N', 'N', 0, -1, a, 1, x, 1, info )
163 CALL chkxer( 'CTRTRS', infot, nout, lerr, ok )
164 infot = 7
165*
166* CTRRFS
167*
168 srnamt = 'CTRRFS'
169 infot = 1
170 CALL ctrrfs( '/', 'N', 'N', 0, 0, a, 1, b, 1, x, 1, r1, r2, w,
171 $ rw, info )
172 CALL chkxer( 'CTRRFS', infot, nout, lerr, ok )
173 infot = 2
174 CALL ctrrfs( 'U', '/', 'N', 0, 0, a, 1, b, 1, x, 1, r1, r2, w,
175 $ rw, info )
176 CALL chkxer( 'CTRRFS', infot, nout, lerr, ok )
177 infot = 3
178 CALL ctrrfs( 'U', 'N', '/', 0, 0, a, 1, b, 1, x, 1, r1, r2, w,
179 $ rw, info )
180 CALL chkxer( 'CTRRFS', infot, nout, lerr, ok )
181 infot = 4
182 CALL ctrrfs( 'U', 'N', 'N', -1, 0, a, 1, b, 1, x, 1, r1, r2, w,
183 $ rw, info )
184 CALL chkxer( 'CTRRFS', infot, nout, lerr, ok )
185 infot = 5
186 CALL ctrrfs( 'U', 'N', 'N', 0, -1, a, 1, b, 1, x, 1, r1, r2, w,
187 $ rw, info )
188 CALL chkxer( 'CTRRFS', infot, nout, lerr, ok )
189 infot = 7
190 CALL ctrrfs( 'U', 'N', 'N', 2, 1, a, 1, b, 2, x, 2, r1, r2, w,
191 $ rw, info )
192 CALL chkxer( 'CTRRFS', infot, nout, lerr, ok )
193 infot = 9
194 CALL ctrrfs( 'U', 'N', 'N', 2, 1, a, 2, b, 1, x, 2, r1, r2, w,
195 $ rw, info )
196 CALL chkxer( 'CTRRFS', infot, nout, lerr, ok )
197 infot = 11
198 CALL ctrrfs( 'U', 'N', 'N', 2, 1, a, 2, b, 2, x, 1, r1, r2, w,
199 $ rw, info )
200 CALL chkxer( 'CTRRFS', infot, nout, lerr, ok )
201*
202* CTRCON
203*
204 srnamt = 'CTRCON'
205 infot = 1
206 CALL ctrcon( '/', 'U', 'N', 0, a, 1, rcond, w, rw, info )
207 CALL chkxer( 'CTRCON', infot, nout, lerr, ok )
208 infot = 2
209 CALL ctrcon( '1', '/', 'N', 0, a, 1, rcond, w, rw, info )
210 CALL chkxer( 'CTRCON', infot, nout, lerr, ok )
211 infot = 3
212 CALL ctrcon( '1', 'U', '/', 0, a, 1, rcond, w, rw, info )
213 CALL chkxer( 'CTRCON', infot, nout, lerr, ok )
214 infot = 4
215 CALL ctrcon( '1', 'U', 'N', -1, a, 1, rcond, w, rw, info )
216 CALL chkxer( 'CTRCON', infot, nout, lerr, ok )
217 infot = 6
218 CALL ctrcon( '1', 'U', 'N', 2, a, 1, rcond, w, rw, info )
219 CALL chkxer( 'CTRCON', infot, nout, lerr, ok )
220*
221* CLATRS
222*
223 srnamt = 'CLATRS'
224 infot = 1
225 CALL clatrs( '/', 'N', 'N', 'N', 0, a, 1, x, scale, rw, info )
226 CALL chkxer( 'CLATRS', infot, nout, lerr, ok )
227 infot = 2
228 CALL clatrs( 'U', '/', 'N', 'N', 0, a, 1, x, scale, rw, info )
229 CALL chkxer( 'CLATRS', infot, nout, lerr, ok )
230 infot = 3
231 CALL clatrs( 'U', 'N', '/', 'N', 0, a, 1, x, scale, rw, info )
232 CALL chkxer( 'CLATRS', infot, nout, lerr, ok )
233 infot = 4
234 CALL clatrs( 'U', 'N', 'N', '/', 0, a, 1, x, scale, rw, info )
235 CALL chkxer( 'CLATRS', infot, nout, lerr, ok )
236 infot = 5
237 CALL clatrs( 'U', 'N', 'N', 'N', -1, a, 1, x, scale, rw, info )
238 CALL chkxer( 'CLATRS', infot, nout, lerr, ok )
239 infot = 7
240 CALL clatrs( 'U', 'N', 'N', 'N', 2, a, 1, x, scale, rw, info )
241 CALL chkxer( 'CLATRS', 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* CTPTRI
248*
249 srnamt = 'CTPTRI'
250 infot = 1
251 CALL ctptri( '/', 'N', 0, a, info )
252 CALL chkxer( 'CTPTRI', infot, nout, lerr, ok )
253 infot = 2
254 CALL ctptri( 'U', '/', 0, a, info )
255 CALL chkxer( 'CTPTRI', infot, nout, lerr, ok )
256 infot = 3
257 CALL ctptri( 'U', 'N', -1, a, info )
258 CALL chkxer( 'CTPTRI', infot, nout, lerr, ok )
259*
260* CTPTRS
261*
262 srnamt = 'CTPTRS'
263 infot = 1
264 CALL ctptrs( '/', 'N', 'N', 0, 0, a, x, 1, info )
265 CALL chkxer( 'CTPTRS', infot, nout, lerr, ok )
266 infot = 2
267 CALL ctptrs( 'U', '/', 'N', 0, 0, a, x, 1, info )
268 CALL chkxer( 'CTPTRS', infot, nout, lerr, ok )
269 infot = 3
270 CALL ctptrs( 'U', 'N', '/', 0, 0, a, x, 1, info )
271 CALL chkxer( 'CTPTRS', infot, nout, lerr, ok )
272 infot = 4
273 CALL ctptrs( 'U', 'N', 'N', -1, 0, a, x, 1, info )
274 CALL chkxer( 'CTPTRS', infot, nout, lerr, ok )
275 infot = 5
276 CALL ctptrs( 'U', 'N', 'N', 0, -1, a, x, 1, info )
277 CALL chkxer( 'CTPTRS', infot, nout, lerr, ok )
278 infot = 8
279 CALL ctptrs( 'U', 'N', 'N', 2, 1, a, x, 1, info )
280 CALL chkxer( 'CTPTRS', infot, nout, lerr, ok )
281*
282* CTPRFS
283*
284 srnamt = 'CTPRFS'
285 infot = 1
286 CALL ctprfs( '/', 'N', 'N', 0, 0, a, b, 1, x, 1, r1, r2, w, rw,
287 $ info )
288 CALL chkxer( 'CTPRFS', infot, nout, lerr, ok )
289 infot = 2
290 CALL ctprfs( 'U', '/', 'N', 0, 0, a, b, 1, x, 1, r1, r2, w, rw,
291 $ info )
292 CALL chkxer( 'CTPRFS', infot, nout, lerr, ok )
293 infot = 3
294 CALL ctprfs( 'U', 'N', '/', 0, 0, a, b, 1, x, 1, r1, r2, w, rw,
295 $ info )
296 CALL chkxer( 'CTPRFS', infot, nout, lerr, ok )
297 infot = 4
298 CALL ctprfs( 'U', 'N', 'N', -1, 0, a, b, 1, x, 1, r1, r2, w,
299 $ rw, info )
300 CALL chkxer( 'CTPRFS', infot, nout, lerr, ok )
301 infot = 5
302 CALL ctprfs( 'U', 'N', 'N', 0, -1, a, b, 1, x, 1, r1, r2, w,
303 $ rw, info )
304 CALL chkxer( 'CTPRFS', infot, nout, lerr, ok )
305 infot = 8
306 CALL ctprfs( 'U', 'N', 'N', 2, 1, a, b, 1, x, 2, r1, r2, w, rw,
307 $ info )
308 CALL chkxer( 'CTPRFS', infot, nout, lerr, ok )
309 infot = 10
310 CALL ctprfs( 'U', 'N', 'N', 2, 1, a, b, 2, x, 1, r1, r2, w, rw,
311 $ info )
312 CALL chkxer( 'CTPRFS', infot, nout, lerr, ok )
313*
314* CTPCON
315*
316 srnamt = 'CTPCON'
317 infot = 1
318 CALL ctpcon( '/', 'U', 'N', 0, a, rcond, w, rw, info )
319 CALL chkxer( 'CTPCON', infot, nout, lerr, ok )
320 infot = 2
321 CALL ctpcon( '1', '/', 'N', 0, a, rcond, w, rw, info )
322 CALL chkxer( 'CTPCON', infot, nout, lerr, ok )
323 infot = 3
324 CALL ctpcon( '1', 'U', '/', 0, a, rcond, w, rw, info )
325 CALL chkxer( 'CTPCON', infot, nout, lerr, ok )
326 infot = 4
327 CALL ctpcon( '1', 'U', 'N', -1, a, rcond, w, rw, info )
328 CALL chkxer( 'CTPCON', infot, nout, lerr, ok )
329*
330* CLATPS
331*
332 srnamt = 'CLATPS'
333 infot = 1
334 CALL clatps( '/', 'N', 'N', 'N', 0, a, x, scale, rw, info )
335 CALL chkxer( 'CLATPS', infot, nout, lerr, ok )
336 infot = 2
337 CALL clatps( 'U', '/', 'N', 'N', 0, a, x, scale, rw, info )
338 CALL chkxer( 'CLATPS', infot, nout, lerr, ok )
339 infot = 3
340 CALL clatps( 'U', 'N', '/', 'N', 0, a, x, scale, rw, info )
341 CALL chkxer( 'CLATPS', infot, nout, lerr, ok )
342 infot = 4
343 CALL clatps( 'U', 'N', 'N', '/', 0, a, x, scale, rw, info )
344 CALL chkxer( 'CLATPS', infot, nout, lerr, ok )
345 infot = 5
346 CALL clatps( 'U', 'N', 'N', 'N', -1, a, x, scale, rw, info )
347 CALL chkxer( 'CLATPS', 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* CTBTRS
354*
355 srnamt = 'CTBTRS'
356 infot = 1
357 CALL ctbtrs( '/', 'N', 'N', 0, 0, 0, a, 1, x, 1, info )
358 CALL chkxer( 'CTBTRS', infot, nout, lerr, ok )
359 infot = 2
360 CALL ctbtrs( 'U', '/', 'N', 0, 0, 0, a, 1, x, 1, info )
361 CALL chkxer( 'CTBTRS', infot, nout, lerr, ok )
362 infot = 3
363 CALL ctbtrs( 'U', 'N', '/', 0, 0, 0, a, 1, x, 1, info )
364 CALL chkxer( 'CTBTRS', infot, nout, lerr, ok )
365 infot = 4
366 CALL ctbtrs( 'U', 'N', 'N', -1, 0, 0, a, 1, x, 1, info )
367 CALL chkxer( 'CTBTRS', infot, nout, lerr, ok )
368 infot = 5
369 CALL ctbtrs( 'U', 'N', 'N', 0, -1, 0, a, 1, x, 1, info )
370 CALL chkxer( 'CTBTRS', infot, nout, lerr, ok )
371 infot = 6
372 CALL ctbtrs( 'U', 'N', 'N', 0, 0, -1, a, 1, x, 1, info )
373 CALL chkxer( 'CTBTRS', infot, nout, lerr, ok )
374 infot = 8
375 CALL ctbtrs( 'U', 'N', 'N', 2, 1, 1, a, 1, x, 2, info )
376 CALL chkxer( 'CTBTRS', infot, nout, lerr, ok )
377 infot = 10
378 CALL ctbtrs( 'U', 'N', 'N', 2, 0, 1, a, 1, x, 1, info )
379 CALL chkxer( 'CTBTRS', infot, nout, lerr, ok )
380*
381* CTBRFS
382*
383 srnamt = 'CTBRFS'
384 infot = 1
385 CALL ctbrfs( '/', 'N', 'N', 0, 0, 0, a, 1, b, 1, x, 1, r1, r2,
386 $ w, rw, info )
387 CALL chkxer( 'CTBRFS', infot, nout, lerr, ok )
388 infot = 2
389 CALL ctbrfs( 'U', '/', 'N', 0, 0, 0, a, 1, b, 1, x, 1, r1, r2,
390 $ w, rw, info )
391 CALL chkxer( 'CTBRFS', infot, nout, lerr, ok )
392 infot = 3
393 CALL ctbrfs( 'U', 'N', '/', 0, 0, 0, a, 1, b, 1, x, 1, r1, r2,
394 $ w, rw, info )
395 CALL chkxer( 'CTBRFS', infot, nout, lerr, ok )
396 infot = 4
397 CALL ctbrfs( 'U', 'N', 'N', -1, 0, 0, a, 1, b, 1, x, 1, r1, r2,
398 $ w, rw, info )
399 CALL chkxer( 'CTBRFS', infot, nout, lerr, ok )
400 infot = 5
401 CALL ctbrfs( 'U', 'N', 'N', 0, -1, 0, a, 1, b, 1, x, 1, r1, r2,
402 $ w, rw, info )
403 CALL chkxer( 'CTBRFS', infot, nout, lerr, ok )
404 infot = 6
405 CALL ctbrfs( 'U', 'N', 'N', 0, 0, -1, a, 1, b, 1, x, 1, r1, r2,
406 $ w, rw, info )
407 CALL chkxer( 'CTBRFS', infot, nout, lerr, ok )
408 infot = 8
409 CALL ctbrfs( 'U', 'N', 'N', 2, 1, 1, a, 1, b, 2, x, 2, r1, r2,
410 $ w, rw, info )
411 CALL chkxer( 'CTBRFS', infot, nout, lerr, ok )
412 infot = 10
413 CALL ctbrfs( 'U', 'N', 'N', 2, 1, 1, a, 2, b, 1, x, 2, r1, r2,
414 $ w, rw, info )
415 CALL chkxer( 'CTBRFS', infot, nout, lerr, ok )
416 infot = 12
417 CALL ctbrfs( 'U', 'N', 'N', 2, 1, 1, a, 2, b, 2, x, 1, r1, r2,
418 $ w, rw, info )
419 CALL chkxer( 'CTBRFS', infot, nout, lerr, ok )
420*
421* CTBCON
422*
423 srnamt = 'CTBCON'
424 infot = 1
425 CALL ctbcon( '/', 'U', 'N', 0, 0, a, 1, rcond, w, rw, info )
426 CALL chkxer( 'CTBCON', infot, nout, lerr, ok )
427 infot = 2
428 CALL ctbcon( '1', '/', 'N', 0, 0, a, 1, rcond, w, rw, info )
429 CALL chkxer( 'CTBCON', infot, nout, lerr, ok )
430 infot = 3
431 CALL ctbcon( '1', 'U', '/', 0, 0, a, 1, rcond, w, rw, info )
432 CALL chkxer( 'CTBCON', infot, nout, lerr, ok )
433 infot = 4
434 CALL ctbcon( '1', 'U', 'N', -1, 0, a, 1, rcond, w, rw, info )
435 CALL chkxer( 'CTBCON', infot, nout, lerr, ok )
436 infot = 5
437 CALL ctbcon( '1', 'U', 'N', 0, -1, a, 1, rcond, w, rw, info )
438 CALL chkxer( 'CTBCON', infot, nout, lerr, ok )
439 infot = 7
440 CALL ctbcon( '1', 'U', 'N', 2, 1, a, 1, rcond, w, rw, info )
441 CALL chkxer( 'CTBCON', infot, nout, lerr, ok )
442*
443* CLATBS
444*
445 srnamt = 'CLATBS'
446 infot = 1
447 CALL clatbs( '/', 'N', 'N', 'N', 0, 0, a, 1, x, scale, rw,
448 $ info )
449 CALL chkxer( 'CLATBS', infot, nout, lerr, ok )
450 infot = 2
451 CALL clatbs( 'U', '/', 'N', 'N', 0, 0, a, 1, x, scale, rw,
452 $ info )
453 CALL chkxer( 'CLATBS', infot, nout, lerr, ok )
454 infot = 3
455 CALL clatbs( 'U', 'N', '/', 'N', 0, 0, a, 1, x, scale, rw,
456 $ info )
457 CALL chkxer( 'CLATBS', infot, nout, lerr, ok )
458 infot = 4
459 CALL clatbs( 'U', 'N', 'N', '/', 0, 0, a, 1, x, scale, rw,
460 $ info )
461 CALL chkxer( 'CLATBS', infot, nout, lerr, ok )
462 infot = 5
463 CALL clatbs( 'U', 'N', 'N', 'N', -1, 0, a, 1, x, scale, rw,
464 $ info )
465 CALL chkxer( 'CLATBS', infot, nout, lerr, ok )
466 infot = 6
467 CALL clatbs( 'U', 'N', 'N', 'N', 1, -1, a, 1, x, scale, rw,
468 $ info )
469 CALL chkxer( 'CLATBS', infot, nout, lerr, ok )
470 infot = 8
471 CALL clatbs( 'U', 'N', 'N', 'N', 2, 1, a, 1, x, scale, rw,
472 $ info )
473 CALL chkxer( 'CLATBS', 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 CERRTR
483*
ctrti2
subroutine ctrti2(uplo, diag, n, a, lda, info)
CTRTI2 computes the inverse of a triangular matrix (unblocked algorithm).
Definition ctrti2.f:110

◆ cerrtz()

subroutine cerrtz ( character*3 path,
integer nunit )

CERRTZ

Purpose:
!>
!> CERRTZ tests the error exits for CTZRZF.
!>
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 cerrtz.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 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, ctzrzf
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 cmplx
95* ..
96* .. Executable Statements ..
97*
98 nout = nunit
99 c2 = path( 2: 3 )
100 a( 1, 1 ) = cmplx( 1.e+0, -1.e+0 )
101 a( 1, 2 ) = cmplx( 2.e+0, -2.e+0 )
102 a( 2, 2 ) = cmplx( 3.e+0, -3.e+0 )
103 a( 2, 1 ) = cmplx( 4.e+0, -4.e+0 )
104 w( 1 ) = cmplx( 0.e+0, 0.e+0 )
105 w( 2 ) = cmplx( 0.e+0, 0.e+0 )
106 ok = .true.
107*
108* Test error exits for the trapezoidal routines.
109*
110 WRITE( nout, fmt = * )
111 IF( lsamen( 2, c2, 'TZ' ) ) THEN
112*
113* CTZRZF
114*
115 srnamt = 'CTZRZF'
116 infot = 1
117 CALL ctzrzf( -1, 0, a, 1, tau, w, 1, info )
118 CALL chkxer( 'CTZRZF', infot, nout, lerr, ok )
119 infot = 2
120 CALL ctzrzf( 1, 0, a, 1, tau, w, 1, info )
121 CALL chkxer( 'CTZRZF', infot, nout, lerr, ok )
122 infot = 4
123 CALL ctzrzf( 2, 2, a, 1, tau, w, 1, info )
124 CALL chkxer( 'CTZRZF', infot, nout, lerr, ok )
125 infot = 7
126 CALL ctzrzf( 2, 2, a, 2, tau, w, 0, info )
127 CALL chkxer( 'CTZRZF', infot, nout, lerr, ok )
128 infot = 7
129 CALL ctzrzf( 2, 3, a, 2, tau, w, 1, info )
130 CALL chkxer( 'CTZRZF', 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 CERRTZ
140*

◆ cerrunhr_col()

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

CERRUNHR_COL

Purpose:
!>
!> CERRUNHR_COL tests the error exits for CUNHR_COL that does
!> Householder reconstruction from the output of tall-skinny
!> factorization CLATSQR.
!>
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 cerrunhr_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 A( NMAX, NMAX ), T( NMAX, NMAX ), D(NMAX)
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, cunhr_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 real, cmplx
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 ) = cmplx( 1.e+0 / real( i+j ) )
104 t( i, j ) = cmplx( 1.e+0 / real( i+j ) )
105 END DO
106 d( j ) = ( 0.e+0, 0.e+0 )
107 END DO
108 ok = .true.
109*
110* Error exits for Householder reconstruction
111*
112* CUNHR_COL
113*
114 srnamt = 'CUNHR_COL'
115*
116 infot = 1
117 CALL cunhr_col( -1, 0, 1, a, 1, t, 1, d, info )
118 CALL chkxer( 'CUNHR_COL', infot, nout, lerr, ok )
119*
120 infot = 2
121 CALL cunhr_col( 0, -1, 1, a, 1, t, 1, d, info )
122 CALL chkxer( 'CUNHR_COL', infot, nout, lerr, ok )
123 CALL cunhr_col( 1, 2, 1, a, 1, t, 1, d, info )
124 CALL chkxer( 'CUNHR_COL', infot, nout, lerr, ok )
125*
126 infot = 3
127 CALL cunhr_col( 0, 0, -1, a, 1, t, 1, d, info )
128 CALL chkxer( 'CUNHR_COL', infot, nout, lerr, ok )
129*
130 CALL cunhr_col( 0, 0, 0, a, 1, t, 1, d, info )
131 CALL chkxer( 'CUNHR_COL', infot, nout, lerr, ok )
132*
133 infot = 5
134 CALL cunhr_col( 0, 0, 1, a, -1, t, 1, d, info )
135 CALL chkxer( 'CUNHR_COL', infot, nout, lerr, ok )
136*
137 CALL cunhr_col( 0, 0, 1, a, 0, t, 1, d, info )
138 CALL chkxer( 'CUNHR_COL', infot, nout, lerr, ok )
139*
140 CALL cunhr_col( 2, 0, 1, a, 1, t, 1, d, info )
141 CALL chkxer( 'CUNHR_COL', infot, nout, lerr, ok )
142*
143 infot = 7
144 CALL cunhr_col( 0, 0, 1, a, 1, t, -1, d, info )
145 CALL chkxer( 'CUNHR_COL', infot, nout, lerr, ok )
146*
147 CALL cunhr_col( 0, 0, 1, a, 1, t, 0, d, info )
148 CALL chkxer( 'CUNHR_COL', infot, nout, lerr, ok )
149*
150 CALL cunhr_col( 4, 3, 2, a, 4, t, 1, d, info )
151 CALL chkxer( 'CUNHR_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 CERRUNHR_COL
160*
cunhr_col
subroutine cunhr_col(m, n, nb, a, lda, t, ldt, d, info)
CUNHR_COL
Definition cunhr_col.f:259

◆ cerrvx()

subroutine cerrvx ( character*3 path,
integer nunit )

CERRVX

CERRVXX

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

◆ cgbt01()

subroutine cgbt01 ( integer m,
integer n,
integer kl,
integer ku,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldafac, * ) afac,
integer ldafac,
integer, dimension( * ) ipiv,
complex, dimension( * ) work,
real resid )

CGBT01

Purpose:
!>
!> CGBT01 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 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 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
!>          CGBTRF.  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 CGBTRF 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 CGBTRF.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*KL+KU+1)
!>
[out]RESID
!>          RESID is REAL
!>          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 cgbt01.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 REAL RESID
134* ..
135* .. Array Arguments ..
136 INTEGER IPIV( * )
137 COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ZERO, ONE
144 parameter( zero = 0.0e+0, one = 1.0e+0 )
145* ..
146* .. Local Scalars ..
147 INTEGER I, I1, I2, IL, IP, IW, J, JL, JU, JUA, KD, LENJ
148 REAL ANORM, EPS
149 COMPLEX T
150* ..
151* .. External Functions ..
152 REAL SCASUM, SLAMCH
153 EXTERNAL scasum, slamch
154* ..
155* .. External Subroutines ..
156 EXTERNAL caxpy, ccopy
157* ..
158* .. Intrinsic Functions ..
159 INTRINSIC cmplx, max, min, real
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 = slamch( '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, scasum( 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 ccopy( 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 caxpy( 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 caxpy( jua+jl+1, -cmplx( one ), a( ku+1-jua, j ), 1,
221 $ work( ju+1-jua ), 1 )
222*
223* Compute the 1-norm of the column.
224*
225 resid = max( resid, scasum( 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 / real( n ) ) / anorm ) / eps
236 END IF
237*
238 RETURN
239*
240* End of CGBT01
241*
caxpy
subroutine caxpy(n, ca, cx, incx, cy, incy)
CAXPY
Definition caxpy.f:88

◆ cgbt02()

subroutine cgbt02 ( character trans,
integer m,
integer n,
integer kl,
integer ku,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldb, * ) b,
integer ldb,
real, dimension( * ) rwork,
real resid )

CGBT02

Purpose:
!>
!> CGBT02 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 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 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 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 REAL array, dimension (MAX(1,LRWORK)),
!>          where LRWORK >= M when TRANS = 'T' or 'C'; otherwise, RWORK
!>          is not referenced.
!>
[out]RESID
!>          RESID is REAL
!>          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 cgbt02.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 REAL RESID
157* ..
158* .. Array Arguments ..
159 REAL RWORK( * )
160 COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 REAL ZERO, ONE
167 parameter( zero = 0.0e+0, one = 1.0e+0 )
168 COMPLEX CONE
169 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
170* ..
171* .. Local Scalars ..
172 INTEGER I1, I2, J, KD, N1
173 REAL ANORM, BNORM, EPS, TEMP, XNORM
174 COMPLEX CDUM
175* ..
176* .. External Functions ..
177 LOGICAL LSAME, SISNAN
178 REAL SCASUM, SLAMCH
179 EXTERNAL lsame, scasum, sisnan, slamch
180* ..
181* .. External Subroutines ..
182 EXTERNAL cgbmv
183* ..
184* .. Statement Functions ..
185 REAL CABS1
186* ..
187* .. Intrinsic Functions ..
188 INTRINSIC abs, aimag, max, min, real
189* ..
190* .. Statement Function definitions ..
191 cabs1( cdum ) = abs( real( cdum ) ) + abs( aimag( cdum ) )
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 = slamch( '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 = scasum( i2-i1+1, a( i1, j ), 1 )
216 IF( anorm.LT.temp .OR. sisnan( 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. sisnan( 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 cgbmv( 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 = scasum( n1, b( 1, j ), 1 )
261 xnorm = scasum( 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 CGBT02
272*
sisnan
logical function sisnan(sin)
SISNAN tests input for NaN.
Definition sisnan.f:59
cgbmv
subroutine cgbmv(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, incy)
CGBMV
Definition cgbmv.f:187

◆ cgbt05()

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

CGBT05

Purpose:
!>
!> CGBT05 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 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 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 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 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 REAL 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 REAL 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 REAL 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 cgbt05.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 REAL BERR( * ), FERR( * ), RESLTS( * )
187 COMPLEX AB( LDAB, * ), B( LDB, * ), X( LDX, * ),
188 $ XACT( LDXACT, * )
189* ..
190*
191* =====================================================================
192*
193* .. Parameters ..
194 REAL ZERO, ONE
195 parameter( zero = 0.0e+0, one = 1.0e+0 )
196* ..
197* .. Local Scalars ..
198 LOGICAL NOTRAN
199 INTEGER I, IMAX, J, K, NZ
200 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
201 COMPLEX ZDUM
202* ..
203* .. External Functions ..
204 LOGICAL LSAME
205 INTEGER ICAMAX
206 REAL SLAMCH
207 EXTERNAL lsame, icamax, slamch
208* ..
209* .. Intrinsic Functions ..
210 INTRINSIC abs, aimag, max, min, real
211* ..
212* .. Statement Functions ..
213 REAL CABS1
214* ..
215* .. Statement Function definitions ..
216 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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 = slamch( 'Epsilon' )
229 unfl = slamch( '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 = icamax( 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 CGBT05
299*
icamax
integer function icamax(n, cx, incx)
ICAMAX
Definition icamax.f:71

◆ cgelqs()

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

CGELQS

Purpose:
!>
!> Compute a minimum-norm solution
!>     min || A*X - B ||
!> using the LQ factorization
!>     A = L*Q
!> computed by CGELQF.
!>
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 array, dimension (LDA,N)
!>          Details of the LQ factorization of the original matrix A as
!>          returned by CGELQF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= M.
!>
[in]TAU
!>          TAU is COMPLEX array, dimension (M)
!>          Details of the orthogonal matrix Q.
!>
[in,out]B
!>          B is COMPLEX 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 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 cgelqs.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 A( LDA, * ), B( LDB, * ), TAU( * ),
131 $ WORK( LWORK )
132* ..
133*
134* =====================================================================
135*
136* .. Parameters ..
137 COMPLEX CZERO, CONE
138 parameter( czero = ( 0.0e+0, 0.0e+0 ),
139 $ cone = ( 1.0e+0, 0.0e+0 ) )
140* ..
141* .. External Subroutines ..
142 EXTERNAL claset, ctrsm, cunmlq, xerbla
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( 'CGELQS', -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 ctrsm( '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 claset( 'Full', n-m, nrhs, czero, czero, b( m+1, 1 ),
185 $ ldb )
186*
187* B := Q' * B
188*
189 CALL cunmlq( 'Left', 'Conjugate transpose', n, nrhs, m, a, lda,
190 $ tau, b, ldb, work, lwork, info )
191*
192 RETURN
193*
194* End of CGELQS
195*
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60

◆ cgennd()

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

CGENND

Purpose:
!>
!>    CGENND 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 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 cgennd.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 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 AII
89* ..
90* .. Intrinsics ..
91 INTRINSIC min, real, aimag
92* ..
93* .. Executable Statements ..
94 k = min( m, n )
95 DO i = 1, k
96 aii = a( i, i )
97 IF( real( aii ).LT.zero.OR.aimag( aii ).NE.zero ) THEN
98 cgennd = .false.
99 RETURN
100 END IF
101 END DO
102 cgennd = .true.
103 RETURN

◆ cgeqls()

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

CGEQLS

Purpose:
!>
!> Solve the least squares problem
!>     min || A*X - B ||
!> using the QL factorization
!>     A = Q*L
!> computed by CGEQLF.
!>
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 array, dimension (LDA,N)
!>          Details of the QL factorization of the original matrix A as
!>          returned by CGEQLF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= M.
!>
[in]TAU
!>          TAU is COMPLEX array, dimension (N)
!>          Details of the orthogonal matrix Q.
!>
[in,out]B
!>          B is COMPLEX 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 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 cgeqls.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 A( LDA, * ), B( LDB, * ), TAU( * ),
132 $ WORK( LWORK )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 COMPLEX ONE
139 parameter( one = ( 1.0e+0, 0.0e+0 ) )
140* ..
141* .. External Subroutines ..
142 EXTERNAL ctrsm, cunmql, xerbla
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( 'CGEQLS', -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 cunmql( '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 ctrsm( '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 CGEQLS
189*

◆ cgeqrs()

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

CGEQRS

Purpose:
!>
!> Solve the least squares problem
!>     min || A*X - B ||
!> using the QR factorization
!>     A = Q*R
!> computed by CGEQRF.
!>
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 array, dimension (LDA,N)
!>          Details of the QR factorization of the original matrix A as
!>          returned by CGEQRF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= M.
!>
[in]TAU
!>          TAU is COMPLEX array, dimension (N)
!>          Details of the orthogonal matrix Q.
!>
[in,out]B
!>          B is COMPLEX 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 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 cgeqrs.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 A( LDA, * ), B( LDB, * ), TAU( * ),
131 $ WORK( LWORK )
132* ..
133*
134* =====================================================================
135*
136* .. Parameters ..
137 COMPLEX ONE
138 parameter( one = ( 1.0e+0, 0.0e+0 ) )
139* ..
140* .. External Subroutines ..
141 EXTERNAL ctrsm, cunmqr, xerbla
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( 'CGEQRS', -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 cunmqr( '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 ctrsm( 'Left', 'Upper', 'No transpose', 'Non-unit', n, nrhs,
183 $ one, a, lda, b, ldb )
184*
185 RETURN
186*
187* End of CGEQRS
188*

◆ cgerqs()

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

CGERQS

Purpose:
!>
!> Compute a minimum-norm solution
!>     min || A*X - B ||
!> using the RQ factorization
!>     A = R*Q
!> computed by CGERQF.
!>
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 array, dimension (LDA,N)
!>          Details of the RQ factorization of the original matrix A as
!>          returned by CGERQF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= M.
!>
[in]TAU
!>          TAU is COMPLEX array, dimension (M)
!>          Details of the orthogonal matrix Q.
!>
[in,out]B
!>          B is COMPLEX 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 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 cgerqs.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 A( LDA, * ), B( LDB, * ), TAU( * ),
132 $ WORK( LWORK )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 COMPLEX CZERO, CONE
139 parameter( czero = ( 0.0e+0, 0.0e+0 ),
140 $ cone = ( 1.0e+0, 0.0e+0 ) )
141* ..
142* .. External Subroutines ..
143 EXTERNAL claset, ctrsm, cunmrq, xerbla
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( 'CGERQS', -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 ctrsm( '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 claset( 'Full', n-m, nrhs, czero, czero, b, ldb )
185*
186* B := Q' * B
187*
188 CALL cunmrq( 'Left', 'Conjugate transpose', n, nrhs, m, a, lda,
189 $ tau, b, ldb, work, lwork, info )
190*
191 RETURN
192*
193* End of CGERQS
194*

◆ cget01()

subroutine cget01 ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldafac, * ) afac,
integer ldafac,
integer, dimension( * ) ipiv,
real, dimension( * ) rwork,
real resid )

CGET01

Purpose:
!>
!> CGET01 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 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 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 CGETRF.
!>          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 CGETRF.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (M)
!>
[out]RESID
!>          RESID is REAL
!>          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 cget01.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 REAL RESID
116* ..
117* .. Array Arguments ..
118 INTEGER IPIV( * )
119 REAL RWORK( * )
120 COMPLEX A( LDA, * ), AFAC( LDAFAC, * )
121* ..
122*
123* =====================================================================
124*
125* .. Parameters ..
126 REAL ONE, ZERO
127 parameter( zero = 0.0e+0, one = 1.0e+0 )
128 COMPLEX CONE
129 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
130* ..
131* .. Local Scalars ..
132 INTEGER I, J, K
133 REAL ANORM, EPS
134 COMPLEX T
135* ..
136* .. External Functions ..
137 REAL CLANGE, SLAMCH
138 COMPLEX CDOTU
139 EXTERNAL clange, slamch, cdotu
140* ..
141* .. External Subroutines ..
142 EXTERNAL cgemv, claswp, cscal, ctrmv
143* ..
144* .. Intrinsic Functions ..
145 INTRINSIC min, real
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 = slamch( 'Epsilon' )
159 anorm = clange( '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 ctrmv( '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 cscal( m-k, t, afac( k+1, k ), 1 )
176 CALL cgemv( '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 + cdotu( k-1, afac( k, 1 ), ldafac,
184 $ afac( 1, k ), 1 )
185*
186* Compute elements (1:K-1,K)
187*
188 CALL ctrmv( 'Lower', 'No transpose', 'Unit', k-1, afac,
189 $ ldafac, afac( 1, k ), 1 )
190 END IF
191 10 CONTINUE
192 CALL claswp( 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 = clange( '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/real( n ) )/anorm ) / eps
211 END IF
212*
213 RETURN
214*
215* End of CGET01
216*
claswp
subroutine claswp(n, a, lda, k1, k2, ipiv, incx)
CLASWP performs a series of row interchanges on a general rectangular matrix.
Definition claswp.f:115
cdotu
complex function cdotu(n, cx, incx, cy, incy)
CDOTU
Definition cdotu.f:83
ctrmv
subroutine ctrmv(uplo, trans, diag, n, a, lda, x, incx)
CTRMV
Definition ctrmv.f:147
cgemv
subroutine cgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
CGEMV
Definition cgemv.f:158

◆ cget02()

subroutine cget02 ( character trans,
integer m,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldb, * ) b,
integer ldb,
real, dimension( * ) rwork,
real resid )

CGET02

Purpose:
!>
!> CGET02 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 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 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 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 REAL array, dimension (M)
!>
[out]RESID
!>          RESID is REAL
!>          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 cget02.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 REAL RESID
143* ..
144* .. Array Arguments ..
145 REAL RWORK( * )
146 COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * )
147* ..
148*
149* =====================================================================
150*
151* .. Parameters ..
152 REAL ZERO, ONE
153 parameter( zero = 0.0e+0, one = 1.0e+0 )
154 COMPLEX CONE
155 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
156* ..
157* .. Local Scalars ..
158 INTEGER J, N1, N2
159 REAL ANORM, BNORM, EPS, XNORM
160* ..
161* .. External Functions ..
162 LOGICAL LSAME
163 REAL CLANGE, SCASUM, SLAMCH
164 EXTERNAL lsame, clange, scasum, slamch
165* ..
166* .. External Subroutines ..
167 EXTERNAL cgemm
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 = slamch( 'Epsilon' )
192 IF( lsame( trans, 'N' ) ) THEN
193 anorm = clange( '1', m, n, a, lda, rwork )
194 ELSE
195 anorm = clange( '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 cgemm( 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 = scasum( n1, b( 1, j ), 1 )
213 xnorm = scasum( 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 CGET02
224*

◆ cget03()

subroutine cget03 ( integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldainv, * ) ainv,
integer ldainv,
complex, dimension( ldwork, * ) work,
integer ldwork,
real, dimension( * ) rwork,
real rcond,
real resid )

CGET03

Purpose:
!>
!> CGET03 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 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 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 array, dimension (LDWORK,N)
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.  LDWORK >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RCOND
!>          RCOND is REAL
!>          The reciprocal of the condition number of A, computed as
!>          ( 1/norm(A) ) / norm(AINV).
!>
[out]RESID
!>          RESID is REAL
!>          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 cget03.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 REAL RCOND, RESID
118* ..
119* .. Array Arguments ..
120 REAL RWORK( * )
121 COMPLEX A( LDA, * ), AINV( LDAINV, * ),
122 $ WORK( LDWORK, * )
123* ..
124*
125* =====================================================================
126*
127* .. Parameters ..
128 REAL ZERO, ONE
129 parameter( zero = 0.0e+0, one = 1.0e+0 )
130 COMPLEX CZERO, CONE
131 parameter( czero = ( 0.0e+0, 0.0e+0 ),
132 $ cone = ( 1.0e+0, 0.0e+0 ) )
133* ..
134* .. Local Scalars ..
135 INTEGER I
136 REAL AINVNM, ANORM, EPS
137* ..
138* .. External Functions ..
139 REAL CLANGE, SLAMCH
140 EXTERNAL clange, slamch
141* ..
142* .. External Subroutines ..
143 EXTERNAL cgemm
144* ..
145* .. Intrinsic Functions ..
146 INTRINSIC real
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 = slamch( 'Epsilon' )
161 anorm = clange( '1', n, n, a, lda, rwork )
162 ainvnm = clange( '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 cgemm( 'No transpose', 'No transpose', n, n, n, -cone,
173 $ ainv, 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 = clange( '1', n, n, work, ldwork, rwork )
181*
182 resid = ( ( resid*rcond )/eps ) / real( n )
183*
184 RETURN
185*
186* End of CGET03
187*

◆ cget04()

subroutine cget04 ( integer n,
integer nrhs,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldxact, * ) xact,
integer ldxact,
real rcond,
real resid )

CGET04

Purpose:
!>
!> CGET04 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 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 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 REAL
!>          The reciprocal of the condition number of the coefficient
!>          matrix in the system of equations.
!>
[out]RESID
!>          RESID is REAL
!>          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 cget04.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 REAL RCOND, RESID
110* ..
111* .. Array Arguments ..
112 COMPLEX X( LDX, * ), XACT( LDXACT, * )
113* ..
114*
115* =====================================================================
116*
117* .. Parameters ..
118 REAL ZERO
119 parameter( zero = 0.0e+0 )
120* ..
121* .. Local Scalars ..
122 INTEGER I, IX, J
123 REAL DIFFNM, EPS, XNORM
124 COMPLEX ZDUM
125* ..
126* .. External Functions ..
127 INTEGER ICAMAX
128 REAL SLAMCH
129 EXTERNAL icamax, slamch
130* ..
131* .. Intrinsic Functions ..
132 INTRINSIC abs, aimag, max, real
133* ..
134* .. Statement Functions ..
135 REAL CABS1
136* ..
137* .. Statement Function definitions ..
138 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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 = slamch( 'Epsilon' )
152 IF( rcond.LT.zero ) THEN
153 resid = 1.0 / 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 = icamax( 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.0 / eps
172 ELSE
173 resid = max( resid, ( diffnm / xnorm )*rcond )
174 END IF
175 20 CONTINUE
176 IF( resid*eps.LT.1.0 )
177 $ resid = resid / eps
178*
179 RETURN
180*
181* End of CGET04
182*

◆ cget07()

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

CGET07

Purpose:
!>
!> CGET07 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 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 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 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 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 REAL 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 REAL 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 REAL 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 cget07.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 REAL BERR( * ), FERR( * ), RESLTS( * )
178 COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * ),
179 $ XACT( LDXACT, * )
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 REAL ZERO, ONE
186 parameter( zero = 0.0e+0, one = 1.0e+0 )
187* ..
188* .. Local Scalars ..
189 LOGICAL NOTRAN
190 INTEGER I, IMAX, J, K
191 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
192 COMPLEX ZDUM
193* ..
194* .. External Functions ..
195 LOGICAL LSAME
196 INTEGER ICAMAX
197 REAL SLAMCH
198 EXTERNAL lsame, icamax, slamch
199* ..
200* .. Intrinsic Functions ..
201 INTRINSIC abs, aimag, max, min, real
202* ..
203* .. Statement Functions ..
204 REAL CABS1
205* ..
206* .. Statement Function definitions ..
207 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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 = slamch( 'Epsilon' )
220 unfl = slamch( '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 = icamax( 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 CGET07
290*

◆ cgtt01()

subroutine cgtt01 ( integer n,
complex, dimension( * ) dl,
complex, dimension( * ) d,
complex, dimension( * ) du,
complex, dimension( * ) dlf,
complex, dimension( * ) df,
complex, dimension( * ) duf,
complex, dimension( * ) du2,
integer, dimension( * ) ipiv,
complex, dimension( ldwork, * ) work,
integer ldwork,
real, dimension( * ) rwork,
real resid )

CGTT01

Purpose:
!>
!> CGTT01 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 array, dimension (N-1)
!>          The (n-1) sub-diagonal elements of A.
!>
[in]D
!>          D is COMPLEX array, dimension (N)
!>          The diagonal elements of A.
!>
[in]DU
!>          DU is COMPLEX array, dimension (N-1)
!>          The (n-1) super-diagonal elements of A.
!>
[in]DLF
!>          DLF is COMPLEX array, dimension (N-1)
!>          The (n-1) multipliers that define the matrix L from the
!>          LU factorization of A.
!>
[in]DF
!>          DF is COMPLEX array, dimension (N)
!>          The n diagonal elements of the upper triangular matrix U from
!>          the LU factorization of A.
!>
[in]DUF
!>          DUF is COMPLEX array, dimension (N-1)
!>          The (n-1) elements of the first super-diagonal of U.
!>
[in]DU2
!>          DU2 is COMPLEX 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 array, dimension (LDWORK,N)
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.  LDWORK >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 cgtt01.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 REAL RESID
142* ..
143* .. Array Arguments ..
144 INTEGER IPIV( * )
145 REAL RWORK( * )
146 COMPLEX D( * ), DF( * ), DL( * ), DLF( * ), DU( * ),
147 $ DU2( * ), DUF( * ), WORK( LDWORK, * )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 REAL ONE, ZERO
154 parameter( one = 1.0e+0, zero = 0.0e+0 )
155* ..
156* .. Local Scalars ..
157 INTEGER I, IP, J, LASTJ
158 REAL ANORM, EPS
159 COMPLEX LI
160* ..
161* .. External Functions ..
162 REAL CLANGT, CLANHS, SLAMCH
163 EXTERNAL clangt, clanhs, slamch
164* ..
165* .. Intrinsic Functions ..
166 INTRINSIC min
167* ..
168* .. External Subroutines ..
169 EXTERNAL caxpy, cswap
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 = slamch( '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 caxpy( 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 cswap( 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 = clangt( '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 = clanhs( '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 CGTT01
257*
clanhs
real function clanhs(norm, n, a, lda, work)
CLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition clanhs.f:109

◆ cgtt02()

subroutine cgtt02 ( character trans,
integer n,
integer nrhs,
complex, dimension( * ) dl,
complex, dimension( * ) d,
complex, dimension( * ) du,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldb, * ) b,
integer ldb,
real resid )

CGTT02

Purpose:
!>
!> CGTT02 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 array, dimension (N-1)
!>          The (n-1) sub-diagonal elements of A.
!>
[in]D
!>          D is COMPLEX array, dimension (N)
!>          The diagonal elements of A.
!>
[in]DU
!>          DU is COMPLEX array, dimension (N-1)
!>          The (n-1) super-diagonal elements of A.
!>
[in]X
!>          X is COMPLEX 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 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 REAL
!>          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 cgtt02.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 REAL RESID
133* ..
134* .. Array Arguments ..
135 COMPLEX B( LDB, * ), D( * ), DL( * ), DU( * ),
136 $ X( LDX, * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 REAL ONE, ZERO
143 parameter( one = 1.0e+0, zero = 0.0e+0 )
144* ..
145* .. Local Scalars ..
146 INTEGER J
147 REAL ANORM, BNORM, EPS, XNORM
148* ..
149* .. External Functions ..
150 LOGICAL LSAME
151 REAL CLANGT, SCASUM, SLAMCH
152 EXTERNAL lsame, clangt, scasum, slamch
153* ..
154* .. External Subroutines ..
155 EXTERNAL clagtm
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 = clangt( '1', n, dl, d, du )
173 ELSE
174 anorm = clangt( 'I', n, dl, d, du )
175 END IF
176*
177* Exit with RESID = 1/EPS if ANORM = 0.
178*
179 eps = slamch( '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 clagtm( trans, n, nrhs, -one, dl, d, du, x, ldx, one, b,
188 $ ldb )
189*
190 DO 10 j = 1, nrhs
191 bnorm = scasum( n, b( 1, j ), 1 )
192 xnorm = scasum( 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 CGTT02
203*

◆ cgtt05()

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

CGTT05

Purpose:
!>
!> CGTT05 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 array, dimension (N-1)
!>          The (n-1) sub-diagonal elements of A.
!>
[in]D
!>          D is COMPLEX array, dimension (N)
!>          The diagonal elements of A.
!>
[in]DU
!>          DU is COMPLEX array, dimension (N-1)
!>          The (n-1) super-diagonal elements of A.
!>
[in]B
!>          B is COMPLEX 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 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 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 REAL 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 REAL 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 REAL 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 cgtt05.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 REAL BERR( * ), FERR( * ), RESLTS( * )
176 COMPLEX B( LDB, * ), D( * ), DL( * ), DU( * ),
177 $ X( LDX, * ), XACT( LDXACT, * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 REAL ZERO, ONE
184 parameter( zero = 0.0e+0, one = 1.0e+0 )
185* ..
186* .. Local Scalars ..
187 LOGICAL NOTRAN
188 INTEGER I, IMAX, J, K, NZ
189 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
190 COMPLEX ZDUM
191* ..
192* .. External Functions ..
193 LOGICAL LSAME
194 INTEGER ICAMAX
195 REAL SLAMCH
196 EXTERNAL lsame, icamax, slamch
197* ..
198* .. Intrinsic Functions ..
199 INTRINSIC abs, aimag, max, min, real
200* ..
201* .. Statement Functions ..
202 REAL CABS1
203* ..
204* .. Statement Function definitions ..
205 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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 = slamch( 'Epsilon' )
218 unfl = slamch( '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 = icamax( 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 CGTT05
310*

◆ chet01()

subroutine chet01 ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldafac, * ) afac,
integer ldafac,
integer, dimension( * ) ipiv,
complex, dimension( ldc, * ) c,
integer ldc,
real, dimension( * ) rwork,
real resid )

CHET01

Purpose:
!>
!> CHET01 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 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 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 CHETRF.
!>
[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 CHETRF.
!>
[out]C
!>          C is COMPLEX array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 chet01.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 REAL RESID
135* ..
136* .. Array Arguments ..
137 INTEGER IPIV( * )
138 REAL RWORK( * )
139 COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
140* ..
141*
142* =====================================================================
143*
144* .. Parameters ..
145 REAL ZERO, ONE
146 parameter( zero = 0.0e+0, one = 1.0e+0 )
147 COMPLEX CZERO, CONE
148 parameter( czero = ( 0.0e+0, 0.0e+0 ),
149 $ cone = ( 1.0e+0, 0.0e+0 ) )
150* ..
151* .. Local Scalars ..
152 INTEGER I, INFO, J
153 REAL ANORM, EPS
154* ..
155* .. External Functions ..
156 LOGICAL LSAME
157 REAL CLANHE, SLAMCH
158 EXTERNAL lsame, clanhe, slamch
159* ..
160* .. External Subroutines ..
161 EXTERNAL clavhe, claset
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC aimag, real
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 = slamch( 'Epsilon' )
178 anorm = clanhe( '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( aimag( 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 claset( 'Full', n, n, czero, cone, c, ldc )
193*
194* Call CLAVHE to form the product D * U' (or D * L' ).
195*
196 CALL clavhe( uplo, 'Conjugate', 'Non-unit', n, n, afac, ldafac,
197 $ ipiv, c, ldc, info )
198*
199* Call CLAVHE again to multiply by U (or L ).
200*
201 CALL clavhe( 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 ) - real( a( j, j ) )
212 30 CONTINUE
213 ELSE
214 DO 50 j = 1, n
215 c( j, j ) = c( j, j ) - real( 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 = clanhe( '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 / real( n ) ) / anorm ) / eps
231 END IF
232*
233 RETURN
234*
235* End of CHET01
236*
clavhe
subroutine clavhe(uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
CLAVHE
Definition clavhe.f:153

◆ chet01_3()

subroutine chet01_3 ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldafac, * ) afac,
integer ldafac,
complex, dimension( * ) e,
integer, dimension( * ) ipiv,
complex, dimension( ldc, * ) c,
integer ldc,
real, dimension( * ) rwork,
real resid )

CHET01_3

Purpose:
!>
!> CHET01_3 reconstructs a Hermitian indefinite matrix A from its
!> block L*D*L' or U*D*U' factorization computed by CHETRF_RK
!> (or CHETRF_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 array, dimension (LDAFAC,N)
!>          Diagonal of the block diagonal matrix D and factors U or L
!>          as computed by CHETRF_RK and CHETRF_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 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 CHETRF_RK (or CHETRF_BK).
!>
[out]C
!>          C is COMPLEX array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 chet01_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 REAL RESID
150* ..
151* .. Array Arguments ..
152 INTEGER IPIV( * )
153 REAL RWORK( * )
154 COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
155 $ E( * )
156* ..
157*
158* =====================================================================
159*
160* .. Parameters ..
161 REAL ZERO, ONE
162 parameter( zero = 0.0e+0, one = 1.0e+0 )
163 COMPLEX CZERO, CONE
164 parameter( czero = ( 0.0e+0, 0.0e+0 ),
165 $ cone = ( 1.0e+0, 0.0e+0 ) )
166* ..
167* .. Local Scalars ..
168 INTEGER I, INFO, J
169 REAL ANORM, EPS
170* ..
171* .. External Functions ..
172 LOGICAL LSAME
173 REAL CLANHE, SLAMCH
174 EXTERNAL lsame, clanhe, slamch
175* ..
176* .. External Subroutines ..
177 EXTERNAL claset, clavhe_rook, csyconvf_rook
178* ..
179* .. Intrinsic Functions ..
180 INTRINSIC aimag, real
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 csyconvf_rook( uplo, 'R', n, afac, ldafac, e, ipiv, info )
194*
195* 1) Determine EPS and the norm of A.
196*
197 eps = slamch( 'Epsilon' )
198 anorm = clanhe( '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( aimag( 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 claset( 'Full', n, n, czero, cone, c, ldc )
213*
214* 3) Call CLAVHE_ROOK to form the product D * U' (or D * L' ).
215*
216 CALL clavhe_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 clavhe_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 ) - real( a( j, j ) )
232 END DO
233 ELSE
234 DO j = 1, n
235 c( j, j ) = c( j, j ) - real( 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 = clanhe( '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/real( n ) )/anorm ) / eps
251 END IF
252*
253* b) Convert to factor of L (or U)
254*
255 CALL csyconvf_rook( uplo, 'C', n, afac, ldafac, e, ipiv, info )
256*
257 RETURN
258*
259* End of CHET01_3
260*
csyconvf_rook
subroutine csyconvf_rook(uplo, way, n, a, lda, e, ipiv, info)
CSYCONVF_ROOK
Definition csyconvf_rook.f:200
clavhe_rook
subroutine clavhe_rook(uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
CLAVHE_ROOK
Definition clavhe_rook.f:156

◆ chet01_aa()

subroutine chet01_aa ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldafac, * ) afac,
integer ldafac,
integer, dimension( * ) ipiv,
complex, dimension( ldc, * ) c,
integer ldc,
real, dimension( * ) rwork,
real resid )

CHET01_AA

Purpose:
!>
!> CHET01_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 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 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 CHETRF.
!>
[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 CHETRF.
!>
[out]C
!>          C is COMPLEX 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 array, dimension (N)
!>
[out]RESID
!>          RESID is COMPLEX
!>          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 chet01_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 REAL RESID
133* ..
134* .. Array Arguments ..
135 INTEGER IPIV( * )
136 REAL RWORK( * )
137 COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 COMPLEX CZERO, CONE
144 parameter( czero = ( 0.0e+0, 0.0e+0 ),
145 $ cone = ( 1.0e+0, 0.0e+0 ) )
146 REAL ZERO, ONE
147 parameter( zero = 0.0e+0, one = 1.0e+0 )
148* ..
149* .. Local Scalars ..
150 INTEGER I, J
151 REAL ANORM, EPS
152* ..
153* .. External Functions ..
154 LOGICAL LSAME
155 REAL SLAMCH, CLANHE
156 EXTERNAL lsame, slamch, clanhe
157* ..
158* .. External Subroutines ..
159 EXTERNAL claset, clavhe
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 = slamch( 'Epsilon' )
176 anorm = clanhe( '1', uplo, n, a, lda, rwork )
177*
178* Initialize C to the tridiagonal matrix T.
179*
180 CALL claset( 'Full', n, n, czero, czero, c, ldc )
181 CALL clacpy( '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 clacpy( 'F', 1, n-1, afac( 1, 2 ), ldafac+1, c( 1, 2 ),
185 $ ldc+1 )
186 CALL clacpy( 'F', 1, n-1, afac( 1, 2 ), ldafac+1, c( 2, 1 ),
187 $ ldc+1 )
188 CALL clacgv( n-1, c( 2, 1 ), ldc+1 )
189 ELSE
190 CALL clacpy( 'F', 1, n-1, afac( 2, 1 ), ldafac+1, c( 1, 2 ),
191 $ ldc+1 )
192 CALL clacpy( 'F', 1, n-1, afac( 2, 1 ), ldafac+1, c( 2, 1 ),
193 $ ldc+1 )
194 CALL clacgv( n-1, c( 1, 2 ), ldc+1 )
195 ENDIF
196*
197* Call CTRMM to form the product U' * D (or L * D ).
198*
199 IF( lsame( uplo, 'U' ) ) THEN
200 CALL ctrmm( 'Left', uplo, 'Conjugate transpose', 'Unit',
201 $ n-1, n, cone, afac( 1, 2 ), ldafac, c( 2, 1 ),
202 $ ldc )
203 ELSE
204 CALL ctrmm( 'Left', uplo, 'No transpose', 'Unit', n-1, n,
205 $ cone, afac( 2, 1 ), ldafac, c( 2, 1 ), ldc )
206 END IF
207*
208* Call CTRMM again to multiply by U (or L ).
209*
210 IF( lsame( uplo, 'U' ) ) THEN
211 CALL ctrmm( 'Right', uplo, 'No transpose', 'Unit', n, n-1,
212 $ cone, afac( 1, 2 ), ldafac, c( 1, 2 ), ldc )
213 ELSE
214 CALL ctrmm( 'Right', uplo, 'Conjugate transpose', 'Unit', n,
215 $ n-1, cone, afac( 2, 1 ), ldafac, c( 1, 2 ),
216 $ ldc )
217 END IF
218 ENDIF
219*
220* Apply hermitian pivots
221*
222 DO j = n, 1, -1
223 i = ipiv( j )
224 IF( i.NE.j )
225 $ CALL cswap( n, c( j, 1 ), ldc, c( i, 1 ), ldc )
226 END DO
227 DO j = n, 1, -1
228 i = ipiv( j )
229 IF( i.NE.j )
230 $ CALL cswap( n, c( 1, j ), 1, c( 1, i ), 1 )
231 END DO
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 = clanhe( '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 CHET01_AA
264*
clacgv
subroutine clacgv(n, x, incx)
CLACGV conjugates a complex vector.
Definition clacgv.f:74
ctrmm
subroutine ctrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
CTRMM
Definition ctrmm.f:177

◆ chet01_rook()

subroutine chet01_rook ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldafac, * ) afac,
integer ldafac,
integer, dimension( * ) ipiv,
complex, dimension( ldc, * ) c,
integer ldc,
real, dimension( * ) rwork,
real resid )

CHET01_ROOK

Purpose:
!>
!> CHET01_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 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 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 array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 chet01_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 REAL RESID
134* ..
135* .. Array Arguments ..
136 INTEGER IPIV( * )
137 REAL RWORK( * )
138 COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 REAL ZERO, ONE
145 parameter( zero = 0.0e+0, one = 1.0e+0 )
146 COMPLEX CZERO, CONE
147 parameter( czero = ( 0.0e+0, 0.0e+0 ),
148 $ cone = ( 1.0e+0, 0.0e+0 ) )
149* ..
150* .. Local Scalars ..
151 INTEGER I, INFO, J
152 REAL ANORM, EPS
153* ..
154* .. External Functions ..
155 LOGICAL LSAME
156 REAL CLANHE, SLAMCH
157 EXTERNAL lsame, clanhe, slamch
158* ..
159* .. External Subroutines ..
160 EXTERNAL claset, clavhe_rook
161* ..
162* .. Intrinsic Functions ..
163 INTRINSIC aimag, real
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 = slamch( 'Epsilon' )
177 anorm = clanhe( '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( aimag( 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 claset( 'Full', n, n, czero, cone, c, ldc )
192*
193* Call CLAVHE_ROOK to form the product D * U' (or D * L' ).
194*
195 CALL clavhe_rook( uplo, 'Conjugate', 'Non-unit', n, n, afac,
196 $ ldafac, ipiv, c, ldc, info )
197*
198* Call CLAVHE_ROOK again to multiply by U (or L ).
199*
200 CALL clavhe_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 ) - real( a( j, j ) )
211 30 CONTINUE
212 ELSE
213 DO 50 j = 1, n
214 c( j, j ) = c( j, j ) - real( 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 = clanhe( '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/real( n ) )/anorm ) / eps
230 END IF
231*
232 RETURN
233*
234* End of CHET01_ROOK
235*

◆ chkxer()

subroutine chkxer ( character*(*) srnamt,
integer infot,
integer nout,
logical lerr,
logical ok )

CHKXER

Purpose:
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 40 of file chkxer.f.

41*
42* -- LAPACK test routine --
43* -- LAPACK is a software package provided by Univ. of Tennessee, --
44* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
45*
46* .. Scalar Arguments ..
47 LOGICAL LERR, OK
48 CHARACTER*(*) SRNAMT
49 INTEGER INFOT, NOUT
50* ..
51* .. Intrinsic Functions ..
52 INTRINSIC len_trim
53* ..
54* .. Executable Statements ..
55 IF( .NOT.lerr ) THEN
56 WRITE( nout, fmt = 9999 )infot,
57 $ srnamt( 1:len_trim( srnamt ) )
58 ok = .false.
59 END IF
60 lerr = .false.
61 RETURN
62*
63 9999 FORMAT( ' *** Illegal value of parameter number ', i2,
64 $ ' not detected by ', a6, ' ***' )
65*
66* End of CHKXER
67*

◆ chpt01()

subroutine chpt01 ( character uplo,
integer n,
complex, dimension( * ) a,
complex, dimension( * ) afac,
integer, dimension( * ) ipiv,
complex, dimension( ldc, * ) c,
integer ldc,
real, dimension( * ) rwork,
real resid )

CHPT01

Purpose:
!>
!> CHPT01 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 array, dimension (N*(N+1)/2)
!>          The original Hermitian matrix A, stored as a packed
!>          triangular matrix.
!>
[in]AFAC
!>          AFAC is COMPLEX 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 CHPTRF.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from CHPTRF.
!>
[out]C
!>          C is COMPLEX array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 chpt01.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 REAL RESID
122* ..
123* .. Array Arguments ..
124 INTEGER IPIV( * )
125 REAL RWORK( * )
126 COMPLEX A( * ), AFAC( * ), C( LDC, * )
127* ..
128*
129* =====================================================================
130*
131* .. Parameters ..
132 REAL ZERO, ONE
133 parameter( zero = 0.0e+0, one = 1.0e+0 )
134 COMPLEX CZERO, CONE
135 parameter( czero = ( 0.0e+0, 0.0e+0 ),
136 $ cone = ( 1.0e+0, 0.0e+0 ) )
137* ..
138* .. Local Scalars ..
139 INTEGER I, INFO, J, JC
140 REAL ANORM, EPS
141* ..
142* .. External Functions ..
143 LOGICAL LSAME
144 REAL CLANHE, CLANHP, SLAMCH
145 EXTERNAL lsame, clanhe, clanhp, slamch
146* ..
147* .. External Subroutines ..
148 EXTERNAL clavhp, claset
149* ..
150* .. Intrinsic Functions ..
151 INTRINSIC aimag, real
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 = slamch( 'Epsilon' )
165 anorm = clanhp( '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( aimag( 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( aimag( 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 claset( 'Full', n, n, czero, cone, c, ldc )
192*
193* Call CLAVHP to form the product D * U' (or D * L' ).
194*
195 CALL clavhp( uplo, 'Conjugate', 'Non-unit', n, n, afac, ipiv, c,
196 $ ldc, info )
197*
198* Call CLAVHP again to multiply by U ( or L ).
199*
200 CALL clavhp( 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 ) - real( 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 ) - real( 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 = clanhe( '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 / real( n ) ) / anorm ) / eps
234 END IF
235*
236 RETURN
237*
238* End of CHPT01
239*
clavhp
subroutine clavhp(uplo, trans, diag, n, nrhs, a, ipiv, b, ldb, info)
CLAVHP
Definition clavhp.f:131
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ clahilb()

subroutine clahilb ( integer n,
integer nrhs,
complex, dimension(lda,n) a,
integer lda,
complex, dimension(ldx, nrhs) x,
integer ldx,
complex, dimension(ldb, nrhs) b,
integer ldb,
real, dimension(n) work,
integer info,
character*3 path )

CLAHILB

Purpose:
!>
!> CLAHILB 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 clahilb.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 REAL WORK(N)
143 COMPLEX 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 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 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 claset, lsamen
176 INTRINSIC real
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('CLAHILB', -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, take
221* 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) * (real(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) * (real(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 = real(m)
241 CALL claset('Full', n, nrhs, (0.0,0.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) =
258 $ invd1(mod(j,size_d)+1) *
259 $ ((work(i)*work(j)) / (i + j - 1))
260 $ * invd1(mod(i,size_d)+1)
261 END DO
262 END DO
263 ELSE
264 DO j = 1, nrhs
265 DO i = 1, n
266 x(i, j) =
267 $ invd2(mod(j,size_d)+1) *
268 $ ((work(i)*work(j)) / (i + j - 1))
269 $ * invd1(mod(i,size_d)+1)
270 END DO
271 END DO
272 END IF

◆ claipd()

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

CLAIPD

Purpose:
!>
!> CLAIPD 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 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 claipd.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 A( * )
93* ..
94*
95* =====================================================================
96*
97* .. Local Scalars ..
98 INTEGER I, IA, IXA
99 REAL BIGNUM
100* ..
101* .. External Functions ..
102 REAL SLAMCH
103 EXTERNAL slamch
104* ..
105* .. Intrinsic Functions ..
106 INTRINSIC cmplx, real
107* ..
108* .. Executable Statements ..
109*
110 bignum = slamch( 'Epsilon' ) / slamch( 'Safe minimum' )
111 ia = 1
112 ixa = inda
113 DO 10 i = 1, n
114 a( ia ) = cmplx( real( a( ia ) ), bignum )
115 ia = ia + ixa
116 ixa = ixa + vinda
117 10 CONTINUE
118 RETURN

◆ claptm()

subroutine claptm ( character uplo,
integer n,
integer nrhs,
real alpha,
real, dimension( * ) d,
complex, dimension( * ) e,
complex, dimension( ldx, * ) x,
integer ldx,
real beta,
complex, dimension( ldb, * ) b,
integer ldb )

CLAPTM

Purpose:
!>
!> CLAPTM 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 REAL
!>          The scalar alpha.  ALPHA must be 1. or -1.; otherwise,
!>          it is assumed to be 0.
!>
[in]D
!>          D is REAL array, dimension (N)
!>          The n diagonal elements of the tridiagonal matrix A.
!>
[in]E
!>          E is COMPLEX array, dimension (N-1)
!>          The (n-1) subdiagonal or superdiagonal elements of A.
!>
[in]X
!>          X is COMPLEX 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 REAL
!>          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,
!>          it is assumed to be 1.
!>
[in,out]B
!>          B is COMPLEX 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 claptm.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 REAL ALPHA, BETA
138* ..
139* .. Array Arguments ..
140 REAL D( * )
141 COMPLEX B( LDB, * ), E( * ), X( LDX, * )
142* ..
143*
144* =====================================================================
145*
146* .. Parameters ..
147 REAL ONE, ZERO
148 parameter( one = 1.0e+0, zero = 0.0e+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 conjg
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 ) + conjg( 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 ) + conjg( 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 $ conjg( 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 $ conjg( 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 ) - conjg( 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 ) - conjg( 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 $ conjg( 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 $ conjg( 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 CLAPTM
263*

◆ clarhs()

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

CLARHS

Purpose:
!>
!> CLARHS 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 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 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 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
!>          CLATMS).  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 clarhs.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 A( LDA, * ), B( LDB, * ), X( LDX, * )
221* ..
222*
223* =====================================================================
224*
225* .. Parameters ..
226 COMPLEX ONE, ZERO
227 parameter( one = ( 1.0e+0, 0.0e+0 ),
228 $ zero = ( 0.0e+0, 0.0e+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 cgbmv, cgemm, chbmv, chemm, chpmv, clacpy,
242 $ clarnv, csbmv, cspmv, csymm, ctbmv, ctpmv,
243 $ ctrmm, xerbla
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, 'Complex 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.
272 $ .NOT.( 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( 'CLARHS', -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 clarnv( 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 cgemm( 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 chemm( '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 csymm( '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 cgbmv( 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 chbmv( 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 csbmv( 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 chpmv( 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 cspmv( 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 clacpy( '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 ctrmm( '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 clacpy( '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 ctpmv( 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 clacpy( '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 ctbmv( 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( 'CLARHS', -info )
435 END IF
436*
437 RETURN
438*
439* End of CLARHS
440*
cspmv
subroutine cspmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
CSPMV computes a matrix-vector product for complex vectors using a complex symmetric packed matrix
Definition cspmv.f:151
ctpmv
subroutine ctpmv(uplo, trans, diag, n, ap, x, incx)
CTPMV
Definition ctpmv.f:142
ctbmv
subroutine ctbmv(uplo, trans, diag, n, k, a, lda, x, incx)
CTBMV
Definition ctbmv.f:186
chpmv
subroutine chpmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
CHPMV
Definition chpmv.f:149
chbmv
subroutine chbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
CHBMV
Definition chbmv.f:187
chemm
subroutine chemm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
CHEMM
Definition chemm.f:191
csymm
subroutine csymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
CSYMM
Definition csymm.f:189
csbmv
subroutine csbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
CSBMV
Definition csbmv.f:152

◆ clatb4()

subroutine clatb4 ( character*3 path,
integer imat,
integer m,
integer n,
character type,
integer kl,
integer ku,
real anorm,
integer mode,
real cndnum,
character dist )

CLATB4

Purpose:
!>
!> CLATB4 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 REAL
!>          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 REAL
!>          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 clatb4.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 REAL ANORM, CNDNUM
131* ..
132*
133* =====================================================================
134*
135* .. Parameters ..
136 REAL SHRINK, TENTH
137 parameter( shrink = 0.25e0, tenth = 0.1e+0 )
138 REAL ONE
139 parameter( one = 1.0e+0 )
140 REAL TWO
141 parameter( two = 2.0e+0 )
142* ..
143* .. Local Scalars ..
144 LOGICAL FIRST
145 CHARACTER*2 C2
146 INTEGER MAT
147 REAL BADC1, BADC2, EPS, LARGE, SMALL
148* ..
149* .. External Functions ..
150 LOGICAL LSAMEN
151 REAL SLAMCH
152 EXTERNAL lsamen, slamch
153* ..
154* .. Intrinsic Functions ..
155 INTRINSIC abs, max, sqrt
156* ..
157* .. External Subroutines ..
158 EXTERNAL slabad
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 = slamch( 'Precision' )
173 badc2 = tenth / eps
174 badc1 = sqrt( badc2 )
175 small = slamch( '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 slabad( 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 CLATB4
542*
slabad
subroutine slabad(small, large)
SLABAD
Definition slabad.f:74

◆ clatb5()

subroutine clatb5 ( character*3 path,
integer imat,
integer n,
character type,
integer kl,
integer ku,
real anorm,
integer mode,
real cndnum,
character dist )

CLATB5

Purpose:
!>
!> CLATB5 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 REAL
!>          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 REAL
!>          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 clatb5.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 REAL ANORM, CNDNUM
121 INTEGER IMAT, KL, KU, MODE, N
122 CHARACTER DIST, TYPE
123 CHARACTER*3 PATH
124* ..
125*
126* =====================================================================
127*
128* .. Parameters ..
129 REAL SHRINK, TENTH
130 parameter( shrink = 0.25e0, tenth = 0.1e+0 )
131 REAL ONE
132 parameter( one = 1.0e+0 )
133 REAL TWO
134 parameter( two = 2.0e+0 )
135* ..
136* .. Local Scalars ..
137 REAL BADC1, BADC2, EPS, LARGE, SMALL
138 LOGICAL FIRST
139 CHARACTER*2 C2
140* ..
141* .. External Functions ..
142 REAL SLAMCH
143 EXTERNAL slamch
144* ..
145* .. Intrinsic Functions ..
146 INTRINSIC max, sqrt
147* ..
148* .. External Subroutines ..
149 EXTERNAL slabad
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 = slamch( 'Precision' )
164 badc2 = tenth / eps
165 badc1 = sqrt( badc2 )
166 small = slamch( '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 slabad( 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.0e4
201 mode = 2
202 ELSE IF( imat.EQ.4 ) THEN
203 cndnum = 1.0e4
204 mode = 1
205 ELSE IF( imat.EQ.5 ) THEN
206 cndnum = 1.0e4
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 CLATB5
230*

◆ clatsp()

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

CLATSP

Purpose:
!>
!> CLATSP 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 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 clatsp.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 X( * )
96* ..
97*
98* =====================================================================
99*
100* .. Parameters ..
101 COMPLEX EYE
102 parameter( eye = ( 0.0, 1.0 ) )
103* ..
104* .. Local Scalars ..
105 INTEGER J, JJ, N5
106 REAL ALPHA, ALPHA3, BETA
107 COMPLEX A, B, C, R
108* ..
109* .. External Functions ..
110 COMPLEX CLARND
111 EXTERNAL clarnd
112* ..
113* .. Intrinsic Functions ..
114 INTRINSIC abs, sqrt
115* ..
116* .. Executable Statements ..
117*
118* Initialize constants
119*
120 alpha = ( 1.+sqrt( 17. ) ) / 8.
121 beta = alpha - 1. / 1000.
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.0
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*clarnd( 5, iseed )
139 b = clarnd( 5, iseed ) / alpha
140 c = a - 2.*b*eye
141 r = c / beta
142 x( jj ) = a
143 x( jj-2 ) = b
144 jj = jj - j
145 x( jj ) = clarnd( 2, iseed )
146 x( jj-1 ) = r
147 jj = jj - ( j-1 )
148 x( jj ) = c
149 jj = jj - ( j-2 )
150 x( jj ) = clarnd( 2, iseed )
151 jj = jj - ( j-3 )
152 x( jj ) = clarnd( 2, iseed )
153 IF( abs( x( jj+( j-3 ) ) ).GT.abs( x( jj ) ) ) THEN
154 x( jj+( j-4 ) ) = 2.0*x( jj+( j-3 ) )
155 ELSE
156 x( jj+( j-4 ) ) = 2.0*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*clarnd( 5, iseed )
166 b = clarnd( 5, iseed ) / alpha
167 c = a - 2.*b*eye
168 r = c / beta
169 x( jj ) = a
170 x( jj-2 ) = b
171 jj = jj - j
172 x( jj ) = clarnd( 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 ) = clarnd( 2, iseed )
181 x( jj-j ) = clarnd( 2, iseed )
182 IF( abs( x( jj ) ).GT.abs( x( jj-j ) ) ) THEN
183 x( jj-1 ) = 2.0*x( jj )
184 ELSE
185 x( jj-1 ) = 2.0*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 ) = clarnd( 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*clarnd( 5, iseed )
203 b = clarnd( 5, iseed ) / alpha
204 c = a - 2.*b*eye
205 r = c / beta
206 x( jj ) = a
207 x( jj+2 ) = b
208 jj = jj + ( n-j+1 )
209 x( jj ) = clarnd( 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 ) = clarnd( 2, iseed )
215 jj = jj + ( n-j-2 )
216 x( jj ) = clarnd( 2, iseed )
217 IF( abs( x( jj-( n-j-2 ) ) ).GT.abs( x( jj ) ) ) THEN
218 x( jj-( n-j-2 )+1 ) = 2.0*x( jj-( n-j-2 ) )
219 ELSE
220 x( jj-( n-j-2 )+1 ) = 2.0*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*clarnd( 5, iseed )
230 b = clarnd( 5, iseed ) / alpha
231 c = a - 2.*b*eye
232 r = c / beta
233 x( jj ) = a
234 x( jj+2 ) = b
235 jj = jj + ( n-j+1 )
236 x( jj ) = clarnd( 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 ) = clarnd( 2, iseed )
245 x( jj+( n-j+1 ) ) = clarnd( 2, iseed )
246 IF( abs( x( jj ) ).GT.abs( x( jj+( n-j+1 ) ) ) ) THEN
247 x( jj+1 ) = 2.0*x( jj )
248 ELSE
249 x( jj+1 ) = 2.0*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 ) = clarnd( 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 CLATSP
263*

◆ clatsy()

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

CLATSY

Purpose:
!>
!> CLATSY 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 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 clatsy.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 X( LDX, * )
101* ..
102*
103* =====================================================================
104*
105* .. Parameters ..
106 COMPLEX EYE
107 parameter( eye = ( 0.0, 1.0 ) )
108* ..
109* .. Local Scalars ..
110 INTEGER I, J, N5
111 REAL ALPHA, ALPHA3, BETA
112 COMPLEX A, B, C, R
113* ..
114* .. External Functions ..
115 COMPLEX CLARND
116 EXTERNAL clarnd
117* ..
118* .. Intrinsic Functions ..
119 INTRINSIC abs, sqrt
120* ..
121* .. Executable Statements ..
122*
123* Initialize constants
124*
125 alpha = ( 1.+sqrt( 17. ) ) / 8.
126 beta = alpha - 1. / 1000.
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.0
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*clarnd( 5, iseed )
145 b = clarnd( 5, iseed ) / alpha
146 c = a - 2.*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 ) = clarnd( 2, iseed )
153 x( i-3, i-3 ) = clarnd( 2, iseed )
154 x( i-4, i-4 ) = clarnd( 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.0*x( i-3, i-3 )
157 ELSE
158 x( i-4, i-3 ) = 2.0*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*clarnd( 5, iseed )
167 b = clarnd( 5, iseed ) / alpha
168 c = a - 2.*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 ) = clarnd( 2, iseed )
175 i = i - 3
176 END IF
177 IF( i.GT.1 ) THEN
178 x( i, i ) = clarnd( 2, iseed )
179 x( i-1, i-1 ) = clarnd( 2, iseed )
180 IF( abs( x( i, i ) ).GT.abs( x( i-1, i-1 ) ) ) THEN
181 x( i-1, i ) = 2.0*x( i, i )
182 ELSE
183 x( i-1, i ) = 2.0*x( i-1, i-1 )
184 END IF
185 i = i - 2
186 ELSE IF( i.EQ.1 ) THEN
187 x( i, i ) = clarnd( 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.0
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*clarnd( 5, iseed )
207 b = clarnd( 5, iseed ) / alpha
208 c = a - 2.*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 ) = clarnd( 2, iseed )
215 x( i+3, i+3 ) = clarnd( 2, iseed )
216 x( i+4, i+4 ) = clarnd( 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.0*x( i+3, i+3 )
219 ELSE
220 x( i+4, i+3 ) = 2.0*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*clarnd( 5, iseed )
229 b = clarnd( 5, iseed ) / alpha
230 c = a - 2.*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 ) = clarnd( 2, iseed )
237 i = i + 3
238 END IF
239 IF( i.LT.n ) THEN
240 x( i, i ) = clarnd( 2, iseed )
241 x( i+1, i+1 ) = clarnd( 2, iseed )
242 IF( abs( x( i, i ) ).GT.abs( x( i+1, i+1 ) ) ) THEN
243 x( i+1, i ) = 2.0*x( i, i )
244 ELSE
245 x( i+1, i ) = 2.0*x( i+1, i+1 )
246 END IF
247 i = i + 2
248 ELSE IF( i.EQ.n ) THEN
249 x( i, i ) = clarnd( 2, iseed )
250 i = i + 1
251 END IF
252 END IF
253*
254 RETURN
255*
256* End of CLATSY
257*

◆ clattb()

subroutine clattb ( integer imat,
character uplo,
character trans,
character diag,
integer, dimension( 4 ) iseed,
integer n,
integer kd,
complex, dimension( ldab, * ) ab,
integer ldab,
complex, dimension( * ) b,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer info )

CLATTB

Purpose:
!>
!> CLATTB 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
!>          CLATMS).  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 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 array, dimension (N)
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL 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 clattb.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 REAL RWORK( * )
153 COMPLEX AB( LDAB, * ), B( * ), WORK( * )
154* ..
155*
156* =====================================================================
157*
158* .. Parameters ..
159 REAL ONE, TWO, ZERO
160 parameter( one = 1.0e+0, two = 2.0e+0, zero = 0.0e+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 REAL ANORM, BIGNUM, BNORM, BSCAL, CNDNUM, REXP,
168 $ SFAC, SMLNUM, TEXP, TLEFT, TNORM, TSCAL, ULP,
169 $ UNFL
170 COMPLEX PLUS1, PLUS2, STAR1
171* ..
172* .. External Functions ..
173 LOGICAL LSAME
174 INTEGER ICAMAX
175 REAL SLAMCH, SLARND
176 COMPLEX CLARND
177 EXTERNAL lsame, icamax, slamch, slarnd, clarnd
178* ..
179* .. External Subroutines ..
180 EXTERNAL ccopy, clarnv, clatb4, clatms, csscal, cswap,
181 $ slabad, slarnv
182* ..
183* .. Intrinsic Functions ..
184 INTRINSIC abs, cmplx, max, min, real, sqrt
185* ..
186* .. Executable Statements ..
187*
188 path( 1: 1 ) = 'Complex precision'
189 path( 2: 3 ) = 'TB'
190 unfl = slamch( 'Safe minimum' )
191 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
192 smlnum = unfl
193 bignum = ( one-ulp ) / smlnum
194 CALL slabad( 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 CLATB4 to set parameters for CLATMS.
208*
209 upper = lsame( uplo, 'U' )
210 IF( upper ) THEN
211 CALL clatb4( 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 clatb4( 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 clatms( 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 ) = real( 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 ) = real( 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*clarnd( 5, iseed )
287 lenj = ( n-3 ) / 2
288 CALL clarnv( 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*clarnd( 5, iseed )
294 lenj = ( n-3 ) / 2
295 CALL clarnv( 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*clarnd( 5, iseed )
319 sfac = sqrt( tnorm )
320 plus1 = sfac*clarnd( 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 = slarnd( 2, iseed )
334 IF( rexp.LT.zero ) THEN
335 star1 = -sfac**( one-rexp )*clarnd( 5, iseed )
336 ELSE
337 star1 = sfac**( one+rexp )*clarnd( 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 ccopy( n-1, work, 1, ab( kd, 2 ), ldab )
346 CALL ccopy( n-2, work( n+1 ), 1, ab( kd-1, 3 ), ldab )
347 ELSE
348 CALL ccopy( n-1, work, 1, ab( 2, 1 ), ldab )
349 CALL ccopy( 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 clarnv( 4, iseed, lenj, ab( kd+1-lenj, j ) )
367 ab( kd+1, j ) = clarnd( 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 clarnv( 4, iseed, lenj, ab( 2, j ) )
374 ab( 1, j ) = clarnd( 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 clarnv( 2, iseed, n, b )
381 iy = icamax( n, b, 1 )
382 bnorm = abs( b( iy ) )
383 bscal = bignum / max( one, bnorm )
384 CALL csscal( 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 clarnv( 2, iseed, n, b )
393 tscal = one / real( 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 clarnv( 4, iseed, lenj, ab( kd+2-lenj, j ) )
399 CALL csscal( lenj, tscal, ab( kd+2-lenj, j ), 1 )
400 END IF
401 ab( kd+1, j ) = clarnd( 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 clarnv( 4, iseed, lenj, ab( 2, j ) )
409 CALL csscal( lenj, tscal, ab( 2, j ), 1 )
410 END IF
411 ab( 1, j ) = clarnd( 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 clarnv( 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 clarnv( 4, iseed, lenj, ab( kd+2-lenj, j ) )
428 ab( kd+1, j ) = clarnd( 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 clarnv( 4, iseed, lenj, ab( 2, j ) )
436 ab( 1, j ) = clarnd( 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*clarnd( 5, iseed )
455 ELSE
456 ab( kd+1, j ) = clarnd( 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*clarnd( 5, iseed )
470 ELSE
471 ab( 1, j ) = clarnd( 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*clarnd( 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*clarnd( 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 / real( kd+1 )
502 tscal = smlnum**texp
503 CALL clarnv( 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 ) = cmplx( -one, -one )
511 ab( kd+1, j ) = tscal*clarnd( 5, iseed )
512 250 CONTINUE
513 b( n ) = cmplx( 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 ) = cmplx( -one, -one )
521 ab( 1, j ) = tscal*clarnd( 5, iseed )
522 270 CONTINUE
523 b( 1 ) = cmplx( 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 clarnv( 4, iseed, lenj, ab( kd+2-lenj, j ) )
535 IF( j.NE.iy ) THEN
536 ab( kd+1, j ) = clarnd( 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 clarnv( 4, iseed, lenj, ab( 1, j ) )
545 IF( j.NE.iy ) THEN
546 ab( 1, j ) = clarnd( 5, iseed )*two
547 ELSE
548 ab( 1, j ) = zero
549 END IF
550 290 CONTINUE
551 END IF
552 CALL clarnv( 2, iseed, n, b )
553 CALL csscal( 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 / real( 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 / real( kd+2 ) )
579 $ / real( kd+3 )
580 ab( kd+1, i-1 ) = one
581 b( i-1 ) = texp*real( ( kd+1 )*( kd+1 )+kd )
582 END IF
583 texp = texp*two
584 320 CONTINUE
585 b( max( 1, j-kd+1 ) ) = ( real( kd+2 ) /
586 $ real( 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 / real( 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 $ real( kd+2 ) ) / real( kd+3 )
599 ab( 1, i+1 ) = one
600 b( i+1 ) = texp*real( ( kd+1 )*( kd+1 )+kd )
601 END IF
602 texp = texp*two
603 340 CONTINUE
604 b( min( n, j+kd-1 ) ) = ( real( kd+2 ) /
605 $ real( 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 clarnv( 4, iseed, lenj, ab( kd+1-lenj, j ) )
620 ab( kd+1, j ) = real( 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 clarnv( 4, iseed, lenj, ab( 2, j ) )
627 ab( 1, j ) = real( j )
628 370 CONTINUE
629 END IF
630*
631* Set the right hand side so that the largest value is BIGNUM.
632*
633 CALL clarnv( 2, iseed, n, b )
634 iy = icamax( n, b, 1 )
635 bnorm = abs( b( iy ) )
636 bscal = bignum / max( one, bnorm )
637 CALL csscal( 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: CLATBS no longer can handle this case
645*
646 tleft = bignum / real( kd+1 )
647 tscal = bignum*( real( kd+1 ) / real( kd+2 ) )
648 IF( upper ) THEN
649 DO 390 j = 1, n
650 lenj = min( j, kd+1 )
651 CALL clarnv( 5, iseed, lenj, ab( kd+2-lenj, j ) )
652 CALL slarnv( 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 clarnv( 5, iseed, lenj, ab( 1, j ) )
661 CALL slarnv( 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 clarnv( 2, iseed, n, b )
668 CALL csscal( 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 cswap( 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 cswap( 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 CLATTB
692*

◆ clattp()

subroutine clattp ( integer imat,
character uplo,
character trans,
character diag,
integer, dimension( 4 ) iseed,
integer n,
complex, dimension( * ) ap,
complex, dimension( * ) b,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer info )

CLATTP

Purpose:
!>
!> CLATTP 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
!>          CLATMS).  Modified on exit.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix to be generated.
!>
[out]AP
!>          AP is COMPLEX 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 array, dimension (N)
!>          The right hand side vector, if IMAT > 10.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL 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 clattp.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 REAL RWORK( * )
143 COMPLEX AP( * ), B( * ), WORK( * )
144* ..
145*
146* =====================================================================
147*
148* .. Parameters ..
149 REAL ONE, TWO, ZERO
150 parameter( one = 1.0e+0, two = 2.0e+0, zero = 0.0e+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 REAL ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, REXP,
159 $ SFAC, SMLNUM, T, TEXP, TLEFT, TSCAL, ULP, UNFL,
160 $ X, Y, Z
161 COMPLEX CTEMP, PLUS1, PLUS2, RA, RB, S, STAR1
162* ..
163* .. External Functions ..
164 LOGICAL LSAME
165 INTEGER ICAMAX
166 REAL SLAMCH
167 COMPLEX CLARND
168 EXTERNAL lsame, icamax, slamch, clarnd
169* ..
170* .. External Subroutines ..
171 EXTERNAL clarnv, clatb4, clatms, crot, crotg, csscal,
172 $ slabad, slarnv
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC abs, cmplx, conjg, max, real, sqrt
176* ..
177* .. Executable Statements ..
178*
179 path( 1: 1 ) = 'Complex precision'
180 path( 2: 3 ) = 'TP'
181 unfl = slamch( 'Safe minimum' )
182 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
183 smlnum = unfl
184 bignum = ( one-ulp ) / smlnum
185 CALL slabad( 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 CLATB4 to set parameters for CLATMS.
199*
200 upper = lsame( uplo, 'U' )
201 IF( upper ) THEN
202 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
203 $ CNDNUM, DIST )
204 packit = 'C'
205 ELSE
206 CALL clatb4( 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 clatms( 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.25*clarnd( 5, iseed )
329 sfac = 0.5
330 plus1 = sfac*clarnd( 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 = clarnd( 2, iseed )
340 IF( rexp.LT.zero ) THEN
341 star1 = -sfac**( one-rexp )*clarnd( 5, iseed )
342 ELSE
343 star1 = sfac**( one+rexp )*clarnd( 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 / real( 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 crotg( 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 ) = -conjg( 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 crot( 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 crotg( ra, rb, c, s )
434 s = conjg( s )
435*
436* Multiply by [ c -s; conjg(s) c] on the right.
437*
438 IF( n.GT.j+1 )
439 $ CALL crot( 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 ) = -conjg( 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 clarnv( 4, iseed, j-1, ap( jc ) )
476 ap( jc+j-1 ) = clarnd( 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 clarnv( 4, iseed, n-j, ap( jc+1 ) )
484 ap( jc ) = clarnd( 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 clarnv( 2, iseed, n, b )
492 iy = icamax( n, b, 1 )
493 bnorm = abs( b( iy ) )
494 bscal = bignum / max( one, bnorm )
495 CALL csscal( 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 clarnv( 2, iseed, n, b )
504 tscal = one / max( one, real( n-1 ) )
505 IF( upper ) THEN
506 jc = 1
507 DO 200 j = 1, n
508 CALL clarnv( 4, iseed, j-1, ap( jc ) )
509 CALL csscal( j-1, tscal, ap( jc ), 1 )
510 ap( jc+j-1 ) = clarnd( 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 clarnv( 2, iseed, n-j, ap( jc+1 ) )
518 CALL csscal( n-j, tscal, ap( jc+1 ), 1 )
519 ap( jc ) = clarnd( 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 clarnv( 2, iseed, n, b )
532 IF( upper ) THEN
533 jc = 1
534 DO 220 j = 1, n
535 CALL clarnv( 4, iseed, j-1, ap( jc ) )
536 ap( jc+j-1 ) = clarnd( 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 clarnv( 4, iseed, n-j, ap( jc+1 ) )
544 ap( jc ) = clarnd( 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*clarnd( 5, iseed )
565 ELSE
566 ap( jc+j-1 ) = clarnd( 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*clarnd( 5, iseed )
582 ELSE
583 ap( jc ) = clarnd( 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*clarnd( 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*clarnd( 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, real( n-1 ) )
615 tscal = smlnum**texp
616 CALL clarnv( 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 ) = cmplx( -one, -one )
625 ap( jc+j-1 ) = tscal*clarnd( 5, iseed )
626 jc = jc + j
627 310 CONTINUE
628 b( n ) = cmplx( 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 ) = cmplx( -one, -one )
637 ap( jc ) = tscal*clarnd( 5, iseed )
638 jc = jc + n - j + 1
639 330 CONTINUE
640 b( 1 ) = cmplx( 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 clarnv( 4, iseed, j, ap( jc ) )
652 IF( j.NE.iy ) THEN
653 ap( jc+j-1 ) = clarnd( 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 clarnv( 4, iseed, n-j+1, ap( jc ) )
663 IF( j.NE.iy ) THEN
664 ap( jc ) = clarnd( 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 clarnv( 2, iseed, n, b )
672 CALL csscal( 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 / real( n+1 )
691 ap( jc+j-1 ) = one
692 b( j ) = texp*( one-ulp )
693 jc = jc - j + 1
694 ap( jc ) = -( tscal / real( n+1 ) ) / real( n+2 )
695 ap( jc+j-2 ) = one
696 b( j-1 ) = texp*real( n*n+n-1 )
697 texp = texp*two
698 jc = jc - j + 2
699 370 CONTINUE
700 b( 1 ) = ( real( n+1 ) / real( n+2 ) )*tscal
701 ELSE
702 jc = 1
703 DO 380 j = 1, n - 1, 2
704 ap( jc+n-j ) = -tscal / real( 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 / real( n+1 ) ) / real( n+2 )
709 ap( jc ) = one
710 b( j+1 ) = texp*real( n*n+n-1 )
711 texp = texp*two
712 jc = jc + n - j
713 380 CONTINUE
714 b( n ) = ( real( n+1 ) / real( 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 clarnv( 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 clarnv( 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 clarnv( 2, iseed, n, b )
743 iy = icamax( n, b, 1 )
744 bnorm = abs( b( iy ) )
745 bscal = bignum / max( one, bnorm )
746 CALL csscal( 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: CLATPS no longer can handle this case
754*
755 tleft = bignum / max( one, real( n-1 ) )
756 tscal = bignum*( real( n-1 ) / max( one, real( n ) ) )
757 IF( upper ) THEN
758 jc = 1
759 DO 420 j = 1, n
760 CALL clarnv( 5, iseed, j, ap( jc ) )
761 CALL slarnv( 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 clarnv( 5, iseed, n-j+1, ap( jc ) )
771 CALL slarnv( 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 clarnv( 2, iseed, n, b )
780 CALL csscal( 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 CLATTP
821*
crot
subroutine crot(n, cx, incx, cy, incy, c, s)
CROT applies a plane rotation with real cosine and complex sine to a pair of complex vectors.
Definition crot.f:103
crotg
subroutine crotg(a, b, c, s)
CROTG
Definition crotg.f90:91

◆ clattr()

subroutine clattr ( integer imat,
character uplo,
character trans,
character diag,
integer, dimension( 4 ) iseed,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) b,
complex, dimension( * ) work,
real, dimension( * ) rwork,
integer info )

CLATTR

Purpose:
!>
!> CLATTR 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
!>          CLATMS).  Modified on exit.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix to be generated.
!>
[out]A
!>          A is COMPLEX 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 array, dimension (N)
!>          The right hand side vector, if IMAT > 10.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (2*N)
!>
[out]RWORK
!>          RWORK is REAL 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 clattr.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 REAL RWORK( * )
150 COMPLEX A( LDA, * ), B( * ), WORK( * )
151* ..
152*
153* =====================================================================
154*
155* .. Parameters ..
156 REAL ONE, TWO, ZERO
157 parameter( one = 1.0e+0, two = 2.0e+0, zero = 0.0e+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 REAL ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, REXP,
165 $ SFAC, SMLNUM, TEXP, TLEFT, TSCAL, ULP, UNFL, X,
166 $ Y, Z
167 COMPLEX PLUS1, PLUS2, RA, RB, S, STAR1
168* ..
169* .. External Functions ..
170 LOGICAL LSAME
171 INTEGER ICAMAX
172 REAL SLAMCH, SLARND
173 COMPLEX CLARND
174 EXTERNAL lsame, icamax, slamch, slarnd, clarnd
175* ..
176* .. External Subroutines ..
177 EXTERNAL ccopy, clarnv, clatb4, clatms, crot, crotg,
178 $ csscal, cswap, slabad, slarnv
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC abs, cmplx, conjg, max, real, sqrt
182* ..
183* .. Executable Statements ..
184*
185 path( 1: 1 ) = 'Complex precision'
186 path( 2: 3 ) = 'TR'
187 unfl = slamch( 'Safe minimum' )
188 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
189 smlnum = unfl
190 bignum = ( one-ulp ) / smlnum
191 CALL slabad( 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 CLATB4 to set parameters for CLATMS.
205*
206 upper = lsame( uplo, 'U' )
207 IF( upper ) THEN
208 CALL clatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
209 $ CNDNUM, DIST )
210 ELSE
211 CALL clatb4( 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 clatms( 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.25*clarnd( 5, iseed )
325 sfac = 0.5
326 plus1 = sfac*clarnd( 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 = slarnd( 2, iseed )
336 IF( rexp.LT.zero ) THEN
337 star1 = -sfac**( one-rexp )*clarnd( 5, iseed )
338 ELSE
339 star1 = sfac**( one+rexp )*clarnd( 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. / ( 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 ccopy( n-3, work, 1, a( 2, 3 ), lda+1 )
355 IF( n.GT.4 )
356 $ CALL ccopy( 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 ccopy( n-3, work, 1, a( 3, 2 ), lda+1 )
366 IF( n.GT.4 )
367 $ CALL ccopy( 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.0
382 CALL crotg( 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 crot( 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 crot( 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.0
403 CALL crotg( ra, rb, c, s )
404 s = conjg( s )
405*
406* Multiply by [ c -s; conjg(s) c] on the right.
407*
408 IF( n.GT.j+1 )
409 $ CALL crot( 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 crot( 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 clarnv( 4, iseed, j-1, a( 1, j ) )
437 a( j, j ) = clarnd( 5, iseed )*two
438 140 CONTINUE
439 ELSE
440 DO 150 j = 1, n
441 IF( j.LT.n )
442 $ CALL clarnv( 4, iseed, n-j, a( j+1, j ) )
443 a( j, j ) = clarnd( 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 clarnv( 2, iseed, n, b )
450 iy = icamax( n, b, 1 )
451 bnorm = abs( b( iy ) )
452 bscal = bignum / max( one, bnorm )
453 CALL csscal( 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 clarnv( 2, iseed, n, b )
462 tscal = one / max( one, real( n-1 ) )
463 IF( upper ) THEN
464 DO 160 j = 1, n
465 CALL clarnv( 4, iseed, j-1, a( 1, j ) )
466 CALL csscal( j-1, tscal, a( 1, j ), 1 )
467 a( j, j ) = clarnd( 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 clarnv( 4, iseed, n-j, a( j+1, j ) )
474 CALL csscal( n-j, tscal, a( j+1, j ), 1 )
475 END IF
476 a( j, j ) = clarnd( 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 clarnv( 2, iseed, n, b )
488 IF( upper ) THEN
489 DO 180 j = 1, n
490 CALL clarnv( 4, iseed, j-1, a( 1, j ) )
491 a( j, j ) = clarnd( 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 clarnv( 4, iseed, n-j, a( j+1, j ) )
498 a( j, j ) = clarnd( 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*clarnd( 5, iseed )
517 ELSE
518 a( j, j ) = clarnd( 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*clarnd( 5, iseed )
532 ELSE
533 a( j, j ) = clarnd( 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*clarnd( 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*clarnd( 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, real( n-1 ) )
564 tscal = smlnum**texp
565 CALL clarnv( 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.
570 260 CONTINUE
571 IF( j.GT.1 )
572 $ a( j-1, j ) = cmplx( -one, -one )
573 a( j, j ) = tscal*clarnd( 5, iseed )
574 270 CONTINUE
575 b( n ) = cmplx( one, one )
576 ELSE
577 DO 290 j = 1, n
578 DO 280 i = j + 2, n
579 a( i, j ) = 0.
580 280 CONTINUE
581 IF( j.LT.n )
582 $ a( j+1, j ) = cmplx( -one, -one )
583 a( j, j ) = tscal*clarnd( 5, iseed )
584 290 CONTINUE
585 b( 1 ) = cmplx( 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 clarnv( 4, iseed, j-1, a( 1, j ) )
596 IF( j.NE.iy ) THEN
597 a( j, j ) = clarnd( 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 clarnv( 4, iseed, n-j, a( j+1, j ) )
606 IF( j.NE.iy ) THEN
607 a( j, j ) = clarnd( 5, iseed )*two
608 ELSE
609 a( j, j ) = zero
610 END IF
611 310 CONTINUE
612 END IF
613 CALL clarnv( 2, iseed, n, b )
614 CALL csscal( 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.
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 / real( n+1 )
634 a( j, j ) = one
635 b( j ) = texp*( one-ulp )
636 a( 1, j-1 ) = -( tscal / real( n+1 ) ) / real( n+2 )
637 a( j-1, j-1 ) = one
638 b( j-1 ) = texp*real( n*n+n-1 )
639 texp = texp*2.
640 340 CONTINUE
641 b( 1 ) = ( real( n+1 ) / real( n+2 ) )*tscal
642 ELSE
643 DO 350 j = 1, n - 1, 2
644 a( n, j ) = -tscal / real( n+1 )
645 a( j, j ) = one
646 b( j ) = texp*( one-ulp )
647 a( n, j+1 ) = -( tscal / real( n+1 ) ) / real( n+2 )
648 a( j+1, j+1 ) = one
649 b( j+1 ) = texp*real( n*n+n-1 )
650 texp = texp*2.
651 350 CONTINUE
652 b( n ) = ( real( n+1 ) / real( 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 clarnv( 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 clarnv( 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 clarnv( 2, iseed, n, b )
677 iy = icamax( n, b, 1 )
678 bnorm = abs( b( iy ) )
679 bscal = bignum / max( one, bnorm )
680 CALL csscal( 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: CLATRS no longer can handle this case
688*
689 tleft = bignum / max( one, real( n-1 ) )
690 tscal = bignum*( real( n-1 ) / max( one, real( n ) ) )
691 IF( upper ) THEN
692 DO 390 j = 1, n
693 CALL clarnv( 5, iseed, j, a( 1, j ) )
694 CALL slarnv( 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 clarnv( 5, iseed, n-j+1, a( j, j ) )
702 CALL slarnv( 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 clarnv( 2, iseed, n, b )
709 CALL csscal( 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 cswap( 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 cswap( 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 CLATTR
731*

◆ clavhe()

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

CLAVHE

Purpose:
!>
!> CLAVHE 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 CHETRF.
!>
!> 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 array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by CHETRF_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 CHETRF.
!>
!>          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 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 clavhe.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 A( LDA, * ), B( LDB, * )
165* ..
166*
167* =====================================================================
168*
169* .. Parameters ..
170 COMPLEX ONE
171 parameter( one = ( 1.0e+0, 0.0e+0 ) )
172* ..
173* .. Local Scalars ..
174 LOGICAL NOUNIT
175 INTEGER J, K, KP
176 COMPLEX D11, D12, D21, D22, T1, T2
177* ..
178* .. External Functions ..
179 LOGICAL LSAME
180 EXTERNAL lsame
181* ..
182* .. External Subroutines ..
183 EXTERNAL cgemv, cgeru, clacgv, cscal, cswap, xerbla
184* ..
185* .. Intrinsic Functions ..
186 INTRINSIC abs, conjg, 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( 'CLAVHE ', -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 cscal( 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 cgeru( 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 cswap( 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 = conjg( 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 cgeru( k-1, nrhs, one, a( 1, k ), 1, b( k, 1 ),
288 $ ldb, b( 1, 1 ), ldb )
289 CALL cgeru( 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 cswap( 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 cscal( 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 cgeru( n-k, nrhs, one, 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 cswap( 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 = conjg( 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 cgeru( n-k, nrhs, one, a( k+1, k ), 1,
371 $ b( k, 1 ), ldb, b( k+1, 1 ), ldb )
372 CALL cgeru( 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 cswap( 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 IF( k.LT.1 )
404 $ GO TO 90
405*
406* 1 x 1 pivot block.
407*
408 IF( ipiv( k ).GT.0 ) THEN
409 IF( k.GT.1 ) THEN
410*
411* Interchange if P(K) != I.
412*
413 kp = ipiv( k )
414 IF( kp.NE.k )
415 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
416*
417* Apply the transformation
418* y = y - B' conjg(x),
419* where x is a column of A and y is a row of B.
420*
421 CALL clacgv( nrhs, b( k, 1 ), ldb )
422 CALL cgemv( 'Conjugate', k-1, nrhs, one, b, ldb,
423 $ a( 1, k ), 1, one, b( k, 1 ), ldb )
424 CALL clacgv( nrhs, b( k, 1 ), ldb )
425 END IF
426 IF( nounit )
427 $ CALL cscal( nrhs, a( k, k ), b( k, 1 ), ldb )
428 k = k - 1
429*
430* 2 x 2 pivot block.
431*
432 ELSE
433 IF( k.GT.2 ) THEN
434*
435* Interchange if P(K) != I.
436*
437 kp = abs( ipiv( k ) )
438 IF( kp.NE.k-1 )
439 $ CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
440 $ ldb )
441*
442* Apply the transformations
443* y = y - B' conjg(x),
444* where x is a block column of A and y is a block
445* row of B.
446*
447 CALL clacgv( nrhs, b( k, 1 ), ldb )
448 CALL cgemv( 'Conjugate', k-2, nrhs, one, b, ldb,
449 $ a( 1, k ), 1, one, b( k, 1 ), ldb )
450 CALL clacgv( nrhs, b( k, 1 ), ldb )
451*
452 CALL clacgv( nrhs, b( k-1, 1 ), ldb )
453 CALL cgemv( 'Conjugate', k-2, nrhs, one, b, ldb,
454 $ a( 1, k-1 ), 1, one, b( k-1, 1 ), ldb )
455 CALL clacgv( nrhs, b( k-1, 1 ), ldb )
456 END IF
457*
458* Multiply by the diagonal block if non-unit.
459*
460 IF( nounit ) THEN
461 d11 = a( k-1, k-1 )
462 d22 = a( k, k )
463 d12 = a( k-1, k )
464 d21 = conjg( d12 )
465 DO 80 j = 1, nrhs
466 t1 = b( k-1, j )
467 t2 = b( k, j )
468 b( k-1, j ) = d11*t1 + d12*t2
469 b( k, j ) = d21*t1 + d22*t2
470 80 CONTINUE
471 END IF
472 k = k - 2
473 END IF
474 GO TO 70
475 90 CONTINUE
476*
477* Form B := L^H*B
478* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
479* and L^H = inv(L^H(m))*P(m)* ... *inv(L^H(1))*P(1)
480*
481 ELSE
482*
483* Loop forward applying the L-transformations.
484*
485 k = 1
486 100 CONTINUE
487 IF( k.GT.n )
488 $ GO TO 120
489*
490* 1 x 1 pivot block
491*
492 IF( ipiv( k ).GT.0 ) THEN
493 IF( k.LT.n ) THEN
494*
495* Interchange if P(K) != I.
496*
497 kp = ipiv( k )
498 IF( kp.NE.k )
499 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
500*
501* Apply the transformation
502*
503 CALL clacgv( nrhs, b( k, 1 ), ldb )
504 CALL cgemv( 'Conjugate', n-k, nrhs, one, b( k+1, 1 ),
505 $ ldb, a( k+1, k ), 1, one, b( k, 1 ), ldb )
506 CALL clacgv( nrhs, b( k, 1 ), ldb )
507 END IF
508 IF( nounit )
509 $ CALL cscal( nrhs, a( k, k ), b( k, 1 ), ldb )
510 k = k + 1
511*
512* 2 x 2 pivot block.
513*
514 ELSE
515 IF( k.LT.n-1 ) THEN
516*
517* Interchange if P(K) != I.
518*
519 kp = abs( ipiv( k ) )
520 IF( kp.NE.k+1 )
521 $ CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
522 $ ldb )
523*
524* Apply the transformation
525*
526 CALL clacgv( nrhs, b( k+1, 1 ), ldb )
527 CALL cgemv( 'Conjugate', n-k-1, nrhs, one,
528 $ b( k+2, 1 ), ldb, a( k+2, k+1 ), 1, one,
529 $ b( k+1, 1 ), ldb )
530 CALL clacgv( nrhs, b( k+1, 1 ), ldb )
531*
532 CALL clacgv( nrhs, b( k, 1 ), ldb )
533 CALL cgemv( 'Conjugate', n-k-1, nrhs, one,
534 $ b( k+2, 1 ), ldb, a( k+2, k ), 1, one,
535 $ b( k, 1 ), ldb )
536 CALL clacgv( nrhs, b( k, 1 ), ldb )
537 END IF
538*
539* Multiply by the diagonal block if non-unit.
540*
541 IF( nounit ) THEN
542 d11 = a( k, k )
543 d22 = a( k+1, k+1 )
544 d21 = a( k+1, k )
545 d12 = conjg( d21 )
546 DO 110 j = 1, nrhs
547 t1 = b( k, j )
548 t2 = b( k+1, j )
549 b( k, j ) = d11*t1 + d12*t2
550 b( k+1, j ) = d21*t1 + d22*t2
551 110 CONTINUE
552 END IF
553 k = k + 2
554 END IF
555 GO TO 100
556 120 CONTINUE
557 END IF
558*
559 END IF
560 RETURN
561*
562* End of CLAVHE
563*
cgeru
subroutine cgeru(m, n, alpha, x, incx, y, incy, a, lda)
CGERU
Definition cgeru.f:130

◆ clavhe_rook()

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

CLAVHE_ROOK

Purpose:
!>
!> CLAVHE_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 CHETRF_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 array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by CHETRF_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 CHETRF_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 154 of file clavhe_rook.f.

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

◆ clavhp()

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

CLAVHP

Purpose:
!>
!>    CLAVHP  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 CHPTRF.
!>    CHPTRF 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', CLAVHP multiplies either by U or U * D
!>    (or L or L * D).
!>    If TRANS = 'C' or 'c', CLAVHP 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 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 CSPTRF or CHPTRF.
!>           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 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 clavhp.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 A( * ), B( LDB, * )
143* ..
144*
145* =====================================================================
146*
147* .. Parameters ..
148 COMPLEX ONE
149 parameter( one = ( 1.0e+0, 0.0e+0 ) )
150* ..
151* .. Local Scalars ..
152 LOGICAL NOUNIT
153 INTEGER J, K, KC, KCNEXT, KP
154 COMPLEX D11, D12, D21, D22, T1, T2
155* ..
156* .. External Functions ..
157 LOGICAL LSAME
158 EXTERNAL lsame
159* ..
160* .. External Subroutines ..
161 EXTERNAL cgemv, cgeru, clacgv, cscal, cswap, xerbla
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC abs, conjg, 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( 'CLAVHP ', -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 cscal( 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 cgeru( 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 cswap( 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 = conjg( 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 cgeru( k-1, nrhs, one, a( kc ), 1, b( k, 1 ),
269 $ ldb, b( 1, 1 ), ldb )
270 CALL cgeru( 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 cswap( 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 cscal( 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 cgeru( 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 cswap( 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 = conjg( 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 cgeru( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
357 $ ldb, b( k+1, 1 ), ldb )
358 CALL cgeru( 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 cswap( 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 IF( k.LT.1 )
392 $ GO TO 90
393 kc = kc - k
394*
395* 1 x 1 pivot block.
396*
397 IF( ipiv( k ).GT.0 ) THEN
398 IF( k.GT.1 ) THEN
399*
400* Interchange if P(K) != I.
401*
402 kp = ipiv( k )
403 IF( kp.NE.k )
404 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
405*
406* Apply the transformation:
407* y := y - B' * conjg(x)
408* where x is a column of A and y is a row of B.
409*
410 CALL clacgv( nrhs, b( k, 1 ), ldb )
411 CALL cgemv( 'Conjugate', k-1, nrhs, one, b, ldb,
412 $ a( kc ), 1, one, b( k, 1 ), ldb )
413 CALL clacgv( nrhs, b( k, 1 ), ldb )
414 END IF
415 IF( nounit )
416 $ CALL cscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
417 k = k - 1
418*
419* 2 x 2 pivot block.
420*
421 ELSE
422 kcnext = kc - ( k-1 )
423 IF( k.GT.2 ) THEN
424*
425* Interchange if P(K) != I.
426*
427 kp = abs( ipiv( k ) )
428 IF( kp.NE.k-1 )
429 $ CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
430 $ ldb )
431*
432* Apply the transformations.
433*
434 CALL clacgv( nrhs, b( k, 1 ), ldb )
435 CALL cgemv( 'Conjugate', k-2, nrhs, one, b, ldb,
436 $ a( kc ), 1, one, b( k, 1 ), ldb )
437 CALL clacgv( nrhs, b( k, 1 ), ldb )
438*
439 CALL clacgv( nrhs, b( k-1, 1 ), ldb )
440 CALL cgemv( 'Conjugate', k-2, nrhs, one, b, ldb,
441 $ a( kcnext ), 1, one, b( k-1, 1 ), ldb )
442 CALL clacgv( nrhs, b( k-1, 1 ), ldb )
443 END IF
444*
445* Multiply by the diagonal block if non-unit.
446*
447 IF( nounit ) THEN
448 d11 = a( kc-1 )
449 d22 = a( kc+k-1 )
450 d12 = a( kc+k-2 )
451 d21 = conjg( d12 )
452 DO 80 j = 1, nrhs
453 t1 = b( k-1, j )
454 t2 = b( k, j )
455 b( k-1, j ) = d11*t1 + d12*t2
456 b( k, j ) = d21*t1 + d22*t2
457 80 CONTINUE
458 END IF
459 kc = kcnext
460 k = k - 2
461 END IF
462 GO TO 70
463 90 CONTINUE
464*
465* Form B := L^H*B
466* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
467* and L^H = inv(L(m))*P(m)* ... *inv(L(1))*P(1)
468*
469 ELSE
470*
471* Loop forward applying the L-transformations.
472*
473 k = 1
474 kc = 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 cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
489*
490* Apply the transformation
491*
492 CALL clacgv( nrhs, b( k, 1 ), ldb )
493 CALL cgemv( 'Conjugate', n-k, nrhs, one, b( k+1, 1 ),
494 $ ldb, a( kc+1 ), 1, one, b( k, 1 ), ldb )
495 CALL clacgv( nrhs, b( k, 1 ), ldb )
496 END IF
497 IF( nounit )
498 $ CALL cscal( nrhs, a( kc ), b( k, 1 ), ldb )
499 kc = kc + n - k + 1
500 k = k + 1
501*
502* 2 x 2 pivot block.
503*
504 ELSE
505 kcnext = kc + n - k + 1
506 IF( k.LT.n-1 ) THEN
507*
508* Interchange if P(K) != I.
509*
510 kp = abs( ipiv( k ) )
511 IF( kp.NE.k+1 )
512 $ CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
513 $ ldb )
514*
515* Apply the transformation
516*
517 CALL clacgv( nrhs, b( k+1, 1 ), ldb )
518 CALL cgemv( 'Conjugate', n-k-1, nrhs, one,
519 $ b( k+2, 1 ), ldb, a( kcnext+1 ), 1, one,
520 $ b( k+1, 1 ), ldb )
521 CALL clacgv( nrhs, b( k+1, 1 ), ldb )
522*
523 CALL clacgv( nrhs, b( k, 1 ), ldb )
524 CALL cgemv( 'Conjugate', n-k-1, nrhs, one,
525 $ b( k+2, 1 ), ldb, a( kc+2 ), 1, one,
526 $ b( k, 1 ), ldb )
527 CALL clacgv( nrhs, b( k, 1 ), ldb )
528 END IF
529*
530* Multiply by the diagonal block if non-unit.
531*
532 IF( nounit ) THEN
533 d11 = a( kc )
534 d22 = a( kcnext )
535 d21 = a( kc+1 )
536 d12 = conjg( d21 )
537 DO 110 j = 1, nrhs
538 t1 = b( k, j )
539 t2 = b( k+1, j )
540 b( k, j ) = d11*t1 + d12*t2
541 b( k+1, j ) = d21*t1 + d22*t2
542 110 CONTINUE
543 END IF
544 kc = kcnext + ( n-k )
545 k = k + 2
546 END IF
547 GO TO 100
548 120 CONTINUE
549 END IF
550*
551 END IF
552 RETURN
553*
554* End of CLAVHP
555*

◆ clavsp()

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

CLAVSP

Purpose:
!>
!>    CLAVSP  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 CSPTRF.
!>    CSPTRF 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', CLAVSP multiplies either by U or U * D
!>    (or L or L * D).
!>    If TRANS = 'C' or 'c', CLAVSP 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 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 CSPTRF.
!>           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 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 clavsp.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 A( * ), B( LDB, * )
143* ..
144*
145* =====================================================================
146*
147* .. Parameters ..
148 COMPLEX ONE
149 parameter( one = ( 1.0e+0, 0.0e+0 ) )
150* ..
151* .. Local Scalars ..
152 LOGICAL NOUNIT
153 INTEGER J, K, KC, KCNEXT, KP
154 COMPLEX D11, D12, D21, D22, T1, T2
155* ..
156* .. External Functions ..
157 LOGICAL LSAME
158 EXTERNAL lsame
159* ..
160* .. External Subroutines ..
161 EXTERNAL cgemv, cgeru, cscal, cswap, xerbla
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( 'CLAVSP ', -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 cscal( 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 cgeru( 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 cswap( 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 cgeru( k-1, nrhs, one, a( kc ), 1, b( k, 1 ),
269 $ ldb, b( 1, 1 ), ldb )
270 CALL cgeru( 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 cswap( 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 cscal( 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 cgeru( 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 cswap( 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 cgeru( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
357 $ ldb, b( k+1, 1 ), ldb )
358 CALL cgeru( 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 cswap( 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 IF( k.LT.1 )
392 $ GO TO 90
393 kc = kc - k
394*
395* 1 x 1 pivot block.
396*
397 IF( ipiv( k ).GT.0 ) THEN
398 IF( k.GT.1 ) THEN
399*
400* Interchange if P(K) != I.
401*
402 kp = ipiv( k )
403 IF( kp.NE.k )
404 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
405*
406* Apply the transformation:
407* y := y - B' * conjg(x)
408* where x is a column of A and y is a row of B.
409*
410 CALL cgemv( 'Transpose', k-1, nrhs, one, b, ldb,
411 $ a( kc ), 1, one, b( k, 1 ), ldb )
412 END IF
413 IF( nounit )
414 $ CALL cscal( nrhs, a( kc+k-1 ), b( k, 1 ), ldb )
415 k = k - 1
416*
417* 2 x 2 pivot block.
418*
419 ELSE
420 kcnext = kc - ( k-1 )
421 IF( k.GT.2 ) THEN
422*
423* Interchange if P(K) != I.
424*
425 kp = abs( ipiv( k ) )
426 IF( kp.NE.k-1 )
427 $ CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
428 $ ldb )
429*
430* Apply the transformations.
431*
432 CALL cgemv( 'Transpose', k-2, nrhs, one, b, ldb,
433 $ a( kc ), 1, one, b( k, 1 ), ldb )
434*
435 CALL cgemv( 'Transpose', k-2, nrhs, one, b, ldb,
436 $ a( kcnext ), 1, one, b( k-1, 1 ), ldb )
437 END IF
438*
439* Multiply by the diagonal block if non-unit.
440*
441 IF( nounit ) THEN
442 d11 = a( kc-1 )
443 d22 = a( kc+k-1 )
444 d12 = a( kc+k-2 )
445 d21 = d12
446 DO 80 j = 1, nrhs
447 t1 = b( k-1, j )
448 t2 = b( k, j )
449 b( k-1, j ) = d11*t1 + d12*t2
450 b( k, j ) = d21*t1 + d22*t2
451 80 CONTINUE
452 END IF
453 kc = kcnext
454 k = k - 2
455 END IF
456 GO TO 70
457 90 CONTINUE
458*
459* Form B := L^T*B
460* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
461* and L^T = inv(L(m))*P(m)* ... *inv(L(1))*P(1)
462*
463 ELSE
464*
465* Loop forward applying the L-transformations.
466*
467 k = 1
468 kc = 1
469 100 CONTINUE
470 IF( k.GT.n )
471 $ GO TO 120
472*
473* 1 x 1 pivot block
474*
475 IF( ipiv( k ).GT.0 ) THEN
476 IF( k.LT.n ) THEN
477*
478* Interchange if P(K) != I.
479*
480 kp = ipiv( k )
481 IF( kp.NE.k )
482 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
483*
484* Apply the transformation
485*
486 CALL cgemv( 'Transpose', n-k, nrhs, one, b( k+1, 1 ),
487 $ ldb, a( kc+1 ), 1, one, b( k, 1 ), ldb )
488 END IF
489 IF( nounit )
490 $ CALL cscal( nrhs, a( kc ), b( k, 1 ), ldb )
491 kc = kc + n - k + 1
492 k = k + 1
493*
494* 2 x 2 pivot block.
495*
496 ELSE
497 kcnext = kc + n - k + 1
498 IF( k.LT.n-1 ) THEN
499*
500* Interchange if P(K) != I.
501*
502 kp = abs( ipiv( k ) )
503 IF( kp.NE.k+1 )
504 $ CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
505 $ ldb )
506*
507* Apply the transformation
508*
509 CALL cgemv( 'Transpose', n-k-1, nrhs, one,
510 $ b( k+2, 1 ), ldb, a( kcnext+1 ), 1, one,
511 $ b( k+1, 1 ), ldb )
512*
513 CALL cgemv( 'Transpose', n-k-1, nrhs, one,
514 $ b( k+2, 1 ), ldb, a( kc+2 ), 1, one,
515 $ b( k, 1 ), ldb )
516 END IF
517*
518* Multiply by the diagonal block if non-unit.
519*
520 IF( nounit ) THEN
521 d11 = a( kc )
522 d22 = a( kcnext )
523 d21 = a( kc+1 )
524 d12 = d21
525 DO 110 j = 1, nrhs
526 t1 = b( k, j )
527 t2 = b( k+1, j )
528 b( k, j ) = d11*t1 + d12*t2
529 b( k+1, j ) = d21*t1 + d22*t2
530 110 CONTINUE
531 END IF
532 kc = kcnext + ( n-k )
533 k = k + 2
534 END IF
535 GO TO 100
536 120 CONTINUE
537 END IF
538*
539 END IF
540 RETURN
541*
542* End of CLAVSP
543*

◆ clavsy()

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

CLAVSY

Purpose:
!>
!> CLAVSY 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 CSYTRF.
!>
!> 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 array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by CSYTRF.
!>          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 CSYTRF.
!>
!>          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 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 clavsy.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 A( LDA, * ), B( LDB, * )
165* ..
166*
167* =====================================================================
168*
169* .. Parameters ..
170 COMPLEX CONE
171 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
172* ..
173* .. Local Scalars ..
174 LOGICAL NOUNIT
175 INTEGER J, K, KP
176 COMPLEX D11, D12, D21, D22, T1, T2
177* ..
178* .. External Functions ..
179 LOGICAL LSAME
180 EXTERNAL lsame
181* ..
182* .. External Subroutines ..
183 EXTERNAL cgemv, cgeru, cscal, cswap, xerbla
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( 'CLAVSY ', -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 cscal( 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 cgeru( 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 cswap( 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 cgeru( k-1, nrhs, cone, a( 1, k ), 1, b( k, 1 ),
288 $ ldb, b( 1, 1 ), ldb )
289 CALL cgeru( 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 cswap( 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 cscal( 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 cgeru( 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 cswap( 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 cgeru( n-k, nrhs, cone, a( k+1, k ), 1,
371 $ b( k, 1 ), ldb, b( k+1, 1 ), ldb )
372 CALL cgeru( 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 cswap( 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 IF( k.LT.1 )
404 $ GO TO 90
405*
406* 1 x 1 pivot block.
407*
408 IF( ipiv( k ).GT.0 ) THEN
409 IF( k.GT.1 ) THEN
410*
411* Interchange if P(K) != I.
412*
413 kp = ipiv( k )
414 IF( kp.NE.k )
415 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
416*
417* Apply the transformation
418*
419 CALL cgemv( 'Transpose', k-1, nrhs, cone, b, ldb,
420 $ a( 1, k ), 1, cone, b( k, 1 ), ldb )
421 END IF
422 IF( nounit )
423 $ CALL cscal( nrhs, a( k, k ), b( k, 1 ), ldb )
424 k = k - 1
425*
426* 2 x 2 pivot block.
427*
428 ELSE
429 IF( k.GT.2 ) THEN
430*
431* Interchange if P(K) != I.
432*
433 kp = abs( ipiv( k ) )
434 IF( kp.NE.k-1 )
435 $ CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
436 $ ldb )
437*
438* Apply the transformations
439*
440 CALL cgemv( 'Transpose', k-2, nrhs, cone, b, ldb,
441 $ a( 1, k ), 1, cone, b( k, 1 ), ldb )
442 CALL cgemv( 'Transpose', k-2, nrhs, cone, b, ldb,
443 $ a( 1, k-1 ), 1, cone, 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( k-1, k-1 )
450 d22 = a( k, k )
451 d12 = a( k-1, k )
452 d21 = 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 k = k - 2
461 END IF
462 GO TO 70
463 90 CONTINUE
464*
465* Form B := L'*B
466* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
467* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1)
468*
469 ELSE
470*
471* Loop forward applying the L-transformations.
472*
473 k = 1
474 100 CONTINUE
475 IF( k.GT.n )
476 $ GO TO 120
477*
478* 1 x 1 pivot block
479*
480 IF( ipiv( k ).GT.0 ) THEN
481 IF( k.LT.n ) THEN
482*
483* Interchange if P(K) != I.
484*
485 kp = ipiv( k )
486 IF( kp.NE.k )
487 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
488*
489* Apply the transformation
490*
491 CALL cgemv( 'Transpose', n-k, nrhs, cone, b( k+1, 1 ),
492 $ ldb, a( k+1, k ), 1, cone, b( k, 1 ), ldb )
493 END IF
494 IF( nounit )
495 $ CALL cscal( nrhs, a( k, k ), b( k, 1 ), ldb )
496 k = k + 1
497*
498* 2 x 2 pivot block.
499*
500 ELSE
501 IF( k.LT.n-1 ) THEN
502*
503* Interchange if P(K) != I.
504*
505 kp = abs( ipiv( k ) )
506 IF( kp.NE.k+1 )
507 $ CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
508 $ ldb )
509*
510* Apply the transformation
511*
512 CALL cgemv( 'Transpose', n-k-1, nrhs, cone,
513 $ b( k+2, 1 ), ldb, a( k+2, k+1 ), 1, cone,
514 $ b( k+1, 1 ), ldb )
515 CALL cgemv( 'Transpose', n-k-1, nrhs, cone,
516 $ b( k+2, 1 ), ldb, a( k+2, k ), 1, cone,
517 $ b( k, 1 ), ldb )
518 END IF
519*
520* Multiply by the diagonal block if non-unit.
521*
522 IF( nounit ) THEN
523 d11 = a( k, k )
524 d22 = a( k+1, k+1 )
525 d21 = a( k+1, k )
526 d12 = d21
527 DO 110 j = 1, nrhs
528 t1 = b( k, j )
529 t2 = b( k+1, j )
530 b( k, j ) = d11*t1 + d12*t2
531 b( k+1, j ) = d21*t1 + d22*t2
532 110 CONTINUE
533 END IF
534 k = k + 2
535 END IF
536 GO TO 100
537 120 CONTINUE
538 END IF
539 END IF
540 RETURN
541*
542* End of CLAVSY
543*

◆ clavsy_rook()

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

CLAVSY_ROOK

Purpose:
!>
!> CLAVSY_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 CSYTRF_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 array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by CSYTRF_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 CSYTRF_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 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 clavsy_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 A( LDA, * ), B( LDB, * )
167* ..
168*
169* =====================================================================
170*
171* .. Parameters ..
172 COMPLEX CONE
173 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
174* ..
175* .. Local Scalars ..
176 LOGICAL NOUNIT
177 INTEGER J, K, KP
178 COMPLEX D11, D12, D21, D22, T1, T2
179* ..
180* .. External Functions ..
181 LOGICAL LSAME
182 EXTERNAL lsame
183* ..
184* .. External Subroutines ..
185 EXTERNAL cgemv, cgeru, cscal, cswap, xerbla
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( 'CLAVSY_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 cscal( 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 cgeru( 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 cswap( 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 cgeru( k-1, nrhs, cone, a( 1, k ), 1, b( k, 1 ),
290 $ ldb, b( 1, 1 ), ldb )
291 CALL cgeru( 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 cswap( 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 cswap( 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 cscal( 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 cgeru( 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 cswap( 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 cgeru( n-k, nrhs, cone, a( k+1, k ), 1,
383 $ b( k, 1 ), ldb, b( k+1, 1 ), ldb )
384 CALL cgeru( 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 cswap( 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 cswap( 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 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 cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
437*
438* Apply the transformation
439*
440 CALL cgemv( 'Transpose', k-1, nrhs, cone, b, ldb,
441 $ a( 1, k ), 1, cone, b( k, 1 ), ldb )
442 END IF
443 IF( nounit )
444 $ CALL cscal( nrhs, a( k, k ), b( k, 1 ), ldb )
445 k = k - 1
446*
447* 2 x 2 pivot block.
448*
449 ELSE
450 IF( k.GT.2 ) THEN
451*
452* Swap the second of pair with Pth
453*
454 kp = abs( ipiv( k ) )
455 IF( kp.NE.k )
456 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
457*
458* Now swap the first of pair with IMAX(r)th
459*
460 kp = abs( ipiv( k-1 ) )
461 IF( kp.NE.k-1 )
462 $ CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
463 $ ldb )
464*
465* Apply the transformations
466*
467 CALL cgemv( 'Transpose', k-2, nrhs, cone, b, ldb,
468 $ a( 1, k ), 1, cone, b( k, 1 ), ldb )
469 CALL cgemv( 'Transpose', k-2, nrhs, cone, b, ldb,
470 $ a( 1, k-1 ), 1, cone, b( k-1, 1 ), ldb )
471 END IF
472*
473* Multiply by the diagonal block if non-unit.
474*
475 IF( nounit ) THEN
476 d11 = a( k-1, k-1 )
477 d22 = a( k, k )
478 d12 = a( k-1, k )
479 d21 = d12
480 DO 80 j = 1, nrhs
481 t1 = b( k-1, j )
482 t2 = b( k, j )
483 b( k-1, j ) = d11*t1 + d12*t2
484 b( k, j ) = d21*t1 + d22*t2
485 80 CONTINUE
486 END IF
487 k = k - 2
488 END IF
489 GO TO 70
490 90 CONTINUE
491*
492* Form B := L'*B
493* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
494* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1)
495*
496 ELSE
497*
498* Loop forward applying the L-transformations.
499*
500 k = 1
501 100 CONTINUE
502 IF( k.GT.n )
503 $ GO TO 120
504*
505* 1 x 1 pivot block
506*
507 IF( ipiv( k ).GT.0 ) THEN
508 IF( k.LT.n ) THEN
509*
510* Interchange if P(K) != I.
511*
512 kp = ipiv( k )
513 IF( kp.NE.k )
514 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
515*
516* Apply the transformation
517*
518 CALL cgemv( 'Transpose', n-k, nrhs, cone, b( k+1, 1 ),
519 $ ldb, a( k+1, k ), 1, cone, b( k, 1 ), ldb )
520 END IF
521 IF( nounit )
522 $ CALL cscal( nrhs, a( k, k ), b( k, 1 ), ldb )
523 k = k + 1
524*
525* 2 x 2 pivot block.
526*
527 ELSE
528 IF( k.LT.n-1 ) THEN
529*
530* Swap the first of pair with Pth
531*
532 kp = abs( ipiv( k ) )
533 IF( kp.NE.k )
534 $ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
535*
536* Now swap the second of pair with IMAX(r)th
537*
538 kp = abs( ipiv( k+1 ) )
539 IF( kp.NE.k+1 )
540 $ CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
541 $ ldb )
542*
543* Apply the transformation
544*
545 CALL cgemv( 'Transpose', n-k-1, nrhs, cone,
546 $ b( k+2, 1 ), ldb, a( k+2, k+1 ), 1, cone,
547 $ b( k+1, 1 ), ldb )
548 CALL cgemv( 'Transpose', n-k-1, nrhs, cone,
549 $ b( k+2, 1 ), ldb, a( k+2, k ), 1, cone,
550 $ b( k, 1 ), ldb )
551 END IF
552*
553* Multiply by the diagonal block if non-unit.
554*
555 IF( nounit ) THEN
556 d11 = a( k, k )
557 d22 = a( k+1, k+1 )
558 d21 = a( k+1, k )
559 d12 = d21
560 DO 110 j = 1, nrhs
561 t1 = b( k, j )
562 t2 = b( k+1, j )
563 b( k, j ) = d11*t1 + d12*t2
564 b( k+1, j ) = d21*t1 + d22*t2
565 110 CONTINUE
566 END IF
567 k = k + 2
568 END IF
569 GO TO 100
570 120 CONTINUE
571 END IF
572 END IF
573 RETURN
574*
575* End of CLAVSY_ROOK
576*

◆ clqt01()

subroutine clqt01 ( integer m,
integer n,
complex, dimension( lda, * ) a,
complex, dimension( lda, * ) af,
complex, dimension( lda, * ) q,
complex, dimension( lda, * ) l,
integer lda,
complex, dimension( * ) tau,
complex, dimension( lwork ) work,
integer lwork,
real, dimension( * ) rwork,
real, dimension( * ) result )

CLQT01

Purpose:
!>
!> CLQT01 tests CGELQF, which computes the LQ factorization of an m-by-n
!> matrix A, and partially tests CUNGLQ which forms the n-by-n
!> orthogonal matrix Q.
!>
!> CLQT01 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 array, dimension (LDA,N)
!>          The m-by-n matrix A.
!>
[out]AF
!>          AF is COMPLEX array, dimension (LDA,N)
!>          Details of the LQ factorization of A, as returned by CGELQF.
!>          See CGELQF for further details.
!>
[out]Q
!>          Q is COMPLEX array, dimension (LDA,N)
!>          The n-by-n orthogonal matrix Q.
!>
[out]L
!>          L is COMPLEX 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 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by CGELQF.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (max(M,N))
!>
[out]RESULT
!>          RESULT is REAL 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 clqt01.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 REAL RESULT( * ), RWORK( * )
136 COMPLEX A( LDA, * ), AF( LDA, * ), L( LDA, * ),
137 $ Q( LDA, * ), TAU( * ), WORK( LWORK )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ZERO, ONE
144 parameter( zero = 0.0e+0, one = 1.0e+0 )
145 COMPLEX ROGUE
146 parameter( rogue = ( -1.0e+10, -1.0e+10 ) )
147* ..
148* .. Local Scalars ..
149 INTEGER INFO, MINMN
150 REAL ANORM, EPS, RESID
151* ..
152* .. External Functions ..
153 REAL CLANGE, CLANSY, SLAMCH
154 EXTERNAL clange, clansy, slamch
155* ..
156* .. External Subroutines ..
157 EXTERNAL cgelqf, cgemm, cherk, clacpy, claset, cunglq
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC cmplx, max, min, real
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 = slamch( 'Epsilon' )
172*
173* Copy the matrix A to the array AF.
174*
175 CALL clacpy( 'Full', m, n, a, lda, af, lda )
176*
177* Factorize the matrix A in the array AF.
178*
179 srnamt = 'CGELQF'
180 CALL cgelqf( m, n, af, lda, tau, work, lwork, info )
181*
182* Copy details of Q
183*
184 CALL claset( 'Full', n, n, rogue, rogue, q, lda )
185 IF( n.GT.1 )
186 $ CALL clacpy( 'Upper', m, n-1, af( 1, 2 ), lda, q( 1, 2 ), lda )
187*
188* Generate the n-by-n matrix Q
189*
190 srnamt = 'CUNGLQ'
191 CALL cunglq( n, n, minmn, q, lda, tau, work, lwork, info )
192*
193* Copy L
194*
195 CALL claset( 'Full', m, n, cmplx( zero ), cmplx( zero ), l, lda )
196 CALL clacpy( 'Lower', m, n, af, lda, l, lda )
197*
198* Compute L - A*Q'
199*
200 CALL cgemm( 'No transpose', 'Conjugate transpose', m, n, n,
201 $ cmplx( -one ), a, lda, q, lda, cmplx( one ), l, lda )
202*
203* Compute norm( L - Q'*A ) / ( N * norm(A) * EPS ) .
204*
205 anorm = clange( '1', m, n, a, lda, rwork )
206 resid = clange( '1', m, n, l, lda, rwork )
207 IF( anorm.GT.zero ) THEN
208 result( 1 ) = ( ( resid / real( max( 1, n ) ) ) / anorm ) / eps
209 ELSE
210 result( 1 ) = zero
211 END IF
212*
213* Compute I - Q*Q'
214*
215 CALL claset( 'Full', n, n, cmplx( zero ), cmplx( one ), l, lda )
216 CALL cherk( 'Upper', 'No transpose', n, n, -one, q, lda, one, l,
217 $ lda )
218*
219* Compute norm( I - Q*Q' ) / ( N * EPS ) .
220*
221 resid = clansy( '1', 'Upper', n, l, lda, rwork )
222*
223 result( 2 ) = ( resid / real( max( 1, n ) ) ) / eps
224*
225 RETURN
226*
227* End of CLQT01
228*

◆ clqt02()

subroutine clqt02 ( integer m,
integer n,
integer k,
complex, dimension( lda, * ) a,
complex, dimension( lda, * ) af,
complex, dimension( lda, * ) q,
complex, dimension( lda, * ) l,
integer lda,
complex, dimension( * ) tau,
complex, dimension( lwork ) work,
integer lwork,
real, dimension( * ) rwork,
real, dimension( * ) result )

CLQT02

Purpose:
!>
!> CLQT02 tests CUNGLQ, 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, CLQT02 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 array, dimension (LDA,N)
!>          The m-by-n matrix A which was factorized by CLQT01.
!>
[in]AF
!>          AF is COMPLEX array, dimension (LDA,N)
!>          Details of the LQ factorization of A, as returned by CGELQF.
!>          See CGELQF for further details.
!>
[out]Q
!>          Q is COMPLEX array, dimension (LDA,N)
!>
[out]L
!>          L is COMPLEX 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 array, dimension (M)
!>          The scalar factors of the elementary reflectors corresponding
!>          to the LQ factorization in AF.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (M)
!>
[out]RESULT
!>          RESULT is REAL 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 clqt02.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 REAL RESULT( * ), RWORK( * )
145 COMPLEX A( LDA, * ), AF( LDA, * ), L( LDA, * ),
146 $ Q( LDA, * ), TAU( * ), WORK( LWORK )
147* ..
148*
149* =====================================================================
150*
151* .. Parameters ..
152 REAL ZERO, ONE
153 parameter( zero = 0.0e+0, one = 1.0e+0 )
154 COMPLEX ROGUE
155 parameter( rogue = ( -1.0e+10, -1.0e+10 ) )
156* ..
157* .. Local Scalars ..
158 INTEGER INFO
159 REAL ANORM, EPS, RESID
160* ..
161* .. External Functions ..
162 REAL CLANGE, CLANSY, SLAMCH
163 EXTERNAL clange, clansy, slamch
164* ..
165* .. External Subroutines ..
166 EXTERNAL cgemm, cherk, clacpy, claset, cunglq
167* ..
168* .. Intrinsic Functions ..
169 INTRINSIC cmplx, max, real
170* ..
171* .. Scalars in Common ..
172 CHARACTER*32 SRNAMT
173* ..
174* .. Common blocks ..
175 COMMON / srnamc / srnamt
176* ..
177* .. Executable Statements ..
178*
179 eps = slamch( 'Epsilon' )
180*
181* Copy the first k rows of the factorization to the array Q
182*
183 CALL claset( 'Full', m, n, rogue, rogue, q, lda )
184 CALL clacpy( '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 = 'CUNGLQ'
189 CALL cunglq( m, n, k, q, lda, tau, work, lwork, info )
190*
191* Copy L(1:k,1:m)
192*
193 CALL claset( 'Full', k, m, cmplx( zero ), cmplx( zero ), l, lda )
194 CALL clacpy( 'Lower', k, m, af, lda, l, lda )
195*
196* Compute L(1:k,1:m) - A(1:k,1:n) * Q(1:m,1:n)'
197*
198 CALL cgemm( 'No transpose', 'Conjugate transpose', k, m, n,
199 $ cmplx( -one ), a, lda, q, lda, cmplx( one ), l, lda )
200*
201* Compute norm( L - A*Q' ) / ( N * norm(A) * EPS ) .
202*
203 anorm = clange( '1', k, n, a, lda, rwork )
204 resid = clange( '1', k, m, l, lda, rwork )
205 IF( anorm.GT.zero ) THEN
206 result( 1 ) = ( ( resid / real( max( 1, n ) ) ) / anorm ) / eps
207 ELSE
208 result( 1 ) = zero
209 END IF
210*
211* Compute I - Q*Q'
212*
213 CALL claset( 'Full', m, m, cmplx( zero ), cmplx( one ), l, lda )
214 CALL cherk( 'Upper', 'No transpose', m, n, -one, q, lda, one, l,
215 $ lda )
216*
217* Compute norm( I - Q*Q' ) / ( N * EPS ) .
218*
219 resid = clansy( '1', 'Upper', m, l, lda, rwork )
220*
221 result( 2 ) = ( resid / real( max( 1, n ) ) ) / eps
222*
223 RETURN
224*
225* End of CLQT02
226*

◆ clqt03()

subroutine clqt03 ( integer m,
integer n,
integer k,
complex, dimension( lda, * ) af,
complex, dimension( lda, * ) c,
complex, dimension( lda, * ) cc,
complex, dimension( lda, * ) q,
integer lda,
complex, dimension( * ) tau,
complex, dimension( lwork ) work,
integer lwork,
real, dimension( * ) rwork,
real, dimension( * ) result )

CLQT03

Purpose:
!>
!> CLQT03 tests CUNMLQ, which computes Q*C, Q'*C, C*Q or C*Q'.
!>
!> CLQT03 compares the results of a call to CUNMLQ with the results of
!> forming Q explicitly by a call to CUNGLQ and then performing matrix
!> multiplication by a call to CGEMM.
!>
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 array, dimension (LDA,N)
!>          Details of the LQ factorization of an m-by-n matrix, as
!>          returned by CGELQF. See CGELQF for further details.
!>
[out]C
!>          C is COMPLEX array, dimension (LDA,N)
!>
[out]CC
!>          CC is COMPLEX array, dimension (LDA,N)
!>
[out]Q
!>          Q is COMPLEX 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 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors corresponding
!>          to the LQ factorization in AF.
!>
[out]WORK
!>          WORK is COMPLEX 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 REAL array, dimension (M)
!>
[out]RESULT
!>          RESULT is REAL 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 clqt03.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 REAL RESULT( * ), RWORK( * )
146 COMPLEX AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
147 $ Q( LDA, * ), TAU( * ), WORK( LWORK )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 REAL ZERO, ONE
154 parameter( zero = 0.0e+0, one = 1.0e+0 )
155 COMPLEX ROGUE
156 parameter( rogue = ( -1.0e+10, -1.0e+10 ) )
157* ..
158* .. Local Scalars ..
159 CHARACTER SIDE, TRANS
160 INTEGER INFO, ISIDE, ITRANS, J, MC, NC
161 REAL CNORM, EPS, RESID
162* ..
163* .. External Functions ..
164 LOGICAL LSAME
165 REAL CLANGE, SLAMCH
166 EXTERNAL lsame, clange, slamch
167* ..
168* .. External Subroutines ..
169 EXTERNAL cgemm, clacpy, clarnv, claset, cunglq, cunmlq
170* ..
171* .. Local Arrays ..
172 INTEGER ISEED( 4 )
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC cmplx, max, real
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 = slamch( 'Epsilon' )
189*
190* Copy the first k rows of the factorization to the array Q
191*
192 CALL claset( 'Full', n, n, rogue, rogue, q, lda )
193 CALL clacpy( 'Upper', k, n-1, af( 1, 2 ), lda, q( 1, 2 ), lda )
194*
195* Generate the n-by-n matrix Q
196*
197 srnamt = 'CUNGLQ'
198 CALL cunglq( 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 clarnv( 2, iseed, mc, c( 1, j ) )
215 10 CONTINUE
216 cnorm = clange( '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 clacpy( 'Full', mc, nc, c, lda, cc, lda )
230*
231* Apply Q or Q' to C
232*
233 srnamt = 'CUNMLQ'
234 CALL cunmlq( 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 cgemm( trans, 'No transpose', mc, nc, mc,
241 $ cmplx( -one ), q, lda, c, lda, cmplx( one ),
242 $ cc, lda )
243 ELSE
244 CALL cgemm( 'No transpose', trans, mc, nc, nc,
245 $ cmplx( -one ), c, lda, q, lda, cmplx( one ),
246 $ cc, lda )
247 END IF
248*
249* Compute error in the difference
250*
251 resid = clange( '1', mc, nc, cc, lda, rwork )
252 result( ( iside-1 )*2+itrans ) = resid /
253 $ ( real( max( 1, n ) )*cnorm*eps )
254*
255 20 CONTINUE
256 30 CONTINUE
257*
258 RETURN
259*
260* End of CLQT03
261*

◆ cpbt01()

subroutine cpbt01 ( character uplo,
integer n,
integer kd,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldafac, * ) afac,
integer ldafac,
real, dimension( * ) rwork,
real resid )

CPBT01

Purpose:
!>
!> CPBT01 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 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 CPBTRF 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 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 CPBTRF.
!>
[in]LDAFAC
!>          LDAFAC is INTEGER
!>          The leading dimension of the array AFAC.
!>          LDAFAC >= max(1,KD+1).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 cpbt01.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 REAL RESID
129* ..
130* .. Array Arguments ..
131 REAL RWORK( * )
132 COMPLEX A( LDA, * ), AFAC( LDAFAC, * )
133* ..
134*
135* =====================================================================
136*
137*
138* .. Parameters ..
139 REAL ZERO, ONE
140 parameter( zero = 0.0e+0, one = 1.0e+0 )
141* ..
142* .. Local Scalars ..
143 INTEGER I, J, K, KC, KLEN, ML, MU
144 REAL AKK, ANORM, EPS
145* ..
146* .. External Functions ..
147 LOGICAL LSAME
148 REAL CLANHB, SLAMCH
149 COMPLEX CDOTC
150 EXTERNAL lsame, clanhb, slamch, cdotc
151* ..
152* .. External Subroutines ..
153 EXTERNAL cher, csscal, ctrmv
154* ..
155* .. Intrinsic Functions ..
156 INTRINSIC aimag, max, min, real
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 = slamch( 'Epsilon' )
170 anorm = clanhb( '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( aimag( 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( aimag( 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 = cdotc( 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 ctrmv( '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 cher( '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 csscal( 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 = clanhb( '1', uplo, n, kd, afac, ldafac, rwork )
258*
259 resid = ( ( resid / real( n ) ) / anorm ) / eps
260*
261 RETURN
262*
263* End of CPBT01
264*
cdotc
complex function cdotc(n, cx, incx, cy, incy)
CDOTC
Definition cdotc.f:83
cher
subroutine cher(uplo, n, alpha, x, incx, a, lda)
CHER
Definition cher.f:135

◆ cpbt02()

subroutine cpbt02 ( character uplo,
integer n,
integer kd,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldb, * ) b,
integer ldb,
real, dimension( * ) rwork,
real resid )

CPBT02

Purpose:
!>
!> CPBT02 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 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 CPBTRF 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 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 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 REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 cpbt02.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 REAL RESID
145* ..
146* .. Array Arguments ..
147 REAL RWORK( * )
148 COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * )
149* ..
150*
151* =====================================================================
152*
153* .. Parameters ..
154 REAL ZERO, ONE
155 parameter( zero = 0.0e+0, one = 1.0e+0 )
156 COMPLEX CONE
157 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
158* ..
159* .. Local Scalars ..
160 INTEGER J
161 REAL ANORM, BNORM, EPS, XNORM
162* ..
163* .. External Functions ..
164 REAL CLANHB, SCASUM, SLAMCH
165 EXTERNAL clanhb, scasum, slamch
166* ..
167* .. External Subroutines ..
168 EXTERNAL chbmv
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 = slamch( 'Epsilon' )
185 anorm = clanhb( '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 chbmv( 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 = scasum( n, b( 1, j ), 1 )
204 xnorm = scasum( 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 CPBT02
215*

◆ cpbt05()

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

CPBT05

Purpose:
!>
!> CPBT05 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 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 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 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 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 REAL 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 REAL 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 REAL 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 cpbt05.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 REAL BERR( * ), FERR( * ), RESLTS( * )
182 COMPLEX AB( LDAB, * ), B( LDB, * ), X( LDX, * ),
183 $ XACT( LDXACT, * )
184* ..
185*
186* =====================================================================
187*
188* .. Parameters ..
189 REAL ZERO, ONE
190 parameter( zero = 0.0e+0, one = 1.0e+0 )
191* ..
192* .. Local Scalars ..
193 LOGICAL UPPER
194 INTEGER I, IMAX, J, K, NZ
195 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
196 COMPLEX ZDUM
197* ..
198* .. External Functions ..
199 LOGICAL LSAME
200 INTEGER ICAMAX
201 REAL SLAMCH
202 EXTERNAL lsame, icamax, slamch
203* ..
204* .. Intrinsic Functions ..
205 INTRINSIC abs, aimag, max, min, real
206* ..
207* .. Statement Functions ..
208 REAL CABS1
209* ..
210* .. Statement Function definitions ..
211 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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 = slamch( 'Epsilon' )
224 unfl = slamch( '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 = icamax( 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( real( 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( real( 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 CPBT05
303*

◆ cpot01()

subroutine cpot01 ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldafac, * ) afac,
integer ldafac,
real, dimension( * ) rwork,
real resid )

CPOT01

Purpose:
!>
!> CPOT01 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 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 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 REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 cpot01.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 REAL RESID
115* ..
116* .. Array Arguments ..
117 REAL RWORK( * )
118 COMPLEX A( LDA, * ), AFAC( LDAFAC, * )
119* ..
120*
121* =====================================================================
122*
123* .. Parameters ..
124 REAL ZERO, ONE
125 parameter( zero = 0.0e+0, one = 1.0e+0 )
126* ..
127* .. Local Scalars ..
128 INTEGER I, J, K
129 REAL ANORM, EPS, TR
130 COMPLEX TC
131* ..
132* .. External Functions ..
133 LOGICAL LSAME
134 REAL CLANHE, SLAMCH
135 COMPLEX CDOTC
136 EXTERNAL lsame, clanhe, slamch, cdotc
137* ..
138* .. External Subroutines ..
139 EXTERNAL cher, cscal, ctrmv
140* ..
141* .. Intrinsic Functions ..
142 INTRINSIC aimag, real
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 = slamch( 'Epsilon' )
156 anorm = clanhe( '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( aimag( 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 = cdotc( 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 ctrmv( '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 cher( '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 cscal( 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 ) - real( a( j, j ) )
217 50 CONTINUE
218 ELSE
219 DO 70 j = 1, n
220 afac( j, j ) = afac( j, j ) - real( 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 = clanhe( '1', uplo, n, afac, ldafac, rwork )
230*
231 resid = ( ( resid / real( n ) ) / anorm ) / eps
232*
233 RETURN
234*
235* End of CPOT01
236*

◆ cpot02()

subroutine cpot02 ( character uplo,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldb, * ) b,
integer ldb,
real, dimension( * ) rwork,
real resid )

CPOT02

Purpose:
!>
!> CPOT02 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 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 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 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 REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 cpot02.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 REAL RESID
136* ..
137* .. Array Arguments ..
138 REAL RWORK( * )
139 COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * )
140* ..
141*
142* =====================================================================
143*
144* .. Parameters ..
145 REAL ZERO, ONE
146 parameter( zero = 0.0e+0, one = 1.0e+0 )
147 COMPLEX CONE
148 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
149* ..
150* .. Local Scalars ..
151 INTEGER J
152 REAL ANORM, BNORM, EPS, XNORM
153* ..
154* .. External Functions ..
155 REAL CLANHE, SCASUM, SLAMCH
156 EXTERNAL clanhe, scasum, slamch
157* ..
158* .. External Subroutines ..
159 EXTERNAL chemm
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 = slamch( 'Epsilon' )
176 anorm = clanhe( '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 chemm( '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 = scasum( n, b( 1, j ), 1 )
193 xnorm = scasum( 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 CPOT02
204*

◆ cpot03()

subroutine cpot03 ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldainv, * ) ainv,
integer ldainv,
complex, dimension( ldwork, * ) work,
integer ldwork,
real, dimension( * ) rwork,
real rcond,
real resid )

CPOT03

Purpose:
!>
!> CPOT03 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 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 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 array, dimension (LDWORK,N)
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.  LDWORK >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RCOND
!>          RCOND is REAL
!>          The reciprocal of the condition number of A, computed as
!>          ( 1/norm(A) ) / norm(AINV).
!>
[out]RESID
!>          RESID is REAL
!>          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 cpot03.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 REAL RCOND, RESID
135* ..
136* .. Array Arguments ..
137 REAL RWORK( * )
138 COMPLEX A( LDA, * ), AINV( LDAINV, * ),
139 $ WORK( LDWORK, * )
140* ..
141*
142* =====================================================================
143*
144* .. Parameters ..
145 REAL ZERO, ONE
146 parameter( zero = 0.0e+0, one = 1.0e+0 )
147 COMPLEX CZERO, CONE
148 parameter( czero = ( 0.0e+0, 0.0e+0 ),
149 $ cone = ( 1.0e+0, 0.0e+0 ) )
150* ..
151* .. Local Scalars ..
152 INTEGER I, J
153 REAL AINVNM, ANORM, EPS
154* ..
155* .. External Functions ..
156 LOGICAL LSAME
157 REAL CLANGE, CLANHE, SLAMCH
158 EXTERNAL lsame, clange, clanhe, slamch
159* ..
160* .. External Subroutines ..
161 EXTERNAL chemm
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC conjg, real
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 = slamch( 'Epsilon' )
179 anorm = clanhe( '1', uplo, n, a, lda, rwork )
180 ainvnm = clanhe( '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 CHEMM 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 ) = conjg( 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 ) = conjg( ainv( i, j ) )
201 30 CONTINUE
202 40 CONTINUE
203 END IF
204 CALL chemm( '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 = clange( '1', n, n, work, ldwork, rwork )
216*
217 resid = ( ( resid*rcond )/eps ) / real( n )
218*
219 RETURN
220*
221* End of CPOT03
222*

◆ cpot05()

subroutine cpot05 ( character uplo,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldxact, * ) xact,
integer ldxact,
real, dimension( * ) ferr,
real, dimension( * ) berr,
real, dimension( * ) reslts )

CPOT05

Purpose:
!>
!> CPOT05 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 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 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 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 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 REAL 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 REAL 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 REAL 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 cpot05.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 REAL BERR( * ), FERR( * ), RESLTS( * )
176 COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * ),
177 $ XACT( LDXACT, * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 REAL ZERO, ONE
184 parameter( zero = 0.0e+0, one = 1.0e+0 )
185* ..
186* .. Local Scalars ..
187 LOGICAL UPPER
188 INTEGER I, IMAX, J, K
189 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
190 COMPLEX ZDUM
191* ..
192* .. External Functions ..
193 LOGICAL LSAME
194 INTEGER ICAMAX
195 REAL SLAMCH
196 EXTERNAL lsame, icamax, slamch
197* ..
198* .. Intrinsic Functions ..
199 INTRINSIC abs, aimag, max, min, real
200* ..
201* .. Statement Functions ..
202 REAL CABS1
203* ..
204* .. Statement Function definitions ..
205 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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 = slamch( 'Epsilon' )
218 unfl = slamch( '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 = icamax( 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( real( 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( real( 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 CPOT05
294*

◆ cppt01()

subroutine cppt01 ( character uplo,
integer n,
complex, dimension( * ) a,
complex, dimension( * ) afac,
real, dimension( * ) rwork,
real resid )

CPPT01

Purpose:
!>
!> CPPT01 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 array, dimension (N*(N+1)/2)
!>          The original Hermitian matrix A, stored as a packed
!>          triangular matrix.
!>
[in,out]AFAC
!>          AFAC is COMPLEX 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 REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 cppt01.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 REAL RESID
104* ..
105* .. Array Arguments ..
106 REAL RWORK( * )
107 COMPLEX A( * ), AFAC( * )
108* ..
109*
110* =====================================================================
111*
112* .. Parameters ..
113 REAL ZERO, ONE
114 parameter( zero = 0.0e+0, one = 1.0e+0 )
115* ..
116* .. Local Scalars ..
117 INTEGER I, K, KC
118 REAL ANORM, EPS, TR
119 COMPLEX TC
120* ..
121* .. External Functions ..
122 LOGICAL LSAME
123 REAL CLANHP, SLAMCH
124 COMPLEX CDOTC
125 EXTERNAL lsame, clanhp, slamch, cdotc
126* ..
127* .. External Subroutines ..
128 EXTERNAL chpr, cscal, ctpmv
129* ..
130* .. Intrinsic Functions ..
131 INTRINSIC aimag, real
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 = slamch( 'Epsilon' )
145 anorm = clanhp( '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( aimag( 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( aimag( 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 = cdotc( 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 ctpmv( '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 ) - real( 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 chpr( '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 cscal( 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 ) - real( 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 = clanhp( '1', uplo, n, afac, rwork )
240*
241 resid = ( ( resid / real( n ) ) / anorm ) / eps
242*
243 RETURN
244*
245* End of CPPT01
246*
chpr
subroutine chpr(uplo, n, alpha, x, incx, ap)
CHPR
Definition chpr.f:130

◆ cppt02()

subroutine cppt02 ( character uplo,
integer n,
integer nrhs,
complex, dimension( * ) a,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldb, * ) b,
integer ldb,
real, dimension( * ) rwork,
real resid )

CPPT02

Purpose:
!>
!> CPPT02 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 array, dimension (N*(N+1)/2)
!>          The original Hermitian matrix A, stored as a packed
!>          triangular matrix.
!>
[in]X
!>          X is COMPLEX 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 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 REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 cppt02.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 REAL RESID
132* ..
133* .. Array Arguments ..
134 REAL RWORK( * )
135 COMPLEX A( * ), B( LDB, * ), X( LDX, * )
136* ..
137*
138* =====================================================================
139*
140* .. Parameters ..
141 REAL ZERO, ONE
142 parameter( zero = 0.0e+0, one = 1.0e+0 )
143 COMPLEX CONE
144 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
145* ..
146* .. Local Scalars ..
147 INTEGER J
148 REAL ANORM, BNORM, EPS, XNORM
149* ..
150* .. External Functions ..
151 REAL CLANHP, SCASUM, SLAMCH
152 EXTERNAL clanhp, scasum, slamch
153* ..
154* .. External Subroutines ..
155 EXTERNAL chpmv
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 = slamch( 'Epsilon' )
172 anorm = clanhp( '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 chpmv( 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 = scasum( n, b( 1, j ), 1 )
191 xnorm = scasum( 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 CPPT02
202*

◆ cppt03()

subroutine cppt03 ( character uplo,
integer n,
complex, dimension( * ) a,
complex, dimension( * ) ainv,
complex, dimension( ldwork, * ) work,
integer ldwork,
real, dimension( * ) rwork,
real rcond,
real resid )

CPPT03

Purpose:
!>
!> CPPT03 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 array, dimension (N*(N+1)/2)
!>          The original Hermitian matrix A, stored as a packed
!>          triangular matrix.
!>
[in]AINV
!>          AINV is COMPLEX array, dimension (N*(N+1)/2)
!>          The (Hermitian) inverse of the matrix A, stored as a packed
!>          triangular matrix.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LDWORK,N)
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.  LDWORK >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RCOND
!>          RCOND is REAL
!>          The reciprocal of the condition number of A, computed as
!>          ( 1/norm(A) ) / norm(AINV).
!>
[out]RESID
!>          RESID is REAL
!>          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 cppt03.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 REAL RCOND, RESID
119* ..
120* .. Array Arguments ..
121 REAL RWORK( * )
122 COMPLEX A( * ), AINV( * ), WORK( LDWORK, * )
123* ..
124*
125* =====================================================================
126*
127* .. Parameters ..
128 REAL ZERO, ONE
129 parameter( zero = 0.0e+0, one = 1.0e+0 )
130 COMPLEX CZERO, CONE
131 parameter( czero = ( 0.0e+0, 0.0e+0 ),
132 $ cone = ( 1.0e+0, 0.0e+0 ) )
133* ..
134* .. Local Scalars ..
135 INTEGER I, J, JJ
136 REAL AINVNM, ANORM, EPS
137* ..
138* .. External Functions ..
139 LOGICAL LSAME
140 REAL CLANGE, CLANHP, SLAMCH
141 EXTERNAL lsame, clange, clanhp, slamch
142* ..
143* .. Intrinsic Functions ..
144 INTRINSIC conjg, real
145* ..
146* .. External Subroutines ..
147 EXTERNAL ccopy, chpmv
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 = slamch( 'Epsilon' )
162 anorm = clanhp( '1', uplo, n, a, rwork )
163 ainvnm = clanhp( '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 ccopy( j, ainv( jj ), 1, work( 1, j+1 ), 1 )
183 DO 10 i = 1, j - 1
184 work( j, i+1 ) = conjg( 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 ) = conjg( ainv( jj+i-1 ) )
191 30 CONTINUE
192*
193* Multiply by A
194*
195 DO 40 j = 1, n - 1
196 CALL chpmv( 'Upper', n, -cone, a, work( 1, j+1 ), 1, czero,
197 $ work( 1, j ), 1 )
198 40 CONTINUE
199 CALL chpmv( '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 ) = conjg( ainv( i+1 ) )
212 50 CONTINUE
213 jj = n + 1
214 DO 70 j = 2, n
215 CALL ccopy( n-j+1, ainv( jj ), 1, work( j, j-1 ), 1 )
216 DO 60 i = 1, n - j
217 work( j, j+i-1 ) = conjg( 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 chpmv( 'Lower', n, -cone, a, work( 1, j-1 ), 1, czero,
226 $ work( 1, j ), 1 )
227 80 CONTINUE
228 CALL chpmv( '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 = clange( '1', n, n, work, ldwork, rwork )
242*
243 resid = ( ( resid*rcond )/eps ) / real( n )
244*
245 RETURN
246*
247* End of CPPT03
248*

◆ cppt05()

subroutine cppt05 ( character uplo,
integer n,
integer nrhs,
complex, dimension( * ) ap,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldxact, * ) xact,
integer ldxact,
real, dimension( * ) ferr,
real, dimension( * ) berr,
real, dimension( * ) reslts )

CPPT05

Purpose:
!>
!> CPPT05 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 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 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 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 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 REAL 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 REAL 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 REAL 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 cppt05.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 REAL BERR( * ), FERR( * ), RESLTS( * )
168 COMPLEX AP( * ), B( LDB, * ), X( LDX, * ),
169 $ XACT( LDXACT, * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 REAL ZERO, ONE
176 parameter( zero = 0.0e+0, one = 1.0e+0 )
177* ..
178* .. Local Scalars ..
179 LOGICAL UPPER
180 INTEGER I, IMAX, J, JC, K
181 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
182 COMPLEX ZDUM
183* ..
184* .. External Functions ..
185 LOGICAL LSAME
186 INTEGER ICAMAX
187 REAL SLAMCH
188 EXTERNAL lsame, icamax, slamch
189* ..
190* .. Intrinsic Functions ..
191 INTRINSIC abs, aimag, max, min, real
192* ..
193* .. Statement Functions ..
194 REAL CABS1
195* ..
196* .. Statement Function definitions ..
197 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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 = slamch( 'Epsilon' )
210 unfl = slamch( '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 = icamax( 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( real( 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( real( 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 CPPT05
291*

◆ cpst01()

subroutine cpst01 ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldafac, * ) afac,
integer ldafac,
complex, dimension( ldperm, * ) perm,
integer ldperm,
integer, dimension( * ) piv,
real, dimension( * ) rwork,
real resid,
integer rank )

CPST01

Purpose:
!>
!> CPST01 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 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 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 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 REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 cpst01.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 REAL RESID
143 INTEGER LDA, LDAFAC, LDPERM, N, RANK
144 CHARACTER UPLO
145* ..
146* .. Array Arguments ..
147 COMPLEX A( LDA, * ), AFAC( LDAFAC, * ),
148 $ PERM( LDPERM, * )
149 REAL RWORK( * )
150 INTEGER PIV( * )
151* ..
152*
153* =====================================================================
154*
155* .. Parameters ..
156 REAL ZERO, ONE
157 parameter( zero = 0.0e+0, one = 1.0e+0 )
158 COMPLEX CZERO
159 parameter( czero = ( 0.0e+0, 0.0e+0 ) )
160* ..
161* .. Local Scalars ..
162 COMPLEX TC
163 REAL ANORM, EPS, TR
164 INTEGER I, J, K
165* ..
166* .. External Functions ..
167 COMPLEX CDOTC
168 REAL CLANHE, SLAMCH
169 LOGICAL LSAME
170 EXTERNAL cdotc, clanhe, slamch, lsame
171* ..
172* .. External Subroutines ..
173 EXTERNAL cher, cscal, ctrmv
174* ..
175* .. Intrinsic Functions ..
176 INTRINSIC aimag, conjg, real
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 = slamch( 'Epsilon' )
190 anorm = clanhe( '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( aimag( 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 = cdotc( 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 ctrmv( '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 cher( '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 cscal( 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 ) ) = conjg( 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 ) ) = conjg( 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 ) - real( a( j, j ) )
301 220 CONTINUE
302 ELSE
303 DO 240 j = 1, n
304 perm( j, j ) = perm( j, j ) - real( 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 = clanhe( '1', uplo, n, perm, ldafac, rwork )
315*
316 resid = ( ( resid / real( n ) ) / anorm ) / eps
317*
318 RETURN
319*
320* End of CPST01
321*

◆ cptt01()

subroutine cptt01 ( integer n,
real, dimension( * ) d,
complex, dimension( * ) e,
real, dimension( * ) df,
complex, dimension( * ) ef,
complex, dimension( * ) work,
real resid )

CPTT01

Purpose:
!>
!> CPTT01 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 REAL array, dimension (N)
!>          The n diagonal elements of the tridiagonal matrix A.
!>
[in]E
!>          E is COMPLEX array, dimension (N-1)
!>          The (n-1) subdiagonal elements of the tridiagonal matrix A.
!>
[in]DF
!>          DF is REAL array, dimension (N)
!>          The n diagonal elements of the factor L from the L*D*L'
!>          factorization of A.
!>
[in]EF
!>          EF is COMPLEX 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 array, dimension (2*N)
!>
[out]RESID
!>          RESID is REAL
!>          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 cptt01.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 REAL RESID
100* ..
101* .. Array Arguments ..
102 REAL D( * ), DF( * )
103 COMPLEX E( * ), EF( * ), WORK( * )
104* ..
105*
106* =====================================================================
107*
108* .. Parameters ..
109 REAL ONE, ZERO
110 parameter( one = 1.0e+0, zero = 0.0e+0 )
111* ..
112* .. Local Scalars ..
113 INTEGER I
114 REAL ANORM, EPS
115 COMPLEX DE
116* ..
117* .. External Functions ..
118 REAL SLAMCH
119 EXTERNAL slamch
120* ..
121* .. Intrinsic Functions ..
122 INTRINSIC abs, conjg, max, real
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 = slamch( '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*conjg( 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 / real( n ) ) / anorm ) / eps
167 END IF
168*
169 RETURN
170*
171* End of CPTT01
172*

◆ cptt02()

subroutine cptt02 ( character uplo,
integer n,
integer nrhs,
real, dimension( * ) d,
complex, dimension( * ) e,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldb, * ) b,
integer ldb,
real resid )

CPTT02

Purpose:
!>
!> CPTT02 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 REAL array, dimension (N)
!>          The n diagonal elements of the tridiagonal matrix A.
!>
[in]E
!>          E is COMPLEX array, dimension (N-1)
!>          The (n-1) subdiagonal elements of the tridiagonal matrix A.
!>
[in]X
!>          X is COMPLEX 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 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 REAL
!>          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 cptt02.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 REAL RESID
124* ..
125* .. Array Arguments ..
126 REAL D( * )
127 COMPLEX B( LDB, * ), E( * ), X( LDX, * )
128* ..
129*
130* =====================================================================
131*
132* .. Parameters ..
133 REAL ONE, ZERO
134 parameter( one = 1.0e+0, zero = 0.0e+0 )
135* ..
136* .. Local Scalars ..
137 INTEGER J
138 REAL ANORM, BNORM, EPS, XNORM
139* ..
140* .. External Functions ..
141 REAL CLANHT, SCASUM, SLAMCH
142 EXTERNAL clanht, scasum, slamch
143* ..
144* .. Intrinsic Functions ..
145 INTRINSIC max
146* ..
147* .. External Subroutines ..
148 EXTERNAL claptm
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 = clanht( '1', n, d, e )
162*
163* Exit with RESID = 1/EPS if ANORM = 0.
164*
165 eps = slamch( '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 claptm( 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 = scasum( n, b( 1, j ), 1 )
181 xnorm = scasum( 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 CPTT02
192*

◆ cptt05()

subroutine cptt05 ( integer n,
integer nrhs,
real, dimension( * ) d,
complex, dimension( * ) e,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldxact, * ) xact,
integer ldxact,
real, dimension( * ) ferr,
real, dimension( * ) berr,
real, dimension( * ) reslts )

CPTT05

Purpose:
!>
!> CPTT05 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 REAL array, dimension (N)
!>          The n diagonal elements of the tridiagonal matrix A.
!>
[in]E
!>          E is COMPLEX array, dimension (N-1)
!>          The (n-1) subdiagonal elements of the tridiagonal matrix A.
!>
[in]B
!>          B is COMPLEX 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 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 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 REAL 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 REAL 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 REAL 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 cptt05.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 REAL BERR( * ), D( * ), FERR( * ), RESLTS( * )
160 COMPLEX B( LDB, * ), E( * ), X( LDX, * ),
161 $ XACT( LDXACT, * )
162* ..
163*
164* =====================================================================
165*
166* .. Parameters ..
167 REAL ZERO, ONE
168 parameter( zero = 0.0e+0, one = 1.0e+0 )
169* ..
170* .. Local Scalars ..
171 INTEGER I, IMAX, J, K, NZ
172 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
173 COMPLEX ZDUM
174* ..
175* .. External Functions ..
176 INTEGER ICAMAX
177 REAL SLAMCH
178 EXTERNAL icamax, slamch
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC abs, aimag, max, min, real
182* ..
183* .. Statement Functions ..
184 REAL CABS1
185* ..
186* .. Statement Function definitions ..
187 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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 = slamch( 'Epsilon' )
200 unfl = slamch( '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 = icamax( 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 CPTT05
265*

◆ cqlt01()

subroutine cqlt01 ( integer m,
integer n,
complex, dimension( lda, * ) a,
complex, dimension( lda, * ) af,
complex, dimension( lda, * ) q,
complex, dimension( lda, * ) l,
integer lda,
complex, dimension( * ) tau,
complex, dimension( lwork ) work,
integer lwork,
real, dimension( * ) rwork,
real, dimension( * ) result )

CQLT01

Purpose:
!>
!> CQLT01 tests CGEQLF, which computes the QL factorization of an m-by-n
!> matrix A, and partially tests CUNGQL which forms the m-by-m
!> orthogonal matrix Q.
!>
!> CQLT01 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 array, dimension (LDA,N)
!>          The m-by-n matrix A.
!>
[out]AF
!>          AF is COMPLEX array, dimension (LDA,N)
!>          Details of the QL factorization of A, as returned by CGEQLF.
!>          See CGEQLF for further details.
!>
[out]Q
!>          Q is COMPLEX array, dimension (LDA,M)
!>          The m-by-m orthogonal matrix Q.
!>
[out]L
!>          L is COMPLEX 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 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by CGEQLF.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (M)
!>
[out]RESULT
!>          RESULT is REAL 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 cqlt01.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 REAL RESULT( * ), RWORK( * )
136 COMPLEX A( LDA, * ), AF( LDA, * ), L( LDA, * ),
137 $ Q( LDA, * ), TAU( * ), WORK( LWORK )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ZERO, ONE
144 parameter( zero = 0.0e+0, one = 1.0e+0 )
145 COMPLEX ROGUE
146 parameter( rogue = ( -1.0e+10, -1.0e+10 ) )
147* ..
148* .. Local Scalars ..
149 INTEGER INFO, MINMN
150 REAL ANORM, EPS, RESID
151* ..
152* .. External Functions ..
153 REAL CLANGE, CLANSY, SLAMCH
154 EXTERNAL clange, clansy, slamch
155* ..
156* .. External Subroutines ..
157 EXTERNAL cgemm, cgeqlf, cherk, clacpy, claset, cungql
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC cmplx, max, min, real
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 = slamch( 'Epsilon' )
172*
173* Copy the matrix A to the array AF.
174*
175 CALL clacpy( 'Full', m, n, a, lda, af, lda )
176*
177* Factorize the matrix A in the array AF.
178*
179 srnamt = 'CGEQLF'
180 CALL cgeqlf( m, n, af, lda, tau, work, lwork, info )
181*
182* Copy details of Q
183*
184 CALL claset( 'Full', m, m, rogue, rogue, q, lda )
185 IF( m.GE.n ) THEN
186 IF( n.LT.m .AND. n.GT.0 )
187 $ CALL clacpy( 'Full', m-n, n, af, lda, q( 1, m-n+1 ), lda )
188 IF( n.GT.1 )
189 $ CALL clacpy( '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 clacpy( '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 = 'CUNGQL'
200 CALL cungql( m, m, minmn, q, lda, tau, work, lwork, info )
201*
202* Copy L
203*
204 CALL claset( 'Full', m, n, cmplx( zero ), cmplx( zero ), l, lda )
205 IF( m.GE.n ) THEN
206 IF( n.GT.0 )
207 $ CALL clacpy( 'Lower', n, n, af( m-n+1, 1 ), lda,
208 $ l( m-n+1, 1 ), lda )
209 ELSE
210 IF( n.GT.m .AND. m.GT.0 )
211 $ CALL clacpy( 'Full', m, n-m, af, lda, l, lda )
212 IF( m.GT.0 )
213 $ CALL clacpy( 'Lower', m, m, af( 1, n-m+1 ), lda,
214 $ l( 1, n-m+1 ), lda )
215 END IF
216*
217* Compute L - Q'*A
218*
219 CALL cgemm( 'Conjugate transpose', 'No transpose', m, n, m,
220 $ cmplx( -one ), q, lda, a, lda, cmplx( one ), l, lda )
221*
222* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) .
223*
224 anorm = clange( '1', m, n, a, lda, rwork )
225 resid = clange( '1', m, n, l, lda, rwork )
226 IF( anorm.GT.zero ) THEN
227 result( 1 ) = ( ( resid / real( max( 1, m ) ) ) / anorm ) / eps
228 ELSE
229 result( 1 ) = zero
230 END IF
231*
232* Compute I - Q'*Q
233*
234 CALL claset( 'Full', m, m, cmplx( zero ), cmplx( one ), l, lda )
235 CALL cherk( 'Upper', 'Conjugate transpose', m, m, -one, q, lda,
236 $ one, l, lda )
237*
238* Compute norm( I - Q'*Q ) / ( M * EPS ) .
239*
240 resid = clansy( '1', 'Upper', m, l, lda, rwork )
241*
242 result( 2 ) = ( resid / real( max( 1, m ) ) ) / eps
243*
244 RETURN
245*
246* End of CQLT01
247*

◆ cqlt02()

subroutine cqlt02 ( integer m,
integer n,
integer k,
complex, dimension( lda, * ) a,
complex, dimension( lda, * ) af,
complex, dimension( lda, * ) q,
complex, dimension( lda, * ) l,
integer lda,
complex, dimension( * ) tau,
complex, dimension( lwork ) work,
integer lwork,
real, dimension( * ) rwork,
real, dimension( * ) result )

CQLT02

Purpose:
!>
!> CQLT02 tests CUNGQL, 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, CQLT02 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 array, dimension (LDA,N)
!>          The m-by-n matrix A which was factorized by CQLT01.
!>
[in]AF
!>          AF is COMPLEX array, dimension (LDA,N)
!>          Details of the QL factorization of A, as returned by CGEQLF.
!>          See CGEQLF for further details.
!>
[out]Q
!>          Q is COMPLEX array, dimension (LDA,N)
!>
[out]L
!>          L is COMPLEX 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 array, dimension (N)
!>          The scalar factors of the elementary reflectors corresponding
!>          to the QL factorization in AF.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (M)
!>
[out]RESULT
!>          RESULT is REAL 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 cqlt02.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 REAL RESULT( * ), RWORK( * )
146 COMPLEX A( LDA, * ), AF( LDA, * ), L( LDA, * ),
147 $ Q( LDA, * ), TAU( * ), WORK( LWORK )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 REAL ZERO, ONE
154 parameter( zero = 0.0e+0, one = 1.0e+0 )
155 COMPLEX ROGUE
156 parameter( rogue = ( -1.0e+10, -1.0e+10 ) )
157* ..
158* .. Local Scalars ..
159 INTEGER INFO
160 REAL ANORM, EPS, RESID
161* ..
162* .. External Functions ..
163 REAL CLANGE, CLANSY, SLAMCH
164 EXTERNAL clange, clansy, slamch
165* ..
166* .. External Subroutines ..
167 EXTERNAL cgemm, cherk, clacpy, claset, cungql
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC cmplx, max, real
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 = slamch( 'Epsilon' )
189*
190* Copy the last k columns of the factorization to the array Q
191*
192 CALL claset( 'Full', m, n, rogue, rogue, q, lda )
193 IF( k.LT.m )
194 $ CALL clacpy( 'Full', m-k, k, af( 1, n-k+1 ), lda,
195 $ q( 1, n-k+1 ), lda )
196 IF( k.GT.1 )
197 $ CALL clacpy( '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 = 'CUNGQL'
203 CALL cungql( 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 claset( 'Full', n, k, cmplx( zero ), cmplx( zero ),
208 $ l( m-n+1, n-k+1 ), lda )
209 CALL clacpy( '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 cgemm( 'Conjugate transpose', 'No transpose', n, k, m,
215 $ cmplx( -one ), q, lda, a( 1, n-k+1 ), lda,
216 $ cmplx( one ), l( m-n+1, n-k+1 ), lda )
217*
218* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) .
219*
220 anorm = clange( '1', m, k, a( 1, n-k+1 ), lda, rwork )
221 resid = clange( '1', n, k, l( m-n+1, n-k+1 ), lda, rwork )
222 IF( anorm.GT.zero ) THEN
223 result( 1 ) = ( ( resid / real( max( 1, m ) ) ) / anorm ) / eps
224 ELSE
225 result( 1 ) = zero
226 END IF
227*
228* Compute I - Q'*Q
229*
230 CALL claset( 'Full', n, n, cmplx( zero ), cmplx( one ), l, lda )
231 CALL cherk( 'Upper', 'Conjugate transpose', n, m, -one, q, lda,
232 $ one, l, lda )
233*
234* Compute norm( I - Q'*Q ) / ( M * EPS ) .
235*
236 resid = clansy( '1', 'Upper', n, l, lda, rwork )
237*
238 result( 2 ) = ( resid / real( max( 1, m ) ) ) / eps
239*
240 RETURN
241*
242* End of CQLT02
243*

◆ cqlt03()

subroutine cqlt03 ( integer m,
integer n,
integer k,
complex, dimension( lda, * ) af,
complex, dimension( lda, * ) c,
complex, dimension( lda, * ) cc,
complex, dimension( lda, * ) q,
integer lda,
complex, dimension( * ) tau,
complex, dimension( lwork ) work,
integer lwork,
real, dimension( * ) rwork,
real, dimension( * ) result )

CQLT03

Purpose:
!>
!> CQLT03 tests CUNMQL, which computes Q*C, Q'*C, C*Q or C*Q'.
!>
!> CQLT03 compares the results of a call to CUNMQL with the results of
!> forming Q explicitly by a call to CUNGQL and then performing matrix
!> multiplication by a call to CGEMM.
!>
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 array, dimension (LDA,N)
!>          Details of the QL factorization of an m-by-n matrix, as
!>          returned by CGEQLF. See CGEQLF for further details.
!>
[out]C
!>          C is COMPLEX array, dimension (LDA,N)
!>
[out]CC
!>          CC is COMPLEX array, dimension (LDA,N)
!>
[out]Q
!>          Q is COMPLEX 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 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors corresponding
!>          to the QL factorization in AF.
!>
[out]WORK
!>          WORK is COMPLEX 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 REAL array, dimension (M)
!>
[out]RESULT
!>          RESULT is REAL 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 cqlt03.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 REAL RESULT( * ), RWORK( * )
146 COMPLEX AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
147 $ Q( LDA, * ), TAU( * ), WORK( LWORK )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 REAL ZERO, ONE
154 parameter( zero = 0.0e+0, one = 1.0e+0 )
155 COMPLEX ROGUE
156 parameter( rogue = ( -1.0e+10, -1.0e+10 ) )
157* ..
158* .. Local Scalars ..
159 CHARACTER SIDE, TRANS
160 INTEGER INFO, ISIDE, ITRANS, J, MC, MINMN, NC
161 REAL CNORM, EPS, RESID
162* ..
163* .. External Functions ..
164 LOGICAL LSAME
165 REAL CLANGE, SLAMCH
166 EXTERNAL lsame, clange, slamch
167* ..
168* .. External Subroutines ..
169 EXTERNAL cgemm, clacpy, clarnv, claset, cungql, cunmql
170* ..
171* .. Local Arrays ..
172 INTEGER ISEED( 4 )
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC cmplx, max, min, real
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 = slamch( '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 ENDIF
200*
201* Copy the last k columns of the factorization to the array Q
202*
203 CALL claset( 'Full', m, m, rogue, rogue, q, lda )
204 IF( k.GT.0 .AND. m.GT.k )
205 $ CALL clacpy( 'Full', m-k, k, af( 1, n-k+1 ), lda,
206 $ q( 1, m-k+1 ), lda )
207 IF( k.GT.1 )
208 $ CALL clacpy( '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 = 'CUNGQL'
214 CALL cungql( 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 clarnv( 2, iseed, mc, c( 1, j ) )
232 10 CONTINUE
233 cnorm = clange( '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 clacpy( 'Full', mc, nc, c, lda, cc, lda )
247*
248* Apply Q or Q' to C
249*
250 srnamt = 'CUNMQL'
251 IF( k.GT.0 )
252 $ CALL cunmql( side, trans, mc, nc, k, af( 1, n-k+1 ),
253 $ lda, tau( minmn-k+1 ), cc, lda, work,
254 $ lwork, info )
255*
256* Form explicit product and subtract
257*
258 IF( lsame( side, 'L' ) ) THEN
259 CALL cgemm( trans, 'No transpose', mc, nc, mc,
260 $ cmplx( -one ), q, lda, c, lda, cmplx( one ),
261 $ cc, lda )
262 ELSE
263 CALL cgemm( 'No transpose', trans, mc, nc, nc,
264 $ cmplx( -one ), c, lda, q, lda, cmplx( one ),
265 $ cc, lda )
266 END IF
267*
268* Compute error in the difference
269*
270 resid = clange( '1', mc, nc, cc, lda, rwork )
271 result( ( iside-1 )*2+itrans ) = resid /
272 $ ( real( max( 1, m ) )*cnorm*eps )
273*
274 20 CONTINUE
275 30 CONTINUE
276*
277 RETURN
278*
279* End of CQLT03
280*

◆ cqpt01()

real function cqpt01 ( integer m,
integer n,
integer k,
complex, dimension( lda, * ) a,
complex, dimension( lda, * ) af,
integer lda,
complex, dimension( * ) tau,
integer, dimension( * ) jpvt,
complex, dimension( lwork ) work,
integer lwork )

CQPT01

Purpose:
!>
!> CQPT01 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 array, dimension (LDA, N)
!>          The original matrix A.
!>
[in]AF
!>          AF is COMPLEX array, dimension (LDA,N)
!>          The (possibly partial) output of CGEQPF.  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 array, dimension (K)
!>          Details of the Householder transformations as returned by
!>          CGEQPF.
!>
[in]JPVT
!>          JPVT is INTEGER array, dimension (N)
!>          Pivot information as returned by CGEQPF.
!>
[out]WORK
!>          WORK is COMPLEX 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 cqpt01.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 A( LDA, * ), AF( LDA, * ), TAU( * ),
131 $ WORK( LWORK )
132* ..
133*
134* =====================================================================
135*
136* .. Parameters ..
137 REAL ZERO, ONE
138 parameter( zero = 0.0e0, one = 1.0e0 )
139* ..
140* .. Local Scalars ..
141 INTEGER I, INFO, J
142 REAL NORMA
143* ..
144* .. Local Arrays ..
145 REAL RWORK( 1 )
146* ..
147* .. External Functions ..
148 REAL CLANGE, SLAMCH
149 EXTERNAL clange, slamch
150* ..
151* .. External Subroutines ..
152 EXTERNAL caxpy, ccopy, cunmqr, xerbla
153* ..
154* .. Intrinsic Functions ..
155 INTRINSIC cmplx, max, min, real
156* ..
157* .. Executable Statements ..
158*
159 cqpt01 = zero
160*
161* Test if there is enough workspace
162*
163 IF( lwork.LT.m*n+n ) THEN
164 CALL xerbla( 'CQPT01', 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 = clange( '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 ccopy( m, af( 1, j ), 1, work( ( j-1 )*m+1 ), 1 )
185 40 CONTINUE
186*
187 CALL cunmqr( '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 caxpy( m, cmplx( -one ), a( 1, jpvt( j ) ), 1,
195 $ work( ( j-1 )*m+1 ), 1 )
196 50 CONTINUE
197*
198 cqpt01 = clange( 'One-norm', m, n, work, m, rwork ) /
199 $ ( real( max( m, n ) )*slamch( 'Epsilon' ) )
200 IF( norma.NE.zero )
201 $ cqpt01 = cqpt01 / norma
202*
203 RETURN
204*
205* End of CQPT01
206*

◆ cqrt01()

subroutine cqrt01 ( integer m,
integer n,
complex, dimension( lda, * ) a,
complex, dimension( lda, * ) af,
complex, dimension( lda, * ) q,
complex, dimension( lda, * ) r,
integer lda,
complex, dimension( * ) tau,
complex, dimension( lwork ) work,
integer lwork,
real, dimension( * ) rwork,
real, dimension( * ) result )

CQRT01

Purpose:
!>
!> CQRT01 tests CGEQRF, which computes the QR factorization of an m-by-n
!> matrix A, and partially tests CUNGQR which forms the m-by-m
!> orthogonal matrix Q.
!>
!> CQRT01 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 array, dimension (LDA,N)
!>          The m-by-n matrix A.
!>
[out]AF
!>          AF is COMPLEX array, dimension (LDA,N)
!>          Details of the QR factorization of A, as returned by CGEQRF.
!>          See CGEQRF for further details.
!>
[out]Q
!>          Q is COMPLEX array, dimension (LDA,M)
!>          The m-by-m orthogonal matrix Q.
!>
[out]R
!>          R is COMPLEX 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 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by CGEQRF.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (M)
!>
[out]RESULT
!>          RESULT is REAL 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 cqrt01.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 REAL RESULT( * ), RWORK( * )
136 COMPLEX A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
137 $ R( LDA, * ), TAU( * ), WORK( LWORK )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ZERO, ONE
144 parameter( zero = 0.0e+0, one = 1.0e+0 )
145 COMPLEX ROGUE
146 parameter( rogue = ( -1.0e+10, -1.0e+10 ) )
147* ..
148* .. Local Scalars ..
149 INTEGER INFO, MINMN
150 REAL ANORM, EPS, RESID
151* ..
152* .. External Functions ..
153 REAL CLANGE, CLANSY, SLAMCH
154 EXTERNAL clange, clansy, slamch
155* ..
156* .. External Subroutines ..
157 EXTERNAL cgemm, cgeqrf, cherk, clacpy, claset, cungqr
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC cmplx, max, min, real
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 = slamch( 'Epsilon' )
172*
173* Copy the matrix A to the array AF.
174*
175 CALL clacpy( 'Full', m, n, a, lda, af, lda )
176*
177* Factorize the matrix A in the array AF.
178*
179 srnamt = 'CGEQRF'
180 CALL cgeqrf( m, n, af, lda, tau, work, lwork, info )
181*
182* Copy details of Q
183*
184 CALL claset( 'Full', m, m, rogue, rogue, q, lda )
185 CALL clacpy( 'Lower', m-1, n, af( 2, 1 ), lda, q( 2, 1 ), lda )
186*
187* Generate the m-by-m matrix Q
188*
189 srnamt = 'CUNGQR'
190 CALL cungqr( m, m, minmn, q, lda, tau, work, lwork, info )
191*
192* Copy R
193*
194 CALL claset( 'Full', m, n, cmplx( zero ), cmplx( zero ), r, lda )
195 CALL clacpy( 'Upper', m, n, af, lda, r, lda )
196*
197* Compute R - Q'*A
198*
199 CALL cgemm( 'Conjugate transpose', 'No transpose', m, n, m,
200 $ cmplx( -one ), q, lda, a, lda, cmplx( one ), r, lda )
201*
202* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) .
203*
204 anorm = clange( '1', m, n, a, lda, rwork )
205 resid = clange( '1', m, n, r, lda, rwork )
206 IF( anorm.GT.zero ) THEN
207 result( 1 ) = ( ( resid / real( max( 1, m ) ) ) / anorm ) / eps
208 ELSE
209 result( 1 ) = zero
210 END IF
211*
212* Compute I - Q'*Q
213*
214 CALL claset( 'Full', m, m, cmplx( zero ), cmplx( one ), r, lda )
215 CALL cherk( 'Upper', 'Conjugate transpose', m, m, -one, q, lda,
216 $ one, r, lda )
217*
218* Compute norm( I - Q'*Q ) / ( M * EPS ) .
219*
220 resid = clansy( '1', 'Upper', m, r, lda, rwork )
221*
222 result( 2 ) = ( resid / real( max( 1, m ) ) ) / eps
223*
224 RETURN
225*
226* End of CQRT01
227*

◆ cqrt01p()

subroutine cqrt01p ( integer m,
integer n,
complex, dimension( lda, * ) a,
complex, dimension( lda, * ) af,
complex, dimension( lda, * ) q,
complex, dimension( lda, * ) r,
integer lda,
complex, dimension( * ) tau,
complex, dimension( lwork ) work,
integer lwork,
real, dimension( * ) rwork,
real, dimension( * ) result )

CQRT01P

Purpose:
!>
!> CQRT01P tests CGEQRFP, which computes the QR factorization of an m-by-n
!> matrix A, and partially tests CUNGQR which forms the m-by-m
!> orthogonal matrix Q.
!>
!> CQRT01P 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 array, dimension (LDA,N)
!>          The m-by-n matrix A.
!>
[out]AF
!>          AF is COMPLEX array, dimension (LDA,N)
!>          Details of the QR factorization of A, as returned by CGEQRFP.
!>          See CGEQRFP for further details.
!>
[out]Q
!>          Q is COMPLEX array, dimension (LDA,M)
!>          The m-by-m orthogonal matrix Q.
!>
[out]R
!>          R is COMPLEX 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 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by CGEQRFP.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (M)
!>
[out]RESULT
!>          RESULT is REAL 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 cqrt01p.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 REAL RESULT( * ), RWORK( * )
136 COMPLEX A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
137 $ R( LDA, * ), TAU( * ), WORK( LWORK )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ZERO, ONE
144 parameter( zero = 0.0e+0, one = 1.0e+0 )
145 COMPLEX ROGUE
146 parameter( rogue = ( -1.0e+10, -1.0e+10 ) )
147* ..
148* .. Local Scalars ..
149 INTEGER INFO, MINMN
150 REAL ANORM, EPS, RESID
151* ..
152* .. External Functions ..
153 REAL CLANGE, CLANSY, SLAMCH
154 EXTERNAL clange, clansy, slamch
155* ..
156* .. External Subroutines ..
157 EXTERNAL cgemm, cgeqrfp, cherk, clacpy, claset, cungqr
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC cmplx, max, min, real
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 = slamch( 'Epsilon' )
172*
173* Copy the matrix A to the array AF.
174*
175 CALL clacpy( 'Full', m, n, a, lda, af, lda )
176*
177* Factorize the matrix A in the array AF.
178*
179 srnamt = 'CGEQRFP'
180 CALL cgeqrfp( m, n, af, lda, tau, work, lwork, info )
181*
182* Copy details of Q
183*
184 CALL claset( 'Full', m, m, rogue, rogue, q, lda )
185 CALL clacpy( 'Lower', m-1, n, af( 2, 1 ), lda, q( 2, 1 ), lda )
186*
187* Generate the m-by-m matrix Q
188*
189 srnamt = 'CUNGQR'
190 CALL cungqr( m, m, minmn, q, lda, tau, work, lwork, info )
191*
192* Copy R
193*
194 CALL claset( 'Full', m, n, cmplx( zero ), cmplx( zero ), r, lda )
195 CALL clacpy( 'Upper', m, n, af, lda, r, lda )
196*
197* Compute R - Q'*A
198*
199 CALL cgemm( 'Conjugate transpose', 'No transpose', m, n, m,
200 $ cmplx( -one ), q, lda, a, lda, cmplx( one ), r, lda )
201*
202* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) .
203*
204 anorm = clange( '1', m, n, a, lda, rwork )
205 resid = clange( '1', m, n, r, lda, rwork )
206 IF( anorm.GT.zero ) THEN
207 result( 1 ) = ( ( resid / real( max( 1, m ) ) ) / anorm ) / eps
208 ELSE
209 result( 1 ) = zero
210 END IF
211*
212* Compute I - Q'*Q
213*
214 CALL claset( 'Full', m, m, cmplx( zero ), cmplx( one ), r, lda )
215 CALL cherk( 'Upper', 'Conjugate transpose', m, m, -one, q, lda,
216 $ one, r, lda )
217*
218* Compute norm( I - Q'*Q ) / ( M * EPS ) .
219*
220 resid = clansy( '1', 'Upper', m, r, lda, rwork )
221*
222 result( 2 ) = ( resid / real( max( 1, m ) ) ) / eps
223*
224 RETURN
225*
226* End of CQRT01P
227*

◆ cqrt02()

subroutine cqrt02 ( integer m,
integer n,
integer k,
complex, dimension( lda, * ) a,
complex, dimension( lda, * ) af,
complex, dimension( lda, * ) q,
complex, dimension( lda, * ) r,
integer lda,
complex, dimension( * ) tau,
complex, dimension( lwork ) work,
integer lwork,
real, dimension( * ) rwork,
real, dimension( * ) result )

CQRT02

Purpose:
!>
!> CQRT02 tests CUNGQR, 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, CQRT02 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 array, dimension (LDA,N)
!>          The m-by-n matrix A which was factorized by CQRT01.
!>
[in]AF
!>          AF is COMPLEX array, dimension (LDA,N)
!>          Details of the QR factorization of A, as returned by CGEQRF.
!>          See CGEQRF for further details.
!>
[out]Q
!>          Q is COMPLEX array, dimension (LDA,N)
!>
[out]R
!>          R is COMPLEX 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 array, dimension (N)
!>          The scalar factors of the elementary reflectors corresponding
!>          to the QR factorization in AF.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (M)
!>
[out]RESULT
!>          RESULT is REAL 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 cqrt02.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 REAL RESULT( * ), RWORK( * )
145 COMPLEX A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
146 $ R( LDA, * ), TAU( * ), WORK( LWORK )
147* ..
148*
149* =====================================================================
150*
151* .. Parameters ..
152 REAL ZERO, ONE
153 parameter( zero = 0.0e+0, one = 1.0e+0 )
154 COMPLEX ROGUE
155 parameter( rogue = ( -1.0e+10, -1.0e+10 ) )
156* ..
157* .. Local Scalars ..
158 INTEGER INFO
159 REAL ANORM, EPS, RESID
160* ..
161* .. External Functions ..
162 REAL CLANGE, CLANSY, SLAMCH
163 EXTERNAL clange, clansy, slamch
164* ..
165* .. External Subroutines ..
166 EXTERNAL cgemm, cherk, clacpy, claset, cungqr
167* ..
168* .. Intrinsic Functions ..
169 INTRINSIC cmplx, max, real
170* ..
171* .. Scalars in Common ..
172 CHARACTER*32 SRNAMT
173* ..
174* .. Common blocks ..
175 COMMON / srnamc / srnamt
176* ..
177* .. Executable Statements ..
178*
179 eps = slamch( 'Epsilon' )
180*
181* Copy the first k columns of the factorization to the array Q
182*
183 CALL claset( 'Full', m, n, rogue, rogue, q, lda )
184 CALL clacpy( '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 = 'CUNGQR'
189 CALL cungqr( m, n, k, q, lda, tau, work, lwork, info )
190*
191* Copy R(1:n,1:k)
192*
193 CALL claset( 'Full', n, k, cmplx( zero ), cmplx( zero ), r, lda )
194 CALL clacpy( 'Upper', n, k, af, lda, r, lda )
195*
196* Compute R(1:n,1:k) - Q(1:m,1:n)' * A(1:m,1:k)
197*
198 CALL cgemm( 'Conjugate transpose', 'No transpose', n, k, m,
199 $ cmplx( -one ), q, lda, a, lda, cmplx( one ), r, lda )
200*
201* Compute norm( R - Q'*A ) / ( M * norm(A) * EPS ) .
202*
203 anorm = clange( '1', m, k, a, lda, rwork )
204 resid = clange( '1', n, k, r, lda, rwork )
205 IF( anorm.GT.zero ) THEN
206 result( 1 ) = ( ( resid / real( max( 1, m ) ) ) / anorm ) / eps
207 ELSE
208 result( 1 ) = zero
209 END IF
210*
211* Compute I - Q'*Q
212*
213 CALL claset( 'Full', n, n, cmplx( zero ), cmplx( one ), r, lda )
214 CALL cherk( 'Upper', 'Conjugate transpose', n, m, -one, q, lda,
215 $ one, r, lda )
216*
217* Compute norm( I - Q'*Q ) / ( M * EPS ) .
218*
219 resid = clansy( '1', 'Upper', n, r, lda, rwork )
220*
221 result( 2 ) = ( resid / real( max( 1, m ) ) ) / eps
222*
223 RETURN
224*
225* End of CQRT02
226*

◆ cqrt03()

subroutine cqrt03 ( integer m,
integer n,
integer k,
complex, dimension( lda, * ) af,
complex, dimension( lda, * ) c,
complex, dimension( lda, * ) cc,
complex, dimension( lda, * ) q,
integer lda,
complex, dimension( * ) tau,
complex, dimension( lwork ) work,
integer lwork,
real, dimension( * ) rwork,
real, dimension( * ) result )

CQRT03

Purpose:
!>
!> CQRT03 tests CUNMQR, which computes Q*C, Q'*C, C*Q or C*Q'.
!>
!> CQRT03 compares the results of a call to CUNMQR with the results of
!> forming Q explicitly by a call to CUNGQR and then performing matrix
!> multiplication by a call to CGEMM.
!>
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 array, dimension (LDA,N)
!>          Details of the QR factorization of an m-by-n matrix, as
!>          returned by CGEQRF. See CGEQRF for further details.
!>
[out]C
!>          C is COMPLEX array, dimension (LDA,N)
!>
[out]CC
!>          CC is COMPLEX array, dimension (LDA,N)
!>
[out]Q
!>          Q is COMPLEX 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 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors corresponding
!>          to the QR factorization in AF.
!>
[out]WORK
!>          WORK is COMPLEX 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 REAL array, dimension (M)
!>
[out]RESULT
!>          RESULT is REAL 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 cqrt03.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 REAL RESULT( * ), RWORK( * )
146 COMPLEX AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
147 $ Q( LDA, * ), TAU( * ), WORK( LWORK )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 REAL ZERO, ONE
154 parameter( zero = 0.0e+0, one = 1.0e+0 )
155 COMPLEX ROGUE
156 parameter( rogue = ( -1.0e+10, -1.0e+10 ) )
157* ..
158* .. Local Scalars ..
159 CHARACTER SIDE, TRANS
160 INTEGER INFO, ISIDE, ITRANS, J, MC, NC
161 REAL CNORM, EPS, RESID
162* ..
163* .. External Functions ..
164 LOGICAL LSAME
165 REAL CLANGE, SLAMCH
166 EXTERNAL lsame, clange, slamch
167* ..
168* .. External Subroutines ..
169 EXTERNAL cgemm, clacpy, clarnv, claset, cungqr, cunmqr
170* ..
171* .. Local Arrays ..
172 INTEGER ISEED( 4 )
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC cmplx, max, real
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 = slamch( 'Epsilon' )
189*
190* Copy the first k columns of the factorization to the array Q
191*
192 CALL claset( 'Full', m, m, rogue, rogue, q, lda )
193 CALL clacpy( 'Lower', m-1, k, af( 2, 1 ), lda, q( 2, 1 ), lda )
194*
195* Generate the m-by-m matrix Q
196*
197 srnamt = 'CUNGQR'
198 CALL cungqr( 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 clarnv( 2, iseed, mc, c( 1, j ) )
215 10 CONTINUE
216 cnorm = clange( '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 clacpy( 'Full', mc, nc, c, lda, cc, lda )
230*
231* Apply Q or Q' to C
232*
233 srnamt = 'CUNMQR'
234 CALL cunmqr( 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 cgemm( trans, 'No transpose', mc, nc, mc,
241 $ cmplx( -one ), q, lda, c, lda, cmplx( one ),
242 $ cc, lda )
243 ELSE
244 CALL cgemm( 'No transpose', trans, mc, nc, nc,
245 $ cmplx( -one ), c, lda, q, lda, cmplx( one ),
246 $ cc, lda )
247 END IF
248*
249* Compute error in the difference
250*
251 resid = clange( '1', mc, nc, cc, lda, rwork )
252 result( ( iside-1 )*2+itrans ) = resid /
253 $ ( real( max( 1, m ) )*cnorm*eps )
254*
255 20 CONTINUE
256 30 CONTINUE
257*
258 RETURN
259*
260* End of CQRT03
261*

◆ cqrt04()

subroutine cqrt04 ( integer m,
integer n,
integer nb,
real, dimension(6) result )

CQRT04

Purpose:
!>
!> CQRT04 tests CGEQRT and CGEMQRT.
!>
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 REAL 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 cqrt04.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 REAL RESULT(6)
83*
84* =====================================================================
85*
86* ..
87* .. Local allocatable arrays
88 COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:),
89 $ R(:,:), WORK( : ), T(:,:),
90 $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
91 REAL, ALLOCATABLE :: RWORK(:)
92*
93* .. Parameters ..
94 REAL ZERO
95 COMPLEX 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 REAL ANORM, EPS, RESID, CNORM, DNORM
101* ..
102* .. Local Arrays ..
103 INTEGER ISEED( 4 )
104* ..
105* .. External Functions ..
106 REAL SLAMCH
107 REAL CLANGE, CLANSY
108 LOGICAL LSAME
109 EXTERNAL slamch, clange, clansy, lsame
110* ..
111* .. Intrinsic Functions ..
112 INTRINSIC max, min
113* ..
114* .. Data statements ..
115 DATA iseed / 1988, 1989, 1990, 1991 /
116*
117 eps = slamch( '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 clarnv( 2, iseed, m, a( 1, j ) )
133 END DO
134 CALL clacpy( 'Full', m, n, a, m, af, m )
135*
136* Factor the matrix A in the array AF.
137*
138 CALL cgeqrt( m, n, nb, af, m, t, ldt, work, info )
139*
140* Generate the m-by-m matrix Q
141*
142 CALL claset( 'Full', m, m, czero, one, q, m )
143 CALL cgemqrt( 'R', 'N', m, m, k, nb, af, m, t, ldt, q, m,
144 $ work, info )
145*
146* Copy R
147*
148 CALL claset( 'Full', m, n, czero, czero, r, m )
149 CALL clacpy( 'Upper', m, n, af, m, r, m )
150*
151* Compute |R - Q'*A| / |A| and store in RESULT(1)
152*
153 CALL cgemm( 'C', 'N', m, n, m, -one, q, m, a, m, one, r, m )
154 anorm = clange( '1', m, n, a, m, rwork )
155 resid = clange( '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 claset( 'Full', m, m, czero, one, r, m )
165 CALL cherk( 'U', 'C', m, m, real(-one), q, m, real(one), r, m )
166 resid = clansy( '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 clarnv( 2, iseed, m, c( 1, j ) )
173 END DO
174 cnorm = clange( '1', m, n, c, m, rwork)
175 CALL clacpy( 'Full', m, n, c, m, cf, m )
176*
177* Apply Q to C as Q*C
178*
179 CALL cgemqrt( '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 cgemm( 'N', 'N', m, n, m, -one, q, m, c, m, one, cf, m )
185 resid = clange( '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 clacpy( 'Full', m, n, c, m, cf, m )
195*
196* Apply Q to C as QT*C
197*
198 CALL cgemqrt( '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 cgemm( 'C', 'N', m, n, m, -one, q, m, c, m, one, cf, m )
204 resid = clange( '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 clarnv( 2, iseed, n, d( 1, j ) )
215 END DO
216 dnorm = clange( '1', n, m, d, n, rwork)
217 CALL clacpy( 'Full', n, m, d, n, df, n )
218*
219* Apply Q to D as D*Q
220*
221 CALL cgemqrt( '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 cgemm( 'N', 'N', n, m, m, -one, d, n, q, m, one, df, n )
227 resid = clange( '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 clacpy( 'Full', n, m, d, n, df, n )
237*
238* Apply Q to D as D*QT
239*
240 CALL cgemqrt( '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 cgemm( 'N', 'C', n, m, m, -one, d, n, q, m, one, df, n )
246 resid = clange( '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

◆ cqrt05()

subroutine cqrt05 ( integer m,
integer n,
integer l,
integer nb,
real, dimension(6) result )

CQRT05

Purpose:
!>
!> CQRT05 tests CTPQRT and CTPMQRT.
!>
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 REAL 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 cqrt05.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 REAL RESULT(6)
90*
91* =====================================================================
92*
93* ..
94* .. Local allocatable arrays
95 COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:),
96 $ R(:,:), WORK( : ), T(:,:),
97 $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
98 REAL, ALLOCATABLE :: RWORK(:)
99*
100* .. Parameters ..
101 REAL ZERO
102 COMPLEX 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 REAL ANORM, EPS, RESID, CNORM, DNORM
108* ..
109* .. Local Arrays ..
110 INTEGER ISEED( 4 )
111* ..
112* .. External Functions ..
113 REAL SLAMCH
114 REAL CLANGE, CLANSY
115 LOGICAL LSAME
116 EXTERNAL slamch, clange, clansy, lsame
117* ..
118* .. Data statements ..
119 DATA iseed / 1988, 1989, 1990, 1991 /
120*
121 eps = slamch( '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 claset( 'Full', m2, n, czero, czero, a, m2 )
141 CALL claset( 'Full', nb, n, czero, czero, t, nb )
142 DO j=1,n
143 CALL clarnv( 2, iseed, j, a( 1, j ) )
144 END DO
145 IF( m.GT.0 ) THEN
146 DO j=1,n
147 CALL clarnv( 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 clarnv( 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 clacpy( 'Full', m2, n, a, m2, af, m2 )
159*
160* Factor the matrix A in the array AF.
161*
162 CALL ctpqrt( 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 claset( 'Full', m2, m2, czero, one, q, m2 )
167 CALL cgemqrt( 'R', 'N', m2, m2, k, nb, af, m2, t, ldt, q, m2,
168 $ work, info )
169*
170* Copy R
171*
172 CALL claset( 'Full', m2, n, czero, czero, r, m2 )
173 CALL clacpy( 'Upper', m2, n, af, m2, r, m2 )
174*
175* Compute |R - Q'*A| / |A| and store in RESULT(1)
176*
177 CALL cgemm( 'C', 'N', m2, n, m2, -one, q, m2, a, m2, one, r, m2 )
178 anorm = clange( '1', m2, n, a, m2, rwork )
179 resid = clange( '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 claset( 'Full', m2, m2, czero, one, r, m2 )
189 CALL cherk( 'U', 'C', m2, m2, real(-one), q, m2, real(one),
190 $ r, m2 )
191 resid = clansy( '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 clarnv( 2, iseed, m2, c( 1, j ) )
198 END DO
199 cnorm = clange( '1', m2, n, c, m2, rwork)
200 CALL clacpy( 'Full', m2, n, c, m2, cf, m2 )
201*
202* Apply Q to C as Q*C
203*
204 CALL ctpmqrt( '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 cgemm( 'N', 'N', m2, n, m2, -one, q, m2, c, m2, one, cf, m2 )
210 resid = clange( '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 clacpy( 'Full', m2, n, c, m2, cf, m2 )
220*
221* Apply Q to C as QT*C
222*
223 CALL ctpmqrt( '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 cgemm('C','N',m2,n,m2,-one,q,m2,c,m2,one,cf,m2)
229 resid = clange( '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 clarnv( 2, iseed, n, d( 1, j ) )
240 END DO
241 dnorm = clange( '1', n, m2, d, n, rwork)
242 CALL clacpy( 'Full', n, m2, d, n, df, n )
243*
244* Apply Q to D as D*Q
245*
246 CALL ctpmqrt('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 cgemm('N','N',n,m2,m2,-one,d,n,q,m2,one,df,n)
252 resid = clange('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 clacpy('Full',n,m2,d,n,df,n )
262*
263* Apply Q to D as D*QT
264*
265 CALL ctpmqrt('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 cgemm( 'N', 'C', n, m2, m2, -one, d, n, q, m2, one, df, n )
272 resid = clange( '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

◆ cqrt11()

real function cqrt11 ( integer m,
integer k,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( * ) tau,
complex, dimension( lwork ) work,
integer lwork )

CQRT11

Purpose:
!>
!> CQRT11 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 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 array, dimension (K)
!>          The scaling factors tau for the elementary transformations as
!>          computed by the QR factorization routine.
!>
[out]WORK
!>          WORK is COMPLEX 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 cqrt11.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 A( LDA, * ), TAU( * ), WORK( LWORK )
108* ..
109*
110* =====================================================================
111*
112* .. Parameters ..
113 REAL ZERO, ONE
114 parameter( zero = 0.0e0, one = 1.0e0 )
115* ..
116* .. Local Scalars ..
117 INTEGER INFO, J
118* ..
119* .. External Functions ..
120 REAL CLANGE, SLAMCH
121 EXTERNAL clange, slamch
122* ..
123* .. External Subroutines ..
124 EXTERNAL claset, cunm2r, xerbla
125* ..
126* .. Intrinsic Functions ..
127 INTRINSIC cmplx, real
128* ..
129* .. Local Arrays ..
130 REAL RDUMMY( 1 )
131* ..
132* .. Executable Statements ..
133*
134 cqrt11 = zero
135*
136* Test for sufficient workspace
137*
138 IF( lwork.LT.m*m+m ) THEN
139 CALL xerbla( 'CQRT11', 7 )
140 RETURN
141 END IF
142*
143* Quick return if possible
144*
145 IF( m.LE.0 )
146 $ RETURN
147*
148 CALL claset( 'Full', m, m, cmplx( zero ), cmplx( one ), work, m )
149*
150* Form Q
151*
152 CALL cunm2r( 'Left', 'No transpose', m, m, k, a, lda, tau, work,
153 $ m, work( m*m+1 ), info )
154*
155* Form Q'*Q
156*
157 CALL cunm2r( 'Left', 'Conjugate transpose', m, m, k, a, lda, tau,
158 $ work, m, work( m*m+1 ), info )
159*
160 DO 10 j = 1, m
161 work( ( j-1 )*m+j ) = work( ( j-1 )*m+j ) - one
162 10 CONTINUE
163*
164 cqrt11 = clange( 'One-norm', m, m, work, m, rdummy ) /
165 $ ( real( m )*slamch( 'Epsilon' ) )
166*
167 RETURN
168*
169* End of CQRT11
170*

◆ cqrt12()

real function cqrt12 ( integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
real, dimension( * ) s,
complex, dimension( lwork ) work,
integer lwork,
real, dimension( * ) rwork )

CQRT12

Purpose:
!>
!> CQRT12 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 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 REAL array, dimension (min(M,N))
!>          The singular values of the matrix A.
!>
[out]WORK
!>          WORK is COMPLEX 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 REAL array, dimension (4*min(M,N))
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 95 of file cqrt12.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 REAL RWORK( * ), S( * )
107 COMPLEX A( LDA, * ), WORK( LWORK )
108* ..
109*
110* =====================================================================
111*
112* .. Parameters ..
113 REAL ZERO, ONE
114 parameter( zero = 0.0e0, one = 1.0e0 )
115* ..
116* .. Local Scalars ..
117 INTEGER I, INFO, ISCL, J, MN
118 REAL ANRM, BIGNUM, NRMSVL, SMLNUM
119* ..
120* .. Local Arrays ..
121 REAL DUMMY( 1 )
122* ..
123* .. External Functions ..
124 REAL CLANGE, SASUM, SLAMCH, SNRM2
125 EXTERNAL clange, sasum, slamch, snrm2
126* ..
127* .. External Subroutines ..
128 EXTERNAL cgebd2, clascl, claset, saxpy, sbdsqr, slabad,
129 $ slascl, xerbla
130* ..
131* .. Intrinsic Functions ..
132 INTRINSIC cmplx, max, min, real
133* ..
134* .. Executable Statements ..
135*
136 cqrt12 = 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( 'CQRT12', 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 = snrm2( mn, s, 1 )
152*
153* Copy upper triangle of A into work
154*
155 CALL claset( 'Full', m, n, cmplx( zero ), cmplx( zero ), work, m )
156 DO 20 j = 1, n
157 DO 10 i = 1, min( j, m )
158 work( ( j-1 )*m+i ) = a( i, j )
159 10 CONTINUE
160 20 CONTINUE
161*
162* Get machine parameters
163*
164 smlnum = slamch( 'S' ) / slamch( 'P' )
165 bignum = one / smlnum
166 CALL slabad( smlnum, bignum )
167*
168* Scale work if max entry outside range [SMLNUM,BIGNUM]
169*
170 anrm = clange( 'M', m, n, work, m, dummy )
171 iscl = 0
172 IF( anrm.GT.zero .AND. anrm.LT.smlnum ) THEN
173*
174* Scale matrix norm up to SMLNUM
175*
176 CALL clascl( 'G', 0, 0, anrm, smlnum, m, n, work, m, info )
177 iscl = 1
178 ELSE IF( anrm.GT.bignum ) THEN
179*
180* Scale matrix norm down to BIGNUM
181*
182 CALL clascl( 'G', 0, 0, anrm, bignum, m, n, work, m, info )
183 iscl = 1
184 END IF
185*
186 IF( anrm.NE.zero ) THEN
187*
188* Compute SVD of work
189*
190 CALL cgebd2( m, n, work, m, rwork( 1 ), rwork( mn+1 ),
191 $ work( m*n+1 ), work( m*n+mn+1 ),
192 $ work( m*n+2*mn+1 ), info )
193 CALL sbdsqr( 'Upper', mn, 0, 0, 0, rwork( 1 ), rwork( mn+1 ),
194 $ dummy, mn, dummy, 1, dummy, mn, rwork( 2*mn+1 ),
195 $ info )
196*
197 IF( iscl.EQ.1 ) THEN
198 IF( anrm.GT.bignum ) THEN
199 CALL slascl( 'G', 0, 0, bignum, anrm, mn, 1, rwork( 1 ),
200 $ mn, info )
201 END IF
202 IF( anrm.LT.smlnum ) THEN
203 CALL slascl( 'G', 0, 0, smlnum, anrm, mn, 1, rwork( 1 ),
204 $ mn, info )
205 END IF
206 END IF
207*
208 ELSE
209*
210 DO 30 i = 1, mn
211 rwork( i ) = zero
212 30 CONTINUE
213 END IF
214*
215* Compare s and singular values of work
216*
217 CALL saxpy( mn, -one, s, 1, rwork( 1 ), 1 )
218 cqrt12 = sasum( mn, rwork( 1 ), 1 ) /
219 $ ( slamch( 'Epsilon' )*real( max( m, n ) ) )
220 IF( nrmsvl.NE.zero )
221 $ cqrt12 = cqrt12 / nrmsvl
222*
223 RETURN
224*
225* End of CQRT12
226*
slascl
subroutine slascl(type, kl, ku, cfrom, cto, m, n, a, lda, info)
SLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
Definition slascl.f:143
sbdsqr
subroutine sbdsqr(uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c, ldc, work, info)
SBDSQR
Definition sbdsqr.f:240
cgebd2
subroutine cgebd2(m, n, a, lda, d, e, tauq, taup, work, info)
CGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
Definition cgebd2.f:190
clascl
subroutine clascl(type, kl, ku, cfrom, cto, m, n, a, lda, info)
CLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
Definition clascl.f:143
snrm2
real(wp) function snrm2(n, x, incx)
SNRM2
Definition snrm2.f90:89

◆ cqrt13()

subroutine cqrt13 ( integer scale,
integer m,
integer n,
complex, dimension( lda, * ) a,
integer lda,
real norma,
integer, dimension( 4 ) iseed )

CQRT13

Purpose:
!>
!> CQRT13 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 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 REAL
!>          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 cqrt13.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 REAL NORMA
99* ..
100* .. Array Arguments ..
101 INTEGER ISEED( 4 )
102 COMPLEX A( LDA, * )
103* ..
104*
105* =====================================================================
106*
107* .. Parameters ..
108 REAL ONE
109 parameter( one = 1.0e0 )
110* ..
111* .. Local Scalars ..
112 INTEGER INFO, J
113 REAL BIGNUM, SMLNUM
114* ..
115* .. External Functions ..
116 REAL CLANGE, SCASUM, SLAMCH
117 EXTERNAL clange, scasum, slamch
118* ..
119* .. External Subroutines ..
120 EXTERNAL clarnv, clascl, slabad
121* ..
122* .. Intrinsic Functions ..
123 INTRINSIC cmplx, real, sign
124* ..
125* .. Local Arrays ..
126 REAL 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 clarnv( 2, iseed, m, a( 1, j ) )
137 IF( j.LE.m ) THEN
138 a( j, j ) = a( j, j ) + cmplx( sign( scasum( m, a( 1, j ),
139 $ 1 ), real( a( j, j ) ) ) )
140 END IF
141 10 CONTINUE
142*
143* scaled versions
144*
145 IF( scale.NE.1 ) THEN
146 norma = clange( 'Max', m, n, a, lda, dummy )
147 smlnum = slamch( 'Safe minimum' )
148 bignum = one / smlnum
149 CALL slabad( smlnum, bignum )
150 smlnum = smlnum / slamch( 'Epsilon' )
151 bignum = one / smlnum
152*
153 IF( scale.EQ.2 ) THEN
154*
155* matrix scaled up
156*
157 CALL clascl( '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 clascl( 'General', 0, 0, norma, smlnum, m, n, a, lda,
164 $ info )
165 END IF
166 END IF
167*
168 norma = clange( 'One-norm', m, n, a, lda, dummy )
169 RETURN
170*
171* End of CQRT13
172*

◆ cqrt14()

real function cqrt14 ( character trans,
integer m,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( lwork ) work,
integer lwork )

CQRT14

Purpose:
!>
!> CQRT14 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 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 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 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 cqrt14.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 A( LDA, * ), WORK( LWORK ), X( LDX, * )
127* ..
128*
129* =====================================================================
130*
131* .. Parameters ..
132 REAL ZERO, ONE
133 parameter( zero = 0.0e0, one = 1.0e0 )
134* ..
135* .. Local Scalars ..
136 LOGICAL TPSD
137 INTEGER I, INFO, J, LDWORK
138 REAL ANRM, ERR, XNRM
139* ..
140* .. Local Arrays ..
141 REAL RWORK( 1 )
142* ..
143* .. External Functions ..
144 LOGICAL LSAME
145 REAL CLANGE, SLAMCH
146 EXTERNAL lsame, clange, slamch
147* ..
148* .. External Subroutines ..
149 EXTERNAL cgelq2, cgeqr2, clacpy, clascl, xerbla
150* ..
151* .. Intrinsic Functions ..
152 INTRINSIC abs, conjg, max, min, real
153* ..
154* .. Executable Statements ..
155*
156 cqrt14 = 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( 'CQRT14', 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( 'CQRT14', 10 )
171 RETURN
172 ELSE IF( m.LE.0 .OR. nrhs.LE.0 ) THEN
173 RETURN
174 END IF
175 ELSE
176 CALL xerbla( 'CQRT14', 1 )
177 RETURN
178 END IF
179*
180* Copy and scale A
181*
182 CALL clacpy( 'All', m, n, a, lda, work, ldwork )
183 anrm = clange( 'M', m, n, work, ldwork, rwork )
184 IF( anrm.NE.zero )
185 $ CALL clascl( '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 clacpy( 'All', m, nrhs, x, ldx, work( n*ldwork+1 ),
194 $ ldwork )
195 xnrm = clange( 'M', m, nrhs, work( n*ldwork+1 ), ldwork,
196 $ rwork )
197 IF( xnrm.NE.zero )
198 $ CALL clascl( 'G', 0, 0, xnrm, one, m, nrhs,
199 $ work( n*ldwork+1 ), ldwork, info )
200*
201* Compute QR factorization of X
202*
203 CALL cgeqr2( 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 ) = conjg( x( i, j ) )
225 30 CONTINUE
226 40 CONTINUE
227*
228 xnrm = clange( 'M', nrhs, n, work( m+1 ), ldwork, rwork )
229 IF( xnrm.NE.zero )
230 $ CALL clascl( 'G', 0, 0, xnrm, one, nrhs, n, work( m+1 ),
231 $ ldwork, info )
232*
233* Compute LQ factorization of work
234*
235 CALL cgelq2( 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 cqrt14 = err / ( real( max( m, n, nrhs ) )*slamch( 'Epsilon' ) )
251*
252 RETURN
253*
254* End of CQRT14
255*

◆ cqrt15()

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

CQRT15

Purpose:
!>
!> CQRT15 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 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 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 REAL 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 REAL
!>          one-norm norm of A.
!>
[out]NORMB
!>          NORMB is REAL
!>          one-norm norm of B.
!>
[in,out]ISEED
!>          ISEED is integer array, dimension (4)
!>          seed for random number generator.
!>
[out]WORK
!>          WORK is COMPLEX 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 cqrt15.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 REAL NORMA, NORMB
157* ..
158* .. Array Arguments ..
159 INTEGER ISEED( 4 )
160 REAL S( * )
161 COMPLEX A( LDA, * ), B( LDB, * ), WORK( LWORK )
162* ..
163*
164* =====================================================================
165*
166* .. Parameters ..
167 REAL ZERO, ONE, TWO, SVMIN
168 parameter( zero = 0.0e+0, one = 1.0e+0, two = 2.0e+0,
169 $ svmin = 0.1e+0 )
170 COMPLEX CZERO, CONE
171 parameter( czero = ( 0.0e+0, 0.0e+0 ),
172 $ cone = ( 1.0e+0, 0.0e+0 ) )
173* ..
174* .. Local Scalars ..
175 INTEGER INFO, J, MN
176 REAL BIGNUM, EPS, SMLNUM, TEMP
177* ..
178* .. Local Arrays ..
179 REAL DUMMY( 1 )
180* ..
181* .. External Functions ..
182 REAL CLANGE, SASUM, SCNRM2, SLAMCH, SLARND
183 EXTERNAL clange, sasum, scnrm2, slamch, slarnd
184* ..
185* .. External Subroutines ..
186 EXTERNAL cgemm, clarf, clarnv, claror, clascl, claset,
187 $ csscal, slabad, slaord, slascl, xerbla
188* ..
189* .. Intrinsic Functions ..
190 INTRINSIC abs, cmplx, 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( 'CQRT15', 16 )
197 RETURN
198 END IF
199*
200 smlnum = slamch( 'Safe minimum' )
201 bignum = one / smlnum
202 CALL slabad( smlnum, bignum )
203 eps = slamch( '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( 'CQRT15', 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 = slarnd( 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 slaord( 'Decreasing', rank, s, 1 )
235*
236* Generate 'rank' columns of a random orthogonal matrix in A
237*
238 CALL clarnv( 2, iseed, m, work )
239 CALL csscal( m, one / scnrm2( m, work, 1 ), work, 1 )
240 CALL claset( 'Full', m, rank, czero, cone, a, lda )
241 CALL clarf( 'Left', m, rank, work, 1, cmplx( 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 clarnv( 2, iseed, rank*nrhs, work )
249 CALL cgemm( '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 csscal( m, s( j ), a( 1, j ), 1 )
258 40 CONTINUE
259 IF( rank.LT.n )
260 $ CALL claset( 'Full', m, n-rank, czero, czero,
261 $ a( 1, rank+1 ), lda )
262 CALL claror( '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 claset( 'Full', m, n, czero, czero, a, lda )
275 CALL claset( '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 = clange( '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 clascl( 'General', 0, 0, norma, bignum, m, n, a,
289 $ lda, info )
290 CALL slascl( 'General', 0, 0, norma, bignum, mn, 1, s,
291 $ mn, info )
292 CALL clascl( '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 clascl( 'General', 0, 0, norma, smlnum, m, n, a,
299 $ lda, info )
300 CALL slascl( 'General', 0, 0, norma, smlnum, mn, 1, s,
301 $ mn, info )
302 CALL clascl( 'General', 0, 0, norma, smlnum, m, nrhs, b,
303 $ ldb, info )
304 ELSE
305 CALL xerbla( 'CQRT15', 1 )
306 RETURN
307 END IF
308 END IF
309 END IF
310*
311 norma = sasum( mn, s, 1 )
312 normb = clange( 'One-norm', m, nrhs, b, ldb, dummy )
313*
314 RETURN
315*
316* End of CQRT15
317*
clarf
subroutine clarf(side, m, n, v, incv, tau, c, ldc, work)
CLARF applies an elementary reflector to a general rectangular matrix.
Definition clarf.f:128
claror
subroutine claror(side, init, m, n, a, lda, iseed, x, info)
CLAROR
Definition claror.f:158
scnrm2
real(wp) function scnrm2(n, x, incx)
SCNRM2
Definition scnrm2.f90:90

◆ cqrt16()

subroutine cqrt16 ( character trans,
integer m,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldb, * ) b,
integer ldb,
real, dimension( * ) rwork,
real resid )

CQRT16

Purpose:
!>
!> CQRT16 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 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 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 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 REAL array, dimension (M)
!>
[out]RESID
!>          RESID is REAL
!>          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 cqrt16.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 REAL RESID
142* ..
143* .. Array Arguments ..
144 REAL RWORK( * )
145 COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * )
146* ..
147*
148* =====================================================================
149*
150* .. Parameters ..
151 REAL ZERO, ONE
152 parameter( zero = 0.0e+0, one = 1.0e+0 )
153 COMPLEX CONE
154 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
155* ..
156* .. Local Scalars ..
157 INTEGER J, N1, N2
158 REAL ANORM, BNORM, EPS, XNORM
159* ..
160* .. External Functions ..
161 LOGICAL LSAME
162 REAL CLANGE, SCASUM, SLAMCH
163 EXTERNAL lsame, clange, scasum, slamch
164* ..
165* .. External Subroutines ..
166 EXTERNAL cgemm
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 = clange( 'I', m, n, a, lda, rwork )
182 n1 = n
183 n2 = m
184 ELSE
185 anorm = clange( '1', m, n, a, lda, rwork )
186 n1 = m
187 n2 = n
188 END IF
189*
190 eps = slamch( 'Epsilon' )
191*
192* Compute B - A*X (or B - A'*X ) and store in B.
193*
194 CALL cgemm( 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 = scasum( n1, b( 1, j ), 1 )
203 xnorm = scasum( 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 CQRT16
217*

◆ cqrt17()

real function cqrt17 ( character trans,
integer iresid,
integer m,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( ldb, * ) c,
complex, dimension( lwork ) work,
integer lwork )

CQRT17

Purpose:
!>
!> CQRT17 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 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 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 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 array, dimension (LDB,NRHS)
!>
[out]WORK
!>          WORK is COMPLEX 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 cqrt17.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 A( LDA, * ), B( LDB, * ), C( LDB, * ),
164 $ WORK( LWORK ), X( LDX, * )
165* ..
166*
167* =====================================================================
168*
169* .. Parameters ..
170 REAL ZERO, ONE
171 parameter( zero = 0.0e0, one = 1.0e0 )
172* ..
173* .. Local Scalars ..
174 INTEGER INFO, ISCL, NCOLS, NROWS
175 REAL ERR, NORMA, NORMB, NORMRS, SMLNUM
176* ..
177* .. Local Arrays ..
178 REAL RWORK( 1 )
179* ..
180* .. External Functions ..
181 LOGICAL LSAME
182 REAL CLANGE, SLAMCH
183 EXTERNAL lsame, clange, slamch
184* ..
185* .. External Subroutines ..
186 EXTERNAL cgemm, clacpy, clascl, xerbla
187* ..
188* .. Intrinsic Functions ..
189 INTRINSIC cmplx, max, real
190* ..
191* .. Executable Statements ..
192*
193 cqrt17 = 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( 'CQRT17', 1 )
203 RETURN
204 END IF
205*
206 IF( lwork.LT.ncols*nrhs ) THEN
207 CALL xerbla( 'CQRT17', 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 = clange( 'One-norm', m, n, a, lda, rwork )
215 smlnum = slamch( 'Safe minimum' ) / slamch( 'Precision' )
216 iscl = 0
217*
218* compute residual and scale it
219*
220 CALL clacpy( 'All', nrows, nrhs, b, ldb, c, ldb )
221 CALL cgemm( trans, 'No transpose', nrows, nrhs, ncols,
222 $ cmplx( -one ), a, lda, x, ldx, cmplx( one ), c, ldb )
223 normrs = clange( 'Max', nrows, nrhs, c, ldb, rwork )
224 IF( normrs.GT.smlnum ) THEN
225 iscl = 1
226 CALL clascl( 'General', 0, 0, normrs, one, nrows, nrhs, c, ldb,
227 $ info )
228 END IF
229*
230* compute R**H * op(A)
231*
232 CALL cgemm( 'Conjugate transpose', trans, nrhs, ncols, nrows,
233 $ cmplx( one ), c, ldb, a, lda, cmplx( zero ), work,
234 $ nrhs )
235*
236* compute and properly scale error
237*
238 err = clange( 'One-norm', nrhs, ncols, work, nrhs, rwork )
239 IF( norma.NE.zero )
240 $ err = err / norma
241*
242 IF( iscl.EQ.1 )
243 $ err = err*normrs
244*
245 IF( iresid.EQ.1 ) THEN
246 normb = clange( 'One-norm', nrows, nrhs, b, ldb, rwork )
247 IF( normb.NE.zero )
248 $ err = err / normb
249 ELSE
250 IF( normrs.NE.zero )
251 $ err = err / normrs
252 END IF
253*
254 cqrt17 = err / ( slamch( 'Epsilon' )*real( max( m, n, nrhs ) ) )
255 RETURN
256*
257* End of CQRT17
258*

◆ crqt01()

subroutine crqt01 ( integer m,
integer n,
complex, dimension( lda, * ) a,
complex, dimension( lda, * ) af,
complex, dimension( lda, * ) q,
complex, dimension( lda, * ) r,
integer lda,
complex, dimension( * ) tau,
complex, dimension( lwork ) work,
integer lwork,
real, dimension( * ) rwork,
real, dimension( * ) result )

CRQT01

Purpose:
!>
!> CRQT01 tests CGERQF, which computes the RQ factorization of an m-by-n
!> matrix A, and partially tests CUNGRQ which forms the n-by-n
!> orthogonal matrix Q.
!>
!> CRQT01 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 array, dimension (LDA,N)
!>          The m-by-n matrix A.
!>
[out]AF
!>          AF is COMPLEX array, dimension (LDA,N)
!>          Details of the RQ factorization of A, as returned by CGERQF.
!>          See CGERQF for further details.
!>
[out]Q
!>          Q is COMPLEX array, dimension (LDA,N)
!>          The n-by-n orthogonal matrix Q.
!>
[out]R
!>          R is COMPLEX 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 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by CGERQF.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (max(M,N))
!>
[out]RESULT
!>          RESULT is REAL 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 crqt01.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 REAL RESULT( * ), RWORK( * )
136 COMPLEX A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
137 $ R( LDA, * ), TAU( * ), WORK( LWORK )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ZERO, ONE
144 parameter( zero = 0.0e+0, one = 1.0e+0 )
145 COMPLEX ROGUE
146 parameter( rogue = ( -1.0e+10, -1.0e+10 ) )
147* ..
148* .. Local Scalars ..
149 INTEGER INFO, MINMN
150 REAL ANORM, EPS, RESID
151* ..
152* .. External Functions ..
153 REAL CLANGE, CLANSY, SLAMCH
154 EXTERNAL clange, clansy, slamch
155* ..
156* .. External Subroutines ..
157 EXTERNAL cgemm, cgerqf, cherk, clacpy, claset, cungrq
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC cmplx, max, min, real
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 = slamch( 'Epsilon' )
172*
173* Copy the matrix A to the array AF.
174*
175 CALL clacpy( 'Full', m, n, a, lda, af, lda )
176*
177* Factorize the matrix A in the array AF.
178*
179 srnamt = 'CGERQF'
180 CALL cgerqf( m, n, af, lda, tau, work, lwork, info )
181*
182* Copy details of Q
183*
184 CALL claset( 'Full', n, n, rogue, rogue, q, lda )
185 IF( m.LE.n ) THEN
186 IF( m.GT.0 .AND. m.LT.n )
187 $ CALL clacpy( 'Full', m, n-m, af, lda, q( n-m+1, 1 ), lda )
188 IF( m.GT.1 )
189 $ CALL clacpy( '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 clacpy( '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 = 'CUNGRQ'
200 CALL cungrq( n, n, minmn, q, lda, tau, work, lwork, info )
201*
202* Copy R
203*
204 CALL claset( 'Full', m, n, cmplx( zero ), cmplx( zero ), r, lda )
205 IF( m.LE.n ) THEN
206 IF( m.GT.0 )
207 $ CALL clacpy( 'Upper', m, m, af( 1, n-m+1 ), lda,
208 $ r( 1, n-m+1 ), lda )
209 ELSE
210 IF( m.GT.n .AND. n.GT.0 )
211 $ CALL clacpy( 'Full', m-n, n, af, lda, r, lda )
212 IF( n.GT.0 )
213 $ CALL clacpy( 'Upper', n, n, af( m-n+1, 1 ), lda,
214 $ r( m-n+1, 1 ), lda )
215 END IF
216*
217* Compute R - A*Q'
218*
219 CALL cgemm( 'No transpose', 'Conjugate transpose', m, n, n,
220 $ cmplx( -one ), a, lda, q, lda, cmplx( one ), r, lda )
221*
222* Compute norm( R - Q'*A ) / ( N * norm(A) * EPS ) .
223*
224 anorm = clange( '1', m, n, a, lda, rwork )
225 resid = clange( '1', m, n, r, lda, rwork )
226 IF( anorm.GT.zero ) THEN
227 result( 1 ) = ( ( resid / real( max( 1, n ) ) ) / anorm ) / eps
228 ELSE
229 result( 1 ) = zero
230 END IF
231*
232* Compute I - Q*Q'
233*
234 CALL claset( 'Full', n, n, cmplx( zero ), cmplx( one ), r, lda )
235 CALL cherk( 'Upper', 'No transpose', n, n, -one, q, lda, one, r,
236 $ lda )
237*
238* Compute norm( I - Q*Q' ) / ( N * EPS ) .
239*
240 resid = clansy( '1', 'Upper', n, r, lda, rwork )
241*
242 result( 2 ) = ( resid / real( max( 1, n ) ) ) / eps
243*
244 RETURN
245*
246* End of CRQT01
247*

◆ crqt02()

subroutine crqt02 ( integer m,
integer n,
integer k,
complex, dimension( lda, * ) a,
complex, dimension( lda, * ) af,
complex, dimension( lda, * ) q,
complex, dimension( lda, * ) r,
integer lda,
complex, dimension( * ) tau,
complex, dimension( lwork ) work,
integer lwork,
real, dimension( * ) rwork,
real, dimension( * ) result )

CRQT02

Purpose:
!>
!> CRQT02 tests CUNGRQ, 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, CRQT02 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 array, dimension (LDA,N)
!>          The m-by-n matrix A which was factorized by CRQT01.
!>
[in]AF
!>          AF is COMPLEX array, dimension (LDA,N)
!>          Details of the RQ factorization of A, as returned by CGERQF.
!>          See CGERQF for further details.
!>
[out]Q
!>          Q is COMPLEX array, dimension (LDA,N)
!>
[out]R
!>          R is COMPLEX 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 array, dimension (M)
!>          The scalar factors of the elementary reflectors corresponding
!>          to the RQ factorization in AF.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is REAL array, dimension (M)
!>
[out]RESULT
!>          RESULT is REAL 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 crqt02.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 REAL RESULT( * ), RWORK( * )
146 COMPLEX A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
147 $ R( LDA, * ), TAU( * ), WORK( LWORK )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 REAL ZERO, ONE
154 parameter( zero = 0.0e+0, one = 1.0e+0 )
155 COMPLEX ROGUE
156 parameter( rogue = ( -1.0e+10, -1.0e+10 ) )
157* ..
158* .. Local Scalars ..
159 INTEGER INFO
160 REAL ANORM, EPS, RESID
161* ..
162* .. External Functions ..
163 REAL CLANGE, CLANSY, SLAMCH
164 EXTERNAL clange, clansy, slamch
165* ..
166* .. External Subroutines ..
167 EXTERNAL cgemm, cherk, clacpy, claset, cungrq
168* ..
169* .. Intrinsic Functions ..
170 INTRINSIC cmplx, max, real
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 = slamch( 'Epsilon' )
189*
190* Copy the last k rows of the factorization to the array Q
191*
192 CALL claset( 'Full', m, n, rogue, rogue, q, lda )
193 IF( k.LT.n )
194 $ CALL clacpy( 'Full', k, n-k, af( m-k+1, 1 ), lda,
195 $ q( m-k+1, 1 ), lda )
196 IF( k.GT.1 )
197 $ CALL clacpy( '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 = 'CUNGRQ'
203 CALL cungrq( 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 claset( 'Full', k, m, cmplx( zero ), cmplx( zero ),
208 $ r( m-k+1, n-m+1 ), lda )
209 CALL clacpy( '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 cgemm( 'No transpose', 'Conjugate transpose', k, m, n,
215 $ cmplx( -one ), a( m-k+1, 1 ), lda, q, lda,
216 $ cmplx( one ), r( m-k+1, n-m+1 ), lda )
217*
218* Compute norm( R - A*Q' ) / ( N * norm(A) * EPS ) .
219*
220 anorm = clange( '1', k, n, a( m-k+1, 1 ), lda, rwork )
221 resid = clange( '1', k, m, r( m-k+1, n-m+1 ), lda, rwork )
222 IF( anorm.GT.zero ) THEN
223 result( 1 ) = ( ( resid / real( max( 1, n ) ) ) / anorm ) / eps
224 ELSE
225 result( 1 ) = zero
226 END IF
227*
228* Compute I - Q*Q'
229*
230 CALL claset( 'Full', m, m, cmplx( zero ), cmplx( one ), r, lda )
231 CALL cherk( 'Upper', 'No transpose', m, n, -one, q, lda, one, r,
232 $ lda )
233*
234* Compute norm( I - Q*Q' ) / ( N * EPS ) .
235*
236 resid = clansy( '1', 'Upper', m, r, lda, rwork )
237*
238 result( 2 ) = ( resid / real( max( 1, n ) ) ) / eps
239*
240 RETURN
241*
242* End of CRQT02
243*

◆ crqt03()

subroutine crqt03 ( integer m,
integer n,
integer k,
complex, dimension( lda, * ) af,
complex, dimension( lda, * ) c,
complex, dimension( lda, * ) cc,
complex, dimension( lda, * ) q,
integer lda,
complex, dimension( * ) tau,
complex, dimension( lwork ) work,
integer lwork,
real, dimension( * ) rwork,
real, dimension( * ) result )

CRQT03

Purpose:
!>
!> CRQT03 tests CUNMRQ, which computes Q*C, Q'*C, C*Q or C*Q'.
!>
!> CRQT03 compares the results of a call to CUNMRQ with the results of
!> forming Q explicitly by a call to CUNGRQ and then performing matrix
!> multiplication by a call to CGEMM.
!>
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 array, dimension (LDA,N)
!>          Details of the RQ factorization of an m-by-n matrix, as
!>          returned by CGERQF. See CGERQF for further details.
!>
[out]C
!>          C is COMPLEX array, dimension (LDA,N)
!>
[out]CC
!>          CC is COMPLEX array, dimension (LDA,N)
!>
[out]Q
!>          Q is COMPLEX 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 array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors corresponding
!>          to the RQ factorization in AF.
!>
[out]WORK
!>          WORK is COMPLEX 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 REAL array, dimension (M)
!>
[out]RESULT
!>          RESULT is REAL 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 crqt03.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 REAL RESULT( * ), RWORK( * )
146 COMPLEX AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
147 $ Q( LDA, * ), TAU( * ), WORK( LWORK )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 REAL ZERO, ONE
154 parameter( zero = 0.0e+0, one = 1.0e+0 )
155 COMPLEX ROGUE
156 parameter( rogue = ( -1.0e+10, -1.0e+10 ) )
157* ..
158* .. Local Scalars ..
159 CHARACTER SIDE, TRANS
160 INTEGER INFO, ISIDE, ITRANS, J, MC, MINMN, NC
161 REAL CNORM, EPS, RESID
162* ..
163* .. External Functions ..
164 LOGICAL LSAME
165 REAL CLANGE, SLAMCH
166 EXTERNAL lsame, clange, slamch
167* ..
168* .. External Subroutines ..
169 EXTERNAL cgemm, clacpy, clarnv, claset, cungrq, cunmrq
170* ..
171* .. Local Arrays ..
172 INTEGER ISEED( 4 )
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC cmplx, max, min, real
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 = slamch( '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 claset( 'Full', n, n, rogue, rogue, q, lda )
204 IF( k.GT.0 .AND. n.GT.k )
205 $ CALL clacpy( 'Full', k, n-k, af( m-k+1, 1 ), lda,
206 $ q( n-k+1, 1 ), lda )
207 IF( k.GT.1 )
208 $ CALL clacpy( '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 = 'CUNGRQ'
214 CALL cungrq( 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 clarnv( 2, iseed, mc, c( 1, j ) )
232 10 CONTINUE
233 cnorm = clange( '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 clacpy( 'Full', mc, nc, c, lda, cc, lda )
247*
248* Apply Q or Q' to C
249*
250 srnamt = 'CUNMRQ'
251 IF( k.GT.0 )
252 $ CALL cunmrq( 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 cgemm( trans, 'No transpose', mc, nc, mc,
260 $ cmplx( -one ), q, lda, c, lda, cmplx( one ),
261 $ cc, lda )
262 ELSE
263 CALL cgemm( 'No transpose', trans, mc, nc, nc,
264 $ cmplx( -one ), c, lda, q, lda, cmplx( one ),
265 $ cc, lda )
266 END IF
267*
268* Compute error in the difference
269*
270 resid = clange( '1', mc, nc, cc, lda, rwork )
271 result( ( iside-1 )*2+itrans ) = resid /
272 $ ( real( max( 1, n ) )*cnorm*eps )
273*
274 20 CONTINUE
275 30 CONTINUE
276*
277 RETURN
278*
279* End of CRQT03
280*

◆ crzt01()

real function crzt01 ( integer m,
integer n,
complex, dimension( lda, * ) a,
complex, dimension( lda, * ) af,
integer lda,
complex, dimension( * ) tau,
complex, dimension( lwork ) work,
integer lwork )

CRZT01

Purpose:
!>
!> CRZT01 returns
!>      || A - R*Q || / ( M * eps * ||A|| )
!> for an upper trapezoidal A that was factored with CTZRZF.
!>
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 array, dimension (LDA,N)
!>          The original upper trapezoidal M by N matrix A.
!>
[in]AF
!>          AF is COMPLEX array, dimension (LDA,N)
!>          The output of CTZRZF 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 array, dimension (M)
!>          Details of the  Householder transformations as returned by
!>          CTZRZF.
!>
[out]WORK
!>          WORK is COMPLEX 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 crzt01.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 A( LDA, * ), AF( LDA, * ), TAU( * ),
108 $ WORK( LWORK )
109* ..
110*
111* =====================================================================
112*
113* .. Parameters ..
114 REAL ZERO, ONE
115 parameter( zero = 0.0e0, one = 1.0e0 )
116* ..
117* .. Local Scalars ..
118 INTEGER I, INFO, J
119 REAL NORMA
120* ..
121* .. Local Arrays ..
122 REAL RWORK( 1 )
123* ..
124* .. External Functions ..
125 REAL CLANGE, SLAMCH
126 EXTERNAL clange, slamch
127* ..
128* .. External Subroutines ..
129 EXTERNAL caxpy, claset, cunmrz, xerbla
130* ..
131* .. Intrinsic Functions ..
132 INTRINSIC cmplx, max, real
133* ..
134* .. Executable Statements ..
135*
136 crzt01 = zero
137*
138 IF( lwork.LT.m*n+m ) THEN
139 CALL xerbla( 'CRZT01', 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 = clange( 'One-norm', m, n, a, lda, rwork )
149*
150* Copy upper triangle R
151*
152 CALL claset( 'Full', m, n, cmplx( zero ), cmplx( zero ), work, m )
153 DO 20 j = 1, m
154 DO 10 i = 1, j
155 work( ( j-1 )*m+i ) = af( i, j )
156 10 CONTINUE
157 20 CONTINUE
158*
159* R = R * P(1) * ... *P(m)
160*
161 CALL cunmrz( 'Right', 'No tranpose', m, n, m, n-m, af, lda, tau,
162 $ work, m, work( m*n+1 ), lwork-m*n, info )
163*
164* R = R - A
165*
166 DO 30 i = 1, n
167 CALL caxpy( m, cmplx( -one ), a( 1, i ), 1,
168 $ work( ( i-1 )*m+1 ), 1 )
169 30 CONTINUE
170*
171 crzt01 = clange( 'One-norm', m, n, work, m, rwork )
172*
173 crzt01 = crzt01 / ( slamch( 'Epsilon' )*real( max( m, n ) ) )
174 IF( norma.NE.zero )
175 $ crzt01 = crzt01 / norma
176*
177 RETURN
178*
179* End of CRZT01
180*
cunmrz
subroutine cunmrz(side, trans, m, n, k, l, a, lda, tau, c, ldc, work, lwork, info)
CUNMRZ
Definition cunmrz.f:187

◆ crzt02()

real function crzt02 ( integer m,
integer n,
complex, dimension( lda, * ) af,
integer lda,
complex, dimension( * ) tau,
complex, dimension( lwork ) work,
integer lwork )

CRZT02

Purpose:
!>
!> CRZT02 returns
!>      || I - Q'*Q || / ( M * eps)
!> where the matrix Q is defined by the Householder transformations
!> generated by CTZRZF.
!>
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 array, dimension (LDA,N)
!>          The output of CTZRZF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array AF.
!>
[in]TAU
!>          TAU is COMPLEX array, dimension (M)
!>          Details of the Householder transformations as returned by
!>          CTZRZF.
!>
[out]WORK
!>          WORK is COMPLEX 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 crzt02.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 AF( LDA, * ), TAU( * ), WORK( LWORK )
101* ..
102*
103* =====================================================================
104*
105* .. Parameters ..
106 REAL ZERO, ONE
107 parameter( zero = 0.0e0, one = 1.0e0 )
108* ..
109* .. Local Scalars ..
110 INTEGER I, INFO
111* ..
112* .. Local Arrays ..
113 REAL RWORK( 1 )
114* ..
115* .. External Functions ..
116 REAL CLANGE, SLAMCH
117 EXTERNAL clange, slamch
118* ..
119* .. External Subroutines ..
120 EXTERNAL claset, cunmrz, xerbla
121* ..
122* .. Intrinsic Functions ..
123 INTRINSIC cmplx, max, real
124* ..
125* .. Executable Statements ..
126*
127 crzt02 = zero
128*
129 IF( lwork.LT.n*n+n ) THEN
130 CALL xerbla( 'CRZT02', 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 claset( 'Full', n, n, cmplx( zero ), cmplx( one ), work, n )
142*
143* Q := P(1) * ... * P(m) * Q
144*
145 CALL cunmrz( 'Left', 'No transpose', n, n, m, n-m, af, lda, tau,
146 $ work, n, work( n*n+1 ), lwork-n*n, info )
147*
148* Q := P(m)' * ... * P(1)' * Q
149*
150 CALL cunmrz( 'Left', 'Conjugate transpose', n, n, m, n-m, af, lda,
151 $ tau, work, n, work( n*n+1 ), lwork-n*n, info )
152*
153* Q := Q - I
154*
155 DO 10 i = 1, n
156 work( ( i-1 )*n+i ) = work( ( i-1 )*n+i ) - one
157 10 CONTINUE
158*
159 crzt02 = clange( 'One-norm', n, n, work, n, rwork ) /
160 $ ( slamch( 'Epsilon' )*real( max( m, n ) ) )
161 RETURN
162*
163* End of CRZT02
164*

◆ csbmv()

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

CSBMV

Purpose:
!>
!> CSBMV  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
!>           On entry, ALPHA specifies the scalar alpha.
!>           Unchanged on exit.
!>
!>  A      - COMPLEX 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 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
!>           On entry, BETA specifies the scalar beta.
!>           Unchanged on exit.
!>
!>  Y      - COMPLEX 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 csbmv.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 ALPHA, BETA
161* ..
162* .. Array Arguments ..
163 COMPLEX A( LDA, * ), X( * ), Y( * )
164* ..
165*
166* =====================================================================
167*
168* .. Parameters ..
169 COMPLEX ONE
170 parameter( one = ( 1.0e+0, 0.0e+0 ) )
171 COMPLEX ZERO
172 parameter( zero = ( 0.0e+0, 0.0e+0 ) )
173* ..
174* .. Local Scalars ..
175 INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L
176 COMPLEX 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( 'CSBMV ', 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 CSBMV
344*

◆ cspt01()

subroutine cspt01 ( character uplo,
integer n,
complex, dimension( * ) a,
complex, dimension( * ) afac,
integer, dimension( * ) ipiv,
complex, dimension( ldc, * ) c,
integer ldc,
real, dimension( * ) rwork,
real resid )

CSPT01

Purpose:
!>
!> CSPT01 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 array, dimension (N*(N+1)/2)
!>          The original symmetric matrix A, stored as a packed
!>          triangular matrix.
!>
[in]AFAC
!>          AFAC is COMPLEX 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 CSPTRF.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from CSPTRF.
!>
[out]C
!>          C is COMPLEX array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 cspt01.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 REAL RESID
121* ..
122* .. Array Arguments ..
123 INTEGER IPIV( * )
124 REAL RWORK( * )
125 COMPLEX A( * ), AFAC( * ), C( LDC, * )
126* ..
127*
128* =====================================================================
129*
130* .. Parameters ..
131 REAL ZERO, ONE
132 parameter( zero = 0.0e+0, one = 1.0e+0 )
133 COMPLEX CZERO, CONE
134 parameter( czero = ( 0.0e+0, 0.0e+0 ),
135 $ cone = ( 1.0e+0, 0.0e+0 ) )
136* ..
137* .. Local Scalars ..
138 INTEGER I, INFO, J, JC
139 REAL ANORM, EPS
140* ..
141* .. External Functions ..
142 LOGICAL LSAME
143 REAL CLANSP, CLANSY, SLAMCH
144 EXTERNAL lsame, clansp, clansy, slamch
145* ..
146* .. External Subroutines ..
147 EXTERNAL clavsp, claset
148* ..
149* .. Intrinsic Functions ..
150 INTRINSIC real
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 = slamch( 'Epsilon' )
164 anorm = clansp( '1', uplo, n, a, rwork )
165*
166* Initialize C to the identity matrix.
167*
168 CALL claset( 'Full', n, n, czero, cone, c, ldc )
169*
170* Call CLAVSP to form the product D * U' (or D * L' ).
171*
172 CALL clavsp( uplo, 'Transpose', 'Non-unit', n, n, afac, ipiv, c,
173 $ ldc, info )
174*
175* Call CLAVSP again to multiply by U ( or L ).
176*
177 CALL clavsp( 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 = clansy( '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/real( n ) )/anorm ) / eps
209 END IF
210*
211 RETURN
212*
213* End of CSPT01
214*
clavsp
subroutine clavsp(uplo, trans, diag, n, nrhs, a, ipiv, b, ldb, info)
CLAVSP
Definition clavsp.f:131

◆ cspt02()

subroutine cspt02 ( character uplo,
integer n,
integer nrhs,
complex, dimension( * ) a,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldb, * ) b,
integer ldb,
real, dimension( * ) rwork,
real resid )

CSPT02

Purpose:
!>
!> CSPT02 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 array, dimension (N*(N+1)/2)
!>          The original complex symmetric matrix A, stored as a packed
!>          triangular matrix.
!>
[in]X
!>          X is COMPLEX 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 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 REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 cspt02.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 REAL RESID
132* ..
133* .. Array Arguments ..
134 REAL RWORK( * )
135 COMPLEX A( * ), B( LDB, * ), X( LDX, * )
136* ..
137*
138* =====================================================================
139*
140* .. Parameters ..
141 REAL ZERO, ONE
142 parameter( zero = 0.0e+0, one = 1.0e+0 )
143 COMPLEX CONE
144 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
145* ..
146* .. Local Scalars ..
147 INTEGER J
148 REAL ANORM, BNORM, EPS, XNORM
149* ..
150* .. External Functions ..
151 REAL CLANSP, SCASUM, SLAMCH
152 EXTERNAL clansp, scasum, slamch
153* ..
154* .. External Subroutines ..
155 EXTERNAL cspmv
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 = slamch( 'Epsilon' )
172 anorm = clansp( '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 cspmv( 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 = scasum( n, b( 1, j ), 1 )
191 xnorm = scasum( 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 CSPT02
202*

◆ cspt03()

subroutine cspt03 ( character uplo,
integer n,
complex, dimension( * ) a,
complex, dimension( * ) ainv,
complex, dimension( ldw, * ) work,
integer ldw,
real, dimension( * ) rwork,
real rcond,
real resid )

CSPT03

Purpose:
!>
!> CSPT03 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 array, dimension (N*(N+1)/2)
!>          The original complex symmetric matrix A, stored as a packed
!>          triangular matrix.
!>
[in]AINV
!>          AINV is COMPLEX array, dimension (N*(N+1)/2)
!>          The (symmetric) inverse of the matrix A, stored as a packed
!>          triangular matrix.
!>
[out]WORK
!>          WORK is COMPLEX array, dimension (LDW,N)
!>
[in]LDW
!>          LDW is INTEGER
!>          The leading dimension of the array WORK.  LDW >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RCOND
!>          RCOND is REAL
!>          The reciprocal of the condition number of A, computed as
!>          ( 1/norm(A) ) / norm(AINV).
!>
[out]RESID
!>          RESID is REAL
!>          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 cspt03.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 REAL RCOND, RESID
119* ..
120* .. Array Arguments ..
121 REAL RWORK( * )
122 COMPLEX A( * ), AINV( * ), WORK( LDW, * )
123* ..
124*
125* =====================================================================
126*
127* .. Parameters ..
128 REAL ZERO, ONE
129 parameter( zero = 0.0e+0, one = 1.0e+0 )
130* ..
131* .. Local Scalars ..
132 INTEGER I, ICOL, J, JCOL, K, KCOL, NALL
133 REAL AINVNM, ANORM, EPS
134 COMPLEX T
135* ..
136* .. External Functions ..
137 LOGICAL LSAME
138 REAL CLANGE, CLANSP, SLAMCH
139 COMPLEX CDOTU
140 EXTERNAL lsame, clange, clansp, slamch, cdotu
141* ..
142* .. Intrinsic Functions ..
143 INTRINSIC real
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 = slamch( 'Epsilon' )
158 anorm = clansp( '1', uplo, n, a, rwork )
159 ainvnm = clansp( '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 = cdotu( 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 = cdotu( 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 = cdotu( 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 = cdotu( 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 = clange( '1', n, n, work, ldw, rwork )
275*
276 resid = ( ( resid*rcond )/eps ) / real( n )
277*
278 RETURN
279*
280* End of CSPT03
281*

◆ csyt01()

subroutine csyt01 ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldafac, * ) afac,
integer ldafac,
integer, dimension( * ) ipiv,
complex, dimension( ldc, * ) c,
integer ldc,
real, dimension( * ) rwork,
real resid )

CSYT01

Purpose:
!>
!> CSYT01 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 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 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.
!>
[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.
!>
[out]C
!>          C is COMPLEX array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 csyt01.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 REAL RESID
134* ..
135* .. Array Arguments ..
136 INTEGER IPIV( * )
137 REAL RWORK( * )
138 COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 REAL ZERO, ONE
145 parameter( zero = 0.0e+0, one = 1.0e+0 )
146 COMPLEX CZERO, CONE
147 parameter( czero = ( 0.0e+0, 0.0e+0 ),
148 $ cone = ( 1.0e+0, 0.0e+0 ) )
149* ..
150* .. Local Scalars ..
151 INTEGER I, INFO, J
152 REAL ANORM, EPS
153* ..
154* .. External Functions ..
155 LOGICAL LSAME
156 REAL CLANSY, SLAMCH
157 EXTERNAL lsame, clansy, slamch
158* ..
159* .. External Subroutines ..
160 EXTERNAL claset, clavsy
161* ..
162* .. Intrinsic Functions ..
163 INTRINSIC real
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 = slamch( 'Epsilon' )
177 anorm = clansy( '1', uplo, n, a, lda, rwork )
178*
179* Initialize C to the identity matrix.
180*
181 CALL claset( 'Full', n, n, czero, cone, c, ldc )
182*
183* Call CLAVSY to form the product D * U' (or D * L' ).
184*
185 CALL clavsy( uplo, 'Transpose', 'Non-unit', n, n, afac, ldafac,
186 $ ipiv, c, ldc, info )
187*
188* Call CLAVSY again to multiply by U (or L ).
189*
190 CALL clavsy( 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 = clansy( '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/real( n ) )/anorm ) / eps
218 END IF
219*
220 RETURN
221*
222* End of CSYT01
223*
clavsy
subroutine clavsy(uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
CLAVSY
Definition clavsy.f:153

◆ csyt01_3()

subroutine csyt01_3 ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldafac, * ) afac,
integer ldafac,
complex, dimension( * ) e,
integer, dimension( * ) ipiv,
complex, dimension( ldc, * ) c,
integer ldc,
real, dimension( * ) rwork,
real resid )

CSYT01_3

Purpose:
!>
!> CSYT01_3 reconstructs a symmetric indefinite matrix A from its
!> block L*D*L' or U*D*U' factorization computed by CSYTRF_RK
!> (or CSYTRF_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 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 array, dimension (LDAFAC,N)
!>          Diagonal of the block diagonal matrix D and factors U or L
!>          as computed by CSYTRF_RK and CSYTRF_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 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 CSYTRF_RK (or CSYTRF_BK).
!>
[out]C
!>          C is COMPLEX array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 csyt01_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 REAL RESID
150* ..
151* .. Array Arguments ..
152 INTEGER IPIV( * )
153 REAL RWORK( * )
154 COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
155 $ E( * )
156* ..
157*
158* =====================================================================
159*
160* .. Parameters ..
161 REAL ZERO, ONE
162 parameter( zero = 0.0e+0, one = 1.0e+0 )
163 COMPLEX CZERO, CONE
164 parameter( czero = ( 0.0e+0, 0.0e+0 ),
165 $ cone = ( 1.0e+0, 0.0e+0 ) )
166* ..
167* .. Local Scalars ..
168 INTEGER I, INFO, J
169 REAL ANORM, EPS
170* ..
171* .. External Functions ..
172 LOGICAL LSAME
173 REAL SLAMCH, CLANSY
174 EXTERNAL lsame, slamch, clansy
175* ..
176* .. External Subroutines ..
177 EXTERNAL claset, clavsy_rook, csyconvf_rook
178* ..
179* .. Intrinsic Functions ..
180 INTRINSIC real
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 csyconvf_rook( uplo, 'R', n, afac, ldafac, e, ipiv, info )
194*
195* 1) Determine EPS and the norm of A.
196*
197 eps = slamch( 'Epsilon' )
198 anorm = clansy( '1', uplo, n, a, lda, rwork )
199*
200* 2) Initialize C to the identity matrix.
201*
202 CALL claset( '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 clavsy_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 clavsy_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 = clansy( '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 / real( n ) ) / anorm ) / eps
239 END IF
240
241*
242* b) Convert to factor of L (or U)
243*
244 CALL csyconvf_rook( uplo, 'C', n, afac, ldafac, e, ipiv, info )
245*
246 RETURN
247*
248* End of CSYT01_3
249*
clavsy_rook
subroutine clavsy_rook(uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
CLAVSY_ROOK
Definition clavsy_rook.f:155

◆ csyt01_aa()

subroutine csyt01_aa ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldafac, * ) afac,
integer ldafac,
integer, dimension( * ) ipiv,
complex, dimension( ldc, * ) c,
integer ldc,
real, dimension( * ) rwork,
real resid )

CSYT01

Purpose:
!>
!> CSYT01 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 REAL 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 REAL 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.
!>
[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.
!>
[out]C
!>          C is REAL array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 csyt01_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 REAL RESID
133* ..
134* .. Array Arguments ..
135 INTEGER IPIV( * )
136 COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
137 REAL RWORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ZERO, ONE
144 parameter( zero = 0.0d+0, one = 1.0d+0 )
145 COMPLEX CZERO, CONE
146 parameter( czero = 0.0e+0, cone = 1.0e+0 )
147* ..
148* .. Local Scalars ..
149 INTEGER I, J
150 REAL ANORM, EPS
151* ..
152* .. External Functions ..
153 LOGICAL LSAME
154 REAL SLAMCH, CLANSY
155 EXTERNAL lsame, slamch, clansy
156* ..
157* .. External Subroutines ..
158 EXTERNAL claset, clavsy
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 = slamch( 'Epsilon' )
175 anorm = clansy( '1', uplo, n, a, lda, rwork )
176*
177* Initialize C to the tridiagonal matrix T.
178*
179 CALL claset( 'Full', n, n, czero, czero, c, ldc )
180 CALL clacpy( '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 clacpy( 'F', 1, n-1, afac( 1, 2 ), ldafac+1, c( 1, 2 ),
184 $ ldc+1 )
185 CALL clacpy( 'F', 1, n-1, afac( 1, 2 ), ldafac+1, c( 2, 1 ),
186 $ ldc+1 )
187 ELSE
188 CALL clacpy( 'F', 1, n-1, afac( 2, 1 ), ldafac+1, c( 1, 2 ),
189 $ ldc+1 )
190 CALL clacpy( 'F', 1, n-1, afac( 2, 1 ), ldafac+1, c( 2, 1 ),
191 $ ldc+1 )
192 ENDIF
193*
194* Call CTRMM to form the product U' * D (or L * D ).
195*
196 IF( lsame( uplo, 'U' ) ) THEN
197 CALL ctrmm( 'Left', uplo, 'Transpose', 'Unit', n-1, n,
198 $ cone, afac( 1, 2 ), ldafac, c( 2, 1 ), ldc )
199 ELSE
200 CALL ctrmm( 'Left', uplo, 'No transpose', 'Unit', n-1, n,
201 $ cone, afac( 2, 1 ), ldafac, c( 2, 1 ), ldc )
202 END IF
203*
204* Call CTRMM again to multiply by U (or L ).
205*
206 IF( lsame( uplo, 'U' ) ) THEN
207 CALL ctrmm( 'Right', uplo, 'No transpose', 'Unit', n, n-1,
208 $ cone, afac( 1, 2 ), ldafac, c( 1, 2 ), ldc )
209 ELSE
210 CALL ctrmm( '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 cswap( 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 cswap( 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 = clansy( '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 CSYT01_AA
259*

◆ csyt01_rook()

subroutine csyt01_rook ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldafac, * ) afac,
integer ldafac,
integer, dimension( * ) ipiv,
complex, dimension( ldc, * ) c,
integer ldc,
real, dimension( * ) rwork,
real resid )

CSYT01_ROOK

Purpose:
!>
!> CSYT01_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 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 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 array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 csyt01_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 REAL RESID
134* ..
135* .. Array Arguments ..
136 INTEGER IPIV( * )
137 REAL RWORK( * )
138 COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 REAL ZERO, ONE
145 parameter( zero = 0.0e+0, one = 1.0e+0 )
146 COMPLEX CZERO, CONE
147 parameter( czero = ( 0.0e+0, 0.0e+0 ),
148 $ cone = ( 1.0e+0, 0.0e+0 ) )
149* ..
150* .. Local Scalars ..
151 INTEGER I, INFO, J
152 REAL ANORM, EPS
153* ..
154* .. External Functions ..
155 LOGICAL LSAME
156 REAL CLANSY, SLAMCH
157 EXTERNAL lsame, clansy, slamch
158* ..
159* .. External Subroutines ..
160 EXTERNAL claset, clavsy_rook
161* ..
162* .. Intrinsic Functions ..
163 INTRINSIC real
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 = slamch( 'Epsilon' )
177 anorm = clansy( '1', uplo, n, a, lda, rwork )
178*
179* Initialize C to the identity matrix.
180*
181 CALL claset( 'Full', n, n, czero, cone, c, ldc )
182*
183* Call CLAVSY_ROOK to form the product D * U' (or D * L' ).
184*
185 CALL clavsy_rook( uplo, 'Transpose', 'Non-unit', n, n, afac,
186 $ ldafac, ipiv, c, ldc, info )
187*
188* Call CLAVSY_ROOK again to multiply by U (or L ).
189*
190 CALL clavsy_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 = clansy( '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/real( n ) )/anorm ) / eps
218 END IF
219*
220 RETURN
221*
222* End of CSYT01_ROOK
223*

◆ csyt02()

subroutine csyt02 ( character uplo,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldb, * ) b,
integer ldb,
real, dimension( * ) rwork,
real resid )

CSYT02

Purpose:
!>
!> CSYT02 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 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 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 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 REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 csyt02.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 REAL RESID
136* ..
137* .. Array Arguments ..
138 REAL RWORK( * )
139 COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * )
140* ..
141*
142* =====================================================================
143*
144* .. Parameters ..
145 REAL ZERO, ONE
146 parameter( zero = 0.0e+0, one = 1.0e+0 )
147 COMPLEX CONE
148 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
149* ..
150* .. Local Scalars ..
151 INTEGER J
152 REAL ANORM, BNORM, EPS, XNORM
153* ..
154* .. External Functions ..
155 REAL CLANSY, SCASUM, SLAMCH
156 EXTERNAL clansy, scasum, slamch
157* ..
158* .. External Subroutines ..
159 EXTERNAL csymm
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 = slamch( 'Epsilon' )
176 anorm = clansy( '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 csymm( '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 = scasum( n, b( 1, j ), 1 )
193 xnorm = scasum( 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 CSYT02
204*

◆ csyt03()

subroutine csyt03 ( character uplo,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldainv, * ) ainv,
integer ldainv,
complex, dimension( ldwork, * ) work,
integer ldwork,
real, dimension( * ) rwork,
real rcond,
real resid )

CSYT03

Purpose:
!>
!> CSYT03 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 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 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 array, dimension (LDWORK,N)
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.  LDWORK >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RCOND
!>          RCOND is REAL
!>          The reciprocal of the condition number of A, computed as
!>          RCOND = 1/ (norm(A) * norm(AINV)).
!>
[out]RESID
!>          RESID is REAL
!>          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 csyt03.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 REAL RCOND, RESID
135* ..
136* .. Array Arguments ..
137 REAL RWORK( * )
138 COMPLEX A( LDA, * ), AINV( LDAINV, * ),
139 $ WORK( LDWORK, * )
140* ..
141*
142* =====================================================================
143*
144*
145* .. Parameters ..
146 REAL ZERO, ONE
147 parameter( zero = 0.0e+0, one = 1.0e+0 )
148 COMPLEX CZERO, CONE
149 parameter( czero = ( 0.0e+0, 0.0e+0 ),
150 $ cone = ( 1.0e+0, 0.0e+0 ) )
151* ..
152* .. Local Scalars ..
153 INTEGER I, J
154 REAL AINVNM, ANORM, EPS
155* ..
156* .. External Functions ..
157 LOGICAL LSAME
158 REAL CLANGE, CLANSY, SLAMCH
159 EXTERNAL lsame, clange, clansy, slamch
160* ..
161* .. External Subroutines ..
162 EXTERNAL csymm
163* ..
164* .. Intrinsic Functions ..
165 INTRINSIC real
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 = slamch( 'Epsilon' )
180 anorm = clansy( '1', uplo, n, a, lda, rwork )
181 ainvnm = clansy( '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 CSYMM 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 csymm( '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 = clange( '1', n, n, work, ldwork, rwork )
217*
218 resid = ( ( resid*rcond )/eps ) / real( n )
219*
220 RETURN
221*
222* End of CSYT03
223*

◆ ctbt02()

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

CTBT02

Purpose:
!>
!> CTBT02 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 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 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 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 array, dimension (N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 ctbt02.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 REAL RESID
168* ..
169* .. Array Arguments ..
170 REAL RWORK( * )
171 COMPLEX AB( LDAB, * ), B( LDB, * ), WORK( * ),
172 $ X( LDX, * )
173* ..
174*
175* =====================================================================
176*
177* .. Parameters ..
178 REAL ZERO, ONE
179 parameter( zero = 0.0e+0, one = 1.0e+0 )
180* ..
181* .. Local Scalars ..
182 INTEGER J
183 REAL ANORM, BNORM, EPS, XNORM
184* ..
185* .. External Functions ..
186 LOGICAL LSAME
187 REAL CLANTB, SCASUM, SLAMCH
188 EXTERNAL lsame, clantb, scasum, slamch
189* ..
190* .. External Subroutines ..
191 EXTERNAL caxpy, ccopy, ctbmv
192* ..
193* .. Intrinsic Functions ..
194 INTRINSIC cmplx, 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 = clantb( '1', uplo, diag, n, kd, ab, ldab, rwork )
209 ELSE
210 anorm = clantb( 'I', uplo, diag, n, kd, ab, ldab, rwork )
211 END IF
212*
213* Exit with RESID = 1/EPS if ANORM = 0.
214*
215 eps = slamch( '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 ccopy( n, x( 1, j ), 1, work, 1 )
227 CALL ctbmv( uplo, trans, diag, n, kd, ab, ldab, work, 1 )
228 CALL caxpy( n, cmplx( -one ), b( 1, j ), 1, work, 1 )
229 bnorm = scasum( n, work, 1 )
230 xnorm = scasum( 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 CTBT02
241*

◆ ctbt03()

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

CTBT03

Purpose:
!>
!> CTBT03 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 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 REAL
!>          The scaling factor s used in solving the triangular system.
!>
[in]CNORM
!>          CNORM is REAL array, dimension (N)
!>          The 1-norms of the columns of A, not counting the diagonal.
!>
[in]TSCAL
!>          TSCAL is REAL
!>          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 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 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 array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 ctbt03.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 REAL RESID, SCALE, TSCAL
186* ..
187* .. Array Arguments ..
188 REAL CNORM( * )
189 COMPLEX AB( LDAB, * ), B( LDB, * ), WORK( * ),
190 $ X( LDX, * )
191* ..
192*
193* =====================================================================
194*
195*
196* .. Parameters ..
197 REAL ONE, ZERO
198 parameter( one = 1.0e+0, zero = 0.0e+0 )
199* ..
200* .. Local Scalars ..
201 INTEGER IX, J
202 REAL EPS, ERR, SMLNUM, TNORM, XNORM, XSCAL
203* ..
204* .. External Functions ..
205 LOGICAL LSAME
206 INTEGER ICAMAX
207 REAL SLAMCH
208 EXTERNAL lsame, icamax, slamch
209* ..
210* .. External Subroutines ..
211 EXTERNAL caxpy, ccopy, csscal, ctbmv
212* ..
213* .. Intrinsic Functions ..
214 INTRINSIC abs, cmplx, max, real
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 = slamch( 'Epsilon' )
225 smlnum = slamch( 'Safe minimum' )
226*
227* Compute the norm of the triangular matrix A using the column
228* norms already computed by CLATBS.
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 ccopy( n, x( 1, j ), 1, work, 1 )
254 ix = icamax( n, work, 1 )
255 xnorm = max( one, abs( x( ix, j ) ) )
256 xscal = ( one / xnorm ) / real( kd+1 )
257 CALL csscal( n, xscal, work, 1 )
258 CALL ctbmv( uplo, trans, diag, n, kd, ab, ldab, work, 1 )
259 CALL caxpy( n, cmplx( -scale*xscal ), b( 1, j ), 1, work, 1 )
260 ix = icamax( n, work, 1 )
261 err = tscal*abs( work( ix ) )
262 ix = icamax( 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 CTBT03
284*

◆ ctbt05()

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

CTBT05

Purpose:
!>
!> CTBT05 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 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 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 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 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 REAL 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 REAL 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 REAL 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 ctbt05.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 REAL BERR( * ), FERR( * ), RESLTS( * )
200 COMPLEX AB( LDAB, * ), B( LDB, * ), X( LDX, * ),
201 $ XACT( LDXACT, * )
202* ..
203*
204* =====================================================================
205*
206* .. Parameters ..
207 REAL ZERO, ONE
208 parameter( zero = 0.0e+0, one = 1.0e+0 )
209* ..
210* .. Local Scalars ..
211 LOGICAL NOTRAN, UNIT, UPPER
212 INTEGER I, IFU, IMAX, J, K, NZ
213 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
214 COMPLEX ZDUM
215* ..
216* .. External Functions ..
217 LOGICAL LSAME
218 INTEGER ICAMAX
219 REAL SLAMCH
220 EXTERNAL lsame, icamax, slamch
221* ..
222* .. Intrinsic Functions ..
223 INTRINSIC abs, aimag, max, min, real
224* ..
225* .. Statement Functions ..
226 REAL CABS1
227* ..
228* .. Statement Function definitions ..
229 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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 = slamch( 'Epsilon' )
242 unfl = slamch( '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 = icamax( 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 CTBT05
339*

◆ ctbt06()

subroutine ctbt06 ( real rcond,
real rcondc,
character uplo,
character diag,
integer n,
integer kd,
complex, dimension( ldab, * ) ab,
integer ldab,
real, dimension( * ) rwork,
real rat )

CTBT06

Purpose:
!>
!> CTBT06 computes a test ratio comparing RCOND (the reciprocal
!> condition number of a triangular matrix A) and RCONDC, the estimate
!> computed by CTBCON.  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 REAL
!>          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 REAL
!>          The estimate of the reciprocal condition number computed by
!>          CTBCON.
!>
[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 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 REAL array, dimension (N)
!>
[out]RAT
!>          RAT is REAL
!>          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 ctbt06.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 REAL RAT, RCOND, RCONDC
135* ..
136* .. Array Arguments ..
137 REAL RWORK( * )
138 COMPLEX AB( LDAB, * )
139* ..
140*
141* =====================================================================
142*
143* .. Parameters ..
144 REAL ZERO, ONE
145 parameter( zero = 0.0e+0, one = 1.0e+0 )
146* ..
147* .. Local Scalars ..
148 REAL ANORM, BIGNUM, EPS, RMAX, RMIN
149* ..
150* .. External Functions ..
151 REAL CLANTB, SLAMCH
152 EXTERNAL clantb, slamch
153* ..
154* .. Intrinsic Functions ..
155 INTRINSIC max, min
156* ..
157* .. Executable Statements ..
158*
159 eps = slamch( '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 / slamch( 'Safe minimum' )
192 anorm = clantb( '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 CTBT06
200*

◆ ctpt01()

subroutine ctpt01 ( character uplo,
character diag,
integer n,
complex, dimension( * ) ap,
complex, dimension( * ) ainvp,
real rcond,
real, dimension( * ) rwork,
real resid )

CTPT01

Purpose:
!>
!> CTPT01 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 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 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 REAL
!>          The reciprocal condition number of A, computed as
!>          1/(norm(A) * norm(AINV)).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 ctpt01.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 REAL RCOND, RESID
118* ..
119* .. Array Arguments ..
120 REAL RWORK( * )
121 COMPLEX AINVP( * ), AP( * )
122* ..
123*
124* =====================================================================
125*
126* .. Parameters ..
127 REAL ZERO, ONE
128 parameter( zero = 0.0e+0, one = 1.0e+0 )
129* ..
130* .. Local Scalars ..
131 LOGICAL UNITD
132 INTEGER J, JC
133 REAL AINVNM, ANORM, EPS
134* ..
135* .. External Functions ..
136 LOGICAL LSAME
137 REAL CLANTP, SLAMCH
138 EXTERNAL lsame, clantp, slamch
139* ..
140* .. External Subroutines ..
141 EXTERNAL ctpmv
142* ..
143* .. Intrinsic Functions ..
144 INTRINSIC real
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 = slamch( 'Epsilon' )
159 anorm = clantp( '1', uplo, diag, n, ap, rwork )
160 ainvnm = clantp( '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 ctpmv( '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 ctpmv( '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 = clantp( '1', uplo, 'Non-unit', n, ainvp, rwork )
208*
209 resid = ( ( resid*rcond ) / real( n ) ) / eps
210*
211 RETURN
212*
213* End of CTPT01
214*

◆ ctpt02()

subroutine ctpt02 ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex, dimension( * ) ap,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( * ) work,
real, dimension( * ) rwork,
real resid )

CTPT02

Purpose:
!>
!> CTPT02 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 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 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 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 array, dimension (N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*B - 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 ctpt02.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 REAL RESID
156* ..
157* .. Array Arguments ..
158 REAL RWORK( * )
159 COMPLEX AP( * ), B( LDB, * ), WORK( * ), X( LDX, * )
160* ..
161*
162* =====================================================================
163*
164* .. Parameters ..
165 REAL ZERO, ONE
166 parameter( zero = 0.0e+0, one = 1.0e+0 )
167* ..
168* .. Local Scalars ..
169 INTEGER J
170 REAL ANORM, BNORM, EPS, XNORM
171* ..
172* .. External Functions ..
173 LOGICAL LSAME
174 REAL CLANTP, SCASUM, SLAMCH
175 EXTERNAL lsame, clantp, scasum, slamch
176* ..
177* .. External Subroutines ..
178 EXTERNAL caxpy, ccopy, ctpmv
179* ..
180* .. Intrinsic Functions ..
181 INTRINSIC cmplx, 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 = clantp( '1', uplo, diag, n, ap, rwork )
196 ELSE
197 anorm = clantp( 'I', uplo, diag, n, ap, rwork )
198 END IF
199*
200* Exit with RESID = 1/EPS if ANORM = 0.
201*
202 eps = slamch( '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 ccopy( n, x( 1, j ), 1, work, 1 )
214 CALL ctpmv( uplo, trans, diag, n, ap, work, 1 )
215 CALL caxpy( n, cmplx( -one ), b( 1, j ), 1, work, 1 )
216 bnorm = scasum( n, work, 1 )
217 xnorm = scasum( 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 CTPT02
228*

◆ ctpt03()

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

CTPT03

Purpose:
!>
!> CTPT03 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 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 REAL
!>          The scaling factor s used in solving the triangular system.
!>
[in]CNORM
!>          CNORM is REAL array, dimension (N)
!>          The 1-norms of the columns of A, not counting the diagonal.
!>
[in]TSCAL
!>          TSCAL is REAL
!>          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 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 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 array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 ctpt03.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 REAL RESID, SCALE, TSCAL
171* ..
172* .. Array Arguments ..
173 REAL CNORM( * )
174 COMPLEX AP( * ), B( LDB, * ), WORK( * ), X( LDX, * )
175* ..
176*
177* =====================================================================
178*
179* .. Parameters ..
180 REAL ONE, ZERO
181 parameter( one = 1.0e+0, zero = 0.0e+0 )
182* ..
183* .. Local Scalars ..
184 INTEGER IX, J, JJ
185 REAL EPS, ERR, SMLNUM, TNORM, XNORM, XSCAL
186* ..
187* .. External Functions ..
188 LOGICAL LSAME
189 INTEGER ICAMAX
190 REAL SLAMCH
191 EXTERNAL lsame, icamax, slamch
192* ..
193* .. External Subroutines ..
194 EXTERNAL caxpy, ccopy, csscal, ctpmv
195* ..
196* .. Intrinsic Functions ..
197 INTRINSIC abs, cmplx, max, real
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 = slamch( 'Epsilon' )
208 smlnum = slamch( 'Safe minimum' )
209*
210* Compute the norm of the triangular matrix A using the column
211* norms already computed by CLATPS.
212*
213 tnorm = 0.
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 + 1
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 ccopy( n, x( 1, j ), 1, work, 1 )
240 ix = icamax( n, work, 1 )
241 xnorm = max( one, abs( x( ix, j ) ) )
242 xscal = ( one / xnorm ) / real( n )
243 CALL csscal( n, xscal, work, 1 )
244 CALL ctpmv( uplo, trans, diag, n, ap, work, 1 )
245 CALL caxpy( n, cmplx( -scale*xscal ), b( 1, j ), 1, work, 1 )
246 ix = icamax( n, work, 1 )
247 err = tscal*abs( work( ix ) )
248 ix = icamax( 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 CTPT03
270*

◆ ctpt05()

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

CTPT05

Purpose:
!>
!> CTPT05 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 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 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 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 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 REAL 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 REAL 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 REAL 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 ctpt05.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 REAL BERR( * ), FERR( * ), RESLTS( * )
186 COMPLEX AP( * ), B( LDB, * ), X( LDX, * ),
187 $ XACT( LDXACT, * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 REAL ZERO, ONE
194 parameter( zero = 0.0e+0, one = 1.0e+0 )
195* ..
196* .. Local Scalars ..
197 LOGICAL NOTRAN, UNIT, UPPER
198 INTEGER I, IFU, IMAX, J, JC, K
199 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
200 COMPLEX ZDUM
201* ..
202* .. External Functions ..
203 LOGICAL LSAME
204 INTEGER ICAMAX
205 REAL SLAMCH
206 EXTERNAL lsame, icamax, slamch
207* ..
208* .. Intrinsic Functions ..
209 INTRINSIC abs, aimag, max, min, real
210* ..
211* .. Statement Functions ..
212 REAL CABS1
213* ..
214* .. Statement Function definitions ..
215 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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 = slamch( 'Epsilon' )
228 unfl = slamch( '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 = icamax( 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 CTPT05
330*

◆ ctpt06()

subroutine ctpt06 ( real rcond,
real rcondc,
character uplo,
character diag,
integer n,
complex, dimension( * ) ap,
real, dimension( * ) rwork,
real rat )

CTPT06

Purpose:
!>
!> CTPT06 computes a test ratio comparing RCOND (the reciprocal
!> condition number of the triangular matrix A) and RCONDC, the estimate
!> computed by CTPCON.  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 REAL
!>          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 REAL
!>          The estimate of the reciprocal condition number computed by
!>          CTPCON.
!>
[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 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 REAL array, dimension (N)
!>
[out]RAT
!>          RAT is REAL
!>          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 ctpt06.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 REAL RAT, RCOND, RCONDC
121* ..
122* .. Array Arguments ..
123 REAL RWORK( * )
124 COMPLEX AP( * )
125* ..
126*
127* =====================================================================
128*
129* .. Parameters ..
130 REAL ZERO, ONE
131 parameter( zero = 0.0e+0, one = 1.0e+0 )
132* ..
133* .. Local Scalars ..
134 REAL ANORM, BIGNUM, EPS, RMAX, RMIN
135* ..
136* .. External Functions ..
137 REAL CLANTP, SLAMCH
138 EXTERNAL clantp, slamch
139* ..
140* .. Intrinsic Functions ..
141 INTRINSIC max, min
142* ..
143* .. Executable Statements ..
144*
145 eps = slamch( '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 / slamch( 'Safe minimum' )
178 anorm = clantp( '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 CTPT06
186*

◆ ctrt01()

subroutine ctrt01 ( character uplo,
character diag,
integer n,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldainv, * ) ainv,
integer ldainv,
real rcond,
real, dimension( * ) rwork,
real resid )

CTRT01

Purpose:
!>
!> CTRT01 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 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 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 REAL
!>          The reciprocal condition number of A, computed as
!>          1/(norm(A) * norm(AINV)).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 ctrt01.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 REAL RCOND, RESID
134* ..
135* .. Array Arguments ..
136 REAL RWORK( * )
137 COMPLEX A( LDA, * ), AINV( LDAINV, * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ZERO, ONE
144 parameter( zero = 0.0e+0, one = 1.0e+0 )
145* ..
146* .. Local Scalars ..
147 INTEGER J
148 REAL AINVNM, ANORM, EPS
149* ..
150* .. External Functions ..
151 LOGICAL LSAME
152 REAL CLANTR, SLAMCH
153 EXTERNAL lsame, clantr, slamch
154* ..
155* .. External Subroutines ..
156 EXTERNAL ctrmv
157* ..
158* .. Intrinsic Functions ..
159 INTRINSIC real
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 = slamch( 'Epsilon' )
174 anorm = clantr( '1', uplo, diag, n, n, a, lda, rwork )
175 ainvnm = clantr( '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 ctrmv( '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 ctrmv( '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 = clantr( '1', uplo, 'Non-unit', n, n, ainv, ldainv, rwork )
214*
215 resid = ( ( resid*rcond ) / real( n ) ) / eps
216*
217 RETURN
218*
219* End of CTRT01
220*

◆ ctrt02()

subroutine ctrt02 ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
complex, dimension( lda, * ) a,
integer lda,
complex, dimension( ldx, * ) x,
integer ldx,
complex, dimension( ldb, * ) b,
integer ldb,
complex, dimension( * ) work,
real, dimension( * ) rwork,
real resid )

CTRT02

Purpose:
!>
!> CTRT02 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 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 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 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 array, dimension (N)
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 ctrt02.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 REAL RESID
164* ..
165* .. Array Arguments ..
166 REAL RWORK( * )
167 COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ),
168 $ X( LDX, * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 REAL ZERO, ONE
175 parameter( zero = 0.0e+0, one = 1.0e+0 )
176* ..
177* .. Local Scalars ..
178 INTEGER J
179 REAL ANORM, BNORM, EPS, XNORM
180* ..
181* .. External Functions ..
182 LOGICAL LSAME
183 REAL CLANTR, SCASUM, SLAMCH
184 EXTERNAL lsame, clantr, scasum, slamch
185* ..
186* .. External Subroutines ..
187 EXTERNAL caxpy, ccopy, ctrmv
188* ..
189* .. Intrinsic Functions ..
190 INTRINSIC cmplx, 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 = clantr( '1', uplo, diag, n, n, a, lda, rwork )
205 ELSE
206 anorm = clantr( 'I', uplo, diag, n, n, a, lda, rwork )
207 END IF
208*
209* Exit with RESID = 1/EPS if ANORM = 0.
210*
211 eps = slamch( '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 ccopy( n, x( 1, j ), 1, work, 1 )
223 CALL ctrmv( uplo, trans, diag, n, a, lda, work, 1 )
224 CALL caxpy( n, cmplx( -one ), b( 1, j ), 1, work, 1 )
225 bnorm = scasum( n, work, 1 )
226 xnorm = scasum( 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 CTRT02
237*

◆ ctrt03()

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

CTRT03

Purpose:
!>
!> CTRT03 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 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 REAL
!>          The scaling factor s used in solving the triangular system.
!>
[in]CNORM
!>          CNORM is REAL array, dimension (N)
!>          The 1-norms of the columns of A, not counting the diagonal.
!>
[in]TSCAL
!>          TSCAL is REAL
!>          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 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 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 array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 ctrt03.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 REAL RESID, SCALE, TSCAL
180* ..
181* .. Array Arguments ..
182 REAL CNORM( * )
183 COMPLEX A( LDA, * ), B( LDB, * ), WORK( * ),
184 $ X( LDX, * )
185* ..
186*
187* =====================================================================
188*
189* .. Parameters ..
190 REAL ONE, ZERO
191 parameter( one = 1.0e+0, zero = 0.0e+0 )
192* ..
193* .. Local Scalars ..
194 INTEGER IX, J
195 REAL EPS, ERR, SMLNUM, TNORM, XNORM, XSCAL
196* ..
197* .. External Functions ..
198 LOGICAL LSAME
199 INTEGER ICAMAX
200 REAL SLAMCH
201 EXTERNAL lsame, icamax, slamch
202* ..
203* .. External Subroutines ..
204 EXTERNAL caxpy, ccopy, csscal, ctrmv
205* ..
206* .. Intrinsic Functions ..
207 INTRINSIC abs, cmplx, max, real
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 = slamch( 'Epsilon' )
218 smlnum = slamch( 'Safe minimum' )
219*
220* Compute the norm of the triangular matrix A using the column
221* norms already computed by CLATRS.
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 ccopy( n, x( 1, j ), 1, work, 1 )
240 ix = icamax( n, work, 1 )
241 xnorm = max( one, abs( x( ix, j ) ) )
242 xscal = ( one / xnorm ) / real( n )
243 CALL csscal( n, xscal, work, 1 )
244 CALL ctrmv( uplo, trans, diag, n, a, lda, work, 1 )
245 CALL caxpy( n, cmplx( -scale*xscal ), b( 1, j ), 1, work, 1 )
246 ix = icamax( n, work, 1 )
247 err = tscal*abs( work( ix ) )
248 ix = icamax( 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 CTRT03
270*

◆ ctrt05()

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

CTRT05

Purpose:
!>
!> CTRT05 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 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 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 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 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 REAL 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 REAL 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 REAL 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 ctrt05.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 REAL BERR( * ), FERR( * ), RESLTS( * )
193 COMPLEX A( LDA, * ), B( LDB, * ), X( LDX, * ),
194 $ XACT( LDXACT, * )
195* ..
196*
197* =====================================================================
198*
199* .. Parameters ..
200 REAL ZERO, ONE
201 parameter( zero = 0.0e+0, one = 1.0e+0 )
202* ..
203* .. Local Scalars ..
204 LOGICAL NOTRAN, UNIT, UPPER
205 INTEGER I, IFU, IMAX, J, K
206 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
207 COMPLEX ZDUM
208* ..
209* .. External Functions ..
210 LOGICAL LSAME
211 INTEGER ICAMAX
212 REAL SLAMCH
213 EXTERNAL lsame, icamax, slamch
214* ..
215* .. Intrinsic Functions ..
216 INTRINSIC abs, aimag, max, min, real
217* ..
218* .. Statement Functions ..
219 REAL CABS1
220* ..
221* .. Statement Function definitions ..
222 cabs1( zdum ) = abs( real( zdum ) ) + abs( aimag( 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 = slamch( 'Epsilon' )
235 unfl = slamch( '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 = icamax( 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 CTRT05
328*

◆ ctrt06()

subroutine ctrt06 ( real rcond,
real rcondc,
character uplo,
character diag,
integer n,
complex, dimension( lda, * ) a,
integer lda,
real, dimension( * ) rwork,
real rat )

CTRT06

Purpose:
!>
!> CTRT06 computes a test ratio comparing RCOND (the reciprocal
!> condition number of a triangular matrix A) and RCONDC, the estimate
!> computed by CTRCON.  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 REAL
!>          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 REAL
!>          The estimate of the reciprocal condition number computed by
!>          CTRCON.
!>
[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 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 REAL array, dimension (N)
!>
[out]RAT
!>          RAT is REAL
!>          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 ctrt06.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 REAL RAT, RCOND, RCONDC
131* ..
132* .. Array Arguments ..
133 REAL RWORK( * )
134 COMPLEX A( LDA, * )
135* ..
136*
137* =====================================================================
138*
139* .. Parameters ..
140 REAL ZERO, ONE
141 parameter( zero = 0.0e+0, one = 1.0e+0 )
142* ..
143* .. Local Scalars ..
144 REAL ANORM, BIGNUM, EPS, RMAX, RMIN
145* ..
146* .. External Functions ..
147 REAL CLANTR, SLAMCH
148 EXTERNAL clantr, slamch
149* ..
150* .. Intrinsic Functions ..
151 INTRINSIC max, min
152* ..
153* .. Executable Statements ..
154*
155 eps = slamch( '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 / slamch( 'Safe minimum' )
188 anorm = clantr( '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 CTRT06
196*

◆ cunhr_col01()

subroutine cunhr_col01 ( integer m,
integer n,
integer mb1,
integer nb1,
integer nb2,
real, dimension(6) result )

CUNHR_COL01

Purpose:
!>
!> CUNHR_COL01 tests CUNGTSQR and CUNHR_COL using CLATSQR, CGEMQRT.
!> Therefore, CLATSQR (part of CGEQR), CGEMQRT (part of CGEMQR)
!> 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 REAL 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 CGEQRT 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 CGEMQRT,
!>
!>            Q * C, (Q**H) * C, D * Q, D * (Q**H)  are
!>            computed using CGEMM.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 118 of file cunhr_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 REAL RESULT(6)
129*
130* =====================================================================
131*
132* ..
133* .. Local allocatable arrays
134 COMPLEX , ALLOCATABLE :: A(:,:), AF(:,:), Q(:,:), R(:,:),
135 $ WORK( : ), T1(:,:), T2(:,:), DIAG(:),
136 $ C(:,:), CF(:,:), D(:,:), DF(:,:)
137 REAL , ALLOCATABLE :: RWORK(:)
138*
139* .. Parameters ..
140 REAL ZERO
141 parameter( zero = 0.0e+0 )
142 COMPLEX CONE, CZERO
143 parameter( cone = ( 1.0e+0, 0.0e+0 ),
144 $ czero = ( 0.0e+0, 0.0e+0 ) )
145* ..
146* .. Local Scalars ..
147 LOGICAL TESTZEROS
148 INTEGER INFO, I, J, K, L, LWORK, NB1_UB, NB2_UB, NRB
149 REAL ANORM, EPS, RESID, CNORM, DNORM
150* ..
151* .. Local Arrays ..
152 INTEGER ISEED( 4 )
153 COMPLEX WORKQUERY( 1 )
154* ..
155* .. External Functions ..
156 REAL SLAMCH, CLANGE, CLANSY
157 EXTERNAL slamch, clange, clansy
158* ..
159* .. External Subroutines ..
160 EXTERNAL clacpy, clarnv, claset, clatsqr, cunhr_col,
161 $ cungtsqr, cscal, cgemm, cgemqrt, cherk
162* ..
163* .. Intrinsic Functions ..
164 INTRINSIC ceiling, real, 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 = slamch( '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 clarnv( 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 clarnv( 2, iseed, m/2, a( m/4, j ) )
198 END DO
199 END IF
200 END IF
201 CALL clacpy( 'Full', m, n, a, m, af, m )
202*
203* Number of row blocks in CLATSQR
204*
205 nrb = max( 1, ceiling( real( m - n ) / real( 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* CLATSQR requires NB1 to be bounded by N.
214*
215 nb1_ub = min( nb1, n)
216*
217* CGEMQRT requires NB2 to be bounded by N.
218*
219 nb2_ub = min( nb2, n)
220*
221 CALL clatsqr( m, n, mb1, nb1_ub, af, m, t1, nb1,
222 $ workquery, -1, info )
223 lwork = int( workquery( 1 ) )
224 CALL cungtsqr( m, n, mb1, nb1, af, m, t1, nb1, workquery, -1,
225 $ info )
226
227 lwork = max( lwork, int( workquery( 1 ) ) )
228*
229* In CGEMQRT, 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 = 'CLATSQR'
244 CALL clatsqr( 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 = 'CLACPY'
250 CALL clacpy( 'U', n, n, af, m, r, m )
251*
252* Reconstruct the orthogonal matrix Q.
253*
254 srnamt = 'CUNGTSQR'
255 CALL cungtsqr( 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 = 'CUNHR_COL'
262 CALL cunhr_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 CGEQRT. 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 = 'CLACPY'
272 CALL clacpy( 'U', n, n, r, m, af, m )
273*
274 DO i = 1, n
275 IF( diag( i ).EQ.-cone ) THEN
276 CALL cscal( 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 claset( 'Full', m, m, czero, cone, q, m )
286*
287 srnamt = 'CGEMQRT'
288 CALL cgemqrt( 'L', 'N', m, m, k, nb2_ub, af, m, t2, nb2, q, m,
289 $ work, info )
290*
291* Copy R
292*
293 CALL claset( 'Full', m, n, czero, czero, r, m )
294*
295 CALL clacpy( '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 cgemm( 'C', 'N', m, n, m, -cone, q, m, a, m, cone, r, m )
301*
302 anorm = clange( '1', m, n, a, m, rwork )
303 resid = clange( '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 claset( 'Full', m, m, czero, cone, r, m )
314 CALL cherk( 'U', 'C', m, m, -cone, q, m, cone, r, m )
315 resid = clansy( '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 clarnv( 2, iseed, m, c( 1, j ) )
322 END DO
323 cnorm = clange( '1', m, n, c, m, rwork )
324 CALL clacpy( 'Full', m, n, c, m, cf, m )
325*
326* Apply Q to C as Q*C = CF
327*
328 srnamt = 'CGEMQRT'
329 CALL cgemqrt( '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 cgemm( 'N', 'N', m, n, m, -cone, q, m, c, m, cone, cf, m )
336 resid = clange( '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 clacpy( 'Full', m, n, c, m, cf, m )
346*
347* Apply Q to C as (Q**H)*C = CF
348*
349 srnamt = 'CGEMQRT'
350 CALL cgemqrt( '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 cgemm( 'C', 'N', m, n, m, -cone, q, m, c, m, cone, cf, m )
357 resid = clange( '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 clarnv( 2, iseed, n, d( 1, j ) )
368 END DO
369 dnorm = clange( '1', n, m, d, n, rwork )
370 CALL clacpy( 'Full', n, m, d, n, df, n )
371*
372* Apply Q to D as D*Q = DF
373*
374 srnamt = 'CGEMQRT'
375 CALL cgemqrt( '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 cgemm( 'N', 'N', n, m, m, -cone, d, n, q, m, cone, df, n )
382 resid = clange( '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 clacpy( 'Full', n, m, d, n, df, n )
392*
393* Apply Q to D as D*QT = DF
394*
395 srnamt = 'CGEMQRT'
396 CALL cgemqrt( '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 cgemm( 'N', 'C', n, m, m, -cone, d, n, q, m, cone, df, n )
403 resid = clange( '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 CUNHR_COL01
418*
clatsqr
subroutine clatsqr(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
CLATSQR
Definition clatsqr.f:166
cungtsqr
subroutine cungtsqr(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
CUNGTSQR
Definition cungtsqr.f:175

◆ cunhr_col02()

subroutine cunhr_col02 ( integer m,
integer n,
integer mb1,
integer nb1,
integer nb2,
real, dimension(6) result )

CUNHR_COL02

Purpose:
!>
!> CUNHR_COL02 tests CUNGTSQR_ROW and CUNHR_COL inside CGETSQRHRT
!> (which calls CLATSQR, CUNGTSQR_ROW and CUNHR_COL) using CGEMQRT.
!> Therefore, CLATSQR (part of CGEQR), CGEMQRT (part of CGEMQR)
!> 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 REAL 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 CGEQRT 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 CGEMQRT,
!>
!>            Q * C, (Q**H) * C, D * Q, D * (Q**H)  are
!>            computed using CGEMM.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 119 of file cunhr_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 REAL RESULT(6)
130*
131* =====================================================================
132*
133* ..
134* .. Local allocatable arrays
135 COMPLEX , ALLOCATABLE :: A(:,:), AF(:,:), Q(:,:), R(:,:),
136 $ WORK( : ), T1(:,:), T2(:,:), DIAG(:),
137 $ C(:,:), CF(:,:), D(:,:), DF(:,:)
138 REAL , ALLOCATABLE :: RWORK(:)
139*
140* .. Parameters ..
141 REAL ZERO
142 parameter( zero = 0.0e+0 )
143 COMPLEX CONE, CZERO
144 parameter( cone = ( 1.0e+0, 0.0e+0 ),
145 $ czero = ( 0.0e+0, 0.0e+0 ) )
146* ..
147* .. Local Scalars ..
148 LOGICAL TESTZEROS
149 INTEGER INFO, J, K, L, LWORK, NB2_UB, NRB
150 REAL ANORM, EPS, RESID, CNORM, DNORM
151* ..
152* .. Local Arrays ..
153 INTEGER ISEED( 4 )
154 COMPLEX WORKQUERY( 1 )
155* ..
156* .. External Functions ..
157 REAL SLAMCH, CLANGE, CLANSY
158 EXTERNAL slamch, clange, clansy
159* ..
160* .. External Subroutines ..
161 EXTERNAL clacpy, clarnv, claset, cgetsqrhrt,
162 $ cscal, cgemm, cgemqrt, cherk
163* ..
164* .. Intrinsic Functions ..
165 INTRINSIC ceiling, real, 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 = slamch( '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 clarnv( 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 clarnv( 2, iseed, m/2, a( m/4, j ) )
199 END DO
200 END IF
201 END IF
202 CALL clacpy( 'Full', m, n, a, m, af, m )
203*
204* Number of row blocks in CLATSQR
205*
206 nrb = max( 1, ceiling( real( m - n ) / real( 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* CGEMQRT requires NB2 to be bounded by N.
215*
216 nb2_ub = min( nb2, n)
217*
218*
219 CALL cgetsqrhrt( m, n, mb1, nb1, nb2, af, m, t2, nb2,
220 $ workquery, -1, info )
221*
222 lwork = int( workquery( 1 ) )
223*
224* In CGEMQRT, 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 = 'CGETSQRHRT'
239 CALL cgetsqrhrt( 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 claset( 'Full', m, m, czero, cone, q, m )
248*
249 srnamt = 'CGEMQRT'
250 CALL cgemqrt( 'L', 'N', m, m, k, nb2_ub, af, m, t2, nb2, q, m,
251 $ work, info )
252*
253* Copy R
254*
255 CALL claset( 'Full', m, n, czero, czero, r, m )
256*
257 CALL clacpy( '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 cgemm( 'C', 'N', m, n, m, -cone, q, m, a, m, cone, r, m )
263*
264 anorm = clange( '1', m, n, a, m, rwork )
265 resid = clange( '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 claset( 'Full', m, m, czero, cone, r, m )
276 CALL cherk( 'U', 'C', m, m, -cone, q, m, cone, r, m )
277 resid = clansy( '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 clarnv( 2, iseed, m, c( 1, j ) )
284 END DO
285 cnorm = clange( '1', m, n, c, m, rwork )
286 CALL clacpy( 'Full', m, n, c, m, cf, m )
287*
288* Apply Q to C as Q*C = CF
289*
290 srnamt = 'CGEMQRT'
291 CALL cgemqrt( '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 cgemm( 'N', 'N', m, n, m, -cone, q, m, c, m, cone, cf, m )
298 resid = clange( '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 clacpy( 'Full', m, n, c, m, cf, m )
308*
309* Apply Q to C as (Q**T)*C = CF
310*
311 srnamt = 'CGEMQRT'
312 CALL cgemqrt( '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 cgemm( 'C', 'N', m, n, m, -cone, q, m, c, m, cone, cf, m )
319 resid = clange( '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 clarnv( 2, iseed, n, d( 1, j ) )
330 END DO
331 dnorm = clange( '1', n, m, d, n, rwork )
332 CALL clacpy( 'Full', n, m, d, n, df, n )
333*
334* Apply Q to D as D*Q = DF
335*
336 srnamt = 'CGEMQRT'
337 CALL cgemqrt( '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 cgemm( 'N', 'N', n, m, m, -cone, d, n, q, m, cone, df, n )
344 resid = clange( '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 clacpy( 'Full', n, m, d, n, df, n )
354*
355* Apply Q to D as D*QT = DF
356*
357 srnamt = 'CGEMQRT'
358 CALL cgemqrt( '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 cgemm( 'N', 'C', n, m, m, -cone, d, n, q, m, cone, df, n )
365 resid = clange( '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 CUNHR_COL02
380*
cgetsqrhrt
subroutine cgetsqrhrt(m, n, mb1, nb1, nb2, a, lda, t, ldt, work, lwork, info)
CGETSQRHRT
Definition cgetsqrhrt.f:179