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

Functions

subroutine cchklqt (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 CCHKLQT
subroutine cchklqtp (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 CCHKLQTP
subroutine cchktsqr (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 CCHKQRT
subroutine cerrlqt (path, nunit)
 CERRLQT
subroutine cerrlqtp (path, nunit)
 ZERRLQTP
subroutine cerrtsqr (path, nunit)
 CERRTSQR
subroutine clqt04 (m, n, nb, result)
 DLQT04
subroutine clqt05 (m, n, l, nb, result)
 CLQT05
program dchkaa
 DCHKAA
program dchkab
 DCHKAB
subroutine dchkeq (thresh, nout)
 DCHKEQ
subroutine dchkgb (dotype, nm, mval, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, a, la, afac, lafac, b, x, xact, work, rwork, iwork, nout)
 DCHKGB
subroutine dchkge (dotype, nm, mval, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 DCHKGE
subroutine dchkgt (dotype, nn, nval, nns, nsval, thresh, tsterr, a, af, b, x, xact, work, rwork, iwork, nout)
 DCHKGT
subroutine dchklq (dotype, nm, mval, nn, nval, nnb, nbval, nxval, nrhs, thresh, tsterr, nmax, a, af, aq, al, ac, b, x, xact, tau, work, rwork, nout)
 DCHKLQ
subroutine dchklqt (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 DCHKLQT
subroutine dchklqtp (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 DCHKLQTP
subroutine dchkorhr_col (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 DCHKORHR_COL
subroutine dchkpb (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 DCHKPB
subroutine dchkpo (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 DCHKPO
subroutine dchkpp (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 DCHKPP
subroutine dchkps (dotype, nn, nval, nnb, nbval, nrank, rankval, thresh, tsterr, nmax, a, afac, perm, piv, work, rwork, nout)
 DCHKPS
subroutine dchkpt (dotype, nn, nval, nns, nsval, thresh, tsterr, a, d, e, b, x, xact, work, rwork, nout)
 DCHKPT
subroutine dchkq3 (dotype, nm, mval, nn, nval, nnb, nbval, nxval, thresh, a, copya, s, tau, work, iwork, nout)
 DCHKQ3
subroutine dchkql (dotype, nm, mval, nn, nval, nnb, nbval, nxval, nrhs, thresh, tsterr, nmax, a, af, aq, al, ac, b, x, xact, tau, work, rwork, nout)
 DCHKQL
subroutine dchkqr (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)
 DCHKQR
subroutine dchkqrt (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 DCHKQRT
subroutine dchkqrtp (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 DCHKQRTP
program dchkrfp
 DCHKRFP
subroutine dchkrq (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)
 DCHKRQ
subroutine dchksp (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 DCHKSP
subroutine dchksy (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 DCHKSY
subroutine dchksy_aa (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 DCHKSY_AA
subroutine dchksy_aa_2stage (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 DCHKSY_AA_2STAGE
subroutine dchksy_rk (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, e, ainv, b, x, xact, work, rwork, iwork, nout)
 DCHKSY_RK
subroutine dchksy_rook (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 DCHKSY_ROOK
subroutine dchktb (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, ab, ainv, b, x, xact, work, rwork, iwork, nout)
 DCHKTB
subroutine dchktp (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, ap, ainvp, b, x, xact, work, rwork, iwork, nout)
 DCHKTP
subroutine dchktr (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, ainv, b, x, xact, work, rwork, iwork, nout)
 DCHKTR
subroutine dchktsqr (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 DCHKQRT
subroutine dchktz (dotype, nm, mval, nn, nval, thresh, tsterr, a, copya, s, tau, work, nout)
 DCHKTZ
subroutine ddrvab (dotype, nm, mval, nns, nsval, thresh, nmax, a, afac, b, x, work, rwork, swork, iwork, nout)
 DDRVAB
subroutine ddrvac (dotype, nm, mval, nns, nsval, thresh, nmax, a, afac, b, x, work, rwork, swork, nout)
 DDRVAC
subroutine ddrvgb (dotype, nn, nval, nrhs, thresh, tsterr, a, la, afb, lafb, asav, b, bsav, x, xact, s, work, rwork, iwork, nout)
 DDRVGB
subroutine ddrvge (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, asav, b, bsav, x, xact, s, work, rwork, iwork, nout)
 DDRVGE
subroutine ddrvgt (dotype, nn, nval, nrhs, thresh, tsterr, a, af, b, x, xact, work, rwork, iwork, nout)
 DDRVGT
subroutine ddrvls (dotype, nm, mval, nn, nval, nns, nsval, nnb, nbval, nxval, thresh, tsterr, a, copya, b, copyb, c, s, copys, nout)
 DDRVLS
subroutine ddrvpb (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, asav, b, bsav, x, xact, s, work, rwork, iwork, nout)
 DDRVPB
subroutine ddrvpo (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, asav, b, bsav, x, xact, s, work, rwork, iwork, nout)
 DDRVPO
subroutine ddrvpp (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, asav, b, bsav, x, xact, s, work, rwork, iwork, nout)
 DDRVPP
subroutine ddrvpt (dotype, nn, nval, nrhs, thresh, tsterr, a, d, e, b, x, xact, work, rwork, nout)
 DDRVPT
subroutine ddrvrf1 (nout, nn, nval, thresh, a, lda, arf, work)
 DDRVRF1
subroutine ddrvrf2 (nout, nn, nval, a, lda, arf, ap, asav)
 DDRVRF2
subroutine ddrvrf3 (nout, nn, nval, thresh, a, lda, arf, b1, b2, d_work_dlange, d_work_dgeqrf, tau)
 DDRVRF3
subroutine ddrvrf4 (nout, nn, nval, thresh, c1, c2, ldc, crf, a, lda, d_work_dlange)
 DDRVRF4
subroutine ddrvrfp (nout, nn, nval, nns, nsval, nnt, ntval, thresh, a, asav, afac, ainv, b, bsav, xact, x, arf, arfinv, d_work_dlatms, d_work_dpot01, d_temp_dpot02, d_temp_dpot03, d_work_dlansy, d_work_dpot02, d_work_dpot03)
 DDRVRFP
subroutine ddrvsp (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 DDRVSP
subroutine ddrvsy (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 DDRVSY
subroutine ddrvsy_aa (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 DDRVSY_AA
subroutine ddrvsy_aa_2stage (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 DDRVSY_AA_2STAGE
subroutine ddrvsy_rk (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, e, ainv, b, x, xact, work, rwork, iwork, nout)
 DDRVSY_RK
subroutine ddrvsy_rook (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 DDRVSY_ROOK
subroutine debchvxx (thresh, path)
 DEBCHVXX
subroutine derrab (nunit)
 DERRAB
subroutine derrac (nunit)
 DERRAC
subroutine derrge (path, nunit)
 DERRGE
subroutine derrgt (path, nunit)
 DERRGT
subroutine derrlq (path, nunit)
 DERRLQ
subroutine derrlqt (path, nunit)
 DERLQT
subroutine derrlqtp (path, nunit)
 DERRLQTP
subroutine derrls (path, nunit)
 DERRLS
subroutine derrorhr_col (path, nunit)
 DERRORHR_COL
subroutine derrpo (path, nunit)
 DERRPO
subroutine derrps (path, nunit)
 DERRPS
subroutine derrql (path, nunit)
 DERRQL
subroutine derrqp (path, nunit)
 DERRQP
subroutine derrqr (path, nunit)
 DERRQR
subroutine derrqrt (path, nunit)
 DERRQRT
subroutine derrqrtp (path, nunit)
 DERRQRTP
subroutine derrrfp (nunit)
 DERRRFP
subroutine derrrq (path, nunit)
 DERRRQ
subroutine derrsy (path, nunit)
 DERRSY
subroutine derrtr (path, nunit)
 DERRTR
subroutine derrtsqr (path, nunit)
 DERRTSQR
subroutine derrtz (path, nunit)
 DERRTZ
subroutine derrvx (path, nunit)
 DERRVX
subroutine dgbt01 (m, n, kl, ku, a, lda, afac, ldafac, ipiv, work, resid)
 DGBT01
subroutine dgbt02 (trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 DGBT02
subroutine dgbt05 (trans, n, kl, ku, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 DGBT05
subroutine dgelqs (m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
 DGELQS
logical function dgennd (m, n, a, lda)
 DGENND
subroutine dgeqls (m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
 DGEQLS
subroutine dgeqrs (m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
 DGEQRS
subroutine dgerqs (m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
 DGERQS
subroutine dget01 (m, n, a, lda, afac, ldafac, ipiv, rwork, resid)
 DGET01
subroutine dget02 (trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 DGET02
subroutine dget03 (n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
 DGET03
subroutine dget04 (n, nrhs, x, ldx, xact, ldxact, rcond, resid)
 DGET04
double precision function dget06 (rcond, rcondc)
 DGET06
subroutine dget07 (trans, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, chkferr, berr, reslts)
 DGET07
subroutine dget08 (trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 DGET08
subroutine dgtt01 (n, dl, d, du, dlf, df, duf, du2, ipiv, work, ldwork, rwork, resid)
 DGTT01
subroutine dgtt02 (trans, n, nrhs, dl, d, du, x, ldx, b, ldb, resid)
 DGTT02
subroutine dgtt05 (trans, n, nrhs, dl, d, du, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 DGTT05
subroutine dlahilb (n, nrhs, a, lda, x, ldx, b, ldb, work, info)
 DLAHILB
subroutine dlaord (job, n, x, incx)
 DLAORD
subroutine dlaptm (n, nrhs, alpha, d, e, x, ldx, beta, b, ldb)
 DLAPTM
subroutine dlarhs (path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
 DLARHS
subroutine dlatb4 (path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
 DLATB4
subroutine dlatb5 (path, imat, n, type, kl, ku, anorm, mode, cndnum, dist)
 DLATB5
subroutine dlattb (imat, uplo, trans, diag, iseed, n, kd, ab, ldab, b, work, info)
 DLATTB
subroutine dlattp (imat, uplo, trans, diag, iseed, n, a, b, work, info)
 DLATTP
subroutine dlattr (imat, uplo, trans, diag, iseed, n, a, lda, b, work, info)
 DLATTR
subroutine dlavsp (uplo, trans, diag, n, nrhs, a, ipiv, b, ldb, info)
 DLAVSP
subroutine dlavsy (uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
 DLAVSY
subroutine dlavsy_rook (uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
 DLAVSY_ROOK
subroutine dlqt01 (m, n, a, af, q, l, lda, tau, work, lwork, rwork, result)
 DLQT01
subroutine dlqt02 (m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
 DLQT02
subroutine dlqt03 (m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
 DLQT03
subroutine dlqt04 (m, n, nb, result)
 DLQT04
subroutine dlqt05 (m, n, l, nb, result)
 DLQT05
subroutine dorhr_col01 (m, n, mb1, nb1, nb2, result)
 DORHR_COL01
subroutine dorhr_col02 (m, n, mb1, nb1, nb2, result)
 DORHR_COL02
subroutine dpbt01 (uplo, n, kd, a, lda, afac, ldafac, rwork, resid)
 DPBT01
subroutine dpbt02 (uplo, n, kd, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 DPBT02
subroutine dpbt05 (uplo, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 DPBT05
subroutine dpot01 (uplo, n, a, lda, afac, ldafac, rwork, resid)
 DPOT01
subroutine dpot02 (uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 DPOT02
subroutine dpot03 (uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
 DPOT03
subroutine dpot05 (uplo, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 DPOT05
subroutine dpot06 (uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 DPOT06
subroutine dppt01 (uplo, n, a, afac, rwork, resid)
 DPPT01
subroutine dppt02 (uplo, n, nrhs, a, x, ldx, b, ldb, rwork, resid)
 DPPT02
subroutine dppt03 (uplo, n, a, ainv, work, ldwork, rwork, rcond, resid)
 DPPT03
subroutine dppt05 (uplo, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 DPPT05
subroutine dpst01 (uplo, n, a, lda, afac, ldafac, perm, ldperm, piv, rwork, resid, rank)
 DPST01
subroutine dptt01 (n, d, e, df, ef, work, resid)
 DPTT01
subroutine dptt02 (n, nrhs, d, e, x, ldx, b, ldb, resid)
 DPTT02
subroutine dptt05 (n, nrhs, d, e, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 DPTT05
subroutine dqlt01 (m, n, a, af, q, l, lda, tau, work, lwork, rwork, result)
 DQLT01
subroutine dqlt02 (m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
 DQLT02
subroutine dqlt03 (m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
 DQLT03
double precision function dqpt01 (m, n, k, a, af, lda, tau, jpvt, work, lwork)
 DQPT01
subroutine dqrt01 (m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
 DQRT01
subroutine dqrt01p (m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
 DQRT01P
subroutine dqrt02 (m, n, k, a, af, q, r, lda, tau, work, lwork, rwork, result)
 DQRT02
subroutine dqrt03 (m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
 DQRT03
subroutine dqrt04 (m, n, nb, result)
 DQRT04
subroutine dqrt05 (m, n, l, nb, result)
 DQRT05
double precision function dqrt11 (m, k, a, lda, tau, work, lwork)
 DQRT11
double precision function dqrt12 (m, n, a, lda, s, work, lwork)
 DQRT12
subroutine dqrt13 (scale, m, n, a, lda, norma, iseed)
 DQRT13
double precision function dqrt14 (trans, m, n, nrhs, a, lda, x, ldx, work, lwork)
 DQRT14
subroutine dqrt15 (scale, rksel, m, n, nrhs, a, lda, b, ldb, s, rank, norma, normb, iseed, work, lwork)
 DQRT15
subroutine dqrt16 (trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 DQRT16
double precision function dqrt17 (trans, iresid, m, n, nrhs, a, lda, x, ldx, b, ldb, c, work, lwork)
 DQRT17
subroutine drqt01 (m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
 DRQT01
subroutine drqt02 (m, n, k, a, af, q, r, lda, tau, work, lwork, rwork, result)
 DRQT02
subroutine drqt03 (m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
 DRQT03
double precision function drzt01 (m, n, a, af, lda, tau, work, lwork)
 DRZT01
double precision function drzt02 (m, n, af, lda, tau, work, lwork)
 DRZT02
subroutine dspt01 (uplo, n, a, afac, ipiv, c, ldc, rwork, resid)
 DSPT01
subroutine dsyt01 (uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
 DSYT01
subroutine dsyt01_3 (uplo, n, a, lda, afac, ldafac, e, ipiv, c, ldc, rwork, resid)
 DSYT01_3
subroutine dsyt01_aa (uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
 DSYT01
subroutine dsyt01_rook (uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
 DSYT01_ROOK
subroutine dtbt02 (uplo, trans, diag, n, kd, nrhs, ab, ldab, x, ldx, b, ldb, work, resid)
 DTBT02
subroutine dtbt03 (uplo, trans, diag, n, kd, nrhs, ab, ldab, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
 DTBT03
subroutine dtbt05 (uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 DTBT05
subroutine dtbt06 (rcond, rcondc, uplo, diag, n, kd, ab, ldab, work, rat)
 DTBT06
subroutine dtpt01 (uplo, diag, n, ap, ainvp, rcond, work, resid)
 DTPT01
subroutine dtpt02 (uplo, trans, diag, n, nrhs, ap, x, ldx, b, ldb, work, resid)
 DTPT02
subroutine dtpt03 (uplo, trans, diag, n, nrhs, ap, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
 DTPT03
subroutine dtpt05 (uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 DTPT05
subroutine dtpt06 (rcond, rcondc, uplo, diag, n, ap, work, rat)
 DTPT06
subroutine dtrt01 (uplo, diag, n, a, lda, ainv, ldainv, rcond, work, resid)
 DTRT01
subroutine dtrt02 (uplo, trans, diag, n, nrhs, a, lda, x, ldx, b, ldb, work, resid)
 DTRT02
subroutine dtrt03 (uplo, trans, diag, n, nrhs, a, lda, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
 DTRT03
subroutine dtrt05 (uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 DTRT05
subroutine dtrt06 (rcond, rcondc, uplo, diag, n, a, lda, work, rat)
 DTRT06
subroutine dtsqr01 (tssw, m, n, mb, nb, result)
 DTSQR01
subroutine schklqt (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 SCHKLQT
subroutine schklqtp (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 SCHKLQTP
subroutine schksy_rk (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, e, ainv, b, x, xact, work, rwork, iwork, nout)
 SCHKSY_RK
subroutine schktsqr (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 SCHKQRT
subroutine sdrvsy_rook (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 SDRVSY_ROOK
subroutine serrlqt (path, nunit)
 SERRLQT
subroutine serrlqtp (path, nunit)
 DERRLQTP
subroutine serrtsqr (path, nunit)
 DERRTSQR
subroutine slqt04 (m, n, nb, result)
 SLQT04
subroutine slqt05 (m, n, l, nb, result)
 SLQT05
subroutine stsqr01 (tssw, m, n, mb, nb, result)
 STSQR01
subroutine zchklqt (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 ZCHKLQT
subroutine zchklqtp (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 ZCHKLQTP
subroutine zchktsqr (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 DCHKQRT
subroutine zerrlqt (path, nunit)
 ZERLQT
subroutine zerrlqtp (path, nunit)
 ZERRLQTP
subroutine zerrtsqr (path, nunit)
 ZERRTSQR
subroutine zlqt04 (m, n, nb, result)
 DLQT04
subroutine zlqt05 (m, n, l, nb, result)
 ZLQT05

Detailed Description

This is the group of double LAPACK TESTING LIN routines.

Function Documentation

◆ cchklqt()

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

CCHKLQT

Purpose:
!>
!> CCHKLQT tests CGELQT and CUNMLQT.
!>
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 cchklqt.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, cerrlqt, clqt04
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 ) = 'TQ'
149 nrun = 0
150 nfail = 0
151 nerrs = 0
152*
153* Test the error exits
154*
155 IF( tsterr ) CALL cerrlqt( 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 CGELQT and CUNMLQT
175*
176 IF( (nb.LE.minmn).AND.(nb.GT.0) ) THEN
177 CALL clqt04( 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 CCHKLQT
206*
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
cerrlqt
subroutine cerrlqt(path, nunit)
CERRLQT
Definition cerrlqt.f:55
clqt04
subroutine clqt04(m, n, nb, result)
DLQT04
Definition clqt04.f:73
min
#define min(a, b)
Definition macros.h:20

◆ cchklqtp()

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

CCHKLQTP

Purpose:
!>
!> CCHKLQTP tests CTPLQT and CTPMLQT.
!>
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 cchklqtp.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, L, 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, cerrlqtp, clqt04
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 ) = 'XQ'
149 nrun = 0
150 nfail = 0
151 nerrs = 0
152*
153* Test the error exits
154*
155 IF( tsterr ) CALL cerrlqtp( path, nout )
156 infot = 0
157*
158* Do for each value of M
159*
160 DO i = 1, nm
161 m = mval( i )
162*
163* Do for each value of N
164*
165 DO j = 1, nn
166 n = nval( j )
167*
168* Do for each value of L
169*
170 minmn = min( m, n )
171 DO l = 0, minmn, max( minmn, 1 )
172*
173* Do for each possible value of NB
174*
175 DO k = 1, nnb
176 nb = nbval( k )
177*
178* Test DTPLQT and DTPMLQT
179*
180 IF( (nb.LE.m).AND.(nb.GT.0) ) THEN
181 CALL clqt05( m, n, l, nb, result )
182*
183* Print information about the tests that did not
184* pass the threshold.
185*
186 DO t = 1, ntests
187 IF( result( t ).GE.thresh ) THEN
188 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
189 $ CALL alahd( nout, path )
190 WRITE( nout, fmt = 9999 )m, n, nb, l,
191 $ t, result( t )
192 nfail = nfail + 1
193 END IF
194 END DO
195 nrun = nrun + ntests
196 END IF
197 END DO
198 END DO
199 END DO
200 END DO
201*
202* Print a summary of the results.
203*
204 CALL alasum( path, nout, nfail, nrun, nerrs )
205*
206 9999 FORMAT( ' M=', i5, ', N=', i5, ', NB=', i4,' L=', i4,
207 $ ' test(', i2, ')=', g12.5 )
208 RETURN
209*
210* End of CCHKLQTP
211*
clqt05
subroutine clqt05(m, n, l, nb, result)
CLQT05
Definition clqt05.f:80
cerrlqtp
subroutine cerrlqtp(path, nunit)
ZERRLQTP
Definition cerrlqtp.f:55
max
#define max(a, b)
Definition macros.h:21

◆ cchktsqr()

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

CCHKQRT

Purpose:
!>
!> CCHKTSQR tests CGEQR and CGEMQR.
!>
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 cchktsqr.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, INB,
126 $ MINMN, MB, IMB
127*
128* .. Local Arrays ..
129 REAL RESULT( NTESTS )
130* ..
131* .. External Subroutines ..
132 EXTERNAL alaerh, alahd, alasum, cerrtsqr,
133 $ ctsqr01, xlaenv
134* ..
135* .. Intrinsic Functions ..
136 INTRINSIC max, min
137* ..
138* .. Scalars in Common ..
139 LOGICAL LERR, OK
140 CHARACTER*32 SRNAMT
141 INTEGER INFOT, NUNIT
142* ..
143* .. Common blocks ..
144 COMMON / infoc / infot, nunit, ok, lerr
145 COMMON / srnamc / srnamt
146* ..
147* .. Executable Statements ..
148*
149* Initialize constants
150*
151 path( 1: 1 ) = 'C'
152 path( 2: 3 ) = 'TS'
153 nrun = 0
154 nfail = 0
155 nerrs = 0
156*
157* Test the error exits
158*
159 CALL xlaenv( 1, 0 )
160 CALL xlaenv( 2, 0 )
161 IF( tsterr ) CALL cerrtsqr( path, nout )
162 infot = 0
163*
164* Do for each value of M in MVAL.
165*
166 DO i = 1, nm
167 m = mval( i )
168*
169* Do for each value of N in NVAL.
170*
171 DO j = 1, nn
172 n = nval( j )
173 IF (min(m,n).NE.0) THEN
174 DO inb = 1, nnb
175 mb = nbval( inb )
176 CALL xlaenv( 1, mb )
177 DO imb = 1, nnb
178 nb = nbval( imb )
179 CALL xlaenv( 2, nb )
180*
181* Test DGEQR and DGEMQR
182*
183 CALL ctsqr01( 'TS', m, n, mb, nb, result )
184*
185* Print information about the tests that did not
186* pass the threshold.
187*
188 DO t = 1, ntests
189 IF( result( t ).GE.thresh ) THEN
190 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
191 $ CALL alahd( nout, path )
192 WRITE( nout, fmt = 9999 )m, n, mb, nb,
193 $ t, result( t )
194 nfail = nfail + 1
195 END IF
196 END DO
197 nrun = nrun + ntests
198 END DO
199 END DO
200 END IF
201 END DO
202 END DO
203*
204* Do for each value of M in MVAL.
205*
206 DO i = 1, nm
207 m = mval( i )
208*
209* Do for each value of N in NVAL.
210*
211 DO j = 1, nn
212 n = nval( j )
213 IF (min(m,n).NE.0) THEN
214 DO inb = 1, nnb
215 mb = nbval( inb )
216 CALL xlaenv( 1, mb )
217 DO imb = 1, nnb
218 nb = nbval( imb )
219 CALL xlaenv( 2, nb )
220*
221* Test DGEQR and DGEMQR
222*
223 CALL ctsqr01( 'SW', m, n, mb, nb, result )
224*
225* Print information about the tests that did not
226* pass the threshold.
227*
228 DO t = 1, ntests
229 IF( result( t ).GE.thresh ) THEN
230 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
231 $ CALL alahd( nout, path )
232 WRITE( nout, fmt = 9998 )m, n, mb, nb,
233 $ t, result( t )
234 nfail = nfail + 1
235 END IF
236 END DO
237 nrun = nrun + ntests
238 END DO
239 END DO
240 END IF
241 END DO
242 END DO
243*
244* Print a summary of the results.
245*
246 CALL alasum( path, nout, nfail, nrun, nerrs )
247*
248 9999 FORMAT( 'TS: M=', i5, ', N=', i5, ', MB=', i5,
249 $ ', NB=', i5,' test(', i2, ')=', g12.5 )
250 9998 FORMAT( 'SW: M=', i5, ', N=', i5, ', MB=', i5,
251 $ ', NB=', i5,' test(', i2, ')=', g12.5 )
252 RETURN
253*
254* End of CCHKTSQR
255*
ctsqr01
subroutine ctsqr01(tssw, m, n, mb, nb, result)
CTSQR01
Definition ctsqr01.f:82
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
cerrtsqr
subroutine cerrtsqr(path, nunit)
CERRTSQR
Definition cerrtsqr.f:55

◆ cerrlqt()

subroutine cerrlqt ( character*3 path,
integer nunit )

CERRLQT

Purpose:
!>
!> CERRLQT tests the error exits for the COMPLEX routines
!> that use the LQT 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 cerrlqt.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, cgelqt3, cgelqt,
81 $ cgemlqt
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 real, 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.e0 / cmplx( real( i+j ), 0.e0 )
105 c( i, j ) = 1.e0 / cmplx( real( i+j ), 0.e0 )
106 t( i, j ) = 1.e0 / cmplx( real( i+j ), 0.e0 )
107 END DO
108 w( j ) = 0.e0
109 END DO
110 ok = .true.
111*
112* Error exits for LQT factorization
113*
114* CGELQT
115*
116 srnamt = 'CGELQT'
117 infot = 1
118 CALL cgelqt( -1, 0, 1, a, 1, t, 1, w, info )
119 CALL chkxer( 'CGELQT', infot, nout, lerr, ok )
120 infot = 2
121 CALL cgelqt( 0, -1, 1, a, 1, t, 1, w, info )
122 CALL chkxer( 'CGELQT', infot, nout, lerr, ok )
123 infot = 3
124 CALL cgelqt( 0, 0, 0, a, 1, t, 1, w, info )
125 CALL chkxer( 'CGELQT', infot, nout, lerr, ok )
126 infot = 5
127 CALL cgelqt( 2, 1, 1, a, 1, t, 1, w, info )
128 CALL chkxer( 'CGELQT', infot, nout, lerr, ok )
129 infot = 7
130 CALL cgelqt( 2, 2, 2, a, 2, t, 1, w, info )
131 CALL chkxer( 'CGELQT', infot, nout, lerr, ok )
132*
133* CGELQT3
134*
135 srnamt = 'CGELQT3'
136 infot = 1
137 CALL cgelqt3( -1, 0, a, 1, t, 1, info )
138 CALL chkxer( 'CGELQT3', infot, nout, lerr, ok )
139 infot = 2
140 CALL cgelqt3( 0, -1, a, 1, t, 1, info )
141 CALL chkxer( 'CGELQT3', infot, nout, lerr, ok )
142 infot = 4
143 CALL cgelqt3( 2, 2, a, 1, t, 1, info )
144 CALL chkxer( 'CGELQT3', infot, nout, lerr, ok )
145 infot = 6
146 CALL cgelqt3( 2, 2, a, 2, t, 1, info )
147 CALL chkxer( 'CGELQT3', infot, nout, lerr, ok )
148*
149* CGEMLQT
150*
151 srnamt = 'CGEMLQT'
152 infot = 1
153 CALL cgemlqt( '/', 'N', 0, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
154 CALL chkxer( 'CGEMLQT', infot, nout, lerr, ok )
155 infot = 2
156 CALL cgemlqt( 'L', '/', 0, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
157 CALL chkxer( 'CGEMLQT', infot, nout, lerr, ok )
158 infot = 3
159 CALL cgemlqt( 'L', 'N', -1, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
160 CALL chkxer( 'CGEMLQT', infot, nout, lerr, ok )
161 infot = 4
162 CALL cgemlqt( 'L', 'N', 0, -1, 0, 1, a, 1, t, 1, c, 1, w, info )
163 CALL chkxer( 'CGEMLQT', infot, nout, lerr, ok )
164 infot = 5
165 CALL cgemlqt( 'L', 'N', 0, 0, -1, 1, a, 1, t, 1, c, 1, w, info )
166 CALL chkxer( 'CGEMLQT', infot, nout, lerr, ok )
167 infot = 5
168 CALL cgemlqt( 'R', 'N', 0, 0, -1, 1, a, 1, t, 1, c, 1, w, info )
169 CALL chkxer( 'CGEMLQT', infot, nout, lerr, ok )
170 infot = 6
171 CALL cgemlqt( 'L', 'N', 0, 0, 0, 0, a, 1, t, 1, c, 1, w, info )
172 CALL chkxer( 'CGEMLQT', infot, nout, lerr, ok )
173 infot = 8
174 CALL cgemlqt( 'R', 'N', 2, 2, 2, 1, a, 1, t, 1, c, 1, w, info )
175 CALL chkxer( 'CGEMLQT', infot, nout, lerr, ok )
176 infot = 8
177 CALL cgemlqt( 'L', 'N', 2, 2, 2, 1, a, 1, t, 1, c, 1, w, info )
178 CALL chkxer( 'CGEMLQT', infot, nout, lerr, ok )
179 infot = 10
180 CALL cgemlqt( 'R', 'N', 1, 1, 1, 1, a, 1, t, 0, c, 1, w, info )
181 CALL chkxer( 'CGEMLQT', infot, nout, lerr, ok )
182 infot = 12
183 CALL cgemlqt( 'L', 'N', 1, 1, 1, 1, a, 1, t, 1, c, 0, w, info )
184 CALL chkxer( 'CGEMLQT', infot, nout, lerr, ok )
185*
186* Print a summary line.
187*
188 CALL alaesm( path, ok, nout )
189*
190 RETURN
191*
192* End of CERRLQT
193*
cmplx
float cmplx[2]
Definition pblas.h:136
chkxer
subroutine chkxer(srnamt, infot, nout, lerr, ok)
Definition cblat2.f:3196
alaesm
subroutine alaesm(path, ok, nout)
ALAESM
Definition alaesm.f:63
cgemlqt
subroutine cgemlqt(side, trans, m, n, k, mb, v, ldv, t, ldt, c, ldc, work, info)
CGEMLQT
Definition cgemlqt.f:153
cgelqt
subroutine cgelqt(m, n, mb, a, lda, t, ldt, work, info)
CGELQT
Definition cgelqt.f:124
cgelqt3
recursive subroutine cgelqt3(m, n, a, lda, t, ldt, info)
CGELQT3
Definition cgelqt3.f:116

◆ cerrlqtp()

subroutine cerrlqtp ( character*3 path,
integer nunit )

ZERRLQTP

Purpose:
!>
!> CERRLQTP tests the error exits for the complex routines
!> that use the LQT 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 cerrlqtp.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, ctplqt2, ctplqt,
81 $ ctpmlqt
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 real, 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.e0 / cmplx( real( i+j ), 0.e0 )
105 c( i, j ) = 1.e0 / cmplx( real( i+j ), 0.e0 )
106 t( i, j ) = 1.e0 / cmplx( real( i+j ), 0.e0 )
107 END DO
108 w( j ) = 0.e0
109 END DO
110 ok = .true.
111*
112* Error exits for TPLQT factorization
113*
114* CTPLQT
115*
116 srnamt = 'CTPLQT'
117 infot = 1
118 CALL ctplqt( -1, 1, 0, 1, a, 1, b, 1, t, 1, w, info )
119 CALL chkxer( 'CTPLQT', infot, nout, lerr, ok )
120 infot = 2
121 CALL ctplqt( 1, -1, 0, 1, a, 1, b, 1, t, 1, w, info )
122 CALL chkxer( 'CTPLQT', infot, nout, lerr, ok )
123 infot = 3
124 CALL ctplqt( 0, 1, -1, 1, a, 1, b, 1, t, 1, w, info )
125 CALL chkxer( 'CTPLQT', infot, nout, lerr, ok )
126 infot = 3
127 CALL ctplqt( 0, 1, 1, 1, a, 1, b, 1, t, 1, w, info )
128 CALL chkxer( 'CTPLQT', infot, nout, lerr, ok )
129 infot = 4
130 CALL ctplqt( 0, 1, 0, 0, a, 1, b, 1, t, 1, w, info )
131 CALL chkxer( 'CTPLQT', infot, nout, lerr, ok )
132 infot = 4
133 CALL ctplqt( 1, 1, 0, 2, a, 1, b, 1, t, 1, w, info )
134 CALL chkxer( 'CTPLQT', infot, nout, lerr, ok )
135 infot = 6
136 CALL ctplqt( 2, 1, 0, 2, a, 1, b, 1, t, 1, w, info )
137 CALL chkxer( 'CTPLQT', infot, nout, lerr, ok )
138 infot = 8
139 CALL ctplqt( 2, 1, 0, 1, a, 2, b, 1, t, 1, w, info )
140 CALL chkxer( 'CTPLQT', infot, nout, lerr, ok )
141 infot = 10
142 CALL ctplqt( 2, 2, 1, 2, a, 2, b, 2, t, 1, w, info )
143 CALL chkxer( 'CTPLQT', infot, nout, lerr, ok )
144*
145* CTPLQT2
146*
147 srnamt = 'CTPLQT2'
148 infot = 1
149 CALL ctplqt2( -1, 0, 0, a, 1, b, 1, t, 1, info )
150 CALL chkxer( 'CTPLQT2', infot, nout, lerr, ok )
151 infot = 2
152 CALL ctplqt2( 0, -1, 0, a, 1, b, 1, t, 1, info )
153 CALL chkxer( 'CTPLQT2', infot, nout, lerr, ok )
154 infot = 3
155 CALL ctplqt2( 0, 0, -1, a, 1, b, 1, t, 1, info )
156 CALL chkxer( 'CTPLQT2', infot, nout, lerr, ok )
157 infot = 5
158 CALL ctplqt2( 2, 2, 0, a, 1, b, 2, t, 2, info )
159 CALL chkxer( 'CTPLQT2', infot, nout, lerr, ok )
160 infot = 7
161 CALL ctplqt2( 2, 2, 0, a, 2, b, 1, t, 2, info )
162 CALL chkxer( 'CTPLQT2', infot, nout, lerr, ok )
163 infot = 9
164 CALL ctplqt2( 2, 2, 0, a, 2, b, 2, t, 1, info )
165 CALL chkxer( 'CTPLQT2', infot, nout, lerr, ok )
166*
167* CTPMLQT
168*
169 srnamt = 'CTPMLQT'
170 infot = 1
171 CALL ctpmlqt( '/', 'N', 0, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
172 $ w, info )
173 CALL chkxer( 'CTPMLQT', infot, nout, lerr, ok )
174 infot = 2
175 CALL ctpmlqt( 'L', '/', 0, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
176 $ w, info )
177 CALL chkxer( 'CTPMLQT', infot, nout, lerr, ok )
178 infot = 3
179 CALL ctpmlqt( 'L', 'N', -1, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
180 $ w, info )
181 CALL chkxer( 'CTPMLQT', infot, nout, lerr, ok )
182 infot = 4
183 CALL ctpmlqt( 'L', 'N', 0, -1, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
184 $ w, info )
185 CALL chkxer( 'CTPMLQT', infot, nout, lerr, ok )
186 infot = 5
187 CALL ctpmlqt( 'L', 'N', 0, 0, -1, 0, 1, a, 1, t, 1, b, 1, c, 1,
188 $ w, info )
189 infot = 6
190 CALL ctpmlqt( 'L', 'N', 0, 0, 0, -1, 1, a, 1, t, 1, b, 1, c, 1,
191 $ w, info )
192 CALL chkxer( 'CTPMLQT', infot, nout, lerr, ok )
193 infot = 7
194 CALL ctpmlqt( 'L', 'N', 0, 0, 0, 0, 0, a, 1, t, 1, b, 1, c, 1,
195 $ w, info )
196 CALL chkxer( 'CTPMLQT', infot, nout, lerr, ok )
197 infot = 9
198 CALL ctpmlqt( 'R', 'N', 2, 2, 2, 1, 1, a, 1, t, 1, b, 1, c, 1,
199 $ w, info )
200 CALL chkxer( 'CTPMLQT', infot, nout, lerr, ok )
201 infot = 11
202 CALL ctpmlqt( 'R', 'N', 1, 1, 1, 1, 1, a, 1, t, 0, b, 1, c, 1,
203 $ w, info )
204 CALL chkxer( 'CTPMLQT', infot, nout, lerr, ok )
205 infot = 13
206 CALL ctpmlqt( 'L', 'N', 1, 1, 1, 1, 1, a, 1, t, 1, b, 0, c, 1,
207 $ w, info )
208 CALL chkxer( 'CTPMLQT', infot, nout, lerr, ok )
209 infot = 15
210 CALL ctpmlqt( 'L', 'N', 1, 1, 1, 1, 1, a, 1, t, 1, b, 1, c, 0,
211 $ w, info )
212 CALL chkxer( 'CTPMLQT', infot, nout, lerr, ok )
213*
214* Print a summary line.
215*
216 CALL alaesm( path, ok, nout )
217*
218 RETURN
219*
220* End of CERRLQTP
221*
ctplqt2
subroutine ctplqt2(m, n, l, a, lda, b, ldb, t, ldt, info)
CTPLQT2
Definition ctplqt2.f:162
ctpmlqt
subroutine ctpmlqt(side, trans, m, n, k, l, mb, v, ldv, t, ldt, a, lda, b, ldb, work, info)
CTPMLQT
Definition ctpmlqt.f:199
ctplqt
subroutine ctplqt(m, n, l, mb, a, lda, b, ldb, t, ldt, work, info)
CTPLQT
Definition ctplqt.f:174

◆ cerrtsqr()

subroutine cerrtsqr ( character*3 path,
integer nunit )

CERRTSQR

Purpose:
!>
!> CERRTSQR tests the error exits for the COMPLEX routines
!> that use the TSQR 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 Zenver
NAG Ltd.

Definition at line 54 of file cerrtsqr.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, MB, NB
74* ..
75* .. Local Arrays ..
76 COMPLEX A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
77 $ C( NMAX, NMAX ), TAU(NMAX)
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, cgeqr,
81 $ cgemqr, cgelq, cgemlq
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 real
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.e0 / cmplx( real( i+j ), 0.e0 )
105 c( i, j ) = 1.e0 / cmplx( real( i+j ), 0.e0 )
106 t( i, j ) = 1.e0 / cmplx( real( i+j ), 0.e0 )
107 END DO
108 w( j ) = 0.e0
109 END DO
110 ok = .true.
111*
112* Error exits for TS factorization
113*
114* CGEQR
115*
116 srnamt = 'CGEQR'
117 infot = 1
118 CALL cgeqr( -1, 0, a, 1, tau, 1, w, 1, info )
119 CALL chkxer( 'CGEQR', infot, nout, lerr, ok )
120 infot = 2
121 CALL cgeqr( 0, -1, a, 1, tau, 1, w, 1, info )
122 CALL chkxer( 'CGEQR', infot, nout, lerr, ok )
123 infot = 4
124 CALL cgeqr( 1, 1, a, 0, tau, 1, w, 1, info )
125 CALL chkxer( 'CGEQR', infot, nout, lerr, ok )
126 infot = 6
127 CALL cgeqr( 3, 2, a, 3, tau, 1, w, 1, info )
128 CALL chkxer( 'CGEQR', infot, nout, lerr, ok )
129 infot = 8
130 CALL cgeqr( 3, 2, a, 3, tau, 8, w, 0, info )
131 CALL chkxer( 'CGEQR', infot, nout, lerr, ok )
132*
133* CLATSQR
134*
135 mb = 1
136 nb = 1
137 srnamt = 'CLATSQR'
138 infot = 1
139 CALL clatsqr( -1, 0, mb, nb, a, 1, tau, 1, w, 1, info )
140 CALL chkxer( 'CLATSQR', infot, nout, lerr, ok )
141 infot = 2
142 CALL clatsqr( 1, 2, mb, nb, a, 1, tau, 1, w, 1, info )
143 CALL chkxer( 'CLATSQR', infot, nout, lerr, ok )
144 CALL clatsqr( 0, -1, mb, nb, a, 1, tau, 1, w, 1, info )
145 CALL chkxer( 'CLATSQR', infot, nout, lerr, ok )
146 infot = 3
147 CALL clatsqr( 2, 1, -1, nb, a, 2, tau, 1, w, 1, info )
148 CALL chkxer( 'CLATSQR', infot, nout, lerr, ok )
149 infot = 4
150 CALL clatsqr( 2, 1, mb, 2, a, 2, tau, 1, w, 1, info )
151 CALL chkxer( 'CLATSQR', infot, nout, lerr, ok )
152 infot = 6
153 CALL clatsqr( 2, 1, mb, nb, a, 1, tau, 1, w, 1, info )
154 CALL chkxer( 'CLATSQR', infot, nout, lerr, ok )
155 infot = 8
156 CALL clatsqr( 2, 1, mb, nb, a, 2, tau, 0, w, 1, info )
157 CALL chkxer( 'CLATSQR', infot, nout, lerr, ok )
158 infot = 10
159 CALL clatsqr( 2, 1, mb, nb, a, 2, tau, 2, w, 0, info )
160 CALL chkxer( 'CLATSQR', infot, nout, lerr, ok )
161*
162* CGEMQR
163*
164 tau(1)=1
165 tau(2)=1
166 srnamt = 'CGEMQR'
167 nb=1
168 infot = 1
169 CALL cgemqr( '/', 'N', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
170 CALL chkxer( 'CGEMQR', infot, nout, lerr, ok )
171 infot = 2
172 CALL cgemqr( 'L', '/', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
173 CALL chkxer( 'CGEMQR', infot, nout, lerr, ok )
174 infot = 3
175 CALL cgemqr( 'L', 'N', -1, 0, 0, a, 1, tau, 1, c, 1, w,1,info)
176 CALL chkxer( 'CGEMQR', infot, nout, lerr, ok )
177 infot = 4
178 CALL cgemqr( 'L', 'N', 0, -1, 0, a, 1, tau, 1, c, 1, w,1,info)
179 CALL chkxer( 'CGEMQR', infot, nout, lerr, ok )
180 infot = 5
181 CALL cgemqr( 'L', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
182 CALL chkxer( 'CGEMQR', infot, nout, lerr, ok )
183 infot = 5
184 CALL cgemqr( 'R', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
185 CALL chkxer( 'CGEMQR', infot, nout, lerr, ok )
186 infot = 7
187 CALL cgemqr( 'L', 'N', 2, 1, 0, a, 0, tau, 1, c, 1, w, 1,info)
188 CALL chkxer( 'CGEMQR', infot, nout, lerr, ok )
189 infot = 9
190 CALL cgemqr( 'R', 'N', 2, 2, 1, a, 2, tau, 0, c, 1, w, 1,info)
191 CALL chkxer( 'CGEMQR', infot, nout, lerr, ok )
192 infot = 9
193 CALL cgemqr( 'L', 'N', 2, 2, 1, a, 2, tau, 0, c, 1, w, 1,info)
194 CALL chkxer( 'CGEMQR', infot, nout, lerr, ok )
195 infot = 11
196 CALL cgemqr( 'L', 'N', 2, 1, 1, a, 2, tau, 6, c, 0, w, 1,info)
197 CALL chkxer( 'CGEMQR', infot, nout, lerr, ok )
198 infot = 13
199 CALL cgemqr( 'L', 'N', 2, 2, 1, a, 2, tau, 6, c, 2, w, 0,info)
200 CALL chkxer( 'CGEMQR', infot, nout, lerr, ok )
201*
202* CGELQ
203*
204 srnamt = 'CGELQ'
205 infot = 1
206 CALL cgelq( -1, 0, a, 1, tau, 1, w, 1, info )
207 CALL chkxer( 'CGELQ', infot, nout, lerr, ok )
208 infot = 2
209 CALL cgelq( 0, -1, a, 1, tau, 1, w, 1, info )
210 CALL chkxer( 'CGELQ', infot, nout, lerr, ok )
211 infot = 4
212 CALL cgelq( 1, 1, a, 0, tau, 1, w, 1, info )
213 CALL chkxer( 'CGELQ', infot, nout, lerr, ok )
214 infot = 6
215 CALL cgelq( 2, 3, a, 3, tau, 1, w, 1, info )
216 CALL chkxer( 'CGELQ', infot, nout, lerr, ok )
217 infot = 8
218 CALL cgelq( 2, 3, a, 3, tau, 8, w, 0, info )
219 CALL chkxer( 'CGELQ', infot, nout, lerr, ok )
220*
221* CLASWLQ
222*
223 mb = 1
224 nb = 1
225 srnamt = 'CLASWLQ'
226 infot = 1
227 CALL claswlq( -1, 0, mb, nb, a, 1, tau, 1, w, 1, info )
228 CALL chkxer( 'CLASWLQ', infot, nout, lerr, ok )
229 infot = 2
230 CALL claswlq( 2, 1, mb, nb, a, 1, tau, 1, w, 1, info )
231 CALL chkxer( 'CLASWLQ', infot, nout, lerr, ok )
232 CALL claswlq( 0, -1, mb, nb, a, 1, tau, 1, w, 1, info )
233 CALL chkxer( 'CLASWLQ', infot, nout, lerr, ok )
234 infot = 3
235 CALL claswlq( 1, 2, -1, nb, a, 1, tau, 1, w, 1, info )
236 CALL chkxer( 'CLASWLQ', infot, nout, lerr, ok )
237 CALL claswlq( 1, 1, 2, nb, a, 1, tau, 1, w, 1, info )
238 CALL chkxer( 'CLASWLQ', infot, nout, lerr, ok )
239 infot = 4
240 CALL claswlq( 1, 2, mb, -1, a, 1, tau, 1, w, 1, info )
241 CALL chkxer( 'CLASWLQ', infot, nout, lerr, ok )
242 infot = 6
243 CALL claswlq( 1, 2, mb, nb, a, 0, tau, 1, w, 1, info )
244 CALL chkxer( 'CLASWLQ', infot, nout, lerr, ok )
245 infot = 8
246 CALL claswlq( 1, 2, mb, nb, a, 1, tau, 0, w, 1, info )
247 CALL chkxer( 'CLASWLQ', infot, nout, lerr, ok )
248 infot = 10
249 CALL claswlq( 1, 2, mb, nb, a, 1, tau, 1, w, 0, info )
250 CALL chkxer( 'CLASWLQ', infot, nout, lerr, ok )
251*
252* CGEMLQ
253*
254 tau(1)=1
255 tau(2)=1
256 srnamt = 'CGEMLQ'
257 nb=1
258 infot = 1
259 CALL cgemlq( '/', 'N', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
260 CALL chkxer( 'CGEMLQ', infot, nout, lerr, ok )
261 infot = 2
262 CALL cgemlq( 'L', '/', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
263 CALL chkxer( 'CGEMLQ', infot, nout, lerr, ok )
264 infot = 3
265 CALL cgemlq( 'L', 'N', -1, 0, 0, a, 1, tau, 1, c, 1, w,1,info)
266 CALL chkxer( 'CGEMLQ', infot, nout, lerr, ok )
267 infot = 4
268 CALL cgemlq( 'L', 'N', 0, -1, 0, a, 1, tau, 1, c, 1, w,1,info)
269 CALL chkxer( 'CGEMLQ', infot, nout, lerr, ok )
270 infot = 5
271 CALL cgemlq( 'L', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
272 CALL chkxer( 'CGEMLQ', infot, nout, lerr, ok )
273 infot = 5
274 CALL cgemlq( 'R', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
275 CALL chkxer( 'CGEMLQ', infot, nout, lerr, ok )
276 infot = 7
277 CALL cgemlq( 'L', 'N', 1, 2, 0, a, 0, tau, 1, c, 1, w, 1,info)
278 CALL chkxer( 'CGEMLQ', infot, nout, lerr, ok )
279 infot = 9
280 CALL cgemlq( 'R', 'N', 2, 2, 1, a, 1, tau, 0, c, 1, w, 1,info)
281 CALL chkxer( 'CGEMLQ', infot, nout, lerr, ok )
282 infot = 9
283 CALL cgemlq( 'L', 'N', 2, 2, 1, a, 1, tau, 0, c, 1, w, 1,info)
284 CALL chkxer( 'CGEMLQ', infot, nout, lerr, ok )
285 infot = 11
286 CALL cgemlq( 'L', 'N', 1, 2, 1, a, 1, tau, 6, c, 0, w, 1,info)
287 CALL chkxer( 'CGEMLQ', infot, nout, lerr, ok )
288 infot = 13
289 CALL cgemlq( 'L', 'N', 2, 2, 1, a, 2, tau, 6, c, 2, w, 0,info)
290 CALL chkxer( 'CGEMLQ', infot, nout, lerr, ok )
291*
292* Print a summary line.
293*
294 CALL alaesm( path, ok, nout )
295*
296 RETURN
297*
298* End of CERRTSQR
299*
cgelq
subroutine cgelq(m, n, a, lda, t, tsize, work, lwork, info)
CGELQ
Definition cgelq.f:172
cgemlq
subroutine cgemlq(side, trans, m, n, k, a, lda, t, tsize, c, ldc, work, lwork, info)
CGEMLQ
Definition cgemlq.f:170
cgemqr
subroutine cgemqr(side, trans, m, n, k, a, lda, t, tsize, c, ldc, work, lwork, info)
CGEMQR
Definition cgemqr.f:172
cgeqr
subroutine cgeqr(m, n, a, lda, t, tsize, work, lwork, info)
CGEQR
Definition cgeqr.f:174
claswlq
subroutine claswlq(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
CLASWLQ
Definition claswlq.f:164
clatsqr
subroutine clatsqr(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
CLATSQR
Definition clatsqr.f:166

◆ clqt04()

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

DLQT04

Purpose:
!>
!> CLQT04 tests CGELQT and CGEMLQT.
!>
Parameters
[in]M
!>          M is INTEGER
!>          Number of rows in test matrix.
!>
[in]N
!>          N is INTEGER
!>          Number of columns in test matrix.
!>
[in]NB
!>          NB is INTEGER
!>          Block size of test matrix.  NB <= Min(M,N).
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (6)
!>          Results of each of the six tests below.
!>
!>          RESULT(1) = | A - L Q |
!>          RESULT(2) = | I - Q Q^H |
!>          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 clqt04.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
81* .. Return values ..
82 REAL RESULT(6)
83*
84* =====================================================================
85*
86* ..
87* .. Local allocatable arrays
88 COMPLEX, ALLOCATABLE :: AF(:,:), Q(:,:),
89 $ L(:,:), RWORK(:), WORK( : ), T(:,:),
90 $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
91*
92* .. Parameters ..
93 REAL ZERO
94 COMPLEX ONE, CZERO
95 parameter( zero = 0.0)
96 parameter( one = (1.0,0.0), czero=(0.0,0.0) )
97* ..
98* .. Local Scalars ..
99 INTEGER INFO, J, K, LL, LWORK, LDT
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 ll = max(m,n)
120 lwork = max(2,ll)*max(2,ll)*nb
121*
122* Dynamically allocate local arrays
123*
124 ALLOCATE ( a(m,n), af(m,n), q(n,n), l(ll,n), rwork(ll),
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 cgelqt( m, n, nb, af, m, t, ldt, work, info )
139*
140* Generate the n-by-n matrix Q
141*
142 CALL claset( 'Full', n, n, czero, one, q, n )
143 CALL cgemlqt( 'R', 'N', n, n, k, nb, af, m, t, ldt, q, n,
144 $ work, info )
145*
146* Copy L
147*
148 CALL claset( 'Full', ll, n, czero, czero, l, ll )
149 CALL clacpy( 'Lower', m, n, af, m, l, ll )
150*
151* Compute |L - A*Q'| / |A| and store in RESULT(1)
152*
153 CALL cgemm( 'N', 'C', m, n, n, -one, a, m, q, n, one, l, ll )
154 anorm = clange( '1', m, n, a, m, rwork )
155 resid = clange( '1', m, n, l, ll, 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', n, n, czero, one, l, ll )
165 CALL cherk( 'U', 'C', n, n, real(-one), q, n, real(one), l, ll)
166 resid = clansy( '1', 'Upper', n, l, ll, rwork )
167 result( 2 ) = resid / (eps*max(1,n))
168*
169* Generate random m-by-n matrix C and a copy CF
170*
171 DO j=1,m
172 CALL clarnv( 2, iseed, n, d( 1, j ) )
173 END DO
174 dnorm = clange( '1', n, m, d, n, rwork)
175 CALL clacpy( 'Full', n, m, d, n, df, n )
176*
177* Apply Q to C as Q*C
178*
179 CALL cgemlqt( 'L', 'N', n, m, k, nb, af, m, t, nb, df, n,
180 $ work, info)
181*
182* Compute |Q*D - Q*D| / |D|
183*
184 CALL cgemm( 'N', 'N', n, m, n, -one, q, n, d, n, one, df, n )
185 resid = clange( '1', n, m, df, n, rwork )
186 IF( dnorm.GT.zero ) THEN
187 result( 3 ) = resid / (eps*max(1,m)*dnorm)
188 ELSE
189 result( 3 ) = zero
190 END IF
191*
192* Copy D into DF again
193*
194 CALL clacpy( 'Full', n, m, d, n, df, n )
195*
196* Apply Q to D as QT*D
197*
198 CALL cgemlqt( 'L', 'C', n, m, k, nb, af, m, t, nb, df, n,
199 $ work, info)
200*
201* Compute |QT*D - QT*D| / |D|
202*
203 CALL cgemm( 'C', 'N', n, m, n, -one, q, n, d, n, one, df, n )
204 resid = clange( '1', n, m, df, n, rwork )
205 IF( dnorm.GT.zero ) THEN
206 result( 4 ) = resid / (eps*max(1,m)*dnorm)
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,n
214 CALL clarnv( 2, iseed, m, c( 1, j ) )
215 END DO
216 cnorm = clange( '1', m, n, c, m, rwork)
217 CALL clacpy( 'Full', m, n, c, m, cf, m )
218*
219* Apply Q to C as C*Q
220*
221 CALL cgemlqt( 'R', 'N', m, n, k, nb, af, m, t, nb, cf, m,
222 $ work, info)
223*
224* Compute |C*Q - C*Q| / |C|
225*
226 CALL cgemm( 'N', 'N', m, n, n, -one, c, m, q, n, one, cf, m )
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 C into CF again
235*
236 CALL clacpy( 'Full', m, n, c, m, cf, m )
237*
238* Apply Q to D as D*QT
239*
240 CALL cgemlqt( 'R', 'C', m, n, k, nb, af, m, t, nb, cf, m,
241 $ work, info)
242*
243* Compute |C*QT - C*QT| / |C|
244*
245 CALL cgemm( 'N', 'C', m, n, n, -one, c, m, q, n, one, cf, m )
246 resid = clange( '1', m, n, cf, m, 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, l, rwork, work, t, c, d, cf, df)
256*
257 RETURN
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
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
clarnv
subroutine clarnv(idist, iseed, n, x)
CLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition clarnv.f:99
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
cherk
subroutine cherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
CHERK
Definition cherk.f:173
cgemm
subroutine cgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
CGEMM
Definition cgemm.f:187
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68

◆ clqt05()

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

CLQT05

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

Definition at line 79 of file clqt05.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(:,:), RWORK(:), WORK( : ), T(:,:),
97 $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
98*
99* .. Parameters ..
100 REAL ZERO
101 COMPLEX ONE, CZERO
102 parameter( zero = 0.0, one = (1.0,0.0), czero=(0.0,0.0) )
103* ..
104* .. Local Scalars ..
105 INTEGER INFO, J, K, N2, NP1,i
106 REAL ANORM, EPS, RESID, CNORM, DNORM
107* ..
108* .. Local Arrays ..
109 INTEGER ISEED( 4 )
110* ..
111* .. External Functions ..
112 REAL SLAMCH
113 REAL CLANGE, CLANSY
114 LOGICAL LSAME
115 EXTERNAL slamch, clange, clansy, lsame
116* ..
117* .. Data statements ..
118 DATA iseed / 1988, 1989, 1990, 1991 /
119*
120 eps = slamch( 'Epsilon' )
121 k = m
122 n2 = m+n
123 IF( n.GT.0 ) THEN
124 np1 = m+1
125 ELSE
126 np1 = 1
127 END IF
128 lwork = n2*n2*nb
129*
130* Dynamically allocate all arrays
131*
132 ALLOCATE(a(m,n2),af(m,n2),q(n2,n2),r(n2,n2),rwork(n2),
133 $ work(lwork),t(nb,m),c(n2,m),cf(n2,m),
134 $ d(m,n2),df(m,n2) )
135*
136* Put random stuff into A
137*
138 ldt=nb
139 CALL claset( 'Full', m, n2, czero, czero, a, m )
140 CALL claset( 'Full', nb, m, czero, czero, t, nb )
141 DO j=1,m
142 CALL clarnv( 2, iseed, m-j+1, a( j, j ) )
143 END DO
144 IF( n.GT.0 ) THEN
145 DO j=1,n-l
146 CALL clarnv( 2, iseed, m, a( 1, min(n+m,m+1) + j - 1 ) )
147 END DO
148 END IF
149 IF( l.GT.0 ) THEN
150 DO j=1,l
151 CALL clarnv( 2, iseed, m-j+1, a( j, min(n+m,n+m-l+1)
152 $ + j - 1 ) )
153 END DO
154 END IF
155*
156* Copy the matrix A to the array AF.
157*
158 CALL clacpy( 'Full', m, n2, a, m, af, m )
159*
160* Factor the matrix A in the array AF.
161*
162 CALL ctplqt( m,n,l,nb,af,m,af(1,np1),m,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', n2, n2, czero, one, q, n2 )
167 CALL cgemlqt( 'L', 'N', n2, n2, k, nb, af, m, t, ldt, q, n2,
168 $ work, info )
169*
170* Copy L
171*
172 CALL claset( 'Full', n2, n2, czero, czero, r, n2 )
173 CALL clacpy( 'Lower', m, n2, af, m, r, n2 )
174*
175* Compute |L - A*Q*C| / |A| and store in RESULT(1)
176*
177 CALL cgemm( 'N', 'C', m, n2, n2, -one, a, m, q, n2, one, r, n2)
178 anorm = clange( '1', m, n2, a, m, rwork )
179 resid = clange( '1', m, n2, r, n2, rwork )
180 IF( anorm.GT.zero ) THEN
181 result( 1 ) = resid / (eps*anorm*max(1,n2))
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', n2, n2, czero, one, r, n2 )
189 CALL cherk( 'U', 'N', n2, n2, real(-one), q, n2, real(one),
190 $ r, n2 )
191 resid = clansy( '1', 'Upper', n2, r, n2, rwork )
192 result( 2 ) = resid / (eps*max(1,n2))
193*
194* Generate random m-by-n matrix C and a copy CF
195*
196 CALL claset( 'Full', n2, m, czero, one, c, n2 )
197 DO j=1,m
198 CALL clarnv( 2, iseed, n2, c( 1, j ) )
199 END DO
200 cnorm = clange( '1', n2, m, c, n2, rwork)
201 CALL clacpy( 'Full', n2, m, c, n2, cf, n2 )
202*
203* Apply Q to C as Q*C
204*
205 CALL ctpmlqt( 'L','N', n,m,k,l,nb,af(1, np1),m,t,ldt,cf,n2,
206 $ cf(np1,1),n2,work,info)
207*
208* Compute |Q*C - Q*C| / |C|
209*
210 CALL cgemm( 'N', 'N', n2, m, n2, -one, q, n2, c, n2, one, cf, n2 )
211 resid = clange( '1', n2, m, cf, n2, rwork )
212 IF( cnorm.GT.zero ) THEN
213 result( 3 ) = resid / (eps*max(1,n2)*cnorm)
214 ELSE
215 result( 3 ) = zero
216 END IF
217
218*
219* Copy C into CF again
220*
221 CALL clacpy( 'Full', n2, m, c, n2, cf, n2 )
222*
223* Apply Q to C as QT*C
224*
225 CALL ctpmlqt( 'L','C',n,m,k,l,nb,af(1,np1),m,t,ldt,cf,n2,
226 $ cf(np1,1),n2,work,info)
227*
228* Compute |QT*C - QT*C| / |C|
229*
230 CALL cgemm('C','N',n2,m,n2,-one,q,n2,c,n2,one,cf,n2)
231 resid = clange( '1', n2, m, cf, n2, rwork )
232
233 IF( cnorm.GT.zero ) THEN
234 result( 4 ) = resid / (eps*max(1,n2)*cnorm)
235 ELSE
236 result( 4 ) = zero
237 END IF
238*
239* Generate random m-by-n matrix D and a copy DF
240*
241 DO j=1,n2
242 CALL clarnv( 2, iseed, m, d( 1, j ) )
243 END DO
244 dnorm = clange( '1', m, n2, d, m, rwork)
245 CALL clacpy( 'Full', m, n2, d, m, df, m )
246*
247* Apply Q to D as D*Q
248*
249 CALL ctpmlqt('R','N',m,n,k,l,nb,af(1,np1),m,t,ldt,df,m,
250 $ df(1,np1),m,work,info)
251*
252* Compute |D*Q - D*Q| / |D|
253*
254 CALL cgemm('N','N',m,n2,n2,-one,d,m,q,n2,one,df,m)
255 resid = clange('1',m, n2,df,m,rwork )
256 IF( cnorm.GT.zero ) THEN
257 result( 5 ) = resid / (eps*max(1,n2)*dnorm)
258 ELSE
259 result( 5 ) = zero
260 END IF
261*
262* Copy D into DF again
263*
264 CALL clacpy('Full',m,n2,d,m,df,m )
265*
266* Apply Q to D as D*QT
267*
268 CALL ctpmlqt('R','C',m,n,k,l,nb,af(1,np1),m,t,ldt,df,m,
269 $ df(1,np1),m,work,info)
270
271*
272* Compute |D*QT - D*QT| / |D|
273*
274 CALL cgemm( 'N', 'C', m, n2, n2, -one, d, m, q, n2, one, df, m )
275 resid = clange( '1', m, n2, df, m, rwork )
276 IF( cnorm.GT.zero ) THEN
277 result( 6 ) = resid / (eps*max(1,n2)*dnorm)
278 ELSE
279 result( 6 ) = zero
280 END IF
281*
282* Deallocate all arrays
283*
284 DEALLOCATE ( a, af, q, r, rwork, work, t, c, d, cf, df)
285 RETURN

◆ dchkaa()

program dchkaa

DCHKAA

Purpose:
!>
!> DCHKAA is the main test program for the DOUBLE PRECISION LAPACK
!> 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 40 lines:
!> Data file for testing DOUBLE PRECISION LAPACK linear eqn. 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)
!> 20.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
!> DGE   11               List types on next line if 0 < NTYPES < 11
!> DGB    8               List types on next line if 0 < NTYPES <  8
!> DGT   12               List types on next line if 0 < NTYPES < 12
!> DPO    9               List types on next line if 0 < NTYPES <  9
!> DPS    9               List types on next line if 0 < NTYPES <  9
!> DPP    9               List types on next line if 0 < NTYPES <  9
!> DPB    8               List types on next line if 0 < NTYPES <  8
!> DPT   12               List types on next line if 0 < NTYPES < 12
!> DSY   10               List types on next line if 0 < NTYPES < 10
!> DSR   10               List types on next line if 0 < NTYPES < 10
!> DSK   10               List types on next line if 0 < NTYPES < 10
!> DSA   10               List types on next line if 0 < NTYPES < 10
!> DS2   10               List types on next line if 0 < NTYPES < 10
!> DSP   10               List types on next line if 0 < NTYPES < 10
!> DTR   18               List types on next line if 0 < NTYPES < 18
!> DTP   18               List types on next line if 0 < NTYPES < 18
!> DTB   17               List types on next line if 0 < NTYPES < 17
!> DQR    8               List types on next line if 0 < NTYPES <  8
!> DRQ    8               List types on next line if 0 < NTYPES <  8
!> DLQ    8               List types on next line if 0 < NTYPES <  8
!> DQL    8               List types on next line if 0 < NTYPES <  8
!> DQP    6               List types on next line if 0 < NTYPES <  6
!> DTZ    3               List types on next line if 0 < NTYPES <  3
!> DLS    6               List types on next line if 0 < NTYPES <  6
!> DEQ
!> DQT
!> DQX
!> DTQ
!> DXQ
!> DTS
!> DHH
!> 
!>  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 112 of file dchkaa.F.

◆ dchkab()

program dchkab

DCHKAB

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

Definition at line 72 of file dchkab.f.

◆ dchkeq()

subroutine dchkeq ( double precision thresh,
integer nout )

DCHKEQ

Purpose:
!>
!> DCHKEQ tests DGEEQU, DGBEQU, DPOEQU, DPPEQU and DPBEQU
!>
Parameters
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          Threshold for testing routines. Should be between 2 and 10.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 53 of file dchkeq.f.

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

◆ dchkgb()

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

DCHKGB

Purpose:
!>
!> DCHKGB tests DGBTRF, -TRS, -RFS, and -CON
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                      (NMAX*max(3,NSMAX,NMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (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 188 of file dchkgb.f.

191*
192* -- LAPACK test routine --
193* -- LAPACK is a software package provided by Univ. of Tennessee, --
194* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
195*
196* .. Scalar Arguments ..
197 LOGICAL TSTERR
198 INTEGER LA, LAFAC, NM, NN, NNB, NNS, NOUT
199 DOUBLE PRECISION THRESH
200* ..
201* .. Array Arguments ..
202 LOGICAL DOTYPE( * )
203 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
204 $ NVAL( * )
205 DOUBLE PRECISION A( * ), AFAC( * ), B( * ), RWORK( * ),
206 $ WORK( * ), X( * ), XACT( * )
207* ..
208*
209* =====================================================================
210*
211* .. Parameters ..
212 DOUBLE PRECISION ONE, ZERO
213 parameter( one = 1.0d+0, zero = 0.0d+0 )
214 INTEGER NTYPES, NTESTS
215 parameter( ntypes = 8, ntests = 7 )
216 INTEGER NBW, NTRAN
217 parameter( nbw = 4, ntran = 3 )
218* ..
219* .. Local Scalars ..
220 LOGICAL TRFCON, ZEROT
221 CHARACTER DIST, NORM, TRANS, TYPE, XTYPE
222 CHARACTER*3 PATH
223 INTEGER I, I1, I2, IKL, IKU, IM, IMAT, IN, INB, INFO,
224 $ IOFF, IRHS, ITRAN, IZERO, J, K, KL, KOFF, KU,
225 $ LDA, LDAFAC, LDB, M, MODE, N, NB, NERRS, NFAIL,
226 $ NIMAT, NKL, NKU, NRHS, NRUN
227 DOUBLE PRECISION AINVNM, ANORM, ANORMI, ANORMO, CNDNUM, RCOND,
228 $ RCONDC, RCONDI, RCONDO
229* ..
230* .. Local Arrays ..
231 CHARACTER TRANSS( NTRAN )
232 INTEGER ISEED( 4 ), ISEEDY( 4 ), KLVAL( NBW ),
233 $ KUVAL( NBW )
234 DOUBLE PRECISION RESULT( NTESTS )
235* ..
236* .. External Functions ..
237 DOUBLE PRECISION DGET06, DLANGB, DLANGE
238 EXTERNAL dget06, dlangb, dlange
239* ..
240* .. External Subroutines ..
241 EXTERNAL alaerh, alahd, alasum, dcopy, derrge, dgbcon,
242 $ dgbrfs, dgbt01, dgbt02, dgbt05, dgbtrf, dgbtrs,
243 $ dget04, dlacpy, dlarhs, dlaset, dlatb4, dlatms,
244 $ xlaenv
245* ..
246* .. Intrinsic Functions ..
247 INTRINSIC max, min
248* ..
249* .. Scalars in Common ..
250 LOGICAL LERR, OK
251 CHARACTER*32 SRNAMT
252 INTEGER INFOT, NUNIT
253* ..
254* .. Common blocks ..
255 COMMON / infoc / infot, nunit, ok, lerr
256 COMMON / srnamc / srnamt
257* ..
258* .. Data statements ..
259 DATA iseedy / 1988, 1989, 1990, 1991 / ,
260 $ transs / 'N', 'T', 'C' /
261* ..
262* .. Executable Statements ..
263*
264* Initialize constants and the random number seed.
265*
266 path( 1: 1 ) = 'Double precision'
267 path( 2: 3 ) = 'GB'
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 derrge( path, nout )
279 infot = 0
280 CALL xlaenv( 2, 2 )
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 DLATB4 and generate a
381* test matrix with DLATMS.
382*
383 CALL dlatb4( 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 = 'DLATMS'
391 CALL dlatms( 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 DLATMS.
396*
397 IF( info.NE.0 ) THEN
398 CALL alaerh( path, 'DLATMS', 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 dcopy( 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 dcopy( 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 = DLANGB( 'O', N, KL, KU, A, LDA, RWORK )
451* ANORMI = DLANGB( '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 dlacpy( 'Full', kl+ku+1, n, a, lda,
463 $ afac( kl+1 ), ldafac )
464 srnamt = 'DGBTRF'
465 CALL dgbtrf( m, n, kl, ku, afac, ldafac, iwork,
466 $ info )
467*
468* Check error code from DGBTRF.
469*
470 IF( info.NE.izero )
471 $ CALL alaerh( path, 'DGBTRF', 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 dgbt01( 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 = dlangb( 'O', n, kl, ku, a, lda, rwork )
502 anormi = dlangb( '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 dlaset( 'Full', n, n, zero, one, work,
511 $ ldb )
512 srnamt = 'DGBTRS'
513 CALL dgbtrs( '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 = dlange( '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 = dlange( '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 = 'DLARHS'
569 CALL dlarhs( path, xtype, ' ', trans, n,
570 $ n, kl, ku, nrhs, a, lda,
571 $ xact, ldb, b, ldb, iseed,
572 $ info )
573 xtype = 'C'
574 CALL dlacpy( 'Full', n, nrhs, b, ldb, x,
575 $ ldb )
576*
577 srnamt = 'DGBTRS'
578 CALL dgbtrs( trans, n, kl, ku, nrhs, afac,
579 $ ldafac, iwork, x, ldb, info )
580*
581* Check error code from DGBTRS.
582*
583 IF( info.NE.0 )
584 $ CALL alaerh( path, 'DGBTRS', info, 0,
585 $ trans, n, n, kl, ku, -1,
586 $ imat, nfail, nerrs, nout )
587*
588 CALL dlacpy( 'Full', n, nrhs, b, ldb,
589 $ work, ldb )
590 CALL dgbt02( 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 dget04( 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 = 'DGBRFS'
606 CALL dgbrfs( trans, n, kl, ku, nrhs, a,
607 $ lda, afac, ldafac, iwork, b,
608 $ ldb, x, ldb, rwork,
609 $ rwork( nrhs+1 ), work,
610 $ iwork( n+1 ), info )
611*
612* Check error code from DGBRFS.
613*
614 IF( info.NE.0 )
615 $ CALL alaerh( path, 'DGBRFS', info, 0,
616 $ trans, n, n, kl, ku, nrhs,
617 $ imat, nfail, nerrs, nout )
618*
619 CALL dget04( n, nrhs, x, ldb, xact, ldb,
620 $ rcondc, result( 4 ) )
621 CALL dgbt05( trans, n, kl, ku, nrhs, a,
622 $ lda, b, ldb, x, ldb, xact,
623 $ ldb, rwork, rwork( nrhs+1 ),
624 $ result( 5 ) )
625 DO 60 k = 2, 6
626 IF( result( k ).GE.thresh ) THEN
627 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
628 $ CALL alahd( nout, path )
629 WRITE( nout, fmt = 9996 )trans, n,
630 $ kl, ku, nrhs, imat, k,
631 $ result( k )
632 nfail = nfail + 1
633 END IF
634 60 CONTINUE
635 nrun = nrun + 5
636 70 CONTINUE
637 80 CONTINUE
638*
639*+ TEST 7:
640* Get an estimate of RCOND = 1/CNDNUM.
641*
642 90 CONTINUE
643 DO 100 itran = 1, 2
644 IF( itran.EQ.1 ) THEN
645 anorm = anormo
646 rcondc = rcondo
647 norm = 'O'
648 ELSE
649 anorm = anormi
650 rcondc = rcondi
651 norm = 'I'
652 END IF
653 srnamt = 'DGBCON'
654 CALL dgbcon( norm, n, kl, ku, afac, ldafac,
655 $ iwork, anorm, rcond, work,
656 $ iwork( n+1 ), info )
657*
658* Check error code from DGBCON.
659*
660 IF( info.NE.0 )
661 $ CALL alaerh( path, 'DGBCON', info, 0,
662 $ norm, n, n, kl, ku, -1, imat,
663 $ nfail, nerrs, nout )
664*
665 result( 7 ) = dget06( rcond, rcondc )
666*
667* Print information about the tests that did
668* not pass the threshold.
669*
670 IF( result( 7 ).GE.thresh ) THEN
671 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
672 $ CALL alahd( nout, path )
673 WRITE( nout, fmt = 9995 )norm, n, kl, ku,
674 $ imat, 7, result( 7 )
675 nfail = nfail + 1
676 END IF
677 nrun = nrun + 1
678 100 CONTINUE
679*
680 110 CONTINUE
681 120 CONTINUE
682 130 CONTINUE
683 140 CONTINUE
684 150 CONTINUE
685 160 CONTINUE
686*
687* Print a summary of the results.
688*
689 CALL alasum( path, nout, nfail, nrun, nerrs )
690*
691 9999 FORMAT( ' *** In DCHKGB, LA=', i5, ' is too small for M=', i5,
692 $ ', N=', i5, ', KL=', i4, ', KU=', i4,
693 $ / ' ==> Increase LA to at least ', i5 )
694 9998 FORMAT( ' *** In DCHKGB, LAFAC=', i5, ' is too small for M=', i5,
695 $ ', N=', i5, ', KL=', i4, ', KU=', i4,
696 $ / ' ==> Increase LAFAC to at least ', i5 )
697 9997 FORMAT( ' M =', i5, ', N =', i5, ', KL=', i5, ', KU=', i5,
698 $ ', NB =', i4, ', type ', i1, ', test(', i1, ')=', g12.5 )
699 9996 FORMAT( ' TRANS=''', a1, ''', N=', i5, ', KL=', i5, ', KU=', i5,
700 $ ', NRHS=', i3, ', type ', i1, ', test(', i1, ')=', g12.5 )
701 9995 FORMAT( ' NORM =''', a1, ''', N=', i5, ', KL=', i5, ', KU=', i5,
702 $ ',', 10x, ' type ', i1, ', test(', i1, ')=', g12.5 )
703*
704 RETURN
705*
706* End of DCHKGB
707*
dlacpy
subroutine dlacpy(uplo, m, n, a, lda, b, ldb)
DLACPY copies all or part of one two-dimensional array to another.
Definition dlacpy.f:103
dlaset
subroutine dlaset(uplo, m, n, alpha, beta, a, lda)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition dlaset.f:110
dlangb
double precision function dlangb(norm, n, kl, ku, ab, ldab, work)
DLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition dlangb.f:124
dgbtrs
subroutine dgbtrs(trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
DGBTRS
Definition dgbtrs.f:138
dgbtrf
subroutine dgbtrf(m, n, kl, ku, ab, ldab, ipiv, info)
DGBTRF
Definition dgbtrf.f:144
dgbrfs
subroutine dgbrfs(trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
DGBRFS
Definition dgbrfs.f:205
dgbcon
subroutine dgbcon(norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond, work, iwork, info)
DGBCON
Definition dgbcon.f:146
dlange
double precision function dlange(norm, m, n, a, lda, work)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition dlange.f:114
dcopy
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
Definition dcopy.f:82
dlarhs
subroutine dlarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
DLARHS
Definition dlarhs.f:205
dgbt02
subroutine dgbt02(trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
DGBT02
Definition dgbt02.f:149
dgbt05
subroutine dgbt05(trans, n, kl, ku, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
DGBT05
Definition dgbt05.f:176
dlatb4
subroutine dlatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
DLATB4
Definition dlatb4.f:120
dgbt01
subroutine dgbt01(m, n, kl, ku, a, lda, afac, ldafac, ipiv, work, resid)
DGBT01
Definition dgbt01.f:126
derrge
subroutine derrge(path, nunit)
DERRGE
Definition derrge.f:55
dget04
subroutine dget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
DGET04
Definition dget04.f:102
dget06
double precision function dget06(rcond, rcondc)
DGET06
Definition dget06.f:55
dlatms
subroutine dlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
DLATMS
Definition dlatms.f:321

◆ dchkge()

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

DCHKGE

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

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

◆ dchkgt()

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

DCHKGT

Purpose:
!>
!> DCHKGT tests DGTTRF, -TRS, -RFS, and -CON
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is DOUBLE PRECISION array, dimension (NMAX*4)
!>
[out]AF
!>          AF is DOUBLE PRECISION array, dimension (NMAX*4)
!>
[out]B
!>          B is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (max(NMAX,2*NSMAX))
!>
[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 144 of file dchkgt.f.

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

◆ dchklq()

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

DCHKLQ

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

Definition at line 193 of file dchklq.f.

196*
197* -- LAPACK test routine --
198* -- LAPACK is a software package provided by Univ. of Tennessee, --
199* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
200*
201* .. Scalar Arguments ..
202 LOGICAL TSTERR
203 INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
204 DOUBLE PRECISION THRESH
205* ..
206* .. Array Arguments ..
207 LOGICAL DOTYPE( * )
208 INTEGER MVAL( * ), NBVAL( * ), NVAL( * ),
209 $ NXVAL( * )
210 DOUBLE PRECISION A( * ), AC( * ), AF( * ), AL( * ), AQ( * ),
211 $ B( * ), RWORK( * ), TAU( * ), WORK( * ),
212 $ X( * ), XACT( * )
213* ..
214*
215* =====================================================================
216*
217* .. Parameters ..
218 INTEGER NTESTS
219 parameter( ntests = 7 )
220 INTEGER NTYPES
221 parameter( ntypes = 8 )
222 DOUBLE PRECISION ZERO
223 parameter( zero = 0.0d0 )
224* ..
225* .. Local Scalars ..
226 CHARACTER DIST, TYPE
227 CHARACTER*3 PATH
228 INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
229 $ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
230 $ NRUN, NT, NX
231 DOUBLE PRECISION ANORM, CNDNUM
232* ..
233* .. Local Arrays ..
234 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
235 DOUBLE PRECISION RESULT( NTESTS )
236* ..
237* .. External Subroutines ..
238 EXTERNAL alaerh, alahd, alasum, derrlq, dgelqs, dget02,
239 $ dlacpy, dlarhs, dlatb4, dlatms, dlqt01, dlqt02,
240 $ dlqt03, 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 ) = 'Double 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 derrlq( 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 DLATB4 and generate a test matrix
298* with DLATMS.
299*
300 CALL dlatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
301 $ CNDNUM, DIST )
302*
303 srnamt = 'DLATMS'
304 CALL dlatms( 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 DLATMS.
309*
310 IF( info.NE.0 ) THEN
311 CALL alaerh( path, 'DLATMS', 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 DLQT01; other values are
318* used in the calls of DLQT02, 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 DGELQF
353*
354 CALL dlqt01( m, n, a, af, aq, al, lda, tau,
355 $ work, lwork, rwork, result( 1 ) )
356 ELSE IF( m.LE.n ) THEN
357*
358* Test DORGLQ, using factorization
359* returned by DLQT01
360*
361 CALL dlqt02( m, n, k, a, af, aq, al, lda, tau,
362 $ work, lwork, rwork, result( 1 ) )
363 ELSE
364 result( 1 ) = zero
365 result( 2 ) = zero
366 END IF
367 IF( m.GE.k ) THEN
368*
369* Test DORMLQ, using factorization returned
370* by DLQT01
371*
372 CALL dlqt03( m, n, k, af, ac, al, aq, lda, tau,
373 $ work, lwork, rwork, result( 3 ) )
374 nt = nt + 4
375*
376* If M>=N and K=N, call DGELQS to solve a system
377* with NRHS right hand sides and compute the
378* residual.
379*
380 IF( k.EQ.m .AND. inb.EQ.1 ) THEN
381*
382* Generate a solution and set the right
383* hand side.
384*
385 srnamt = 'DLARHS'
386 CALL dlarhs( path, 'New', 'Full',
387 $ 'No transpose', m, n, 0, 0,
388 $ nrhs, a, lda, xact, lda, b, lda,
389 $ iseed, info )
390*
391 CALL dlacpy( 'Full', m, nrhs, b, lda, x,
392 $ lda )
393 srnamt = 'DGELQS'
394 CALL dgelqs( m, n, nrhs, af, lda, tau, x,
395 $ lda, work, lwork, info )
396*
397* Check error code from DGELQS.
398*
399 IF( info.NE.0 )
400 $ CALL alaerh( path, 'DGELQS', info, 0, ' ',
401 $ m, n, nrhs, -1, nb, imat,
402 $ nfail, nerrs, nout )
403*
404 CALL dget02( 'No transpose', m, n, nrhs, a,
405 $ lda, x, lda, b, lda, rwork,
406 $ result( 7 ) )
407 nt = nt + 1
408 ELSE
409 result( 7 ) = zero
410 END IF
411 ELSE
412 result( 3 ) = zero
413 result( 4 ) = zero
414 result( 5 ) = zero
415 result( 6 ) = zero
416 END IF
417*
418* Print information about the tests that did not
419* pass the threshold.
420*
421 DO 20 i = 1, nt
422 IF( result( i ).GE.thresh ) THEN
423 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
424 $ CALL alahd( nout, path )
425 WRITE( nout, fmt = 9999 )m, n, k, nb, nx,
426 $ imat, i, result( i )
427 nfail = nfail + 1
428 END IF
429 20 CONTINUE
430 nrun = nrun + nt
431 30 CONTINUE
432 40 CONTINUE
433 50 CONTINUE
434 60 CONTINUE
435 70 CONTINUE
436*
437* Print a summary of the results.
438*
439 CALL alasum( path, nout, nfail, nrun, nerrs )
440*
441 9999 FORMAT( ' M=', i5, ', N=', i5, ', K=', i5, ', NB=', i4, ', NX=',
442 $ i5, ', type ', i2, ', test(', i2, ')=', g12.5 )
443 RETURN
444*
445* End of DCHKLQ
446*
dlqt03
subroutine dlqt03(m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
DLQT03
Definition dlqt03.f:136
dlqt01
subroutine dlqt01(m, n, a, af, q, l, lda, tau, work, lwork, rwork, result)
DLQT01
Definition dlqt01.f:126
dgelqs
subroutine dgelqs(m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
DGELQS
Definition dgelqs.f:121
derrlq
subroutine derrlq(path, nunit)
DERRLQ
Definition derrlq.f:55
dlqt02
subroutine dlqt02(m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
DLQT02
Definition dlqt02.f:135

◆ dchklqt()

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

DCHKLQT

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

Definition at line 100 of file dchklqt.f.

102 IMPLICIT NONE
103*
104* -- LAPACK test routine --
105* -- LAPACK is a software package provided by Univ. of Tennessee, --
106* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
107*
108* .. Scalar Arguments ..
109 LOGICAL TSTERR
110 INTEGER NM, NN, NNB, NOUT
111 DOUBLE PRECISION THRESH
112* ..
113* .. Array Arguments ..
114 INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
115* ..
116*
117* =====================================================================
118*
119* .. Parameters ..
120 INTEGER NTESTS
121 parameter( ntests = 6 )
122* ..
123* .. Local Scalars ..
124 CHARACTER*3 PATH
125 INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN,
126 $ MINMN
127*
128* .. Local Arrays ..
129 DOUBLE PRECISION RESULT( NTESTS )
130* ..
131* .. External Subroutines ..
132 EXTERNAL alaerh, alahd, alasum, derrlqt, dlqt04
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 ) = 'D'
148 path( 2: 3 ) = 'TQ'
149 nrun = 0
150 nfail = 0
151 nerrs = 0
152*
153* Test the error exits
154*
155 IF( tsterr ) CALL derrlqt( 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 DGELQT and DGEMLQT
175*
176 IF( (nb.LE.minmn).AND.(nb.GT.0) ) THEN
177 CALL dlqt04( 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 DCHKLQT
206*
dlqt04
subroutine dlqt04(m, n, nb, result)
DLQT04
Definition dlqt04.f:73
derrlqt
subroutine derrlqt(path, nunit)
DERLQT
Definition derrlqt.f:55

◆ dchklqtp()

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

DCHKLQTP

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

Definition at line 100 of file dchklqtp.f.

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

◆ dchkorhr_col()

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

DCHKORHR_COL

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

Definition at line 106 of file dchkorhr_col.f.

108 IMPLICIT NONE
109*
110* -- LAPACK test routine --
111* -- LAPACK is a software package provided by Univ. of Tennessee, --
112* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
113*
114* .. Scalar Arguments ..
115 LOGICAL TSTERR
116 INTEGER NM, NN, NNB, NOUT
117 DOUBLE PRECISION THRESH
118* ..
119* .. Array Arguments ..
120 INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
121* ..
122*
123* =====================================================================
124*
125* .. Parameters ..
126 INTEGER NTESTS
127 parameter( ntests = 6 )
128* ..
129* .. Local Scalars ..
130 CHARACTER(LEN=3) PATH
131 INTEGER I, IMB1, INB1, INB2, J, T, M, N, MB1, NB1,
132 $ NB2, NFAIL, NERRS, NRUN
133*
134* .. Local Arrays ..
135 DOUBLE PRECISION RESULT( NTESTS )
136* ..
137* .. External Subroutines ..
138 EXTERNAL alahd, alasum, derrorhr_col, dorhr_col01,
139 $ dorhr_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 ) = 'D'
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 derrorhr_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 DORHR_COL
204*
205 CALL dorhr_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 DORHR_COL
266*
267 CALL dorhr_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( 'DORGTSQR and DORHR_COL: M=', i5, ', N=', i5,
297 $ ', MB1=', i5, ', NB1=', i5, ', NB2=', i5,
298 $ ' test(', i2, ')=', g12.5 )
299 9998 FORMAT( 'DORGTSQR_ROW and DORHR_COL: M=', i5, ', N=', i5,
300 $ ', MB1=', i5, ', NB1=', i5, ', NB2=', i5,
301 $ ' test(', i2, ')=', g12.5 )
302 RETURN
303*
304* End of DCHKORHR_COL
305*
dorhr_col01
subroutine dorhr_col01(m, n, mb1, nb1, nb2, result)
DORHR_COL01
Definition dorhr_col01.f:119
dorhr_col02
subroutine dorhr_col02(m, n, mb1, nb1, nb2, result)
DORHR_COL02
Definition dorhr_col02.f:120
derrorhr_col
subroutine derrorhr_col(path, nunit)
DERRORHR_COL
Definition derrorhr_col.f:56

◆ dchkpb()

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

DCHKPB

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

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

◆ dchkpo()

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

DCHKPO

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

172*
173* -- LAPACK test routine --
174* -- LAPACK is a software package provided by Univ. of Tennessee, --
175* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176*
177* .. Scalar Arguments ..
178 LOGICAL TSTERR
179 INTEGER NMAX, NN, NNB, NNS, NOUT
180 DOUBLE PRECISION THRESH
181* ..
182* .. Array Arguments ..
183 LOGICAL DOTYPE( * )
184 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
185 DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
186 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
187* ..
188*
189* =====================================================================
190*
191* .. Parameters ..
192 DOUBLE PRECISION ZERO
193 parameter( zero = 0.0d+0 )
194 INTEGER NTYPES
195 parameter( ntypes = 9 )
196 INTEGER NTESTS
197 parameter( ntests = 8 )
198* ..
199* .. Local Scalars ..
200 LOGICAL ZEROT
201 CHARACTER DIST, TYPE, UPLO, XTYPE
202 CHARACTER*3 PATH
203 INTEGER I, IMAT, IN, INB, INFO, IOFF, IRHS, IUPLO,
204 $ IZERO, K, KL, KU, LDA, MODE, N, NB, NERRS,
205 $ NFAIL, NIMAT, NRHS, NRUN
206 DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
207* ..
208* .. Local Arrays ..
209 CHARACTER UPLOS( 2 )
210 INTEGER ISEED( 4 ), ISEEDY( 4 )
211 DOUBLE PRECISION RESULT( NTESTS )
212* ..
213* .. External Functions ..
214 DOUBLE PRECISION DGET06, DLANSY
215 EXTERNAL dget06, dlansy
216* ..
217* .. External Subroutines ..
218 EXTERNAL alaerh, alahd, alasum, derrpo, dget04, dlacpy,
219 $ dlarhs, dlatb4, dlatms, dpocon, dporfs, dpot01,
220 $ dpot02, dpot03, dpot05, dpotrf, dpotri, dpotrs,
221 $ xlaenv
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* .. Intrinsic Functions ..
233 INTRINSIC max
234* ..
235* .. Data statements ..
236 DATA iseedy / 1988, 1989, 1990, 1991 /
237 DATA uplos / 'U', 'L' /
238* ..
239* .. Executable Statements ..
240*
241* Initialize constants and the random number seed.
242*
243 path( 1: 1 ) = 'Double precision'
244 path( 2: 3 ) = 'PO'
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 derrpo( path, nout )
256 infot = 0
257 CALL xlaenv( 2, 2 )
258*
259* Do for each value of N in NVAL
260*
261 DO 120 in = 1, nn
262 n = nval( in )
263 lda = max( n, 1 )
264 xtype = 'N'
265 nimat = ntypes
266 IF( n.LE.0 )
267 $ nimat = 1
268*
269 izero = 0
270 DO 110 imat = 1, nimat
271*
272* Do the tests only if DOTYPE( IMAT ) is true.
273*
274 IF( .NOT.dotype( imat ) )
275 $ GO TO 110
276*
277* Skip types 3, 4, or 5 if the matrix size is too small.
278*
279 zerot = imat.GE.3 .AND. imat.LE.5
280 IF( zerot .AND. n.LT.imat-2 )
281 $ GO TO 110
282*
283* Do first for UPLO = 'U', then for UPLO = 'L'
284*
285 DO 100 iuplo = 1, 2
286 uplo = uplos( iuplo )
287*
288* Set up parameters with DLATB4 and generate a test matrix
289* with DLATMS.
290*
291 CALL dlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
292 $ CNDNUM, DIST )
293*
294 srnamt = 'DLATMS'
295 CALL dlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
296 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
297 $ INFO )
298*
299* Check error code from DLATMS.
300*
301 IF( info.NE.0 ) THEN
302 CALL alaerh( path, 'DLATMS', info, 0, uplo, n, n, -1,
303 $ -1, -1, imat, nfail, nerrs, nout )
304 GO TO 100
305 END IF
306*
307* For types 3-5, zero one row and column of the matrix to
308* 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 ioff = ( izero-1 )*lda
319*
320* Set row and column IZERO of A to 0.
321*
322 IF( iuplo.EQ.1 ) THEN
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 + lda
330 30 CONTINUE
331 ELSE
332 ioff = izero
333 DO 40 i = 1, izero - 1
334 a( ioff ) = zero
335 ioff = ioff + lda
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 izero = 0
344 END IF
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 dlacpy( uplo, n, n, a, lda, afac, lda )
355 srnamt = 'DPOTRF'
356 CALL dpotrf( uplo, n, afac, lda, info )
357*
358* Check error code from DPOTRF.
359*
360 IF( info.NE.izero ) THEN
361 CALL alaerh( path, 'DPOTRF', 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 dlacpy( uplo, n, n, afac, lda, ainv, lda )
376 CALL dpot01( 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 dlacpy( uplo, n, n, afac, lda, ainv, lda )
383 srnamt = 'DPOTRI'
384 CALL dpotri( uplo, n, ainv, lda, info )
385*
386* Check error code from DPOTRI.
387*
388 IF( info.NE.0 )
389 $ CALL alaerh( path, 'DPOTRI', info, 0, uplo, n, n,
390 $ -1, -1, -1, imat, nfail, nerrs, nout )
391*
392 CALL dpot03( 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 = 'DLARHS'
422 CALL dlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
423 $ nrhs, a, lda, xact, lda, b, lda,
424 $ iseed, info )
425 CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
426*
427 srnamt = 'DPOTRS'
428 CALL dpotrs( uplo, n, nrhs, afac, lda, x, lda,
429 $ info )
430*
431* Check error code from DPOTRS.
432*
433 IF( info.NE.0 )
434 $ CALL alaerh( path, 'DPOTRS', info, 0, uplo, n,
435 $ n, -1, -1, nrhs, imat, nfail,
436 $ nerrs, nout )
437*
438 CALL dlacpy( 'Full', n, nrhs, b, lda, work, lda )
439 CALL dpot02( 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 dget04( 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 = 'DPORFS'
452 CALL dporfs( uplo, n, nrhs, a, lda, afac, lda, b,
453 $ lda, x, lda, rwork, rwork( nrhs+1 ),
454 $ work, iwork, info )
455*
456* Check error code from DPORFS.
457*
458 IF( info.NE.0 )
459 $ CALL alaerh( path, 'DPORFS', info, 0, uplo, n,
460 $ n, -1, -1, nrhs, imat, nfail,
461 $ nerrs, nout )
462*
463 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
464 $ result( 5 ) )
465 CALL dpot05( 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 = dlansy( '1', uplo, n, a, lda, rwork )
488 srnamt = 'DPOCON'
489 CALL dpocon( uplo, n, afac, lda, anorm, rcond, work,
490 $ iwork, info )
491*
492* Check error code from DPOCON.
493*
494 IF( info.NE.0 )
495 $ CALL alaerh( path, 'DPOCON', info, 0, uplo, n, n,
496 $ -1, -1, -1, imat, nfail, nerrs, nout )
497*
498 result( 8 ) = dget06( rcond, rcondc )
499*
500* Print the test ratio if it is .GE. THRESH.
501*
502 IF( result( 8 ).GE.thresh ) THEN
503 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
504 $ CALL alahd( nout, path )
505 WRITE( nout, fmt = 9997 )uplo, n, imat, 8,
506 $ result( 8 )
507 nfail = nfail + 1
508 END IF
509 nrun = nrun + 1
510 90 CONTINUE
511 100 CONTINUE
512 110 CONTINUE
513 120 CONTINUE
514*
515* Print a summary of the results.
516*
517 CALL alasum( path, nout, nfail, nrun, nerrs )
518*
519 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
520 $ i2, ', test ', i2, ', ratio =', g12.5 )
521 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
522 $ i2, ', test(', i2, ') =', g12.5 )
523 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
524 $ ', test(', i2, ') =', g12.5 )
525 RETURN
526*
527* End of DCHKPO
528*
dpotrs
subroutine dpotrs(uplo, n, nrhs, a, lda, b, ldb, info)
DPOTRS
Definition dpotrs.f:110
dpotrf
subroutine dpotrf(uplo, n, a, lda, info)
DPOTRF
Definition dpotrf.f:107
dpocon
subroutine dpocon(uplo, n, a, lda, anorm, rcond, work, iwork, info)
DPOCON
Definition dpocon.f:121
dpotri
subroutine dpotri(uplo, n, a, lda, info)
DPOTRI
Definition dpotri.f:95
dporfs
subroutine dporfs(uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx, ferr, berr, work, iwork, info)
DPORFS
Definition dporfs.f:183
dlansy
double precision function dlansy(norm, uplo, n, a, lda, work)
DLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlansy.f:122
dpot01
subroutine dpot01(uplo, n, a, lda, afac, ldafac, rwork, resid)
DPOT01
Definition dpot01.f:104
dpot02
subroutine dpot02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
DPOT02
Definition dpot02.f:127
dpot03
subroutine dpot03(uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
DPOT03
Definition dpot03.f:125
dpot05
subroutine dpot05(uplo, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
DPOT05
Definition dpot05.f:164

◆ dchkpp()

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

DCHKPP

Purpose:
!>
!> DCHKPP tests DPPTRF, -TRI, -TRS, -RFS, and -CON
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is DOUBLE PRECISION array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AFAC
!>          AFAC is DOUBLE PRECISION array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AINV
!>          AINV is DOUBLE PRECISION array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (max(NMAX,2*NSMAX))
!>
[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 160 of file dchkpp.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, NNS, NOUT
171 DOUBLE PRECISION THRESH
172* ..
173* .. Array Arguments ..
174 LOGICAL DOTYPE( * )
175 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
176 DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
177 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 DOUBLE PRECISION ZERO
184 parameter( zero = 0.0d+0 )
185 INTEGER NTYPES
186 parameter( ntypes = 9 )
187 INTEGER NTESTS
188 parameter( ntests = 8 )
189* ..
190* .. Local Scalars ..
191 LOGICAL ZEROT
192 CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE
193 CHARACTER*3 PATH
194 INTEGER I, IMAT, IN, INFO, IOFF, IRHS, IUPLO, IZERO, K,
195 $ KL, KU, LDA, MODE, N, NERRS, NFAIL, NIMAT, NPP,
196 $ NRHS, NRUN
197 DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
198* ..
199* .. Local Arrays ..
200 CHARACTER PACKS( 2 ), UPLOS( 2 )
201 INTEGER ISEED( 4 ), ISEEDY( 4 )
202 DOUBLE PRECISION RESULT( NTESTS )
203* ..
204* .. External Functions ..
205 DOUBLE PRECISION DGET06, DLANSP
206 EXTERNAL dget06, dlansp
207* ..
208* .. External Subroutines ..
209 EXTERNAL alaerh, alahd, alasum, dcopy, derrpo, dget04,
210 $ dlacpy, dlarhs, dlatb4, dlatms, dppcon, dpprfs,
211 $ dppt01, dppt02, dppt03, dppt05, dpptrf, dpptri,
212 $ dpptrs
213* ..
214* .. Scalars in Common ..
215 LOGICAL LERR, OK
216 CHARACTER*32 SRNAMT
217 INTEGER INFOT, NUNIT
218* ..
219* .. Common blocks ..
220 COMMON / infoc / infot, nunit, ok, lerr
221 COMMON / srnamc / srnamt
222* ..
223* .. Intrinsic Functions ..
224 INTRINSIC max
225* ..
226* .. Data statements ..
227 DATA iseedy / 1988, 1989, 1990, 1991 /
228 DATA uplos / 'U', 'L' / , packs / 'C', 'R' /
229* ..
230* .. Executable Statements ..
231*
232* Initialize constants and the random number seed.
233*
234 path( 1: 1 ) = 'Double 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 derrpo( path, nout )
247 infot = 0
248*
249* Do for each value of N in NVAL
250*
251 DO 110 in = 1, nn
252 n = nval( in )
253 lda = max( n, 1 )
254 xtype = 'N'
255 nimat = ntypes
256 IF( n.LE.0 )
257 $ nimat = 1
258*
259 DO 100 imat = 1, nimat
260*
261* Do the tests only if DOTYPE( IMAT ) is true.
262*
263 IF( .NOT.dotype( imat ) )
264 $ GO TO 100
265*
266* Skip types 3, 4, or 5 if the matrix size is too small.
267*
268 zerot = imat.GE.3 .AND. imat.LE.5
269 IF( zerot .AND. n.LT.imat-2 )
270 $ GO TO 100
271*
272* Do first for UPLO = 'U', then for UPLO = 'L'
273*
274 DO 90 iuplo = 1, 2
275 uplo = uplos( iuplo )
276 packit = packs( iuplo )
277*
278* Set up parameters with DLATB4 and generate a test matrix
279* with DLATMS.
280*
281 CALL dlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
282 $ CNDNUM, DIST )
283*
284 srnamt = 'DLATMS'
285 CALL dlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
286 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
287 $ INFO )
288*
289* Check error code from DLATMS.
290*
291 IF( info.NE.0 ) THEN
292 CALL alaerh( path, 'DLATMS', info, 0, uplo, n, n, -1,
293 $ -1, -1, imat, nfail, nerrs, nout )
294 GO TO 90
295 END IF
296*
297* For types 3-5, zero one row and column of the matrix to
298* 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* Set row and column IZERO of A to 0.
310*
311 IF( iuplo.EQ.1 ) THEN
312 ioff = ( izero-1 )*izero / 2
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 + i
320 30 CONTINUE
321 ELSE
322 ioff = izero
323 DO 40 i = 1, izero - 1
324 a( ioff ) = zero
325 ioff = ioff + n - i
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 izero = 0
334 END IF
335*
336* Compute the L*L' or U'*U factorization of the matrix.
337*
338 npp = n*( n+1 ) / 2
339 CALL dcopy( npp, a, 1, afac, 1 )
340 srnamt = 'DPPTRF'
341 CALL dpptrf( uplo, n, afac, info )
342*
343* Check error code from DPPTRF.
344*
345 IF( info.NE.izero ) THEN
346 CALL alaerh( path, 'DPPTRF', info, izero, uplo, n, n,
347 $ -1, -1, -1, imat, nfail, nerrs, nout )
348 GO TO 90
349 END IF
350*
351* Skip the tests if INFO is not 0.
352*
353 IF( info.NE.0 )
354 $ GO TO 90
355*
356*+ TEST 1
357* Reconstruct matrix from factors and compute residual.
358*
359 CALL dcopy( npp, afac, 1, ainv, 1 )
360 CALL dppt01( uplo, n, a, ainv, rwork, result( 1 ) )
361*
362*+ TEST 2
363* Form the inverse and compute the residual.
364*
365 CALL dcopy( npp, afac, 1, ainv, 1 )
366 srnamt = 'DPPTRI'
367 CALL dpptri( uplo, n, ainv, info )
368*
369* Check error code from DPPTRI.
370*
371 IF( info.NE.0 )
372 $ CALL alaerh( path, 'DPPTRI', info, 0, uplo, n, n, -1,
373 $ -1, -1, imat, nfail, nerrs, nout )
374*
375 CALL dppt03( uplo, n, a, ainv, work, lda, rwork, rcondc,
376 $ result( 2 ) )
377*
378* Print information about the tests that did not pass
379* the threshold.
380*
381 DO 60 k = 1, 2
382 IF( result( k ).GE.thresh ) THEN
383 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
384 $ CALL alahd( nout, path )
385 WRITE( nout, fmt = 9999 )uplo, n, imat, k,
386 $ result( k )
387 nfail = nfail + 1
388 END IF
389 60 CONTINUE
390 nrun = nrun + 2
391*
392 DO 80 irhs = 1, nns
393 nrhs = nsval( irhs )
394*
395*+ TEST 3
396* Solve and compute residual for A * X = B.
397*
398 srnamt = 'DLARHS'
399 CALL dlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
400 $ nrhs, a, lda, xact, lda, b, lda, iseed,
401 $ info )
402 CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
403*
404 srnamt = 'DPPTRS'
405 CALL dpptrs( uplo, n, nrhs, afac, x, lda, info )
406*
407* Check error code from DPPTRS.
408*
409 IF( info.NE.0 )
410 $ CALL alaerh( path, 'DPPTRS', info, 0, uplo, n, n,
411 $ -1, -1, nrhs, imat, nfail, nerrs,
412 $ nout )
413*
414 CALL dlacpy( 'Full', n, nrhs, b, lda, work, lda )
415 CALL dppt02( uplo, n, nrhs, a, x, lda, work, lda,
416 $ rwork, result( 3 ) )
417*
418*+ TEST 4
419* Check solution from generated exact solution.
420*
421 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
422 $ result( 4 ) )
423*
424*+ TESTS 5, 6, and 7
425* Use iterative refinement to improve the solution.
426*
427 srnamt = 'DPPRFS'
428 CALL dpprfs( uplo, n, nrhs, a, afac, b, lda, x, lda,
429 $ rwork, rwork( nrhs+1 ), work, iwork,
430 $ info )
431*
432* Check error code from DPPRFS.
433*
434 IF( info.NE.0 )
435 $ CALL alaerh( path, 'DPPRFS', info, 0, uplo, n, n,
436 $ -1, -1, nrhs, imat, nfail, nerrs,
437 $ nout )
438*
439 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
440 $ result( 5 ) )
441 CALL dppt05( uplo, n, nrhs, a, b, lda, x, lda, xact,
442 $ lda, rwork, rwork( nrhs+1 ),
443 $ result( 6 ) )
444*
445* Print information about the tests that did not pass
446* the threshold.
447*
448 DO 70 k = 3, 7
449 IF( result( k ).GE.thresh ) THEN
450 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
451 $ CALL alahd( nout, path )
452 WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat,
453 $ k, result( k )
454 nfail = nfail + 1
455 END IF
456 70 CONTINUE
457 nrun = nrun + 5
458 80 CONTINUE
459*
460*+ TEST 8
461* Get an estimate of RCOND = 1/CNDNUM.
462*
463 anorm = dlansp( '1', uplo, n, a, rwork )
464 srnamt = 'DPPCON'
465 CALL dppcon( uplo, n, afac, anorm, rcond, work, iwork,
466 $ info )
467*
468* Check error code from DPPCON.
469*
470 IF( info.NE.0 )
471 $ CALL alaerh( path, 'DPPCON', info, 0, uplo, n, n, -1,
472 $ -1, -1, imat, nfail, nerrs, nout )
473*
474 result( 8 ) = dget06( rcond, rcondc )
475*
476* Print the test ratio if greater than or equal to THRESH.
477*
478 IF( result( 8 ).GE.thresh ) THEN
479 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
480 $ CALL alahd( nout, path )
481 WRITE( nout, fmt = 9999 )uplo, n, imat, 8,
482 $ result( 8 )
483 nfail = nfail + 1
484 END IF
485 nrun = nrun + 1
486 90 CONTINUE
487 100 CONTINUE
488 110 CONTINUE
489*
490* Print a summary of the results.
491*
492 CALL alasum( path, nout, nfail, nrun, nerrs )
493*
494 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', type ', i2, ', test ',
495 $ i2, ', ratio =', g12.5 )
496 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
497 $ i2, ', test(', i2, ') =', g12.5 )
498 RETURN
499*
500* End of DCHKPP
501*
dlansp
double precision function dlansp(norm, uplo, n, ap, work)
DLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlansp.f:114
dppcon
subroutine dppcon(uplo, n, ap, anorm, rcond, work, iwork, info)
DPPCON
Definition dppcon.f:118
dpptrs
subroutine dpptrs(uplo, n, nrhs, ap, b, ldb, info)
DPPTRS
Definition dpptrs.f:108
dpptri
subroutine dpptri(uplo, n, ap, info)
DPPTRI
Definition dpptri.f:93
dpptrf
subroutine dpptrf(uplo, n, ap, info)
DPPTRF
Definition dpptrf.f:119
dpprfs
subroutine dpprfs(uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr, work, iwork, info)
DPPRFS
Definition dpprfs.f:171
dppt01
subroutine dppt01(uplo, n, a, afac, rwork, resid)
DPPT01
Definition dppt01.f:93
dppt02
subroutine dppt02(uplo, n, nrhs, a, x, ldx, b, ldb, rwork, resid)
DPPT02
Definition dppt02.f:122
dppt05
subroutine dppt05(uplo, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
DPPT05
Definition dppt05.f:156
dppt03
subroutine dppt03(uplo, n, a, ainv, work, ldwork, rwork, rcond, resid)
DPPT03
Definition dppt03.f:110

◆ dchkps()

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

DCHKPS

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

Definition at line 151 of file dchkps.f.

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

◆ dchkpt()

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

DCHKPT

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

Definition at line 144 of file dchkpt.f.

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

◆ dchkq3()

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

DCHKQ3

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

◆ dchkql()

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

DCHKQL

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

Definition at line 193 of file dchkql.f.

196*
197* -- LAPACK test routine --
198* -- LAPACK is a software package provided by Univ. of Tennessee, --
199* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
200*
201* .. Scalar Arguments ..
202 LOGICAL TSTERR
203 INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
204 DOUBLE PRECISION THRESH
205* ..
206* .. Array Arguments ..
207 LOGICAL DOTYPE( * )
208 INTEGER MVAL( * ), NBVAL( * ), NVAL( * ),
209 $ NXVAL( * )
210 DOUBLE PRECISION A( * ), AC( * ), AF( * ), AL( * ), AQ( * ),
211 $ B( * ), RWORK( * ), TAU( * ), WORK( * ),
212 $ X( * ), XACT( * )
213* ..
214*
215* =====================================================================
216*
217* .. Parameters ..
218 INTEGER NTESTS
219 parameter( ntests = 7 )
220 INTEGER NTYPES
221 parameter( ntypes = 8 )
222 DOUBLE PRECISION ZERO
223 parameter( zero = 0.0d0 )
224* ..
225* .. Local Scalars ..
226 CHARACTER DIST, TYPE
227 CHARACTER*3 PATH
228 INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
229 $ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
230 $ NRUN, NT, NX
231 DOUBLE PRECISION ANORM, CNDNUM
232* ..
233* .. Local Arrays ..
234 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
235 DOUBLE PRECISION RESULT( NTESTS )
236* ..
237* .. External Subroutines ..
238 EXTERNAL alaerh, alahd, alasum, derrql, dgeqls, dget02,
239 $ dlacpy, dlarhs, dlatb4, dlatms, dqlt01, dqlt02,
240 $ dqlt03, 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 ) = 'Double 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 derrql( 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 DLATB4 and generate a test matrix
298* with DLATMS.
299*
300 CALL dlatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
301 $ CNDNUM, DIST )
302*
303 srnamt = 'DLATMS'
304 CALL dlatms( 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 DLATMS.
309*
310 IF( info.NE.0 ) THEN
311 CALL alaerh( path, 'DLATMS', 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 DQLT01; other values are
318* used in the calls of DQLT02, 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 DGEQLF
353*
354 CALL dqlt01( m, n, a, af, aq, al, lda, tau,
355 $ work, lwork, rwork, result( 1 ) )
356 ELSE IF( m.GE.n ) THEN
357*
358* Test DORGQL, using factorization
359* returned by DQLT01
360*
361 CALL dqlt02( 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 DORMQL, using factorization returned
367* by DQLT01
368*
369 CALL dqlt03( 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 DGEQLS 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 = 'DLARHS'
383 CALL dlarhs( path, 'New', 'Full',
384 $ 'No transpose', m, n, 0, 0,
385 $ nrhs, a, lda, xact, lda, b, lda,
386 $ iseed, info )
387*
388 CALL dlacpy( 'Full', m, nrhs, b, lda, x,
389 $ lda )
390 srnamt = 'DGEQLS'
391 CALL dgeqls( m, n, nrhs, af, lda, tau, x,
392 $ lda, work, lwork, info )
393*
394* Check error code from DGEQLS.
395*
396 IF( info.NE.0 )
397 $ CALL alaerh( path, 'DGEQLS', info, 0, ' ',
398 $ m, n, nrhs, -1, nb, imat,
399 $ nfail, nerrs, nout )
400*
401 CALL dget02( '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 DCHKQL
436*
derrql
subroutine derrql(path, nunit)
DERRQL
Definition derrql.f:55
dqlt03
subroutine dqlt03(m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
DQLT03
Definition dqlt03.f:136
dgeqls
subroutine dgeqls(m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
DGEQLS
Definition dgeqls.f:122
dqlt02
subroutine dqlt02(m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
DQLT02
Definition dqlt02.f:136
dqlt01
subroutine dqlt01(m, n, a, af, q, l, lda, tau, work, lwork, rwork, result)
DQLT01
Definition dqlt01.f:126

◆ dchkqr()

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

DCHKQR

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

Definition at line 198 of file dchkqr.f.

201*
202* -- LAPACK test routine --
203* -- LAPACK is a software package provided by Univ. of Tennessee, --
204* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
205*
206* .. Scalar Arguments ..
207 LOGICAL TSTERR
208 INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
209 DOUBLE PRECISION THRESH
210* ..
211* .. Array Arguments ..
212 LOGICAL DOTYPE( * )
213 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
214 $ NXVAL( * )
215 DOUBLE PRECISION A( * ), AC( * ), AF( * ), AQ( * ), AR( * ),
216 $ B( * ), RWORK( * ), TAU( * ), WORK( * ),
217 $ X( * ), XACT( * )
218* ..
219*
220* =====================================================================
221*
222* .. Parameters ..
223 INTEGER NTESTS
224 parameter( ntests = 9 )
225 INTEGER NTYPES
226 parameter( ntypes = 8 )
227 DOUBLE PRECISION ZERO
228 parameter( zero = 0.0d0 )
229* ..
230* .. Local Scalars ..
231 CHARACTER DIST, TYPE
232 CHARACTER*3 PATH
233 INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
234 $ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
235 $ NRUN, NT, NX
236 DOUBLE PRECISION ANORM, CNDNUM
237* ..
238* .. Local Arrays ..
239 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
240 DOUBLE PRECISION RESULT( NTESTS )
241* ..
242* .. External Functions ..
243 LOGICAL DGENND
244 EXTERNAL dgennd
245* ..
246* .. External Subroutines ..
247 EXTERNAL alaerh, alahd, alasum, derrqr, dgeqrs, dget02,
248 $ dlacpy, dlarhs, dlatb4, dlatms, dqrt01,
249 $ dqrt01p, dqrt02, dqrt03, 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 ) = 'Double 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 derrqr( 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 DLATB4 and generate a test matrix
307* with DLATMS.
308*
309 CALL dlatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
310 $ CNDNUM, DIST )
311*
312 srnamt = 'DLATMS'
313 CALL dlatms( 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 DLATMS.
318*
319 IF( info.NE.0 ) THEN
320 CALL alaerh( path, 'DLATMS', 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 DQRT01; other values are
327* used in the calls of DQRT02, 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 DGEQRF
362*
363 CALL dqrt01( m, n, a, af, aq, ar, lda, tau,
364 $ work, lwork, rwork, result( 1 ) )
365
366*
367* Test DGEQRFP
368*
369 CALL dqrt01p( m, n, a, af, aq, ar, lda, tau,
370 $ work, lwork, rwork, result( 8 ) )
371
372 IF( .NOT. dgennd( m, n, af, lda ) )
373 $ result( 9 ) = 2*thresh
374 nt = nt + 1
375 ELSE IF( m.GE.n ) THEN
376*
377* Test DORGQR, using factorization
378* returned by DQRT01
379*
380 CALL dqrt02( m, n, k, a, af, aq, ar, lda, tau,
381 $ work, lwork, rwork, result( 1 ) )
382 END IF
383 IF( m.GE.k ) THEN
384*
385* Test DORMQR, using factorization returned
386* by DQRT01
387*
388 CALL dqrt03( m, n, k, af, ac, ar, aq, lda, tau,
389 $ work, lwork, rwork, result( 3 ) )
390 nt = nt + 4
391*
392* If M>=N and K=N, call DGEQRS to solve a system
393* with NRHS right hand sides and compute the
394* residual.
395*
396 IF( k.EQ.n .AND. inb.EQ.1 ) THEN
397*
398* Generate a solution and set the right
399* hand side.
400*
401 srnamt = 'DLARHS'
402 CALL dlarhs( path, 'New', 'Full',
403 $ 'No transpose', m, n, 0, 0,
404 $ nrhs, a, lda, xact, lda, b, lda,
405 $ iseed, info )
406*
407 CALL dlacpy( 'Full', m, nrhs, b, lda, x,
408 $ lda )
409 srnamt = 'DGEQRS'
410 CALL dgeqrs( m, n, nrhs, af, lda, tau, x,
411 $ lda, work, lwork, info )
412*
413* Check error code from DGEQRS.
414*
415 IF( info.NE.0 )
416 $ CALL alaerh( path, 'DGEQRS', info, 0, ' ',
417 $ m, n, nrhs, -1, nb, imat,
418 $ nfail, nerrs, nout )
419*
420 CALL dget02( 'No transpose', m, n, nrhs, a,
421 $ lda, x, lda, b, lda, rwork,
422 $ result( 7 ) )
423 nt = nt + 1
424 END IF
425 END IF
426*
427* Print information about the tests that did not
428* pass the threshold.
429*
430 DO 20 i = 1, ntests
431 IF( result( i ).GE.thresh ) THEN
432 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
433 $ CALL alahd( nout, path )
434 WRITE( nout, fmt = 9999 )m, n, k, nb, nx,
435 $ imat, i, result( i )
436 nfail = nfail + 1
437 END IF
438 20 CONTINUE
439 nrun = nrun + ntests
440 30 CONTINUE
441 40 CONTINUE
442 50 CONTINUE
443 60 CONTINUE
444 70 CONTINUE
445*
446* Print a summary of the results.
447*
448 CALL alasum( path, nout, nfail, nrun, nerrs )
449*
450 9999 FORMAT( ' M=', i5, ', N=', i5, ', K=', i5, ', NB=', i4, ', NX=',
451 $ i5, ', type ', i2, ', test(', i2, ')=', g12.5 )
452 RETURN
453*
454* End of DCHKQR
455*
dgeqrs
subroutine dgeqrs(m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
DGEQRS
Definition dgeqrs.f:121
dqrt01
subroutine dqrt01(m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
DQRT01
Definition dqrt01.f:126
dqrt01p
subroutine dqrt01p(m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
DQRT01P
Definition dqrt01p.f:126
derrqr
subroutine derrqr(path, nunit)
DERRQR
Definition derrqr.f:55
dgennd
logical function dgennd(m, n, a, lda)
DGENND
Definition dgennd.f:68
dqrt03
subroutine dqrt03(m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
DQRT03
Definition dqrt03.f:136
dqrt02
subroutine dqrt02(m, n, k, a, af, q, r, lda, tau, work, lwork, rwork, result)
DQRT02
Definition dqrt02.f:135

◆ dchkqrt()

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

DCHKQRT

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

Definition at line 100 of file dchkqrt.f.

102 IMPLICIT NONE
103*
104* -- LAPACK test routine --
105* -- LAPACK is a software package provided by Univ. of Tennessee, --
106* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
107*
108* .. Scalar Arguments ..
109 LOGICAL TSTERR
110 INTEGER NM, NN, NNB, NOUT
111 DOUBLE PRECISION THRESH
112* ..
113* .. Array Arguments ..
114 INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
115* ..
116*
117* =====================================================================
118*
119* .. Parameters ..
120 INTEGER NTESTS
121 parameter( ntests = 6 )
122* ..
123* .. Local Scalars ..
124 CHARACTER*3 PATH
125 INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN,
126 $ MINMN
127*
128* .. Local Arrays ..
129 DOUBLE PRECISION RESULT( NTESTS )
130* ..
131* .. External Subroutines ..
132 EXTERNAL alaerh, alahd, alasum, derrqrt, dqrt04
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 ) = 'D'
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 derrqrt( 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 DGEQRT and DGEMQRT
175*
176 IF( (nb.LE.minmn).AND.(nb.GT.0) ) THEN
177 CALL dqrt04( 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 DCHKQRT
206*
dqrt04
subroutine dqrt04(m, n, nb, result)
DQRT04
Definition dqrt04.f:73
derrqrt
subroutine derrqrt(path, nunit)
DERRQRT
Definition derrqrt.f:55

◆ dchkqrtp()

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

DCHKQRTP

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

Definition at line 100 of file dchkqrtp.f.

102 IMPLICIT NONE
103*
104* -- LAPACK test routine --
105* -- LAPACK is a software package provided by Univ. of Tennessee, --
106* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
107*
108* .. Scalar Arguments ..
109 LOGICAL TSTERR
110 INTEGER NM, NN, NNB, NOUT
111 DOUBLE PRECISION THRESH
112* ..
113* .. Array Arguments ..
114 INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
115* ..
116*
117* =====================================================================
118*
119* .. Parameters ..
120 INTEGER NTESTS
121 parameter( ntests = 6 )
122* ..
123* .. Local Scalars ..
124 CHARACTER*3 PATH
125 INTEGER I, J, K, L, T, M, N, NB, NFAIL, NERRS, NRUN,
126 $ MINMN
127* ..
128* .. Local Arrays ..
129 DOUBLE PRECISION RESULT( NTESTS )
130* ..
131* .. External Subroutines ..
132 EXTERNAL alaerh, alahd, alasum, derrqrtp
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 ) = 'D'
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 derrqrtp( path, nout )
156 infot = 0
157*
158* Do for each value of M
159*
160 DO i = 1, nm
161 m = mval( i )
162*
163* Do for each value of N
164*
165 DO j = 1, nn
166 n = nval( j )
167*
168* Do for each value of L
169*
170 minmn = min( m, n )
171 DO l = 0, minmn, max( minmn, 1 )
172*
173* Do for each possible value of NB
174*
175 DO k = 1, nnb
176 nb = nbval( k )
177*
178* Test DTPQRT and DTPMQRT
179*
180 IF( (nb.LE.n).AND.(nb.GT.0) ) THEN
181 CALL dqrt05( m, n, l, nb, result )
182*
183* Print information about the tests that did not
184* pass the threshold.
185*
186 DO t = 1, ntests
187 IF( result( t ).GE.thresh ) THEN
188 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
189 $ CALL alahd( nout, path )
190 WRITE( nout, fmt = 9999 )m, n, nb, l,
191 $ t, result( t )
192 nfail = nfail + 1
193 END IF
194 END DO
195 nrun = nrun + ntests
196 END IF
197 END DO
198 END DO
199 END DO
200 END DO
201*
202* Print a summary of the results.
203*
204 CALL alasum( path, nout, nfail, nrun, nerrs )
205*
206 9999 FORMAT( ' M=', i5, ', N=', i5, ', NB=', i4,' L=', i4,
207 $ ' test(', i2, ')=', g12.5 )
208 RETURN
209*
210* End of DCHKQRTP
211*
dqrt05
subroutine dqrt05(m, n, l, nb, result)
DQRT05
Definition dqrt05.f:80
derrqrtp
subroutine derrqrtp(path, nunit)
DERRQRTP
Definition derrqrtp.f:55

◆ dchkrfp()

program dchkrfp

DCHKRFP

Purpose:
!>
!> DCHKRFP is the main test program for the DOUBLE PRECISION 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 dchkrfp.f.

◆ dchkrq()

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

DCHKRQ

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

Definition at line 198 of file dchkrq.f.

201*
202* -- LAPACK test routine --
203* -- LAPACK is a software package provided by Univ. of Tennessee, --
204* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
205*
206* .. Scalar Arguments ..
207 LOGICAL TSTERR
208 INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
209 DOUBLE PRECISION THRESH
210* ..
211* .. Array Arguments ..
212 LOGICAL DOTYPE( * )
213 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
214 $ NXVAL( * )
215 DOUBLE PRECISION A( * ), AC( * ), AF( * ), AQ( * ), AR( * ),
216 $ B( * ), RWORK( * ), TAU( * ), WORK( * ),
217 $ X( * ), XACT( * )
218* ..
219*
220* =====================================================================
221*
222* .. Parameters ..
223 INTEGER NTESTS
224 parameter( ntests = 7 )
225 INTEGER NTYPES
226 parameter( ntypes = 8 )
227 DOUBLE PRECISION ZERO
228 parameter( zero = 0.0d0 )
229* ..
230* .. Local Scalars ..
231 CHARACTER DIST, TYPE
232 CHARACTER*3 PATH
233 INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
234 $ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
235 $ NRUN, NT, NX
236 DOUBLE PRECISION ANORM, CNDNUM
237* ..
238* .. Local Arrays ..
239 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
240 DOUBLE PRECISION RESULT( NTESTS )
241* ..
242* .. External Subroutines ..
243 EXTERNAL alaerh, alahd, alasum, derrrq, dgerqs, dget02,
244 $ dlacpy, dlarhs, dlatb4, dlatms, drqt01, drqt02,
245 $ drqt03, 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 ) = 'Double 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 derrrq( 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 DLATB4 and generate a test matrix
303* with DLATMS.
304*
305 CALL dlatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
306 $ CNDNUM, DIST )
307*
308 srnamt = 'DLATMS'
309 CALL dlatms( 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 DLATMS.
314*
315 IF( info.NE.0 ) THEN
316 CALL alaerh( path, 'DLATMS', 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 DRQT01; other values are
323* used in the calls of DRQT02, 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 DGERQF
358*
359 CALL drqt01( m, n, a, af, aq, ar, lda, tau,
360 $ work, lwork, rwork, result( 1 ) )
361 ELSE IF( m.LE.n ) THEN
362*
363* Test DORGRQ, using factorization
364* returned by DRQT01
365*
366 CALL drqt02( m, n, k, a, af, aq, ar, lda, tau,
367 $ work, lwork, rwork, result( 1 ) )
368
369 END IF
370 IF( m.GE.k ) THEN
371*
372* Test DORMRQ, using factorization returned
373* by DRQT01
374*
375 CALL drqt03( m, n, k, af, ac, ar, aq, lda, tau,
376 $ work, lwork, rwork, result( 3 ) )
377 nt = nt + 4
378*
379* If M>=N and K=N, call DGERQS to solve a system
380* with NRHS right hand sides and compute the
381* residual.
382*
383 IF( k.EQ.m .AND. inb.EQ.1 ) THEN
384*
385* Generate a solution and set the right
386* hand side.
387*
388 srnamt = 'DLARHS'
389 CALL dlarhs( path, 'New', 'Full',
390 $ 'No transpose', m, n, 0, 0,
391 $ nrhs, a, lda, xact, lda, b, lda,
392 $ iseed, info )
393*
394 CALL dlacpy( 'Full', m, nrhs, b, lda,
395 $ x( n-m+1 ), lda )
396 srnamt = 'DGERQS'
397 CALL dgerqs( m, n, nrhs, af, lda, tau, x,
398 $ lda, work, lwork, info )
399*
400* Check error code from DGERQS.
401*
402 IF( info.NE.0 )
403 $ CALL alaerh( path, 'DGERQS', info, 0, ' ',
404 $ m, n, nrhs, -1, nb, imat,
405 $ nfail, nerrs, nout )
406*
407 CALL dget02( 'No transpose', m, n, nrhs, a,
408 $ lda, x, lda, b, lda, rwork,
409 $ result( 7 ) )
410 nt = nt + 1
411 END IF
412 END IF
413*
414* Print information about the tests that did not
415* pass the threshold.
416*
417 DO 20 i = 1, nt
418 IF( result( i ).GE.thresh ) THEN
419 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
420 $ CALL alahd( nout, path )
421 WRITE( nout, fmt = 9999 )m, n, k, nb, nx,
422 $ imat, i, result( i )
423 nfail = nfail + 1
424 END IF
425 20 CONTINUE
426 nrun = nrun + nt
427 30 CONTINUE
428 40 CONTINUE
429 50 CONTINUE
430 60 CONTINUE
431 70 CONTINUE
432*
433* Print a summary of the results.
434*
435 CALL alasum( path, nout, nfail, nrun, nerrs )
436*
437 9999 FORMAT( ' M=', i5, ', N=', i5, ', K=', i5, ', NB=', i4, ', NX=',
438 $ i5, ', type ', i2, ', test(', i2, ')=', g12.5 )
439 RETURN
440*
441* End of DCHKRQ
442*
dgerqs
subroutine dgerqs(m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
DGERQS
Definition dgerqs.f:122
drqt03
subroutine drqt03(m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
DRQT03
Definition drqt03.f:136
drqt01
subroutine drqt01(m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
DRQT01
Definition drqt01.f:126
derrrq
subroutine derrrq(path, nunit)
DERRRQ
Definition derrrq.f:55
drqt02
subroutine drqt02(m, n, k, a, af, q, r, lda, tau, work, lwork, rwork, result)
DRQT02
Definition drqt02.f:136

◆ dchksp()

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

DCHKSP

Purpose:
!>
!> DCHKSP tests DSPTRF, -TRI, -TRS, -RFS, and -CON
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is DOUBLE PRECISION array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AFAC
!>          AFAC is DOUBLE PRECISION array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AINV
!>          AINV is DOUBLE PRECISION array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                      (NMAX*max(2,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array,
!>                                 dimension (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 160 of file dchksp.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, NNS, NOUT
171 DOUBLE PRECISION THRESH
172* ..
173* .. Array Arguments ..
174 LOGICAL DOTYPE( * )
175 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
176 DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
177 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 DOUBLE PRECISION ZERO
184 parameter( zero = 0.0d+0 )
185 INTEGER NTYPES
186 parameter( ntypes = 10 )
187 INTEGER NTESTS
188 parameter( ntests = 8 )
189* ..
190* .. Local Scalars ..
191 LOGICAL TRFCON, ZEROT
192 CHARACTER DIST, PACKIT, TYPE, UPLO, XTYPE
193 CHARACTER*3 PATH
194 INTEGER I, I1, I2, IMAT, IN, INFO, IOFF, IRHS, IUPLO,
195 $ IZERO, J, K, KL, KU, LDA, MODE, N, NERRS,
196 $ NFAIL, NIMAT, NPP, NRHS, NRUN, NT
197 DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
198* ..
199* .. Local Arrays ..
200 CHARACTER UPLOS( 2 )
201 INTEGER ISEED( 4 ), ISEEDY( 4 )
202 DOUBLE PRECISION RESULT( NTESTS )
203* ..
204* .. External Functions ..
205 LOGICAL LSAME
206 DOUBLE PRECISION DGET06, DLANSP
207 EXTERNAL lsame, dget06, dlansp
208* ..
209* .. External Subroutines ..
210 EXTERNAL alaerh, alahd, alasum, dcopy, derrsy, dget04,
211 $ dlacpy, dlarhs, dlatb4, dlatms, dppt02, dppt03,
212 $ dppt05, dspcon, dsprfs, dspt01, dsptrf, dsptri,
213 $ dsptrs
214* ..
215* .. Intrinsic Functions ..
216 INTRINSIC max, min
217* ..
218* .. Scalars in Common ..
219 LOGICAL LERR, OK
220 CHARACTER*32 SRNAMT
221 INTEGER INFOT, NUNIT
222* ..
223* .. Common blocks ..
224 COMMON / infoc / infot, nunit, ok, lerr
225 COMMON / srnamc / srnamt
226* ..
227* .. Data statements ..
228 DATA iseedy / 1988, 1989, 1990, 1991 /
229 DATA uplos / 'U', 'L' /
230* ..
231* .. Executable Statements ..
232*
233* Initialize constants and the random number seed.
234*
235 path( 1: 1 ) = 'Double precision'
236 path( 2: 3 ) = 'SP'
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 derrsy( path, nout )
248 infot = 0
249*
250* Do for each value of N in NVAL
251*
252 DO 170 in = 1, nn
253 n = nval( in )
254 lda = max( n, 1 )
255 xtype = 'N'
256 nimat = ntypes
257 IF( n.LE.0 )
258 $ nimat = 1
259*
260 izero = 0
261 DO 160 imat = 1, nimat
262*
263* Do the tests only if DOTYPE( IMAT ) is true.
264*
265 IF( .NOT.dotype( imat ) )
266 $ GO TO 160
267*
268* Skip types 3, 4, 5, or 6 if the matrix size is too small.
269*
270 zerot = imat.GE.3 .AND. imat.LE.6
271 IF( zerot .AND. n.LT.imat-2 )
272 $ GO TO 160
273*
274* Do first for UPLO = 'U', then for UPLO = 'L'
275*
276 DO 150 iuplo = 1, 2
277 uplo = uplos( iuplo )
278 IF( lsame( uplo, 'U' ) ) THEN
279 packit = 'C'
280 ELSE
281 packit = 'R'
282 END IF
283*
284* Set up parameters with DLATB4 and generate a test matrix
285* with DLATMS.
286*
287 CALL dlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
288 $ CNDNUM, DIST )
289*
290 srnamt = 'DLATMS'
291 CALL dlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
292 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
293 $ INFO )
294*
295* Check error code from DLATMS.
296*
297 IF( info.NE.0 ) THEN
298 CALL alaerh( path, 'DLATMS', info, 0, uplo, n, n, -1,
299 $ -1, -1, imat, nfail, nerrs, nout )
300 GO TO 150
301 END IF
302*
303* For types 3-6, zero one or more rows and columns of
304* the matrix to 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*
315 IF( imat.LT.6 ) THEN
316*
317* Set row and column IZERO to zero.
318*
319 IF( iuplo.EQ.1 ) THEN
320 ioff = ( izero-1 )*izero / 2
321 DO 20 i = 1, izero - 1
322 a( ioff+i ) = zero
323 20 CONTINUE
324 ioff = ioff + izero
325 DO 30 i = izero, n
326 a( ioff ) = zero
327 ioff = ioff + i
328 30 CONTINUE
329 ELSE
330 ioff = izero
331 DO 40 i = 1, izero - 1
332 a( ioff ) = zero
333 ioff = ioff + n - i
334 40 CONTINUE
335 ioff = ioff - izero
336 DO 50 i = izero, n
337 a( ioff+i ) = zero
338 50 CONTINUE
339 END IF
340 ELSE
341 ioff = 0
342 IF( iuplo.EQ.1 ) THEN
343*
344* Set the first IZERO rows and columns to zero.
345*
346 DO 70 j = 1, n
347 i2 = min( j, izero )
348 DO 60 i = 1, i2
349 a( ioff+i ) = zero
350 60 CONTINUE
351 ioff = ioff + j
352 70 CONTINUE
353 ELSE
354*
355* Set the last IZERO rows and columns to zero.
356*
357 DO 90 j = 1, n
358 i1 = max( j, izero )
359 DO 80 i = i1, n
360 a( ioff+i ) = zero
361 80 CONTINUE
362 ioff = ioff + n - j
363 90 CONTINUE
364 END IF
365 END IF
366 ELSE
367 izero = 0
368 END IF
369*
370* Compute the L*D*L' or U*D*U' factorization of the matrix.
371*
372 npp = n*( n+1 ) / 2
373 CALL dcopy( npp, a, 1, afac, 1 )
374 srnamt = 'DSPTRF'
375 CALL dsptrf( uplo, n, afac, iwork, info )
376*
377* Adjust the expected value of INFO to account for
378* pivoting.
379*
380 k = izero
381 IF( k.GT.0 ) THEN
382 100 CONTINUE
383 IF( iwork( k ).LT.0 ) THEN
384 IF( iwork( k ).NE.-k ) THEN
385 k = -iwork( k )
386 GO TO 100
387 END IF
388 ELSE IF( iwork( k ).NE.k ) THEN
389 k = iwork( k )
390 GO TO 100
391 END IF
392 END IF
393*
394* Check error code from DSPTRF.
395*
396 IF( info.NE.k )
397 $ CALL alaerh( path, 'DSPTRF', info, k, uplo, n, n, -1,
398 $ -1, -1, imat, nfail, nerrs, nout )
399 IF( info.NE.0 ) THEN
400 trfcon = .true.
401 ELSE
402 trfcon = .false.
403 END IF
404*
405*+ TEST 1
406* Reconstruct matrix from factors and compute residual.
407*
408 CALL dspt01( uplo, n, a, afac, iwork, ainv, lda, rwork,
409 $ result( 1 ) )
410 nt = 1
411*
412*+ TEST 2
413* Form the inverse and compute the residual.
414*
415 IF( .NOT.trfcon ) THEN
416 CALL dcopy( npp, afac, 1, ainv, 1 )
417 srnamt = 'DSPTRI'
418 CALL dsptri( uplo, n, ainv, iwork, work, info )
419*
420* Check error code from DSPTRI.
421*
422 IF( info.NE.0 )
423 $ CALL alaerh( path, 'DSPTRI', info, 0, uplo, n, n,
424 $ -1, -1, -1, imat, nfail, nerrs, nout )
425*
426 CALL dppt03( uplo, n, a, ainv, work, lda, rwork,
427 $ rcondc, result( 2 ) )
428 nt = 2
429 END IF
430*
431* Print information about the tests that did not pass
432* the threshold.
433*
434 DO 110 k = 1, nt
435 IF( result( k ).GE.thresh ) THEN
436 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
437 $ CALL alahd( nout, path )
438 WRITE( nout, fmt = 9999 )uplo, n, imat, k,
439 $ result( k )
440 nfail = nfail + 1
441 END IF
442 110 CONTINUE
443 nrun = nrun + nt
444*
445* Do only the condition estimate if INFO is not 0.
446*
447 IF( trfcon ) THEN
448 rcondc = zero
449 GO TO 140
450 END IF
451*
452 DO 130 irhs = 1, nns
453 nrhs = nsval( irhs )
454*
455*+ TEST 3
456* Solve and compute residual for A * X = B.
457*
458 srnamt = 'DLARHS'
459 CALL dlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
460 $ nrhs, a, lda, xact, lda, b, lda, iseed,
461 $ info )
462 CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
463*
464 srnamt = 'DSPTRS'
465 CALL dsptrs( uplo, n, nrhs, afac, iwork, x, lda,
466 $ info )
467*
468* Check error code from DSPTRS.
469*
470 IF( info.NE.0 )
471 $ CALL alaerh( path, 'DSPTRS', info, 0, uplo, n, n,
472 $ -1, -1, nrhs, imat, nfail, nerrs,
473 $ nout )
474*
475 CALL dlacpy( 'Full', n, nrhs, b, lda, work, lda )
476 CALL dppt02( uplo, n, nrhs, a, x, lda, work, lda,
477 $ rwork, result( 3 ) )
478*
479*+ TEST 4
480* Check solution from generated exact solution.
481*
482 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
483 $ result( 4 ) )
484*
485*+ TESTS 5, 6, and 7
486* Use iterative refinement to improve the solution.
487*
488 srnamt = 'DSPRFS'
489 CALL dsprfs( uplo, n, nrhs, a, afac, iwork, b, lda, x,
490 $ lda, rwork, rwork( nrhs+1 ), work,
491 $ iwork( n+1 ), info )
492*
493* Check error code from DSPRFS.
494*
495 IF( info.NE.0 )
496 $ CALL alaerh( path, 'DSPRFS', info, 0, uplo, n, n,
497 $ -1, -1, nrhs, imat, nfail, nerrs,
498 $ nout )
499*
500 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
501 $ result( 5 ) )
502 CALL dppt05( uplo, n, nrhs, a, b, lda, x, lda, xact,
503 $ lda, rwork, rwork( nrhs+1 ),
504 $ result( 6 ) )
505*
506* Print information about the tests that did not pass
507* the threshold.
508*
509 DO 120 k = 3, 7
510 IF( result( k ).GE.thresh ) THEN
511 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
512 $ CALL alahd( nout, path )
513 WRITE( nout, fmt = 9998 )uplo, n, nrhs, imat,
514 $ k, result( k )
515 nfail = nfail + 1
516 END IF
517 120 CONTINUE
518 nrun = nrun + 5
519 130 CONTINUE
520*
521*+ TEST 8
522* Get an estimate of RCOND = 1/CNDNUM.
523*
524 140 CONTINUE
525 anorm = dlansp( '1', uplo, n, a, rwork )
526 srnamt = 'DSPCON'
527 CALL dspcon( uplo, n, afac, iwork, anorm, rcond, work,
528 $ iwork( n+1 ), info )
529*
530* Check error code from DSPCON.
531*
532 IF( info.NE.0 )
533 $ CALL alaerh( path, 'DSPCON', info, 0, uplo, n, n, -1,
534 $ -1, -1, imat, nfail, nerrs, nout )
535*
536 result( 8 ) = dget06( rcond, rcondc )
537*
538* Print the test ratio if it is .GE. THRESH.
539*
540 IF( result( 8 ).GE.thresh ) THEN
541 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
542 $ CALL alahd( nout, path )
543 WRITE( nout, fmt = 9999 )uplo, n, imat, 8,
544 $ result( 8 )
545 nfail = nfail + 1
546 END IF
547 nrun = nrun + 1
548 150 CONTINUE
549 160 CONTINUE
550 170 CONTINUE
551*
552* Print a summary of the results.
553*
554 CALL alasum( path, nout, nfail, nrun, nerrs )
555*
556 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', type ', i2, ', test ',
557 $ i2, ', ratio =', g12.5 )
558 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
559 $ i2, ', test(', i2, ') =', g12.5 )
560 RETURN
561*
562* End of DCHKSP
563*
dspcon
subroutine dspcon(uplo, n, ap, ipiv, anorm, rcond, work, iwork, info)
DSPCON
Definition dspcon.f:125
dsprfs
subroutine dsprfs(uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
DSPRFS
Definition dsprfs.f:179
dsptrs
subroutine dsptrs(uplo, n, nrhs, ap, ipiv, b, ldb, info)
DSPTRS
Definition dsptrs.f:115
dsptri
subroutine dsptri(uplo, n, ap, ipiv, work, info)
DSPTRI
Definition dsptri.f:109
dsptrf
subroutine dsptrf(uplo, n, ap, ipiv, info)
DSPTRF
Definition dsptrf.f:159
dspt01
subroutine dspt01(uplo, n, a, afac, ipiv, c, ldc, rwork, resid)
DSPT01
Definition dspt01.f:110
derrsy
subroutine derrsy(path, nunit)
DERRSY
Definition derrsy.f:55

◆ dchksy()

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

DCHKSY

Purpose:
!>
!> DCHKSY tests DSYTRF, -TRI2, -TRS, -TRS2, -RFS, and -CON.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is DOUBLE PRECISION array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX))
!>
[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 dchksy.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* .. Scalar Arguments ..
176 LOGICAL TSTERR
177 INTEGER NMAX, NN, NNB, NNS, NOUT
178 DOUBLE PRECISION THRESH
179* ..
180* .. Array Arguments ..
181 LOGICAL DOTYPE( * )
182 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
183 DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
184 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
185* ..
186*
187* =====================================================================
188*
189* .. Parameters ..
190 DOUBLE PRECISION ZERO
191 parameter( zero = 0.0d+0 )
192 INTEGER NTYPES
193 parameter( ntypes = 10 )
194 INTEGER NTESTS
195 parameter( ntests = 9 )
196* ..
197* .. Local Scalars ..
198 LOGICAL TRFCON, ZEROT
199 CHARACTER DIST, TYPE, UPLO, XTYPE
200 CHARACTER*3 PATH
201 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
202 $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
203 $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
204 DOUBLE PRECISION ANORM, CNDNUM, RCOND, RCONDC
205* ..
206* .. Local Arrays ..
207 CHARACTER UPLOS( 2 )
208 INTEGER ISEED( 4 ), ISEEDY( 4 )
209 DOUBLE PRECISION RESULT( NTESTS )
210* ..
211* .. External Functions ..
212 DOUBLE PRECISION DGET06, DLANSY
213 EXTERNAL dget06, dlansy
214* ..
215* .. External Subroutines ..
216 EXTERNAL alaerh, alahd, alasum, derrsy, dget04, dlacpy,
217 $ dlarhs, dlatb4, dlatms, dpot02, dpot03, dpot05,
218 $ dsycon, dsyrfs, dsyt01, dsytrf,
219 $ dsytri2, dsytrs, dsytrs2, 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 path( 1: 1 ) = 'Double precision'
242 path( 2: 3 ) = 'SY'
243 nrun = 0
244 nfail = 0
245 nerrs = 0
246 DO 10 i = 1, 4
247 iseed( i ) = iseedy( i )
248 10 CONTINUE
249*
250* Test the error exits
251*
252 IF( tsterr )
253 $ CALL derrsy( path, nout )
254 infot = 0
255*
256* Set the minimum block size for which the block routine should
257* be used, which will be later returned by ILAENV
258*
259 CALL xlaenv( 2, 2 )
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 izero = 0
272*
273* Do for each value of matrix type IMAT
274*
275 DO 170 imat = 1, nimat
276*
277* Do the tests only if DOTYPE( IMAT ) is true.
278*
279 IF( .NOT.dotype( imat ) )
280 $ GO TO 170
281*
282* Skip types 3, 4, 5, or 6 if the matrix size is too small.
283*
284 zerot = imat.GE.3 .AND. imat.LE.6
285 IF( zerot .AND. n.LT.imat-2 )
286 $ GO TO 170
287*
288* Do first for UPLO = 'U', then for UPLO = 'L'
289*
290 DO 160 iuplo = 1, 2
291 uplo = uplos( iuplo )
292*
293* Begin generate the test matrix A.
294*
295*
296* Set up parameters with DLATB4 for the matrix generator
297* based on the type of matrix to be generated.
298*
299 CALL dlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
300 $ CNDNUM, DIST )
301*
302* Generate a matrix with DLATMS.
303*
304 srnamt = 'DLATMS'
305 CALL dlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
306 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
307 $ INFO )
308*
309* Check error code from DLATMS and handle error.
310*
311 IF( info.NE.0 ) THEN
312 CALL alaerh( path, 'DLATMS', info, 0, uplo, n, n, -1,
313 $ -1, -1, imat, nfail, nerrs, nout )
314*
315* Skip all tests for this generated matrix
316*
317 GO TO 160
318 END IF
319*
320* For matrix types 3-6, zero one or more rows and
321* columns of the matrix to test that INFO is returned
322* correctly.
323*
324 IF( zerot ) THEN
325 IF( imat.EQ.3 ) THEN
326 izero = 1
327 ELSE IF( imat.EQ.4 ) THEN
328 izero = n
329 ELSE
330 izero = n / 2 + 1
331 END IF
332*
333 IF( imat.LT.6 ) THEN
334*
335* Set row and column IZERO to zero.
336*
337 IF( iuplo.EQ.1 ) THEN
338 ioff = ( izero-1 )*lda
339 DO 20 i = 1, izero - 1
340 a( ioff+i ) = zero
341 20 CONTINUE
342 ioff = ioff + izero
343 DO 30 i = izero, n
344 a( ioff ) = zero
345 ioff = ioff + lda
346 30 CONTINUE
347 ELSE
348 ioff = izero
349 DO 40 i = 1, izero - 1
350 a( ioff ) = zero
351 ioff = ioff + lda
352 40 CONTINUE
353 ioff = ioff - izero
354 DO 50 i = izero, n
355 a( ioff+i ) = zero
356 50 CONTINUE
357 END IF
358 ELSE
359 IF( iuplo.EQ.1 ) THEN
360*
361* Set the first IZERO rows and columns to zero.
362*
363 ioff = 0
364 DO 70 j = 1, n
365 i2 = min( j, izero )
366 DO 60 i = 1, i2
367 a( ioff+i ) = zero
368 60 CONTINUE
369 ioff = ioff + lda
370 70 CONTINUE
371 ELSE
372*
373* Set the last IZERO rows and columns to zero.
374*
375 ioff = 0
376 DO 90 j = 1, n
377 i1 = max( j, izero )
378 DO 80 i = i1, n
379 a( ioff+i ) = zero
380 80 CONTINUE
381 ioff = ioff + lda
382 90 CONTINUE
383 END IF
384 END IF
385 ELSE
386 izero = 0
387 END IF
388*
389* End generate the test matrix A.
390*
391* Do for each value of NB in NBVAL
392*
393 DO 150 inb = 1, nnb
394*
395* Set the optimal blocksize, which will be later
396* returned by ILAENV.
397*
398 nb = nbval( inb )
399 CALL xlaenv( 1, nb )
400*
401* Copy the test matrix A into matrix AFAC which
402* will be factorized in place. This is needed to
403* preserve the test matrix A for subsequent tests.
404*
405 CALL dlacpy( uplo, n, n, a, lda, afac, lda )
406*
407* Compute the L*D*L**T or U*D*U**T factorization of the
408* matrix. IWORK stores details of the interchanges and
409* the block structure of D. AINV is a work array for
410* block factorization, LWORK is the length of AINV.
411*
412 lwork = max( 2, nb )*lda
413 srnamt = 'DSYTRF'
414 CALL dsytrf( uplo, n, afac, lda, iwork, ainv, lwork,
415 $ info )
416*
417* Adjust the expected value of INFO to account for
418* pivoting.
419*
420 k = izero
421 IF( k.GT.0 ) THEN
422 100 CONTINUE
423 IF( iwork( k ).LT.0 ) THEN
424 IF( iwork( k ).NE.-k ) THEN
425 k = -iwork( k )
426 GO TO 100
427 END IF
428 ELSE IF( iwork( k ).NE.k ) THEN
429 k = iwork( k )
430 GO TO 100
431 END IF
432 END IF
433*
434* Check error code from DSYTRF and handle error.
435*
436 IF( info.NE.k )
437 $ CALL alaerh( path, 'DSYTRF', info, k, uplo, n, n,
438 $ -1, -1, nb, imat, nfail, nerrs, nout )
439*
440* Set the condition estimate flag if the INFO is not 0.
441*
442 IF( info.NE.0 ) THEN
443 trfcon = .true.
444 ELSE
445 trfcon = .false.
446 END IF
447*
448*+ TEST 1
449* Reconstruct matrix from factors and compute residual.
450*
451 CALL dsyt01( uplo, n, a, lda, afac, lda, iwork, ainv,
452 $ lda, rwork, result( 1 ) )
453 nt = 1
454*
455*+ TEST 2
456* Form the inverse and compute the residual,
457* if the factorization was competed without INFO > 0
458* (i.e. there is no zero rows and columns).
459* Do it only for the first block size.
460*
461 IF( inb.EQ.1 .AND. .NOT.trfcon ) THEN
462 CALL dlacpy( uplo, n, n, afac, lda, ainv, lda )
463 srnamt = 'DSYTRI2'
464 lwork = (n+nb+1)*(nb+3)
465 CALL dsytri2( uplo, n, ainv, lda, iwork, work,
466 $ lwork, info )
467*
468* Check error code from DSYTRI2 and handle error.
469*
470 IF( info.NE.0 )
471 $ CALL alaerh( path, 'DSYTRI2', info, -1, uplo, n,
472 $ n, -1, -1, -1, imat, nfail, nerrs,
473 $ nout )
474*
475* Compute the residual for a symmetric matrix times
476* its inverse.
477*
478 CALL dpot03( uplo, n, a, lda, ainv, lda, work, lda,
479 $ rwork, rcondc, result( 2 ) )
480 nt = 2
481 END IF
482*
483* Print information about the tests that did not pass
484* the threshold.
485*
486 DO 110 k = 1, nt
487 IF( result( k ).GE.thresh ) THEN
488 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
489 $ CALL alahd( nout, path )
490 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
491 $ result( k )
492 nfail = nfail + 1
493 END IF
494 110 CONTINUE
495 nrun = nrun + nt
496*
497* Skip the other tests if this is not the first block
498* size.
499*
500 IF( inb.GT.1 )
501 $ GO TO 150
502*
503* Do only the condition estimate if INFO is not 0.
504*
505 IF( trfcon ) THEN
506 rcondc = zero
507 GO TO 140
508 END IF
509*
510* Do for each value of NRHS in NSVAL.
511*
512 DO 130 irhs = 1, nns
513 nrhs = nsval( irhs )
514*
515*+ TEST 3 ( Using TRS)
516* Solve and compute residual for A * X = B.
517*
518* Choose a set of NRHS random solution vectors
519* stored in XACT and set up the right hand side B
520*
521 srnamt = 'DLARHS'
522 CALL dlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
523 $ nrhs, a, lda, xact, lda, b, lda,
524 $ iseed, info )
525 CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
526*
527 srnamt = 'DSYTRS'
528 CALL dsytrs( uplo, n, nrhs, afac, lda, iwork, x,
529 $ lda, info )
530*
531* Check error code from DSYTRS and handle error.
532*
533 IF( info.NE.0 )
534 $ CALL alaerh( path, 'DSYTRS', info, 0, uplo, n,
535 $ n, -1, -1, nrhs, imat, nfail,
536 $ nerrs, nout )
537*
538 CALL dlacpy( 'Full', n, nrhs, b, lda, work, lda )
539*
540* Compute the residual for the solution
541*
542 CALL dpot02( uplo, n, nrhs, a, lda, x, lda, work,
543 $ lda, rwork, result( 3 ) )
544*
545*+ TEST 4 (Using TRS2)
546*
547* Solve and compute residual for A * X = B.
548*
549* Choose a set of NRHS random solution vectors
550* stored in XACT and set up the right hand side B
551*
552 srnamt = 'DLARHS'
553 CALL dlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
554 $ nrhs, a, lda, xact, lda, b, lda,
555 $ iseed, info )
556 CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
557*
558 srnamt = 'DSYTRS2'
559 CALL dsytrs2( uplo, n, nrhs, afac, lda, iwork, x,
560 $ lda, work, info )
561*
562* Check error code from DSYTRS2 and handle error.
563*
564 IF( info.NE.0 )
565 $ CALL alaerh( path, 'DSYTRS2', info, 0, uplo, n,
566 $ n, -1, -1, nrhs, imat, nfail,
567 $ nerrs, nout )
568*
569 CALL dlacpy( 'Full', n, nrhs, b, lda, work, lda )
570*
571* Compute the residual for the solution
572*
573 CALL dpot02( uplo, n, nrhs, a, lda, x, lda, work,
574 $ lda, rwork, result( 4 ) )
575*
576*+ TEST 5
577* Check solution from generated exact solution.
578*
579 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
580 $ result( 5 ) )
581*
582*+ TESTS 6, 7, and 8
583* Use iterative refinement to improve the solution.
584*
585 srnamt = 'DSYRFS'
586 CALL dsyrfs( uplo, n, nrhs, a, lda, afac, lda,
587 $ iwork, b, lda, x, lda, rwork,
588 $ rwork( nrhs+1 ), work, iwork( n+1 ),
589 $ info )
590*
591* Check error code from DSYRFS and handle error.
592*
593 IF( info.NE.0 )
594 $ CALL alaerh( path, 'DSYRFS', info, 0, uplo, n,
595 $ n, -1, -1, nrhs, imat, nfail,
596 $ nerrs, nout )
597*
598 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
599 $ result( 6 ) )
600 CALL dpot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
601 $ xact, lda, rwork, rwork( nrhs+1 ),
602 $ result( 7 ) )
603*
604* Print information about the tests that did not pass
605* the threshold.
606*
607 DO 120 k = 3, 8
608 IF( result( k ).GE.thresh ) THEN
609 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
610 $ CALL alahd( nout, path )
611 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
612 $ imat, k, result( k )
613 nfail = nfail + 1
614 END IF
615 120 CONTINUE
616 nrun = nrun + 6
617*
618* End do for each value of NRHS in NSVAL.
619*
620 130 CONTINUE
621*
622*+ TEST 9
623* Get an estimate of RCOND = 1/CNDNUM.
624*
625 140 CONTINUE
626 anorm = dlansy( '1', uplo, n, a, lda, rwork )
627 srnamt = 'DSYCON'
628 CALL dsycon( uplo, n, afac, lda, iwork, anorm, rcond,
629 $ work, iwork( n+1 ), info )
630*
631* Check error code from DSYCON and handle error.
632*
633 IF( info.NE.0 )
634 $ CALL alaerh( path, 'DSYCON', info, 0, uplo, n, n,
635 $ -1, -1, -1, imat, nfail, nerrs, nout )
636*
637* Compute the test ratio to compare values of RCOND
638*
639 result( 9 ) = dget06( rcond, rcondc )
640*
641* Print information about the tests that did not pass
642* the threshold.
643*
644 IF( result( 9 ).GE.thresh ) THEN
645 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
646 $ CALL alahd( nout, path )
647 WRITE( nout, fmt = 9997 )uplo, n, imat, 9,
648 $ result( 9 )
649 nfail = nfail + 1
650 END IF
651 nrun = nrun + 1
652 150 CONTINUE
653*
654 160 CONTINUE
655 170 CONTINUE
656 180 CONTINUE
657*
658* Print a summary of the results.
659*
660 CALL alasum( path, nout, nfail, nrun, nerrs )
661*
662 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
663 $ i2, ', test ', i2, ', ratio =', g12.5 )
664 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
665 $ i2, ', test(', i2, ') =', g12.5 )
666 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
667 $ ', test(', i2, ') =', g12.5 )
668 RETURN
669*
670* End of DCHKSY
671*
dsycon
subroutine dsycon(uplo, n, a, lda, ipiv, anorm, rcond, work, iwork, info)
DSYCON
Definition dsycon.f:130
dsytrf
subroutine dsytrf(uplo, n, a, lda, ipiv, work, lwork, info)
DSYTRF
Definition dsytrf.f:182
dsytri2
subroutine dsytri2(uplo, n, a, lda, ipiv, work, lwork, info)
DSYTRI2
Definition dsytri2.f:127
dsyrfs
subroutine dsyrfs(uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
DSYRFS
Definition dsyrfs.f:191
dsytrs2
subroutine dsytrs2(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, info)
DSYTRS2
Definition dsytrs2.f:132
dsytrs
subroutine dsytrs(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
DSYTRS
Definition dsytrs.f:120
dsyt01
subroutine dsyt01(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
DSYT01
Definition dsyt01.f:124

◆ dchksy_aa()

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

DCHKSY_AA

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

◆ dchksy_aa_2stage()

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

DCHKSY_AA_2STAGE

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

Definition at line 168 of file dchksy_aa_2stage.f.

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

◆ dchksy_rk()

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

DCHKSY_RK

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

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

◆ dchksy_rook()

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

DCHKSY_ROOK

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

Definition at line 168 of file dchksy_rook.f.

171*
172* -- LAPACK test routine --
173* -- LAPACK is a software package provided by Univ. of Tennessee, --
174* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
175*
176* .. Scalar Arguments ..
177 LOGICAL TSTERR
178 INTEGER NMAX, NN, NNB, NNS, NOUT
179 DOUBLE PRECISION THRESH
180* ..
181* .. Array Arguments ..
182 LOGICAL DOTYPE( * )
183 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
184 DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
185 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
186* ..
187*
188* =====================================================================
189*
190* .. Parameters ..
191 DOUBLE PRECISION ZERO, ONE
192 parameter( zero = 0.0d+0, one = 1.0d+0 )
193 DOUBLE PRECISION EIGHT, SEVTEN
194 parameter( eight = 8.0d+0, sevten = 17.0d+0 )
195 INTEGER NTYPES
196 parameter( ntypes = 10 )
197 INTEGER NTESTS
198 parameter( ntests = 7 )
199* ..
200* .. Local Scalars ..
201 LOGICAL TRFCON, ZEROT
202 CHARACTER DIST, TYPE, UPLO, XTYPE
203 CHARACTER*3 PATH, MATPATH
204 INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS,
205 $ IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, MODE,
206 $ N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, NT
207 DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, SING_MAX,
208 $ SING_MIN, RCOND, RCONDC
209* ..
210* .. Local Arrays ..
211 CHARACTER UPLOS( 2 )
212 INTEGER ISEED( 4 ), ISEEDY( 4 )
213 DOUBLE PRECISION BLOCK( 2, 2 ), DDUMMY( 1 ), RESULT( NTESTS )
214* ..
215* .. External Functions ..
216 DOUBLE PRECISION DGET06, DLANGE, DLANSY
217 EXTERNAL dget06, dlange, dlansy
218* ..
219* .. External Subroutines ..
220 EXTERNAL alaerh, alahd, alasum, derrsy, dget04, dlacpy,
221 $ dlarhs, dlatb4, dlatms, dpot02, dpot03, dgesvd,
222 $ dsycon_rook, dsyt01_rook, dsytrf_rook,
223 $ dsytri_rook, dsytrs_rook, xlaenv
224* ..
225* .. Intrinsic Functions ..
226 INTRINSIC max, min, sqrt
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 alpha = ( one+sqrt( sevten ) ) / eight
246*
247* Test path
248*
249 path( 1: 1 ) = 'Double precision'
250 path( 2: 3 ) = 'SR'
251*
252* Path to generate matrices
253*
254 matpath( 1: 1 ) = 'Double precision'
255 matpath( 2: 3 ) = 'SY'
256*
257 nrun = 0
258 nfail = 0
259 nerrs = 0
260 DO 10 i = 1, 4
261 iseed( i ) = iseedy( i )
262 10 CONTINUE
263*
264* Test the error exits
265*
266 IF( tsterr )
267 $ CALL derrsy( path, nout )
268 infot = 0
269*
270* Set the minimum block size for which the block routine should
271* be used, which will be later returned by ILAENV
272*
273 CALL xlaenv( 2, 2 )
274*
275* Do for each value of N in NVAL
276*
277 DO 270 in = 1, nn
278 n = nval( in )
279 lda = max( n, 1 )
280 xtype = 'N'
281 nimat = ntypes
282 IF( n.LE.0 )
283 $ nimat = 1
284*
285 izero = 0
286*
287* Do for each value of matrix type IMAT
288*
289 DO 260 imat = 1, nimat
290*
291* Do the tests only if DOTYPE( IMAT ) is true.
292*
293 IF( .NOT.dotype( imat ) )
294 $ GO TO 260
295*
296* Skip types 3, 4, 5, or 6 if the matrix size is too small.
297*
298 zerot = imat.GE.3 .AND. imat.LE.6
299 IF( zerot .AND. n.LT.imat-2 )
300 $ GO TO 260
301*
302* Do first for UPLO = 'U', then for UPLO = 'L'
303*
304 DO 250 iuplo = 1, 2
305 uplo = uplos( iuplo )
306*
307* Begin generate the test matrix A.
308*
309* Set up parameters with DLATB4 for the matrix generator
310* based on the type of matrix to be generated.
311*
312 CALL dlatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
313 $ MODE, CNDNUM, DIST )
314*
315* Generate a matrix with DLATMS.
316*
317 srnamt = 'DLATMS'
318 CALL dlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
319 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
320 $ INFO )
321*
322* Check error code from DLATMS and handle error.
323*
324 IF( info.NE.0 ) THEN
325 CALL alaerh( path, 'DLATMS', 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 250
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 ) = zero
354 20 CONTINUE
355 ioff = ioff + izero
356 DO 30 i = izero, n
357 a( ioff ) = zero
358 ioff = ioff + lda
359 30 CONTINUE
360 ELSE
361 ioff = izero
362 DO 40 i = 1, izero - 1
363 a( ioff ) = zero
364 ioff = ioff + lda
365 40 CONTINUE
366 ioff = ioff - izero
367 DO 50 i = izero, n
368 a( ioff+i ) = zero
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 ) = zero
381 60 CONTINUE
382 ioff = ioff + lda
383 70 CONTINUE
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 ) = zero
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*
405* Do for each value of NB in NBVAL
406*
407 DO 240 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 dlacpy( 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 lwork = max( 2, nb )*lda
427 srnamt = 'DSYTRF_ROOK'
428 CALL dsytrf_rook( uplo, n, afac, lda, iwork, ainv,
429 $ lwork, info )
430*
431* Adjust the expected value of INFO to account for
432* pivoting.
433*
434 k = izero
435 IF( k.GT.0 ) THEN
436 100 CONTINUE
437 IF( iwork( k ).LT.0 ) THEN
438 IF( iwork( k ).NE.-k ) THEN
439 k = -iwork( k )
440 GO TO 100
441 END IF
442 ELSE IF( iwork( k ).NE.k ) THEN
443 k = iwork( k )
444 GO TO 100
445 END IF
446 END IF
447*
448* Check error code from DSYTRF_ROOK and handle error.
449*
450 IF( info.NE.k)
451 $ CALL alaerh( path, 'DSYTRF_ROOK', info, k,
452 $ uplo, n, n, -1, -1, nb, imat,
453 $ nfail, nerrs, nout )
454*
455* Set the condition estimate flag if the INFO is not 0.
456*
457 IF( info.NE.0 ) THEN
458 trfcon = .true.
459 ELSE
460 trfcon = .false.
461 END IF
462*
463*+ TEST 1
464* Reconstruct matrix from factors and compute residual.
465*
466 CALL dsyt01_rook( uplo, n, a, lda, afac, lda, iwork,
467 $ ainv, lda, rwork, result( 1 ) )
468 nt = 1
469*
470*+ TEST 2
471* Form the inverse and compute the residual,
472* if the factorization was competed without INFO > 0
473* (i.e. there is no zero rows and columns).
474* Do it only for the first block size.
475*
476 IF( inb.EQ.1 .AND. .NOT.trfcon ) THEN
477 CALL dlacpy( uplo, n, n, afac, lda, ainv, lda )
478 srnamt = 'DSYTRI_ROOK'
479 CALL dsytri_rook( uplo, n, ainv, lda, iwork, work,
480 $ info )
481*
482* Check error code from DSYTRI_ROOK and handle error.
483*
484 IF( info.NE.0 )
485 $ CALL alaerh( path, 'DSYTRI_ROOK', info, -1,
486 $ uplo, n, n, -1, -1, -1, imat,
487 $ nfail, nerrs, nout )
488*
489* Compute the residual for a symmetric matrix times
490* its inverse.
491*
492 CALL dpot03( uplo, n, a, lda, ainv, lda, work, lda,
493 $ rwork, rcondc, result( 2 ) )
494 nt = 2
495 END IF
496*
497* Print information about the tests that did not pass
498* the threshold.
499*
500 DO 110 k = 1, nt
501 IF( result( k ).GE.thresh ) THEN
502 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
503 $ CALL alahd( nout, path )
504 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
505 $ result( k )
506 nfail = nfail + 1
507 END IF
508 110 CONTINUE
509 nrun = nrun + nt
510*
511*+ TEST 3
512* Compute largest element in U or L
513*
514 result( 3 ) = zero
515 dtemp = zero
516*
517 const = one / ( one-alpha )
518*
519 IF( iuplo.EQ.1 ) THEN
520*
521* Compute largest element in U
522*
523 k = n
524 120 CONTINUE
525 IF( k.LE.1 )
526 $ GO TO 130
527*
528 IF( iwork( k ).GT.zero ) THEN
529*
530* Get max absolute value from elements
531* in column k in in U
532*
533 dtemp = dlange( 'M', k-1, 1,
534 $ afac( ( k-1 )*lda+1 ), lda, rwork )
535 ELSE
536*
537* Get max absolute value from elements
538* in columns k and k-1 in U
539*
540 dtemp = dlange( 'M', k-2, 2,
541 $ afac( ( k-2 )*lda+1 ), lda, rwork )
542 k = k - 1
543*
544 END IF
545*
546* DTEMP should be bounded by CONST
547*
548 dtemp = dtemp - const + thresh
549 IF( dtemp.GT.result( 3 ) )
550 $ result( 3 ) = dtemp
551*
552 k = k - 1
553*
554 GO TO 120
555 130 CONTINUE
556*
557 ELSE
558*
559* Compute largest element in L
560*
561 k = 1
562 140 CONTINUE
563 IF( k.GE.n )
564 $ GO TO 150
565*
566 IF( iwork( k ).GT.zero ) THEN
567*
568* Get max absolute value from elements
569* in column k in in L
570*
571 dtemp = dlange( 'M', n-k, 1,
572 $ afac( ( k-1 )*lda+k+1 ), lda, rwork )
573 ELSE
574*
575* Get max absolute value from elements
576* in columns k and k+1 in L
577*
578 dtemp = dlange( 'M', n-k-1, 2,
579 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
580 k = k + 1
581*
582 END IF
583*
584* DTEMP should be bounded by CONST
585*
586 dtemp = dtemp - const + thresh
587 IF( dtemp.GT.result( 3 ) )
588 $ result( 3 ) = dtemp
589*
590 k = k + 1
591*
592 GO TO 140
593 150 CONTINUE
594 END IF
595*
596*
597*+ TEST 4
598* Compute largest 2-Norm (condition number)
599* of 2-by-2 diag blocks
600*
601 result( 4 ) = zero
602 dtemp = zero
603*
604 const = ( one+alpha ) / ( one-alpha )
605 CALL dlacpy( uplo, n, n, afac, lda, ainv, lda )
606*
607 IF( iuplo.EQ.1 ) THEN
608*
609* Loop backward for UPLO = 'U'
610*
611 k = n
612 160 CONTINUE
613 IF( k.LE.1 )
614 $ GO TO 170
615*
616 IF( iwork( k ).LT.zero ) THEN
617*
618* Get the two singular values
619* (real and non-negative) of a 2-by-2 block,
620* store them in RWORK array
621*
622 block( 1, 1 ) = afac( ( k-2 )*lda+k-1 )
623 block( 1, 2 ) = afac( (k-1)*lda+k-1 )
624 block( 2, 1 ) = block( 1, 2 )
625 block( 2, 2 ) = afac( (k-1)*lda+k )
626*
627 CALL dgesvd( 'N', 'N', 2, 2, block, 2, rwork,
628 $ ddummy, 1, ddummy, 1,
629 $ work, 10, info )
630*
631 sing_max = rwork( 1 )
632 sing_min = rwork( 2 )
633*
634 dtemp = sing_max / sing_min
635*
636* DTEMP should be bounded by CONST
637*
638 dtemp = dtemp - const + thresh
639 IF( dtemp.GT.result( 4 ) )
640 $ result( 4 ) = dtemp
641 k = k - 1
642*
643 END IF
644*
645 k = k - 1
646*
647 GO TO 160
648 170 CONTINUE
649*
650 ELSE
651*
652* Loop forward for UPLO = 'L'
653*
654 k = 1
655 180 CONTINUE
656 IF( k.GE.n )
657 $ GO TO 190
658*
659 IF( iwork( k ).LT.zero ) THEN
660*
661* Get the two singular values
662* (real and non-negative) of a 2-by-2 block,
663* store them in RWORK array
664*
665 block( 1, 1 ) = afac( ( k-1 )*lda+k )
666 block( 2, 1 ) = afac( ( k-1 )*lda+k+1 )
667 block( 1, 2 ) = block( 2, 1 )
668 block( 2, 2 ) = afac( k*lda+k+1 )
669*
670 CALL dgesvd( 'N', 'N', 2, 2, block, 2, rwork,
671 $ ddummy, 1, ddummy, 1,
672 $ work, 10, info )
673*
674*
675 sing_max = rwork( 1 )
676 sing_min = rwork( 2 )
677*
678 dtemp = sing_max / sing_min
679*
680* DTEMP should be bounded by CONST
681*
682 dtemp = dtemp - const + thresh
683 IF( dtemp.GT.result( 4 ) )
684 $ result( 4 ) = dtemp
685 k = k + 1
686*
687 END IF
688*
689 k = k + 1
690*
691 GO TO 180
692 190 CONTINUE
693 END IF
694*
695* Print information about the tests that did not pass
696* the threshold.
697*
698 DO 200 k = 3, 4
699 IF( result( k ).GE.thresh ) THEN
700 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
701 $ CALL alahd( nout, path )
702 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
703 $ result( k )
704 nfail = nfail + 1
705 END IF
706 200 CONTINUE
707 nrun = nrun + 2
708*
709* Skip the other tests if this is not the first block
710* size.
711*
712 IF( inb.GT.1 )
713 $ GO TO 240
714*
715* Do only the condition estimate if INFO is not 0.
716*
717 IF( trfcon ) THEN
718 rcondc = zero
719 GO TO 230
720 END IF
721*
722* Do for each value of NRHS in NSVAL.
723*
724 DO 220 irhs = 1, nns
725 nrhs = nsval( irhs )
726*
727*+ TEST 5 ( Using TRS_ROOK)
728* Solve and compute residual for A * X = B.
729*
730* Choose a set of NRHS random solution vectors
731* stored in XACT and set up the right hand side B
732*
733 srnamt = 'DLARHS'
734 CALL dlarhs( matpath, xtype, uplo, ' ', n, n,
735 $ kl, ku, nrhs, a, lda, xact, lda,
736 $ b, lda, iseed, info )
737 CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
738*
739 srnamt = 'DSYTRS_ROOK'
740 CALL dsytrs_rook( uplo, n, nrhs, afac, lda, iwork,
741 $ x, lda, info )
742*
743* Check error code from DSYTRS_ROOK and handle error.
744*
745 IF( info.NE.0 )
746 $ CALL alaerh( path, 'DSYTRS_ROOK', info, 0,
747 $ uplo, n, n, -1, -1, nrhs, imat,
748 $ nfail, nerrs, nout )
749*
750 CALL dlacpy( 'Full', n, nrhs, b, lda, work, lda )
751*
752* Compute the residual for the solution
753*
754 CALL dpot02( uplo, n, nrhs, a, lda, x, lda, work,
755 $ lda, rwork, result( 5 ) )
756*
757*+ TEST 6
758* Check solution from generated exact solution.
759*
760 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
761 $ result( 6 ) )
762*
763* Print information about the tests that did not pass
764* the threshold.
765*
766 DO 210 k = 5, 6
767 IF( result( k ).GE.thresh ) THEN
768 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
769 $ CALL alahd( nout, path )
770 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
771 $ imat, k, result( k )
772 nfail = nfail + 1
773 END IF
774 210 CONTINUE
775 nrun = nrun + 2
776*
777* End do for each value of NRHS in NSVAL.
778*
779 220 CONTINUE
780*
781*+ TEST 7
782* Get an estimate of RCOND = 1/CNDNUM.
783*
784 230 CONTINUE
785 anorm = dlansy( '1', uplo, n, a, lda, rwork )
786 srnamt = 'DSYCON_ROOK'
787 CALL dsycon_rook( uplo, n, afac, lda, iwork, anorm,
788 $ rcond, work, iwork( n+1 ), info )
789*
790* Check error code from DSYCON_ROOK and handle error.
791*
792 IF( info.NE.0 )
793 $ CALL alaerh( path, 'DSYCON_ROOK', info, 0,
794 $ uplo, n, n, -1, -1, -1, imat,
795 $ nfail, nerrs, nout )
796*
797* Compute the test ratio to compare to values of RCOND
798*
799 result( 7 ) = dget06( rcond, rcondc )
800*
801* Print information about the tests that did not pass
802* the threshold.
803*
804 IF( result( 7 ).GE.thresh ) THEN
805 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
806 $ CALL alahd( nout, path )
807 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
808 $ result( 7 )
809 nfail = nfail + 1
810 END IF
811 nrun = nrun + 1
812 240 CONTINUE
813*
814 250 CONTINUE
815 260 CONTINUE
816 270 CONTINUE
817*
818* Print a summary of the results.
819*
820 CALL alasum( path, nout, nfail, nrun, nerrs )
821*
822 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
823 $ i2, ', test ', i2, ', ratio =', g12.5 )
824 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
825 $ i2, ', test(', i2, ') =', g12.5 )
826 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
827 $ ', test(', i2, ') =', g12.5 )
828 RETURN
829*
830* End of DCHKSY_ROOK
831*
dsytrf_rook
subroutine dsytrf_rook(uplo, n, a, lda, ipiv, work, lwork, info)
DSYTRF_ROOK
Definition dsytrf_rook.f:208
dsycon_rook
subroutine dsycon_rook(uplo, n, a, lda, ipiv, anorm, rcond, work, iwork, info)
DSYCON_ROOK
Definition dsycon_rook.f:144
dsytri_rook
subroutine dsytri_rook(uplo, n, a, lda, ipiv, work, info)
DSYTRI_ROOK
Definition dsytri_rook.f:129
dsytrs_rook
subroutine dsytrs_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
DSYTRS_ROOK
Definition dsytrs_rook.f:136
dsyt01_rook
subroutine dsyt01_rook(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
DSYT01_ROOK
Definition dsyt01_rook.f:124

◆ dchktb()

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

DCHKTB

Purpose:
!>
!> DCHKTB tests DTBTRS, -RFS, and -CON, and DLATBS.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The leading dimension of the work arrays.
!>          NMAX >= the maximum value of N in NVAL.
!>
[out]AB
!>          AB is DOUBLE PRECISION array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (max(NMAX,2*NSMAX))
!>
[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 152 of file dchktb.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, NNS, NOUT
163 DOUBLE PRECISION THRESH
164* ..
165* .. Array Arguments ..
166 LOGICAL DOTYPE( * )
167 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
168 DOUBLE PRECISION AB( * ), AINV( * ), B( * ), RWORK( * ),
169 $ WORK( * ), X( * ), XACT( * )
170* ..
171*
172* =====================================================================
173*
174* .. Parameters ..
175 INTEGER NTYPE1, NTYPES
176 parameter( ntype1 = 9, ntypes = 17 )
177 INTEGER NTESTS
178 parameter( ntests = 8 )
179 INTEGER NTRAN
180 parameter( ntran = 3 )
181 DOUBLE PRECISION ONE, ZERO
182 parameter( one = 1.0d+0, zero = 0.0d+0 )
183* ..
184* .. Local Scalars ..
185 CHARACTER DIAG, NORM, TRANS, UPLO, XTYPE
186 CHARACTER*3 PATH
187 INTEGER I, IDIAG, IK, IMAT, IN, INFO, IRHS, ITRAN,
188 $ IUPLO, J, K, KD, LDA, LDAB, N, NERRS, NFAIL,
189 $ NIMAT, NIMAT2, NK, NRHS, NRUN
190 DOUBLE PRECISION AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
191 $ SCALE
192* ..
193* .. Local Arrays ..
194 CHARACTER TRANSS( NTRAN ), UPLOS( 2 )
195 INTEGER ISEED( 4 ), ISEEDY( 4 )
196 DOUBLE PRECISION RESULT( NTESTS )
197* ..
198* .. External Functions ..
199 LOGICAL LSAME
200 DOUBLE PRECISION DLANTB, DLANTR
201 EXTERNAL lsame, dlantb, dlantr
202* ..
203* .. External Subroutines ..
204 EXTERNAL alaerh, alahd, alasum, dcopy, derrtr, dget04,
205 $ dlacpy, dlarhs, dlaset, dlatbs, dlattb, dtbcon,
206 $ dtbrfs, dtbsv, dtbt02, dtbt03, dtbt05, dtbt06,
207 $ dtbtrs
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* .. Intrinsic Functions ..
219 INTRINSIC max, min
220* ..
221* .. Data statements ..
222 DATA iseedy / 1988, 1989, 1990, 1991 /
223 DATA uplos / 'U', 'L' / , transs / 'N', 'T', 'C' /
224* ..
225* .. Executable Statements ..
226*
227* Initialize constants and the random number seed.
228*
229 path( 1: 1 ) = 'Double precision'
230 path( 2: 3 ) = 'TB'
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 derrtr( path, nout )
242 infot = 0
243*
244 DO 140 in = 1, nn
245*
246* Do for each value of N in NVAL
247*
248 n = nval( in )
249 lda = max( 1, n )
250 xtype = 'N'
251 nimat = ntype1
252 nimat2 = ntypes
253 IF( n.LE.0 ) THEN
254 nimat = 1
255 nimat2 = ntype1 + 1
256 END IF
257*
258 nk = min( n+1, 4 )
259 DO 130 ik = 1, nk
260*
261* Do for KD = 0, N, (3N-1)/4, and (N+1)/4. This order makes
262* it easier to skip redundant values for small values of N.
263*
264 IF( ik.EQ.1 ) THEN
265 kd = 0
266 ELSE IF( ik.EQ.2 ) THEN
267 kd = max( n, 0 )
268 ELSE IF( ik.EQ.3 ) THEN
269 kd = ( 3*n-1 ) / 4
270 ELSE IF( ik.EQ.4 ) THEN
271 kd = ( n+1 ) / 4
272 END IF
273 ldab = kd + 1
274*
275 DO 90 imat = 1, nimat
276*
277* Do the tests only if DOTYPE( IMAT ) is true.
278*
279 IF( .NOT.dotype( imat ) )
280 $ GO TO 90
281*
282 DO 80 iuplo = 1, 2
283*
284* Do first for UPLO = 'U', then for UPLO = 'L'
285*
286 uplo = uplos( iuplo )
287*
288* Call DLATTB to generate a triangular test matrix.
289*
290 srnamt = 'DLATTB'
291 CALL dlattb( imat, uplo, 'No transpose', diag, iseed,
292 $ n, kd, ab, ldab, x, work, info )
293*
294* Set IDIAG = 1 for non-unit matrices, 2 for unit.
295*
296 IF( lsame( diag, 'N' ) ) THEN
297 idiag = 1
298 ELSE
299 idiag = 2
300 END IF
301*
302* Form the inverse of A so we can get a good estimate
303* of RCONDC = 1/(norm(A) * norm(inv(A))).
304*
305 CALL dlaset( 'Full', n, n, zero, one, ainv, lda )
306 IF( lsame( uplo, 'U' ) ) THEN
307 DO 20 j = 1, n
308 CALL dtbsv( uplo, 'No transpose', diag, j, kd,
309 $ ab, ldab, ainv( ( j-1 )*lda+1 ), 1 )
310 20 CONTINUE
311 ELSE
312 DO 30 j = 1, n
313 CALL dtbsv( uplo, 'No transpose', diag, n-j+1,
314 $ kd, ab( ( j-1 )*ldab+1 ), ldab,
315 $ ainv( ( j-1 )*lda+j ), 1 )
316 30 CONTINUE
317 END IF
318*
319* Compute the 1-norm condition number of A.
320*
321 anorm = dlantb( '1', uplo, diag, n, kd, ab, ldab,
322 $ rwork )
323 ainvnm = dlantr( '1', uplo, diag, n, n, ainv, lda,
324 $ rwork )
325 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
326 rcondo = one
327 ELSE
328 rcondo = ( one / anorm ) / ainvnm
329 END IF
330*
331* Compute the infinity-norm condition number of A.
332*
333 anorm = dlantb( 'I', uplo, diag, n, kd, ab, ldab,
334 $ rwork )
335 ainvnm = dlantr( 'I', uplo, diag, n, n, ainv, lda,
336 $ rwork )
337 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
338 rcondi = one
339 ELSE
340 rcondi = ( one / anorm ) / ainvnm
341 END IF
342*
343 DO 60 irhs = 1, nns
344 nrhs = nsval( irhs )
345 xtype = 'N'
346*
347 DO 50 itran = 1, ntran
348*
349* Do for op(A) = A, A**T, or A**H.
350*
351 trans = transs( itran )
352 IF( itran.EQ.1 ) THEN
353 norm = 'O'
354 rcondc = rcondo
355 ELSE
356 norm = 'I'
357 rcondc = rcondi
358 END IF
359*
360*+ TEST 1
361* Solve and compute residual for op(A)*x = b.
362*
363 srnamt = 'DLARHS'
364 CALL dlarhs( path, xtype, uplo, trans, n, n, kd,
365 $ idiag, nrhs, ab, ldab, xact, lda,
366 $ b, lda, iseed, info )
367 xtype = 'C'
368 CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
369*
370 srnamt = 'DTBTRS'
371 CALL dtbtrs( uplo, trans, diag, n, kd, nrhs, ab,
372 $ ldab, x, lda, info )
373*
374* Check error code from DTBTRS.
375*
376 IF( info.NE.0 )
377 $ CALL alaerh( path, 'DTBTRS', info, 0,
378 $ uplo // trans // diag, n, n, kd,
379 $ kd, nrhs, imat, nfail, nerrs,
380 $ nout )
381*
382 CALL dtbt02( uplo, trans, diag, n, kd, nrhs, ab,
383 $ ldab, x, lda, b, lda, work,
384 $ result( 1 ) )
385*
386*+ TEST 2
387* Check solution from generated exact solution.
388*
389 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
390 $ result( 2 ) )
391*
392*+ TESTS 3, 4, and 5
393* Use iterative refinement to improve the solution
394* and compute error bounds.
395*
396 srnamt = 'DTBRFS'
397 CALL dtbrfs( uplo, trans, diag, n, kd, nrhs, ab,
398 $ ldab, b, lda, x, lda, rwork,
399 $ rwork( nrhs+1 ), work, iwork,
400 $ info )
401*
402* Check error code from DTBRFS.
403*
404 IF( info.NE.0 )
405 $ CALL alaerh( path, 'DTBRFS', info, 0,
406 $ uplo // trans // diag, n, n, kd,
407 $ kd, nrhs, imat, nfail, nerrs,
408 $ nout )
409*
410 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
411 $ result( 3 ) )
412 CALL dtbt05( uplo, trans, diag, n, kd, nrhs, ab,
413 $ ldab, b, lda, x, lda, xact, lda,
414 $ rwork, rwork( nrhs+1 ),
415 $ result( 4 ) )
416*
417* Print information about the tests that did not
418* pass the threshold.
419*
420 DO 40 k = 1, 5
421 IF( result( k ).GE.thresh ) THEN
422 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
423 $ CALL alahd( nout, path )
424 WRITE( nout, fmt = 9999 )uplo, trans,
425 $ diag, n, kd, nrhs, imat, k, result( k )
426 nfail = nfail + 1
427 END IF
428 40 CONTINUE
429 nrun = nrun + 5
430 50 CONTINUE
431 60 CONTINUE
432*
433*+ TEST 6
434* Get an estimate of RCOND = 1/CNDNUM.
435*
436 DO 70 itran = 1, 2
437 IF( itran.EQ.1 ) THEN
438 norm = 'O'
439 rcondc = rcondo
440 ELSE
441 norm = 'I'
442 rcondc = rcondi
443 END IF
444 srnamt = 'DTBCON'
445 CALL dtbcon( norm, uplo, diag, n, kd, ab, ldab,
446 $ rcond, work, iwork, info )
447*
448* Check error code from DTBCON.
449*
450 IF( info.NE.0 )
451 $ CALL alaerh( path, 'DTBCON', info, 0,
452 $ norm // uplo // diag, n, n, kd, kd,
453 $ -1, imat, nfail, nerrs, nout )
454*
455 CALL dtbt06( rcond, rcondc, uplo, diag, n, kd, ab,
456 $ ldab, rwork, result( 6 ) )
457*
458* Print information about the tests that did not pass
459* the threshold.
460*
461 IF( result( 6 ).GE.thresh ) THEN
462 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
463 $ CALL alahd( nout, path )
464 WRITE( nout, fmt = 9998 ) 'DTBCON', norm, uplo,
465 $ diag, n, kd, imat, 6, result( 6 )
466 nfail = nfail + 1
467 END IF
468 nrun = nrun + 1
469 70 CONTINUE
470 80 CONTINUE
471 90 CONTINUE
472*
473* Use pathological test matrices to test DLATBS.
474*
475 DO 120 imat = ntype1 + 1, nimat2
476*
477* Do the tests only if DOTYPE( IMAT ) is true.
478*
479 IF( .NOT.dotype( imat ) )
480 $ GO TO 120
481*
482 DO 110 iuplo = 1, 2
483*
484* Do first for UPLO = 'U', then for UPLO = 'L'
485*
486 uplo = uplos( iuplo )
487 DO 100 itran = 1, ntran
488*
489* Do for op(A) = A, A**T, and A**H.
490*
491 trans = transs( itran )
492*
493* Call DLATTB to generate a triangular test matrix.
494*
495 srnamt = 'DLATTB'
496 CALL dlattb( imat, uplo, trans, diag, iseed, n, kd,
497 $ ab, ldab, x, work, info )
498*
499*+ TEST 7
500* Solve the system op(A)*x = b
501*
502 srnamt = 'DLATBS'
503 CALL dcopy( n, x, 1, b, 1 )
504 CALL dlatbs( uplo, trans, diag, 'N', n, kd, ab,
505 $ ldab, b, scale, rwork, info )
506*
507* Check error code from DLATBS.
508*
509 IF( info.NE.0 )
510 $ CALL alaerh( path, 'DLATBS', info, 0,
511 $ uplo // trans // diag // 'N', n, n,
512 $ kd, kd, -1, imat, nfail, nerrs,
513 $ nout )
514*
515 CALL dtbt03( uplo, trans, diag, n, kd, 1, ab, ldab,
516 $ scale, rwork, one, b, lda, x, lda,
517 $ work, result( 7 ) )
518*
519*+ TEST 8
520* Solve op(A)*x = b again with NORMIN = 'Y'.
521*
522 CALL dcopy( n, x, 1, b, 1 )
523 CALL dlatbs( uplo, trans, diag, 'Y', n, kd, ab,
524 $ ldab, b, scale, rwork, info )
525*
526* Check error code from DLATBS.
527*
528 IF( info.NE.0 )
529 $ CALL alaerh( path, 'DLATBS', info, 0,
530 $ uplo // trans // diag // 'Y', n, n,
531 $ kd, kd, -1, imat, nfail, nerrs,
532 $ nout )
533*
534 CALL dtbt03( uplo, trans, diag, n, kd, 1, ab, ldab,
535 $ scale, rwork, one, b, lda, x, lda,
536 $ work, result( 8 ) )
537*
538* Print information about the tests that did not pass
539* the threshold.
540*
541 IF( result( 7 ).GE.thresh ) THEN
542 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
543 $ CALL alahd( nout, path )
544 WRITE( nout, fmt = 9997 )'DLATBS', uplo, trans,
545 $ diag, 'N', n, kd, imat, 7, result( 7 )
546 nfail = nfail + 1
547 END IF
548 IF( result( 8 ).GE.thresh ) THEN
549 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
550 $ CALL alahd( nout, path )
551 WRITE( nout, fmt = 9997 )'DLATBS', uplo, trans,
552 $ diag, 'Y', n, kd, imat, 8, result( 8 )
553 nfail = nfail + 1
554 END IF
555 nrun = nrun + 2
556 100 CONTINUE
557 110 CONTINUE
558 120 CONTINUE
559 130 CONTINUE
560 140 CONTINUE
561*
562* Print a summary of the results.
563*
564 CALL alasum( path, nout, nfail, nrun, nerrs )
565*
566 9999 FORMAT( ' UPLO=''', a1, ''', TRANS=''', a1, ''',
567 $ DIAG=''', a1, ''', N=', i5, ', KD=', i5, ', NRHS=', i5,
568 $ ', type ', i2, ', test(', i2, ')=', g12.5 )
569 9998 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ''', a1, ''',',
570 $ i5, ',', i5, ', ... ), type ', i2, ', test(', i2, ')=',
571 $ g12.5 )
572 9997 FORMAT( 1x, a, '( ''', a1, ''', ''', a1, ''', ''', a1, ''', ''',
573 $ a1, ''',', i5, ',', i5, ', ... ), type ', i2, ', test(',
574 $ i1, ')=', g12.5 )
575 RETURN
576*
577* End of DCHKTB
578*
dlantr
double precision function dlantr(norm, uplo, diag, m, n, a, lda, work)
DLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlantr.f:141
dlatbs
subroutine dlatbs(uplo, trans, diag, normin, n, kd, ab, ldab, x, scale, cnorm, info)
DLATBS solves a triangular banded system of equations.
Definition dlatbs.f:242
dlantb
double precision function dlantb(norm, uplo, diag, n, k, ab, ldab, work)
DLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlantb.f:140
dtbtrs
subroutine dtbtrs(uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, info)
DTBTRS
Definition dtbtrs.f:146
dtbcon
subroutine dtbcon(norm, uplo, diag, n, kd, ab, ldab, rcond, work, iwork, info)
DTBCON
Definition dtbcon.f:143
dtbrfs
subroutine dtbrfs(uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, ferr, berr, work, iwork, info)
DTBRFS
Definition dtbrfs.f:188
dtbsv
subroutine dtbsv(uplo, trans, diag, n, k, a, lda, x, incx)
DTBSV
Definition dtbsv.f:189
dtbt06
subroutine dtbt06(rcond, rcondc, uplo, diag, n, kd, ab, ldab, work, rat)
DTBT06
Definition dtbt06.f:125
dtbt03
subroutine dtbt03(uplo, trans, diag, n, kd, nrhs, ab, ldab, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
DTBT03
Definition dtbt03.f:175
derrtr
subroutine derrtr(path, nunit)
DERRTR
Definition derrtr.f:55
dlattb
subroutine dlattb(imat, uplo, trans, diag, iseed, n, kd, ab, ldab, b, work, info)
DLATTB
Definition dlattb.f:135
dtbt05
subroutine dtbt05(uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
DTBT05
Definition dtbt05.f:189
dtbt02
subroutine dtbt02(uplo, trans, diag, n, kd, nrhs, ab, ldab, x, ldx, b, ldb, work, resid)
DTBT02
Definition dtbt02.f:154

◆ dchktp()

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

DCHKTP

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

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

◆ dchktr()

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

DCHKTR

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

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

◆ dchktsqr()

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

DCHKQRT

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

Definition at line 100 of file dchktsqr.f.

102 IMPLICIT NONE
103*
104* -- LAPACK test routine --
105* -- LAPACK is a software package provided by Univ. of Tennessee, --
106* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
107*
108* .. Scalar Arguments ..
109 LOGICAL TSTERR
110 INTEGER NM, NN, NNB, NOUT
111 DOUBLE PRECISION THRESH
112* ..
113* .. Array Arguments ..
114 INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
115* ..
116*
117* =====================================================================
118*
119* .. Parameters ..
120 INTEGER NTESTS
121 parameter( ntests = 6 )
122* ..
123* .. Local Scalars ..
124 CHARACTER*3 PATH
125 INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, INB,
126 $ MINMN, MB, IMB
127*
128* .. Local Arrays ..
129 DOUBLE PRECISION RESULT( NTESTS )
130* ..
131* .. External Subroutines ..
132 EXTERNAL alaerh, alahd, alasum, derrtsqr,
133 $ dtsqr01, xlaenv
134* ..
135* .. Intrinsic Functions ..
136 INTRINSIC max, min
137* ..
138* .. Scalars in Common ..
139 LOGICAL LERR, OK
140 CHARACTER*32 SRNAMT
141 INTEGER INFOT, NUNIT
142* ..
143* .. Common blocks ..
144 COMMON / infoc / infot, nunit, ok, lerr
145 COMMON / srnamc / srnamt
146* ..
147* .. Executable Statements ..
148*
149* Initialize constants
150*
151 path( 1: 1 ) = 'D'
152 path( 2: 3 ) = 'TS'
153 nrun = 0
154 nfail = 0
155 nerrs = 0
156*
157* Test the error exits
158*
159 CALL xlaenv( 1, 0 )
160 CALL xlaenv( 2, 0 )
161 IF( tsterr ) CALL derrtsqr( path, nout )
162 infot = 0
163*
164* Do for each value of M in MVAL.
165*
166 DO i = 1, nm
167 m = mval( i )
168*
169* Do for each value of N in NVAL.
170*
171 DO j = 1, nn
172 n = nval( j )
173 IF (min(m,n).NE.0) THEN
174 DO inb = 1, nnb
175 mb = nbval( inb )
176 CALL xlaenv( 1, mb )
177 DO imb = 1, nnb
178 nb = nbval( imb )
179 CALL xlaenv( 2, nb )
180*
181* Test DGEQR and DGEMQR
182*
183 CALL dtsqr01( 'TS', m, n, mb, nb, result )
184*
185* Print information about the tests that did not
186* pass the threshold.
187*
188 DO t = 1, ntests
189 IF( result( t ).GE.thresh ) THEN
190 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
191 $ CALL alahd( nout, path )
192 WRITE( nout, fmt = 9999 )m, n, mb, nb,
193 $ t, result( t )
194 nfail = nfail + 1
195 END IF
196 END DO
197 nrun = nrun + ntests
198 END DO
199 END DO
200 END IF
201 END DO
202 END DO
203*
204* Do for each value of M in MVAL.
205*
206 DO i = 1, nm
207 m = mval( i )
208*
209* Do for each value of N in NVAL.
210*
211 DO j = 1, nn
212 n = nval( j )
213 IF (min(m,n).NE.0) THEN
214 DO inb = 1, nnb
215 mb = nbval( inb )
216 CALL xlaenv( 1, mb )
217 DO imb = 1, nnb
218 nb = nbval( imb )
219 CALL xlaenv( 2, nb )
220*
221* Test DGEQR and DGEMQR
222*
223 CALL dtsqr01( 'SW', m, n, mb, nb, result )
224*
225* Print information about the tests that did not
226* pass the threshold.
227*
228 DO t = 1, ntests
229 IF( result( t ).GE.thresh ) THEN
230 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
231 $ CALL alahd( nout, path )
232 WRITE( nout, fmt = 9998 )m, n, mb, nb,
233 $ t, result( t )
234 nfail = nfail + 1
235 END IF
236 END DO
237 nrun = nrun + ntests
238 END DO
239 END DO
240 END IF
241 END DO
242 END DO
243*
244* Print a summary of the results.
245*
246 CALL alasum( path, nout, nfail, nrun, nerrs )
247*
248 9999 FORMAT( 'TS: M=', i5, ', N=', i5, ', MB=', i5,
249 $ ', NB=', i5,' test(', i2, ')=', g12.5 )
250 9998 FORMAT( 'SW: M=', i5, ', N=', i5, ', MB=', i5,
251 $ ', NB=', i5,' test(', i2, ')=', g12.5 )
252 RETURN
253*
254* End of DCHKTSQR
255*
dtsqr01
subroutine dtsqr01(tssw, m, n, mb, nb, result)
DTSQR01
Definition dtsqr01.f:84
derrtsqr
subroutine derrtsqr(path, nunit)
DERRTSQR
Definition derrtsqr.f:55

◆ dchktz()

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

DCHKTZ

Purpose:
!>
!> DCHKTZ tests DTZRZF.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (MMAX*NMAX)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension
!>                      (min(MMAX,NMAX))
!>
[out]TAU
!>          TAU is DOUBLE PRECISION array, dimension (MMAX)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                      (MMAX*NMAX + 4*NMAX + MMAX)
!>
[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 130 of file dchktz.f.

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

◆ ddrvab()

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

DDRVAB

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

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

◆ ddrvac()

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

DDRVAC

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

Definition at line 141 of file ddrvac.f.

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

◆ ddrvgb()

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

DDRVGB

DDRVGBX

Purpose:
!>
!> DDRVGB tests the driver routines DGBSV and -SVX.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LA)
!>
[out]B
!>          B is DOUBLE PRECISION array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is DOUBLE PRECISION array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is DOUBLE PRECISION array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (2*NMAX)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                      (NMAX*max(3,NRHS,NMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (NMAX+2*NRHS)
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (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.
Purpose:
!>
!> DDRVGB tests the driver routines DGBSV, -SVX, and -SVXX.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise ddrvgb.f defines this subroutine.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LA)
!>
[out]B
!>          B is DOUBLE PRECISION array, dimension (NMAX*NRHS)
!>
[out]BSAV
!>          BSAV is DOUBLE PRECISION array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is DOUBLE PRECISION array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension (2*NMAX)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                      (NMAX*max(3,NRHS,NMAX))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (max(2*NMAX,NMAX+2*NRHS))
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (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 ddrvgb.f.

172*
173* -- LAPACK test routine --
174* -- LAPACK is a software package provided by Univ. of Tennessee, --
175* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176*
177* .. Scalar Arguments ..
178 LOGICAL TSTERR
179 INTEGER LA, LAFB, NN, NOUT, NRHS
180 DOUBLE PRECISION THRESH
181* ..
182* .. Array Arguments ..
183 LOGICAL DOTYPE( * )
184 INTEGER IWORK( * ), NVAL( * )
185 DOUBLE PRECISION A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
186 $ RWORK( * ), S( * ), WORK( * ), X( * ),
187 $ XACT( * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 DOUBLE PRECISION ONE, ZERO
194 parameter( one = 1.0d+0, zero = 0.0d+0 )
195 INTEGER NTYPES
196 parameter( ntypes = 8 )
197 INTEGER NTESTS
198 parameter( ntests = 7 )
199 INTEGER NTRAN
200 parameter( ntran = 3 )
201* ..
202* .. Local Scalars ..
203 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
204 CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
205 CHARACTER*3 PATH
206 INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN,
207 $ INFO, IOFF, ITRAN, IZERO, J, K, K1, KL, KU,
208 $ LDA, LDAFB, LDB, MODE, N, NB, NBMIN, NERRS,
209 $ NFACT, NFAIL, NIMAT, NKL, NKU, NRUN, NT
210 DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV,
211 $ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO,
212 $ ROLDC, ROLDI, ROLDO, ROWCND, RPVGRW
213* ..
214* .. Local Arrays ..
215 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
216 INTEGER ISEED( 4 ), ISEEDY( 4 )
217 DOUBLE PRECISION RESULT( NTESTS )
218* ..
219* .. External Functions ..
220 LOGICAL LSAME
221 DOUBLE PRECISION DGET06, DLAMCH, DLANGB, DLANGE, DLANTB
222 EXTERNAL lsame, dget06, dlamch, dlangb, dlange, dlantb
223* ..
224* .. External Subroutines ..
225 EXTERNAL aladhd, alaerh, alasvm, derrvx, dgbequ, dgbsv,
226 $ dgbsvx, dgbt01, dgbt02, dgbt05, dgbtrf, dgbtrs,
227 $ dget04, dlacpy, dlaqgb, dlarhs, dlaset, dlatb4,
228 $ dlatms, xlaenv
229* ..
230* .. Intrinsic Functions ..
231 INTRINSIC abs, 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 ) = 'Double 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 derrvx( 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 DLATB4 and generate a
356* test matrix with DLATMS.
357*
358 CALL dlatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
359 $ MODE, CNDNUM, DIST )
360 rcondc = one / cndnum
361*
362 srnamt = 'DLATMS'
363 CALL dlatms( 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 DLATMS.
368*
369 IF( info.NE.0 ) THEN
370 CALL alaerh( path, 'DLATMS', 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 dlacpy( 'Full', kl+ku+1, n, a, lda, asav, lda )
408*
409 DO 110 iequed = 1, 4
410 equed = equeds( iequed )
411 IF( iequed.EQ.1 ) THEN
412 nfact = 3
413 ELSE
414 nfact = 1
415 END IF
416*
417 DO 100 ifact = 1, nfact
418 fact = facts( ifact )
419 prefac = lsame( fact, 'F' )
420 nofact = lsame( fact, 'N' )
421 equil = lsame( fact, 'E' )
422*
423 IF( zerot ) THEN
424 IF( prefac )
425 $ GO TO 100
426 rcondo = zero
427 rcondi = zero
428*
429 ELSE IF( .NOT.nofact ) THEN
430*
431* Compute the condition number for comparison
432* with the value returned by DGESVX (FACT =
433* 'N' reuses the condition number from the
434* previous iteration with FACT = 'F').
435*
436 CALL dlacpy( '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 dgbequ( 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 dlaqgb( 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 DGET04.
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 = dlangb( '1', n, kl, ku, afb( kl+1 ),
478 $ ldafb, rwork )
479 anormi = dlangb( 'I', n, kl, ku, afb( kl+1 ),
480 $ ldafb, rwork )
481*
482* Factor the matrix A.
483*
484 CALL dgbtrf( n, n, kl, ku, afb, ldafb, iwork,
485 $ info )
486*
487* Form the inverse of A.
488*
489 CALL dlaset( 'Full', n, n, zero, one, work,
490 $ ldb )
491 srnamt = 'DGBTRS'
492 CALL dgbtrs( '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 = dlange( '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 = dlange( '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 dlacpy( '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 = 'DLARHS'
538 CALL dlarhs( path, xtype, 'Full', trans, n,
539 $ n, kl, ku, nrhs, a, lda, xact,
540 $ ldb, b, ldb, iseed, info )
541 xtype = 'C'
542 CALL dlacpy( 'Full', n, nrhs, b, ldb, bsav,
543 $ ldb )
544*
545 IF( nofact .AND. itran.EQ.1 ) THEN
546*
547* --- Test DGBSV ---
548*
549* Compute the LU factorization of the matrix
550* and solve the system.
551*
552 CALL dlacpy( 'Full', kl+ku+1, n, a, lda,
553 $ afb( kl+1 ), ldafb )
554 CALL dlacpy( 'Full', n, nrhs, b, ldb, x,
555 $ ldb )
556*
557 srnamt = 'DGBSV '
558 CALL dgbsv( n, kl, ku, nrhs, afb, ldafb,
559 $ iwork, x, ldb, info )
560*
561* Check error code from DGBSV .
562*
563 IF( info.NE.izero )
564 $ CALL alaerh( path, 'DGBSV ', 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 dgbt01( 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 dlacpy( 'Full', n, nrhs, b, ldb,
582 $ work, ldb )
583 CALL dgbt02( '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 dget04( 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 )'DGBSV ',
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 DGBSVX ---
612*
613 IF( .NOT.prefac )
614 $ CALL dlaset( 'Full', 2*kl+ku+1, n, zero,
615 $ zero, afb, ldafb )
616 CALL dlaset( 'Full', n, nrhs, zero, zero, x,
617 $ ldb )
618 IF( iequed.GT.1 .AND. n.GT.0 ) THEN
619*
620* Equilibrate the matrix if FACT = 'F' and
621* EQUED = 'R', 'C', or 'B'.
622*
623 CALL dlaqgb( n, n, kl, ku, a, lda, s,
624 $ s( n+1 ), rowcnd, colcnd,
625 $ amax, equed )
626 END IF
627*
628* Solve the system and compute the condition
629* number and error bounds using DGBSVX.
630*
631 srnamt = 'DGBSVX'
632 CALL dgbsvx( fact, trans, n, kl, ku, nrhs, a,
633 $ lda, afb, ldafb, iwork, equed,
634 $ s, s( n+1 ), b, ldb, x, ldb,
635 $ rcond, rwork, rwork( nrhs+1 ),
636 $ work, iwork( n+1 ), info )
637*
638* Check the error code from DGBSVX.
639*
640 IF( info.NE.izero )
641 $ CALL alaerh( path, 'DGBSVX', info, izero,
642 $ fact // trans, n, n, kl, ku,
643 $ nrhs, imat, nfail, nerrs,
644 $ nout )
645*
646* Compare WORK(1) from DGBSVX with the computed
647* reciprocal pivot growth factor 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 = dlantb( 'M', 'U', 'N', info,
659 $ min( info-1, kl+ku ),
660 $ afb( max( 1, kl+ku+2-info ) ),
661 $ ldafb, work )
662 IF( rpvgrw.EQ.zero ) THEN
663 rpvgrw = one
664 ELSE
665 rpvgrw = anrmpv / rpvgrw
666 END IF
667 ELSE
668 rpvgrw = dlantb( 'M', 'U', 'N', n, kl+ku,
669 $ afb, ldafb, work )
670 IF( rpvgrw.EQ.zero ) THEN
671 rpvgrw = one
672 ELSE
673 rpvgrw = dlangb( 'M', n, kl, ku, a,
674 $ lda, work ) / rpvgrw
675 END IF
676 END IF
677 result( 7 ) = abs( rpvgrw-work( 1 ) ) /
678 $ max( work( 1 ), rpvgrw ) /
679 $ dlamch( 'E' )
680*
681 IF( .NOT.prefac ) THEN
682*
683* Reconstruct matrix from factors and
684* compute residual.
685*
686 CALL dgbt01( 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 dlacpy( 'Full', n, nrhs, bsav, ldb,
700 $ work, ldb )
701 CALL dgbt02( 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 dget04( 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 dget04( 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 dgbt05( trans, n, kl, ku, nrhs, asav,
727 $ lda, b, 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 DGBSVX with the computed
735* value in RCONDC.
736*
737 result( 6 ) = dget06( rcond, rcondc )
738*
739* Print information about the tests that did
740* not pass the threshold.
741*
742 IF( .NOT.trfcon ) THEN
743 DO 80 k = k1, ntests
744 IF( result( k ).GE.thresh ) THEN
745 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
746 $ CALL aladhd( nout, path )
747 IF( prefac ) THEN
748 WRITE( nout, fmt = 9995 )
749 $ 'DGBSVX', fact, trans, n, kl,
750 $ ku, equed, imat, k,
751 $ result( k )
752 ELSE
753 WRITE( nout, fmt = 9996 )
754 $ 'DGBSVX', 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 )'DGBSVX',
768 $ fact, trans, n, kl, ku, equed,
769 $ imat, 1, result( 1 )
770 ELSE
771 WRITE( nout, fmt = 9996 )'DGBSVX',
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 )'DGBSVX',
783 $ fact, trans, n, kl, ku, equed,
784 $ imat, 6, result( 6 )
785 ELSE
786 WRITE( nout, fmt = 9996 )'DGBSVX',
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 )'DGBSVX',
798 $ fact, trans, n, kl, ku, equed,
799 $ imat, 7, result( 7 )
800 ELSE
801 WRITE( nout, fmt = 9996 )'DGBSVX',
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*
809 END IF
810 90 CONTINUE
811 100 CONTINUE
812 110 CONTINUE
813 120 CONTINUE
814 130 CONTINUE
815 140 CONTINUE
816 150 CONTINUE
817*
818* Print a summary of the results.
819*
820 CALL alasvm( path, nout, nfail, nrun, nerrs )
821*
822 9999 FORMAT( ' *** In DDRVGB, LA=', i5, ' is too small for N=', i5,
823 $ ', KU=', i5, ', KL=', i5, / ' ==> Increase LA to at least ',
824 $ i5 )
825 9998 FORMAT( ' *** In DDRVGB, LAFB=', i5, ' is too small for N=', i5,
826 $ ', KU=', i5, ', KL=', i5, /
827 $ ' ==> Increase LAFB to at least ', i5 )
828 9997 FORMAT( 1x, a, ', N=', i5, ', KL=', i5, ', KU=', i5, ', type ',
829 $ i1, ', test(', i1, ')=', g12.5 )
830 9996 FORMAT( 1x, a, '( ''', a1, ''',''', a1, ''',', i5, ',', i5, ',',
831 $ i5, ',...), type ', i1, ', test(', i1, ')=', g12.5 )
832 9995 FORMAT( 1x, a, '( ''', a1, ''',''', a1, ''',', i5, ',', i5, ',',
833 $ i5, ',...), EQUED=''', a1, ''', type ', i1, ', test(', i1,
834 $ ')=', g12.5 )
835*
836 RETURN
837*
838* End of DDRVGB
839*
alasvm
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
Definition alasvm.f:73
aladhd
subroutine aladhd(iounit, path)
ALADHD
Definition aladhd.f:90
dlaqgb
subroutine dlaqgb(m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, equed)
DLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ.
Definition dlaqgb.f:159
dgbsvx
subroutine dgbsvx(fact, trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, equed, r, c, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, info)
DGBSVX computes the solution to system of linear equations A * X = B for GB matrices
Definition dgbsvx.f:369
dgbsv
subroutine dgbsv(n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
DGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver)
Definition dgbsv.f:162
derrvx
subroutine derrvx(path, nunit)
DERRVX
Definition derrvx.f:55

◆ ddrvge()

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

DDRVGE

DDRVGEX

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

164*
165* -- LAPACK test routine --
166* -- LAPACK is a software package provided by Univ. of Tennessee, --
167* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
168*
169* .. Scalar Arguments ..
170 LOGICAL TSTERR
171 INTEGER NMAX, NN, NOUT, NRHS
172 DOUBLE PRECISION THRESH
173* ..
174* .. Array Arguments ..
175 LOGICAL DOTYPE( * )
176 INTEGER IWORK( * ), NVAL( * )
177 DOUBLE PRECISION A( * ), AFAC( * ), ASAV( * ), B( * ),
178 $ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
179 $ X( * ), XACT( * )
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 DOUBLE PRECISION ONE, ZERO
186 parameter( one = 1.0d+0, zero = 0.0d+0 )
187 INTEGER NTYPES
188 parameter( ntypes = 11 )
189 INTEGER NTESTS
190 parameter( ntests = 7 )
191 INTEGER NTRAN
192 parameter( ntran = 3 )
193* ..
194* .. Local Scalars ..
195 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
196 CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
197 CHARACTER*3 PATH
198 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, ITRAN,
199 $ IZERO, K, K1, KL, KU, LDA, LWORK, MODE, N, NB,
200 $ NBMIN, NERRS, NFACT, NFAIL, NIMAT, NRUN, NT
201 DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, CNDNUM,
202 $ COLCND, RCOND, RCONDC, RCONDI, RCONDO, ROLDC,
203 $ ROLDI, ROLDO, ROWCND, RPVGRW
204* ..
205* .. Local Arrays ..
206 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
207 INTEGER ISEED( 4 ), ISEEDY( 4 )
208 DOUBLE PRECISION RESULT( NTESTS )
209* ..
210* .. External Functions ..
211 LOGICAL LSAME
212 DOUBLE PRECISION DGET06, DLAMCH, DLANGE, DLANTR
213 EXTERNAL lsame, dget06, dlamch, dlange, dlantr
214* ..
215* .. External Subroutines ..
216 EXTERNAL aladhd, alaerh, alasvm, derrvx, dgeequ, dgesv,
217 $ dgesvx, dget01, dget02, dget04, dget07, dgetrf,
218 $ dgetri, dlacpy, dlaqge, dlarhs, dlaset, dlatb4,
219 $ dlatms, xlaenv
220* ..
221* .. Intrinsic Functions ..
222 INTRINSIC abs, 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 ) = 'Double 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 derrvx( 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 DLATB4 and generate a test matrix
289* with DLATMS.
290*
291 CALL dlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
292 $ CNDNUM, DIST )
293 rcondc = one / cndnum
294*
295 srnamt = 'DLATMS'
296 CALL dlatms( 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 DLATMS.
301*
302 IF( info.NE.0 ) THEN
303 CALL alaerh( path, 'DLATMS', 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 dlaset( 'Full', n, n-izero+1, zero, zero,
326 $ 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 dlacpy( '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 DGESVX (FACT = 'N' reuses
360* the condition number from the previous iteration
361* with FACT = 'F').
362*
363 CALL dlacpy( '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 dgeequ( 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 dlaqge( 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 DGET04.
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 = dlange( '1', n, n, afac, lda, rwork )
401 anormi = dlange( 'I', n, n, afac, lda, rwork )
402*
403* Factor the matrix A.
404*
405 srnamt = 'DGETRF'
406 CALL dgetrf( n, n, afac, lda, iwork, info )
407*
408* Form the inverse of A.
409*
410 CALL dlacpy( 'Full', n, n, afac, lda, a, lda )
411 lwork = nmax*max( 3, nrhs )
412 srnamt = 'DGETRI'
413 CALL dgetri( n, a, lda, iwork, work, lwork, info )
414*
415* Compute the 1-norm condition number of A.
416*
417 ainvnm = dlange( '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 = dlange( '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 dlacpy( 'Full', n, n, asav, lda, a, lda )
448*
449* Form an exact solution and set the right hand side.
450*
451 srnamt = 'DLARHS'
452 CALL dlarhs( path, xtype, 'Full', trans, n, n, kl,
453 $ ku, nrhs, a, lda, xact, lda, b, lda,
454 $ iseed, info )
455 xtype = 'C'
456 CALL dlacpy( 'Full', n, nrhs, b, lda, bsav, lda )
457*
458 IF( nofact .AND. itran.EQ.1 ) THEN
459*
460* --- Test DGESV ---
461*
462* Compute the LU factorization of the matrix and
463* solve the system.
464*
465 CALL dlacpy( 'Full', n, n, a, lda, afac, lda )
466 CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
467*
468 srnamt = 'DGESV '
469 CALL dgesv( n, nrhs, afac, lda, iwork, x, lda,
470 $ info )
471*
472* Check error code from DGESV .
473*
474 IF( info.NE.izero )
475 $ CALL alaerh( path, 'DGESV ', 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 dget01( 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 dlacpy( 'Full', n, nrhs, b, lda, work,
490 $ lda )
491 CALL dget02( '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 dget04( 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 )'DGESV ', 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 DGESVX ---
518*
519 IF( .NOT.prefac )
520 $ CALL dlaset( 'Full', n, n, zero, zero, afac,
521 $ lda )
522 CALL dlaset( 'Full', n, nrhs, zero, zero, x, lda )
523 IF( iequed.GT.1 .AND. n.GT.0 ) THEN
524*
525* Equilibrate the matrix if FACT = 'F' and
526* EQUED = 'R', 'C', or 'B'.
527*
528 CALL dlaqge( n, n, a, lda, s, s( n+1 ), rowcnd,
529 $ colcnd, amax, equed )
530 END IF
531*
532* Solve the system and compute the condition number
533* and error bounds using DGESVX.
534*
535 srnamt = 'DGESVX'
536 CALL dgesvx( fact, trans, n, nrhs, a, lda, afac,
537 $ lda, iwork, equed, s, s( n+1 ), b,
538 $ lda, x, lda, rcond, rwork,
539 $ rwork( nrhs+1 ), work, iwork( n+1 ),
540 $ info )
541*
542* Check the error code from DGESVX.
543*
544 IF( info.NE.izero )
545 $ CALL alaerh( path, 'DGESVX', info, izero,
546 $ fact // trans, n, n, -1, -1, nrhs,
547 $ imat, nfail, nerrs, nout )
548*
549* Compare WORK(1) from DGESVX with the computed
550* reciprocal pivot growth factor RPVGRW
551*
552 IF( info.NE.0 .AND. info.LE.n) THEN
553 rpvgrw = dlantr( 'M', 'U', 'N', info, info,
554 $ afac, lda, work )
555 IF( rpvgrw.EQ.zero ) THEN
556 rpvgrw = one
557 ELSE
558 rpvgrw = dlange( 'M', n, info, a, lda,
559 $ work ) / rpvgrw
560 END IF
561 ELSE
562 rpvgrw = dlantr( 'M', 'U', 'N', n, n, afac, lda,
563 $ work )
564 IF( rpvgrw.EQ.zero ) THEN
565 rpvgrw = one
566 ELSE
567 rpvgrw = dlange( 'M', n, n, a, lda, work ) /
568 $ rpvgrw
569 END IF
570 END IF
571 result( 7 ) = abs( rpvgrw-work( 1 ) ) /
572 $ max( work( 1 ), rpvgrw ) /
573 $ dlamch( 'E' )
574*
575 IF( .NOT.prefac ) THEN
576*
577* Reconstruct matrix from factors and compute
578* residual.
579*
580 CALL dget01( n, n, a, lda, afac, lda, iwork,
581 $ rwork( 2*nrhs+1 ), result( 1 ) )
582 k1 = 1
583 ELSE
584 k1 = 2
585 END IF
586*
587 IF( info.EQ.0 ) THEN
588 trfcon = .false.
589*
590* Compute residual of the computed solution.
591*
592 CALL dlacpy( 'Full', n, nrhs, bsav, lda, work,
593 $ lda )
594 CALL dget02( trans, n, n, nrhs, asav, lda, x,
595 $ lda, work, lda, rwork( 2*nrhs+1 ),
596 $ result( 2 ) )
597*
598* Check solution from generated exact solution.
599*
600 IF( nofact .OR. ( prefac .AND. lsame( equed,
601 $ 'N' ) ) ) THEN
602 CALL dget04( n, nrhs, x, lda, xact, lda,
603 $ rcondc, result( 3 ) )
604 ELSE
605 IF( itran.EQ.1 ) THEN
606 roldc = roldo
607 ELSE
608 roldc = roldi
609 END IF
610 CALL dget04( n, nrhs, x, lda, xact, lda,
611 $ roldc, result( 3 ) )
612 END IF
613*
614* Check the error bounds from iterative
615* refinement.
616*
617 CALL dget07( trans, n, nrhs, asav, lda, b, lda,
618 $ x, lda, xact, lda, rwork, .true.,
619 $ rwork( nrhs+1 ), result( 4 ) )
620 ELSE
621 trfcon = .true.
622 END IF
623*
624* Compare RCOND from DGESVX with the computed value
625* in RCONDC.
626*
627 result( 6 ) = dget06( rcond, rcondc )
628*
629* Print information about the tests that did not pass
630* the threshold.
631*
632 IF( .NOT.trfcon ) THEN
633 DO 40 k = k1, ntests
634 IF( result( k ).GE.thresh ) THEN
635 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
636 $ CALL aladhd( nout, path )
637 IF( prefac ) THEN
638 WRITE( nout, fmt = 9997 )'DGESVX',
639 $ fact, trans, n, equed, imat, k,
640 $ result( k )
641 ELSE
642 WRITE( nout, fmt = 9998 )'DGESVX',
643 $ fact, trans, n, imat, k, result( k )
644 END IF
645 nfail = nfail + 1
646 END IF
647 40 CONTINUE
648 nrun = nrun + ntests - k1 + 1
649 ELSE
650 IF( result( 1 ).GE.thresh .AND. .NOT.prefac )
651 $ THEN
652 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
653 $ CALL aladhd( nout, path )
654 IF( prefac ) THEN
655 WRITE( nout, fmt = 9997 )'DGESVX', fact,
656 $ trans, n, equed, imat, 1, result( 1 )
657 ELSE
658 WRITE( nout, fmt = 9998 )'DGESVX', fact,
659 $ trans, n, imat, 1, result( 1 )
660 END IF
661 nfail = nfail + 1
662 nrun = nrun + 1
663 END IF
664 IF( result( 6 ).GE.thresh ) THEN
665 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
666 $ CALL aladhd( nout, path )
667 IF( prefac ) THEN
668 WRITE( nout, fmt = 9997 )'DGESVX', fact,
669 $ trans, n, equed, imat, 6, result( 6 )
670 ELSE
671 WRITE( nout, fmt = 9998 )'DGESVX', fact,
672 $ trans, n, imat, 6, result( 6 )
673 END IF
674 nfail = nfail + 1
675 nrun = nrun + 1
676 END IF
677 IF( result( 7 ).GE.thresh ) THEN
678 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
679 $ CALL aladhd( nout, path )
680 IF( prefac ) THEN
681 WRITE( nout, fmt = 9997 )'DGESVX', fact,
682 $ trans, n, equed, imat, 7, result( 7 )
683 ELSE
684 WRITE( nout, fmt = 9998 )'DGESVX', fact,
685 $ trans, n, imat, 7, result( 7 )
686 END IF
687 nfail = nfail + 1
688 nrun = nrun + 1
689 END IF
690*
691 END IF
692*
693 50 CONTINUE
694 60 CONTINUE
695 70 CONTINUE
696 80 CONTINUE
697 90 CONTINUE
698*
699* Print a summary of the results.
700*
701 CALL alasvm( path, nout, nfail, nrun, nerrs )
702*
703 9999 FORMAT( 1x, a, ', N =', i5, ', type ', i2, ', test(', i2, ') =',
704 $ g12.5 )
705 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', TRANS=''', a1, ''', N=', i5,
706 $ ', type ', i2, ', test(', i1, ')=', g12.5 )
707 9997 FORMAT( 1x, a, ', FACT=''', a1, ''', TRANS=''', a1, ''', N=', i5,
708 $ ', EQUED=''', a1, ''', type ', i2, ', test(', i1, ')=',
709 $ g12.5 )
710 RETURN
711*
712* End of DDRVGE
713*
dlaqge
subroutine dlaqge(m, n, a, lda, r, c, rowcnd, colcnd, amax, equed)
DLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sgeequ.
Definition dlaqge.f:142
dgesvx
subroutine dgesvx(fact, trans, n, nrhs, a, lda, af, ldaf, ipiv, equed, r, c, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, info)
DGESVX computes the solution to system of linear equations A * X = B for GE matrices
Definition dgesvx.f:349
dgesv
subroutine dgesv(n, nrhs, a, lda, ipiv, b, ldb, info)
DGESV computes the solution to system of linear equations A * X = B for GE matrices
Definition dgesv.f:122

◆ ddrvgt()

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

DDRVGT

Purpose:
!>
!> DDRVGT tests DGTSV and -SVX.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, NRHS >= 0.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is DOUBLE PRECISION array, dimension (NMAX*4)
!>
[out]AF
!>          AF is DOUBLE PRECISION array, dimension (NMAX*4)
!>
[out]B
!>          B is DOUBLE PRECISION array, dimension (NMAX*NRHS)
!>
[out]X
!>          X is DOUBLE PRECISION array, dimension (NMAX*NRHS)
!>
[out]XACT
!>          XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension
!>                      (NMAX*max(3,NRHS))
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension
!>                      (max(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 ddrvgt.f.

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

◆ ddrvls()

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

DDRVLS

Purpose:
!>
!> DDRVLS tests the least squares driver routines DGELS, DGETSLS, DGELSS, DGELSY,
!> and DGELSD.
!>
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 orthogonal 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 orthogonal 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]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]NNB
!>          NNB is INTEGER
!>          The number of values of NB and NX contained in the
!>          vectors NBVAL and NXVAL.  The blocking parameters are used
!>          in pairs (NB,NX).
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NXVAL
!>          NXVAL is INTEGER array, dimension (NNB)
!>          The values of the crossover point NX.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (MMAX*NMAX)
!>
[out]B
!>          B is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (MMAX*NSMAX)
!>
[out]C
!>          C is DOUBLE PRECISION array, dimension (MMAX*NSMAX)
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension
!>                      (min(MMAX,NMAX))
!>
[out]COPYS
!>          COPYS is DOUBLE PRECISION array, dimension
!>                      (min(MMAX,NMAX))
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 189 of file ddrvls.f.

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

◆ ddrvpb()

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

DDRVPB

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

Definition at line 161 of file ddrvpb.f.

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

◆ ddrvpo()

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

DDRVPO

DDRVPOX

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

Definition at line 161 of file ddrvpo.f.

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

◆ ddrvpp()

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

DDRVPP

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

Definition at line 164 of file ddrvpp.f.

167*
168* -- LAPACK test routine --
169* -- LAPACK is a software package provided by Univ. of Tennessee, --
170* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
171*
172* .. Scalar Arguments ..
173 LOGICAL TSTERR
174 INTEGER NMAX, NN, NOUT, NRHS
175 DOUBLE PRECISION THRESH
176* ..
177* .. Array Arguments ..
178 LOGICAL DOTYPE( * )
179 INTEGER IWORK( * ), NVAL( * )
180 DOUBLE PRECISION A( * ), AFAC( * ), ASAV( * ), B( * ),
181 $ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
182 $ X( * ), XACT( * )
183* ..
184*
185* =====================================================================
186*
187* .. Parameters ..
188 DOUBLE PRECISION ONE, ZERO
189 parameter( one = 1.0d+0, zero = 0.0d+0 )
190 INTEGER NTYPES
191 parameter( ntypes = 9 )
192 INTEGER NTESTS
193 parameter( ntests = 6 )
194* ..
195* .. Local Scalars ..
196 LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
197 CHARACTER DIST, EQUED, FACT, PACKIT, TYPE, UPLO, XTYPE
198 CHARACTER*3 PATH
199 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
200 $ IZERO, K, K1, KL, KU, LDA, MODE, N, NERRS,
201 $ NFACT, NFAIL, NIMAT, NPP, NRUN, NT
202 DOUBLE PRECISION AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
203 $ ROLDC, SCOND
204* ..
205* .. Local Arrays ..
206 CHARACTER EQUEDS( 2 ), FACTS( 3 ), PACKS( 2 ), UPLOS( 2 )
207 INTEGER ISEED( 4 ), ISEEDY( 4 )
208 DOUBLE PRECISION RESULT( NTESTS )
209* ..
210* .. External Functions ..
211 LOGICAL LSAME
212 DOUBLE PRECISION DGET06, DLANSP
213 EXTERNAL lsame, dget06, dlansp
214* ..
215* .. External Subroutines ..
216 EXTERNAL aladhd, alaerh, alasvm, dcopy, derrvx, dget04,
217 $ dlacpy, dlaqsp, dlarhs, dlaset, dlatb4, dlatms,
218 $ dppequ, dppsv, dppsvx, dppt01, dppt02, dppt05,
219 $ dpptrf, dpptri
220* ..
221* .. Scalars in Common ..
222 LOGICAL LERR, OK
223 CHARACTER*32 SRNAMT
224 INTEGER INFOT, NUNIT
225* ..
226* .. Common blocks ..
227 COMMON / infoc / infot, nunit, ok, lerr
228 COMMON / srnamc / srnamt
229* ..
230* .. Intrinsic Functions ..
231 INTRINSIC max
232* ..
233* .. Data statements ..
234 DATA iseedy / 1988, 1989, 1990, 1991 /
235 DATA uplos / 'U', 'L' / , facts / 'F', 'N', 'E' / ,
236 $ packs / 'C', 'R' / , equeds / 'N', 'Y' /
237* ..
238* .. Executable Statements ..
239*
240* Initialize constants and the random number seed.
241*
242 path( 1: 1 ) = 'Double precision'
243 path( 2: 3 ) = 'PP'
244 nrun = 0
245 nfail = 0
246 nerrs = 0
247 DO 10 i = 1, 4
248 iseed( i ) = iseedy( i )
249 10 CONTINUE
250*
251* Test the error exits
252*
253 IF( tsterr )
254 $ CALL derrvx( path, nout )
255 infot = 0
256*
257* Do for each value of N in NVAL
258*
259 DO 140 in = 1, nn
260 n = nval( in )
261 lda = max( n, 1 )
262 npp = n*( n+1 ) / 2
263 xtype = 'N'
264 nimat = ntypes
265 IF( n.LE.0 )
266 $ nimat = 1
267*
268 DO 130 imat = 1, nimat
269*
270* Do the tests only if DOTYPE( IMAT ) is true.
271*
272 IF( .NOT.dotype( imat ) )
273 $ GO TO 130
274*
275* Skip types 3, 4, or 5 if the matrix size is too small.
276*
277 zerot = imat.GE.3 .AND. imat.LE.5
278 IF( zerot .AND. n.LT.imat-2 )
279 $ GO TO 130
280*
281* Do first for UPLO = 'U', then for UPLO = 'L'
282*
283 DO 120 iuplo = 1, 2
284 uplo = uplos( iuplo )
285 packit = packs( iuplo )
286*
287* Set up parameters with DLATB4 and generate a test matrix
288* with DLATMS.
289*
290 CALL dlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
291 $ CNDNUM, DIST )
292 rcondc = one / cndnum
293*
294 srnamt = 'DLATMS'
295 CALL dlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
296 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
297 $ INFO )
298*
299* Check error code from DLATMS.
300*
301 IF( info.NE.0 ) THEN
302 CALL alaerh( path, 'DLATMS', info, 0, uplo, n, n, -1,
303 $ -1, -1, imat, nfail, nerrs, nout )
304 GO TO 120
305 END IF
306*
307* For types 3-5, zero one row and column of the matrix to
308* 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* Set row and column IZERO of A to 0.
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 izero = 0
344 END IF
345*
346* Save a copy of the matrix A in ASAV.
347*
348 CALL dcopy( 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 DPPSVX (FACT = 'N' reuses
373* the condition number from the previous iteration
374* with FACT = 'F').
375*
376 CALL dcopy( 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 dppequ( 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 dlaqsp( 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 DGET04.
397*
398 IF( equil )
399 $ roldc = rcondc
400*
401* Compute the 1-norm of A.
402*
403 anorm = dlansp( '1', uplo, n, afac, rwork )
404*
405* Factor the matrix A.
406*
407 CALL dpptrf( uplo, n, afac, info )
408*
409* Form the inverse of A.
410*
411 CALL dcopy( npp, afac, 1, a, 1 )
412 CALL dpptri( uplo, n, a, info )
413*
414* Compute the 1-norm condition number of A.
415*
416 ainvnm = dlansp( '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 dcopy( npp, asav, 1, a, 1 )
427*
428* Form an exact solution and set the right hand side.
429*
430 srnamt = 'DLARHS'
431 CALL dlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
432 $ nrhs, a, lda, xact, lda, b, lda,
433 $ iseed, info )
434 xtype = 'C'
435 CALL dlacpy( 'Full', n, nrhs, b, lda, bsav, lda )
436*
437 IF( nofact ) THEN
438*
439* --- Test DPPSV ---
440*
441* Compute the L*L' or U'*U factorization of the
442* matrix and solve the system.
443*
444 CALL dcopy( npp, a, 1, afac, 1 )
445 CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
446*
447 srnamt = 'DPPSV '
448 CALL dppsv( uplo, n, nrhs, afac, x, lda, info )
449*
450* Check error code from DPPSV .
451*
452 IF( info.NE.izero ) THEN
453 CALL alaerh( path, 'DPPSV ', 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 dppt01( uplo, n, a, afac, rwork,
465 $ result( 1 ) )
466*
467* Compute residual of the computed solution.
468*
469 CALL dlacpy( 'Full', n, nrhs, b, lda, work,
470 $ lda )
471 CALL dppt02( uplo, n, nrhs, a, x, lda, work,
472 $ lda, rwork, result( 2 ) )
473*
474* Check solution from generated exact solution.
475*
476 CALL dget04( 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 )'DPPSV ', 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 DPPSVX ---
497*
498 IF( .NOT.prefac .AND. npp.GT.0 )
499 $ CALL dlaset( 'Full', npp, 1, zero, zero, afac,
500 $ npp )
501 CALL dlaset( 'Full', n, nrhs, zero, zero, x, lda )
502 IF( iequed.GT.1 .AND. n.GT.0 ) THEN
503*
504* Equilibrate the matrix if FACT='F' and
505* EQUED='Y'.
506*
507 CALL dlaqsp( uplo, n, a, s, scond, amax, equed )
508 END IF
509*
510* Solve the system and compute the condition number
511* and error bounds using DPPSVX.
512*
513 srnamt = 'DPPSVX'
514 CALL dppsvx( fact, uplo, n, nrhs, a, afac, equed,
515 $ s, b, lda, x, lda, rcond, rwork,
516 $ rwork( nrhs+1 ), work, iwork, info )
517*
518* Check the error code from DPPSVX.
519*
520 IF( info.NE.izero ) THEN
521 CALL alaerh( path, 'DPPSVX', info, izero,
522 $ fact // uplo, n, n, -1, -1, nrhs,
523 $ imat, nfail, nerrs, nout )
524 GO TO 90
525 END IF
526*
527 IF( info.EQ.0 ) THEN
528 IF( .NOT.prefac ) THEN
529*
530* Reconstruct matrix from factors and compute
531* residual.
532*
533 CALL dppt01( uplo, n, a, afac,
534 $ rwork( 2*nrhs+1 ), result( 1 ) )
535 k1 = 1
536 ELSE
537 k1 = 2
538 END IF
539*
540* Compute residual of the computed solution.
541*
542 CALL dlacpy( 'Full', n, nrhs, bsav, lda, work,
543 $ lda )
544 CALL dppt02( uplo, n, nrhs, asav, x, lda, work,
545 $ lda, rwork( 2*nrhs+1 ),
546 $ result( 2 ) )
547*
548* Check solution from generated exact solution.
549*
550 IF( nofact .OR. ( prefac .AND. lsame( equed,
551 $ 'N' ) ) ) THEN
552 CALL dget04( n, nrhs, x, lda, xact, lda,
553 $ rcondc, result( 3 ) )
554 ELSE
555 CALL dget04( n, nrhs, x, lda, xact, lda,
556 $ roldc, result( 3 ) )
557 END IF
558*
559* Check the error bounds from iterative
560* refinement.
561*
562 CALL dppt05( uplo, n, nrhs, asav, b, lda, x,
563 $ lda, xact, lda, rwork,
564 $ rwork( nrhs+1 ), result( 4 ) )
565 ELSE
566 k1 = 6
567 END IF
568*
569* Compare RCOND from DPPSVX with the computed value
570* in RCONDC.
571*
572 result( 6 ) = dget06( rcond, rcondc )
573*
574* Print information about the tests that did not pass
575* the threshold.
576*
577 DO 80 k = k1, 6
578 IF( result( k ).GE.thresh ) THEN
579 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
580 $ CALL aladhd( nout, path )
581 IF( prefac ) THEN
582 WRITE( nout, fmt = 9997 )'DPPSVX', fact,
583 $ uplo, n, equed, imat, k, result( k )
584 ELSE
585 WRITE( nout, fmt = 9998 )'DPPSVX', fact,
586 $ uplo, n, imat, k, result( k )
587 END IF
588 nfail = nfail + 1
589 END IF
590 80 CONTINUE
591 nrun = nrun + 7 - k1
592 90 CONTINUE
593 100 CONTINUE
594 110 CONTINUE
595 120 CONTINUE
596 130 CONTINUE
597 140 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 ', i1,
604 $ ', test(', i1, ')=', g12.5 )
605 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N=', i5,
606 $ ', type ', i1, ', test(', i1, ')=', g12.5 )
607 9997 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N=', i5,
608 $ ', EQUED=''', a1, ''', type ', i1, ', test(', i1, ')=',
609 $ g12.5 )
610 RETURN
611*
612* End of DDRVPP
613*
dlaqsp
subroutine dlaqsp(uplo, n, ap, s, scond, amax, equed)
DLAQSP scales a symmetric/Hermitian matrix in packed storage, using scaling factors computed by sppeq...
Definition dlaqsp.f:125
dppsvx
subroutine dppsvx(fact, uplo, n, nrhs, ap, afp, equed, s, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, info)
DPPSVX computes the solution to system of linear equations A * X = B for OTHER matrices
Definition dppsvx.f:311
dppsv
subroutine dppsv(uplo, n, nrhs, ap, b, ldb, info)
DPPSV computes the solution to system of linear equations A * X = B for OTHER matrices
Definition dppsv.f:144

◆ ddrvpt()

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

DDRVPT

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

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

◆ ddrvrf1()

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

DDRVRF1

Purpose:
!>
!> DDRVRF1 tests the LAPACK RFP routines:
!>     DLANSF
!>
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 DOUBLE PRECISION array, dimension (LDA,NMAX)
!>
[in]LDA
!>          LDA is INTEGER
!>                The leading dimension of the array A.  LDA >= max(1,NMAX).
!>
[out]ARF
!>          ARF is DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension ( NMAX )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 93 of file ddrvrf1.f.

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

◆ ddrvrf2()

subroutine ddrvrf2 ( integer nout,
integer nn,
integer, dimension( nn ) nval,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) arf,
double precision, dimension(*) ap,
double precision, dimension( lda, * ) asav )

DDRVRF2

Purpose:
!>
!> DDRVRF2 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 DOUBLE PRECISION array, dimension (LDA,NMAX)
!>
[in]LDA
!>          LDA is INTEGER
!>                The leading dimension of the array A.  LDA >= max(1,NMAX).
!>
[out]ARF
!>          ARF is DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2).
!>
[out]AP
!>          AP is DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2).
!>
[out]ASAV
!>          ASAV is DOUBLE PRECISION array, dimension (LDA,NMAX)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 88 of file ddrvrf2.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 DOUBLE PRECISION 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 DOUBLE PRECISION DLARND
116 EXTERNAL dlarnd
117* ..
118* .. External Subroutines ..
119 EXTERNAL dtfttr, dtfttp, dtrttf, dtrttp, dtpttr, dtpttf
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', 'T' /
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 = 'T'
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) = dlarnd( 2, iseed )
166 END DO
167 END DO
168*
169 srnamt = 'DTRTTF'
170 CALL dtrttf( cform, uplo, n, a, lda, arf, info )
171*
172 srnamt = 'DTFTTP'
173 CALL dtfttp( cform, uplo, n, arf, ap, info )
174*
175 srnamt = 'DTPTTR'
176 CALL dtpttr( 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 = 'DTRTTP'
200 CALL dtrttp( uplo, n, a, lda, ap, info )
201*
202 srnamt = 'DTPTTF'
203 CALL dtpttf( cform, uplo, n, ap, arf, info )
204*
205 srnamt = 'DTFTTR'
206 CALL dtfttr( 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 DDRVRF2
260*
dtfttr
subroutine dtfttr(transr, uplo, n, arf, a, lda, info)
DTFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full f...
Definition dtfttr.f:196
dtpttf
subroutine dtpttf(transr, uplo, n, ap, arf, info)
DTPTTF copies a triangular matrix from the standard packed format (TP) to the rectangular full packed...
Definition dtpttf.f:186
dtrttp
subroutine dtrttp(uplo, n, a, lda, ap, info)
DTRTTP copies a triangular matrix from the standard full format (TR) to the standard packed format (T...
Definition dtrttp.f:104
dtfttp
subroutine dtfttp(transr, uplo, n, arf, ap, info)
DTFTTP copies a triangular matrix from the rectangular full packed format (TF) to the standard packed...
Definition dtfttp.f:187
dtpttr
subroutine dtpttr(uplo, n, ap, a, lda, info)
DTPTTR copies a triangular matrix from the standard packed format (TP) to the standard full format (T...
Definition dtpttr.f:104

◆ ddrvrf3()

subroutine ddrvrf3 ( integer nout,
integer nn,
integer, dimension( nn ) nval,
double precision thresh,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) arf,
double precision, dimension( lda, * ) b1,
double precision, dimension( lda, * ) b2,
double precision, dimension( * ) d_work_dlange,
double precision, dimension( * ) d_work_dgeqrf,
double precision, dimension( * ) tau )

DDRVRF3

Purpose:
!>
!> DDRVRF3 tests the LAPACK RFP routines:
!>     DTFSM
!>
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 DOUBLE PRECISION array, dimension (LDA,NMAX)
!>
[in]LDA
!>          LDA is INTEGER
!>                The leading dimension of the array A.  LDA >= max(1,NMAX).
!>
[out]ARF
!>          ARF is DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2).
!>
[out]B1
!>          B1 is DOUBLE PRECISION array, dimension (LDA,NMAX)
!>
[out]B2
!>          B2 is DOUBLE PRECISION array, dimension (LDA,NMAX)
!>
[out]D_WORK_DLANGE
!>          D_WORK_DLANGE is DOUBLE PRECISION array, dimension (NMAX)
!>
[out]D_WORK_DGEQRF
!>          D_WORK_DGEQRF is DOUBLE PRECISION array, dimension (NMAX)
!>
[out]TAU
!>          TAU is DOUBLE PRECISION array, dimension (NMAX)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 116 of file ddrvrf3.f.

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

◆ ddrvrf4()

subroutine ddrvrf4 ( integer nout,
integer nn,
integer, dimension( nn ) nval,
double precision thresh,
double precision, dimension( ldc, * ) c1,
double precision, dimension( ldc, *) c2,
integer ldc,
double precision, dimension( * ) crf,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) d_work_dlange )

DDRVRF4

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

Definition at line 116 of file ddrvrf4.f.

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

◆ ddrvrfp()

subroutine ddrvrfp ( integer nout,
integer nn,
integer, dimension( nn ) nval,
integer nns,
integer, dimension( nns ) nsval,
integer nnt,
integer, dimension( nnt ) ntval,
double precision thresh,
double precision, dimension( * ) a,
double precision, dimension( * ) asav,
double precision, dimension( * ) afac,
double precision, dimension( * ) ainv,
double precision, dimension( * ) b,
double precision, dimension( * ) bsav,
double precision, dimension( * ) xact,
double precision, dimension( * ) x,
double precision, dimension( * ) arf,
double precision, dimension( * ) arfinv,
double precision, dimension( * ) d_work_dlatms,
double precision, dimension( * ) d_work_dpot01,
double precision, dimension( * ) d_temp_dpot02,
double precision, dimension( * ) d_temp_dpot03,
double precision, dimension( * ) d_work_dlansy,
double precision, dimension( * ) d_work_dpot02,
double precision, dimension( * ) d_work_dpot03 )

DDRVRFP

Purpose:
!>
!> DDRVRFP tests the LAPACK RFP routines:
!>     DPFTRF, DPFTRS, and DPFTRI.
!>
!> This testing routine follow the same tests as DDRVPO (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 DTRTTF and
!> DTFTTR.
!>
!> 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 DPFTRF, 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 DPFTRF is called to compute L (or U), the
!> Cholesky factor of A. Then L (or U) is used to solve the linear system
!> of equations AX = B. This gives X. Then L (or U) is used to compute the
!> inverse of A, AINV. The following four tests are then performed:
!> (1) norm( L*L' - A ) / ( N * norm(A) * EPS ) or
!>     norm( U'*U - A ) / ( N * norm(A) * EPS ),
!> (2) norm(B - A*X) / ( norm(A) * norm(X) * EPS ),
!> (3) norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ),
!> (4) ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ),
!> where EPS is the machine precision, RCOND the condition number of A, and
!> norm( . ) the 1-norm for (1,2,3) and the inf-norm for (4).
!> Errors occur when INFO parameter is not as expected. Failures occur when
!> a test ratios is greater than THRES.
!>
Parameters
[in]NOUT
!>          NOUT is INTEGER
!>                The unit number for output.
!>
[in]NN
!>          NN is INTEGER
!>                The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>                The values of the matrix dimension N.
!>
[in]NNS
!>          NNS is INTEGER
!>                The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>                The values of the number of right-hand sides NRHS.
!>
[in]NNT
!>          NNT is INTEGER
!>                The number of values of MATRIX TYPE contained in the vector NTVAL.
!>
[in]NTVAL
!>          NTVAL is INTEGER array, dimension (NNT)
!>                The values of matrix type (between 0 and 9 for PO/PP/PF matrices).
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>                The threshold value for the test ratios.  A result is
!>                included in the output file if RESULT >= THRESH.  To have
!>                every test ratio printed, use THRESH = 0.
!>
[out]A
!>          A is DOUBLE PRECISION array, dimension (NMAX*NMAX)
!>
[out]ASAV
!>          ASAV is DOUBLE PRECISION array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is DOUBLE PRECISION array, dimension (NMAX*MAXRHS)
!>
[out]BSAV
!>          BSAV is DOUBLE PRECISION array, dimension (NMAX*MAXRHS)
!>
[out]XACT
!>          XACT is DOUBLE PRECISION array, dimension (NMAX*MAXRHS)
!>
[out]X
!>          X is DOUBLE PRECISION array, dimension (NMAX*MAXRHS)
!>
[out]ARF
!>          ARF is DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2)
!>
[out]ARFINV
!>          ARFINV is DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2)
!>
[out]D_WORK_DLATMS
!>          D_WORK_DLATMS is DOUBLE PRECISION array, dimension ( 3*NMAX )
!>
[out]D_WORK_DPOT01
!>          D_WORK_DPOT01 is DOUBLE PRECISION array, dimension ( NMAX )
!>
[out]D_TEMP_DPOT02
!>          D_TEMP_DPOT02 is DOUBLE PRECISION array, dimension ( NMAX*MAXRHS )
!>
[out]D_TEMP_DPOT03
!>          D_TEMP_DPOT03 is DOUBLE PRECISION array, dimension ( NMAX*NMAX )
!>
[out]D_WORK_DLANSY
!>          D_WORK_DLANSY is DOUBLE PRECISION array, dimension ( NMAX )
!>
[out]D_WORK_DPOT02
!>          D_WORK_DPOT02 is DOUBLE PRECISION array, dimension ( NMAX )
!>
[out]D_WORK_DPOT03
!>          D_WORK_DPOT03 is DOUBLE PRECISION array, dimension ( NMAX )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 232 of file ddrvrfp.f.

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

◆ ddrvsp()

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

DDRVSP

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

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

◆ ddrvsy()

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

DDRVSY

DDRVSYX

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

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

◆ ddrvsy_aa()

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

DDRVSY_AA

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

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

◆ ddrvsy_aa_2stage()

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

DDRVSY_AA_2STAGE

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

Definition at line 151 of file ddrvsy_aa_2stage.f.

155*
156* -- LAPACK test routine --
157* -- LAPACK is a software package provided by Univ. of Tennessee, --
158* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
159*
160* .. Scalar Arguments ..
161 LOGICAL TSTERR
162 INTEGER NMAX, NN, NOUT, NRHS
163 DOUBLE PRECISION THRESH
164* ..
165* .. Array Arguments ..
166 LOGICAL DOTYPE( * )
167 INTEGER IWORK( * ), NVAL( * )
168 DOUBLE PRECISION RWORK( * )
169 DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
170 $ WORK( * ), X( * ), XACT( * )
171* ..
172*
173* =====================================================================
174*
175* .. Parameters ..
176 DOUBLE PRECISION ONE, ZERO
177 parameter( one = 1.0d+0, zero = 0.0d+0 )
178 INTEGER NTYPES, NTESTS
179 parameter( ntypes = 10, ntests = 3 )
180 INTEGER NFACT
181 parameter( nfact = 2 )
182* ..
183* .. Local Scalars ..
184 LOGICAL ZEROT
185 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
186 CHARACTER*3 MATPATH, PATH
187 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
188 $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
189 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
190 DOUBLE PRECISION ANORM, CNDNUM
191* ..
192* .. Local Arrays ..
193 CHARACTER FACTS( NFACT ), UPLOS( 2 )
194 INTEGER ISEED( 4 ), ISEEDY( 4 )
195 DOUBLE PRECISION RESULT( NTESTS )
196* ..
197* .. External Functions ..
198 DOUBLE PRECISION DLANSY, SGET06
199 EXTERNAL dlansy, sget06
200* ..
201* .. External Subroutines ..
202 EXTERNAL aladhd, alaerh, alasvm, xlaenv, derrvx,
203 $ dget04, dlacpy, dlarhs, dlatb4, dlatms,
204 $ dsysv_aa_2stage, dpot02,
205 $ dsytrf_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 ) = 'Double precision'
230 path( 2: 3 ) = 'S2'
231*
232* Path to generate matrices
233*
234 matpath( 1: 1 ) = 'Double 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 derrvx( 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 DLATB4 for the matrix generator
288* based on the type of matrix to be generated.
289*
290 CALL dlatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
291 $ MODE, CNDNUM, DIST )
292*
293* Generate a matrix with DLATMS.
294*
295 srnamt = 'DLATMS'
296 CALL dlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
297 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA,
298 $ WORK, INFO )
299*
300* Check error code from DLATMS and handle error.
301*
302 IF( info.NE.0 ) THEN
303 CALL alaerh( path, 'DLATMS', 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 = 'DLARHS'
389 CALL dlarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
390 $ nrhs, a, lda, xact, lda, b, lda, iseed,
391 $ info )
392 xtype = 'C'
393*
394* --- Test DSYSV_AA_2STAGE ---
395*
396 IF( ifact.EQ.2 ) THEN
397 CALL dlacpy( uplo, n, n, a, lda, afac, lda )
398 CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
399*
400* Factor the matrix and solve the system using DSYSV_AA.
401*
402 srnamt = 'DSYSV_AA_2STAGE '
403 lwork = min(n*nb, 3*nmax*nmax)
404 CALL dsysv_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 DSYSV_AA .
430*
431 IF( info.NE.k ) THEN
432 CALL alaerh( path, 'DSYSV_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 dlacpy( 'Full', n, nrhs, b, lda, work, lda )
443 CALL dpot02( 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 )'DSYSV_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 DDRVSY_AA_2STAGE
486*
dsysv_aa_2stage
subroutine dsysv_aa_2stage(uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, work, lwork, info)
DSYSV_AA_2STAGE computes the solution to system of linear equations A * X = B for SY matrices
Definition dsysv_aa_2stage.f:188
sget06
real function sget06(rcond, rcondc)
SGET06
Definition sget06.f:55

◆ ddrvsy_rk()

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

DDRVSY_RK

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

Definition at line 153 of file ddrvsy_rk.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 LOGICAL TSTERR
163 INTEGER NMAX, NN, NOUT, NRHS
164 DOUBLE PRECISION THRESH
165* ..
166* .. Array Arguments ..
167 LOGICAL DOTYPE( * )
168 INTEGER IWORK( * ), NVAL( * )
169 DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
170 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
171* ..
172*
173* =====================================================================
174*
175* .. Parameters ..
176 DOUBLE PRECISION ONE, ZERO
177 parameter( one = 1.0d+0, zero = 0.0d+0 )
178 INTEGER NTYPES, NTESTS
179 parameter( ntypes = 10, ntests = 3 )
180 INTEGER NFACT
181 parameter( nfact = 2 )
182* ..
183* .. Local Scalars ..
184 LOGICAL ZEROT
185 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
186 CHARACTER*3 PATH, MATPATH
187 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
188 $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
189 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
190 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC
191* ..
192* .. Local Arrays ..
193 CHARACTER FACTS( NFACT ), UPLOS( 2 )
194 INTEGER ISEED( 4 ), ISEEDY( 4 )
195 DOUBLE PRECISION RESULT( NTESTS )
196* ..
197* .. External Functions ..
198 DOUBLE PRECISION DLANSY
199 EXTERNAL dlansy
200* ..
201* .. External Subroutines ..
202 EXTERNAL aladhd, alaerh, alasvm, derrvx, dget04, dlacpy,
203 $ dlarhs, dlatb4, dlatms, dpot02, dsysv_rk,
204 $ dsyt01_3, dsytrf_rk, dsytri_3, 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 ) = 'Double precision'
229 path( 2: 3 ) = 'SK'
230*
231* Path to generate matrices
232*
233 matpath( 1: 1 ) = 'Double precision'
234 matpath( 2: 3 ) = 'SY'
235*
236 nrun = 0
237 nfail = 0
238 nerrs = 0
239 DO 10 i = 1, 4
240 iseed( i ) = iseedy( i )
241 10 CONTINUE
242 lwork = max( 2*nmax, nmax*nrhs )
243*
244* Test the error exits
245*
246 IF( tsterr )
247 $ CALL derrvx( 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 DLATB4 for the matrix generator
289* based on the type of matrix to be generated.
290*
291 CALL dlatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
292 $ MODE, CNDNUM, DIST )
293*
294* Generate a matrix with DLATMS.
295*
296 srnamt = 'DLATMS'
297 CALL dlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
298 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
299 $ INFO )
300*
301* Check error code from DLATMS and handle error.
302*
303 IF( info.NE.0 ) THEN
304 CALL alaerh( path, 'DLATMS', info, 0, uplo, n, n, -1,
305 $ -1, -1, imat, nfail, nerrs, nout )
306*
307* Skip all tests for this generated matrix
308*
309 GO TO 160
310 END IF
311*
312* For types 3-6, zero one or more rows and columns of the
313* matrix to test that INFO is returned correctly.
314*
315 IF( zerot ) THEN
316 IF( imat.EQ.3 ) THEN
317 izero = 1
318 ELSE IF( imat.EQ.4 ) THEN
319 izero = n
320 ELSE
321 izero = n / 2 + 1
322 END IF
323*
324 IF( imat.LT.6 ) THEN
325*
326* Set row and column IZERO to zero.
327*
328 IF( iuplo.EQ.1 ) THEN
329 ioff = ( izero-1 )*lda
330 DO 20 i = 1, izero - 1
331 a( ioff+i ) = zero
332 20 CONTINUE
333 ioff = ioff + izero
334 DO 30 i = izero, n
335 a( ioff ) = zero
336 ioff = ioff + lda
337 30 CONTINUE
338 ELSE
339 ioff = izero
340 DO 40 i = 1, izero - 1
341 a( ioff ) = zero
342 ioff = ioff + lda
343 40 CONTINUE
344 ioff = ioff - izero
345 DO 50 i = izero, n
346 a( ioff+i ) = zero
347 50 CONTINUE
348 END IF
349 ELSE
350 ioff = 0
351 IF( iuplo.EQ.1 ) THEN
352*
353* Set the first IZERO rows and columns to zero.
354*
355 DO 70 j = 1, n
356 i2 = min( j, izero )
357 DO 60 i = 1, i2
358 a( ioff+i ) = zero
359 60 CONTINUE
360 ioff = ioff + lda
361 70 CONTINUE
362 ELSE
363*
364* Set the last IZERO rows and columns to zero.
365*
366 DO 90 j = 1, n
367 i1 = max( j, izero )
368 DO 80 i = i1, n
369 a( ioff+i ) = zero
370 80 CONTINUE
371 ioff = ioff + lda
372 90 CONTINUE
373 END IF
374 END IF
375 ELSE
376 izero = 0
377 END IF
378*
379* End generate the test matrix A.
380*
381 DO 150 ifact = 1, nfact
382*
383* Do first for FACT = 'F', then for other values.
384*
385 fact = facts( ifact )
386*
387* Compute the condition number
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 = dlansy( '1', uplo, n, a, lda, rwork )
399*
400* Factor the matrix A.
401*
402 CALL dlacpy( uplo, n, n, a, lda, afac, lda )
403 CALL dsytrf_rk( uplo, n, afac, lda, e, iwork, work,
404 $ lwork, info )
405*
406* Compute inv(A) and take its norm.
407*
408 CALL dlacpy( uplo, n, n, afac, lda, ainv, lda )
409 lwork = (n+nb+1)*(nb+3)
410*
411* We need to compute the inverse to compute
412* RCONDC that is used later in TEST3.
413*
414 CALL dsytri_3( uplo, n, ainv, lda, e, iwork,
415 $ work, lwork, info )
416 ainvnm = dlansy( '1', uplo, n, ainv, lda, rwork )
417*
418* Compute the 1-norm condition number of A.
419*
420 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
421 rcondc = one
422 ELSE
423 rcondc = ( one / anorm ) / ainvnm
424 END IF
425 END IF
426*
427* Form an exact solution and set the right hand side.
428*
429 srnamt = 'DLARHS'
430 CALL dlarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
431 $ nrhs, a, lda, xact, lda, b, lda, iseed,
432 $ info )
433 xtype = 'C'
434*
435* --- Test DSYSV_RK ---
436*
437 IF( ifact.EQ.2 ) THEN
438 CALL dlacpy( uplo, n, n, a, lda, afac, lda )
439 CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
440*
441* Factor the matrix and solve the system using
442* DSYSV_RK.
443*
444 srnamt = 'DSYSV_RK'
445 CALL dsysv_rk( uplo, n, nrhs, afac, lda, e, iwork,
446 $ x, lda, work, lwork, info )
447*
448* Adjust the expected value of INFO to account for
449* pivoting.
450*
451 k = izero
452 IF( k.GT.0 ) THEN
453 100 CONTINUE
454 IF( iwork( k ).LT.0 ) THEN
455 IF( iwork( k ).NE.-k ) THEN
456 k = -iwork( k )
457 GO TO 100
458 END IF
459 ELSE IF( iwork( k ).NE.k ) THEN
460 k = iwork( k )
461 GO TO 100
462 END IF
463 END IF
464*
465* Check error code from DSYSV_RK and handle error.
466*
467 IF( info.NE.k ) THEN
468 CALL alaerh( path, 'DSYSV_RK', info, k, uplo,
469 $ n, n, -1, -1, nrhs, imat, nfail,
470 $ nerrs, nout )
471 GO TO 120
472 ELSE IF( info.NE.0 ) THEN
473 GO TO 120
474 END IF
475*
476*+ TEST 1 Reconstruct matrix from factors and compute
477* residual.
478*
479 CALL dsyt01_3( uplo, n, a, lda, afac, lda, e,
480 $ iwork, ainv, lda, rwork,
481 $ result( 1 ) )
482*
483*+ TEST 2 Compute residual of the computed solution.
484*
485 CALL dlacpy( 'Full', n, nrhs, b, lda, work, lda )
486 CALL dpot02( uplo, n, nrhs, a, lda, x, lda, work,
487 $ lda, rwork, result( 2 ) )
488*
489*+ TEST 3
490* Check solution from generated exact solution.
491*
492 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
493 $ result( 3 ) )
494 nt = 3
495*
496* Print information about the tests that did not pass
497* the threshold.
498*
499 DO 110 k = 1, nt
500 IF( result( k ).GE.thresh ) THEN
501 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
502 $ CALL aladhd( nout, path )
503 WRITE( nout, fmt = 9999 )'DSYSV_RK', uplo,
504 $ n, imat, k, result( k )
505 nfail = nfail + 1
506 END IF
507 110 CONTINUE
508 nrun = nrun + nt
509 120 CONTINUE
510 END IF
511*
512 150 CONTINUE
513*
514 160 CONTINUE
515 170 CONTINUE
516 180 CONTINUE
517*
518* Print a summary of the results.
519*
520 CALL alasvm( path, nout, nfail, nrun, nerrs )
521*
522 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
523 $ ', test ', i2, ', ratio =', g12.5 )
524 RETURN
525*
526* End of DDRVSY_RK
527*
dsysv_rk
subroutine dsysv_rk(uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work, lwork, info)
DSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices
Definition dsysv_rk.f:228

◆ ddrvsy_rook()

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

DDRVSY_ROOK

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

Definition at line 149 of file ddrvsy_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 DOUBLE PRECISION THRESH
161* ..
162* .. Array Arguments ..
163 LOGICAL DOTYPE( * )
164 INTEGER IWORK( * ), NVAL( * )
165 DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
166 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
167* ..
168*
169* =====================================================================
170*
171* .. Parameters ..
172 DOUBLE PRECISION ONE, ZERO
173 parameter( one = 1.0d+0, zero = 0.0d+0 )
174 INTEGER NTYPES, NTESTS
175 parameter( ntypes = 10, ntests = 3 )
176 INTEGER NFACT
177 parameter( nfact = 2 )
178* ..
179* .. Local Scalars ..
180 LOGICAL ZEROT
181 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
182 CHARACTER*3 PATH, MATPATH
183 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
184 $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N,
185 $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT
186 DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC
187* ..
188* .. Local Arrays ..
189 CHARACTER FACTS( NFACT ), UPLOS( 2 )
190 INTEGER ISEED( 4 ), ISEEDY( 4 )
191 DOUBLE PRECISION RESULT( NTESTS )
192* ..
193* .. External Functions ..
194 DOUBLE PRECISION DLANSY
195 EXTERNAL dlansy
196* ..
197* .. External Subroutines ..
198 EXTERNAL aladhd, alaerh, alasvm, derrvx, dget04, dlacpy,
199 $ dlarhs, dlaset, dlatb4, dlatms, dpot02, dpot05,
200 $ dsysv_rook, dsyt01_rook, dsytrf_rook,
201 $ dsytri_rook,
202 $ xlaenv
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* .. Intrinsic Functions ..
214 INTRINSIC max, min
215* ..
216* .. Data statements ..
217 DATA iseedy / 1988, 1989, 1990, 1991 /
218 DATA uplos / 'U', 'L' / , facts / 'F', 'N' /
219* ..
220* .. Executable Statements ..
221*
222* Initialize constants and the random number seed.
223*
224* Test path
225*
226 path( 1: 1 ) = 'Double precision'
227 path( 2: 3 ) = 'SR'
228*
229* Path to generate matrices
230*
231 matpath( 1: 1 ) = 'Double precision'
232 matpath( 2: 3 ) = 'SY'
233*
234 nrun = 0
235 nfail = 0
236 nerrs = 0
237 DO 10 i = 1, 4
238 iseed( i ) = iseedy( i )
239 10 CONTINUE
240 lwork = max( 2*nmax, nmax*nrhs )
241*
242* Test the error exits
243*
244 IF( tsterr )
245 $ CALL derrvx( path, nout )
246 infot = 0
247*
248* Set the block size and minimum block size for which the block
249* routine should be used, which will be later returned by ILAENV.
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 lda = max( n, 1 )
261 xtype = 'N'
262 nimat = ntypes
263 IF( n.LE.0 )
264 $ nimat = 1
265*
266 DO 170 imat = 1, nimat
267*
268* Do the tests only if DOTYPE( IMAT ) is true.
269*
270 IF( .NOT.dotype( imat ) )
271 $ GO TO 170
272*
273* Skip types 3, 4, 5, or 6 if the matrix size is too small.
274*
275 zerot = imat.GE.3 .AND. imat.LE.6
276 IF( zerot .AND. n.LT.imat-2 )
277 $ GO TO 170
278*
279* Do first for UPLO = 'U', then for UPLO = 'L'
280*
281 DO 160 iuplo = 1, 2
282 uplo = uplos( iuplo )
283*
284* Begin generate the test matrix A.
285*
286* Set up parameters with DLATB4 for the matrix generator
287* based on the type of matrix to be generated.
288*
289 CALL dlatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
290 $ MODE, CNDNUM, DIST )
291*
292* Generate a matrix with DLATMS.
293*
294 srnamt = 'DLATMS'
295 CALL dlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
296 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
297 $ INFO )
298*
299* Check error code from DLATMS and handle error.
300*
301 IF( info.NE.0 ) THEN
302 CALL alaerh( path, 'DLATMS', info, 0, uplo, n, n, -1,
303 $ -1, -1, imat, nfail, nerrs, nout )
304*
305* Skip all tests for this generated matrix
306*
307 GO TO 160
308 END IF
309*
310* For types 3-6, zero one or more rows and columns of the
311* 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 ioff = 0
349 IF( iuplo.EQ.1 ) THEN
350*
351* Set the first IZERO rows and columns to zero.
352*
353 DO 70 j = 1, n
354 i2 = min( j, izero )
355 DO 60 i = 1, i2
356 a( ioff+i ) = zero
357 60 CONTINUE
358 ioff = ioff + lda
359 70 CONTINUE
360 ELSE
361*
362* Set the last IZERO rows and columns to zero.
363*
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 DO 150 ifact = 1, nfact
380*
381* Do first for FACT = 'F', then for other values.
382*
383 fact = facts( ifact )
384*
385* Compute the condition number for comparison with
386* the value returned by DSYSVX_ROOK.
387*
388 IF( zerot ) THEN
389 IF( ifact.EQ.1 )
390 $ GO TO 150
391 rcondc = zero
392*
393 ELSE IF( ifact.EQ.1 ) THEN
394*
395* Compute the 1-norm of A.
396*
397 anorm = dlansy( '1', uplo, n, a, lda, rwork )
398*
399* Factor the matrix A.
400*
401 CALL dlacpy( uplo, n, n, a, lda, afac, lda )
402 CALL dsytrf_rook( uplo, n, afac, lda, iwork, work,
403 $ lwork, info )
404*
405* Compute inv(A) and take its norm.
406*
407 CALL dlacpy( uplo, n, n, afac, lda, ainv, lda )
408 lwork = (n+nb+1)*(nb+3)
409 CALL dsytri_rook( uplo, n, ainv, lda, iwork,
410 $ work, info )
411 ainvnm = dlansy( '1', uplo, n, ainv, lda, 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 = 'DLARHS'
425 CALL dlarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
426 $ nrhs, a, lda, xact, lda, b, lda, iseed,
427 $ info )
428 xtype = 'C'
429*
430* --- Test DSYSV_ROOK ---
431*
432 IF( ifact.EQ.2 ) THEN
433 CALL dlacpy( uplo, n, n, a, lda, afac, lda )
434 CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
435*
436* Factor the matrix and solve the system using
437* DSYSV_ROOK.
438*
439 srnamt = 'DSYSV_ROOK'
440 CALL dsysv_rook( uplo, n, nrhs, afac, lda, iwork,
441 $ x, lda, work, lwork, info )
442*
443* Adjust the expected value of INFO to account for
444* pivoting.
445*
446 k = izero
447 IF( k.GT.0 ) THEN
448 100 CONTINUE
449 IF( iwork( k ).LT.0 ) THEN
450 IF( iwork( k ).NE.-k ) THEN
451 k = -iwork( k )
452 GO TO 100
453 END IF
454 ELSE IF( iwork( k ).NE.k ) THEN
455 k = iwork( k )
456 GO TO 100
457 END IF
458 END IF
459*
460* Check error code from DSYSV_ROOK and handle error.
461*
462 IF( info.NE.k ) THEN
463 CALL alaerh( path, 'DSYSV_ROOK', info, k, uplo,
464 $ n, n, -1, -1, nrhs, imat, nfail,
465 $ nerrs, nout )
466 GO TO 120
467 ELSE IF( info.NE.0 ) THEN
468 GO TO 120
469 END IF
470*
471*+ TEST 1 Reconstruct matrix from factors and compute
472* residual.
473*
474 CALL dsyt01_rook( uplo, n, a, lda, afac, lda,
475 $ iwork, ainv, lda, rwork,
476 $ result( 1 ) )
477*
478*+ TEST 2 Compute residual of the computed solution.
479*
480 CALL dlacpy( 'Full', n, nrhs, b, lda, work, lda )
481 CALL dpot02( uplo, n, nrhs, a, lda, x, lda, work,
482 $ lda, rwork, result( 2 ) )
483*
484*+ TEST 3
485* Check solution from generated exact solution.
486*
487 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
488 $ result( 3 ) )
489 nt = 3
490*
491* Print information about the tests that did not pass
492* the threshold.
493*
494 DO 110 k = 1, nt
495 IF( result( k ).GE.thresh ) THEN
496 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
497 $ CALL aladhd( nout, path )
498 WRITE( nout, fmt = 9999 )'DSYSV_ROOK', uplo,
499 $ n, imat, k, result( k )
500 nfail = nfail + 1
501 END IF
502 110 CONTINUE
503 nrun = nrun + nt
504 120 CONTINUE
505 END IF
506*
507 150 CONTINUE
508*
509 160 CONTINUE
510 170 CONTINUE
511 180 CONTINUE
512*
513* Print a summary of the results.
514*
515 CALL alasvm( path, nout, nfail, nrun, nerrs )
516*
517 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i2,
518 $ ', test ', i2, ', ratio =', g12.5 )
519 RETURN
520*
521* End of DDRVSY_ROOK
522*
dsysv_rook
subroutine dsysv_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
DSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices
Definition dsysv_rook.f:204

◆ debchvxx()

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

DEBCHVXX

Purpose:
!>
!>  DEBCHVXX will run D**SVXX on a series of Hilbert matrices and then
!>  compare the error bounds returned by D**SVXX to see if the returned
!>  answer indeed falls within those bounds.
!>
!>  Eight test ratios will be computed.  The tests will pass if they are .LT.
!>  THRESH.  There are two cases that are determined by 1 / (SQRT( N ) * EPS).
!>  If that value is .LE. to the component wise reciprocal condition number,
!>  it uses the guaranteed case, other wise it uses the unguaranteed case.
!>
!>  Test ratios:
!>     Let Xc be X_computed and Xt be X_truth.
!>     The norm used is the infinity norm.
!>
!>     Let A be the guaranteed case and B be the unguaranteed case.
!>
!>       1. Normwise guaranteed forward error bound.
!>       A: norm ( abs( Xc - Xt ) / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ) and
!>          ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N),10) * EPS.
!>          If these conditions are met, the test ratio is set to be
!>          ERRBND( *, nwise_i, bnd_i ) / MAX(SQRT(N), 10).  Otherwise it is 1/EPS.
!>       B: For this case, CGESVXX should just return 1.  If it is less than
!>          one, treat it the same as in 1A.  Otherwise it fails. (Set test
!>          ratio to ERRBND( *, nwise_i, bnd_i ) * THRESH?)
!>
!>       2. Componentwise guaranteed forward error bound.
!>       A: norm ( abs( Xc(j) - Xt(j) ) ) / norm (Xt(j)) .LE. ERRBND( *, cwise_i, bnd_i )
!>          for all j .AND. ERRBND( *, cwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS.
!>          If these conditions are met, the test ratio is set to be
!>          ERRBND( *, cwise_i, bnd_i ) / MAX(SQRT(N), 10).  Otherwise it is 1/EPS.
!>       B: Same as normwise test ratio.
!>
!>       3. Backwards error.
!>       A: The test ratio is set to BERR/EPS.
!>       B: Same test ratio.
!>
!>       4. Reciprocal condition number.
!>       A: A condition number is computed with Xt and compared with the one
!>          returned from CGESVXX.  Let RCONDc be the RCOND returned by D**SVXX
!>          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 debchvxx.f.

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

◆ derrab()

subroutine derrab ( integer nunit)

DERRAB

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

Definition at line 46 of file derrab.f.

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

◆ derrac()

subroutine derrac ( integer nunit)

DERRAC

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

Definition at line 46 of file derrac.f.

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

◆ derrge()

subroutine derrge ( character*3 path,
integer nunit )

DERRGE

DERRGEX

Purpose:
!>
!> DERRGE tests the error exits for the DOUBLE PRECISION 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:
!>
!> DERRGE tests the error exits for the DOUBLE PRECISION routines
!> for general matrices.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise derrge.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 derrge.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, LW
69 parameter( nmax = 4, lw = 3*nmax )
70* ..
71* .. Local Scalars ..
72 CHARACTER*2 C2
73 INTEGER I, INFO, J
74 DOUBLE PRECISION ANRM, CCOND, RCOND
75* ..
76* .. Local Arrays ..
77 INTEGER IP( NMAX ), IW( NMAX )
78 DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
79 $ R1( NMAX ), R2( NMAX ), W( LW ), X( NMAX )
80* ..
81* .. External Functions ..
82 LOGICAL LSAMEN
83 EXTERNAL lsamen
84* ..
85* .. External Subroutines ..
86 EXTERNAL alaesm, chkxer, dgbcon, dgbequ, dgbrfs, dgbtf2,
87 $ dgbtrf, dgbtrs, dgecon, dgeequ, dgerfs, dgetf2,
88 $ dgetrf, dgetri, dgetrs
89* ..
90* .. Scalars in Common ..
91 LOGICAL LERR, OK
92 CHARACTER*32 SRNAMT
93 INTEGER INFOT, NOUT
94* ..
95* .. Common blocks ..
96 COMMON / infoc / infot, nout, ok, lerr
97 COMMON / srnamc / srnamt
98* ..
99* .. Intrinsic Functions ..
100 INTRINSIC dble
101* ..
102* .. Executable Statements ..
103*
104 nout = nunit
105 WRITE( nout, fmt = * )
106 c2 = path( 2: 3 )
107*
108* Set the variables to innocuous values.
109*
110 DO 20 j = 1, nmax
111 DO 10 i = 1, nmax
112 a( i, j ) = 1.d0 / dble( i+j )
113 af( i, j ) = 1.d0 / dble( i+j )
114 10 CONTINUE
115 b( j ) = 0.d0
116 r1( j ) = 0.d0
117 r2( j ) = 0.d0
118 w( j ) = 0.d0
119 x( j ) = 0.d0
120 ip( j ) = j
121 iw( j ) = j
122 20 CONTINUE
123 ok = .true.
124*
125 IF( lsamen( 2, c2, 'GE' ) ) THEN
126*
127* Test error exits of the routines that use the LU decomposition
128* of a general matrix.
129*
130* DGETRF
131*
132 srnamt = 'DGETRF'
133 infot = 1
134 CALL dgetrf( -1, 0, a, 1, ip, info )
135 CALL chkxer( 'DGETRF', infot, nout, lerr, ok )
136 infot = 2
137 CALL dgetrf( 0, -1, a, 1, ip, info )
138 CALL chkxer( 'DGETRF', infot, nout, lerr, ok )
139 infot = 4
140 CALL dgetrf( 2, 1, a, 1, ip, info )
141 CALL chkxer( 'DGETRF', infot, nout, lerr, ok )
142*
143* DGETF2
144*
145 srnamt = 'DGETF2'
146 infot = 1
147 CALL dgetf2( -1, 0, a, 1, ip, info )
148 CALL chkxer( 'DGETF2', infot, nout, lerr, ok )
149 infot = 2
150 CALL dgetf2( 0, -1, a, 1, ip, info )
151 CALL chkxer( 'DGETF2', infot, nout, lerr, ok )
152 infot = 4
153 CALL dgetf2( 2, 1, a, 1, ip, info )
154 CALL chkxer( 'DGETF2', infot, nout, lerr, ok )
155*
156* DGETRI
157*
158 srnamt = 'DGETRI'
159 infot = 1
160 CALL dgetri( -1, a, 1, ip, w, lw, info )
161 CALL chkxer( 'DGETRI', infot, nout, lerr, ok )
162 infot = 3
163 CALL dgetri( 2, a, 1, ip, w, lw, info )
164 CALL chkxer( 'DGETRI', infot, nout, lerr, ok )
165*
166* DGETRS
167*
168 srnamt = 'DGETRS'
169 infot = 1
170 CALL dgetrs( '/', 0, 0, a, 1, ip, b, 1, info )
171 CALL chkxer( 'DGETRS', infot, nout, lerr, ok )
172 infot = 2
173 CALL dgetrs( 'N', -1, 0, a, 1, ip, b, 1, info )
174 CALL chkxer( 'DGETRS', infot, nout, lerr, ok )
175 infot = 3
176 CALL dgetrs( 'N', 0, -1, a, 1, ip, b, 1, info )
177 CALL chkxer( 'DGETRS', infot, nout, lerr, ok )
178 infot = 5
179 CALL dgetrs( 'N', 2, 1, a, 1, ip, b, 2, info )
180 CALL chkxer( 'DGETRS', infot, nout, lerr, ok )
181 infot = 8
182 CALL dgetrs( 'N', 2, 1, a, 2, ip, b, 1, info )
183 CALL chkxer( 'DGETRS', infot, nout, lerr, ok )
184*
185* DGERFS
186*
187 srnamt = 'DGERFS'
188 infot = 1
189 CALL dgerfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
190 $ iw, info )
191 CALL chkxer( 'DGERFS', infot, nout, lerr, ok )
192 infot = 2
193 CALL dgerfs( 'N', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
194 $ w, iw, info )
195 CALL chkxer( 'DGERFS', infot, nout, lerr, ok )
196 infot = 3
197 CALL dgerfs( 'N', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
198 $ w, iw, info )
199 CALL chkxer( 'DGERFS', infot, nout, lerr, ok )
200 infot = 5
201 CALL dgerfs( 'N', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
202 $ iw, info )
203 CALL chkxer( 'DGERFS', infot, nout, lerr, ok )
204 infot = 7
205 CALL dgerfs( 'N', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
206 $ iw, info )
207 CALL chkxer( 'DGERFS', infot, nout, lerr, ok )
208 infot = 10
209 CALL dgerfs( 'N', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
210 $ iw, info )
211 CALL chkxer( 'DGERFS', infot, nout, lerr, ok )
212 infot = 12
213 CALL dgerfs( 'N', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
214 $ iw, info )
215 CALL chkxer( 'DGERFS', infot, nout, lerr, ok )
216*
217* DGECON
218*
219 srnamt = 'DGECON'
220 infot = 1
221 CALL dgecon( '/', 0, a, 1, anrm, rcond, w, iw, info )
222 CALL chkxer( 'DGECON', infot, nout, lerr, ok )
223 infot = 2
224 CALL dgecon( '1', -1, a, 1, anrm, rcond, w, iw, info )
225 CALL chkxer( 'DGECON', infot, nout, lerr, ok )
226 infot = 4
227 CALL dgecon( '1', 2, a, 1, anrm, rcond, w, iw, info )
228 CALL chkxer( 'DGECON', infot, nout, lerr, ok )
229*
230* DGEEQU
231*
232 srnamt = 'DGEEQU'
233 infot = 1
234 CALL dgeequ( -1, 0, a, 1, r1, r2, rcond, ccond, anrm, info )
235 CALL chkxer( 'DGEEQU', infot, nout, lerr, ok )
236 infot = 2
237 CALL dgeequ( 0, -1, a, 1, r1, r2, rcond, ccond, anrm, info )
238 CALL chkxer( 'DGEEQU', infot, nout, lerr, ok )
239 infot = 4
240 CALL dgeequ( 2, 2, a, 1, r1, r2, rcond, ccond, anrm, info )
241 CALL chkxer( 'DGEEQU', infot, nout, lerr, ok )
242*
243 ELSE IF( lsamen( 2, c2, 'GB' ) ) THEN
244*
245* Test error exits of the routines that use the LU decomposition
246* of a general band matrix.
247*
248* DGBTRF
249*
250 srnamt = 'DGBTRF'
251 infot = 1
252 CALL dgbtrf( -1, 0, 0, 0, a, 1, ip, info )
253 CALL chkxer( 'DGBTRF', infot, nout, lerr, ok )
254 infot = 2
255 CALL dgbtrf( 0, -1, 0, 0, a, 1, ip, info )
256 CALL chkxer( 'DGBTRF', infot, nout, lerr, ok )
257 infot = 3
258 CALL dgbtrf( 1, 1, -1, 0, a, 1, ip, info )
259 CALL chkxer( 'DGBTRF', infot, nout, lerr, ok )
260 infot = 4
261 CALL dgbtrf( 1, 1, 0, -1, a, 1, ip, info )
262 CALL chkxer( 'DGBTRF', infot, nout, lerr, ok )
263 infot = 6
264 CALL dgbtrf( 2, 2, 1, 1, a, 3, ip, info )
265 CALL chkxer( 'DGBTRF', infot, nout, lerr, ok )
266*
267* DGBTF2
268*
269 srnamt = 'DGBTF2'
270 infot = 1
271 CALL dgbtf2( -1, 0, 0, 0, a, 1, ip, info )
272 CALL chkxer( 'DGBTF2', infot, nout, lerr, ok )
273 infot = 2
274 CALL dgbtf2( 0, -1, 0, 0, a, 1, ip, info )
275 CALL chkxer( 'DGBTF2', infot, nout, lerr, ok )
276 infot = 3
277 CALL dgbtf2( 1, 1, -1, 0, a, 1, ip, info )
278 CALL chkxer( 'DGBTF2', infot, nout, lerr, ok )
279 infot = 4
280 CALL dgbtf2( 1, 1, 0, -1, a, 1, ip, info )
281 CALL chkxer( 'DGBTF2', infot, nout, lerr, ok )
282 infot = 6
283 CALL dgbtf2( 2, 2, 1, 1, a, 3, ip, info )
284 CALL chkxer( 'DGBTF2', infot, nout, lerr, ok )
285*
286* DGBTRS
287*
288 srnamt = 'DGBTRS'
289 infot = 1
290 CALL dgbtrs( '/', 0, 0, 0, 1, a, 1, ip, b, 1, info )
291 CALL chkxer( 'DGBTRS', infot, nout, lerr, ok )
292 infot = 2
293 CALL dgbtrs( 'N', -1, 0, 0, 1, a, 1, ip, b, 1, info )
294 CALL chkxer( 'DGBTRS', infot, nout, lerr, ok )
295 infot = 3
296 CALL dgbtrs( 'N', 1, -1, 0, 1, a, 1, ip, b, 1, info )
297 CALL chkxer( 'DGBTRS', infot, nout, lerr, ok )
298 infot = 4
299 CALL dgbtrs( 'N', 1, 0, -1, 1, a, 1, ip, b, 1, info )
300 CALL chkxer( 'DGBTRS', infot, nout, lerr, ok )
301 infot = 5
302 CALL dgbtrs( 'N', 1, 0, 0, -1, a, 1, ip, b, 1, info )
303 CALL chkxer( 'DGBTRS', infot, nout, lerr, ok )
304 infot = 7
305 CALL dgbtrs( 'N', 2, 1, 1, 1, a, 3, ip, b, 2, info )
306 CALL chkxer( 'DGBTRS', infot, nout, lerr, ok )
307 infot = 10
308 CALL dgbtrs( 'N', 2, 0, 0, 1, a, 1, ip, b, 1, info )
309 CALL chkxer( 'DGBTRS', infot, nout, lerr, ok )
310*
311* DGBRFS
312*
313 srnamt = 'DGBRFS'
314 infot = 1
315 CALL dgbrfs( '/', 0, 0, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
316 $ r2, w, iw, info )
317 CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
318 infot = 2
319 CALL dgbrfs( 'N', -1, 0, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
320 $ r2, w, iw, info )
321 CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
322 infot = 3
323 CALL dgbrfs( 'N', 1, -1, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
324 $ r2, w, iw, info )
325 CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
326 infot = 4
327 CALL dgbrfs( 'N', 1, 0, -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
328 $ r2, w, iw, info )
329 CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
330 infot = 5
331 CALL dgbrfs( 'N', 1, 0, 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1,
332 $ r2, w, iw, info )
333 CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
334 infot = 7
335 CALL dgbrfs( 'N', 2, 1, 1, 1, a, 2, af, 4, ip, b, 2, x, 2, r1,
336 $ r2, w, iw, info )
337 CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
338 infot = 9
339 CALL dgbrfs( 'N', 2, 1, 1, 1, a, 3, af, 3, ip, b, 2, x, 2, r1,
340 $ r2, w, iw, info )
341 CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
342 infot = 12
343 CALL dgbrfs( 'N', 2, 0, 0, 1, a, 1, af, 1, ip, b, 1, x, 2, r1,
344 $ r2, w, iw, info )
345 CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
346 infot = 14
347 CALL dgbrfs( 'N', 2, 0, 0, 1, a, 1, af, 1, ip, b, 2, x, 1, r1,
348 $ r2, w, iw, info )
349 CALL chkxer( 'DGBRFS', infot, nout, lerr, ok )
350*
351* DGBCON
352*
353 srnamt = 'DGBCON'
354 infot = 1
355 CALL dgbcon( '/', 0, 0, 0, a, 1, ip, anrm, rcond, w, iw, info )
356 CALL chkxer( 'DGBCON', infot, nout, lerr, ok )
357 infot = 2
358 CALL dgbcon( '1', -1, 0, 0, a, 1, ip, anrm, rcond, w, iw,
359 $ info )
360 CALL chkxer( 'DGBCON', infot, nout, lerr, ok )
361 infot = 3
362 CALL dgbcon( '1', 1, -1, 0, a, 1, ip, anrm, rcond, w, iw,
363 $ info )
364 CALL chkxer( 'DGBCON', infot, nout, lerr, ok )
365 infot = 4
366 CALL dgbcon( '1', 1, 0, -1, a, 1, ip, anrm, rcond, w, iw,
367 $ info )
368 CALL chkxer( 'DGBCON', infot, nout, lerr, ok )
369 infot = 6
370 CALL dgbcon( '1', 2, 1, 1, a, 3, ip, anrm, rcond, w, iw, info )
371 CALL chkxer( 'DGBCON', infot, nout, lerr, ok )
372*
373* DGBEQU
374*
375 srnamt = 'DGBEQU'
376 infot = 1
377 CALL dgbequ( -1, 0, 0, 0, a, 1, r1, r2, rcond, ccond, anrm,
378 $ info )
379 CALL chkxer( 'DGBEQU', infot, nout, lerr, ok )
380 infot = 2
381 CALL dgbequ( 0, -1, 0, 0, a, 1, r1, r2, rcond, ccond, anrm,
382 $ info )
383 CALL chkxer( 'DGBEQU', infot, nout, lerr, ok )
384 infot = 3
385 CALL dgbequ( 1, 1, -1, 0, a, 1, r1, r2, rcond, ccond, anrm,
386 $ info )
387 CALL chkxer( 'DGBEQU', infot, nout, lerr, ok )
388 infot = 4
389 CALL dgbequ( 1, 1, 0, -1, a, 1, r1, r2, rcond, ccond, anrm,
390 $ info )
391 CALL chkxer( 'DGBEQU', infot, nout, lerr, ok )
392 infot = 6
393 CALL dgbequ( 2, 2, 1, 1, a, 2, r1, r2, rcond, ccond, anrm,
394 $ info )
395 CALL chkxer( 'DGBEQU', 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 DERRGE
405*
dgbtf2
subroutine dgbtf2(m, n, kl, ku, ab, ldab, ipiv, info)
DGBTF2 computes the LU factorization of a general band matrix using the unblocked version of the algo...
Definition dgbtf2.f:145
dgetf2
subroutine dgetf2(m, n, a, lda, ipiv, info)
DGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row inter...
Definition dgetf2.f:108

◆ derrgt()

subroutine derrgt ( character*3 path,
integer nunit )

DERRGT

Purpose:
!>
!> DERRGT tests the error exits for the DOUBLE PRECISION 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 derrgt.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
74 DOUBLE PRECISION ANORM, RCOND
75* ..
76* .. Local Arrays ..
77 INTEGER IP( NMAX ), IW( NMAX )
78 DOUBLE PRECISION B( NMAX ), C( NMAX ), CF( NMAX ), D( NMAX ),
79 $ DF( NMAX ), E( NMAX ), EF( NMAX ), F( NMAX ),
80 $ R1( NMAX ), R2( NMAX ), W( NMAX ), X( NMAX )
81* ..
82* .. External Functions ..
83 LOGICAL LSAMEN
84 EXTERNAL lsamen
85* ..
86* .. External Subroutines ..
87 EXTERNAL alaesm, chkxer, dgtcon, dgtrfs, dgttrf, dgttrs,
88 $ dptcon, dptrfs, dpttrf, dpttrs
89* ..
90* .. Scalars in Common ..
91 LOGICAL LERR, OK
92 CHARACTER*32 SRNAMT
93 INTEGER INFOT, NOUT
94* ..
95* .. Common blocks ..
96 COMMON / infoc / infot, nout, ok, lerr
97 COMMON / srnamc / srnamt
98* ..
99* .. Executable Statements ..
100*
101 nout = nunit
102 WRITE( nout, fmt = * )
103 c2 = path( 2: 3 )
104 d( 1 ) = 1.d0
105 d( 2 ) = 2.d0
106 df( 1 ) = 1.d0
107 df( 2 ) = 2.d0
108 e( 1 ) = 3.d0
109 e( 2 ) = 4.d0
110 ef( 1 ) = 3.d0
111 ef( 2 ) = 4.d0
112 anorm = 1.0d0
113 ok = .true.
114*
115 IF( lsamen( 2, c2, 'GT' ) ) THEN
116*
117* Test error exits for the general tridiagonal routines.
118*
119* DGTTRF
120*
121 srnamt = 'DGTTRF'
122 infot = 1
123 CALL dgttrf( -1, c, d, e, f, ip, info )
124 CALL chkxer( 'DGTTRF', infot, nout, lerr, ok )
125*
126* DGTTRS
127*
128 srnamt = 'DGTTRS'
129 infot = 1
130 CALL dgttrs( '/', 0, 0, c, d, e, f, ip, x, 1, info )
131 CALL chkxer( 'DGTTRS', infot, nout, lerr, ok )
132 infot = 2
133 CALL dgttrs( 'N', -1, 0, c, d, e, f, ip, x, 1, info )
134 CALL chkxer( 'DGTTRS', infot, nout, lerr, ok )
135 infot = 3
136 CALL dgttrs( 'N', 0, -1, c, d, e, f, ip, x, 1, info )
137 CALL chkxer( 'DGTTRS', infot, nout, lerr, ok )
138 infot = 10
139 CALL dgttrs( 'N', 2, 1, c, d, e, f, ip, x, 1, info )
140 CALL chkxer( 'DGTTRS', infot, nout, lerr, ok )
141*
142* DGTRFS
143*
144 srnamt = 'DGTRFS'
145 infot = 1
146 CALL dgtrfs( '/', 0, 0, c, d, e, cf, df, ef, f, ip, b, 1, x, 1,
147 $ r1, r2, w, iw, info )
148 CALL chkxer( 'DGTRFS', infot, nout, lerr, ok )
149 infot = 2
150 CALL dgtrfs( 'N', -1, 0, c, d, e, cf, df, ef, f, ip, b, 1, x,
151 $ 1, r1, r2, w, iw, info )
152 CALL chkxer( 'DGTRFS', infot, nout, lerr, ok )
153 infot = 3
154 CALL dgtrfs( 'N', 0, -1, c, d, e, cf, df, ef, f, ip, b, 1, x,
155 $ 1, r1, r2, w, iw, info )
156 CALL chkxer( 'DGTRFS', infot, nout, lerr, ok )
157 infot = 13
158 CALL dgtrfs( 'N', 2, 1, c, d, e, cf, df, ef, f, ip, b, 1, x, 2,
159 $ r1, r2, w, iw, info )
160 CALL chkxer( 'DGTRFS', infot, nout, lerr, ok )
161 infot = 15
162 CALL dgtrfs( 'N', 2, 1, c, d, e, cf, df, ef, f, ip, b, 2, x, 1,
163 $ r1, r2, w, iw, info )
164 CALL chkxer( 'DGTRFS', infot, nout, lerr, ok )
165*
166* DGTCON
167*
168 srnamt = 'DGTCON'
169 infot = 1
170 CALL dgtcon( '/', 0, c, d, e, f, ip, anorm, rcond, w, iw,
171 $ info )
172 CALL chkxer( 'DGTCON', infot, nout, lerr, ok )
173 infot = 2
174 CALL dgtcon( 'I', -1, c, d, e, f, ip, anorm, rcond, w, iw,
175 $ info )
176 CALL chkxer( 'DGTCON', infot, nout, lerr, ok )
177 infot = 8
178 CALL dgtcon( 'I', 0, c, d, e, f, ip, -anorm, rcond, w, iw,
179 $ info )
180 CALL chkxer( 'DGTCON', 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* DPTTRF
188*
189 srnamt = 'DPTTRF'
190 infot = 1
191 CALL dpttrf( -1, d, e, info )
192 CALL chkxer( 'DPTTRF', infot, nout, lerr, ok )
193*
194* DPTTRS
195*
196 srnamt = 'DPTTRS'
197 infot = 1
198 CALL dpttrs( -1, 0, d, e, x, 1, info )
199 CALL chkxer( 'DPTTRS', infot, nout, lerr, ok )
200 infot = 2
201 CALL dpttrs( 0, -1, d, e, x, 1, info )
202 CALL chkxer( 'DPTTRS', infot, nout, lerr, ok )
203 infot = 6
204 CALL dpttrs( 2, 1, d, e, x, 1, info )
205 CALL chkxer( 'DPTTRS', infot, nout, lerr, ok )
206*
207* DPTRFS
208*
209 srnamt = 'DPTRFS'
210 infot = 1
211 CALL dptrfs( -1, 0, d, e, df, ef, b, 1, x, 1, r1, r2, w, info )
212 CALL chkxer( 'DPTRFS', infot, nout, lerr, ok )
213 infot = 2
214 CALL dptrfs( 0, -1, d, e, df, ef, b, 1, x, 1, r1, r2, w, info )
215 CALL chkxer( 'DPTRFS', infot, nout, lerr, ok )
216 infot = 8
217 CALL dptrfs( 2, 1, d, e, df, ef, b, 1, x, 2, r1, r2, w, info )
218 CALL chkxer( 'DPTRFS', infot, nout, lerr, ok )
219 infot = 10
220 CALL dptrfs( 2, 1, d, e, df, ef, b, 2, x, 1, r1, r2, w, info )
221 CALL chkxer( 'DPTRFS', infot, nout, lerr, ok )
222*
223* DPTCON
224*
225 srnamt = 'DPTCON'
226 infot = 1
227 CALL dptcon( -1, d, e, anorm, rcond, w, info )
228 CALL chkxer( 'DPTCON', infot, nout, lerr, ok )
229 infot = 4
230 CALL dptcon( 0, d, e, -anorm, rcond, w, info )
231 CALL chkxer( 'DPTCON', infot, nout, lerr, ok )
232 END IF
233*
234* Print a summary line.
235*
236 CALL alaesm( path, ok, nout )
237*
238 RETURN
239*
240* End of DERRGT
241*

◆ derrlq()

subroutine derrlq ( character*3 path,
integer nunit )

DERRLQ

Purpose:
!>
!> DERRLQ tests the error exits for the DOUBLE PRECISION 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 derrlq.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 DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
76 $ W( NMAX ), X( NMAX )
77* ..
78* .. External Subroutines ..
79 EXTERNAL alaesm, chkxer, dgelq2, dgelqf, dgelqs, dorgl2,
80 $ dorglq, dorml2, dormlq
81* ..
82* .. Scalars in Common ..
83 LOGICAL LERR, OK
84 CHARACTER*32 SRNAMT
85 INTEGER INFOT, NOUT
86* ..
87* .. Common blocks ..
88 COMMON / infoc / infot, nout, ok, lerr
89 COMMON / srnamc / srnamt
90* ..
91* .. Intrinsic Functions ..
92 INTRINSIC dble
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 ) = 1.d0 / dble( i+j )
104 af( i, j ) = 1.d0 / dble( i+j )
105 10 CONTINUE
106 b( j ) = 0.d0
107 w( j ) = 0.d0
108 x( j ) = 0.d0
109 20 CONTINUE
110 ok = .true.
111*
112* Error exits for LQ factorization
113*
114* DGELQF
115*
116 srnamt = 'DGELQF'
117 infot = 1
118 CALL dgelqf( -1, 0, a, 1, b, w, 1, info )
119 CALL chkxer( 'DGELQF', infot, nout, lerr, ok )
120 infot = 2
121 CALL dgelqf( 0, -1, a, 1, b, w, 1, info )
122 CALL chkxer( 'DGELQF', infot, nout, lerr, ok )
123 infot = 4
124 CALL dgelqf( 2, 1, a, 1, b, w, 2, info )
125 CALL chkxer( 'DGELQF', infot, nout, lerr, ok )
126 infot = 7
127 CALL dgelqf( 2, 1, a, 2, b, w, 1, info )
128 CALL chkxer( 'DGELQF', infot, nout, lerr, ok )
129*
130* DGELQ2
131*
132 srnamt = 'DGELQ2'
133 infot = 1
134 CALL dgelq2( -1, 0, a, 1, b, w, info )
135 CALL chkxer( 'DGELQ2', infot, nout, lerr, ok )
136 infot = 2
137 CALL dgelq2( 0, -1, a, 1, b, w, info )
138 CALL chkxer( 'DGELQ2', infot, nout, lerr, ok )
139 infot = 4
140 CALL dgelq2( 2, 1, a, 1, b, w, info )
141 CALL chkxer( 'DGELQ2', infot, nout, lerr, ok )
142*
143* DGELQS
144*
145 srnamt = 'DGELQS'
146 infot = 1
147 CALL dgelqs( -1, 0, 0, a, 1, x, b, 1, w, 1, info )
148 CALL chkxer( 'DGELQS', infot, nout, lerr, ok )
149 infot = 2
150 CALL dgelqs( 0, -1, 0, a, 1, x, b, 1, w, 1, info )
151 CALL chkxer( 'DGELQS', infot, nout, lerr, ok )
152 infot = 2
153 CALL dgelqs( 2, 1, 0, a, 2, x, b, 1, w, 1, info )
154 CALL chkxer( 'DGELQS', infot, nout, lerr, ok )
155 infot = 3
156 CALL dgelqs( 0, 0, -1, a, 1, x, b, 1, w, 1, info )
157 CALL chkxer( 'DGELQS', infot, nout, lerr, ok )
158 infot = 5
159 CALL dgelqs( 2, 2, 0, a, 1, x, b, 2, w, 1, info )
160 CALL chkxer( 'DGELQS', infot, nout, lerr, ok )
161 infot = 8
162 CALL dgelqs( 1, 2, 0, a, 1, x, b, 1, w, 1, info )
163 CALL chkxer( 'DGELQS', infot, nout, lerr, ok )
164 infot = 10
165 CALL dgelqs( 1, 1, 2, a, 1, x, b, 1, w, 1, info )
166 CALL chkxer( 'DGELQS', infot, nout, lerr, ok )
167*
168* DORGLQ
169*
170 srnamt = 'DORGLQ'
171 infot = 1
172 CALL dorglq( -1, 0, 0, a, 1, x, w, 1, info )
173 CALL chkxer( 'DORGLQ', infot, nout, lerr, ok )
174 infot = 2
175 CALL dorglq( 0, -1, 0, a, 1, x, w, 1, info )
176 CALL chkxer( 'DORGLQ', infot, nout, lerr, ok )
177 infot = 2
178 CALL dorglq( 2, 1, 0, a, 2, x, w, 2, info )
179 CALL chkxer( 'DORGLQ', infot, nout, lerr, ok )
180 infot = 3
181 CALL dorglq( 0, 0, -1, a, 1, x, w, 1, info )
182 CALL chkxer( 'DORGLQ', infot, nout, lerr, ok )
183 infot = 3
184 CALL dorglq( 1, 1, 2, a, 1, x, w, 1, info )
185 CALL chkxer( 'DORGLQ', infot, nout, lerr, ok )
186 infot = 5
187 CALL dorglq( 2, 2, 0, a, 1, x, w, 2, info )
188 CALL chkxer( 'DORGLQ', infot, nout, lerr, ok )
189 infot = 8
190 CALL dorglq( 2, 2, 0, a, 2, x, w, 1, info )
191 CALL chkxer( 'DORGLQ', infot, nout, lerr, ok )
192*
193* DORGL2
194*
195 srnamt = 'DORGL2'
196 infot = 1
197 CALL dorgl2( -1, 0, 0, a, 1, x, w, info )
198 CALL chkxer( 'DORGL2', infot, nout, lerr, ok )
199 infot = 2
200 CALL dorgl2( 0, -1, 0, a, 1, x, w, info )
201 CALL chkxer( 'DORGL2', infot, nout, lerr, ok )
202 infot = 2
203 CALL dorgl2( 2, 1, 0, a, 2, x, w, info )
204 CALL chkxer( 'DORGL2', infot, nout, lerr, ok )
205 infot = 3
206 CALL dorgl2( 0, 0, -1, a, 1, x, w, info )
207 CALL chkxer( 'DORGL2', infot, nout, lerr, ok )
208 infot = 3
209 CALL dorgl2( 1, 1, 2, a, 1, x, w, info )
210 CALL chkxer( 'DORGL2', infot, nout, lerr, ok )
211 infot = 5
212 CALL dorgl2( 2, 2, 0, a, 1, x, w, info )
213 CALL chkxer( 'DORGL2', infot, nout, lerr, ok )
214*
215* DORMLQ
216*
217 srnamt = 'DORMLQ'
218 infot = 1
219 CALL dormlq( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
220 CALL chkxer( 'DORMLQ', infot, nout, lerr, ok )
221 infot = 2
222 CALL dormlq( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
223 CALL chkxer( 'DORMLQ', infot, nout, lerr, ok )
224 infot = 3
225 CALL dormlq( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, 1, info )
226 CALL chkxer( 'DORMLQ', infot, nout, lerr, ok )
227 infot = 4
228 CALL dormlq( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, 1, info )
229 CALL chkxer( 'DORMLQ', infot, nout, lerr, ok )
230 infot = 5
231 CALL dormlq( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, 1, info )
232 CALL chkxer( 'DORMLQ', infot, nout, lerr, ok )
233 infot = 5
234 CALL dormlq( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, 1, info )
235 CALL chkxer( 'DORMLQ', infot, nout, lerr, ok )
236 infot = 5
237 CALL dormlq( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, 1, info )
238 CALL chkxer( 'DORMLQ', infot, nout, lerr, ok )
239 infot = 7
240 CALL dormlq( 'L', 'N', 2, 0, 2, a, 1, x, af, 2, w, 1, info )
241 CALL chkxer( 'DORMLQ', infot, nout, lerr, ok )
242 infot = 7
243 CALL dormlq( 'R', 'N', 0, 2, 2, a, 1, x, af, 1, w, 1, info )
244 CALL chkxer( 'DORMLQ', infot, nout, lerr, ok )
245 infot = 10
246 CALL dormlq( 'L', 'N', 2, 1, 0, a, 2, x, af, 1, w, 1, info )
247 CALL chkxer( 'DORMLQ', infot, nout, lerr, ok )
248 infot = 12
249 CALL dormlq( 'L', 'N', 1, 2, 0, a, 1, x, af, 1, w, 1, info )
250 CALL chkxer( 'DORMLQ', infot, nout, lerr, ok )
251 infot = 12
252 CALL dormlq( 'R', 'N', 2, 1, 0, a, 1, x, af, 2, w, 1, info )
253 CALL chkxer( 'DORMLQ', infot, nout, lerr, ok )
254*
255* DORML2
256*
257 srnamt = 'DORML2'
258 infot = 1
259 CALL dorml2( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, info )
260 CALL chkxer( 'DORML2', infot, nout, lerr, ok )
261 infot = 2
262 CALL dorml2( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, info )
263 CALL chkxer( 'DORML2', infot, nout, lerr, ok )
264 infot = 3
265 CALL dorml2( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, info )
266 CALL chkxer( 'DORML2', infot, nout, lerr, ok )
267 infot = 4
268 CALL dorml2( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, info )
269 CALL chkxer( 'DORML2', infot, nout, lerr, ok )
270 infot = 5
271 CALL dorml2( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, info )
272 CALL chkxer( 'DORML2', infot, nout, lerr, ok )
273 infot = 5
274 CALL dorml2( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, info )
275 CALL chkxer( 'DORML2', infot, nout, lerr, ok )
276 infot = 5
277 CALL dorml2( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, info )
278 CALL chkxer( 'DORML2', infot, nout, lerr, ok )
279 infot = 7
280 CALL dorml2( 'L', 'N', 2, 1, 2, a, 1, x, af, 2, w, info )
281 CALL chkxer( 'DORML2', infot, nout, lerr, ok )
282 infot = 7
283 CALL dorml2( 'R', 'N', 1, 2, 2, a, 1, x, af, 1, w, info )
284 CALL chkxer( 'DORML2', infot, nout, lerr, ok )
285 infot = 10
286 CALL dorml2( 'L', 'N', 2, 1, 0, a, 2, x, af, 1, w, info )
287 CALL chkxer( 'DORML2', infot, nout, lerr, ok )
288*
289* Print a summary line.
290*
291 CALL alaesm( path, ok, nout )
292*
293 RETURN
294*
295* End of DERRLQ
296*
dgelq2
subroutine dgelq2(m, n, a, lda, tau, work, info)
DGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorithm.
Definition dgelq2.f:129
dorml2
subroutine dorml2(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
DORML2 multiplies a general matrix by the orthogonal matrix from a LQ factorization determined by sge...
Definition dorml2.f:159
dorgl2
subroutine dorgl2(m, n, k, a, lda, tau, work, info)
DORGL2
Definition dorgl2.f:113
dormlq
subroutine dormlq(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
DORMLQ
Definition dormlq.f:167
dorglq
subroutine dorglq(m, n, k, a, lda, tau, work, lwork, info)
DORGLQ
Definition dorglq.f:127

◆ derrlqt()

subroutine derrlqt ( character*3 path,
integer nunit )

DERLQT

Purpose:
!>
!> DERRLQT tests the error exits for the DOUBLE PRECISION routines
!> that use the LQT 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 derrlqt.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 DOUBLE PRECISION A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
77 $ C( NMAX, NMAX )
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, dgelqt3, dgelqt,
81 $ dgemlqt
82* ..
83* .. Scalars in Common ..
84 LOGICAL LERR, OK
85 CHARACTER*32 SRNAMT
86 INTEGER INFOT, NOUT
87* ..
88* .. Common blocks ..
89 COMMON / infoc / infot, nout, ok, lerr
90 COMMON / srnamc / srnamt
91* ..
92* .. Intrinsic Functions ..
93 INTRINSIC dble
94* ..
95* .. Executable Statements ..
96*
97 nout = nunit
98 WRITE( nout, fmt = * )
99*
100* Set the variables to innocuous values.
101*
102 DO j = 1, nmax
103 DO i = 1, nmax
104 a( i, j ) = 1.d0 / dble( i+j )
105 c( i, j ) = 1.d0 / dble( i+j )
106 t( i, j ) = 1.d0 / dble( i+j )
107 END DO
108 w( j ) = 0.d0
109 END DO
110 ok = .true.
111*
112* Error exits for LQT factorization
113*
114* DGELQT
115*
116 srnamt = 'DGELQT'
117 infot = 1
118 CALL dgelqt( -1, 0, 1, a, 1, t, 1, w, info )
119 CALL chkxer( 'DGELQT', infot, nout, lerr, ok )
120 infot = 2
121 CALL dgelqt( 0, -1, 1, a, 1, t, 1, w, info )
122 CALL chkxer( 'DGELQT', infot, nout, lerr, ok )
123 infot = 3
124 CALL dgelqt( 0, 0, 0, a, 1, t, 1, w, info )
125 CALL chkxer( 'DGELQT', infot, nout, lerr, ok )
126 infot = 5
127 CALL dgelqt( 2, 1, 1, a, 1, t, 1, w, info )
128 CALL chkxer( 'DGELQT', infot, nout, lerr, ok )
129 infot = 7
130 CALL dgelqt( 2, 2, 2, a, 2, t, 1, w, info )
131 CALL chkxer( 'DGELQT', infot, nout, lerr, ok )
132*
133* DGELQT3
134*
135 srnamt = 'DGELQT3'
136 infot = 1
137 CALL dgelqt3( -1, 0, a, 1, t, 1, info )
138 CALL chkxer( 'DGELQT3', infot, nout, lerr, ok )
139 infot = 2
140 CALL dgelqt3( 0, -1, a, 1, t, 1, info )
141 CALL chkxer( 'DGELQT3', infot, nout, lerr, ok )
142 infot = 4
143 CALL dgelqt3( 2, 2, a, 1, t, 1, info )
144 CALL chkxer( 'DGELQT3', infot, nout, lerr, ok )
145 infot = 6
146 CALL dgelqt3( 2, 2, a, 2, t, 1, info )
147 CALL chkxer( 'DGELQT3', infot, nout, lerr, ok )
148*
149* DGEMLQT
150*
151 srnamt = 'DGEMLQT'
152 infot = 1
153 CALL dgemlqt( '/', 'N', 0, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
154 CALL chkxer( 'DGEMLQT', infot, nout, lerr, ok )
155 infot = 2
156 CALL dgemlqt( 'L', '/', 0, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
157 CALL chkxer( 'DGEMLQT', infot, nout, lerr, ok )
158 infot = 3
159 CALL dgemlqt( 'L', 'N', -1, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
160 CALL chkxer( 'DGEMLQT', infot, nout, lerr, ok )
161 infot = 4
162 CALL dgemlqt( 'L', 'N', 0, -1, 0, 1, a, 1, t, 1, c, 1, w, info )
163 CALL chkxer( 'DGEMLQT', infot, nout, lerr, ok )
164 infot = 5
165 CALL dgemlqt( 'L', 'N', 0, 0, -1, 1, a, 1, t, 1, c, 1, w, info )
166 CALL chkxer( 'DGEMLQT', infot, nout, lerr, ok )
167 infot = 5
168 CALL dgemlqt( 'R', 'N', 0, 0, -1, 1, a, 1, t, 1, c, 1, w, info )
169 CALL chkxer( 'DGEMLQT', infot, nout, lerr, ok )
170 infot = 6
171 CALL dgemlqt( 'L', 'N', 0, 0, 0, 0, a, 1, t, 1, c, 1, w, info )
172 CALL chkxer( 'DGEMLQT', infot, nout, lerr, ok )
173 infot = 8
174 CALL dgemlqt( 'R', 'N', 2, 2, 2, 1, a, 1, t, 1, c, 1, w, info )
175 CALL chkxer( 'DGEMLQT', infot, nout, lerr, ok )
176 infot = 8
177 CALL dgemlqt( 'L', 'N', 2, 2, 2, 1, a, 1, t, 1, c, 1, w, info )
178 CALL chkxer( 'DGEMLQT', infot, nout, lerr, ok )
179 infot = 10
180 CALL dgemlqt( 'R', 'N', 1, 1, 1, 1, a, 1, t, 0, c, 1, w, info )
181 CALL chkxer( 'DGEMLQT', infot, nout, lerr, ok )
182 infot = 12
183 CALL dgemlqt( 'L', 'N', 1, 1, 1, 1, a, 1, t, 1, c, 0, w, info )
184 CALL chkxer( 'DGEMLQT', infot, nout, lerr, ok )
185*
186* Print a summary line.
187*
188 CALL alaesm( path, ok, nout )
189*
190 RETURN
191*
192* End of DERRLQT
193*
dgelqt
subroutine dgelqt(m, n, mb, a, lda, t, ldt, work, info)
DGELQT
Definition dgelqt.f:139
dgemlqt
subroutine dgemlqt(side, trans, m, n, k, mb, v, ldv, t, ldt, c, ldc, work, info)
DGEMLQT
Definition dgemlqt.f:168
dgelqt3
recursive subroutine dgelqt3(m, n, a, lda, t, ldt, info)
DGELQT3 recursively computes a LQ factorization of a general real or complex matrix using the compact...
Definition dgelqt3.f:131

◆ derrlqtp()

subroutine derrlqtp ( character*3 path,
integer nunit )

DERRLQTP

Purpose:
!>
!> DERRLQTP tests the error exits for the REAL routines
!> that use the LQT 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 derrlqtp.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 DOUBLE PRECISION A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
77 $ B( NMAX, NMAX ), C( NMAX, NMAX )
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, dtplqt2, dtplqt,
81 $ dtpmlqt
82* ..
83* .. Scalars in Common ..
84 LOGICAL LERR, OK
85 CHARACTER*32 SRNAMT
86 INTEGER INFOT, NOUT
87* ..
88* .. Common blocks ..
89 COMMON / infoc / infot, nout, ok, lerr
90 COMMON / srnamc / srnamt
91* ..
92* .. Intrinsic Functions ..
93 INTRINSIC dble
94* ..
95* .. Executable Statements ..
96*
97 nout = nunit
98 WRITE( nout, fmt = * )
99*
100* Set the variables to innocuous values.
101*
102 DO j = 1, nmax
103 DO i = 1, nmax
104 a( i, j ) = 1.d0 / dble( i+j )
105 c( i, j ) = 1.d0 / dble( i+j )
106 t( i, j ) = 1.d0 / dble( i+j )
107 END DO
108 w( j ) = 0.0
109 END DO
110 ok = .true.
111*
112* Error exits for TPLQT factorization
113*
114* DTPLQT
115*
116 srnamt = 'DTPLQT'
117 infot = 1
118 CALL dtplqt( -1, 1, 0, 1, a, 1, b, 1, t, 1, w, info )
119 CALL chkxer( 'DTPLQT', infot, nout, lerr, ok )
120 infot = 2
121 CALL dtplqt( 1, -1, 0, 1, a, 1, b, 1, t, 1, w, info )
122 CALL chkxer( 'DTPLQT', infot, nout, lerr, ok )
123 infot = 3
124 CALL dtplqt( 0, 1, -1, 1, a, 1, b, 1, t, 1, w, info )
125 CALL chkxer( 'DTPLQT', infot, nout, lerr, ok )
126 infot = 3
127 CALL dtplqt( 0, 1, 1, 1, a, 1, b, 1, t, 1, w, info )
128 CALL chkxer( 'DTPLQT', infot, nout, lerr, ok )
129 infot = 4
130 CALL dtplqt( 0, 1, 0, 0, a, 1, b, 1, t, 1, w, info )
131 CALL chkxer( 'DTPLQT', infot, nout, lerr, ok )
132 infot = 4
133 CALL dtplqt( 1, 1, 0, 2, a, 1, b, 1, t, 1, w, info )
134 CALL chkxer( 'DTPLQT', infot, nout, lerr, ok )
135 infot = 6
136 CALL dtplqt( 2, 1, 0, 2, a, 1, b, 1, t, 1, w, info )
137 CALL chkxer( 'DTPLQT', infot, nout, lerr, ok )
138 infot = 8
139 CALL dtplqt( 2, 1, 0, 1, a, 2, b, 1, t, 1, w, info )
140 CALL chkxer( 'DTPLQT', infot, nout, lerr, ok )
141 infot = 10
142 CALL dtplqt( 2, 2, 1, 2, a, 2, b, 2, t, 1, w, info )
143 CALL chkxer( 'DTPLQT', infot, nout, lerr, ok )
144*
145* DTPLQT2
146*
147 srnamt = 'DTPLQT2'
148 infot = 1
149 CALL dtplqt2( -1, 0, 0, a, 1, b, 1, t, 1, info )
150 CALL chkxer( 'DTPLQT2', infot, nout, lerr, ok )
151 infot = 2
152 CALL dtplqt2( 0, -1, 0, a, 1, b, 1, t, 1, info )
153 CALL chkxer( 'DTPLQT2', infot, nout, lerr, ok )
154 infot = 3
155 CALL dtplqt2( 0, 0, -1, a, 1, b, 1, t, 1, info )
156 CALL chkxer( 'DTPLQT2', infot, nout, lerr, ok )
157 infot = 5
158 CALL dtplqt2( 2, 2, 0, a, 1, b, 2, t, 2, info )
159 CALL chkxer( 'DTPLQT2', infot, nout, lerr, ok )
160 infot = 7
161 CALL dtplqt2( 2, 2, 0, a, 2, b, 1, t, 2, info )
162 CALL chkxer( 'DTPLQT2', infot, nout, lerr, ok )
163 infot = 9
164 CALL dtplqt2( 2, 2, 0, a, 2, b, 2, t, 1, info )
165 CALL chkxer( 'DTPLQT2', infot, nout, lerr, ok )
166*
167* DTPMLQT
168*
169 srnamt = 'DTPMLQT'
170 infot = 1
171 CALL dtpmlqt( '/', 'N', 0, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
172 $ w, info )
173 CALL chkxer( 'DTPMLQT', infot, nout, lerr, ok )
174 infot = 2
175 CALL dtpmlqt( 'L', '/', 0, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
176 $ w, info )
177 CALL chkxer( 'DTPMLQT', infot, nout, lerr, ok )
178 infot = 3
179 CALL dtpmlqt( 'L', 'N', -1, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
180 $ w, info )
181 CALL chkxer( 'DTPMLQT', infot, nout, lerr, ok )
182 infot = 4
183 CALL dtpmlqt( 'L', 'N', 0, -1, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
184 $ w, info )
185 CALL chkxer( 'DTPMLQT', infot, nout, lerr, ok )
186 infot = 5
187 CALL dtpmlqt( 'L', 'N', 0, 0, -1, 0, 1, a, 1, t, 1, b, 1, c, 1,
188 $ w, info )
189 infot = 6
190 CALL dtpmlqt( 'L', 'N', 0, 0, 0, -1, 1, a, 1, t, 1, b, 1, c, 1,
191 $ w, info )
192 CALL chkxer( 'DTPMLQT', infot, nout, lerr, ok )
193 infot = 7
194 CALL dtpmlqt( 'L', 'N', 0, 0, 0, 0, 0, a, 1, t, 1, b, 1, c, 1,
195 $ w, info )
196 CALL chkxer( 'DTPMLQT', infot, nout, lerr, ok )
197 infot = 9
198 CALL dtpmlqt( 'R', 'N', 2, 2, 2, 1, 1, a, 1, t, 1, b, 1, c, 1,
199 $ w, info )
200 CALL chkxer( 'DTPMLQT', infot, nout, lerr, ok )
201 infot = 11
202 CALL dtpmlqt( 'R', 'N', 1, 1, 1, 1, 1, a, 1, t, 0, b, 1, c, 1,
203 $ w, info )
204 CALL chkxer( 'DTPMLQT', infot, nout, lerr, ok )
205 infot = 13
206 CALL dtpmlqt( 'L', 'N', 1, 1, 1, 1, 1, a, 1, t, 1, b, 0, c, 1,
207 $ w, info )
208 CALL chkxer( 'DTPMLQT', infot, nout, lerr, ok )
209 infot = 15
210 CALL dtpmlqt( 'L', 'N', 1, 1, 1, 1, 1, a, 1, t, 1, b, 1, c, 0,
211 $ w, info )
212 CALL chkxer( 'DTPMLQT', infot, nout, lerr, ok )
213*
214* Print a summary line.
215*
216 CALL alaesm( path, ok, nout )
217*
218 RETURN
219*
220* End of DERRLQTP
221*
dtplqt
subroutine dtplqt(m, n, l, mb, a, lda, b, ldb, t, ldt, work, info)
DTPLQT
Definition dtplqt.f:189
dtplqt2
subroutine dtplqt2(m, n, l, a, lda, b, ldb, t, ldt, info)
DTPLQT2 computes a LQ factorization of a real or complex "triangular-pentagonal" matrix,...
Definition dtplqt2.f:177
dtpmlqt
subroutine dtpmlqt(side, trans, m, n, k, l, mb, v, ldv, t, ldt, a, lda, b, ldb, work, info)
DTPMLQT
Definition dtpmlqt.f:214

◆ derrls()

subroutine derrls ( character*3 path,
integer nunit )

DERRLS

Purpose:
!>
!> DERRLS tests the error exits for the DOUBLE PRECISION least squares
!> driver routines (DGELS, SGELSS, SGELSY, SGELSD).
!>
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 derrls.f.

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

◆ derrorhr_col()

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

DERRORHR_COL

Purpose:
!>
!> DERRORHR_COL tests the error exits for DORHR_COL that does
!> Householder reconstruction from the output of tall-skinny
!> factorization DLATSQR.
!>
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 derrorhr_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 DOUBLE PRECISION A( NMAX, NMAX ), T( NMAX, NMAX ), D(NMAX)
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, dorhr_col
81* ..
82* .. Scalars in Common ..
83 LOGICAL LERR, OK
84 CHARACTER(LEN=32) SRNAMT
85 INTEGER INFOT, NOUT
86* ..
87* .. Common blocks ..
88 COMMON / infoc / infot, nout, ok, lerr
89 COMMON / srnamc / srnamt
90* ..
91* .. Intrinsic Functions ..
92 INTRINSIC dble
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 ) = 1.d+0 / dble( i+j )
104 t( i, j ) = 1.d+0 / dble( i+j )
105 END DO
106 d( j ) = 0.d+0
107 END DO
108 ok = .true.
109*
110* Error exits for Householder reconstruction
111*
112* DORHR_COL
113*
114 srnamt = 'DORHR_COL'
115*
116 infot = 1
117 CALL dorhr_col( -1, 0, 1, a, 1, t, 1, d, info )
118 CALL chkxer( 'DORHR_COL', infot, nout, lerr, ok )
119*
120 infot = 2
121 CALL dorhr_col( 0, -1, 1, a, 1, t, 1, d, info )
122 CALL chkxer( 'DORHR_COL', infot, nout, lerr, ok )
123 CALL dorhr_col( 1, 2, 1, a, 1, t, 1, d, info )
124 CALL chkxer( 'DORHR_COL', infot, nout, lerr, ok )
125*
126 infot = 3
127 CALL dorhr_col( 0, 0, -1, a, 1, t, 1, d, info )
128 CALL chkxer( 'DORHR_COL', infot, nout, lerr, ok )
129*
130 CALL dorhr_col( 0, 0, 0, a, 1, t, 1, d, info )
131 CALL chkxer( 'DORHR_COL', infot, nout, lerr, ok )
132*
133 infot = 5
134 CALL dorhr_col( 0, 0, 1, a, -1, t, 1, d, info )
135 CALL chkxer( 'DORHR_COL', infot, nout, lerr, ok )
136*
137 CALL dorhr_col( 0, 0, 1, a, 0, t, 1, d, info )
138 CALL chkxer( 'DORHR_COL', infot, nout, lerr, ok )
139*
140 CALL dorhr_col( 2, 0, 1, a, 1, t, 1, d, info )
141 CALL chkxer( 'DORHR_COL', infot, nout, lerr, ok )
142*
143 infot = 7
144 CALL dorhr_col( 0, 0, 1, a, 1, t, -1, d, info )
145 CALL chkxer( 'DORHR_COL', infot, nout, lerr, ok )
146*
147 CALL dorhr_col( 0, 0, 1, a, 1, t, 0, d, info )
148 CALL chkxer( 'DORHR_COL', infot, nout, lerr, ok )
149*
150 CALL dorhr_col( 4, 3, 2, a, 4, t, 1, d, info )
151 CALL chkxer( 'DORHR_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 DERRORHR_COL
160*
dorhr_col
subroutine dorhr_col(m, n, nb, a, lda, t, ldt, d, info)
DORHR_COL
Definition dorhr_col.f:259

◆ derrpo()

subroutine derrpo ( character*3 path,
integer nunit )

DERRPO

DERRPOX

Purpose:
!>
!> DERRPO tests the error exits for the DOUBLE PRECISION routines
!> for symmetric 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:
!>
!> DERRPO tests the error exits for the DOUBLE PRECISION routines
!> for symmetric positive definite matrices.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise derrpo.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 derrpo.f.

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

◆ derrps()

subroutine derrps ( character*3 path,
integer nunit )

DERRPS

Purpose:
!>
!> DERRPS tests the error exits for the DOUBLE PRECISION routines
!> for DPSTRF.
!>
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 derrps.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 DOUBLE PRECISION A( NMAX, NMAX ), WORK( 2*NMAX )
76 INTEGER PIV( NMAX )
77* ..
78* .. External Subroutines ..
79 EXTERNAL alaesm, chkxer, dpstf2, dpstrf
80* ..
81* .. Scalars in Common ..
82 INTEGER INFOT, NOUT
83 LOGICAL LERR, OK
84 CHARACTER*32 SRNAMT
85* ..
86* .. Common blocks ..
87 COMMON / infoc / infot, nout, ok, lerr
88 COMMON / srnamc / srnamt
89* ..
90* .. Intrinsic Functions ..
91 INTRINSIC dble
92* ..
93* .. Executable Statements ..
94*
95 nout = nunit
96 WRITE( nout, fmt = * )
97*
98* Set the variables to innocuous values.
99*
100 DO 110 j = 1, nmax
101 DO 100 i = 1, nmax
102 a( i, j ) = 1.d0 / dble( i+j )
103*
104 100 CONTINUE
105 piv( j ) = j
106 work( j ) = 0.d0
107 work( nmax+j ) = 0.d0
108*
109 110 CONTINUE
110 ok = .true.
111*
112*
113* Test error exits of the routines that use the Cholesky
114* decomposition of a symmetric positive semidefinite matrix.
115*
116* DPSTRF
117*
118 srnamt = 'DPSTRF'
119 infot = 1
120 CALL dpstrf( '/', 0, a, 1, piv, rank, -1.d0, work, info )
121 CALL chkxer( 'DPSTRF', infot, nout, lerr, ok )
122 infot = 2
123 CALL dpstrf( 'U', -1, a, 1, piv, rank, -1.d0, work, info )
124 CALL chkxer( 'DPSTRF', infot, nout, lerr, ok )
125 infot = 4
126 CALL dpstrf( 'U', 2, a, 1, piv, rank, -1.d0, work, info )
127 CALL chkxer( 'DPSTRF', infot, nout, lerr, ok )
128*
129* DPSTF2
130*
131 srnamt = 'DPSTF2'
132 infot = 1
133 CALL dpstf2( '/', 0, a, 1, piv, rank, -1.d0, work, info )
134 CALL chkxer( 'DPSTF2', infot, nout, lerr, ok )
135 infot = 2
136 CALL dpstf2( 'U', -1, a, 1, piv, rank, -1.d0, work, info )
137 CALL chkxer( 'DPSTF2', infot, nout, lerr, ok )
138 infot = 4
139 CALL dpstf2( 'U', 2, a, 1, piv, rank, -1.d0, work, info )
140 CALL chkxer( 'DPSTF2', infot, nout, lerr, ok )
141*
142*
143* Print a summary line.
144*
145 CALL alaesm( path, ok, nout )
146*
147 RETURN
148*
149* End of DERRPS
150*
dpstf2
subroutine dpstf2(uplo, n, a, lda, piv, rank, tol, work, info)
DPSTF2 computes the Cholesky factorization with complete pivoting of a real symmetric positive semide...
Definition dpstf2.f:141

◆ derrql()

subroutine derrql ( character*3 path,
integer nunit )

DERRQL

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

◆ derrqp()

subroutine derrqp ( character*3 path,
integer nunit )

DERRQP

Purpose:
!>
!> DERRQP tests the error exits for DGEQP3.
!>
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 derrqp.f.

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

◆ derrqr()

subroutine derrqr ( character*3 path,
integer nunit )

DERRQR

Purpose:
!>
!> DERRQR tests the error exits for the DOUBLE PRECISION 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 derrqr.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 DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
76 $ W( NMAX ), X( NMAX )
77* ..
78* .. External Subroutines ..
79 EXTERNAL alaesm, chkxer, dgeqr2, dgeqr2p, dgeqrf,
80 $ dgeqrfp, dgeqrs, dorg2r, dorgqr, dorm2r,
81 $ dormqr
82* ..
83* .. Scalars in Common ..
84 LOGICAL LERR, OK
85 CHARACTER*32 SRNAMT
86 INTEGER INFOT, NOUT
87* ..
88* .. Common blocks ..
89 COMMON / infoc / infot, nout, ok, lerr
90 COMMON / srnamc / srnamt
91* ..
92* .. Intrinsic Functions ..
93 INTRINSIC dble
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 ) = 1.d0 / dble( i+j )
105 af( i, j ) = 1.d0 / dble( i+j )
106 10 CONTINUE
107 b( j ) = 0.d0
108 w( j ) = 0.d0
109 x( j ) = 0.d0
110 20 CONTINUE
111 ok = .true.
112*
113* Error exits for QR factorization
114*
115* DGEQRF
116*
117 srnamt = 'DGEQRF'
118 infot = 1
119 CALL dgeqrf( -1, 0, a, 1, b, w, 1, info )
120 CALL chkxer( 'DGEQRF', infot, nout, lerr, ok )
121 infot = 2
122 CALL dgeqrf( 0, -1, a, 1, b, w, 1, info )
123 CALL chkxer( 'DGEQRF', infot, nout, lerr, ok )
124 infot = 4
125 CALL dgeqrf( 2, 1, a, 1, b, w, 1, info )
126 CALL chkxer( 'DGEQRF', infot, nout, lerr, ok )
127 infot = 7
128 CALL dgeqrf( 1, 2, a, 1, b, w, 1, info )
129 CALL chkxer( 'DGEQRF', infot, nout, lerr, ok )
130*
131* DGEQRFP
132*
133 srnamt = 'DGEQRFP'
134 infot = 1
135 CALL dgeqrfp( -1, 0, a, 1, b, w, 1, info )
136 CALL chkxer( 'DGEQRFP', infot, nout, lerr, ok )
137 infot = 2
138 CALL dgeqrfp( 0, -1, a, 1, b, w, 1, info )
139 CALL chkxer( 'DGEQRFP', infot, nout, lerr, ok )
140 infot = 4
141 CALL dgeqrfp( 2, 1, a, 1, b, w, 1, info )
142 CALL chkxer( 'DGEQRFP', infot, nout, lerr, ok )
143 infot = 7
144 CALL dgeqrfp( 1, 2, a, 1, b, w, 1, info )
145 CALL chkxer( 'DGEQRFP', infot, nout, lerr, ok )
146*
147* DGEQR2
148*
149 srnamt = 'DGEQR2'
150 infot = 1
151 CALL dgeqr2( -1, 0, a, 1, b, w, info )
152 CALL chkxer( 'DGEQR2', infot, nout, lerr, ok )
153 infot = 2
154 CALL dgeqr2( 0, -1, a, 1, b, w, info )
155 CALL chkxer( 'DGEQR2', infot, nout, lerr, ok )
156 infot = 4
157 CALL dgeqr2( 2, 1, a, 1, b, w, info )
158 CALL chkxer( 'DGEQR2', infot, nout, lerr, ok )
159*
160* DGEQR2P
161*
162 srnamt = 'DGEQR2P'
163 infot = 1
164 CALL dgeqr2p( -1, 0, a, 1, b, w, info )
165 CALL chkxer( 'DGEQR2P', infot, nout, lerr, ok )
166 infot = 2
167 CALL dgeqr2p( 0, -1, a, 1, b, w, info )
168 CALL chkxer( 'DGEQR2P', infot, nout, lerr, ok )
169 infot = 4
170 CALL dgeqr2p( 2, 1, a, 1, b, w, info )
171 CALL chkxer( 'DGEQR2P', infot, nout, lerr, ok )
172*
173* DGEQRS
174*
175 srnamt = 'DGEQRS'
176 infot = 1
177 CALL dgeqrs( -1, 0, 0, a, 1, x, b, 1, w, 1, info )
178 CALL chkxer( 'DGEQRS', infot, nout, lerr, ok )
179 infot = 2
180 CALL dgeqrs( 0, -1, 0, a, 1, x, b, 1, w, 1, info )
181 CALL chkxer( 'DGEQRS', infot, nout, lerr, ok )
182 infot = 2
183 CALL dgeqrs( 1, 2, 0, a, 2, x, b, 2, w, 1, info )
184 CALL chkxer( 'DGEQRS', infot, nout, lerr, ok )
185 infot = 3
186 CALL dgeqrs( 0, 0, -1, a, 1, x, b, 1, w, 1, info )
187 CALL chkxer( 'DGEQRS', infot, nout, lerr, ok )
188 infot = 5
189 CALL dgeqrs( 2, 1, 0, a, 1, x, b, 2, w, 1, info )
190 CALL chkxer( 'DGEQRS', infot, nout, lerr, ok )
191 infot = 8
192 CALL dgeqrs( 2, 1, 0, a, 2, x, b, 1, w, 1, info )
193 CALL chkxer( 'DGEQRS', infot, nout, lerr, ok )
194 infot = 10
195 CALL dgeqrs( 1, 1, 2, a, 1, x, b, 1, w, 1, info )
196 CALL chkxer( 'DGEQRS', infot, nout, lerr, ok )
197*
198* DORGQR
199*
200 srnamt = 'DORGQR'
201 infot = 1
202 CALL dorgqr( -1, 0, 0, a, 1, x, w, 1, info )
203 CALL chkxer( 'DORGQR', infot, nout, lerr, ok )
204 infot = 2
205 CALL dorgqr( 0, -1, 0, a, 1, x, w, 1, info )
206 CALL chkxer( 'DORGQR', infot, nout, lerr, ok )
207 infot = 2
208 CALL dorgqr( 1, 2, 0, a, 1, x, w, 2, info )
209 CALL chkxer( 'DORGQR', infot, nout, lerr, ok )
210 infot = 3
211 CALL dorgqr( 0, 0, -1, a, 1, x, w, 1, info )
212 CALL chkxer( 'DORGQR', infot, nout, lerr, ok )
213 infot = 3
214 CALL dorgqr( 1, 1, 2, a, 1, x, w, 1, info )
215 CALL chkxer( 'DORGQR', infot, nout, lerr, ok )
216 infot = 5
217 CALL dorgqr( 2, 2, 0, a, 1, x, w, 2, info )
218 CALL chkxer( 'DORGQR', infot, nout, lerr, ok )
219 infot = 8
220 CALL dorgqr( 2, 2, 0, a, 2, x, w, 1, info )
221 CALL chkxer( 'DORGQR', infot, nout, lerr, ok )
222*
223* DORG2R
224*
225 srnamt = 'DORG2R'
226 infot = 1
227 CALL dorg2r( -1, 0, 0, a, 1, x, w, info )
228 CALL chkxer( 'DORG2R', infot, nout, lerr, ok )
229 infot = 2
230 CALL dorg2r( 0, -1, 0, a, 1, x, w, info )
231 CALL chkxer( 'DORG2R', infot, nout, lerr, ok )
232 infot = 2
233 CALL dorg2r( 1, 2, 0, a, 1, x, w, info )
234 CALL chkxer( 'DORG2R', infot, nout, lerr, ok )
235 infot = 3
236 CALL dorg2r( 0, 0, -1, a, 1, x, w, info )
237 CALL chkxer( 'DORG2R', infot, nout, lerr, ok )
238 infot = 3
239 CALL dorg2r( 2, 1, 2, a, 2, x, w, info )
240 CALL chkxer( 'DORG2R', infot, nout, lerr, ok )
241 infot = 5
242 CALL dorg2r( 2, 1, 0, a, 1, x, w, info )
243 CALL chkxer( 'DORG2R', infot, nout, lerr, ok )
244*
245* DORMQR
246*
247 srnamt = 'DORMQR'
248 infot = 1
249 CALL dormqr( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
250 CALL chkxer( 'DORMQR', infot, nout, lerr, ok )
251 infot = 2
252 CALL dormqr( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, 1, info )
253 CALL chkxer( 'DORMQR', infot, nout, lerr, ok )
254 infot = 3
255 CALL dormqr( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, 1, info )
256 CALL chkxer( 'DORMQR', infot, nout, lerr, ok )
257 infot = 4
258 CALL dormqr( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, 1, info )
259 CALL chkxer( 'DORMQR', infot, nout, lerr, ok )
260 infot = 5
261 CALL dormqr( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, 1, info )
262 CALL chkxer( 'DORMQR', infot, nout, lerr, ok )
263 infot = 5
264 CALL dormqr( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, 1, info )
265 CALL chkxer( 'DORMQR', infot, nout, lerr, ok )
266 infot = 5
267 CALL dormqr( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, 1, info )
268 CALL chkxer( 'DORMQR', infot, nout, lerr, ok )
269 infot = 7
270 CALL dormqr( 'L', 'N', 2, 1, 0, a, 1, x, af, 2, w, 1, info )
271 CALL chkxer( 'DORMQR', infot, nout, lerr, ok )
272 infot = 7
273 CALL dormqr( 'R', 'N', 1, 2, 0, a, 1, x, af, 1, w, 1, info )
274 CALL chkxer( 'DORMQR', infot, nout, lerr, ok )
275 infot = 10
276 CALL dormqr( 'L', 'N', 2, 1, 0, a, 2, x, af, 1, w, 1, info )
277 CALL chkxer( 'DORMQR', infot, nout, lerr, ok )
278 infot = 12
279 CALL dormqr( 'L', 'N', 1, 2, 0, a, 1, x, af, 1, w, 1, info )
280 CALL chkxer( 'DORMQR', infot, nout, lerr, ok )
281 infot = 12
282 CALL dormqr( 'R', 'N', 2, 1, 0, a, 1, x, af, 2, w, 1, info )
283 CALL chkxer( 'DORMQR', infot, nout, lerr, ok )
284*
285* DORM2R
286*
287 srnamt = 'DORM2R'
288 infot = 1
289 CALL dorm2r( '/', 'N', 0, 0, 0, a, 1, x, af, 1, w, info )
290 CALL chkxer( 'DORM2R', infot, nout, lerr, ok )
291 infot = 2
292 CALL dorm2r( 'L', '/', 0, 0, 0, a, 1, x, af, 1, w, info )
293 CALL chkxer( 'DORM2R', infot, nout, lerr, ok )
294 infot = 3
295 CALL dorm2r( 'L', 'N', -1, 0, 0, a, 1, x, af, 1, w, info )
296 CALL chkxer( 'DORM2R', infot, nout, lerr, ok )
297 infot = 4
298 CALL dorm2r( 'L', 'N', 0, -1, 0, a, 1, x, af, 1, w, info )
299 CALL chkxer( 'DORM2R', infot, nout, lerr, ok )
300 infot = 5
301 CALL dorm2r( 'L', 'N', 0, 0, -1, a, 1, x, af, 1, w, info )
302 CALL chkxer( 'DORM2R', infot, nout, lerr, ok )
303 infot = 5
304 CALL dorm2r( 'L', 'N', 0, 1, 1, a, 1, x, af, 1, w, info )
305 CALL chkxer( 'DORM2R', infot, nout, lerr, ok )
306 infot = 5
307 CALL dorm2r( 'R', 'N', 1, 0, 1, a, 1, x, af, 1, w, info )
308 CALL chkxer( 'DORM2R', infot, nout, lerr, ok )
309 infot = 7
310 CALL dorm2r( 'L', 'N', 2, 1, 0, a, 1, x, af, 2, w, info )
311 CALL chkxer( 'DORM2R', infot, nout, lerr, ok )
312 infot = 7
313 CALL dorm2r( 'R', 'N', 1, 2, 0, a, 1, x, af, 1, w, info )
314 CALL chkxer( 'DORM2R', infot, nout, lerr, ok )
315 infot = 10
316 CALL dorm2r( 'L', 'N', 2, 1, 0, a, 2, x, af, 1, w, info )
317 CALL chkxer( 'DORM2R', infot, nout, lerr, ok )
318*
319* Print a summary line.
320*
321 CALL alaesm( path, ok, nout )
322*
323 RETURN
324*
325* End of DERRQR
326*
dgeqr2p
subroutine dgeqr2p(m, n, a, lda, tau, work, info)
DGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagonal elem...
Definition dgeqr2p.f:134
dgeqrfp
subroutine dgeqrfp(m, n, a, lda, tau, work, lwork, info)
DGEQRFP
Definition dgeqrfp.f:149
dorm2r
subroutine dorm2r(side, trans, m, n, k, a, lda, tau, c, ldc, work, info)
DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sge...
Definition dorm2r.f:159
dormqr
subroutine dormqr(side, trans, m, n, k, a, lda, tau, c, ldc, work, lwork, info)
DORMQR
Definition dormqr.f:167
dorg2r
subroutine dorg2r(m, n, k, a, lda, tau, work, info)
DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf ...
Definition dorg2r.f:114
dorgqr
subroutine dorgqr(m, n, k, a, lda, tau, work, lwork, info)
DORGQR
Definition dorgqr.f:128

◆ derrqrt()

subroutine derrqrt ( character*3 path,
integer nunit )

DERRQRT

Purpose:
!>
!> DERRQRT tests the error exits for the DOUBLE PRECISION 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 derrqrt.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 DOUBLE PRECISION A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
77 $ C( NMAX, NMAX )
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, dgeqrt2, dgeqrt3, dgeqrt,
81 $ dgemqrt
82* ..
83* .. Scalars in Common ..
84 LOGICAL LERR, OK
85 CHARACTER*32 SRNAMT
86 INTEGER INFOT, NOUT
87* ..
88* .. Common blocks ..
89 COMMON / infoc / infot, nout, ok, lerr
90 COMMON / srnamc / srnamt
91* ..
92* .. Intrinsic Functions ..
93 INTRINSIC dble
94* ..
95* .. Executable Statements ..
96*
97 nout = nunit
98 WRITE( nout, fmt = * )
99*
100* Set the variables to innocuous values.
101*
102 DO j = 1, nmax
103 DO i = 1, nmax
104 a( i, j ) = 1.d0 / dble( i+j )
105 c( i, j ) = 1.d0 / dble( i+j )
106 t( i, j ) = 1.d0 / dble( i+j )
107 END DO
108 w( j ) = 0.d0
109 END DO
110 ok = .true.
111*
112* Error exits for QRT factorization
113*
114* DGEQRT
115*
116 srnamt = 'DGEQRT'
117 infot = 1
118 CALL dgeqrt( -1, 0, 1, a, 1, t, 1, w, info )
119 CALL chkxer( 'DGEQRT', infot, nout, lerr, ok )
120 infot = 2
121 CALL dgeqrt( 0, -1, 1, a, 1, t, 1, w, info )
122 CALL chkxer( 'DGEQRT', infot, nout, lerr, ok )
123 infot = 3
124 CALL dgeqrt( 0, 0, 0, a, 1, t, 1, w, info )
125 CALL chkxer( 'DGEQRT', infot, nout, lerr, ok )
126 infot = 5
127 CALL dgeqrt( 2, 1, 1, a, 1, t, 1, w, info )
128 CALL chkxer( 'DGEQRT', infot, nout, lerr, ok )
129 infot = 7
130 CALL dgeqrt( 2, 2, 2, a, 2, t, 1, w, info )
131 CALL chkxer( 'DGEQRT', infot, nout, lerr, ok )
132*
133* DGEQRT2
134*
135 srnamt = 'DGEQRT2'
136 infot = 1
137 CALL dgeqrt2( -1, 0, a, 1, t, 1, info )
138 CALL chkxer( 'DGEQRT2', infot, nout, lerr, ok )
139 infot = 2
140 CALL dgeqrt2( 0, -1, a, 1, t, 1, info )
141 CALL chkxer( 'DGEQRT2', infot, nout, lerr, ok )
142 infot = 4
143 CALL dgeqrt2( 2, 1, a, 1, t, 1, info )
144 CALL chkxer( 'DGEQRT2', infot, nout, lerr, ok )
145 infot = 6
146 CALL dgeqrt2( 2, 2, a, 2, t, 1, info )
147 CALL chkxer( 'DGEQRT2', infot, nout, lerr, ok )
148*
149* DGEQRT3
150*
151 srnamt = 'DGEQRT3'
152 infot = 1
153 CALL dgeqrt3( -1, 0, a, 1, t, 1, info )
154 CALL chkxer( 'DGEQRT3', infot, nout, lerr, ok )
155 infot = 2
156 CALL dgeqrt3( 0, -1, a, 1, t, 1, info )
157 CALL chkxer( 'DGEQRT3', infot, nout, lerr, ok )
158 infot = 4
159 CALL dgeqrt3( 2, 1, a, 1, t, 1, info )
160 CALL chkxer( 'DGEQRT3', infot, nout, lerr, ok )
161 infot = 6
162 CALL dgeqrt3( 2, 2, a, 2, t, 1, info )
163 CALL chkxer( 'DGEQRT3', infot, nout, lerr, ok )
164*
165* DGEMQRT
166*
167 srnamt = 'DGEMQRT'
168 infot = 1
169 CALL dgemqrt( '/', 'N', 0, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
170 CALL chkxer( 'DGEMQRT', infot, nout, lerr, ok )
171 infot = 2
172 CALL dgemqrt( 'L', '/', 0, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
173 CALL chkxer( 'DGEMQRT', infot, nout, lerr, ok )
174 infot = 3
175 CALL dgemqrt( 'L', 'N', -1, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
176 CALL chkxer( 'DGEMQRT', infot, nout, lerr, ok )
177 infot = 4
178 CALL dgemqrt( 'L', 'N', 0, -1, 0, 1, a, 1, t, 1, c, 1, w, info )
179 CALL chkxer( 'DGEMQRT', infot, nout, lerr, ok )
180 infot = 5
181 CALL dgemqrt( 'L', 'N', 0, 0, -1, 1, a, 1, t, 1, c, 1, w, info )
182 CALL chkxer( 'DGEMQRT', infot, nout, lerr, ok )
183 infot = 5
184 CALL dgemqrt( 'R', 'N', 0, 0, -1, 1, a, 1, t, 1, c, 1, w, info )
185 CALL chkxer( 'DGEMQRT', infot, nout, lerr, ok )
186 infot = 6
187 CALL dgemqrt( 'L', 'N', 0, 0, 0, 0, a, 1, t, 1, c, 1, w, info )
188 CALL chkxer( 'DGEMQRT', infot, nout, lerr, ok )
189 infot = 8
190 CALL dgemqrt( 'R', 'N', 1, 2, 1, 1, a, 1, t, 1, c, 1, w, info )
191 CALL chkxer( 'DGEMQRT', infot, nout, lerr, ok )
192 infot = 8
193 CALL dgemqrt( 'L', 'N', 2, 1, 1, 1, a, 1, t, 1, c, 1, w, info )
194 CALL chkxer( 'DGEMQRT', infot, nout, lerr, ok )
195 infot = 10
196 CALL dgemqrt( 'R', 'N', 1, 1, 1, 1, a, 1, t, 0, c, 1, w, info )
197 CALL chkxer( 'DGEMQRT', infot, nout, lerr, ok )
198 infot = 12
199 CALL dgemqrt( 'L', 'N', 1, 1, 1, 1, a, 1, t, 1, c, 0, w, info )
200 CALL chkxer( 'DGEMQRT', infot, nout, lerr, ok )
201*
202* Print a summary line.
203*
204 CALL alaesm( path, ok, nout )
205*
206 RETURN
207*
208* End of DERRQRT
209*
dgeqrt3
recursive subroutine dgeqrt3(m, n, a, lda, t, ldt, info)
DGEQRT3 recursively computes a QR factorization of a general real or complex matrix using the compact...
Definition dgeqrt3.f:132
dgeqrt
subroutine dgeqrt(m, n, nb, a, lda, t, ldt, work, info)
DGEQRT
Definition dgeqrt.f:141
dgemqrt
subroutine dgemqrt(side, trans, m, n, k, nb, v, ldv, t, ldt, c, ldc, work, info)
DGEMQRT
Definition dgemqrt.f:168
dgeqrt2
subroutine dgeqrt2(m, n, a, lda, t, ldt, info)
DGEQRT2 computes a QR factorization of a general real or complex matrix using the compact WY represen...
Definition dgeqrt2.f:127

◆ derrqrtp()

subroutine derrqrtp ( character*3 path,
integer nunit )

DERRQRTP

Purpose:
!>
!> DERRQRTP 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 derrqrtp.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 DOUBLE PRECISION A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
77 $ B( NMAX, NMAX ), C( NMAX, NMAX )
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, dtpqrt2, dtpqrt,
81 $ dtpmqrt
82* ..
83* .. Scalars in Common ..
84 LOGICAL LERR, OK
85 CHARACTER*32 SRNAMT
86 INTEGER INFOT, NOUT
87* ..
88* .. Common blocks ..
89 COMMON / infoc / infot, nout, ok, lerr
90 COMMON / srnamc / srnamt
91* ..
92* .. Intrinsic Functions ..
93 INTRINSIC dble
94* ..
95* .. Executable Statements ..
96*
97 nout = nunit
98 WRITE( nout, fmt = * )
99*
100* Set the variables to innocuous values.
101*
102 DO j = 1, nmax
103 DO i = 1, nmax
104 a( i, j ) = 1.d0 / dble( i+j )
105 c( i, j ) = 1.d0 / dble( i+j )
106 t( i, j ) = 1.d0 / dble( i+j )
107 END DO
108 w( j ) = 0.0
109 END DO
110 ok = .true.
111*
112* Error exits for TPQRT factorization
113*
114* DTPQRT
115*
116 srnamt = 'DTPQRT'
117 infot = 1
118 CALL dtpqrt( -1, 1, 0, 1, a, 1, b, 1, t, 1, w, info )
119 CALL chkxer( 'DTPQRT', infot, nout, lerr, ok )
120 infot = 2
121 CALL dtpqrt( 1, -1, 0, 1, a, 1, b, 1, t, 1, w, info )
122 CALL chkxer( 'DTPQRT', infot, nout, lerr, ok )
123 infot = 3
124 CALL dtpqrt( 0, 1, -1, 1, a, 1, b, 1, t, 1, w, info )
125 CALL chkxer( 'DTPQRT', infot, nout, lerr, ok )
126 infot = 3
127 CALL dtpqrt( 0, 1, 1, 1, a, 1, b, 1, t, 1, w, info )
128 CALL chkxer( 'DTPQRT', infot, nout, lerr, ok )
129 infot = 4
130 CALL dtpqrt( 0, 1, 0, 0, a, 1, b, 1, t, 1, w, info )
131 CALL chkxer( 'DTPQRT', infot, nout, lerr, ok )
132 infot = 4
133 CALL dtpqrt( 0, 1, 0, 2, a, 1, b, 1, t, 1, w, info )
134 CALL chkxer( 'DTPQRT', infot, nout, lerr, ok )
135 infot = 6
136 CALL dtpqrt( 1, 2, 0, 2, a, 1, b, 1, t, 1, w, info )
137 CALL chkxer( 'DTPQRT', infot, nout, lerr, ok )
138 infot = 8
139 CALL dtpqrt( 2, 1, 0, 1, a, 1, b, 1, t, 1, w, info )
140 CALL chkxer( 'DTPQRT', infot, nout, lerr, ok )
141 infot = 10
142 CALL dtpqrt( 2, 2, 1, 2, a, 2, b, 2, t, 1, w, info )
143 CALL chkxer( 'DTPQRT', infot, nout, lerr, ok )
144*
145* DTPQRT2
146*
147 srnamt = 'DTPQRT2'
148 infot = 1
149 CALL dtpqrt2( -1, 0, 0, a, 1, b, 1, t, 1, info )
150 CALL chkxer( 'DTPQRT2', infot, nout, lerr, ok )
151 infot = 2
152 CALL dtpqrt2( 0, -1, 0, a, 1, b, 1, t, 1, info )
153 CALL chkxer( 'DTPQRT2', infot, nout, lerr, ok )
154 infot = 3
155 CALL dtpqrt2( 0, 0, -1, a, 1, b, 1, t, 1, info )
156 CALL chkxer( 'DTPQRT2', infot, nout, lerr, ok )
157 infot = 5
158 CALL dtpqrt2( 2, 2, 0, a, 1, b, 2, t, 2, info )
159 CALL chkxer( 'DTPQRT2', infot, nout, lerr, ok )
160 infot = 7
161 CALL dtpqrt2( 2, 2, 0, a, 2, b, 1, t, 2, info )
162 CALL chkxer( 'DTPQRT2', infot, nout, lerr, ok )
163 infot = 9
164 CALL dtpqrt2( 2, 2, 0, a, 2, b, 2, t, 1, info )
165 CALL chkxer( 'DTPQRT2', infot, nout, lerr, ok )
166*
167* DTPMQRT
168*
169 srnamt = 'DTPMQRT'
170 infot = 1
171 CALL dtpmqrt( '/', 'N', 0, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
172 $ w, info )
173 CALL chkxer( 'DTPMQRT', infot, nout, lerr, ok )
174 infot = 2
175 CALL dtpmqrt( 'L', '/', 0, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
176 $ w, info )
177 CALL chkxer( 'DTPMQRT', infot, nout, lerr, ok )
178 infot = 3
179 CALL dtpmqrt( 'L', 'N', -1, 0, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
180 $ w, info )
181 CALL chkxer( 'DTPMQRT', infot, nout, lerr, ok )
182 infot = 4
183 CALL dtpmqrt( 'L', 'N', 0, -1, 0, 0, 1, a, 1, t, 1, b, 1, c, 1,
184 $ w, info )
185 CALL chkxer( 'DTPMQRT', infot, nout, lerr, ok )
186 infot = 5
187 CALL dtpmqrt( 'L', 'N', 0, 0, -1, 0, 1, a, 1, t, 1, b, 1, c, 1,
188 $ w, info )
189 infot = 6
190 CALL dtpmqrt( 'L', 'N', 0, 0, 0, -1, 1, a, 1, t, 1, b, 1, c, 1,
191 $ w, info )
192 CALL chkxer( 'DTPMQRT', infot, nout, lerr, ok )
193 infot = 7
194 CALL dtpmqrt( 'L', 'N', 0, 0, 0, 0, 0, a, 1, t, 1, b, 1, c, 1,
195 $ w, info )
196 CALL chkxer( 'DTPMQRT', infot, nout, lerr, ok )
197 infot = 9
198 CALL dtpmqrt( 'R', 'N', 1, 2, 1, 1, 1, a, 1, t, 1, b, 1, c, 1,
199 $ w, info )
200 CALL chkxer( 'DTPMQRT', infot, nout, lerr, ok )
201 infot = 9
202 CALL dtpmqrt( 'L', 'N', 2, 1, 1, 1, 1, a, 1, t, 1, b, 1, c, 1,
203 $ w, info )
204 CALL chkxer( 'DTPMQRT', infot, nout, lerr, ok )
205 infot = 11
206 CALL dtpmqrt( 'R', 'N', 1, 1, 1, 1, 1, a, 1, t, 0, b, 1, c, 1,
207 $ w, info )
208 CALL chkxer( 'DTPMQRT', infot, nout, lerr, ok )
209 infot = 13
210 CALL dtpmqrt( 'L', 'N', 1, 1, 1, 1, 1, a, 1, t, 1, b, 0, c, 1,
211 $ w, info )
212 CALL chkxer( 'DTPMQRT', infot, nout, lerr, ok )
213 infot = 15
214 CALL dtpmqrt( 'L', 'N', 1, 1, 1, 1, 1, a, 1, t, 1, b, 1, c, 0,
215 $ w, info )
216 CALL chkxer( 'DTPMQRT', infot, nout, lerr, ok )
217*
218* Print a summary line.
219*
220 CALL alaesm( path, ok, nout )
221*
222 RETURN
223*
224* End of DERRQRTP
225*
dtpqrt2
subroutine dtpqrt2(m, n, l, a, lda, b, ldb, t, ldt, info)
DTPQRT2 computes a QR factorization of a real or complex "triangular-pentagonal" matrix,...
Definition dtpqrt2.f:173
dtpmqrt
subroutine dtpmqrt(side, trans, m, n, k, l, nb, v, ldv, t, ldt, a, lda, b, ldb, work, info)
DTPMQRT
Definition dtpmqrt.f:216
dtpqrt
subroutine dtpqrt(m, n, l, nb, a, lda, b, ldb, t, ldt, work, info)
DTPQRT
Definition dtpqrt.f:189

◆ derrrfp()

subroutine derrrfp ( integer nunit)

DERRRFP

Purpose:
!>
!> DERRRFP tests the error exits for the DOUBLE PRECISION driver routines
!> for solving linear systems of equations.
!>
!> DDRVRFP tests the DOUBLE PRECISION LAPACK RFP routines:
!>     DTFSM, DTFTRI, DSFRK, DTFTTP, DTFTTR, DPFTRF, DPFTRS, DTPTTF,
!>     DTPTTR, DTRTTF, and DTRTTP
!>
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 derrrfp.f.

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

◆ derrrq()

subroutine derrrq ( character*3 path,
integer nunit )

DERRRQ

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

◆ derrsy()

subroutine derrsy ( character*3 path,
integer nunit )

DERRSY

DERRSYX

Purpose:
!>
!> DERRSY tests the error exits for the DOUBLE PRECISION 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:
!>
!> DERRSY tests the error exits for the DOUBLE PRECISION routines
!> for symmetric indefinite matrices.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise derrsy.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 derrsy.f.

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

◆ derrtr()

subroutine derrtr ( character*3 path,
integer nunit )

DERRTR

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

◆ derrtsqr()

subroutine derrtsqr ( character*3 path,
integer nunit )

DERRTSQR

Purpose:
!>
!> DERRTSQR tests the error exits for the DOUBLE PRECISION routines
!> that use the TSQR 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 derrtsqr.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, MB, NB
74* ..
75* .. Local Arrays ..
76 DOUBLE PRECISION A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
77 $ C( NMAX, NMAX ), TAU(NMAX*2)
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, dgeqr,
81 $ dgemqr, dgelq, dgemlq
82* ..
83* .. Scalars in Common ..
84 LOGICAL LERR, OK
85 CHARACTER*32 SRNAMT
86 INTEGER INFOT, NOUT
87* ..
88* .. Common blocks ..
89 COMMON / infoc / infot, nout, ok, lerr
90 COMMON / srnamc / srnamt
91* ..
92* .. Intrinsic Functions ..
93 INTRINSIC dble
94* ..
95* .. Executable Statements ..
96*
97 nout = nunit
98 WRITE( nout, fmt = * )
99*
100* Set the variables to innocuous values.
101*
102 DO j = 1, nmax
103 DO i = 1, nmax
104 a( i, j ) = 1.d0 / dble( i+j )
105 c( i, j ) = 1.d0 / dble( i+j )
106 t( i, j ) = 1.d0 / dble( i+j )
107 END DO
108 w( j ) = 0.d0
109 END DO
110 ok = .true.
111*
112* Error exits for TS factorization
113*
114* DGEQR
115*
116 srnamt = 'DGEQR'
117 infot = 1
118 CALL dgeqr( -1, 0, a, 1, tau, 1, w, 1, info )
119 CALL chkxer( 'DGEQR', infot, nout, lerr, ok )
120 infot = 2
121 CALL dgeqr( 0, -1, a, 1, tau, 1, w, 1, info )
122 CALL chkxer( 'DGEQR', infot, nout, lerr, ok )
123 infot = 4
124 CALL dgeqr( 1, 1, a, 0, tau, 1, w, 1, info )
125 CALL chkxer( 'DGEQR', infot, nout, lerr, ok )
126 infot = 6
127 CALL dgeqr( 3, 2, a, 3, tau, 1, w, 1, info )
128 CALL chkxer( 'DGEQR', infot, nout, lerr, ok )
129 infot = 8
130 CALL dgeqr( 3, 2, a, 3, tau, 7, w, 0, info )
131 CALL chkxer( 'DGEQR', infot, nout, lerr, ok )
132*
133* DLATSQR
134*
135 mb = 1
136 nb = 1
137 srnamt = 'DLATSQR'
138 infot = 1
139 CALL dlatsqr( -1, 0, mb, nb, a, 1, tau, 1, w, 1, info )
140 CALL chkxer( 'DLATSQR', infot, nout, lerr, ok )
141 infot = 2
142 CALL dlatsqr( 1, 2, mb, nb, a, 1, tau, 1, w, 1, info )
143 CALL chkxer( 'DLATSQR', infot, nout, lerr, ok )
144 CALL dlatsqr( 0, -1, mb, nb, a, 1, tau, 1, w, 1, info )
145 CALL chkxer( 'DLATSQR', infot, nout, lerr, ok )
146 infot = 3
147 CALL dlatsqr( 2, 1, -1, nb, a, 2, tau, 1, w, 1, info )
148 CALL chkxer( 'DLATSQR', infot, nout, lerr, ok )
149 infot = 4
150 CALL dlatsqr( 2, 1, mb, 2, a, 2, tau, 1, w, 1, info )
151 CALL chkxer( 'DLATSQR', infot, nout, lerr, ok )
152 infot = 6
153 CALL dlatsqr( 2, 1, mb, nb, a, 1, tau, 1, w, 1, info )
154 CALL chkxer( 'DLATSQR', infot, nout, lerr, ok )
155 infot = 8
156 CALL dlatsqr( 2, 1, mb, nb, a, 2, tau, 0, w, 1, info )
157 CALL chkxer( 'DLATSQR', infot, nout, lerr, ok )
158 infot = 10
159 CALL dlatsqr( 2, 1, mb, nb, a, 2, tau, 2, w, 0, info )
160 CALL chkxer( 'DLATSQR', infot, nout, lerr, ok )
161*
162* DGEMQR
163*
164 tau(1)=1
165 tau(2)=1
166 tau(3)=1
167 tau(4)=1
168 srnamt = 'DGEMQR'
169 nb=1
170 infot = 1
171 CALL dgemqr( '/', 'N', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
172 CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
173 infot = 2
174 CALL dgemqr( 'L', '/', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
175 CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
176 infot = 3
177 CALL dgemqr( 'L', 'N', -1, 0, 0, a, 1, tau, 1, c, 1, w,1,info)
178 CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
179 infot = 4
180 CALL dgemqr( 'L', 'N', 0, -1, 0, a, 1, tau, 1, c, 1, w,1,info)
181 CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
182 infot = 5
183 CALL dgemqr( 'L', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
184 CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
185 infot = 5
186 CALL dgemqr( 'R', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
187 CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
188 infot = 7
189 CALL dgemqr( 'L', 'N', 2, 1, 0, a, 0, tau, 1, c, 1, w, 1,info)
190 CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
191 infot = 9
192 CALL dgemqr( 'R', 'N', 2, 2, 1, a, 2, tau, 0, c, 1, w, 1,info)
193 CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
194 infot = 9
195 CALL dgemqr( 'L', 'N', 2, 2, 1, a, 2, tau, 0, c, 1, w, 1,info)
196 CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
197 infot = 11
198 CALL dgemqr( 'L', 'N', 2, 1, 1, a, 2, tau, 6, c, 0, w, 1,info)
199 CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
200 infot = 13
201 CALL dgemqr( 'L', 'N', 2, 2, 1, a, 2, tau, 6, c, 2, w, 0,info)
202 CALL chkxer( 'DGEMQR', infot, nout, lerr, ok )
203*
204* DGELQ
205*
206 srnamt = 'DGELQ'
207 infot = 1
208 CALL dgelq( -1, 0, a, 1, tau, 1, w, 1, info )
209 CALL chkxer( 'DGELQ', infot, nout, lerr, ok )
210 infot = 2
211 CALL dgelq( 0, -1, a, 1, tau, 1, w, 1, info )
212 CALL chkxer( 'DGELQ', infot, nout, lerr, ok )
213 infot = 4
214 CALL dgelq( 1, 1, a, 0, tau, 1, w, 1, info )
215 CALL chkxer( 'DGELQ', infot, nout, lerr, ok )
216 infot = 6
217 CALL dgelq( 2, 3, a, 3, tau, 1, w, 1, info )
218 CALL chkxer( 'DGELQ', infot, nout, lerr, ok )
219 infot = 8
220 CALL dgelq( 2, 3, a, 3, tau, 7, w, 0, info )
221 CALL chkxer( 'DGELQ', infot, nout, lerr, ok )
222*
223* DLASWLQ
224*
225 mb = 1
226 nb = 1
227 srnamt = 'DLASWLQ'
228 infot = 1
229 CALL dlaswlq( -1, 0, mb, nb, a, 1, tau, 1, w, 1, info )
230 CALL chkxer( 'DLASWLQ', infot, nout, lerr, ok )
231 infot = 2
232 CALL dlaswlq( 2, 1, mb, nb, a, 1, tau, 1, w, 1, info )
233 CALL chkxer( 'DLASWLQ', infot, nout, lerr, ok )
234 CALL dlaswlq( 0, -1, mb, nb, a, 1, tau, 1, w, 1, info )
235 CALL chkxer( 'DLASWLQ', infot, nout, lerr, ok )
236 infot = 3
237 CALL dlaswlq( 1, 2, -1, nb, a, 1, tau, 1, w, 1, info )
238 CALL chkxer( 'DLASWLQ', infot, nout, lerr, ok )
239 CALL dlaswlq( 1, 1, 2, nb, a, 1, tau, 1, w, 1, info )
240 CALL chkxer( 'DLASWLQ', infot, nout, lerr, ok )
241 infot = 4
242 CALL dlaswlq( 1, 2, mb, -1, a, 1, tau, 1, w, 1, info )
243 CALL chkxer( 'DLASWLQ', infot, nout, lerr, ok )
244 infot = 6
245 CALL dlaswlq( 1, 2, mb, nb, a, 0, tau, 1, w, 1, info )
246 CALL chkxer( 'DLASWLQ', infot, nout, lerr, ok )
247 infot = 8
248 CALL dlaswlq( 1, 2, mb, nb, a, 1, tau, 0, w, 1, info )
249 CALL chkxer( 'DLASWLQ', infot, nout, lerr, ok )
250 infot = 10
251 CALL dlaswlq( 1, 2, mb, nb, a, 1, tau, 1, w, 0, info )
252 CALL chkxer( 'DLASWLQ', infot, nout, lerr, ok )
253*
254* DGEMLQ
255*
256 tau(1)=1
257 tau(2)=1
258 srnamt = 'DGEMLQ'
259 nb=1
260 infot = 1
261 CALL dgemlq( '/', 'N', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
262 CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
263 infot = 2
264 CALL dgemlq( 'L', '/', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
265 CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
266 infot = 3
267 CALL dgemlq( 'L', 'N', -1, 0, 0, a, 1, tau, 1, c, 1, w,1,info)
268 CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
269 infot = 4
270 CALL dgemlq( 'L', 'N', 0, -1, 0, a, 1, tau, 1, c, 1, w,1,info)
271 CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
272 infot = 5
273 CALL dgemlq( 'L', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
274 CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
275 infot = 5
276 CALL dgemlq( 'R', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
277 CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
278 infot = 7
279 CALL dgemlq( 'L', 'N', 1, 2, 0, a, 0, tau, 1, c, 1, w, 1,info)
280 CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
281 infot = 9
282 CALL dgemlq( 'R', 'N', 2, 2, 1, a, 1, tau, 0, c, 1, w, 1,info)
283 CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
284 infot = 9
285 CALL dgemlq( 'L', 'N', 2, 2, 1, a, 1, tau, 0, c, 1, w, 1,info)
286 CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
287 infot = 11
288 CALL dgemlq( 'L', 'N', 1, 2, 1, a, 1, tau, 6, c, 0, w, 1,info)
289 CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
290 infot = 13
291 CALL dgemlq( 'L', 'N', 2, 2, 1, a, 2, tau, 6, c, 2, w, 0,info)
292 CALL chkxer( 'DGEMLQ', infot, nout, lerr, ok )
293*
294* Print a summary line.
295*
296 CALL alaesm( path, ok, nout )
297*
298 RETURN
299*
300* End of DERRTSQR
301*
dgelq
subroutine dgelq(m, n, a, lda, t, tsize, work, lwork, info)
DGELQ
Definition dgelq.f:172
dgemlq
subroutine dgemlq(side, trans, m, n, k, a, lda, t, tsize, c, ldc, work, lwork, info)
DGEMLQ
Definition dgemlq.f:171
dgemqr
subroutine dgemqr(side, trans, m, n, k, a, lda, t, tsize, c, ldc, work, lwork, info)
DGEMQR
Definition dgemqr.f:172
dgeqr
subroutine dgeqr(m, n, a, lda, t, tsize, work, lwork, info)
DGEQR
Definition dgeqr.f:174
dlaswlq
subroutine dlaswlq(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
DLASWLQ
Definition dlaswlq.f:164
dlatsqr
subroutine dlatsqr(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
DLATSQR
Definition dlatsqr.f:166

◆ derrtz()

subroutine derrtz ( character*3 path,
integer nunit )

DERRTZ

Purpose:
!>
!> DERRTZ tests the error exits for STZRZF.
!>
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 derrtz.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 DOUBLE PRECISION 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, dtzrzf
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* .. Executable Statements ..
94*
95 nout = nunit
96 WRITE( nout, fmt = * )
97 c2 = path( 2: 3 )
98 a( 1, 1 ) = 1.d+0
99 a( 1, 2 ) = 2.d+0
100 a( 2, 2 ) = 3.d+0
101 a( 2, 1 ) = 4.d+0
102 w( 1 ) = 0.0d+0
103 w( 2 ) = 0.0d+0
104 ok = .true.
105*
106 IF( lsamen( 2, c2, 'TZ' ) ) THEN
107*
108* Test error exits for the trapezoidal routines.
109*
110* DTZRZF
111*
112 srnamt = 'DTZRZF'
113 infot = 1
114 CALL dtzrzf( -1, 0, a, 1, tau, w, 1, info )
115 CALL chkxer( 'DTZRZF', infot, nout, lerr, ok )
116 infot = 2
117 CALL dtzrzf( 1, 0, a, 1, tau, w, 1, info )
118 CALL chkxer( 'DTZRZF', infot, nout, lerr, ok )
119 infot = 4
120 CALL dtzrzf( 2, 2, a, 1, tau, w, 1, info )
121 CALL chkxer( 'DTZRZF', infot, nout, lerr, ok )
122 infot = 7
123 CALL dtzrzf( 2, 2, a, 2, tau, w, 0, info )
124 CALL chkxer( 'DTZRZF', infot, nout, lerr, ok )
125 infot = 7
126 CALL dtzrzf( 2, 3, a, 2, tau, w, 1, info )
127 CALL chkxer( 'DTZRZF', infot, nout, lerr, ok )
128 END IF
129*
130* Print a summary line.
131*
132 CALL alaesm( path, ok, nout )
133*
134 RETURN
135*
136* End of DERRTZ
137*

◆ derrvx()

subroutine derrvx ( character*3 path,
integer nunit )

DERRVX

DERRVXX

Purpose:
!>
!> DERRVX tests the error exits for the DOUBLE PRECISION 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 derrvx.f.

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX
69 parameter( nmax = 4 )
70* ..
71* .. Local Scalars ..
72 CHARACTER EQ
73 CHARACTER*2 C2
74 INTEGER I, INFO, J
75 DOUBLE PRECISION RCOND
76* ..
77* .. Local Arrays ..
78 INTEGER IP( NMAX ), IW( NMAX )
79 DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ),
80 $ C( NMAX ), E( NMAX ), R( NMAX ), R1( NMAX ),
81 $ R2( NMAX ), W( 2*NMAX ), X( NMAX )
82* ..
83* .. External Functions ..
84 LOGICAL LSAMEN
85 EXTERNAL lsamen
86* ..
87* .. External Subroutines ..
88 EXTERNAL chkxer, dgbsv, dgbsvx, dgesv, dgesvx, dgtsv,
89 $ dgtsvx, dpbsv, dpbsvx, dposv, dposvx, dppsv,
90 $ dppsvx, dptsv, dptsvx, dspsv, dspsvx, dsysv,
91 $ dsysv_aa, dsysv_rk, dsysv_rook, dsysvx,
92 $ dsysv_aa_2stage
93* ..
94* .. Scalars in Common ..
95 LOGICAL LERR, OK
96 CHARACTER*32 SRNAMT
97 INTEGER INFOT, NOUT
98* ..
99* .. Common blocks ..
100 COMMON / infoc / infot, nout, ok, lerr
101 COMMON / srnamc / srnamt
102* ..
103* .. Intrinsic Functions ..
104 INTRINSIC dble
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 ) = 1.d0 / dble( i+j )
117 af( i, j ) = 1.d0 / dble( i+j )
118 10 CONTINUE
119 b( j ) = 0.d+0
120 e( j ) = 0.d+0
121 r1( j ) = 0.d+0
122 r2( j ) = 0.d+0
123 w( j ) = 0.d+0
124 x( j ) = 0.d+0
125 c( j ) = 0.d+0
126 r( j ) = 0.d+0
127 ip( j ) = j
128 20 CONTINUE
129 eq = ' '
130 ok = .true.
131*
132 IF( lsamen( 2, c2, 'GE' ) ) THEN
133*
134* DGESV
135*
136 srnamt = 'DGESV '
137 infot = 1
138 CALL dgesv( -1, 0, a, 1, ip, b, 1, info )
139 CALL chkxer( 'DGESV ', infot, nout, lerr, ok )
140 infot = 2
141 CALL dgesv( 0, -1, a, 1, ip, b, 1, info )
142 CALL chkxer( 'DGESV ', infot, nout, lerr, ok )
143 infot = 4
144 CALL dgesv( 2, 1, a, 1, ip, b, 2, info )
145 CALL chkxer( 'DGESV ', infot, nout, lerr, ok )
146 infot = 7
147 CALL dgesv( 2, 1, a, 2, ip, b, 1, info )
148 CALL chkxer( 'DGESV ', infot, nout, lerr, ok )
149*
150* DGESVX
151*
152 srnamt = 'DGESVX'
153 infot = 1
154 CALL dgesvx( '/', 'N', 0, 0, a, 1, af, 1, ip, eq, r, c, b, 1,
155 $ x, 1, rcond, r1, r2, w, iw, info )
156 CALL chkxer( 'DGESVX', infot, nout, lerr, ok )
157 infot = 2
158 CALL dgesvx( 'N', '/', 0, 0, a, 1, af, 1, ip, eq, r, c, b, 1,
159 $ x, 1, rcond, r1, r2, w, iw, info )
160 CALL chkxer( 'DGESVX', infot, nout, lerr, ok )
161 infot = 3
162 CALL dgesvx( 'N', 'N', -1, 0, a, 1, af, 1, ip, eq, r, c, b, 1,
163 $ x, 1, rcond, r1, r2, w, iw, info )
164 CALL chkxer( 'DGESVX', infot, nout, lerr, ok )
165 infot = 4
166 CALL dgesvx( 'N', 'N', 0, -1, a, 1, af, 1, ip, eq, r, c, b, 1,
167 $ x, 1, rcond, r1, r2, w, iw, info )
168 CALL chkxer( 'DGESVX', infot, nout, lerr, ok )
169 infot = 6
170 CALL dgesvx( 'N', 'N', 2, 1, a, 1, af, 2, ip, eq, r, c, b, 2,
171 $ x, 2, rcond, r1, r2, w, iw, info )
172 CALL chkxer( 'DGESVX', infot, nout, lerr, ok )
173 infot = 8
174 CALL dgesvx( 'N', 'N', 2, 1, a, 2, af, 1, ip, eq, r, c, b, 2,
175 $ x, 2, rcond, r1, r2, w, iw, info )
176 CALL chkxer( 'DGESVX', infot, nout, lerr, ok )
177 infot = 10
178 eq = '/'
179 CALL dgesvx( 'F', 'N', 0, 0, a, 1, af, 1, ip, eq, r, c, b, 1,
180 $ x, 1, rcond, r1, r2, w, iw, info )
181 CALL chkxer( 'DGESVX', infot, nout, lerr, ok )
182 infot = 11
183 eq = 'R'
184 CALL dgesvx( 'F', 'N', 1, 0, a, 1, af, 1, ip, eq, r, c, b, 1,
185 $ x, 1, rcond, r1, r2, w, iw, info )
186 CALL chkxer( 'DGESVX', infot, nout, lerr, ok )
187 infot = 12
188 eq = 'C'
189 CALL dgesvx( 'F', 'N', 1, 0, a, 1, af, 1, ip, eq, r, c, b, 1,
190 $ x, 1, rcond, r1, r2, w, iw, info )
191 CALL chkxer( 'DGESVX', infot, nout, lerr, ok )
192 infot = 14
193 CALL dgesvx( 'N', 'N', 2, 1, a, 2, af, 2, ip, eq, r, c, b, 1,
194 $ x, 2, rcond, r1, r2, w, iw, info )
195 CALL chkxer( 'DGESVX', infot, nout, lerr, ok )
196 infot = 16
197 CALL dgesvx( 'N', 'N', 2, 1, a, 2, af, 2, ip, eq, r, c, b, 2,
198 $ x, 1, rcond, r1, r2, w, iw, info )
199 CALL chkxer( 'DGESVX', infot, nout, lerr, ok )
200*
201 ELSE IF( lsamen( 2, c2, 'GB' ) ) THEN
202*
203* DGBSV
204*
205 srnamt = 'DGBSV '
206 infot = 1
207 CALL dgbsv( -1, 0, 0, 0, a, 1, ip, b, 1, info )
208 CALL chkxer( 'DGBSV ', infot, nout, lerr, ok )
209 infot = 2
210 CALL dgbsv( 1, -1, 0, 0, a, 1, ip, b, 1, info )
211 CALL chkxer( 'DGBSV ', infot, nout, lerr, ok )
212 infot = 3
213 CALL dgbsv( 1, 0, -1, 0, a, 1, ip, b, 1, info )
214 CALL chkxer( 'DGBSV ', infot, nout, lerr, ok )
215 infot = 4
216 CALL dgbsv( 0, 0, 0, -1, a, 1, ip, b, 1, info )
217 CALL chkxer( 'DGBSV ', infot, nout, lerr, ok )
218 infot = 6
219 CALL dgbsv( 1, 1, 1, 0, a, 3, ip, b, 1, info )
220 CALL chkxer( 'DGBSV ', infot, nout, lerr, ok )
221 infot = 9
222 CALL dgbsv( 2, 0, 0, 0, a, 1, ip, b, 1, info )
223 CALL chkxer( 'DGBSV ', infot, nout, lerr, ok )
224*
225* DGBSVX
226*
227 srnamt = 'DGBSVX'
228 infot = 1
229 CALL dgbsvx( '/', 'N', 0, 0, 0, 0, a, 1, af, 1, ip, eq, r, c,
230 $ b, 1, x, 1, rcond, r1, r2, w, iw, info )
231 CALL chkxer( 'DGBSVX', infot, nout, lerr, ok )
232 infot = 2
233 CALL dgbsvx( 'N', '/', 0, 0, 0, 0, a, 1, af, 1, ip, eq, r, c,
234 $ b, 1, x, 1, rcond, r1, r2, w, iw, info )
235 CALL chkxer( 'DGBSVX', infot, nout, lerr, ok )
236 infot = 3
237 CALL dgbsvx( 'N', 'N', -1, 0, 0, 0, a, 1, af, 1, ip, eq, r, c,
238 $ b, 1, x, 1, rcond, r1, r2, w, iw, info )
239 CALL chkxer( 'DGBSVX', infot, nout, lerr, ok )
240 infot = 4
241 CALL dgbsvx( 'N', 'N', 1, -1, 0, 0, a, 1, af, 1, ip, eq, r, c,
242 $ b, 1, x, 1, rcond, r1, r2, w, iw, info )
243 CALL chkxer( 'DGBSVX', infot, nout, lerr, ok )
244 infot = 5
245 CALL dgbsvx( 'N', 'N', 1, 0, -1, 0, a, 1, af, 1, ip, eq, r, c,
246 $ b, 1, x, 1, rcond, r1, r2, w, iw, info )
247 CALL chkxer( 'DGBSVX', infot, nout, lerr, ok )
248 infot = 6
249 CALL dgbsvx( 'N', 'N', 0, 0, 0, -1, a, 1, af, 1, ip, eq, r, c,
250 $ b, 1, x, 1, rcond, r1, r2, w, iw, info )
251 CALL chkxer( 'DGBSVX', infot, nout, lerr, ok )
252 infot = 8
253 CALL dgbsvx( 'N', 'N', 1, 1, 1, 0, a, 2, af, 4, ip, eq, r, c,
254 $ b, 1, x, 1, rcond, r1, r2, w, iw, info )
255 CALL chkxer( 'DGBSVX', infot, nout, lerr, ok )
256 infot = 10
257 CALL dgbsvx( 'N', 'N', 1, 1, 1, 0, a, 3, af, 3, ip, eq, r, c,
258 $ b, 1, x, 1, rcond, r1, r2, w, iw, info )
259 CALL chkxer( 'DGBSVX', infot, nout, lerr, ok )
260 infot = 12
261 eq = '/'
262 CALL dgbsvx( 'F', 'N', 0, 0, 0, 0, a, 1, af, 1, ip, eq, r, c,
263 $ b, 1, x, 1, rcond, r1, r2, w, iw, info )
264 CALL chkxer( 'DGBSVX', infot, nout, lerr, ok )
265 infot = 13
266 eq = 'R'
267 CALL dgbsvx( 'F', 'N', 1, 0, 0, 0, a, 1, af, 1, ip, eq, r, c,
268 $ b, 1, x, 1, rcond, r1, r2, w, iw, info )
269 CALL chkxer( 'DGBSVX', infot, nout, lerr, ok )
270 infot = 14
271 eq = 'C'
272 CALL dgbsvx( 'F', 'N', 1, 0, 0, 0, a, 1, af, 1, ip, eq, r, c,
273 $ b, 1, x, 1, rcond, r1, r2, w, iw, info )
274 CALL chkxer( 'DGBSVX', infot, nout, lerr, ok )
275 infot = 16
276 CALL dgbsvx( 'N', 'N', 2, 0, 0, 0, a, 1, af, 1, ip, eq, r, c,
277 $ b, 1, x, 2, rcond, r1, r2, w, iw, info )
278 CALL chkxer( 'DGBSVX', infot, nout, lerr, ok )
279 infot = 18
280 CALL dgbsvx( 'N', 'N', 2, 0, 0, 0, a, 1, af, 1, ip, eq, r, c,
281 $ b, 2, x, 1, rcond, r1, r2, w, iw, info )
282 CALL chkxer( 'DGBSVX', infot, nout, lerr, ok )
283*
284 ELSE IF( lsamen( 2, c2, 'GT' ) ) THEN
285*
286* DGTSV
287*
288 srnamt = 'DGTSV '
289 infot = 1
290 CALL dgtsv( -1, 0, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ), b, 1,
291 $ info )
292 CALL chkxer( 'DGTSV ', infot, nout, lerr, ok )
293 infot = 2
294 CALL dgtsv( 0, -1, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ), b, 1,
295 $ info )
296 CALL chkxer( 'DGTSV ', infot, nout, lerr, ok )
297 infot = 7
298 CALL dgtsv( 2, 0, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ), b, 1, info )
299 CALL chkxer( 'DGTSV ', infot, nout, lerr, ok )
300*
301* DGTSVX
302*
303 srnamt = 'DGTSVX'
304 infot = 1
305 CALL dgtsvx( '/', 'N', 0, 0, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ),
306 $ af( 1, 1 ), af( 1, 2 ), af( 1, 3 ), af( 1, 4 ),
307 $ ip, b, 1, x, 1, rcond, r1, r2, w, iw, info )
308 CALL chkxer( 'DGTSVX', infot, nout, lerr, ok )
309 infot = 2
310 CALL dgtsvx( 'N', '/', 0, 0, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ),
311 $ af( 1, 1 ), af( 1, 2 ), af( 1, 3 ), af( 1, 4 ),
312 $ ip, b, 1, x, 1, rcond, r1, r2, w, iw, info )
313 CALL chkxer( 'DGTSVX', infot, nout, lerr, ok )
314 infot = 3
315 CALL dgtsvx( 'N', 'N', -1, 0, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ),
316 $ af( 1, 1 ), af( 1, 2 ), af( 1, 3 ), af( 1, 4 ),
317 $ ip, b, 1, x, 1, rcond, r1, r2, w, iw, info )
318 CALL chkxer( 'DGTSVX', infot, nout, lerr, ok )
319 infot = 4
320 CALL dgtsvx( 'N', 'N', 0, -1, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ),
321 $ af( 1, 1 ), af( 1, 2 ), af( 1, 3 ), af( 1, 4 ),
322 $ ip, b, 1, x, 1, rcond, r1, r2, w, iw, info )
323 CALL chkxer( 'DGTSVX', infot, nout, lerr, ok )
324 infot = 14
325 CALL dgtsvx( 'N', 'N', 2, 0, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ),
326 $ af( 1, 1 ), af( 1, 2 ), af( 1, 3 ), af( 1, 4 ),
327 $ ip, b, 1, x, 2, rcond, r1, r2, w, iw, info )
328 CALL chkxer( 'DGTSVX', infot, nout, lerr, ok )
329 infot = 16
330 CALL dgtsvx( 'N', 'N', 2, 0, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ),
331 $ af( 1, 1 ), af( 1, 2 ), af( 1, 3 ), af( 1, 4 ),
332 $ ip, b, 2, x, 1, rcond, r1, r2, w, iw, info )
333 CALL chkxer( 'DGTSVX', infot, nout, lerr, ok )
334*
335 ELSE IF( lsamen( 2, c2, 'PO' ) ) THEN
336*
337* DPOSV
338*
339 srnamt = 'DPOSV '
340 infot = 1
341 CALL dposv( '/', 0, 0, a, 1, b, 1, info )
342 CALL chkxer( 'DPOSV ', infot, nout, lerr, ok )
343 infot = 2
344 CALL dposv( 'U', -1, 0, a, 1, b, 1, info )
345 CALL chkxer( 'DPOSV ', infot, nout, lerr, ok )
346 infot = 3
347 CALL dposv( 'U', 0, -1, a, 1, b, 1, info )
348 CALL chkxer( 'DPOSV ', infot, nout, lerr, ok )
349 infot = 5
350 CALL dposv( 'U', 2, 0, a, 1, b, 2, info )
351 CALL chkxer( 'DPOSV ', infot, nout, lerr, ok )
352 infot = 7
353 CALL dposv( 'U', 2, 0, a, 2, b, 1, info )
354 CALL chkxer( 'DPOSV ', infot, nout, lerr, ok )
355*
356* DPOSVX
357*
358 srnamt = 'DPOSVX'
359 infot = 1
360 CALL dposvx( '/', 'U', 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
361 $ rcond, r1, r2, w, iw, info )
362 CALL chkxer( 'DPOSVX', infot, nout, lerr, ok )
363 infot = 2
364 CALL dposvx( 'N', '/', 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
365 $ rcond, r1, r2, w, iw, info )
366 CALL chkxer( 'DPOSVX', infot, nout, lerr, ok )
367 infot = 3
368 CALL dposvx( 'N', 'U', -1, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
369 $ rcond, r1, r2, w, iw, info )
370 CALL chkxer( 'DPOSVX', infot, nout, lerr, ok )
371 infot = 4
372 CALL dposvx( 'N', 'U', 0, -1, a, 1, af, 1, eq, c, b, 1, x, 1,
373 $ rcond, r1, r2, w, iw, info )
374 CALL chkxer( 'DPOSVX', infot, nout, lerr, ok )
375 infot = 6
376 CALL dposvx( 'N', 'U', 2, 0, a, 1, af, 2, eq, c, b, 2, x, 2,
377 $ rcond, r1, r2, w, iw, info )
378 CALL chkxer( 'DPOSVX', infot, nout, lerr, ok )
379 infot = 8
380 CALL dposvx( 'N', 'U', 2, 0, a, 2, af, 1, eq, c, b, 2, x, 2,
381 $ rcond, r1, r2, w, iw, info )
382 CALL chkxer( 'DPOSVX', infot, nout, lerr, ok )
383 infot = 9
384 eq = '/'
385 CALL dposvx( 'F', 'U', 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
386 $ rcond, r1, r2, w, iw, info )
387 CALL chkxer( 'DPOSVX', infot, nout, lerr, ok )
388 infot = 10
389 eq = 'Y'
390 CALL dposvx( 'F', 'U', 1, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
391 $ rcond, r1, r2, w, iw, info )
392 CALL chkxer( 'DPOSVX', infot, nout, lerr, ok )
393 infot = 12
394 CALL dposvx( 'N', 'U', 2, 0, a, 2, af, 2, eq, c, b, 1, x, 2,
395 $ rcond, r1, r2, w, iw, info )
396 CALL chkxer( 'DPOSVX', infot, nout, lerr, ok )
397 infot = 14
398 CALL dposvx( 'N', 'U', 2, 0, a, 2, af, 2, eq, c, b, 2, x, 1,
399 $ rcond, r1, r2, w, iw, info )
400 CALL chkxer( 'DPOSVX', infot, nout, lerr, ok )
401*
402 ELSE IF( lsamen( 2, c2, 'PP' ) ) THEN
403*
404* DPPSV
405*
406 srnamt = 'DPPSV '
407 infot = 1
408 CALL dppsv( '/', 0, 0, a, b, 1, info )
409 CALL chkxer( 'DPPSV ', infot, nout, lerr, ok )
410 infot = 2
411 CALL dppsv( 'U', -1, 0, a, b, 1, info )
412 CALL chkxer( 'DPPSV ', infot, nout, lerr, ok )
413 infot = 3
414 CALL dppsv( 'U', 0, -1, a, b, 1, info )
415 CALL chkxer( 'DPPSV ', infot, nout, lerr, ok )
416 infot = 6
417 CALL dppsv( 'U', 2, 0, a, b, 1, info )
418 CALL chkxer( 'DPPSV ', infot, nout, lerr, ok )
419*
420* DPPSVX
421*
422 srnamt = 'DPPSVX'
423 infot = 1
424 CALL dppsvx( '/', 'U', 0, 0, a, af, eq, c, b, 1, x, 1, rcond,
425 $ r1, r2, w, iw, info )
426 CALL chkxer( 'DPPSVX', infot, nout, lerr, ok )
427 infot = 2
428 CALL dppsvx( 'N', '/', 0, 0, a, af, eq, c, b, 1, x, 1, rcond,
429 $ r1, r2, w, iw, info )
430 CALL chkxer( 'DPPSVX', infot, nout, lerr, ok )
431 infot = 3
432 CALL dppsvx( 'N', 'U', -1, 0, a, af, eq, c, b, 1, x, 1, rcond,
433 $ r1, r2, w, iw, info )
434 CALL chkxer( 'DPPSVX', infot, nout, lerr, ok )
435 infot = 4
436 CALL dppsvx( 'N', 'U', 0, -1, a, af, eq, c, b, 1, x, 1, rcond,
437 $ r1, r2, w, iw, info )
438 CALL chkxer( 'DPPSVX', infot, nout, lerr, ok )
439 infot = 7
440 eq = '/'
441 CALL dppsvx( 'F', 'U', 0, 0, a, af, eq, c, b, 1, x, 1, rcond,
442 $ r1, r2, w, iw, info )
443 CALL chkxer( 'DPPSVX', infot, nout, lerr, ok )
444 infot = 8
445 eq = 'Y'
446 CALL dppsvx( 'F', 'U', 1, 0, a, af, eq, c, b, 1, x, 1, rcond,
447 $ r1, r2, w, iw, info )
448 CALL chkxer( 'DPPSVX', infot, nout, lerr, ok )
449 infot = 10
450 CALL dppsvx( 'N', 'U', 2, 0, a, af, eq, c, b, 1, x, 2, rcond,
451 $ r1, r2, w, iw, info )
452 CALL chkxer( 'DPPSVX', infot, nout, lerr, ok )
453 infot = 12
454 CALL dppsvx( 'N', 'U', 2, 0, a, af, eq, c, b, 2, x, 1, rcond,
455 $ r1, r2, w, iw, info )
456 CALL chkxer( 'DPPSVX', infot, nout, lerr, ok )
457*
458 ELSE IF( lsamen( 2, c2, 'PB' ) ) THEN
459*
460* DPBSV
461*
462 srnamt = 'DPBSV '
463 infot = 1
464 CALL dpbsv( '/', 0, 0, 0, a, 1, b, 1, info )
465 CALL chkxer( 'DPBSV ', infot, nout, lerr, ok )
466 infot = 2
467 CALL dpbsv( 'U', -1, 0, 0, a, 1, b, 1, info )
468 CALL chkxer( 'DPBSV ', infot, nout, lerr, ok )
469 infot = 3
470 CALL dpbsv( 'U', 1, -1, 0, a, 1, b, 1, info )
471 CALL chkxer( 'DPBSV ', infot, nout, lerr, ok )
472 infot = 4
473 CALL dpbsv( 'U', 0, 0, -1, a, 1, b, 1, info )
474 CALL chkxer( 'DPBSV ', infot, nout, lerr, ok )
475 infot = 6
476 CALL dpbsv( 'U', 1, 1, 0, a, 1, b, 2, info )
477 CALL chkxer( 'DPBSV ', infot, nout, lerr, ok )
478 infot = 8
479 CALL dpbsv( 'U', 2, 0, 0, a, 1, b, 1, info )
480 CALL chkxer( 'DPBSV ', infot, nout, lerr, ok )
481*
482* DPBSVX
483*
484 srnamt = 'DPBSVX'
485 infot = 1
486 CALL dpbsvx( '/', 'U', 0, 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
487 $ rcond, r1, r2, w, iw, info )
488 CALL chkxer( 'DPBSVX', infot, nout, lerr, ok )
489 infot = 2
490 CALL dpbsvx( 'N', '/', 0, 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
491 $ rcond, r1, r2, w, iw, info )
492 CALL chkxer( 'DPBSVX', infot, nout, lerr, ok )
493 infot = 3
494 CALL dpbsvx( 'N', 'U', -1, 0, 0, a, 1, af, 1, eq, c, b, 1, x,
495 $ 1, rcond, r1, r2, w, iw, info )
496 CALL chkxer( 'DPBSVX', infot, nout, lerr, ok )
497 infot = 4
498 CALL dpbsvx( 'N', 'U', 1, -1, 0, a, 1, af, 1, eq, c, b, 1, x,
499 $ 1, rcond, r1, r2, w, iw, info )
500 CALL chkxer( 'DPBSVX', infot, nout, lerr, ok )
501 infot = 5
502 CALL dpbsvx( 'N', 'U', 0, 0, -1, a, 1, af, 1, eq, c, b, 1, x,
503 $ 1, rcond, r1, r2, w, iw, info )
504 CALL chkxer( 'DPBSVX', infot, nout, lerr, ok )
505 infot = 7
506 CALL dpbsvx( 'N', 'U', 1, 1, 0, a, 1, af, 2, eq, c, b, 2, x, 2,
507 $ rcond, r1, r2, w, iw, info )
508 CALL chkxer( 'DPBSVX', infot, nout, lerr, ok )
509 infot = 9
510 CALL dpbsvx( 'N', 'U', 1, 1, 0, a, 2, af, 1, eq, c, b, 2, x, 2,
511 $ rcond, r1, r2, w, iw, info )
512 CALL chkxer( 'DPBSVX', infot, nout, lerr, ok )
513 infot = 10
514 eq = '/'
515 CALL dpbsvx( 'F', 'U', 0, 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
516 $ rcond, r1, r2, w, iw, info )
517 CALL chkxer( 'DPBSVX', infot, nout, lerr, ok )
518 infot = 11
519 eq = 'Y'
520 CALL dpbsvx( 'F', 'U', 1, 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
521 $ rcond, r1, r2, w, iw, info )
522 CALL chkxer( 'DPBSVX', infot, nout, lerr, ok )
523 infot = 13
524 CALL dpbsvx( 'N', 'U', 2, 0, 0, a, 1, af, 1, eq, c, b, 1, x, 2,
525 $ rcond, r1, r2, w, iw, info )
526 CALL chkxer( 'DPBSVX', infot, nout, lerr, ok )
527 infot = 15
528 CALL dpbsvx( 'N', 'U', 2, 0, 0, a, 1, af, 1, eq, c, b, 2, x, 1,
529 $ rcond, r1, r2, w, iw, info )
530 CALL chkxer( 'DPBSVX', infot, nout, lerr, ok )
531*
532 ELSE IF( lsamen( 2, c2, 'PT' ) ) THEN
533*
534* DPTSV
535*
536 srnamt = 'DPTSV '
537 infot = 1
538 CALL dptsv( -1, 0, a( 1, 1 ), a( 1, 2 ), b, 1, info )
539 CALL chkxer( 'DPTSV ', infot, nout, lerr, ok )
540 infot = 2
541 CALL dptsv( 0, -1, a( 1, 1 ), a( 1, 2 ), b, 1, info )
542 CALL chkxer( 'DPTSV ', infot, nout, lerr, ok )
543 infot = 6
544 CALL dptsv( 2, 0, a( 1, 1 ), a( 1, 2 ), b, 1, info )
545 CALL chkxer( 'DPTSV ', infot, nout, lerr, ok )
546*
547* DPTSVX
548*
549 srnamt = 'DPTSVX'
550 infot = 1
551 CALL dptsvx( '/', 0, 0, a( 1, 1 ), a( 1, 2 ), af( 1, 1 ),
552 $ af( 1, 2 ), b, 1, x, 1, rcond, r1, r2, w, info )
553 CALL chkxer( 'DPTSVX', infot, nout, lerr, ok )
554 infot = 2
555 CALL dptsvx( 'N', -1, 0, a( 1, 1 ), a( 1, 2 ), af( 1, 1 ),
556 $ af( 1, 2 ), b, 1, x, 1, rcond, r1, r2, w, info )
557 CALL chkxer( 'DPTSVX', infot, nout, lerr, ok )
558 infot = 3
559 CALL dptsvx( 'N', 0, -1, a( 1, 1 ), a( 1, 2 ), af( 1, 1 ),
560 $ af( 1, 2 ), b, 1, x, 1, rcond, r1, r2, w, info )
561 CALL chkxer( 'DPTSVX', infot, nout, lerr, ok )
562 infot = 9
563 CALL dptsvx( 'N', 2, 0, a( 1, 1 ), a( 1, 2 ), af( 1, 1 ),
564 $ af( 1, 2 ), b, 1, x, 2, rcond, r1, r2, w, info )
565 CALL chkxer( 'DPTSVX', infot, nout, lerr, ok )
566 infot = 11
567 CALL dptsvx( 'N', 2, 0, a( 1, 1 ), a( 1, 2 ), af( 1, 1 ),
568 $ af( 1, 2 ), b, 2, x, 1, rcond, r1, r2, w, info )
569 CALL chkxer( 'DPTSVX', infot, nout, lerr, ok )
570*
571 ELSE IF( lsamen( 2, c2, 'SY' ) ) THEN
572*
573* DSYSV
574*
575 srnamt = 'DSYSV '
576 infot = 1
577 CALL dsysv( '/', 0, 0, a, 1, ip, b, 1, w, 1, info )
578 CALL chkxer( 'DSYSV ', infot, nout, lerr, ok )
579 infot = 2
580 CALL dsysv( 'U', -1, 0, a, 1, ip, b, 1, w, 1, info )
581 CALL chkxer( 'DSYSV ', infot, nout, lerr, ok )
582 infot = 3
583 CALL dsysv( 'U', 0, -1, a, 1, ip, b, 1, w, 1, info )
584 CALL chkxer( 'DSYSV ', infot, nout, lerr, ok )
585 infot = 5
586 CALL dsysv( 'U', 2, 0, a, 1, ip, b, 2, w, 1, info )
587 CALL chkxer( 'DSYSV_ROOK', infot, nout, lerr, ok )
588 infot = 8
589 CALL dsysv( 'U', 2, 0, a, 2, ip, b, 1, w, 1, info )
590 CALL chkxer( 'DSYSV ', infot, nout, lerr, ok )
591 infot = 10
592 CALL dsysv( 'U', 0, 0, a, 1, ip, b, 1, w, 0, info )
593 CALL chkxer( 'DSYSV ', infot, nout, lerr, ok )
594 infot = 10
595 CALL dsysv( 'U', 0, 0, a, 1, ip, b, 1, w, -2, info )
596 CALL chkxer( 'DSYSV ', infot, nout, lerr, ok )
597*
598* DSYSVX
599*
600 srnamt = 'DSYSVX'
601 infot = 1
602 CALL dsysvx( '/', 'U', 0, 0, a, 1, af, 1, ip, b, 1, x, 1,
603 $ rcond, r1, r2, w, 1, iw, info )
604 CALL chkxer( 'DSYSVX', infot, nout, lerr, ok )
605 infot = 2
606 CALL dsysvx( 'N', '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1,
607 $ rcond, r1, r2, w, 1, iw, info )
608 CALL chkxer( 'DSYSVX', infot, nout, lerr, ok )
609 infot = 3
610 CALL dsysvx( 'N', 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1,
611 $ rcond, r1, r2, w, 1, iw, info )
612 CALL chkxer( 'DSYSVX', infot, nout, lerr, ok )
613 infot = 4
614 CALL dsysvx( 'N', 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1,
615 $ rcond, r1, r2, w, 1, iw, info )
616 CALL chkxer( 'DSYSVX', infot, nout, lerr, ok )
617 infot = 6
618 CALL dsysvx( 'N', 'U', 2, 0, a, 1, af, 2, ip, b, 2, x, 2,
619 $ rcond, r1, r2, w, 4, iw, info )
620 CALL chkxer( 'DSYSVX', infot, nout, lerr, ok )
621 infot = 8
622 CALL dsysvx( 'N', 'U', 2, 0, a, 2, af, 1, ip, b, 2, x, 2,
623 $ rcond, r1, r2, w, 4, iw, info )
624 CALL chkxer( 'DSYSVX', infot, nout, lerr, ok )
625 infot = 11
626 CALL dsysvx( 'N', 'U', 2, 0, a, 2, af, 2, ip, b, 1, x, 2,
627 $ rcond, r1, r2, w, 4, iw, info )
628 CALL chkxer( 'DSYSVX', infot, nout, lerr, ok )
629 infot = 13
630 CALL dsysvx( 'N', 'U', 2, 0, a, 2, af, 2, ip, b, 2, x, 1,
631 $ rcond, r1, r2, w, 4, iw, info )
632 CALL chkxer( 'DSYSVX', infot, nout, lerr, ok )
633 infot = 18
634 CALL dsysvx( 'N', 'U', 2, 0, a, 2, af, 2, ip, b, 2, x, 2,
635 $ rcond, r1, r2, w, 3, iw, info )
636 CALL chkxer( 'DSYSVX', infot, nout, lerr, ok )
637*
638 ELSE IF( lsamen( 2, c2, 'SR' ) ) THEN
639*
640* DSYSV_ROOK
641*
642 srnamt = 'DSYSV_ROOK'
643 infot = 1
644 CALL dsysv_rook( '/', 0, 0, a, 1, ip, b, 1, w, 1, info )
645 CALL chkxer( 'DSYSV_ROOK', infot, nout, lerr, ok )
646 infot = 2
647 CALL dsysv_rook( 'U', -1, 0, a, 1, ip, b, 1, w, 1, info )
648 CALL chkxer( 'DSYSV_ROOK', infot, nout, lerr, ok )
649 infot = 3
650 CALL dsysv_rook( 'U', 0, -1, a, 1, ip, b, 1, w, 1, info )
651 CALL chkxer( 'DSYSV_ROOK', infot, nout, lerr, ok )
652 infot = 5
653 CALL dsysv_rook( 'U', 2, 0, a, 1, ip, b, 2, w, 1, info )
654 CALL chkxer( 'DSYSV_ROOK', infot, nout, lerr, ok )
655 infot = 8
656 CALL dsysv_rook( 'U', 2, 0, a, 2, ip, b, 1, w, 1, info )
657 CALL chkxer( 'DSYSV_ROOK', infot, nout, lerr, ok )
658 infot = 10
659 CALL dsysv_rook( 'U', 0, 0, a, 1, ip, b, 1, w, 0, info )
660 CALL chkxer( 'DSYSV_ROOK', infot, nout, lerr, ok )
661 infot = 10
662 CALL dsysv_rook( 'U', 0, 0, a, 1, ip, b, 1, w, -2, info )
663 CALL chkxer( 'DSYSV_ROOK', infot, nout, lerr, ok )
664*
665 ELSE IF( lsamen( 2, c2, 'SK' ) ) THEN
666*
667* DSYSV_RK
668*
669* Test error exits of the driver that uses factorization
670* of a symmetric indefinite matrix with rook
671* (bounded Bunch-Kaufman) pivoting with the new storage
672* format for factors L ( or U) and D.
673*
674* L (or U) is stored in A, diagonal of D is stored on the
675* diagonal of A, subdiagonal of D is stored in a separate array E.
676*
677 srnamt = 'DSYSV_RK'
678 infot = 1
679 CALL dsysv_rk( '/', 0, 0, a, 1, e, ip, b, 1, w, 1, info )
680 CALL chkxer( 'DSYSV_RK', infot, nout, lerr, ok )
681 infot = 2
682 CALL dsysv_rk( 'U', -1, 0, a, 1, e, ip, b, 1, w, 1, info )
683 CALL chkxer( 'DSYSV_RK', infot, nout, lerr, ok )
684 infot = 3
685 CALL dsysv_rk( 'U', 0, -1, a, 1, e, ip, b, 1, w, 1, info )
686 CALL chkxer( 'DSYSV_RK', infot, nout, lerr, ok )
687 infot = 5
688 CALL dsysv_rk( 'U', 2, 0, a, 1, e, ip, b, 2, w, 1, info )
689 CALL chkxer( 'DSYSV_RK', infot, nout, lerr, ok )
690 infot = 9
691 CALL dsysv_rk( 'U', 2, 0, a, 2, e, ip, b, 1, w, 1, info )
692 CALL chkxer( 'DSYSV_RK', infot, nout, lerr, ok )
693 infot = 11
694 CALL dsysv_rk( 'U', 0, 0, a, 1, e, ip, b, 1, w, 0, info )
695 CALL chkxer( 'DSYSV_RK', infot, nout, lerr, ok )
696 infot = 11
697 CALL dsysv_rk( 'U', 0, 0, a, 1, e, ip, b, 1, w, -2, info )
698 CALL chkxer( 'DSYSV_RK', infot, nout, lerr, ok )
699*
700 ELSE IF( lsamen( 2, c2, 'SA' ) ) THEN
701*
702* DSYSV_AA
703*
704 srnamt = 'DSYSV_AA'
705 infot = 1
706 CALL dsysv_aa( '/', 0, 0, a, 1, ip, b, 1, w, 1, info )
707 CALL chkxer( 'DSYSV_AA', infot, nout, lerr, ok )
708 infot = 2
709 CALL dsysv_aa( 'U', -1, 0, a, 1, ip, b, 1, w, 1, info )
710 CALL chkxer( 'DSYSV_AA', infot, nout, lerr, ok )
711 infot = 3
712 CALL dsysv_aa( 'U', 0, -1, a, 1, ip, b, 1, w, 1, info )
713 CALL chkxer( 'DSYSV_AA', infot, nout, lerr, ok )
714 infot = 8
715 CALL dsysv_aa( 'U', 2, 0, a, 2, ip, b, 1, w, 1, info )
716 CALL chkxer( 'DSYSV_AA', infot, nout, lerr, ok )
717*
718 ELSE IF( lsamen( 2, c2, 'S2' ) ) THEN
719*
720* DSYSV_AASEN_2STAGE
721*
722 srnamt = 'DSYSV_AA_2STAGE'
723 infot = 1
724 CALL dsysv_aa_2stage( '/', 0, 0, a, 1, a, 1, ip, ip, b, 1,
725 $ w, 1, info )
726 CALL chkxer( 'DSYSV_AA_2STAGE', infot, nout, lerr, ok )
727 infot = 2
728 CALL dsysv_aa_2stage( 'U', -1, 0, a, 1, a, 1, ip, ip, b, 1,
729 $ w, 1, info )
730 CALL chkxer( 'DSYSV_AA_2STAGE', infot, nout, lerr, ok )
731 infot = 3
732 CALL dsysv_aa_2stage( 'U', 0, -1, a, 1, a, 1, ip, ip, b, 1,
733 $ w, 1, info )
734 CALL chkxer( 'DSYSV_AA_2STAGE', infot, nout, lerr, ok )
735 infot = 5
736 CALL dsysv_aa_2stage( 'U', 2, 1, a, 1, a, 1, ip, ip, b, 1,
737 $ w, 1, info )
738 CALL chkxer( 'DSYSV_AA_2STAGE', infot, nout, lerr, ok )
739 infot = 11
740 CALL dsysv_aa_2stage( 'U', 2, 1, a, 2, a, 8, ip, ip, b, 1,
741 $ w, 1, info )
742 CALL chkxer( 'DSYSV_AA_2STAGE', infot, nout, lerr, ok )
743 infot = 7
744 CALL dsysv_aa_2stage( 'U', 2, 1, a, 2, a, 1, ip, ip, b, 2,
745 $ w, 1, info )
746 CALL chkxer( 'DSYSV_AA_2STAGE', infot, nout, lerr, ok )
747*
748 ELSE IF( lsamen( 2, c2, 'SP' ) ) THEN
749*
750* DSPSV
751*
752 srnamt = 'DSPSV '
753 infot = 1
754 CALL dspsv( '/', 0, 0, a, ip, b, 1, info )
755 CALL chkxer( 'DSPSV ', infot, nout, lerr, ok )
756 infot = 2
757 CALL dspsv( 'U', -1, 0, a, ip, b, 1, info )
758 CALL chkxer( 'DSPSV ', infot, nout, lerr, ok )
759 infot = 3
760 CALL dspsv( 'U', 0, -1, a, ip, b, 1, info )
761 CALL chkxer( 'DSPSV ', infot, nout, lerr, ok )
762 infot = 7
763 CALL dspsv( 'U', 2, 0, a, ip, b, 1, info )
764 CALL chkxer( 'DSPSV ', infot, nout, lerr, ok )
765*
766* DSPSVX
767*
768 srnamt = 'DSPSVX'
769 infot = 1
770 CALL dspsvx( '/', 'U', 0, 0, a, af, ip, b, 1, x, 1, rcond, r1,
771 $ r2, w, iw, info )
772 CALL chkxer( 'DSPSVX', infot, nout, lerr, ok )
773 infot = 2
774 CALL dspsvx( 'N', '/', 0, 0, a, af, ip, b, 1, x, 1, rcond, r1,
775 $ r2, w, iw, info )
776 CALL chkxer( 'DSPSVX', infot, nout, lerr, ok )
777 infot = 3
778 CALL dspsvx( 'N', 'U', -1, 0, a, af, ip, b, 1, x, 1, rcond, r1,
779 $ r2, w, iw, info )
780 CALL chkxer( 'DSPSVX', infot, nout, lerr, ok )
781 infot = 4
782 CALL dspsvx( 'N', 'U', 0, -1, a, af, ip, b, 1, x, 1, rcond, r1,
783 $ r2, w, iw, info )
784 CALL chkxer( 'DSPSVX', infot, nout, lerr, ok )
785 infot = 9
786 CALL dspsvx( 'N', 'U', 2, 0, a, af, ip, b, 1, x, 2, rcond, r1,
787 $ r2, w, iw, info )
788 CALL chkxer( 'DSPSVX', infot, nout, lerr, ok )
789 infot = 11
790 CALL dspsvx( 'N', 'U', 2, 0, a, af, ip, b, 2, x, 1, rcond, r1,
791 $ r2, w, iw, info )
792 CALL chkxer( 'DSPSVX', infot, nout, lerr, ok )
793 END IF
794*
795* Print a summary line.
796*
797 IF( ok ) THEN
798 WRITE( nout, fmt = 9999 )path
799 ELSE
800 WRITE( nout, fmt = 9998 )path
801 END IF
802*
803 9999 FORMAT( 1x, a3, ' drivers passed the tests of the error exits' )
804 9998 FORMAT( ' *** ', a3, ' drivers failed the tests of the error ',
805 $ 'exits ***' )
806*
807 RETURN
808*
809* End of DERRVX
810*

◆ dgbt01()

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

DGBT01

Purpose:
!>
!> DGBT01 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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
!>          DGBTRF.  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 DGBTRF 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 DGBTRF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (2*KL+KU+1)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(L*U - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file dgbt01.f.

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

◆ dgbt02()

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

DGBT02

Purpose:
!>
!> DGBT02 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 or A**T, depending on TRANS, and EPS is the
!> machine epsilon.
!> The norm used is the 1-norm.
!>
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]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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  IF TRANS = 'N',
!>          LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK)),
!>          where LRWORK >= M when TRANS = 'T' or 'C'; otherwise, RWORK
!>          is not referenced.
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - op(A)*X) / ( norm(op(A)) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 147 of file dgbt02.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 CHARACTER TRANS
156 INTEGER KL, KU, LDA, LDB, LDX, M, N, NRHS
157 DOUBLE PRECISION RESID
158* ..
159* .. Array Arguments ..
160 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * ),
161 $ RWORK( * )
162* ..
163*
164* =====================================================================
165*
166* .. Parameters ..
167 DOUBLE PRECISION ZERO, ONE
168 parameter( zero = 0.0d+0, one = 1.0d+0 )
169* ..
170* .. Local Scalars ..
171 INTEGER I1, I2, J, KD, N1
172 DOUBLE PRECISION ANORM, BNORM, EPS, TEMP, XNORM
173* ..
174* .. External Functions ..
175 LOGICAL DISNAN, LSAME
176 DOUBLE PRECISION DASUM, DLAMCH
177 EXTERNAL dasum, disnan, dlamch, lsame
178* ..
179* .. External Subroutines ..
180 EXTERNAL dgbmv
181* ..
182* .. Intrinsic Functions ..
183 INTRINSIC abs, max, min
184* ..
185* .. Executable Statements ..
186*
187* Quick return if N = 0 pr NRHS = 0
188*
189 IF( m.LE.0 .OR. n.LE.0 .OR. nrhs.LE.0 ) THEN
190 resid = zero
191 RETURN
192 END IF
193*
194* Exit with RESID = 1/EPS if ANORM = 0.
195*
196 eps = dlamch( 'Epsilon' )
197 anorm = zero
198 IF( lsame( trans, 'N' ) ) THEN
199*
200* Find norm1(A).
201*
202 kd = ku + 1
203 DO 10 j = 1, n
204 i1 = max( kd+1-j, 1 )
205 i2 = min( kd+m-j, kl+kd )
206 IF( i2.GE.i1 ) THEN
207 temp = dasum( i2-i1+1, a( i1, j ), 1 )
208 IF( anorm.LT.temp .OR. disnan( temp ) ) anorm = temp
209 END IF
210 10 CONTINUE
211 ELSE
212*
213* Find normI(A).
214*
215 DO 12 i1 = 1, m
216 rwork( i1 ) = zero
217 12 CONTINUE
218 DO 16 j = 1, n
219 kd = ku + 1 - j
220 DO 14 i1 = max( 1, j-ku ), min( m, j+kl )
221 rwork( i1 ) = rwork( i1 ) + abs( a( kd+i1, j ) )
222 14 CONTINUE
223 16 CONTINUE
224 DO 18 i1 = 1, m
225 temp = rwork( i1 )
226 IF( anorm.LT.temp .OR. disnan( temp ) ) anorm = temp
227 18 CONTINUE
228 END IF
229 IF( anorm.LE.zero ) THEN
230 resid = one / eps
231 RETURN
232 END IF
233*
234 IF( lsame( trans, 'T' ) .OR. lsame( trans, 'C' ) ) THEN
235 n1 = n
236 ELSE
237 n1 = m
238 END IF
239*
240* Compute B - op(A)*X
241*
242 DO 20 j = 1, nrhs
243 CALL dgbmv( trans, m, n, kl, ku, -one, a, lda, x( 1, j ), 1,
244 $ one, b( 1, j ), 1 )
245 20 CONTINUE
246*
247* Compute the maximum over the number of right hand sides of
248* norm(B - op(A)*X) / ( norm(op(A)) * norm(X) * EPS ).
249*
250 resid = zero
251 DO 30 j = 1, nrhs
252 bnorm = dasum( n1, b( 1, j ), 1 )
253 xnorm = dasum( n1, x( 1, j ), 1 )
254 IF( xnorm.LE.zero ) THEN
255 resid = one / eps
256 ELSE
257 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
258 END IF
259 30 CONTINUE
260*
261 RETURN
262*
263* End of DGBT02
264*
disnan
logical function disnan(din)
DISNAN tests input for NaN.
Definition disnan.f:59
dgbmv
subroutine dgbmv(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, incy)
DGBMV
Definition dgbmv.f:185

◆ dgbt05()

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

DGBT05

Purpose:
!>
!> DGBT05 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 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, 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( NZ*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 174 of file dgbt05.f.

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

◆ dgelqs()

subroutine dgelqs ( integer m,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tau,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( lwork ) work,
integer lwork,
integer info )

DGELQS

Purpose:
!>
!> Compute a minimum-norm solution
!>     min || A*X - B ||
!> using the LQ factorization
!>     A = L*Q
!> computed by DGELQF.
!>
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 DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the LQ factorization of the original matrix A as
!>          returned by DGELQF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= M.
!>
[in]TAU
!>          TAU is DOUBLE PRECISION array, dimension (M)
!>          Details of the orthogonal matrix Q.
!>
[in,out]B
!>          B is DOUBLE PRECISION 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 DOUBLE PRECISION 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 dgelqs.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 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAU( * ),
131 $ WORK( LWORK )
132* ..
133*
134* =====================================================================
135*
136* .. Parameters ..
137 DOUBLE PRECISION ZERO, ONE
138 parameter( zero = 0.0d+0, one = 1.0d+0 )
139* ..
140* .. External Subroutines ..
141 EXTERNAL dlaset, dormlq, dtrsm, xerbla
142* ..
143* .. Intrinsic Functions ..
144 INTRINSIC max
145* ..
146* .. Executable Statements ..
147*
148* Test the input parameters.
149*
150 info = 0
151 IF( m.LT.0 ) THEN
152 info = -1
153 ELSE IF( n.LT.0 .OR. m.GT.n ) 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, n ) ) 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( 'DGELQS', -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* Solve L*X = B(1:m,:)
176*
177 CALL dtrsm( 'Left', 'Lower', 'No transpose', 'Non-unit', m, nrhs,
178 $ one, a, lda, b, ldb )
179*
180* Set B(m+1:n,:) to zero
181*
182 IF( m.LT.n )
183 $ CALL dlaset( 'Full', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb )
184*
185* B := Q' * B
186*
187 CALL dormlq( 'Left', 'Transpose', n, nrhs, m, a, lda, tau, b, ldb,
188 $ work, lwork, info )
189*
190 RETURN
191*
192* End of DGELQS
193*
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60

◆ dgennd()

logical function dgennd ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda )

DGENND

Purpose:
!>
!>    DGENND tests that its argument has a 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 DOUBLE PRECISION 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 dgennd.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 DOUBLE PRECISION A( LDA, * )
78* ..
79*
80* =====================================================================
81*
82* .. Parameters ..
83 DOUBLE PRECISION ZERO
84 parameter( zero = 0.0d0 )
85* ..
86* .. Local Scalars ..
87 INTEGER I, K
88* ..
89* .. Intrinsics ..
90 INTRINSIC min
91* ..
92* .. Executable Statements ..
93 k = min( m, n )
94 DO i = 1, k
95 IF( a( i, i ).LT.zero ) THEN
96 dgennd = .false.
97 RETURN
98 END IF
99 END DO
100 dgennd = .true.
101 RETURN

◆ dgeqls()

subroutine dgeqls ( integer m,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tau,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( lwork ) work,
integer lwork,
integer info )

DGEQLS

Purpose:
!>
!> Solve the least squares problem
!>     min || A*X - B ||
!> using the QL factorization
!>     A = Q*L
!> computed by DGEQLF.
!>
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 DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the QL factorization of the original matrix A as
!>          returned by DGEQLF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= M.
!>
[in]TAU
!>          TAU is DOUBLE PRECISION array, dimension (N)
!>          Details of the orthogonal matrix Q.
!>
[in,out]B
!>          B is DOUBLE PRECISION 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 DOUBLE PRECISION 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 dgeqls.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 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAU( * ),
132 $ WORK( LWORK )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 DOUBLE PRECISION ONE
139 parameter( one = 1.0d+0 )
140* ..
141* .. External Subroutines ..
142 EXTERNAL dormql, dtrsm, 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( 'DGEQLS', -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 dormql( 'Left', 'Transpose', m, nrhs, n, a, lda, tau, b, ldb,
179 $ work, lwork, info )
180*
181* Solve L*X = B(m-n+1:m,:)
182*
183 CALL dtrsm( '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 DGEQLS
189*

◆ dgeqrs()

subroutine dgeqrs ( integer m,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tau,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( lwork ) work,
integer lwork,
integer info )

DGEQRS

Purpose:
!>
!> Solve the least squares problem
!>     min || A*X - B ||
!> using the QR factorization
!>     A = Q*R
!> computed by DGEQRF.
!>
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 DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the QR factorization of the original matrix A as
!>          returned by DGEQRF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= M.
!>
[in]TAU
!>          TAU is DOUBLE PRECISION array, dimension (N)
!>          Details of the orthogonal matrix Q.
!>
[in,out]B
!>          B is DOUBLE PRECISION 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 DOUBLE PRECISION 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 dgeqrs.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 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAU( * ),
131 $ WORK( LWORK )
132* ..
133*
134* =====================================================================
135*
136* .. Parameters ..
137 DOUBLE PRECISION ONE
138 parameter( one = 1.0d+0 )
139* ..
140* .. External Subroutines ..
141 EXTERNAL dormqr, dtrsm, 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( 'DGEQRS', -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 dormqr( 'Left', 'Transpose', m, nrhs, n, a, lda, tau, b, ldb,
178 $ work, lwork, info )
179*
180* Solve R*X = B(1:n,:)
181*
182 CALL dtrsm( 'Left', 'Upper', 'No transpose', 'Non-unit', n, nrhs,
183 $ one, a, lda, b, ldb )
184*
185 RETURN
186*
187* End of DGEQRS
188*

◆ dgerqs()

subroutine dgerqs ( integer m,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) tau,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision, dimension( lwork ) work,
integer lwork,
integer info )

DGERQS

Purpose:
!>
!> Compute a minimum-norm solution
!>     min || A*X - B ||
!> using the RQ factorization
!>     A = R*Q
!> computed by DGERQF.
!>
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 DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the RQ factorization of the original matrix A as
!>          returned by DGERQF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= M.
!>
[in]TAU
!>          TAU is DOUBLE PRECISION array, dimension (M)
!>          Details of the orthogonal matrix Q.
!>
[in,out]B
!>          B is DOUBLE PRECISION 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 DOUBLE PRECISION 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 dgerqs.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 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAU( * ),
132 $ WORK( LWORK )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 DOUBLE PRECISION ZERO, ONE
139 parameter( zero = 0.0d+0, one = 1.0d+0 )
140* ..
141* .. External Subroutines ..
142 EXTERNAL dlaset, dormrq, dtrsm, 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( 'DGERQS', -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 R*X = B(n-m+1:n,:)
177*
178 CALL dtrsm( 'Left', 'Upper', 'No transpose', 'Non-unit', m, nrhs,
179 $ one, a( 1, n-m+1 ), lda, b( n-m+1, 1 ), ldb )
180*
181* Set B(1:n-m,:) to zero
182*
183 CALL dlaset( 'Full', n-m, nrhs, zero, zero, b, ldb )
184*
185* B := Q' * B
186*
187 CALL dormrq( 'Left', 'Transpose', n, nrhs, m, a, lda, tau, b, ldb,
188 $ work, lwork, info )
189*
190 RETURN
191*
192* End of DGERQS
193*

◆ dget01()

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

DGET01

Purpose:
!>
!> DGET01 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DGETRF.
!>          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 DGETRF.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(L*U - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 105 of file dget01.f.

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

◆ dget02()

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

DGET02

Purpose:
!>
!> DGET02 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 or A**T, depending on TRANS, and EPS is the
!> machine epsilon.
!> The norm used is the 1-norm.
!>
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]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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - op(A)*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  IF TRANS = 'N',
!>          LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - op(A)*X) / ( norm(op(A)) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 133 of file dget02.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 CHARACTER TRANS
142 INTEGER LDA, LDB, LDX, M, N, NRHS
143 DOUBLE PRECISION RESID
144* ..
145* .. Array Arguments ..
146 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ),
147 $ X( LDX, * )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 DOUBLE PRECISION ZERO, ONE
154 parameter( zero = 0.0d+0, one = 1.0d+0 )
155* ..
156* .. Local Scalars ..
157 INTEGER J, N1, N2
158 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
159* ..
160* .. External Functions ..
161 LOGICAL LSAME
162 DOUBLE PRECISION DASUM, DLAMCH, DLANGE
163 EXTERNAL lsame, dasum, dlamch, dlange
164* ..
165* .. External Subroutines ..
166 EXTERNAL dgemm
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 n1 = n
182 n2 = m
183 ELSE
184 n1 = m
185 n2 = n
186 END IF
187*
188* Exit with RESID = 1/EPS if ANORM = 0.
189*
190 eps = dlamch( 'Epsilon' )
191 IF( lsame( trans, 'N' ) ) THEN
192 anorm = dlange( '1', m, n, a, lda, rwork )
193 ELSE
194 anorm = dlange( 'I', m, n, a, lda, rwork )
195 END IF
196 IF( anorm.LE.zero ) THEN
197 resid = one / eps
198 RETURN
199 END IF
200*
201* Compute B - op(A)*X and store in B.
202*
203 CALL dgemm( trans, 'No transpose', n1, nrhs, n2, -one, a, lda, x,
204 $ ldx, one, b, ldb )
205*
206* Compute the maximum over the number of right hand sides of
207* norm(B - op(A)*X) / ( norm(op(A)) * norm(X) * EPS ) .
208*
209 resid = zero
210 DO 10 j = 1, nrhs
211 bnorm = dasum( n1, b( 1, j ), 1 )
212 xnorm = dasum( n2, x( 1, j ), 1 )
213 IF( xnorm.LE.zero ) THEN
214 resid = one / eps
215 ELSE
216 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
217 END IF
218 10 CONTINUE
219*
220 RETURN
221*
222* End of DGET02
223*

◆ dget03()

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

DGET03

Purpose:
!>
!> DGET03 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDWORK,N)
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.  LDWORK >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of A, computed as
!>          ( 1/norm(A) ) / norm(AINV).
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(I - AINV*A) / ( N * norm(A) * norm(AINV) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 107 of file dget03.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 INTEGER LDA, LDAINV, LDWORK, N
116 DOUBLE PRECISION RCOND, RESID
117* ..
118* .. Array Arguments ..
119 DOUBLE PRECISION A( LDA, * ), AINV( LDAINV, * ), RWORK( * ),
120 $ WORK( LDWORK, * )
121* ..
122*
123* =====================================================================
124*
125* .. Parameters ..
126 DOUBLE PRECISION ZERO, ONE
127 parameter( zero = 0.0d+0, one = 1.0d+0 )
128* ..
129* .. Local Scalars ..
130 INTEGER I
131 DOUBLE PRECISION AINVNM, ANORM, EPS
132* ..
133* .. External Functions ..
134 DOUBLE PRECISION DLAMCH, DLANGE
135 EXTERNAL dlamch, dlange
136* ..
137* .. External Subroutines ..
138 EXTERNAL dgemm
139* ..
140* .. Intrinsic Functions ..
141 INTRINSIC dble
142* ..
143* .. Executable Statements ..
144*
145* Quick exit if N = 0.
146*
147 IF( n.LE.0 ) THEN
148 rcond = one
149 resid = zero
150 RETURN
151 END IF
152*
153* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
154*
155 eps = dlamch( 'Epsilon' )
156 anorm = dlange( '1', n, n, a, lda, rwork )
157 ainvnm = dlange( '1', n, n, ainv, ldainv, rwork )
158 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
159 rcond = zero
160 resid = one / eps
161 RETURN
162 END IF
163 rcond = ( one / anorm ) / ainvnm
164*
165* Compute I - A * AINV
166*
167 CALL dgemm( 'No transpose', 'No transpose', n, n, n, -one, ainv,
168 $ ldainv, a, lda, zero, work, ldwork )
169 DO 10 i = 1, n
170 work( i, i ) = one + work( i, i )
171 10 CONTINUE
172*
173* Compute norm(I - AINV*A) / (N * norm(A) * norm(AINV) * EPS)
174*
175 resid = dlange( '1', n, n, work, ldwork, rwork )
176*
177 resid = ( ( resid*rcond ) / eps ) / dble( n )
178*
179 RETURN
180*
181* End of DGET03
182*

◆ dget04()

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

DGET04

Purpose:
!>
!> DGET04 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension( LDX, NRHS )
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of the coefficient
!>          matrix in the system of equations.
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the NRHS solution vectors of
!>          ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 101 of file dget04.f.

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

◆ dget06()

double precision function dget06 ( double precision rcond,
double precision rcondc )

DGET06

Purpose:
!>
!> DGET06 computes a test ratio to compare two values for RCOND.
!>
Parameters
[in]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The estimate of the reciprocal of the condition number of A,
!>          as computed by DGECON.
!>
[in]RCONDC
!>          RCONDC is DOUBLE PRECISION
!>          The reciprocal of the condition number of A, computed as
!>          ( 1/norm(A) ) / norm(inv(A)).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 54 of file dget06.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 DOUBLE PRECISION RCOND, RCONDC
62* ..
63*
64* =====================================================================
65*
66* .. Parameters ..
67 DOUBLE PRECISION ZERO, ONE
68 parameter( zero = 0.0d+0, one = 1.0d+0 )
69* ..
70* .. Local Scalars ..
71 DOUBLE PRECISION EPS, RAT
72* ..
73* .. External Functions ..
74 DOUBLE PRECISION DLAMCH
75 EXTERNAL dlamch
76* ..
77* .. Intrinsic Functions ..
78 INTRINSIC max, min
79* ..
80* .. Executable Statements ..
81*
82 eps = dlamch( 'Epsilon' )
83 IF( rcond.GT.zero ) THEN
84 IF( rcondc.GT.zero ) THEN
85 rat = max( rcond, rcondc ) / min( rcond, rcondc ) -
86 $ ( one-eps )
87 ELSE
88 rat = rcond / eps
89 END IF
90 ELSE
91 IF( rcondc.GT.zero ) THEN
92 rat = rcondc / eps
93 ELSE
94 rat = zero
95 END IF
96 END IF
97 dget06 = rat
98 RETURN
99*
100* End of DGET06
101*

◆ dget07()

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

DGET07

Purpose:
!>
!> DGET07 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]CHKFERR
!>          CHKFERR is LOGICAL
!>          Set to .TRUE. to check FERR, .FALSE. not to check FERR.
!>          When the test system is ill-conditioned, the 
!>          solution in XACT may be incorrect.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 163 of file dget07.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 LOGICAL CHKFERR
173 INTEGER LDA, LDB, LDX, LDXACT, N, NRHS
174* ..
175* .. Array Arguments ..
176 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
177 $ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 DOUBLE PRECISION ZERO, ONE
184 parameter( zero = 0.0d+0, one = 1.0d+0 )
185* ..
186* .. Local Scalars ..
187 LOGICAL NOTRAN
188 INTEGER I, IMAX, J, K
189 DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
190* ..
191* .. External Functions ..
192 LOGICAL LSAME
193 INTEGER IDAMAX
194 DOUBLE PRECISION DLAMCH
195 EXTERNAL lsame, idamax, dlamch
196* ..
197* .. Intrinsic Functions ..
198 INTRINSIC abs, max, min
199* ..
200* .. Executable Statements ..
201*
202* Quick exit if N = 0 or NRHS = 0.
203*
204 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
205 reslts( 1 ) = zero
206 reslts( 2 ) = zero
207 RETURN
208 END IF
209*
210 eps = dlamch( 'Epsilon' )
211 unfl = dlamch( 'Safe minimum' )
212 ovfl = one / unfl
213 notran = lsame( trans, 'N' )
214*
215* Test 1: Compute the maximum of
216* norm(X - XACT) / ( norm(X) * FERR )
217* over all the vectors X and XACT using the infinity-norm.
218*
219 errbnd = zero
220 IF( chkferr ) THEN
221 DO 30 j = 1, nrhs
222 imax = idamax( n, x( 1, j ), 1 )
223 xnorm = max( abs( x( imax, j ) ), unfl )
224 diff = zero
225 DO 10 i = 1, n
226 diff = max( diff, abs( x( i, j )-xact( i, j ) ) )
227 10 CONTINUE
228*
229 IF( xnorm.GT.one ) THEN
230 GO TO 20
231 ELSE IF( diff.LE.ovfl*xnorm ) THEN
232 GO TO 20
233 ELSE
234 errbnd = one / eps
235 GO TO 30
236 END IF
237*
238 20 CONTINUE
239 IF( diff / xnorm.LE.ferr( j ) ) THEN
240 errbnd = max( errbnd, ( diff / xnorm ) / ferr( j ) )
241 ELSE
242 errbnd = one / eps
243 END IF
244 30 CONTINUE
245 END IF
246 reslts( 1 ) = errbnd
247*
248* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
249* (*) = (n+1)*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
250*
251 DO 70 k = 1, nrhs
252 DO 60 i = 1, n
253 tmp = abs( b( i, k ) )
254 IF( notran ) THEN
255 DO 40 j = 1, n
256 tmp = tmp + abs( a( i, j ) )*abs( x( j, k ) )
257 40 CONTINUE
258 ELSE
259 DO 50 j = 1, n
260 tmp = tmp + abs( a( j, i ) )*abs( x( j, k ) )
261 50 CONTINUE
262 END IF
263 IF( i.EQ.1 ) THEN
264 axbi = tmp
265 ELSE
266 axbi = min( axbi, tmp )
267 END IF
268 60 CONTINUE
269 tmp = berr( k ) / ( ( n+1 )*eps+( n+1 )*unfl /
270 $ max( axbi, ( n+1 )*unfl ) )
271 IF( k.EQ.1 ) THEN
272 reslts( 2 ) = tmp
273 ELSE
274 reslts( 2 ) = max( reslts( 2 ), tmp )
275 END IF
276 70 CONTINUE
277*
278 RETURN
279*
280* End of DGET07
281*

◆ dget08()

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

DGET08

Purpose:
!>
!> DGET08 computes the residual for a solution of a system of linear
!> equations  A*x = b  or  A'*x = b:
!>    RESID = norm(B - A*X,inf) / ( norm(A,inf) * norm(X,inf) * 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'*x = b, where A' is the transpose of A
!>          = 'C':  A'*x = b, where A' is the 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  IF TRANS = 'N',
!>          LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 131 of file dget08.f.

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

◆ dgtt01()

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

DGTT01

Purpose:
!>
!> DGTT01 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 DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) sub-diagonal elements of A.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of A.
!>
[in]DU
!>          DU is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) super-diagonal elements of A.
!>
[in]DLF
!>          DLF is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) multipliers that define the matrix L from the
!>          LU factorization of A.
!>
[in]DF
!>          DF is DOUBLE PRECISION array, dimension (N)
!>          The n diagonal elements of the upper triangular matrix U from
!>          the LU factorization of A.
!>
[in]DUF
!>          DUF is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) elements of the first super-diagonal of U.
!>
[in]DU2
!>          DU2 is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDWORK,N)
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.  LDWORK >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The scaled residual:  norm(L*U - A) / (norm(A) * EPS)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 132 of file dgtt01.f.

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

◆ dgtt02()

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

DGTT02

Purpose:
!>
!> DGTT02 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.
!> The norm used is the 1-norm.
!>
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 = 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 DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) sub-diagonal elements of A.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of A.
!>
[in]DU
!>          DU is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) super-diagonal elements of A.
!>
[in]X
!>          X is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - op(A)*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(B - op(A)*X) / (norm(op(A)) * norm(X) * EPS)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 123 of file dgtt02.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 TRANS
132 INTEGER LDB, LDX, N, NRHS
133 DOUBLE PRECISION RESID
134* ..
135* .. Array Arguments ..
136 DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ),
137 $ X( LDX, * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ONE, ZERO
144 parameter( one = 1.0d+0, zero = 0.0d+0 )
145* ..
146* .. Local Scalars ..
147 INTEGER J
148 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
149* ..
150* .. External Functions ..
151 LOGICAL LSAME
152 DOUBLE PRECISION DASUM, DLAMCH, DLANGT
153 EXTERNAL lsame, dasum, dlamch, dlangt
154* ..
155* .. External Subroutines ..
156 EXTERNAL dlagtm
157* ..
158* .. Intrinsic Functions ..
159 INTRINSIC max
160* ..
161* .. Executable Statements ..
162*
163* Quick exit if N = 0 or NRHS = 0
164*
165 resid = zero
166 IF( n.LE.0 .OR. nrhs.EQ.0 )
167 $ RETURN
168*
169* Compute the maximum over the number of right hand sides of
170* norm(B - op(A)*X) / ( norm(op(A)) * norm(X) * EPS ).
171*
172 IF( lsame( trans, 'N' ) ) THEN
173 anorm = dlangt( '1', n, dl, d, du )
174 ELSE
175 anorm = dlangt( 'I', n, dl, d, du )
176 END IF
177*
178* Exit with RESID = 1/EPS if ANORM = 0.
179*
180 eps = dlamch( 'Epsilon' )
181 IF( anorm.LE.zero ) THEN
182 resid = one / eps
183 RETURN
184 END IF
185*
186* Compute B - op(A)*X and store in B.
187*
188 CALL dlagtm( trans, n, nrhs, -one, dl, d, du, x, ldx, one, b,
189 $ ldb )
190*
191 DO 10 j = 1, nrhs
192 bnorm = dasum( n, b( 1, j ), 1 )
193 xnorm = dasum( 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 DGTT02
204*

◆ dgtt05()

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

DGTT05

Purpose:
!>
!> DGTT05 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 DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) sub-diagonal elements of A.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The diagonal elements of A.
!>
[in]DU
!>          DU is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) super-diagonal elements of A.
!>
[in]B
!>          B is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( NZ*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 163 of file dgtt05.f.

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

◆ dlahilb()

subroutine dlahilb ( integer n,
integer nrhs,
double precision, dimension(lda, n) a,
integer lda,
double precision, dimension(ldx, nrhs) x,
integer ldx,
double precision, dimension(ldb, nrhs) b,
integer ldb,
double precision, dimension(n) work,
integer info )

DLAHILB

Purpose:
!>
!> DLAHILB 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 123 of file dlahilb.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 INTEGER N, NRHS, LDA, LDX, LDB, INFO
131* .. Array Arguments ..
132 DOUBLE PRECISION A(LDA, N), X(LDX, NRHS), B(LDB, NRHS), WORK(N)
133* ..
134*
135* =====================================================================
136* .. Local Scalars ..
137 INTEGER TM, TI, R
138 INTEGER M
139 INTEGER I, J
140* ..
141* .. Parameters ..
142* NMAX_EXACT the largest dimension where the generated data is
143* exact.
144* NMAX_APPROX the largest dimension where the generated data has
145* a small componentwise relative error.
146 INTEGER NMAX_EXACT, NMAX_APPROX
147 parameter(nmax_exact = 6, nmax_approx = 11)
148
149* ..
150* .. External Functions
151 EXTERNAL dlaset
152 INTRINSIC dble
153* ..
154* .. Executable Statements ..
155*
156* Test the input arguments
157*
158 info = 0
159 IF (n .LT. 0 .OR. n .GT. nmax_approx) THEN
160 info = -1
161 ELSE IF (nrhs .LT. 0) THEN
162 info = -2
163 ELSE IF (lda .LT. n) THEN
164 info = -4
165 ELSE IF (ldx .LT. n) THEN
166 info = -6
167 ELSE IF (ldb .LT. n) THEN
168 info = -8
169 END IF
170 IF (info .LT. 0) THEN
171 CALL xerbla('DLAHILB', -info)
172 RETURN
173 END IF
174 IF (n .GT. nmax_exact) THEN
175 info = 1
176 END IF
177*
178* Compute M = the LCM of the integers [1, 2*N-1]. The largest
179* reasonable N is small enough that integers suffice (up to N = 11).
180 m = 1
181 DO i = 2, (2*n-1)
182 tm = m
183 ti = i
184 r = mod(tm, ti)
185 DO WHILE (r .NE. 0)
186 tm = ti
187 ti = r
188 r = mod(tm, ti)
189 END DO
190 m = (m / ti) * i
191 END DO
192*
193* Generate the scaled Hilbert matrix in A
194 DO j = 1, n
195 DO i = 1, n
196 a(i, j) = dble(m) / (i + j - 1)
197 END DO
198 END DO
199*
200* Generate matrix B as simply the first NRHS columns of M * the
201* identity.
202 CALL dlaset('Full', n, nrhs, 0.0d+0, dble(m), b, ldb)
203
204* Generate the true solutions in X. Because B = the first NRHS
205* columns of M*I, the true solutions are just the first NRHS columns
206* of the inverse Hilbert matrix.
207 work(1) = n
208 DO j = 2, n
209 work(j) = ( ( (work(j-1)/(j-1)) * (j-1 - n) ) /(j-1) )
210 $ * (n +j -1)
211 END DO
212*
213 DO j = 1, nrhs
214 DO i = 1, n
215 x(i, j) = (work(i)*work(j)) / (i + j - 1)
216 END DO
217 END DO
218*

◆ dlaord()

subroutine dlaord ( character job,
integer n,
double precision, dimension( * ) x,
integer incx )

DLAORD

Purpose:
!>
!> DLAORD sorts the elements of a vector x in increasing or decreasing
!> order.
!>
Parameters
[in]JOB
!>          JOB is CHARACTER
!>          = 'I':  Sort in increasing order
!>          = 'D':  Sort in decreasing order
!>
[in]N
!>          N is INTEGER
!>          The length of the vector X.
!>
[in,out]X
!>          X is DOUBLE PRECISION array, dimension
!>                         (1+(N-1)*INCX)
!>          On entry, the vector of length n to be sorted.
!>          On exit, the vector x is sorted in the prescribed order.
!>
[in]INCX
!>          INCX is INTEGER
!>          The spacing between successive elements of X.  INCX >= 0.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 72 of file dlaord.f.

73*
74* -- LAPACK test routine --
75* -- LAPACK is a software package provided by Univ. of Tennessee, --
76* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
77*
78* .. Scalar Arguments ..
79 CHARACTER JOB
80 INTEGER INCX, N
81* ..
82* .. Array Arguments ..
83 DOUBLE PRECISION X( * )
84* ..
85*
86* =====================================================================
87*
88* .. Local Scalars ..
89 INTEGER I, INC, IX, IXNEXT
90 DOUBLE PRECISION TEMP
91* ..
92* .. External Functions ..
93 LOGICAL LSAME
94 EXTERNAL lsame
95* ..
96* .. Intrinsic Functions ..
97 INTRINSIC abs
98* ..
99* .. Executable Statements ..
100*
101 inc = abs( incx )
102 IF( lsame( job, 'I' ) ) THEN
103*
104* Sort in increasing order
105*
106 DO 20 i = 2, n
107 ix = 1 + ( i-1 )*inc
108 10 CONTINUE
109 IF( ix.EQ.1 )
110 $ GO TO 20
111 ixnext = ix - inc
112 IF( x( ix ).GT.x( ixnext ) ) THEN
113 GO TO 20
114 ELSE
115 temp = x( ix )
116 x( ix ) = x( ixnext )
117 x( ixnext ) = temp
118 END IF
119 ix = ixnext
120 GO TO 10
121 20 CONTINUE
122*
123 ELSE IF( lsame( job, 'D' ) ) THEN
124*
125* Sort in decreasing order
126*
127 DO 40 i = 2, n
128 ix = 1 + ( i-1 )*inc
129 30 CONTINUE
130 IF( ix.EQ.1 )
131 $ GO TO 40
132 ixnext = ix - inc
133 IF( x( ix ).LT.x( ixnext ) ) THEN
134 GO TO 40
135 ELSE
136 temp = x( ix )
137 x( ix ) = x( ixnext )
138 x( ixnext ) = temp
139 END IF
140 ix = ixnext
141 GO TO 30
142 40 CONTINUE
143 END IF
144 RETURN
145*
146* End of DLAORD
147*

◆ dlaptm()

subroutine dlaptm ( integer n,
integer nrhs,
double precision alpha,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
double precision, dimension( ldx, * ) x,
integer ldx,
double precision beta,
double precision, dimension( ldb, * ) b,
integer ldb )

DLAPTM

Purpose:
!>
!> DLAPTM multiplies an N by NRHS matrix X by a symmetric 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]N
!>          N is INTEGER
!>          The order of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices X and B.
!>
[in]ALPHA
!>          ALPHA is DOUBLE PRECISION
!>          The scalar alpha.  ALPHA must be 1. or -1.; otherwise,
!>          it is assumed to be 0.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The n diagonal elements of the tridiagonal matrix A.
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) subdiagonal or superdiagonal elements of A.
!>
[in]X
!>          X is DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          The N by NRHS matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(N,1).
!>
[in]BETA
!>          BETA is DOUBLE PRECISION
!>          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,
!>          it is assumed to be 1.
!>
[in,out]B
!>          B is DOUBLE PRECISION 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 115 of file dlaptm.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 INTEGER LDB, LDX, N, NRHS
123 DOUBLE PRECISION ALPHA, BETA
124* ..
125* .. Array Arguments ..
126 DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), X( LDX, * )
127* ..
128*
129* =====================================================================
130*
131* .. Parameters ..
132 DOUBLE PRECISION ONE, ZERO
133 parameter( one = 1.0d+0, zero = 0.0d+0 )
134* ..
135* .. Local Scalars ..
136 INTEGER I, J
137* ..
138* .. Executable Statements ..
139*
140 IF( n.EQ.0 )
141 $ RETURN
142*
143* Multiply B by BETA if BETA.NE.1.
144*
145 IF( beta.EQ.zero ) THEN
146 DO 20 j = 1, nrhs
147 DO 10 i = 1, n
148 b( i, j ) = zero
149 10 CONTINUE
150 20 CONTINUE
151 ELSE IF( beta.EQ.-one ) THEN
152 DO 40 j = 1, nrhs
153 DO 30 i = 1, n
154 b( i, j ) = -b( i, j )
155 30 CONTINUE
156 40 CONTINUE
157 END IF
158*
159 IF( alpha.EQ.one ) THEN
160*
161* Compute B := B + A*X
162*
163 DO 60 j = 1, nrhs
164 IF( n.EQ.1 ) THEN
165 b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j )
166 ELSE
167 b( 1, j ) = b( 1, j ) + d( 1 )*x( 1, j ) +
168 $ e( 1 )*x( 2, j )
169 b( n, j ) = b( n, j ) + e( n-1 )*x( n-1, j ) +
170 $ d( n )*x( n, j )
171 DO 50 i = 2, n - 1
172 b( i, j ) = b( i, j ) + e( i-1 )*x( i-1, j ) +
173 $ d( i )*x( i, j ) + e( i )*x( i+1, j )
174 50 CONTINUE
175 END IF
176 60 CONTINUE
177 ELSE IF( alpha.EQ.-one ) THEN
178*
179* Compute B := B - A*X
180*
181 DO 80 j = 1, nrhs
182 IF( n.EQ.1 ) THEN
183 b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j )
184 ELSE
185 b( 1, j ) = b( 1, j ) - d( 1 )*x( 1, j ) -
186 $ e( 1 )*x( 2, j )
187 b( n, j ) = b( n, j ) - e( n-1 )*x( n-1, j ) -
188 $ d( n )*x( n, j )
189 DO 70 i = 2, n - 1
190 b( i, j ) = b( i, j ) - e( i-1 )*x( i-1, j ) -
191 $ d( i )*x( i, j ) - e( i )*x( i+1, j )
192 70 CONTINUE
193 END IF
194 80 CONTINUE
195 END IF
196 RETURN
197*
198* End of DLAPTM
199*

◆ dlarhs()

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

DLARHS

Purpose:
!>
!> DLARHS 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 or A**T, depending on TRANS.
!>
Parameters
[in]PATH
!>          PATH is CHARACTER*3
!>          The type of the real matrix A.  PATH may be given in any
!>          combination of upper and lower case.  Valid types include
!>             xGE:  General m x n matrix
!>             xGB:  General banded matrix
!>             xPO:  Symmetric positive definite, 2-D storage
!>             xPP:  Symmetric positive definite packed
!>             xPB:  Symmetric positive definite 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
!>          Specifies whether the upper or lower triangular part of the
!>          matrix A is stored, if A is symmetric.
!>          = '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 = Transpose)
!>
[in]M
!>          M is INTEGER
!>          The number or 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 DOUBLE PRECISION 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) DOUBLE PRECISION 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 DOUBLE PRECISION 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
!>          DLATMS).  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 203 of file dlarhs.f.

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

◆ dlatb4()

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

DLATB4

Purpose:
!>
!> DLATB4 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
!>          = 'P':  symmetric positive (semi)definite matrix
!>          = 'N':  nonsymmetric matrix
!>
[out]KL
!>          KL is INTEGER
!>          The lower band width of the matrix to be generated.
!>
[out]KU
!>          KU is INTEGER
!>          The upper band width of the matrix to be generated.
!>
[out]ANORM
!>          ANORM is DOUBLE PRECISION
!>          The desired norm of the matrix to be generated.  The diagonal
!>          matrix of singular values or eigenvalues is scaled by this
!>          value.
!>
[out]MODE
!>          MODE is INTEGER
!>          A key indicating how to choose the vector of eigenvalues.
!>
[out]CNDNUM
!>          CNDNUM is DOUBLE PRECISION
!>          The desired condition number.
!>
[out]DIST
!>          DIST is CHARACTER*1
!>          The type of distribution to be used by the random number
!>          generator.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

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

◆ dlatb5()

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

DLATB5

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

Definition at line 112 of file dlatb5.f.

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

◆ dlattb()

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

DLATTB

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

◆ dlattp()

subroutine dlattp ( integer imat,
character uplo,
character trans,
character diag,
integer, dimension( 4 ) iseed,
integer n,
double precision, dimension( * ) a,
double precision, dimension( * ) b,
double precision, dimension( * ) work,
integer info )

DLATTP

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

◆ dlattr()

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

DLATTR

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

◆ dlavsp()

subroutine dlavsp ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
double precision, dimension( * ) a,
integer, dimension( * ) ipiv,
double precision, dimension( ldb, * ) b,
integer ldb,
integer info )

DLAVSP

Purpose:
!>
!> DLAVSP  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 DSPTRF.
!>
!> 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' )
!> 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
!>          = 'T':  x := A'*x
!>          = 'C':  x := A'*x
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the diagonal blocks are unit
!>          matrices.  If the diagonal blocks are assumed to be unit,
!>          then A = U or A = L, otherwise A = U*D or A = L*D.
!>          = 'U':  Diagonal blocks are assumed to be unit matrices.
!>          = 'N':  Diagonal blocks are assumed to be non-unit matrices.
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of vectors
!>          x to be multiplied by A.  NRHS >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L, stored as a packed triangular
!>          matrix as computed by DSPTRF.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from DSPTRF.
!>
[in,out]B
!>          B is DOUBLE PRECISION 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 128 of file dlavsp.f.

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

◆ dlavsy()

subroutine dlavsy ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( ldb, * ) b,
integer ldb,
integer info )

DLAVSY

Purpose:
!>
!> DLAVSY  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 DSYTRF.
!>
!> 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')
!> 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
!>          = 'T':  x := A'*x
!>          = 'C':  x := A'*x
!>
[in]DIAG
!>          DIAG is CHARACTER*1
!>          Specifies whether or not the diagonal blocks are unit
!>          matrices.  If the diagonal blocks are assumed to be unit,
!>          then A = U or A = L, otherwise A = U*D or A = L*D.
!>          = 'U':  Diagonal blocks are assumed to be unit matrices.
!>          = 'N':  Diagonal blocks are assumed to be non-unit matrices.
!>
[in]N
!>          N is INTEGER
!>          The number of rows and columns of the matrix A.  N >= 0.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of vectors
!>          x to be multiplied by A.  NRHS >= 0.
!>
[in]A
!>          A is DOUBLE PRECISION array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by DSYTRF.
!>          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 DSYTRF.
!>
!>          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 DOUBLE PRECISION 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 dlavsy.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 DOUBLE PRECISION A( LDA, * ), B( LDB, * )
167* ..
168*
169* =====================================================================
170*
171* .. Parameters ..
172 DOUBLE PRECISION ONE
173 parameter( one = 1.0d+0 )
174* ..
175* .. Local Scalars ..
176 LOGICAL NOUNIT
177 INTEGER J, K, KP
178 DOUBLE PRECISION D11, D12, D21, D22, T1, T2
179* ..
180* .. External Functions ..
181 LOGICAL LSAME
182 EXTERNAL lsame
183* ..
184* .. External Subroutines ..
185 EXTERNAL dgemv, dger, dscal, dswap, 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.
198 $ lsame( trans, 'T' ) .AND. .NOT.lsame( trans, 'C' ) ) 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( 'DLAVSY ', -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 dscal( 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 dger( k-1, nrhs, one, a( 1, k ), 1, b( k, 1 ),
255 $ ldb, b( 1, 1 ), ldb )
256*
257* Interchange if P(K) .ne. I.
258*
259 kp = ipiv( k )
260 IF( kp.NE.k )
261 $ CALL dswap( 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 dger( k-1, nrhs, one, a( 1, k ), 1, b( k, 1 ),
290 $ ldb, b( 1, 1 ), ldb )
291 CALL dger( k-1, nrhs, one, a( 1, k+1 ), 1,
292 $ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
293*
294* Interchange if P(K) .ne. I.
295*
296 kp = abs( ipiv( k ) )
297 IF( kp.NE.k )
298 $ CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
299 END IF
300 k = k + 2
301 END IF
302 GO TO 10
303 30 CONTINUE
304*
305* Compute B := L*B
306* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
307*
308 ELSE
309*
310* Loop backward applying the transformations to B.
311*
312 k = n
313 40 CONTINUE
314 IF( k.LT.1 )
315 $ GO TO 60
316*
317* Test the pivot index. If greater than zero, a 1 x 1
318* pivot was used, otherwise a 2 x 2 pivot was used.
319*
320 IF( ipiv( k ).GT.0 ) THEN
321*
322* 1 x 1 pivot block:
323*
324* Multiply by the diagonal element if forming L * D.
325*
326 IF( nounit )
327 $ CALL dscal( nrhs, a( k, k ), b( k, 1 ), ldb )
328*
329* Multiply by P(K) * inv(L(K)) if K < N.
330*
331 IF( k.NE.n ) THEN
332 kp = ipiv( k )
333*
334* Apply the transformation.
335*
336 CALL dger( n-k, nrhs, one, a( k+1, k ), 1, b( k, 1 ),
337 $ ldb, b( k+1, 1 ), ldb )
338*
339* Interchange if a permutation was applied at the
340* K-th step of the factorization.
341*
342 IF( kp.NE.k )
343 $ CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
344 END IF
345 k = k - 1
346*
347 ELSE
348*
349* 2 x 2 pivot block:
350*
351* Multiply by the diagonal block if forming L * D.
352*
353 IF( nounit ) THEN
354 d11 = a( k-1, k-1 )
355 d22 = a( k, k )
356 d21 = a( k, k-1 )
357 d12 = d21
358 DO 50 j = 1, nrhs
359 t1 = b( k-1, j )
360 t2 = b( k, j )
361 b( k-1, j ) = d11*t1 + d12*t2
362 b( k, j ) = d21*t1 + d22*t2
363 50 CONTINUE
364 END IF
365*
366* Multiply by P(K) * inv(L(K)) if K < N.
367*
368 IF( k.NE.n ) THEN
369*
370* Apply the transformation.
371*
372 CALL dger( n-k, nrhs, one, a( k+1, k ), 1, b( k, 1 ),
373 $ ldb, b( k+1, 1 ), ldb )
374 CALL dger( n-k, nrhs, one, a( k+1, k-1 ), 1,
375 $ b( k-1, 1 ), ldb, b( k+1, 1 ), ldb )
376*
377* Interchange if a permutation was applied at the
378* K-th step of the factorization.
379*
380 kp = abs( ipiv( k ) )
381 IF( kp.NE.k )
382 $ CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
383 END IF
384 k = k - 2
385 END IF
386 GO TO 40
387 60 CONTINUE
388 END IF
389*----------------------------------------
390*
391* Compute B := A' * B (transpose)
392*
393*----------------------------------------
394 ELSE
395*
396* Form B := U'*B
397* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
398* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m)
399*
400 IF( lsame( uplo, 'U' ) ) THEN
401*
402* Loop backward applying the transformations.
403*
404 k = n
405 70 CONTINUE
406 IF( k.LT.1 )
407 $ GO TO 90
408*
409* 1 x 1 pivot block.
410*
411 IF( ipiv( k ).GT.0 ) THEN
412 IF( k.GT.1 ) THEN
413*
414* Interchange if P(K) .ne. I.
415*
416 kp = ipiv( k )
417 IF( kp.NE.k )
418 $ CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
419*
420* Apply the transformation
421*
422 CALL dgemv( 'Transpose', k-1, nrhs, one, b, ldb,
423 $ a( 1, k ), 1, one, b( k, 1 ), ldb )
424 END IF
425 IF( nounit )
426 $ CALL dscal( nrhs, a( k, k ), b( k, 1 ), ldb )
427 k = k - 1
428*
429* 2 x 2 pivot block.
430*
431 ELSE
432 IF( k.GT.2 ) THEN
433*
434* Interchange if P(K) .ne. I.
435*
436 kp = abs( ipiv( k ) )
437 IF( kp.NE.k-1 )
438 $ CALL dswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
439 $ ldb )
440*
441* Apply the transformations
442*
443 CALL dgemv( 'Transpose', k-2, nrhs, one, b, ldb,
444 $ a( 1, k ), 1, one, b( k, 1 ), ldb )
445 CALL dgemv( 'Transpose', k-2, nrhs, one, b, ldb,
446 $ a( 1, k-1 ), 1, one, b( k-1, 1 ), ldb )
447 END IF
448*
449* Multiply by the diagonal block if non-unit.
450*
451 IF( nounit ) THEN
452 d11 = a( k-1, k-1 )
453 d22 = a( k, k )
454 d12 = a( k-1, k )
455 d21 = d12
456 DO 80 j = 1, nrhs
457 t1 = b( k-1, j )
458 t2 = b( k, j )
459 b( k-1, j ) = d11*t1 + d12*t2
460 b( k, j ) = d21*t1 + d22*t2
461 80 CONTINUE
462 END IF
463 k = k - 2
464 END IF
465 GO TO 70
466 90 CONTINUE
467*
468* Form B := L'*B
469* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
470* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1)
471*
472 ELSE
473*
474* Loop forward applying the L-transformations.
475*
476 k = 1
477 100 CONTINUE
478 IF( k.GT.n )
479 $ GO TO 120
480*
481* 1 x 1 pivot block
482*
483 IF( ipiv( k ).GT.0 ) THEN
484 IF( k.LT.n ) THEN
485*
486* Interchange if P(K) .ne. I.
487*
488 kp = ipiv( k )
489 IF( kp.NE.k )
490 $ CALL dswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
491*
492* Apply the transformation
493*
494 CALL dgemv( 'Transpose', n-k, nrhs, one, b( k+1, 1 ),
495 $ ldb, a( k+1, k ), 1, one, b( k, 1 ), ldb )
496 END IF
497 IF( nounit )
498 $ CALL dscal( nrhs, a( k, k ), b( k, 1 ), ldb )
499 k = k + 1
500*
501* 2 x 2 pivot block.
502*
503 ELSE
504 IF( k.LT.n-1 ) THEN
505*
506* Interchange if P(K) .ne. I.
507*
508 kp = abs( ipiv( k ) )
509 IF( kp.NE.k+1 )
510 $ CALL dswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
511 $ ldb )
512*
513* Apply the transformation
514*
515 CALL dgemv( 'Transpose', n-k-1, nrhs, one,
516 $ b( k+2, 1 ), ldb, a( k+2, k+1 ), 1, one,
517 $ b( k+1, 1 ), ldb )
518 CALL dgemv( 'Transpose', n-k-1, nrhs, one,
519 $ b( k+2, 1 ), ldb, a( k+2, k ), 1, one,
520 $ b( k, 1 ), ldb )
521 END IF
522*
523* Multiply by the diagonal block if non-unit.
524*
525 IF( nounit ) THEN
526 d11 = a( k, k )
527 d22 = a( k+1, k+1 )
528 d21 = a( k+1, k )
529 d12 = d21
530 DO 110 j = 1, nrhs
531 t1 = b( k, j )
532 t2 = b( k+1, j )
533 b( k, j ) = d11*t1 + d12*t2
534 b( k+1, j ) = d21*t1 + d22*t2
535 110 CONTINUE
536 END IF
537 k = k + 2
538 END IF
539 GO TO 100
540 120 CONTINUE
541 END IF
542*
543 END IF
544 RETURN
545*
546* End of DLAVSY
547*

◆ dlavsy_rook()

subroutine dlavsy_rook ( character uplo,
character trans,
character diag,
integer n,
integer nrhs,
double precision, dimension( lda, * ) a,
integer lda,
integer, dimension( * ) ipiv,
double precision, dimension( ldb, * ) b,
integer ldb,
integer info )

DLAVSY_ROOK

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

◆ dlqt01()

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

DLQT01

Purpose:
!>
!> DLQT01 tests DGELQF, which computes the LQ factorization of an m-by-n
!> matrix A, and partially tests DORGLQ which forms the n-by-n
!> orthogonal matrix Q.
!>
!> DLQT01 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The m-by-n matrix A.
!>
[out]AF
!>          AF is DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the LQ factorization of A, as returned by DGELQF.
!>          See DGELQF for further details.
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDA,N)
!>          The n-by-n orthogonal matrix Q.
!>
[out]L
!>          L is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by DGELQF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(M,N))
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file dlqt01.f.

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

◆ dlqt02()

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

DLQT02

Purpose:
!>
!> DLQT02 tests DORGLQ, 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, DLQT02 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The m-by-n matrix A which was factorized by DLQT01.
!>
[in]AF
!>          AF is DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the LQ factorization of A, as returned by DGELQF.
!>          See DGELQF for further details.
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDA,N)
!>
[out]L
!>          L is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (M)
!>          The scalar factors of the elementary reflectors corresponding
!>          to the LQ factorization in AF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( L - A*Q' ) / ( N * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 133 of file dlqt02.f.

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

◆ dlqt03()

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

DLQT03

Purpose:
!>
!> DLQT03 tests DORMLQ, which computes Q*C, Q'*C, C*Q or C*Q'.
!>
!> DLQT03 compares the results of a call to DORMLQ with the results of
!> forming Q explicitly by a call to DORGLQ and then performing matrix
!> multiplication by a call to DGEMM.
!>
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 DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the LQ factorization of an m-by-n matrix, as
!>          returned by DGELQF. See SGELQF for further details.
!>
[out]C
!>          C is DOUBLE PRECISION array, dimension (LDA,N)
!>
[out]CC
!>          CC is DOUBLE PRECISION array, dimension (LDA,N)
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDA,N)
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays AF, C, CC, and Q.
!>
[in]TAU
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors corresponding
!>          to the LQ factorization in AF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of WORK.  LWORK must be at least M, and should be
!>          M*NB, where NB is the blocksize for this environment.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The test ratios compare two techniques for multiplying a
!>          random matrix C by an n-by-n orthogonal matrix Q.
!>          RESULT(1) = norm( Q*C - Q*C )  / ( N * norm(C) * EPS )
!>          RESULT(2) = norm( C*Q - C*Q )  / ( N * norm(C) * EPS )
!>          RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS )
!>          RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 134 of file dlqt03.f.

136*
137* -- LAPACK test routine --
138* -- LAPACK is a software package provided by Univ. of Tennessee, --
139* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
140*
141* .. Scalar Arguments ..
142 INTEGER K, LDA, LWORK, M, N
143* ..
144* .. Array Arguments ..
145 DOUBLE PRECISION AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
146 $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
147 $ WORK( LWORK )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 DOUBLE PRECISION ONE
154 parameter( one = 1.0d0 )
155 DOUBLE PRECISION ROGUE
156 parameter( rogue = -1.0d+10 )
157* ..
158* .. Local Scalars ..
159 CHARACTER SIDE, TRANS
160 INTEGER INFO, ISIDE, ITRANS, J, MC, NC
161 DOUBLE PRECISION CNORM, EPS, RESID
162* ..
163* .. External Functions ..
164 LOGICAL LSAME
165 DOUBLE PRECISION DLAMCH, DLANGE
166 EXTERNAL lsame, dlamch, dlange
167* ..
168* .. External Subroutines ..
169 EXTERNAL dgemm, dlacpy, dlarnv, dlaset, dorglq, dormlq
170* ..
171* .. Local Arrays ..
172 INTEGER ISEED( 4 )
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC dble, max
176* ..
177* .. Scalars in Common ..
178 CHARACTER*32 SRNAMT
179* ..
180* .. Common blocks ..
181 COMMON / srnamc / srnamt
182* ..
183* .. Data statements ..
184 DATA iseed / 1988, 1989, 1990, 1991 /
185* ..
186* .. Executable Statements ..
187*
188 eps = dlamch( 'Epsilon' )
189*
190* Copy the first k rows of the factorization to the array Q
191*
192 CALL dlaset( 'Full', n, n, rogue, rogue, q, lda )
193 CALL dlacpy( 'Upper', k, n-1, af( 1, 2 ), lda, q( 1, 2 ), lda )
194*
195* Generate the n-by-n matrix Q
196*
197 srnamt = 'DORGLQ'
198 CALL dorglq( 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 dlarnv( 2, iseed, mc, c( 1, j ) )
215 10 CONTINUE
216 cnorm = dlange( '1', mc, nc, c, lda, rwork )
217 IF( cnorm.EQ.0.0d0 )
218 $ cnorm = one
219*
220 DO 20 itrans = 1, 2
221 IF( itrans.EQ.1 ) THEN
222 trans = 'N'
223 ELSE
224 trans = 'T'
225 END IF
226*
227* Copy C
228*
229 CALL dlacpy( 'Full', mc, nc, c, lda, cc, lda )
230*
231* Apply Q or Q' to C
232*
233 srnamt = 'DORMLQ'
234 CALL dormlq( 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 dgemm( trans, 'No transpose', mc, nc, mc, -one, q,
241 $ lda, c, lda, one, cc, lda )
242 ELSE
243 CALL dgemm( 'No transpose', trans, mc, nc, nc, -one, c,
244 $ lda, q, lda, one, cc, lda )
245 END IF
246*
247* Compute error in the difference
248*
249 resid = dlange( '1', mc, nc, cc, lda, rwork )
250 result( ( iside-1 )*2+itrans ) = resid /
251 $ ( dble( max( 1, n ) )*cnorm*eps )
252*
253 20 CONTINUE
254 30 CONTINUE
255*
256 RETURN
257*
258* End of DLQT03
259*

◆ dlqt04()

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

DLQT04

Purpose:
!>
!> DLQT04 tests DGELQT and DGEMLQT.
!>
Parameters
[in]M
!>          M is INTEGER
!>          Number of rows in test matrix.
!>
[in]N
!>          N is INTEGER
!>          Number of columns in test matrix.
!>
[in]NB
!>          NB is INTEGER
!>          Block size of test matrix.  NB <= Min(M,N).
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (6)
!>          Results of each of the six tests below.
!>
!>          RESULT(1) = | A - L Q |
!>          RESULT(2) = | I - Q Q^H |
!>          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 dlqt04.f.

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

◆ dlqt05()

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

DLQT05

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

Definition at line 79 of file dlqt05.f.

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

◆ dorhr_col01()

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

DORHR_COL01

Purpose:
!>
!> DORHR_COL01 tests DORGTSQR and DORHR_COL using DLATSQR, DGEMQRT.
!> Therefore, DLATSQR (part of DGEQR), DGEMQRT (part of DGEMQR)
!> have to be tested before this test.
!>
!>
Parameters
[in]M
!>          M is INTEGER
!>          Number of rows in test matrix.
!>
[in]N
!>          N is INTEGER
!>          Number of columns in test matrix.
!>
[in]MB1
!>          MB1 is INTEGER
!>          Number of row in row block in an input test matrix.
!>
[in]NB1
!>          NB1 is INTEGER
!>          Number of columns in column block an input test matrix.
!>
[in]NB2
!>          NB2 is INTEGER
!>          Number of columns in column block in an output test matrix.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (6)
!>          Results of each of the six tests below.
!>
!>            A is a m-by-n test input matrix to be factored.
!>            so that A = Q_gr * ( R )
!>                               ( 0 ),
!>
!>            Q_qr is an implicit m-by-m orthogonal Q matrix, the result
!>            of factorization in blocked WY-representation,
!>            stored in ZGEQRT output format.
!>
!>            R is a n-by-n upper-triangular matrix,
!>
!>            0 is a (m-n)-by-n zero matrix,
!>
!>            Q is an explicit m-by-m orthogonal 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 DGEMQRT,
!>
!>            Q * C, (Q**H) * C, D * Q, D * (Q**H)  are
!>            computed using DGEMM.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 118 of file dorhr_col01.f.

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

◆ dorhr_col02()

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

DORHR_COL02

Purpose:
!>
!> DORHR_COL02 tests DORGTSQR_ROW and DORHR_COL inside DGETSQRHRT
!> (which calls DLATSQR, DORGTSQR_ROW and DORHR_COL) using DGEMQRT.
!> Therefore, DLATSQR (part of DGEQR), DGEMQRT (part of DGEMQR)
!> have to be tested before this test.
!>
!>
Parameters
[in]M
!>          M is INTEGER
!>          Number of rows in test matrix.
!>
[in]N
!>          N is INTEGER
!>          Number of columns in test matrix.
!>
[in]MB1
!>          MB1 is INTEGER
!>          Number of row in row block in an input test matrix.
!>
[in]NB1
!>          NB1 is INTEGER
!>          Number of columns in column block an input test matrix.
!>
[in]NB2
!>          NB2 is INTEGER
!>          Number of columns in column block in an output test matrix.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (6)
!>          Results of each of the six tests below.
!>
!>            A is a m-by-n test input matrix to be factored.
!>            so that A = Q_gr * ( R )
!>                               ( 0 ),
!>
!>            Q_qr is an implicit m-by-m orthogonal Q matrix, the result
!>            of factorization in blocked WY-representation,
!>            stored in ZGEQRT output format.
!>
!>            R is a n-by-n upper-triangular matrix,
!>
!>            0 is a (m-n)-by-n zero matrix,
!>
!>            Q is an explicit m-by-m orthogonal 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 DGEMQRT,
!>
!>            Q * C, (Q**H) * C, D * Q, D * (Q**H)  are
!>            computed using DGEMM.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 119 of file dorhr_col02.f.

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

◆ dpbt01()

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

DPBT01

Purpose:
!>
!> DPBT01 reconstructs a symmetric 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
!>          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]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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The original symmetric 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 DPBTRF for further details.
!>
[in]LDA
!>          LDA is INTEGER.
!>          The leading dimension of the array A.  LDA >= max(1,KD+1).
!>
[in]AFAC
!>          AFAC is DOUBLE PRECISION 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 DPBTRF.
!>
[in]LDAFAC
!>          LDAFAC is INTEGER
!>          The leading dimension of the array AFAC.
!>          LDAFAC >= max(1,KD+1).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 117 of file dpbt01.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 CHARACTER UPLO
126 INTEGER KD, LDA, LDAFAC, N
127 DOUBLE PRECISION RESID
128* ..
129* .. Array Arguments ..
130 DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), RWORK( * )
131* ..
132*
133* =====================================================================
134*
135*
136* .. Parameters ..
137 DOUBLE PRECISION ZERO, ONE
138 parameter( zero = 0.0d+0, one = 1.0d+0 )
139* ..
140* .. Local Scalars ..
141 INTEGER I, J, K, KC, KLEN, ML, MU
142 DOUBLE PRECISION ANORM, EPS, T
143* ..
144* .. External Functions ..
145 LOGICAL LSAME
146 DOUBLE PRECISION DDOT, DLAMCH, DLANSB
147 EXTERNAL lsame, ddot, dlamch, dlansb
148* ..
149* .. External Subroutines ..
150 EXTERNAL dscal, dsyr, dtrmv
151* ..
152* .. Intrinsic Functions ..
153 INTRINSIC dble, max, min
154* ..
155* .. Executable Statements ..
156*
157* Quick exit if N = 0.
158*
159 IF( n.LE.0 ) THEN
160 resid = zero
161 RETURN
162 END IF
163*
164* Exit with RESID = 1/EPS if ANORM = 0.
165*
166 eps = dlamch( 'Epsilon' )
167 anorm = dlansb( '1', uplo, n, kd, a, lda, rwork )
168 IF( anorm.LE.zero ) THEN
169 resid = one / eps
170 RETURN
171 END IF
172*
173* Compute the product U'*U, overwriting U.
174*
175 IF( lsame( uplo, 'U' ) ) THEN
176 DO 10 k = n, 1, -1
177 kc = max( 1, kd+2-k )
178 klen = kd + 1 - kc
179*
180* Compute the (K,K) element of the result.
181*
182 t = ddot( klen+1, afac( kc, k ), 1, afac( kc, k ), 1 )
183 afac( kd+1, k ) = t
184*
185* Compute the rest of column K.
186*
187 IF( klen.GT.0 )
188 $ CALL dtrmv( 'Upper', 'Transpose', 'Non-unit', klen,
189 $ afac( kd+1, k-klen ), ldafac-1,
190 $ afac( kc, k ), 1 )
191*
192 10 CONTINUE
193*
194* UPLO = 'L': Compute the product L*L', overwriting L.
195*
196 ELSE
197 DO 20 k = n, 1, -1
198 klen = min( kd, n-k )
199*
200* Add a multiple of column K of the factor L to each of
201* columns K+1 through N.
202*
203 IF( klen.GT.0 )
204 $ CALL dsyr( 'Lower', klen, one, afac( 2, k ), 1,
205 $ afac( 1, k+1 ), ldafac-1 )
206*
207* Scale column K by the diagonal element.
208*
209 t = afac( 1, k )
210 CALL dscal( klen+1, t, afac( 1, k ), 1 )
211*
212 20 CONTINUE
213 END IF
214*
215* Compute the difference L*L' - A or U'*U - A.
216*
217 IF( lsame( uplo, 'U' ) ) THEN
218 DO 40 j = 1, n
219 mu = max( 1, kd+2-j )
220 DO 30 i = mu, kd + 1
221 afac( i, j ) = afac( i, j ) - a( i, j )
222 30 CONTINUE
223 40 CONTINUE
224 ELSE
225 DO 60 j = 1, n
226 ml = min( kd+1, n-j+1 )
227 DO 50 i = 1, ml
228 afac( i, j ) = afac( i, j ) - a( i, j )
229 50 CONTINUE
230 60 CONTINUE
231 END IF
232*
233* Compute norm( L*L' - A ) / ( N * norm(A) * EPS )
234*
235 resid = dlansb( 'I', uplo, n, kd, afac, ldafac, rwork )
236*
237 resid = ( ( resid / dble( n ) ) / anorm ) / eps
238*
239 RETURN
240*
241* End of DPBT01
242*
dsyr
subroutine dsyr(uplo, n, alpha, x, incx, a, lda)
DSYR
Definition dsyr.f:132

◆ dpbt02()

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

DPBT02

Purpose:
!>
!> DPBT02 computes the residual for a solution of a symmetric 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
!>          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]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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The original symmetric 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 DPBTRF for further details.
!>
[in]LDA
!>          LDA is INTEGER.
!>          The leading dimension of the array A.  LDA >= max(1,KD+1).
!>
[in]X
!>          X is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 134 of file dpbt02.f.

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

◆ dpbt05()

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

DPBT05

Purpose:
!>
!> DPBT05 tests the error bounds from iterative refinement for the
!> computed solution to a system of equations A*X = B, where A is a
!> symmetric 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
!>          symmetric 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 DOUBLE PRECISION array, dimension (LDAB,N)
!>          The upper or lower triangle of the symmetric 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( NZ*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 169 of file dpbt05.f.

171*
172* -- LAPACK test routine --
173* -- LAPACK is a software package provided by Univ. of Tennessee, --
174* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
175*
176* .. Scalar Arguments ..
177 CHARACTER UPLO
178 INTEGER KD, LDAB, LDB, LDX, LDXACT, N, NRHS
179* ..
180* .. Array Arguments ..
181 DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), BERR( * ),
182 $ FERR( * ), RESLTS( * ), X( LDX, * ),
183 $ XACT( LDXACT, * )
184* ..
185*
186* =====================================================================
187*
188* .. Parameters ..
189 DOUBLE PRECISION ZERO, ONE
190 parameter( zero = 0.0d+0, one = 1.0d+0 )
191* ..
192* .. Local Scalars ..
193 LOGICAL UPPER
194 INTEGER I, IMAX, J, K, NZ
195 DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
196* ..
197* .. External Functions ..
198 LOGICAL LSAME
199 INTEGER IDAMAX
200 DOUBLE PRECISION DLAMCH
201 EXTERNAL lsame, idamax, dlamch
202* ..
203* .. Intrinsic Functions ..
204 INTRINSIC abs, max, min
205* ..
206* .. Executable Statements ..
207*
208* Quick exit if N = 0 or NRHS = 0.
209*
210 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
211 reslts( 1 ) = zero
212 reslts( 2 ) = zero
213 RETURN
214 END IF
215*
216 eps = dlamch( 'Epsilon' )
217 unfl = dlamch( 'Safe minimum' )
218 ovfl = one / unfl
219 upper = lsame( uplo, 'U' )
220 nz = 2*max( kd, n-1 ) + 1
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 = idamax( n, x( 1, j ), 1 )
229 xnorm = max( abs( x( imax, j ) ), unfl )
230 diff = zero
231 DO 10 i = 1, n
232 diff = max( diff, abs( 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 / ( NZ*EPS + (*) ), where
254* (*) = NZ*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 = abs( b( i, k ) )
259 IF( upper ) THEN
260 DO 40 j = max( i-kd, 1 ), i
261 tmp = tmp + abs( ab( kd+1-i+j, i ) )*abs( x( j, k ) )
262 40 CONTINUE
263 DO 50 j = i + 1, min( i+kd, n )
264 tmp = tmp + abs( ab( kd+1+i-j, j ) )*abs( x( j, k ) )
265 50 CONTINUE
266 ELSE
267 DO 60 j = max( i-kd, 1 ), i - 1
268 tmp = tmp + abs( ab( 1+i-j, j ) )*abs( x( j, k ) )
269 60 CONTINUE
270 DO 70 j = i, min( i+kd, n )
271 tmp = tmp + abs( ab( 1+j-i, i ) )*abs( x( j, k ) )
272 70 CONTINUE
273 END IF
274 IF( i.EQ.1 ) THEN
275 axbi = tmp
276 ELSE
277 axbi = min( axbi, tmp )
278 END IF
279 80 CONTINUE
280 tmp = berr( k ) / ( nz*eps+nz*unfl / max( axbi, nz*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 DPBT05
291*

◆ dpot01()

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

DPOT01

Purpose:
!>
!> DPOT01 reconstructs a symmetric 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.
!>
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 DOUBLE PRECISION 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,out]AFAC
!>          AFAC is DOUBLE PRECISION array, dimension (LDAFAC,N)
!>          On entry, the factor L or U from the L * L**T or U**T * U
!>          factorization of A.
!>          Overwritten with the reconstructed matrix, and then with
!>          the difference L * L**T - A (or U**T * U - A).
!>
[in]LDAFAC
!>          LDAFAC is INTEGER
!>          The leading dimension of the array AFAC.  LDAFAC >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L * L**T - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U**T * U - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 103 of file dpot01.f.

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

◆ dpot02()

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

DPOT02

Purpose:
!>
!> DPOT02 computes the residual for the solution of a 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 DOUBLE PRECISION 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]X
!>          X is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 125 of file dpot02.f.

127*
128* -- LAPACK test routine --
129* -- LAPACK is a software package provided by Univ. of Tennessee, --
130* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
131*
132* .. Scalar Arguments ..
133 CHARACTER UPLO
134 INTEGER LDA, LDB, LDX, N, NRHS
135 DOUBLE PRECISION RESID
136* ..
137* .. Array Arguments ..
138 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ),
139 $ X( LDX, * )
140* ..
141*
142* =====================================================================
143*
144* .. Parameters ..
145 DOUBLE PRECISION ZERO, ONE
146 parameter( zero = 0.0d+0, one = 1.0d+0 )
147* ..
148* .. Local Scalars ..
149 INTEGER J
150 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
151* ..
152* .. External Functions ..
153 DOUBLE PRECISION DASUM, DLAMCH, DLANSY
154 EXTERNAL dasum, dlamch, dlansy
155* ..
156* .. External Subroutines ..
157 EXTERNAL dsymm
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC max
161* ..
162* .. Executable Statements ..
163*
164* Quick exit if N = 0 or NRHS = 0.
165*
166 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
167 resid = zero
168 RETURN
169 END IF
170*
171* Exit with RESID = 1/EPS if ANORM = 0.
172*
173 eps = dlamch( 'Epsilon' )
174 anorm = dlansy( '1', uplo, n, a, lda, rwork )
175 IF( anorm.LE.zero ) THEN
176 resid = one / eps
177 RETURN
178 END IF
179*
180* Compute B - A*X
181*
182 CALL dsymm( 'Left', uplo, n, nrhs, -one, a, lda, x, ldx, one, b,
183 $ ldb )
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 10 j = 1, nrhs
190 bnorm = dasum( n, b( 1, j ), 1 )
191 xnorm = dasum( 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 10 CONTINUE
198*
199 RETURN
200*
201* End of DPOT02
202*

◆ dpot03()

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

DPOT03

Purpose:
!>
!> DPOT03 computes the residual for a 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
!>          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 DOUBLE PRECISION 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,out]AINV
!>          AINV is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDWORK,N)
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.  LDWORK >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of A, computed as
!>          ( 1/norm(A) ) / norm(AINV).
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 123 of file dpot03.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, LDAINV, LDWORK, N
133 DOUBLE PRECISION RCOND, RESID
134* ..
135* .. Array Arguments ..
136 DOUBLE PRECISION A( LDA, * ), AINV( LDAINV, * ), RWORK( * ),
137 $ WORK( LDWORK, * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ZERO, ONE
144 parameter( zero = 0.0d+0, one = 1.0d+0 )
145* ..
146* .. Local Scalars ..
147 INTEGER I, J
148 DOUBLE PRECISION AINVNM, ANORM, EPS
149* ..
150* .. External Functions ..
151 LOGICAL LSAME
152 DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
153 EXTERNAL lsame, dlamch, dlange, dlansy
154* ..
155* .. External Subroutines ..
156 EXTERNAL dsymm
157* ..
158* .. Intrinsic Functions ..
159 INTRINSIC dble
160* ..
161* .. Executable Statements ..
162*
163* Quick exit if N = 0.
164*
165 IF( n.LE.0 ) THEN
166 rcond = one
167 resid = zero
168 RETURN
169 END IF
170*
171* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
172*
173 eps = dlamch( 'Epsilon' )
174 anorm = dlansy( '1', uplo, n, a, lda, rwork )
175 ainvnm = dlansy( '1', uplo, 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* Expand AINV into a full matrix and call DSYMM to multiply
184* AINV on the left by A.
185*
186 IF( lsame( uplo, 'U' ) ) THEN
187 DO 20 j = 1, n
188 DO 10 i = 1, j - 1
189 ainv( j, i ) = ainv( i, j )
190 10 CONTINUE
191 20 CONTINUE
192 ELSE
193 DO 40 j = 1, n
194 DO 30 i = j + 1, n
195 ainv( j, i ) = ainv( i, j )
196 30 CONTINUE
197 40 CONTINUE
198 END IF
199 CALL dsymm( 'Left', uplo, n, n, -one, a, lda, ainv, ldainv, zero,
200 $ work, ldwork )
201*
202* Add the identity matrix to WORK .
203*
204 DO 50 i = 1, n
205 work( i, i ) = work( i, i ) + one
206 50 CONTINUE
207*
208* Compute norm(I - A*AINV) / (N * norm(A) * norm(AINV) * EPS)
209*
210 resid = dlange( '1', n, n, work, ldwork, rwork )
211*
212 resid = ( ( resid*rcond ) / eps ) / dble( n )
213*
214 RETURN
215*
216* End of DPOT03
217*

◆ dpot05()

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

DPOT05

Purpose:
!>
!> DPOT05 tests the error bounds from iterative refinement for the
!> computed solution to a system of equations A*X = B, where A is a
!> symmetric 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
!>          symmetric 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The symmetric 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

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

◆ dpot06()

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

DPOT06

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

Definition at line 125 of file dpot06.f.

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

◆ dppt01()

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

DPPT01

Purpose:
!>
!> DPPT01 reconstructs a symmetric 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.
!>
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 DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          The original symmetric matrix A, stored as a packed
!>          triangular matrix.
!>
[in,out]AFAC
!>          AFAC is DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          On entry, the factor L or U from the L*L' or U'*U
!>          factorization of A, stored as a packed triangular matrix.
!>          Overwritten with the reconstructed matrix, and then with the
!>          difference L*L' - A (or U'*U - A).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 92 of file dppt01.f.

93*
94* -- LAPACK test routine --
95* -- LAPACK is a software package provided by Univ. of Tennessee, --
96* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
97*
98* .. Scalar Arguments ..
99 CHARACTER UPLO
100 INTEGER N
101 DOUBLE PRECISION RESID
102* ..
103* .. Array Arguments ..
104 DOUBLE PRECISION A( * ), AFAC( * ), RWORK( * )
105* ..
106*
107* =====================================================================
108*
109* .. Parameters ..
110 DOUBLE PRECISION ZERO, ONE
111 parameter( zero = 0.0d+0, one = 1.0d+0 )
112* ..
113* .. Local Scalars ..
114 INTEGER I, K, KC, NPP
115 DOUBLE PRECISION ANORM, EPS, T
116* ..
117* .. External Functions ..
118 LOGICAL LSAME
119 DOUBLE PRECISION DDOT, DLAMCH, DLANSP
120 EXTERNAL lsame, ddot, dlamch, dlansp
121* ..
122* .. External Subroutines ..
123 EXTERNAL dscal, dspr, dtpmv
124* ..
125* .. Intrinsic Functions ..
126 INTRINSIC dble
127* ..
128* .. Executable Statements ..
129*
130* Quick exit if N = 0
131*
132 IF( n.LE.0 ) THEN
133 resid = zero
134 RETURN
135 END IF
136*
137* Exit with RESID = 1/EPS if ANORM = 0.
138*
139 eps = dlamch( 'Epsilon' )
140 anorm = dlansp( '1', uplo, n, a, rwork )
141 IF( anorm.LE.zero ) THEN
142 resid = one / eps
143 RETURN
144 END IF
145*
146* Compute the product U'*U, overwriting U.
147*
148 IF( lsame( uplo, 'U' ) ) THEN
149 kc = ( n*( n-1 ) ) / 2 + 1
150 DO 10 k = n, 1, -1
151*
152* Compute the (K,K) element of the result.
153*
154 t = ddot( k, afac( kc ), 1, afac( kc ), 1 )
155 afac( kc+k-1 ) = t
156*
157* Compute the rest of column K.
158*
159 IF( k.GT.1 ) THEN
160 CALL dtpmv( 'Upper', 'Transpose', 'Non-unit', k-1, afac,
161 $ afac( kc ), 1 )
162 kc = kc - ( k-1 )
163 END IF
164 10 CONTINUE
165*
166* Compute the product L*L', overwriting L.
167*
168 ELSE
169 kc = ( n*( n+1 ) ) / 2
170 DO 20 k = n, 1, -1
171*
172* Add a multiple of column K of the factor L to each of
173* columns K+1 through N.
174*
175 IF( k.LT.n )
176 $ CALL dspr( 'Lower', n-k, one, afac( kc+1 ), 1,
177 $ afac( kc+n-k+1 ) )
178*
179* Scale column K by the diagonal element.
180*
181 t = afac( kc )
182 CALL dscal( n-k+1, t, afac( kc ), 1 )
183*
184 kc = kc - ( n-k+2 )
185 20 CONTINUE
186 END IF
187*
188* Compute the difference L*L' - A (or U'*U - A).
189*
190 npp = n*( n+1 ) / 2
191 DO 30 i = 1, npp
192 afac( i ) = afac( i ) - a( i )
193 30 CONTINUE
194*
195* Compute norm( L*U - A ) / ( N * norm(A) * EPS )
196*
197 resid = dlansp( '1', uplo, n, afac, rwork )
198*
199 resid = ( ( resid / dble( n ) ) / anorm ) / eps
200*
201 RETURN
202*
203* End of DPPT01
204*
dspr
subroutine dspr(uplo, n, alpha, x, incx, ap)
DSPR
Definition dspr.f:127

◆ dppt02()

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

DPPT02

Purpose:
!>
!> DPPT02 computes the residual in the solution of a 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
!>          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 DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          The original symmetric matrix A, stored as a packed
!>          triangular matrix.
!>
[in]X
!>          X is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 120 of file dppt02.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 UPLO
129 INTEGER LDB, LDX, N, NRHS
130 DOUBLE PRECISION RESID
131* ..
132* .. Array Arguments ..
133 DOUBLE PRECISION A( * ), B( LDB, * ), RWORK( * ), X( LDX, * )
134* ..
135*
136* =====================================================================
137*
138* .. Parameters ..
139 DOUBLE PRECISION ZERO, ONE
140 parameter( zero = 0.0d+0, one = 1.0d+0 )
141* ..
142* .. Local Scalars ..
143 INTEGER J
144 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
145* ..
146* .. External Functions ..
147 DOUBLE PRECISION DASUM, DLAMCH, DLANSP
148 EXTERNAL dasum, dlamch, dlansp
149* ..
150* .. External Subroutines ..
151 EXTERNAL dspmv
152* ..
153* .. Intrinsic Functions ..
154 INTRINSIC max
155* ..
156* .. Executable Statements ..
157*
158* Quick exit if N = 0 or NRHS = 0.
159*
160 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
161 resid = zero
162 RETURN
163 END IF
164*
165* Exit with RESID = 1/EPS if ANORM = 0.
166*
167 eps = dlamch( 'Epsilon' )
168 anorm = dlansp( '1', uplo, n, a, rwork )
169 IF( anorm.LE.zero ) THEN
170 resid = one / eps
171 RETURN
172 END IF
173*
174* Compute B - A*X for the matrix of right hand sides B.
175*
176 DO 10 j = 1, nrhs
177 CALL dspmv( uplo, n, -one, a, x( 1, j ), 1, one, b( 1, j ), 1 )
178 10 CONTINUE
179*
180* Compute the maximum over the number of right hand sides of
181* norm( B - A*X ) / ( norm(A) * norm(X) * EPS ) .
182*
183 resid = zero
184 DO 20 j = 1, nrhs
185 bnorm = dasum( n, b( 1, j ), 1 )
186 xnorm = dasum( n, x( 1, j ), 1 )
187 IF( xnorm.LE.zero ) THEN
188 resid = one / eps
189 ELSE
190 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
191 END IF
192 20 CONTINUE
193*
194 RETURN
195*
196* End of DPPT02
197*

◆ dppt03()

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

DPPT03

Purpose:
!>
!> DPPT03 computes the residual for a 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
!>          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 DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          The original symmetric matrix A, stored as a packed
!>          triangular matrix.
!>
[in]AINV
!>          AINV is DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          The (symmetric) inverse of the matrix A, stored as a packed
!>          triangular matrix.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LDWORK,N)
!>
[in]LDWORK
!>          LDWORK is INTEGER
!>          The leading dimension of the array WORK.  LDWORK >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal of the condition number of A, computed as
!>          ( 1/norm(A) ) / norm(AINV).
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(I - A*AINV) / ( N * norm(A) * norm(AINV) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 108 of file dppt03.f.

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

◆ dppt05()

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

DPPT05

Purpose:
!>
!> DPPT05 tests the error bounds from iterative refinement for the
!> computed solution to a system of equations A*X = B, where A is a
!> symmetric 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
!>          symmetric 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 DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          The upper or lower triangle of the symmetric 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 154 of file dppt05.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 UPLO
163 INTEGER LDB, LDX, LDXACT, N, NRHS
164* ..
165* .. Array Arguments ..
166 DOUBLE PRECISION AP( * ), B( LDB, * ), BERR( * ), FERR( * ),
167 $ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
168* ..
169*
170* =====================================================================
171*
172* .. Parameters ..
173 DOUBLE PRECISION ZERO, ONE
174 parameter( zero = 0.0d+0, one = 1.0d+0 )
175* ..
176* .. Local Scalars ..
177 LOGICAL UPPER
178 INTEGER I, IMAX, J, JC, K
179 DOUBLE PRECISION AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
180* ..
181* .. External Functions ..
182 LOGICAL LSAME
183 INTEGER IDAMAX
184 DOUBLE PRECISION DLAMCH
185 EXTERNAL lsame, idamax, dlamch
186* ..
187* .. Intrinsic Functions ..
188 INTRINSIC abs, max, min
189* ..
190* .. Executable Statements ..
191*
192* Quick exit if N = 0 or NRHS = 0.
193*
194 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
195 reslts( 1 ) = zero
196 reslts( 2 ) = zero
197 RETURN
198 END IF
199*
200 eps = dlamch( 'Epsilon' )
201 unfl = dlamch( 'Safe minimum' )
202 ovfl = one / unfl
203 upper = lsame( uplo, 'U' )
204*
205* Test 1: Compute the maximum of
206* norm(X - XACT) / ( norm(X) * FERR )
207* over all the vectors X and XACT using the infinity-norm.
208*
209 errbnd = zero
210 DO 30 j = 1, nrhs
211 imax = idamax( n, x( 1, j ), 1 )
212 xnorm = max( abs( x( imax, j ) ), unfl )
213 diff = zero
214 DO 10 i = 1, n
215 diff = max( diff, abs( x( i, j )-xact( i, j ) ) )
216 10 CONTINUE
217*
218 IF( xnorm.GT.one ) THEN
219 GO TO 20
220 ELSE IF( diff.LE.ovfl*xnorm ) THEN
221 GO TO 20
222 ELSE
223 errbnd = one / eps
224 GO TO 30
225 END IF
226*
227 20 CONTINUE
228 IF( diff / xnorm.LE.ferr( j ) ) THEN
229 errbnd = max( errbnd, ( diff / xnorm ) / ferr( j ) )
230 ELSE
231 errbnd = one / eps
232 END IF
233 30 CONTINUE
234 reslts( 1 ) = errbnd
235*
236* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where
237* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i )
238*
239 DO 90 k = 1, nrhs
240 DO 80 i = 1, n
241 tmp = abs( b( i, k ) )
242 IF( upper ) THEN
243 jc = ( ( i-1 )*i ) / 2
244 DO 40 j = 1, i
245 tmp = tmp + abs( ap( jc+j ) )*abs( x( j, k ) )
246 40 CONTINUE
247 jc = jc + i
248 DO 50 j = i + 1, n
249 tmp = tmp + abs( ap( jc ) )*abs( x( j, k ) )
250 jc = jc + j
251 50 CONTINUE
252 ELSE
253 jc = i
254 DO 60 j = 1, i - 1
255 tmp = tmp + abs( ap( jc ) )*abs( x( j, k ) )
256 jc = jc + n - j
257 60 CONTINUE
258 DO 70 j = i, n
259 tmp = tmp + abs( ap( jc+j-i ) )*abs( x( j, k ) )
260 70 CONTINUE
261 END IF
262 IF( i.EQ.1 ) THEN
263 axbi = tmp
264 ELSE
265 axbi = min( axbi, tmp )
266 END IF
267 80 CONTINUE
268 tmp = berr( k ) / ( ( n+1 )*eps+( n+1 )*unfl /
269 $ max( axbi, ( n+1 )*unfl ) )
270 IF( k.EQ.1 ) THEN
271 reslts( 2 ) = tmp
272 ELSE
273 reslts( 2 ) = max( reslts( 2 ), tmp )
274 END IF
275 90 CONTINUE
276*
277 RETURN
278*
279* End of DPPT05
280*

◆ dpst01()

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

DPST01

Purpose:
!>
!> DPST01 reconstructs a symmetric 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.
!>
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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDPERM,N)
!>          Overwritten with the reconstructed matrix, and then with the
!>          difference P*L*L'*P' - A (or P*U'*U*P' - A)
!>
[in]LDPERM
!>          LDPERM is INTEGER
!>          The leading dimension of the array PERM.
!>          LDAPERM >= max(1,N).
!>
[in]PIV
!>          PIV is INTEGER array, dimension (N)
!>          PIV is such that the nonzero entries are
!>          P( PIV( K ), K ) = 1.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS )
!>
[in]RANK
!>          RANK is INTEGER
!>          number of nonzero singular values of A.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 132 of file dpst01.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 DOUBLE PRECISION RESID
141 INTEGER LDA, LDAFAC, LDPERM, N, RANK
142 CHARACTER UPLO
143* ..
144* .. Array Arguments ..
145 DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ),
146 $ PERM( LDPERM, * ), RWORK( * )
147 INTEGER PIV( * )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 DOUBLE PRECISION ZERO, ONE
154 parameter( zero = 0.0d+0, one = 1.0d+0 )
155* ..
156* .. Local Scalars ..
157 DOUBLE PRECISION ANORM, EPS, T
158 INTEGER I, J, K
159* ..
160* .. External Functions ..
161 DOUBLE PRECISION DDOT, DLAMCH, DLANSY
162 LOGICAL LSAME
163 EXTERNAL ddot, dlamch, dlansy, lsame
164* ..
165* .. External Subroutines ..
166 EXTERNAL dscal, dsyr, dtrmv
167* ..
168* .. Intrinsic Functions ..
169 INTRINSIC dble
170* ..
171* .. Executable Statements ..
172*
173* Quick exit if N = 0.
174*
175 IF( n.LE.0 ) THEN
176 resid = zero
177 RETURN
178 END IF
179*
180* Exit with RESID = 1/EPS if ANORM = 0.
181*
182 eps = dlamch( 'Epsilon' )
183 anorm = dlansy( '1', uplo, n, a, lda, rwork )
184 IF( anorm.LE.zero ) THEN
185 resid = one / eps
186 RETURN
187 END IF
188*
189* Compute the product U'*U, overwriting U.
190*
191 IF( lsame( uplo, 'U' ) ) THEN
192*
193 IF( rank.LT.n ) THEN
194 DO 110 j = rank + 1, n
195 DO 100 i = rank + 1, j
196 afac( i, j ) = zero
197 100 CONTINUE
198 110 CONTINUE
199 END IF
200*
201 DO 120 k = n, 1, -1
202*
203* Compute the (K,K) element of the result.
204*
205 t = ddot( k, afac( 1, k ), 1, afac( 1, k ), 1 )
206 afac( k, k ) = t
207*
208* Compute the rest of column K.
209*
210 CALL dtrmv( 'Upper', 'Transpose', 'Non-unit', k-1, afac,
211 $ ldafac, afac( 1, k ), 1 )
212*
213 120 CONTINUE
214*
215* Compute the product L*L', overwriting L.
216*
217 ELSE
218*
219 IF( rank.LT.n ) THEN
220 DO 140 j = rank + 1, n
221 DO 130 i = j, n
222 afac( i, j ) = zero
223 130 CONTINUE
224 140 CONTINUE
225 END IF
226*
227 DO 150 k = n, 1, -1
228* Add a multiple of column K of the factor L to each of
229* columns K+1 through N.
230*
231 IF( k+1.LE.n )
232 $ CALL dsyr( 'Lower', n-k, one, afac( k+1, k ), 1,
233 $ afac( k+1, k+1 ), ldafac )
234*
235* Scale column K by the diagonal element.
236*
237 t = afac( k, k )
238 CALL dscal( n-k+1, t, afac( k, k ), 1 )
239 150 CONTINUE
240*
241 END IF
242*
243* Form P*L*L'*P' or P*U'*U*P'
244*
245 IF( lsame( uplo, 'U' ) ) THEN
246*
247 DO 170 j = 1, n
248 DO 160 i = 1, n
249 IF( piv( i ).LE.piv( j ) ) THEN
250 IF( i.LE.j ) THEN
251 perm( piv( i ), piv( j ) ) = afac( i, j )
252 ELSE
253 perm( piv( i ), piv( j ) ) = afac( j, i )
254 END IF
255 END IF
256 160 CONTINUE
257 170 CONTINUE
258*
259*
260 ELSE
261*
262 DO 190 j = 1, n
263 DO 180 i = 1, n
264 IF( piv( i ).GE.piv( j ) ) THEN
265 IF( i.GE.j ) THEN
266 perm( piv( i ), piv( j ) ) = afac( i, j )
267 ELSE
268 perm( piv( i ), piv( j ) ) = afac( j, i )
269 END IF
270 END IF
271 180 CONTINUE
272 190 CONTINUE
273*
274 END IF
275*
276* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A).
277*
278 IF( lsame( uplo, 'U' ) ) THEN
279 DO 210 j = 1, n
280 DO 200 i = 1, j
281 perm( i, j ) = perm( i, j ) - a( i, j )
282 200 CONTINUE
283 210 CONTINUE
284 ELSE
285 DO 230 j = 1, n
286 DO 220 i = j, n
287 perm( i, j ) = perm( i, j ) - a( i, j )
288 220 CONTINUE
289 230 CONTINUE
290 END IF
291*
292* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or
293* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ).
294*
295 resid = dlansy( '1', uplo, n, perm, ldafac, rwork )
296*
297 resid = ( ( resid / dble( n ) ) / anorm ) / eps
298*
299 RETURN
300*
301* End of DPST01
302*

◆ dptt01()

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

DPTT01

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

Definition at line 90 of file dptt01.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 N
98 DOUBLE PRECISION RESID
99* ..
100* .. Array Arguments ..
101 DOUBLE PRECISION D( * ), DF( * ), E( * ), EF( * ), WORK( * )
102* ..
103*
104* =====================================================================
105*
106* .. Parameters ..
107 DOUBLE PRECISION ONE, ZERO
108 parameter( one = 1.0d+0, zero = 0.0d+0 )
109* ..
110* .. Local Scalars ..
111 INTEGER I
112 DOUBLE PRECISION ANORM, DE, EPS
113* ..
114* .. External Functions ..
115 DOUBLE PRECISION DLAMCH
116 EXTERNAL dlamch
117* ..
118* .. Intrinsic Functions ..
119 INTRINSIC abs, dble, max
120* ..
121* .. Executable Statements ..
122*
123* Quick return if possible
124*
125 IF( n.LE.0 ) THEN
126 resid = zero
127 RETURN
128 END IF
129*
130 eps = dlamch( 'Epsilon' )
131*
132* Construct the difference L*D*L' - A.
133*
134 work( 1 ) = df( 1 ) - d( 1 )
135 DO 10 i = 1, n - 1
136 de = df( i )*ef( i )
137 work( n+i ) = de - e( i )
138 work( 1+i ) = de*ef( i ) + df( i+1 ) - d( i+1 )
139 10 CONTINUE
140*
141* Compute the 1-norms of the tridiagonal matrices A and WORK.
142*
143 IF( n.EQ.1 ) THEN
144 anorm = d( 1 )
145 resid = abs( work( 1 ) )
146 ELSE
147 anorm = max( d( 1 )+abs( e( 1 ) ), d( n )+abs( e( n-1 ) ) )
148 resid = max( abs( work( 1 ) )+abs( work( n+1 ) ),
149 $ abs( work( n ) )+abs( work( 2*n-1 ) ) )
150 DO 20 i = 2, n - 1
151 anorm = max( anorm, d( i )+abs( e( i ) )+abs( e( i-1 ) ) )
152 resid = max( resid, abs( work( i ) )+abs( work( n+i-1 ) )+
153 $ abs( work( n+i ) ) )
154 20 CONTINUE
155 END IF
156*
157* Compute norm(L*D*L' - A) / (n * norm(A) * EPS)
158*
159 IF( anorm.LE.zero ) THEN
160 IF( resid.NE.zero )
161 $ resid = one / eps
162 ELSE
163 resid = ( ( resid / dble( n ) ) / anorm ) / eps
164 END IF
165*
166 RETURN
167*
168* End of DPTT01
169*

◆ dptt02()

subroutine dptt02 ( integer n,
integer nrhs,
double precision, dimension( * ) d,
double precision, dimension( * ) e,
double precision, dimension( ldx, * ) x,
integer ldx,
double precision, dimension( ldb, * ) b,
integer ldb,
double precision resid )

DPTT02

Purpose:
!>
!> DPTT02 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]N
!>          N is INTEGTER
!>          The order of the matrix A.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices B and X.  NRHS >= 0.
!>
[in]D
!>          D is DOUBLE PRECISION array, dimension (N)
!>          The n diagonal elements of the tridiagonal matrix A.
!>
[in]E
!>          E is DOUBLE PRECISION array, dimension (N-1)
!>          The (n-1) subdiagonal elements of the tridiagonal matrix A.
!>
[in]X
!>          X is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          On entry, the n by nrhs matrix of right hand side vectors B.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,N).
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(B - A*X) / (norm(A) * norm(X) * EPS)
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 103 of file dptt02.f.

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

◆ dptt05()

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

DPTT05

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

Definition at line 148 of file dptt05.f.

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

◆ dqlt01()

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

DQLT01

Purpose:
!>
!> DQLT01 tests DGEQLF, which computes the QL factorization of an m-by-n
!> matrix A, and partially tests DORGQL which forms the m-by-m
!> orthogonal matrix Q.
!>
!> DQLT01 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The m-by-n matrix A.
!>
[out]AF
!>          AF is DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the QL factorization of A, as returned by DGEQLF.
!>          See DGEQLF for further details.
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDA,M)
!>          The m-by-m orthogonal matrix Q.
!>
[out]L
!>          L is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by DGEQLF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file dqlt01.f.

126*
127* -- LAPACK test routine --
128* -- LAPACK is a software package provided by Univ. of Tennessee, --
129* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
130*
131* .. Scalar Arguments ..
132 INTEGER LDA, LWORK, M, N
133* ..
134* .. Array Arguments ..
135 DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), L( LDA, * ),
136 $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
137 $ WORK( LWORK )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ZERO, ONE
144 parameter( zero = 0.0d+0, one = 1.0d+0 )
145 DOUBLE PRECISION ROGUE
146 parameter( rogue = -1.0d+10 )
147* ..
148* .. Local Scalars ..
149 INTEGER INFO, MINMN
150 DOUBLE PRECISION ANORM, EPS, RESID
151* ..
152* .. External Functions ..
153 DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
154 EXTERNAL dlamch, dlange, dlansy
155* ..
156* .. External Subroutines ..
157 EXTERNAL dgemm, dgeqlf, dlacpy, dlaset, dorgql, dsyrk
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC dble, max, min
161* ..
162* .. Scalars in Common ..
163 CHARACTER*32 SRNAMT
164* ..
165* .. Common blocks ..
166 COMMON / srnamc / srnamt
167* ..
168* .. Executable Statements ..
169*
170 minmn = min( m, n )
171 eps = dlamch( 'Epsilon' )
172*
173* Copy the matrix A to the array AF.
174*
175 CALL dlacpy( 'Full', m, n, a, lda, af, lda )
176*
177* Factorize the matrix A in the array AF.
178*
179 srnamt = 'DGEQLF'
180 CALL dgeqlf( m, n, af, lda, tau, work, lwork, info )
181*
182* Copy details of Q
183*
184 CALL dlaset( 'Full', m, m, rogue, rogue, q, lda )
185 IF( m.GE.n ) THEN
186 IF( n.LT.m .AND. n.GT.0 )
187 $ CALL dlacpy( 'Full', m-n, n, af, lda, q( 1, m-n+1 ), lda )
188 IF( n.GT.1 )
189 $ CALL dlacpy( '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 dlacpy( '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 = 'DORGQL'
200 CALL dorgql( m, m, minmn, q, lda, tau, work, lwork, info )
201*
202* Copy L
203*
204 CALL dlaset( 'Full', m, n, zero, zero, l, lda )
205 IF( m.GE.n ) THEN
206 IF( n.GT.0 )
207 $ CALL dlacpy( '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 dlacpy( 'Full', m, n-m, af, lda, l, lda )
212 IF( m.GT.0 )
213 $ CALL dlacpy( '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 dgemm( 'Transpose', 'No transpose', m, n, m, -one, q, lda, a,
220 $ lda, one, l, lda )
221*
222* Compute norm( L - Q'*A ) / ( M * norm(A) * EPS ) .
223*
224 anorm = dlange( '1', m, n, a, lda, rwork )
225 resid = dlange( '1', m, n, l, lda, rwork )
226 IF( anorm.GT.zero ) THEN
227 result( 1 ) = ( ( resid / dble( max( 1, m ) ) ) / anorm ) / eps
228 ELSE
229 result( 1 ) = zero
230 END IF
231*
232* Compute I - Q'*Q
233*
234 CALL dlaset( 'Full', m, m, zero, one, l, lda )
235 CALL dsyrk( 'Upper', 'Transpose', m, m, -one, q, lda, one, l,
236 $ lda )
237*
238* Compute norm( I - Q'*Q ) / ( M * EPS ) .
239*
240 resid = dlansy( '1', 'Upper', m, l, lda, rwork )
241*
242 result( 2 ) = ( resid / dble( max( 1, m ) ) ) / eps
243*
244 RETURN
245*
246* End of DQLT01
247*

◆ dqlt02()

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

DQLT02

Purpose:
!>
!> DQLT02 tests DORGQL, 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, DQLT02 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The m-by-n matrix A which was factorized by DQLT01.
!>
[in]AF
!>          AF is DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the QL factorization of A, as returned by DGEQLF.
!>          See DGEQLF for further details.
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDA,N)
!>
[out]L
!>          L is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>          The scalar factors of the elementary reflectors corresponding
!>          to the QL factorization in AF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( L - Q'*A ) / ( M * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 134 of file dqlt02.f.

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

◆ dqlt03()

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

DQLT03

Purpose:
!>
!> DQLT03 tests DORMQL, which computes Q*C, Q'*C, C*Q or C*Q'.
!>
!> DQLT03 compares the results of a call to DORMQL with the results of
!> forming Q explicitly by a call to DORGQL and then performing matrix
!> multiplication by a call to DGEMM.
!>
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 DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the QL factorization of an m-by-n matrix, as
!>          returned by DGEQLF. See SGEQLF for further details.
!>
[out]C
!>          C is DOUBLE PRECISION array, dimension (LDA,N)
!>
[out]CC
!>          CC is DOUBLE PRECISION array, dimension (LDA,N)
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDA,M)
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays AF, C, CC, and Q.
!>
[in]TAU
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors corresponding
!>          to the QL factorization in AF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of WORK.  LWORK must be at least M, and should be
!>          M*NB, where NB is the blocksize for this environment.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The test ratios compare two techniques for multiplying a
!>          random matrix C by an m-by-m orthogonal matrix Q.
!>          RESULT(1) = norm( Q*C - Q*C )  / ( M * norm(C) * EPS )
!>          RESULT(2) = norm( C*Q - C*Q )  / ( M * norm(C) * EPS )
!>          RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS )
!>          RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 134 of file dqlt03.f.

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

◆ dqpt01()

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

DQPT01

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

◆ dqrt01()

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

DQRT01

Purpose:
!>
!> DQRT01 tests DGEQRF, which computes the QR factorization of an m-by-n
!> matrix A, and partially tests DORGQR which forms the m-by-m
!> orthogonal matrix Q.
!>
!> DQRT01 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The m-by-n matrix A.
!>
[out]AF
!>          AF is DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the QR factorization of A, as returned by DGEQRF.
!>          See DGEQRF for further details.
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDA,M)
!>          The m-by-m orthogonal matrix Q.
!>
[out]R
!>          R is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by DGEQRF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file dqrt01.f.

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

◆ dqrt01p()

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

DQRT01P

Purpose:
!>
!> DQRT01P tests DGEQRFP, which computes the QR factorization of an m-by-n
!> matrix A, and partially tests DORGQR which forms the m-by-m
!> orthogonal matrix Q.
!>
!> DQRT01P 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The m-by-n matrix A.
!>
[out]AF
!>          AF is DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the QR factorization of A, as returned by DGEQRFP.
!>          See DGEQRFP for further details.
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDA,M)
!>          The m-by-m orthogonal matrix Q.
!>
[out]R
!>          R is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by DGEQRFP.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file dqrt01p.f.

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

◆ dqrt02()

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

DQRT02

Purpose:
!>
!> DQRT02 tests DORGQR, 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, DQRT02 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The m-by-n matrix A which was factorized by DQRT01.
!>
[in]AF
!>          AF is DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the QR factorization of A, as returned by DGEQRF.
!>          See DGEQRF for further details.
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDA,N)
!>
[out]R
!>          R is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>          The scalar factors of the elementary reflectors corresponding
!>          to the QR factorization in AF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( R - Q'*A ) / ( M * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q'*Q ) / ( M * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 133 of file dqrt02.f.

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

◆ dqrt03()

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

DQRT03

Purpose:
!>
!> DQRT03 tests DORMQR, which computes Q*C, Q'*C, C*Q or C*Q'.
!>
!> DQRT03 compares the results of a call to DORMQR with the results of
!> forming Q explicitly by a call to DORGQR and then performing matrix
!> multiplication by a call to DGEMM.
!>
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 DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the QR factorization of an m-by-n matrix, as
!>          returned by DGEQRF. See DGEQRF for further details.
!>
[out]C
!>          C is DOUBLE PRECISION array, dimension (LDA,N)
!>
[out]CC
!>          CC is DOUBLE PRECISION array, dimension (LDA,N)
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDA,M)
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays AF, C, CC, and Q.
!>
[in]TAU
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors corresponding
!>          to the QR factorization in AF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of WORK.  LWORK must be at least M, and should be
!>          M*NB, where NB is the blocksize for this environment.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The test ratios compare two techniques for multiplying a
!>          random matrix C by an m-by-m orthogonal matrix Q.
!>          RESULT(1) = norm( Q*C - Q*C )  / ( M * norm(C) * EPS )
!>          RESULT(2) = norm( C*Q - C*Q )  / ( M * norm(C) * EPS )
!>          RESULT(3) = norm( Q'*C - Q'*C )/ ( M * norm(C) * EPS )
!>          RESULT(4) = norm( C*Q' - C*Q' )/ ( M * norm(C) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 134 of file dqrt03.f.

136*
137* -- LAPACK test routine --
138* -- LAPACK is a software package provided by Univ. of Tennessee, --
139* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
140*
141* .. Scalar Arguments ..
142 INTEGER K, LDA, LWORK, M, N
143* ..
144* .. Array Arguments ..
145 DOUBLE PRECISION AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
146 $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
147 $ WORK( LWORK )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 DOUBLE PRECISION ONE
154 parameter( one = 1.0d0 )
155 DOUBLE PRECISION ROGUE
156 parameter( rogue = -1.0d+10 )
157* ..
158* .. Local Scalars ..
159 CHARACTER SIDE, TRANS
160 INTEGER INFO, ISIDE, ITRANS, J, MC, NC
161 DOUBLE PRECISION CNORM, EPS, RESID
162* ..
163* .. External Functions ..
164 LOGICAL LSAME
165 DOUBLE PRECISION DLAMCH, DLANGE
166 EXTERNAL lsame, dlamch, dlange
167* ..
168* .. External Subroutines ..
169 EXTERNAL dgemm, dlacpy, dlarnv, dlaset, dorgqr, dormqr
170* ..
171* .. Local Arrays ..
172 INTEGER ISEED( 4 )
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC dble, max
176* ..
177* .. Scalars in Common ..
178 CHARACTER*32 SRNAMT
179* ..
180* .. Common blocks ..
181 COMMON / srnamc / srnamt
182* ..
183* .. Data statements ..
184 DATA iseed / 1988, 1989, 1990, 1991 /
185* ..
186* .. Executable Statements ..
187*
188 eps = dlamch( 'Epsilon' )
189*
190* Copy the first k columns of the factorization to the array Q
191*
192 CALL dlaset( 'Full', m, m, rogue, rogue, q, lda )
193 CALL dlacpy( 'Lower', m-1, k, af( 2, 1 ), lda, q( 2, 1 ), lda )
194*
195* Generate the m-by-m matrix Q
196*
197 srnamt = 'DORGQR'
198 CALL dorgqr( 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 dlarnv( 2, iseed, mc, c( 1, j ) )
215 10 CONTINUE
216 cnorm = dlange( '1', mc, nc, c, lda, rwork )
217 IF( cnorm.EQ.0.0d0 )
218 $ cnorm = one
219*
220 DO 20 itrans = 1, 2
221 IF( itrans.EQ.1 ) THEN
222 trans = 'N'
223 ELSE
224 trans = 'T'
225 END IF
226*
227* Copy C
228*
229 CALL dlacpy( 'Full', mc, nc, c, lda, cc, lda )
230*
231* Apply Q or Q' to C
232*
233 srnamt = 'DORMQR'
234 CALL dormqr( 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 dgemm( trans, 'No transpose', mc, nc, mc, -one, q,
241 $ lda, c, lda, one, cc, lda )
242 ELSE
243 CALL dgemm( 'No transpose', trans, mc, nc, nc, -one, c,
244 $ lda, q, lda, one, cc, lda )
245 END IF
246*
247* Compute error in the difference
248*
249 resid = dlange( '1', mc, nc, cc, lda, rwork )
250 result( ( iside-1 )*2+itrans ) = resid /
251 $ ( dble( max( 1, m ) )*cnorm*eps )
252*
253 20 CONTINUE
254 30 CONTINUE
255*
256 RETURN
257*
258* End of DQRT03
259*

◆ dqrt04()

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

DQRT04

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

Definition at line 72 of file dqrt04.f.

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

◆ dqrt05()

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

DQRT05

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

Definition at line 79 of file dqrt05.f.

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

◆ dqrt11()

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

DQRT11

Purpose:
!>
!> DQRT11 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (K)
!>          The scaling factors tau for the elementary transformations as
!>          computed by the QR factorization routine.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dqrt11.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 DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK )
108* ..
109*
110* =====================================================================
111*
112* .. Parameters ..
113 DOUBLE PRECISION ZERO, ONE
114 parameter( zero = 0.0d0, one = 1.0d0 )
115* ..
116* .. Local Scalars ..
117 INTEGER INFO, J
118* ..
119* .. External Functions ..
120 DOUBLE PRECISION DLAMCH, DLANGE
121 EXTERNAL dlamch, dlange
122* ..
123* .. External Subroutines ..
124 EXTERNAL dlaset, dorm2r, xerbla
125* ..
126* .. Intrinsic Functions ..
127 INTRINSIC dble
128* ..
129* .. Local Arrays ..
130 DOUBLE PRECISION RDUMMY( 1 )
131* ..
132* .. Executable Statements ..
133*
134 dqrt11 = zero
135*
136* Test for sufficient workspace
137*
138 IF( lwork.LT.m*m+m ) THEN
139 CALL xerbla( 'DQRT11', 7 )
140 RETURN
141 END IF
142*
143* Quick return if possible
144*
145 IF( m.LE.0 )
146 $ RETURN
147*
148 CALL dlaset( 'Full', m, m, zero, one, work, m )
149*
150* Form Q
151*
152 CALL dorm2r( '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 dorm2r( 'Left', 'Transpose', m, m, k, a, lda, tau, work, m,
158 $ 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 dqrt11 = dlange( 'One-norm', m, m, work, m, rdummy ) /
165 $ ( dble( m )*dlamch( 'Epsilon' ) )
166*
167 RETURN
168*
169* End of DQRT11
170*

◆ dqrt12()

double precision function dqrt12 ( integer m,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) s,
double precision, dimension( lwork ) work,
integer lwork )

DQRT12

Purpose:
!>
!> DQRT12 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The M-by-N matrix A. Only the upper trapezoid is referenced.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>
[in]S
!>          S is DOUBLE PRECISION array, dimension (min(M,N))
!>          The singular values of the matrix A.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK. LWORK >= max(M*N + 4*min(M,N) +
!>          max(M,N), M*N+2*MIN( M, N )+4*N).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

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

◆ dqrt13()

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

DQRT13

Purpose:
!>
!> DQRT13 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The M-by-N matrix A.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>
[out]NORMA
!>          NORMA is DOUBLE PRECISION
!>          The one-norm of A.
!>
[in,out]ISEED
!>          ISEED is integer array, dimension (4)
!>          Seed for random number generator
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 90 of file dqrt13.f.

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

◆ dqrt14()

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

DQRT14

Purpose:
!>
!> DQRT14 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 = 'T') 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
!>          = 'T':  Transpose, check for X in the 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          If TRANS = 'N', the N-by-NRHS matrix X.
!>          IF TRANS = 'T', the M-by-NRHS matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          length of workspace array required
!>          If TRANS = 'N', LWORK >= (M+NRHS)*(N+2);
!>          if TRANS = 'T', 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 dqrt14.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 DOUBLE PRECISION A( LDA, * ), WORK( LWORK ), X( LDX, * )
127* ..
128*
129* =====================================================================
130*
131* .. Parameters ..
132 DOUBLE PRECISION ZERO, ONE
133 parameter( zero = 0.0d0, one = 1.0d0 )
134* ..
135* .. Local Scalars ..
136 LOGICAL TPSD
137 INTEGER I, INFO, J, LDWORK
138 DOUBLE PRECISION ANRM, ERR, XNRM
139* ..
140* .. Local Arrays ..
141 DOUBLE PRECISION RWORK( 1 )
142* ..
143* .. External Functions ..
144 LOGICAL LSAME
145 DOUBLE PRECISION DLAMCH, DLANGE
146 EXTERNAL lsame, dlamch, dlange
147* ..
148* .. External Subroutines ..
149 EXTERNAL dgelq2, dgeqr2, dlacpy, dlascl, xerbla
150* ..
151* .. Intrinsic Functions ..
152 INTRINSIC abs, dble, max, min
153* ..
154* .. Executable Statements ..
155*
156 dqrt14 = 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( 'DQRT14', 10 )
162 RETURN
163 ELSE IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
164 RETURN
165 END IF
166 ELSE IF( lsame( trans, 'T' ) ) THEN
167 ldwork = m
168 tpsd = .true.
169 IF( lwork.LT.( n+nrhs )*( m+2 ) ) THEN
170 CALL xerbla( 'DQRT14', 10 )
171 RETURN
172 ELSE IF( m.LE.0 .OR. nrhs.LE.0 ) THEN
173 RETURN
174 END IF
175 ELSE
176 CALL xerbla( 'DQRT14', 1 )
177 RETURN
178 END IF
179*
180* Copy and scale A
181*
182 CALL dlacpy( 'All', m, n, a, lda, work, ldwork )
183 anrm = dlange( 'M', m, n, work, ldwork, rwork )
184 IF( anrm.NE.zero )
185 $ CALL dlascl( '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 dlacpy( 'All', m, nrhs, x, ldx, work( n*ldwork+1 ),
194 $ ldwork )
195 xnrm = dlange( 'M', m, nrhs, work( n*ldwork+1 ), ldwork,
196 $ rwork )
197 IF( xnrm.NE.zero )
198 $ CALL dlascl( 'G', 0, 0, xnrm, one, m, nrhs,
199 $ work( n*ldwork+1 ), ldwork, info )
200*
201* Compute QR factorization of X
202*
203 CALL dgeqr2( 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 ) = x( i, j )
225 30 CONTINUE
226 40 CONTINUE
227*
228 xnrm = dlange( 'M', nrhs, n, work( m+1 ), ldwork, rwork )
229 IF( xnrm.NE.zero )
230 $ CALL dlascl( 'G', 0, 0, xnrm, one, nrhs, n, work( m+1 ),
231 $ ldwork, info )
232*
233* Compute LQ factorization of work
234*
235 CALL dgelq2( 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 dqrt14 = err / ( dble( max( m, n, nrhs ) )*dlamch( 'Epsilon' ) )
251*
252 RETURN
253*
254* End of DQRT14
255*

◆ dqrt15()

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

DQRT15

Purpose:
!>
!> DQRT15 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDB, NRHS)
!>          A matrix that is in the range space of matrix A.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.
!>
[out]S
!>          S is DOUBLE PRECISION array, dimension MIN(M,N)
!>          Singular values of A.
!>
[out]RANK
!>          RANK is INTEGER
!>          number of nonzero singular values of A.
!>
[out]NORMA
!>          NORMA is DOUBLE PRECISION
!>          one-norm of A.
!>
[out]NORMB
!>          NORMB is DOUBLE PRECISION
!>          one-norm of B.
!>
[in,out]ISEED
!>          ISEED is integer array, dimension (4)
!>          seed for random number generator.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 146 of file dqrt15.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 INTEGER LDA, LDB, LWORK, M, N, NRHS, RANK, RKSEL, SCALE
155 DOUBLE PRECISION NORMA, NORMB
156* ..
157* .. Array Arguments ..
158 INTEGER ISEED( 4 )
159 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( LWORK )
160* ..
161*
162* =====================================================================
163*
164* .. Parameters ..
165 DOUBLE PRECISION ZERO, ONE, TWO, SVMIN
166 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0,
167 $ svmin = 0.1d0 )
168* ..
169* .. Local Scalars ..
170 INTEGER INFO, J, MN
171 DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TEMP
172* ..
173* .. Local Arrays ..
174 DOUBLE PRECISION DUMMY( 1 )
175* ..
176* .. External Functions ..
177 DOUBLE PRECISION DASUM, DLAMCH, DLANGE, DLARND, DNRM2
178 EXTERNAL dasum, dlamch, dlange, dlarnd, dnrm2
179* ..
180* .. External Subroutines ..
181 EXTERNAL dgemm, dlaord, dlarf, dlarnv, dlaror, dlascl,
182 $ dlaset, dscal, xerbla
183* ..
184* .. Intrinsic Functions ..
185 INTRINSIC abs, max, min
186* ..
187* .. Executable Statements ..
188*
189 mn = min( m, n )
190 IF( lwork.LT.max( m+mn, mn*nrhs, 2*n+m ) ) THEN
191 CALL xerbla( 'DQRT15', 16 )
192 RETURN
193 END IF
194*
195 smlnum = dlamch( 'Safe minimum' )
196 bignum = one / smlnum
197 eps = dlamch( 'Epsilon' )
198 smlnum = ( smlnum / eps ) / eps
199 bignum = one / smlnum
200*
201* Determine rank and (unscaled) singular values
202*
203 IF( rksel.EQ.1 ) THEN
204 rank = mn
205 ELSE IF( rksel.EQ.2 ) THEN
206 rank = ( 3*mn ) / 4
207 DO 10 j = rank + 1, mn
208 s( j ) = zero
209 10 CONTINUE
210 ELSE
211 CALL xerbla( 'DQRT15', 2 )
212 END IF
213*
214 IF( rank.GT.0 ) THEN
215*
216* Nontrivial case
217*
218 s( 1 ) = one
219 DO 30 j = 2, rank
220 20 CONTINUE
221 temp = dlarnd( 1, iseed )
222 IF( temp.GT.svmin ) THEN
223 s( j ) = abs( temp )
224 ELSE
225 GO TO 20
226 END IF
227 30 CONTINUE
228 CALL dlaord( 'Decreasing', rank, s, 1 )
229*
230* Generate 'rank' columns of a random orthogonal matrix in A
231*
232 CALL dlarnv( 2, iseed, m, work )
233 CALL dscal( m, one / dnrm2( m, work, 1 ), work, 1 )
234 CALL dlaset( 'Full', m, rank, zero, one, a, lda )
235 CALL dlarf( 'Left', m, rank, work, 1, two, a, lda,
236 $ work( m+1 ) )
237*
238* workspace used: m+mn
239*
240* Generate consistent rhs in the range space of A
241*
242 CALL dlarnv( 2, iseed, rank*nrhs, work )
243 CALL dgemm( 'No transpose', 'No transpose', m, nrhs, rank, one,
244 $ a, lda, work, rank, zero, b, ldb )
245*
246* work space used: <= mn *nrhs
247*
248* generate (unscaled) matrix A
249*
250 DO 40 j = 1, rank
251 CALL dscal( m, s( j ), a( 1, j ), 1 )
252 40 CONTINUE
253 IF( rank.LT.n )
254 $ CALL dlaset( 'Full', m, n-rank, zero, zero, a( 1, rank+1 ),
255 $ lda )
256 CALL dlaror( 'Right', 'No initialization', m, n, a, lda, iseed,
257 $ work, info )
258*
259 ELSE
260*
261* work space used 2*n+m
262*
263* Generate null matrix and rhs
264*
265 DO 50 j = 1, mn
266 s( j ) = zero
267 50 CONTINUE
268 CALL dlaset( 'Full', m, n, zero, zero, a, lda )
269 CALL dlaset( 'Full', m, nrhs, zero, zero, b, ldb )
270*
271 END IF
272*
273* Scale the matrix
274*
275 IF( scale.NE.1 ) THEN
276 norma = dlange( 'Max', m, n, a, lda, dummy )
277 IF( norma.NE.zero ) THEN
278 IF( scale.EQ.2 ) THEN
279*
280* matrix scaled up
281*
282 CALL dlascl( 'General', 0, 0, norma, bignum, m, n, a,
283 $ lda, info )
284 CALL dlascl( 'General', 0, 0, norma, bignum, mn, 1, s,
285 $ mn, info )
286 CALL dlascl( 'General', 0, 0, norma, bignum, m, nrhs, b,
287 $ ldb, info )
288 ELSE IF( scale.EQ.3 ) THEN
289*
290* matrix scaled down
291*
292 CALL dlascl( 'General', 0, 0, norma, smlnum, m, n, a,
293 $ lda, info )
294 CALL dlascl( 'General', 0, 0, norma, smlnum, mn, 1, s,
295 $ mn, info )
296 CALL dlascl( 'General', 0, 0, norma, smlnum, m, nrhs, b,
297 $ ldb, info )
298 ELSE
299 CALL xerbla( 'DQRT15', 1 )
300 RETURN
301 END IF
302 END IF
303 END IF
304*
305 norma = dasum( mn, s, 1 )
306 normb = dlange( 'One-norm', m, nrhs, b, ldb, dummy )
307*
308 RETURN
309*
310* End of DQRT15
311*
dlarf
subroutine dlarf(side, m, n, v, incv, tau, c, ldc, work)
DLARF applies an elementary reflector to a general rectangular matrix.
Definition dlarf.f:124
dlaror
subroutine dlaror(side, init, m, n, a, lda, iseed, x, info)
DLAROR
Definition dlaror.f:146

◆ dqrt16()

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

DQRT16

Purpose:
!>
!> DQRT16 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'*x = b, where A' is the transpose of A
!>          = 'C':  A'*x = b, where A' is the 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          On entry, the right hand side vectors for the system of
!>          linear equations.
!>          On exit, B is overwritten with the difference B - A*X.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  IF TRANS = 'N',
!>          LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(B - A*X) / ( max(m,n) * norm(A) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 131 of file dqrt16.f.

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

◆ dqrt17()

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

DQRT17

Purpose:
!>
!> DQRT17 computes the ratio
!>
!>    norm(R**T * op(A)) / ( norm(A) * alpha * max(M,N,NRHS) * EPS ),
!>
!> where R = B - op(A)*X, op(A) is A or A**T, 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.
!>          = 'T':  Transpose, op(A) = A**T.
!>
[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 = 'T', 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 = 'T', 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          If TRANS = 'N', the n-by-nrhs matrix X.
!>          If TRANS = 'T', 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 = 'T', LDX >= M.
!>
[in]B
!>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
!>          If TRANS = 'N', the m-by-nrhs matrix B.
!>          If TRANS = 'T', 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 = 'T', LDB >= N.
!>
[out]C
!>          C is DOUBLE PRECISION array, dimension (LDB,NRHS)
!>
[out]WORK
!>          WORK is DOUBLE PRECISION 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 dqrt17.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 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDB, * ),
164 $ WORK( LWORK ), X( LDX, * )
165* ..
166*
167* =====================================================================
168*
169* .. Parameters ..
170 DOUBLE PRECISION ZERO, ONE
171 parameter( zero = 0.0d0, one = 1.0d0 )
172* ..
173* .. Local Scalars ..
174 INTEGER INFO, ISCL, NCOLS, NROWS
175 DOUBLE PRECISION ERR, NORMA, NORMB, NORMRS, SMLNUM
176* ..
177* .. Local Arrays ..
178 DOUBLE PRECISION RWORK( 1 )
179* ..
180* .. External Functions ..
181 LOGICAL LSAME
182 DOUBLE PRECISION DLAMCH, DLANGE
183 EXTERNAL lsame, dlamch, dlange
184* ..
185* .. External Subroutines ..
186 EXTERNAL dgemm, dlacpy, dlascl, xerbla
187* ..
188* .. Intrinsic Functions ..
189 INTRINSIC dble, max
190* ..
191* .. Executable Statements ..
192*
193 dqrt17 = zero
194*
195 IF( lsame( trans, 'N' ) ) THEN
196 nrows = m
197 ncols = n
198 ELSE IF( lsame( trans, 'T' ) ) THEN
199 nrows = n
200 ncols = m
201 ELSE
202 CALL xerbla( 'DQRT17', 1 )
203 RETURN
204 END IF
205*
206 IF( lwork.LT.ncols*nrhs ) THEN
207 CALL xerbla( 'DQRT17', 13 )
208 RETURN
209 END IF
210*
211 IF( m.LE.0 .OR. n.LE.0 .OR. nrhs.LE.0 ) THEN
212 RETURN
213 END IF
214*
215 norma = dlange( 'One-norm', m, n, a, lda, rwork )
216 smlnum = dlamch( 'Safe minimum' ) / dlamch( 'Precision' )
217 iscl = 0
218*
219* compute residual and scale it
220*
221 CALL dlacpy( 'All', nrows, nrhs, b, ldb, c, ldb )
222 CALL dgemm( trans, 'No transpose', nrows, nrhs, ncols, -one, a,
223 $ lda, x, ldx, one, c, ldb )
224 normrs = dlange( 'Max', nrows, nrhs, c, ldb, rwork )
225 IF( normrs.GT.smlnum ) THEN
226 iscl = 1
227 CALL dlascl( 'General', 0, 0, normrs, one, nrows, nrhs, c, ldb,
228 $ info )
229 END IF
230*
231* compute R**T * op(A)
232*
233 CALL dgemm( 'Transpose', trans, nrhs, ncols, nrows, one, c, ldb,
234 $ a, lda, zero, work, nrhs )
235*
236* compute and properly scale error
237*
238 err = dlange( '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 = dlange( '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 dqrt17 = err / ( dlamch( 'Epsilon' )*dble( max( m, n, nrhs ) ) )
255 RETURN
256*
257* End of DQRT17
258*

◆ drqt01()

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

DRQT01

Purpose:
!>
!> DRQT01 tests DGERQF, which computes the RQ factorization of an m-by-n
!> matrix A, and partially tests DORGRQ which forms the n-by-n
!> orthogonal matrix Q.
!>
!> DRQT01 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The m-by-n matrix A.
!>
[out]AF
!>          AF is DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the RQ factorization of A, as returned by DGERQF.
!>          See DGERQF for further details.
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDA,N)
!>          The n-by-n orthogonal matrix Q.
!>
[out]R
!>          R is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors, as returned
!>          by DGERQF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (max(M,N))
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 124 of file drqt01.f.

126*
127* -- LAPACK test routine --
128* -- LAPACK is a software package provided by Univ. of Tennessee, --
129* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
130*
131* .. Scalar Arguments ..
132 INTEGER LDA, LWORK, M, N
133* ..
134* .. Array Arguments ..
135 DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), Q( LDA, * ),
136 $ R( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
137 $ WORK( LWORK )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 DOUBLE PRECISION ZERO, ONE
144 parameter( zero = 0.0d+0, one = 1.0d+0 )
145 DOUBLE PRECISION ROGUE
146 parameter( rogue = -1.0d+10 )
147* ..
148* .. Local Scalars ..
149 INTEGER INFO, MINMN
150 DOUBLE PRECISION ANORM, EPS, RESID
151* ..
152* .. External Functions ..
153 DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
154 EXTERNAL dlamch, dlange, dlansy
155* ..
156* .. External Subroutines ..
157 EXTERNAL dgemm, dgerqf, dlacpy, dlaset, dorgrq, dsyrk
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC dble, max, min
161* ..
162* .. Scalars in Common ..
163 CHARACTER*32 SRNAMT
164* ..
165* .. Common blocks ..
166 COMMON / srnamc / srnamt
167* ..
168* .. Executable Statements ..
169*
170 minmn = min( m, n )
171 eps = dlamch( 'Epsilon' )
172*
173* Copy the matrix A to the array AF.
174*
175 CALL dlacpy( 'Full', m, n, a, lda, af, lda )
176*
177* Factorize the matrix A in the array AF.
178*
179 srnamt = 'DGERQF'
180 CALL dgerqf( m, n, af, lda, tau, work, lwork, info )
181*
182* Copy details of Q
183*
184 CALL dlaset( 'Full', n, n, rogue, rogue, q, lda )
185 IF( m.LE.n ) THEN
186 IF( m.GT.0 .AND. m.LT.n )
187 $ CALL dlacpy( 'Full', m, n-m, af, lda, q( n-m+1, 1 ), lda )
188 IF( m.GT.1 )
189 $ CALL dlacpy( '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 dlacpy( '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 = 'DORGRQ'
200 CALL dorgrq( n, n, minmn, q, lda, tau, work, lwork, info )
201*
202* Copy R
203*
204 CALL dlaset( 'Full', m, n, zero, zero, r, lda )
205 IF( m.LE.n ) THEN
206 IF( m.GT.0 )
207 $ CALL dlacpy( '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 dlacpy( 'Full', m-n, n, af, lda, r, lda )
212 IF( n.GT.0 )
213 $ CALL dlacpy( '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 dgemm( 'No transpose', 'Transpose', m, n, n, -one, a, lda, q,
220 $ lda, one, r, lda )
221*
222* Compute norm( R - Q'*A ) / ( N * norm(A) * EPS ) .
223*
224 anorm = dlange( '1', m, n, a, lda, rwork )
225 resid = dlange( '1', m, n, r, lda, rwork )
226 IF( anorm.GT.zero ) THEN
227 result( 1 ) = ( ( resid / dble( max( 1, n ) ) ) / anorm ) / eps
228 ELSE
229 result( 1 ) = zero
230 END IF
231*
232* Compute I - Q*Q'
233*
234 CALL dlaset( 'Full', n, n, zero, one, r, lda )
235 CALL dsyrk( 'Upper', 'No transpose', n, n, -one, q, lda, one, r,
236 $ lda )
237*
238* Compute norm( I - Q*Q' ) / ( N * EPS ) .
239*
240 resid = dlansy( '1', 'Upper', n, r, lda, rwork )
241*
242 result( 2 ) = ( resid / dble( max( 1, n ) ) ) / eps
243*
244 RETURN
245*
246* End of DRQT01
247*

◆ drqt02()

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

DRQT02

Purpose:
!>
!> DRQT02 tests DORGRQ, 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, DRQT02 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The m-by-n matrix A which was factorized by DRQT01.
!>
[in]AF
!>          AF is DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the RQ factorization of A, as returned by DGERQF.
!>          See DGERQF for further details.
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDA,N)
!>
[out]R
!>          R is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (M)
!>          The scalar factors of the elementary reflectors corresponding
!>          to the RQ factorization in AF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The dimension of the array WORK.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (2)
!>          The test ratios:
!>          RESULT(1) = norm( R - A*Q' ) / ( N * norm(A) * EPS )
!>          RESULT(2) = norm( I - Q*Q' ) / ( N * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 134 of file drqt02.f.

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

◆ drqt03()

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

DRQT03

Purpose:
!>
!> DRQT03 tests DORMRQ, which computes Q*C, Q'*C, C*Q or C*Q'.
!>
!> DRQT03 compares the results of a call to DORMRQ with the results of
!> forming Q explicitly by a call to DORGRQ and then performing matrix
!> multiplication by a call to DGEMM.
!>
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 DOUBLE PRECISION array, dimension (LDA,N)
!>          Details of the RQ factorization of an m-by-n matrix, as
!>          returned by DGERQF. See SGERQF for further details.
!>
[out]C
!>          C is DOUBLE PRECISION array, dimension (LDA,N)
!>
[out]CC
!>          CC is DOUBLE PRECISION array, dimension (LDA,N)
!>
[out]Q
!>          Q is DOUBLE PRECISION array, dimension (LDA,N)
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the arrays AF, C, CC, and Q.
!>
[in]TAU
!>          TAU is DOUBLE PRECISION array, dimension (min(M,N))
!>          The scalar factors of the elementary reflectors corresponding
!>          to the RQ factorization in AF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of WORK.  LWORK must be at least M, and should be
!>          M*NB, where NB is the blocksize for this environment.
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (M)
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (4)
!>          The test ratios compare two techniques for multiplying a
!>          random matrix C by an n-by-n orthogonal matrix Q.
!>          RESULT(1) = norm( Q*C - Q*C )  / ( N * norm(C) * EPS )
!>          RESULT(2) = norm( C*Q - C*Q )  / ( N * norm(C) * EPS )
!>          RESULT(3) = norm( Q'*C - Q'*C )/ ( N * norm(C) * EPS )
!>          RESULT(4) = norm( C*Q' - C*Q' )/ ( N * norm(C) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 134 of file drqt03.f.

136*
137* -- LAPACK test routine --
138* -- LAPACK is a software package provided by Univ. of Tennessee, --
139* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
140*
141* .. Scalar Arguments ..
142 INTEGER K, LDA, LWORK, M, N
143* ..
144* .. Array Arguments ..
145 DOUBLE PRECISION AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
146 $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
147 $ WORK( LWORK )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 DOUBLE PRECISION ZERO, ONE
154 parameter( zero = 0.0d0, one = 1.0d0 )
155 DOUBLE PRECISION ROGUE
156 parameter( rogue = -1.0d+10 )
157* ..
158* .. Local Scalars ..
159 CHARACTER SIDE, TRANS
160 INTEGER INFO, ISIDE, ITRANS, J, MC, MINMN, NC
161 DOUBLE PRECISION CNORM, EPS, RESID
162* ..
163* .. External Functions ..
164 LOGICAL LSAME
165 DOUBLE PRECISION DLAMCH, DLANGE
166 EXTERNAL lsame, dlamch, dlange
167* ..
168* .. External Subroutines ..
169 EXTERNAL dgemm, dlacpy, dlarnv, dlaset, dorgrq, dormrq
170* ..
171* .. Local Arrays ..
172 INTEGER ISEED( 4 )
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC dble, max, min
176* ..
177* .. Scalars in Common ..
178 CHARACTER*32 SRNAMT
179* ..
180* .. Common blocks ..
181 COMMON / srnamc / srnamt
182* ..
183* .. Data statements ..
184 DATA iseed / 1988, 1989, 1990, 1991 /
185* ..
186* .. Executable Statements ..
187*
188 eps = dlamch( 'Epsilon' )
189 minmn = min( m, n )
190*
191* Quick return if possible
192*
193 IF( minmn.EQ.0 ) THEN
194 result( 1 ) = zero
195 result( 2 ) = zero
196 result( 3 ) = zero
197 result( 4 ) = zero
198 RETURN
199 END IF
200*
201* Copy the last k rows of the factorization to the array Q
202*
203 CALL dlaset( 'Full', n, n, rogue, rogue, q, lda )
204 IF( k.GT.0 .AND. n.GT.k )
205 $ CALL dlacpy( 'Full', k, n-k, af( m-k+1, 1 ), lda,
206 $ q( n-k+1, 1 ), lda )
207 IF( k.GT.1 )
208 $ CALL dlacpy( '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 = 'DORGRQ'
214 CALL dorgrq( 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 dlarnv( 2, iseed, mc, c( 1, j ) )
232 10 CONTINUE
233 cnorm = dlange( '1', mc, nc, c, lda, rwork )
234 IF( cnorm.EQ.0.0d0 )
235 $ cnorm = one
236*
237 DO 20 itrans = 1, 2
238 IF( itrans.EQ.1 ) THEN
239 trans = 'N'
240 ELSE
241 trans = 'T'
242 END IF
243*
244* Copy C
245*
246 CALL dlacpy( 'Full', mc, nc, c, lda, cc, lda )
247*
248* Apply Q or Q' to C
249*
250 srnamt = 'DORMRQ'
251 IF( k.GT.0 )
252 $ CALL dormrq( 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 dgemm( trans, 'No transpose', mc, nc, mc, -one, q,
260 $ lda, c, lda, one, cc, lda )
261 ELSE
262 CALL dgemm( 'No transpose', trans, mc, nc, nc, -one, c,
263 $ lda, q, lda, one, cc, lda )
264 END IF
265*
266* Compute error in the difference
267*
268 resid = dlange( '1', mc, nc, cc, lda, rwork )
269 result( ( iside-1 )*2+itrans ) = resid /
270 $ ( dble( max( 1, n ) )*cnorm*eps )
271*
272 20 CONTINUE
273 30 CONTINUE
274*
275 RETURN
276*
277* End of DRQT03
278*

◆ drzt01()

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

DRZT01

Purpose:
!>
!> DRZT01 returns
!>      || A - R*Q || / ( M * eps * ||A|| )
!> for an upper trapezoidal A that was factored with DTZRZF.
!>
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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The original upper trapezoidal M by N matrix A.
!>
[in]AF
!>          AF is DOUBLE PRECISION array, dimension (LDA,N)
!>          The output of DTZRZF 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 DOUBLE PRECISION array, dimension (M)
!>          Details of the Householder transformations as returned by
!>          DTZRZF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          The length of the array WORK.  LWORK >= m*n + m*nb.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 96 of file drzt01.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 DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), TAU( * ),
108 $ WORK( LWORK )
109* ..
110*
111* =====================================================================
112*
113* .. Parameters ..
114 DOUBLE PRECISION ZERO, ONE
115 parameter( zero = 0.0d+0, one = 1.0d+0 )
116* ..
117* .. Local Scalars ..
118 INTEGER I, INFO, J
119 DOUBLE PRECISION NORMA
120* ..
121* .. Local Arrays ..
122 DOUBLE PRECISION RWORK( 1 )
123* ..
124* .. External Functions ..
125 DOUBLE PRECISION DLAMCH, DLANGE
126 EXTERNAL dlamch, dlange
127* ..
128* .. External Subroutines ..
129 EXTERNAL daxpy, dlaset, dormrz, xerbla
130* ..
131* .. Intrinsic Functions ..
132 INTRINSIC dble, max
133* ..
134* .. Executable Statements ..
135*
136 drzt01 = zero
137*
138 IF( lwork.LT.m*n+m ) THEN
139 CALL xerbla( 'DRZT01', 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 = dlange( 'One-norm', m, n, a, lda, rwork )
149*
150* Copy upper triangle R
151*
152 CALL dlaset( 'Full', m, n, zero, 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 dormrz( '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 daxpy( m, -one, a( 1, i ), 1, work( ( i-1 )*m+1 ), 1 )
168 30 CONTINUE
169*
170 drzt01 = dlange( 'One-norm', m, n, work, m, rwork )
171*
172 drzt01 = drzt01 / ( dlamch( 'Epsilon' )*dble( max( m, n ) ) )
173 IF( norma.NE.zero )
174 $ drzt01 = drzt01 / norma
175*
176 RETURN
177*
178* End of DRZT01
179*
dormrz
subroutine dormrz(side, trans, m, n, k, l, a, lda, tau, c, ldc, work, lwork, info)
DORMRZ
Definition dormrz.f:187

◆ drzt02()

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

DRZT02

Purpose:
!>
!> DRZT02 returns
!>      || I - Q'*Q || / ( M * eps)
!> where the matrix Q is defined by the Householder transformations
!> generated by DTZRZF.
!>
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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The output of DTZRZF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array AF.
!>
[in]TAU
!>          TAU is DOUBLE PRECISION array, dimension (M)
!>          Details of the Householder transformations as returned by
!>          DTZRZF.
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (LWORK)
!>
[in]LWORK
!>          LWORK is INTEGER
!>          length of WORK array. LWORK >= N*N+N*NB.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 89 of file drzt02.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 DOUBLE PRECISION AF( LDA, * ), TAU( * ), WORK( LWORK )
101* ..
102*
103* =====================================================================
104*
105* .. Parameters ..
106 DOUBLE PRECISION ZERO, ONE
107 parameter( zero = 0.0d+0, one = 1.0d+0 )
108* ..
109* .. Local Scalars ..
110 INTEGER I, INFO
111* ..
112* .. Local Arrays ..
113 DOUBLE PRECISION RWORK( 1 )
114* ..
115* .. External Functions ..
116 DOUBLE PRECISION DLAMCH, DLANGE
117 EXTERNAL dlamch, dlange
118* ..
119* .. External Subroutines ..
120 EXTERNAL dlaset, dormrz, xerbla
121* ..
122* .. Intrinsic Functions ..
123 INTRINSIC dble, max
124* ..
125* .. Executable Statements ..
126*
127 drzt02 = zero
128*
129 IF( lwork.LT.n*n+n ) THEN
130 CALL xerbla( 'DRZT02', 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 dlaset( 'Full', n, n, zero, one, work, n )
142*
143* Q := P(1) * ... * P(m) * Q
144*
145 CALL dormrz( '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 dormrz( 'Left', 'Transpose', n, n, m, n-m, af, lda, tau,
151 $ 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 drzt02 = dlange( 'One-norm', n, n, work, n, rwork ) /
160 $ ( dlamch( 'Epsilon' )*dble( max( m, n ) ) )
161 RETURN
162*
163* End of DRZT02
164*

◆ dspt01()

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

DSPT01

Purpose:
!>
!> DSPT01 reconstructs a symmetric 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 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 DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          The original symmetric matrix A, stored as a packed
!>          triangular matrix.
!>
[in]AFAC
!>          AFAC is DOUBLE PRECISION 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 DSPTRF.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from DSPTRF.
!>
[out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 109 of file dspt01.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 LDC, N
118 DOUBLE PRECISION RESID
119* ..
120* .. Array Arguments ..
121 INTEGER IPIV( * )
122 DOUBLE PRECISION A( * ), AFAC( * ), C( LDC, * ), RWORK( * )
123* ..
124*
125* =====================================================================
126*
127* .. Parameters ..
128 DOUBLE PRECISION ZERO, ONE
129 parameter( zero = 0.0d+0, one = 1.0d+0 )
130* ..
131* .. Local Scalars ..
132 INTEGER I, INFO, J, JC
133 DOUBLE PRECISION ANORM, EPS
134* ..
135* .. External Functions ..
136 LOGICAL LSAME
137 DOUBLE PRECISION DLAMCH, DLANSP, DLANSY
138 EXTERNAL lsame, dlamch, dlansp, dlansy
139* ..
140* .. External Subroutines ..
141 EXTERNAL dlaset, dlavsp
142* ..
143* .. Intrinsic Functions ..
144 INTRINSIC dble
145* ..
146* .. Executable Statements ..
147*
148* Quick exit if N = 0.
149*
150 IF( n.LE.0 ) THEN
151 resid = zero
152 RETURN
153 END IF
154*
155* Determine EPS and the norm of A.
156*
157 eps = dlamch( 'Epsilon' )
158 anorm = dlansp( '1', uplo, n, a, rwork )
159*
160* Initialize C to the identity matrix.
161*
162 CALL dlaset( 'Full', n, n, zero, one, c, ldc )
163*
164* Call DLAVSP to form the product D * U' (or D * L' ).
165*
166 CALL dlavsp( uplo, 'Transpose', 'Non-unit', n, n, afac, ipiv, c,
167 $ ldc, info )
168*
169* Call DLAVSP again to multiply by U ( or L ).
170*
171 CALL dlavsp( uplo, 'No transpose', 'Unit', n, n, afac, ipiv, c,
172 $ ldc, info )
173*
174* Compute the difference C - A .
175*
176 IF( lsame( uplo, 'U' ) ) THEN
177 jc = 0
178 DO 20 j = 1, n
179 DO 10 i = 1, j
180 c( i, j ) = c( i, j ) - a( jc+i )
181 10 CONTINUE
182 jc = jc + j
183 20 CONTINUE
184 ELSE
185 jc = 1
186 DO 40 j = 1, n
187 DO 30 i = j, n
188 c( i, j ) = c( i, j ) - a( jc+i-j )
189 30 CONTINUE
190 jc = jc + n - j + 1
191 40 CONTINUE
192 END IF
193*
194* Compute norm( C - A ) / ( N * norm(A) * EPS )
195*
196 resid = dlansy( '1', uplo, n, c, ldc, rwork )
197*
198 IF( anorm.LE.zero ) THEN
199 IF( resid.NE.zero )
200 $ resid = one / eps
201 ELSE
202 resid = ( ( resid / dble( n ) ) / anorm ) / eps
203 END IF
204*
205 RETURN
206*
207* End of DSPT01
208*
dlavsp
subroutine dlavsp(uplo, trans, diag, n, nrhs, a, ipiv, b, ldb, info)
DLAVSP
Definition dlavsp.f:130

◆ dsyt01()

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

DSYT01

Purpose:
!>
!> DSYT01 reconstructs a 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 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DSYTRF.
!>
[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 DSYTRF.
!>
[out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 122 of file dsyt01.f.

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

◆ dsyt01_3()

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

DSYT01_3

Purpose:
!>
!> DSYT01_3 reconstructs a symmetric indefinite matrix A from its
!> block L*D*L' or U*D*U' factorization computed by DSYTRF_RK
!> (or DSYTRF_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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDAFAC,N)
!>          Diagonal of the block diagonal matrix D and factors U or L
!>          as computed by DSYTRF_RK and DSYTRF_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 DOUBLE PRECISION 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 DSYTRF_RK (or DSYTRF_BK).
!>
[out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 138 of file dsyt01_3.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 CHARACTER UPLO
147 INTEGER LDA, LDAFAC, LDC, N
148 DOUBLE PRECISION RESID
149* ..
150* .. Array Arguments ..
151 INTEGER IPIV( * )
152 DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
153 $ E( * ), RWORK( * )
154* ..
155*
156* =====================================================================
157*
158* .. Parameters ..
159 DOUBLE PRECISION ZERO, ONE
160 parameter( zero = 0.0d+0, one = 1.0d+0 )
161* ..
162* .. Local Scalars ..
163 INTEGER I, INFO, J
164 DOUBLE PRECISION ANORM, EPS
165* ..
166* .. External Functions ..
167 LOGICAL LSAME
168 DOUBLE PRECISION DLAMCH, DLANSY
169 EXTERNAL lsame, dlamch, dlansy
170* ..
171* .. External Subroutines ..
172 EXTERNAL dlaset, dlavsy_rook, dsyconvf_rook
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC dble
176* ..
177* .. Executable Statements ..
178*
179* Quick exit if N = 0.
180*
181 IF( n.LE.0 ) THEN
182 resid = zero
183 RETURN
184 END IF
185*
186* a) Revert to multiplyers of L
187*
188 CALL dsyconvf_rook( uplo, 'R', n, afac, ldafac, e, ipiv, info )
189*
190* 1) Determine EPS and the norm of A.
191*
192 eps = dlamch( 'Epsilon' )
193 anorm = dlansy( '1', uplo, n, a, lda, rwork )
194*
195* 2) Initialize C to the identity matrix.
196*
197 CALL dlaset( 'Full', n, n, zero, one, c, ldc )
198*
199* 3) Call DLAVSY_ROOK to form the product D * U' (or D * L' ).
200*
201 CALL dlavsy_rook( uplo, 'Transpose', 'Non-unit', n, n, afac,
202 $ ldafac, ipiv, c, ldc, info )
203*
204* 4) Call DLAVSY_ROOK again to multiply by U (or L ).
205*
206 CALL dlavsy_rook( uplo, 'No transpose', 'Unit', n, n, afac,
207 $ ldafac, ipiv, c, ldc, info )
208*
209* 5) Compute the difference C - A.
210*
211 IF( lsame( uplo, 'U' ) ) THEN
212 DO j = 1, n
213 DO i = 1, j
214 c( i, j ) = c( i, j ) - a( i, j )
215 END DO
216 END DO
217 ELSE
218 DO j = 1, n
219 DO i = j, n
220 c( i, j ) = c( i, j ) - a( i, j )
221 END DO
222 END DO
223 END IF
224*
225* 6) Compute norm( C - A ) / ( N * norm(A) * EPS )
226*
227 resid = dlansy( '1', uplo, n, c, ldc, rwork )
228*
229 IF( anorm.LE.zero ) THEN
230 IF( resid.NE.zero )
231 $ resid = one / eps
232 ELSE
233 resid = ( ( resid / dble( n ) ) / anorm ) / eps
234 END IF
235
236*
237* b) Convert to factor of L (or U)
238*
239 CALL dsyconvf_rook( uplo, 'C', n, afac, ldafac, e, ipiv, info )
240*
241 RETURN
242*
243* End of DSYT01_3
244*
dsyconvf_rook
subroutine dsyconvf_rook(uplo, way, n, a, lda, e, ipiv, info)
DSYCONVF_ROOK
Definition dsyconvf_rook.f:197
dlavsy_rook
subroutine dlavsy_rook(uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
DLAVSY_ROOK
Definition dlavsy_rook.f:157

◆ dsyt01_aa()

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

DSYT01

Purpose:
!>
!> DSYT01 reconstructs a 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 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DSYTRF.
!>
[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 DSYTRF.
!>
[out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 122 of file dsyt01_aa.f.

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

◆ dsyt01_rook()

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

DSYT01_ROOK

Purpose:
!>
!> DSYT01_ROOK reconstructs a 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 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DSYTRF_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 DSYTRF_ROOK.
!>
[out]C
!>          C is DOUBLE PRECISION array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 122 of file dsyt01_rook.f.

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

◆ dtbt02()

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

DTBT02

Purpose:
!>
!> DTBT02 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 or A**T, b is the column of B, x is the solution
!> vector, and EPS is the machine epsilon.
!> The norm used is the 1-norm.
!>
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 = 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 DOUBLE PRECISION 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]X
!>          X is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 152 of file dtbt02.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 CHARACTER DIAG, TRANS, UPLO
161 INTEGER KD, LDAB, LDB, LDX, N, NRHS
162 DOUBLE PRECISION RESID
163* ..
164* .. Array Arguments ..
165 DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), WORK( * ),
166 $ X( LDX, * )
167* ..
168*
169* =====================================================================
170*
171* .. Parameters ..
172 DOUBLE PRECISION ZERO, ONE
173 parameter( zero = 0.0d+0, one = 1.0d+0 )
174* ..
175* .. Local Scalars ..
176 INTEGER J
177 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
178* ..
179* .. External Functions ..
180 LOGICAL LSAME
181 DOUBLE PRECISION DASUM, DLAMCH, DLANTB
182 EXTERNAL lsame, dasum, dlamch, dlantb
183* ..
184* .. External Subroutines ..
185 EXTERNAL daxpy, dcopy, dtbmv
186* ..
187* .. Intrinsic Functions ..
188 INTRINSIC max
189* ..
190* .. Executable Statements ..
191*
192* Quick exit if N = 0 or NRHS = 0
193*
194 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
195 resid = zero
196 RETURN
197 END IF
198*
199* Compute the 1-norm of op(A).
200*
201 IF( lsame( trans, 'N' ) ) THEN
202 anorm = dlantb( '1', uplo, diag, n, kd, ab, ldab, work )
203 ELSE
204 anorm = dlantb( 'I', uplo, diag, n, kd, ab, ldab, work )
205 END IF
206*
207* Exit with RESID = 1/EPS if ANORM = 0.
208*
209 eps = dlamch( 'Epsilon' )
210 IF( anorm.LE.zero ) THEN
211 resid = one / eps
212 RETURN
213 END IF
214*
215* Compute the maximum over the number of right hand sides of
216* norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
217*
218 resid = zero
219 DO 10 j = 1, nrhs
220 CALL dcopy( n, x( 1, j ), 1, work, 1 )
221 CALL dtbmv( uplo, trans, diag, n, kd, ab, ldab, work, 1 )
222 CALL daxpy( n, -one, b( 1, j ), 1, work, 1 )
223 bnorm = dasum( n, work, 1 )
224 xnorm = dasum( n, x( 1, j ), 1 )
225 IF( xnorm.LE.zero ) THEN
226 resid = one / eps
227 ELSE
228 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
229 END IF
230 10 CONTINUE
231*
232 RETURN
233*
234* End of DTBT02
235*

◆ dtbt03()

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

DTBT03

Purpose:
!>
!> DTBT03 computes the residual for the solution to a scaled triangular
!> system of equations  A*x = s*b  or  A'*x = s*b  when A is a
!> triangular band matrix. Here A' is the 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 or A' 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'*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 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 DOUBLE PRECISION array, dimension (LDAB,N)
!>          The upper or lower triangular band matrix A, stored in the
!>          first kd+1 rows of the array. The j-th column of A is stored
!>          in the j-th column of the array AB as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[in]SCALE
!>          SCALE is DOUBLE PRECISION
!>          The scaling factor s used in solving the triangular system.
!>
[in]CNORM
!>          CNORM is DOUBLE PRECISION array, dimension (N)
!>          The 1-norms of the columns of A, not counting the diagonal.
!>
[in]TSCAL
!>          TSCAL is DOUBLE PRECISION
!>          The scaling factor used in computing the 1-norms in CNORM.
!>          CNORM actually contains the column norms of TSCAL*A.
!>
[in]X
!>          X is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*x - 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 172 of file dtbt03.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 KD, LDAB, LDB, LDX, N, NRHS
183 DOUBLE PRECISION RESID, SCALE, TSCAL
184* ..
185* .. Array Arguments ..
186 DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), CNORM( * ),
187 $ WORK( * ), X( LDX, * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 DOUBLE PRECISION ONE, ZERO
194 parameter( one = 1.0d+0, zero = 0.0d+0 )
195* ..
196* .. Local Scalars ..
197 INTEGER IX, J
198 DOUBLE PRECISION BIGNUM, EPS, ERR, SMLNUM, TNORM, XNORM, XSCAL
199* ..
200* .. External Functions ..
201 LOGICAL LSAME
202 INTEGER IDAMAX
203 DOUBLE PRECISION DLAMCH
204 EXTERNAL lsame, idamax, dlamch
205* ..
206* .. External Subroutines ..
207 EXTERNAL daxpy, dcopy, dlabad, dscal, dtbmv
208* ..
209* .. Intrinsic Functions ..
210 INTRINSIC abs, dble, max
211* ..
212* .. Executable Statements ..
213*
214* Quick exit if N = 0
215*
216 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
217 resid = zero
218 RETURN
219 END IF
220 eps = dlamch( 'Epsilon' )
221 smlnum = dlamch( 'Safe minimum' )
222 bignum = one / smlnum
223 CALL dlabad( smlnum, bignum )
224*
225* Compute the norm of the triangular matrix A using the column
226* norms already computed by DLATBS.
227*
228 tnorm = zero
229 IF( lsame( diag, 'N' ) ) THEN
230 IF( lsame( uplo, 'U' ) ) THEN
231 DO 10 j = 1, n
232 tnorm = max( tnorm, tscal*abs( ab( kd+1, j ) )+
233 $ cnorm( j ) )
234 10 CONTINUE
235 ELSE
236 DO 20 j = 1, n
237 tnorm = max( tnorm, tscal*abs( ab( 1, j ) )+cnorm( j ) )
238 20 CONTINUE
239 END IF
240 ELSE
241 DO 30 j = 1, n
242 tnorm = max( tnorm, tscal+cnorm( j ) )
243 30 CONTINUE
244 END IF
245*
246* Compute the maximum over the number of right hand sides of
247* norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
248*
249 resid = zero
250 DO 40 j = 1, nrhs
251 CALL dcopy( n, x( 1, j ), 1, work, 1 )
252 ix = idamax( n, work, 1 )
253 xnorm = max( one, abs( x( ix, j ) ) )
254 xscal = ( one / xnorm ) / dble( kd+1 )
255 CALL dscal( n, xscal, work, 1 )
256 CALL dtbmv( uplo, trans, diag, n, kd, ab, ldab, work, 1 )
257 CALL daxpy( n, -scale*xscal, b( 1, j ), 1, work, 1 )
258 ix = idamax( n, work, 1 )
259 err = tscal*abs( work( ix ) )
260 ix = idamax( n, x( 1, j ), 1 )
261 xnorm = abs( x( ix, j ) )
262 IF( err*smlnum.LE.xnorm ) THEN
263 IF( xnorm.GT.zero )
264 $ err = err / xnorm
265 ELSE
266 IF( err.GT.zero )
267 $ err = one / eps
268 END IF
269 IF( err*smlnum.LE.tnorm ) THEN
270 IF( tnorm.GT.zero )
271 $ err = err / tnorm
272 ELSE
273 IF( err.GT.zero )
274 $ err = one / eps
275 END IF
276 resid = max( resid, err )
277 40 CONTINUE
278*
279 RETURN
280*
281* End of DTBT03
282*

◆ dtbt05()

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

DTBT05

Purpose:
!>
!> DTBT05 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( NZ*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 187 of file dtbt05.f.

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

◆ dtbt06()

subroutine dtbt06 ( double precision rcond,
double precision rcondc,
character uplo,
character diag,
integer n,
integer kd,
double precision, dimension( ldab, * ) ab,
integer ldab,
double precision, dimension( * ) work,
double precision rat )

DTBT06

Purpose:
!>
!> DTBT06 computes a test ratio comparing RCOND (the reciprocal
!> condition number of a triangular matrix A) and RCONDC, the estimate
!> computed by DTBCON.  Information about the triangular matrix A is
!> used if one estimate is zero and the other is non-zero to decide if
!> underflow in the estimate is justified.
!>
Parameters
[in]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The estimate of the reciprocal condition number obtained by
!>          forming the explicit inverse of the matrix A and computing
!>          RCOND = 1/( norm(A) * norm(inv(A)) ).
!>
[in]RCONDC
!>          RCONDC is DOUBLE PRECISION
!>          The estimate of the reciprocal condition number computed by
!>          DTBCON.
!>
[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 DOUBLE PRECISION 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]WORK
!>          WORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RAT
!>          RAT is DOUBLE PRECISION
!>          The test ratio.  If both RCOND and RCONDC are nonzero,
!>             RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1.
!>          If RAT = 0, the two estimates are exactly the same.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 123 of file dtbt06.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 KD, LDAB, N
133 DOUBLE PRECISION RAT, RCOND, RCONDC
134* ..
135* .. Array Arguments ..
136 DOUBLE PRECISION AB( LDAB, * ), WORK( * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 DOUBLE PRECISION ZERO, ONE
143 parameter( zero = 0.0d+0, one = 1.0d+0 )
144* ..
145* .. Local Scalars ..
146 DOUBLE PRECISION ANORM, BIGNUM, EPS, RMAX, RMIN, SMLNUM
147* ..
148* .. External Functions ..
149 DOUBLE PRECISION DLAMCH, DLANTB
150 EXTERNAL dlamch, dlantb
151* ..
152* .. Intrinsic Functions ..
153 INTRINSIC max, min
154* ..
155* .. External Subroutines ..
156 EXTERNAL dlabad
157* ..
158* .. Executable Statements ..
159*
160 eps = dlamch( 'Epsilon' )
161 rmax = max( rcond, rcondc )
162 rmin = min( rcond, rcondc )
163*
164* Do the easy cases first.
165*
166 IF( rmin.LT.zero ) THEN
167*
168* Invalid value for RCOND or RCONDC, return 1/EPS.
169*
170 rat = one / eps
171*
172 ELSE IF( rmin.GT.zero ) THEN
173*
174* Both estimates are positive, return RMAX/RMIN - 1.
175*
176 rat = rmax / rmin - one
177*
178 ELSE IF( rmax.EQ.zero ) THEN
179*
180* Both estimates zero.
181*
182 rat = zero
183*
184 ELSE
185*
186* One estimate is zero, the other is non-zero. If the matrix is
187* ill-conditioned, return the nonzero estimate multiplied by
188* 1/EPS; if the matrix is badly scaled, return the nonzero
189* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum
190* element in absolute value in A.
191*
192 smlnum = dlamch( 'Safe minimum' )
193 bignum = one / smlnum
194 CALL dlabad( smlnum, bignum )
195 anorm = dlantb( 'M', uplo, diag, n, kd, ab, ldab, work )
196*
197 rat = rmax*( min( bignum / max( one, anorm ), one / eps ) )
198 END IF
199*
200 RETURN
201*
202* End of DTBT06
203*

◆ dtpt01()

subroutine dtpt01 ( character uplo,
character diag,
integer n,
double precision, dimension( * ) ap,
double precision, dimension( * ) ainvp,
double precision rcond,
double precision, dimension( * ) work,
double precision resid )

DTPT01

Purpose:
!>
!> DTPT01 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 DOUBLE PRECISION 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,out]AINVP
!>          AINVP is DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          On entry, the (triangular) inverse of the matrix A, packed
!>          columnwise in a linear array as in AP.
!>          On exit, the contents of AINVP are destroyed.
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal condition number of A, computed as
!>          1/(norm(A) * norm(AINV)).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 107 of file dtpt01.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 CHARACTER DIAG, UPLO
115 INTEGER N
116 DOUBLE PRECISION RCOND, RESID
117* ..
118* .. Array Arguments ..
119 DOUBLE PRECISION AINVP( * ), AP( * ), WORK( * )
120* ..
121*
122* =====================================================================
123*
124* .. Parameters ..
125 DOUBLE PRECISION ZERO, ONE
126 parameter( zero = 0.0d+0, one = 1.0d+0 )
127* ..
128* .. Local Scalars ..
129 LOGICAL UNITD
130 INTEGER J, JC
131 DOUBLE PRECISION AINVNM, ANORM, EPS
132* ..
133* .. External Functions ..
134 LOGICAL LSAME
135 DOUBLE PRECISION DLAMCH, DLANTP
136 EXTERNAL lsame, dlamch, dlantp
137* ..
138* .. External Subroutines ..
139 EXTERNAL dtpmv
140* ..
141* .. Intrinsic Functions ..
142 INTRINSIC dble
143* ..
144* .. Executable Statements ..
145*
146* Quick exit if N = 0.
147*
148 IF( n.LE.0 ) THEN
149 rcond = one
150 resid = zero
151 RETURN
152 END IF
153*
154* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
155*
156 eps = dlamch( 'Epsilon' )
157 anorm = dlantp( '1', uplo, diag, n, ap, work )
158 ainvnm = dlantp( '1', uplo, diag, n, ainvp, work )
159 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
160 rcond = zero
161 resid = one / eps
162 RETURN
163 END IF
164 rcond = ( one / anorm ) / ainvnm
165*
166* Compute A * AINV, overwriting AINV.
167*
168 unitd = lsame( diag, 'U' )
169 IF( lsame( uplo, 'U' ) ) THEN
170 jc = 1
171 DO 10 j = 1, n
172 IF( unitd )
173 $ ainvp( jc+j-1 ) = one
174*
175* Form the j-th column of A*AINV
176*
177 CALL dtpmv( 'Upper', 'No transpose', diag, j, ap,
178 $ ainvp( jc ), 1 )
179*
180* Subtract 1 from the diagonal
181*
182 ainvp( jc+j-1 ) = ainvp( jc+j-1 ) - one
183 jc = jc + j
184 10 CONTINUE
185 ELSE
186 jc = 1
187 DO 20 j = 1, n
188 IF( unitd )
189 $ ainvp( jc ) = one
190*
191* Form the j-th column of A*AINV
192*
193 CALL dtpmv( 'Lower', 'No transpose', diag, n-j+1, ap( jc ),
194 $ ainvp( jc ), 1 )
195*
196* Subtract 1 from the diagonal
197*
198 ainvp( jc ) = ainvp( jc ) - one
199 jc = jc + n - j + 1
200 20 CONTINUE
201 END IF
202*
203* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS)
204*
205 resid = dlantp( '1', uplo, 'Non-unit', n, ainvp, work )
206*
207 resid = ( ( resid*rcond ) / dble( n ) ) / eps
208*
209 RETURN
210*
211* End of DTPT01
212*

◆ dtpt02()

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

DTPT02

Purpose:
!>
!> DTPT02 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 or A**T, b is the column of B, x is the solution
!> vector, and EPS is the machine epsilon.
!> The norm used is the 1-norm.
!>
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 = 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*X - B) / ( norm(op(A)) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 140 of file dtpt02.f.

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

◆ dtpt03()

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

DTPT03

Purpose:
!>
!> DTPT03 computes the residual for the solution to a scaled triangular
!> system of equations A*x = s*b  or  A'*x = s*b  when the triangular
!> matrix A is stored in packed format.  Here A' is the 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 or A' 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'*x = s*b  (Transpose)
!>          = 'C':  A'*x = s*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 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 DOUBLE PRECISION array, dimension (N*(N+1)/2)
!>          The upper or lower triangular matrix A, packed columnwise in
!>          a linear array.  The j-th column of A is stored in the array
!>          AP as follows:
!>          if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L',
!>             AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
!>
[in]SCALE
!>          SCALE is DOUBLE PRECISION
!>          The scaling factor s used in solving the triangular system.
!>
[in]CNORM
!>          CNORM is DOUBLE PRECISION array, dimension (N)
!>          The 1-norms of the columns of A, not counting the diagonal.
!>
[in]TSCAL
!>          TSCAL is DOUBLE PRECISION
!>          The scaling factor used in computing the 1-norms in CNORM.
!>          CNORM actually contains the column norms of TSCAL*A.
!>
[in]X
!>          X is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*x - 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 159 of file dtpt03.f.

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

◆ dtpt05()

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

DTPT05

Purpose:
!>
!> DTPT05 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 172 of file dtpt05.f.

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

◆ dtpt06()

subroutine dtpt06 ( double precision rcond,
double precision rcondc,
character uplo,
character diag,
integer n,
double precision, dimension( * ) ap,
double precision, dimension( * ) work,
double precision rat )

DTPT06

Purpose:
!>
!> DTPT06 computes a test ratio comparing RCOND (the reciprocal
!> condition number of a triangular matrix A) and RCONDC, the estimate
!> computed by DTPCON.  Information about the triangular matrix A is
!> used if one estimate is zero and the other is non-zero to decide if
!> underflow in the estimate is justified.
!>
Parameters
[in]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The estimate of the reciprocal condition number obtained by
!>          forming the explicit inverse of the matrix A and computing
!>          RCOND = 1/( norm(A) * norm(inv(A)) ).
!>
[in]RCONDC
!>          RCONDC is DOUBLE PRECISION
!>          The estimate of the reciprocal condition number computed by
!>          DTPCON.
!>
[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 DOUBLE PRECISION 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]WORK
!>          WORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RAT
!>          RAT is DOUBLE PRECISION
!>          The test ratio.  If both RCOND and RCONDC are nonzero,
!>             RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1.
!>          If RAT = 0, the two estimates are exactly the same.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 110 of file dtpt06.f.

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

◆ dtrt01()

subroutine dtrt01 ( character uplo,
character diag,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( ldainv, * ) ainv,
integer ldainv,
double precision rcond,
double precision, dimension( * ) work,
double precision resid )

DTRT01

Purpose:
!>
!> DTRT01 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 DOUBLE PRECISION 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,out]AINV
!>          AINV is DOUBLE PRECISION array, dimension (LDAINV,N)
!>          On entry, the (triangular) inverse of the matrix A, in the
!>          same storage format as A.
!>          On exit, the contents of AINV are destroyed.
!>
[in]LDAINV
!>          LDAINV is INTEGER
!>          The leading dimension of the array AINV.  LDAINV >= max(1,N).
!>
[out]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The reciprocal condition number of A, computed as
!>          1/(norm(A) * norm(AINV)).
!>
[out]WORK
!>          WORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          norm(A*AINV - I) / ( N * norm(A) * norm(AINV) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 122 of file dtrt01.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 DIAG, UPLO
131 INTEGER LDA, LDAINV, N
132 DOUBLE PRECISION RCOND, RESID
133* ..
134* .. Array Arguments ..
135 DOUBLE PRECISION A( LDA, * ), AINV( LDAINV, * ), WORK( * )
136* ..
137*
138* =====================================================================
139*
140* .. Parameters ..
141 DOUBLE PRECISION ZERO, ONE
142 parameter( zero = 0.0d+0, one = 1.0d+0 )
143* ..
144* .. Local Scalars ..
145 INTEGER J
146 DOUBLE PRECISION AINVNM, ANORM, EPS
147* ..
148* .. External Functions ..
149 LOGICAL LSAME
150 DOUBLE PRECISION DLAMCH, DLANTR
151 EXTERNAL lsame, dlamch, dlantr
152* ..
153* .. External Subroutines ..
154 EXTERNAL dtrmv
155* ..
156* .. Intrinsic Functions ..
157 INTRINSIC dble
158* ..
159* .. Executable Statements ..
160*
161* Quick exit if N = 0
162*
163 IF( n.LE.0 ) THEN
164 rcond = one
165 resid = zero
166 RETURN
167 END IF
168*
169* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
170*
171 eps = dlamch( 'Epsilon' )
172 anorm = dlantr( '1', uplo, diag, n, n, a, lda, work )
173 ainvnm = dlantr( '1', uplo, diag, n, n, ainv, ldainv, work )
174 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
175 rcond = zero
176 resid = one / eps
177 RETURN
178 END IF
179 rcond = ( one / anorm ) / ainvnm
180*
181* Set the diagonal of AINV to 1 if AINV has unit diagonal.
182*
183 IF( lsame( diag, 'U' ) ) THEN
184 DO 10 j = 1, n
185 ainv( j, j ) = one
186 10 CONTINUE
187 END IF
188*
189* Compute A * AINV, overwriting AINV.
190*
191 IF( lsame( uplo, 'U' ) ) THEN
192 DO 20 j = 1, n
193 CALL dtrmv( 'Upper', 'No transpose', diag, j, a, lda,
194 $ ainv( 1, j ), 1 )
195 20 CONTINUE
196 ELSE
197 DO 30 j = 1, n
198 CALL dtrmv( 'Lower', 'No transpose', diag, n-j+1, a( j, j ),
199 $ lda, ainv( j, j ), 1 )
200 30 CONTINUE
201 END IF
202*
203* Subtract 1 from each diagonal element to form A*AINV - I.
204*
205 DO 40 j = 1, n
206 ainv( j, j ) = ainv( j, j ) - one
207 40 CONTINUE
208*
209* Compute norm(A*AINV - I) / (N * norm(A) * norm(AINV) * EPS)
210*
211 resid = dlantr( '1', uplo, 'Non-unit', n, n, ainv, ldainv, work )
212*
213 resid = ( ( resid*rcond ) / dble( n ) ) / eps
214*
215 RETURN
216*
217* End of DTRT01
218*

◆ dtrt02()

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

DTRT02

Purpose:
!>
!> DTRT02 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 or A**T, b is the column of B, x is the solution
!> vector, and EPS is the machine epsilon.
!> The norm used is the 1-norm.
!>
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 = 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*X - B) / ( norm(op(A)) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 148 of file dtrt02.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 CHARACTER DIAG, TRANS, UPLO
157 INTEGER LDA, LDB, LDX, N, NRHS
158 DOUBLE PRECISION RESID
159* ..
160* .. Array Arguments ..
161 DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ),
162 $ X( LDX, * )
163* ..
164*
165* =====================================================================
166*
167* .. Parameters ..
168 DOUBLE PRECISION ZERO, ONE
169 parameter( zero = 0.0d+0, one = 1.0d+0 )
170* ..
171* .. Local Scalars ..
172 INTEGER J
173 DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
174* ..
175* .. External Functions ..
176 LOGICAL LSAME
177 DOUBLE PRECISION DASUM, DLAMCH, DLANTR
178 EXTERNAL lsame, dasum, dlamch, dlantr
179* ..
180* .. External Subroutines ..
181 EXTERNAL daxpy, dcopy, dtrmv
182* ..
183* .. Intrinsic Functions ..
184 INTRINSIC max
185* ..
186* .. Executable Statements ..
187*
188* Quick exit if N = 0 or NRHS = 0
189*
190 IF( n.LE.0 .OR. nrhs.LE.0 ) THEN
191 resid = zero
192 RETURN
193 END IF
194*
195* Compute the 1-norm of op(A).
196*
197 IF( lsame( trans, 'N' ) ) THEN
198 anorm = dlantr( '1', uplo, diag, n, n, a, lda, work )
199 ELSE
200 anorm = dlantr( 'I', uplo, diag, n, n, a, lda, work )
201 END IF
202*
203* Exit with RESID = 1/EPS if ANORM = 0.
204*
205 eps = dlamch( 'Epsilon' )
206 IF( anorm.LE.zero ) THEN
207 resid = one / eps
208 RETURN
209 END IF
210*
211* Compute the maximum over the number of right hand sides of
212* norm(op(A)*X - B) / ( norm(op(A)) * norm(X) * EPS )
213*
214 resid = zero
215 DO 10 j = 1, nrhs
216 CALL dcopy( n, x( 1, j ), 1, work, 1 )
217 CALL dtrmv( uplo, trans, diag, n, a, lda, work, 1 )
218 CALL daxpy( n, -one, b( 1, j ), 1, work, 1 )
219 bnorm = dasum( n, work, 1 )
220 xnorm = dasum( n, x( 1, j ), 1 )
221 IF( xnorm.LE.zero ) THEN
222 resid = one / eps
223 ELSE
224 resid = max( resid, ( ( bnorm / anorm ) / xnorm ) / eps )
225 END IF
226 10 CONTINUE
227*
228 RETURN
229*
230* End of DTRT02
231*

◆ dtrt03()

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

DTRT03

Purpose:
!>
!> DTRT03 computes the residual for the solution to a scaled triangular
!> system of equations A*x = s*b  or  A'*x = s*b.
!> Here A is a triangular matrix, A' is the 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 or A' 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'*x = s*b  (Transpose)
!>          = 'C':  A'*x = s*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 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 DOUBLE PRECISION array, dimension (LDA,N)
!>          The triangular matrix A.  If UPLO = 'U', the leading n by n
!>          upper triangular part of the array A contains the upper
!>          triangular matrix, and the strictly lower triangular part of
!>          A is not referenced.  If UPLO = 'L', the leading n by n lower
!>          triangular part of the array A contains the lower triangular
!>          matrix, and the strictly upper triangular part of A is not
!>          referenced.  If DIAG = 'U', the diagonal elements of A are
!>          also not referenced and are assumed to be 1.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]SCALE
!>          SCALE is DOUBLE PRECISION
!>          The scaling factor s used in solving the triangular system.
!>
[in]CNORM
!>          CNORM is DOUBLE PRECISION array, dimension (N)
!>          The 1-norms of the columns of A, not counting the diagonal.
!>
[in]TSCAL
!>          TSCAL is DOUBLE PRECISION
!>          The scaling factor used in computing the 1-norms in CNORM.
!>          CNORM actually contains the column norms of TSCAL*A.
!>
[in]X
!>          X is DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N)
!>
[out]RESID
!>          RESID is DOUBLE PRECISION
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*x - 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 167 of file dtrt03.f.

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

◆ dtrt05()

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

DTRT05

Purpose:
!>
!> DTRT05 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (LDX,NRHS)
!>          The exact solution vectors.  Each vector is stored as a
!>          column of the matrix XACT.
!>
[in]LDXACT
!>          LDXACT is INTEGER
!>          The leading dimension of the array XACT.  LDXACT >= max(1,N).
!>
[in]FERR
!>          FERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The estimated forward error bounds for each solution vector
!>          X.  If XTRUE is the true solution, FERR bounds the magnitude
!>          of the largest entry in (X - XTRUE) divided by the magnitude
!>          of the largest entry in X.
!>
[in]BERR
!>          BERR is DOUBLE PRECISION array, dimension (NRHS)
!>          The componentwise relative backward error of each solution
!>          vector (i.e., the smallest relative change in any entry of A
!>          or B that makes X an exact solution).
!>
[out]RESLTS
!>          RESLTS is DOUBLE PRECISION array, dimension (2)
!>          The maximum over the NRHS solution vectors of the ratios:
!>          RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
!>          RESLTS(2) = BERR / ( (n+1)*EPS + (*) )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 179 of file dtrt05.f.

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

◆ dtrt06()

subroutine dtrt06 ( double precision rcond,
double precision rcondc,
character uplo,
character diag,
integer n,
double precision, dimension( lda, * ) a,
integer lda,
double precision, dimension( * ) work,
double precision rat )

DTRT06

Purpose:
!>
!> DTRT06 computes a test ratio comparing RCOND (the reciprocal
!> condition number of a triangular matrix A) and RCONDC, the estimate
!> computed by DTRCON.  Information about the triangular matrix A is
!> used if one estimate is zero and the other is non-zero to decide if
!> underflow in the estimate is justified.
!>
Parameters
[in]RCOND
!>          RCOND is DOUBLE PRECISION
!>          The estimate of the reciprocal condition number obtained by
!>          forming the explicit inverse of the matrix A and computing
!>          RCOND = 1/( norm(A) * norm(inv(A)) ).
!>
[in]RCONDC
!>          RCONDC is DOUBLE PRECISION
!>          The estimate of the reciprocal condition number computed by
!>          DTRCON.
!>
[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 DOUBLE PRECISION 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]WORK
!>          WORK is DOUBLE PRECISION array, dimension (N)
!>
[out]RAT
!>          RAT is DOUBLE PRECISION
!>          The test ratio.  If both RCOND and RCONDC are nonzero,
!>             RAT = MAX( RCOND, RCONDC )/MIN( RCOND, RCONDC ) - 1.
!>          If RAT = 0, the two estimates are exactly the same.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 119 of file dtrt06.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 DIAG, UPLO
128 INTEGER LDA, N
129 DOUBLE PRECISION RAT, RCOND, RCONDC
130* ..
131* .. Array Arguments ..
132 DOUBLE PRECISION A( LDA, * ), WORK( * )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 DOUBLE PRECISION ZERO, ONE
139 parameter( zero = 0.0d+0, one = 1.0d+0 )
140* ..
141* .. Local Scalars ..
142 DOUBLE PRECISION ANORM, BIGNUM, EPS, RMAX, RMIN, SMLNUM
143* ..
144* .. External Functions ..
145 DOUBLE PRECISION DLAMCH, DLANTR
146 EXTERNAL dlamch, dlantr
147* ..
148* .. Intrinsic Functions ..
149 INTRINSIC max, min
150* ..
151* .. External Subroutines ..
152 EXTERNAL dlabad
153* ..
154* .. Executable Statements ..
155*
156 eps = dlamch( 'Epsilon' )
157 rmax = max( rcond, rcondc )
158 rmin = min( rcond, rcondc )
159*
160* Do the easy cases first.
161*
162 IF( rmin.LT.zero ) THEN
163*
164* Invalid value for RCOND or RCONDC, return 1/EPS.
165*
166 rat = one / eps
167*
168 ELSE IF( rmin.GT.zero ) THEN
169*
170* Both estimates are positive, return RMAX/RMIN - 1.
171*
172 rat = rmax / rmin - one
173*
174 ELSE IF( rmax.EQ.zero ) THEN
175*
176* Both estimates zero.
177*
178 rat = zero
179*
180 ELSE
181*
182* One estimate is zero, the other is non-zero. If the matrix is
183* ill-conditioned, return the nonzero estimate multiplied by
184* 1/EPS; if the matrix is badly scaled, return the nonzero
185* estimate multiplied by BIGNUM/TMAX, where TMAX is the maximum
186* element in absolute value in A.
187*
188 smlnum = dlamch( 'Safe minimum' )
189 bignum = one / smlnum
190 CALL dlabad( smlnum, bignum )
191 anorm = dlantr( 'M', uplo, diag, n, n, a, lda, work )
192*
193 rat = rmax*( min( bignum / max( one, anorm ), one / eps ) )
194 END IF
195*
196 RETURN
197*
198* End of DTRT06
199*

◆ dtsqr01()

subroutine dtsqr01 ( character tssw,
integer m,
integer n,
integer mb,
integer nb,
double precision, dimension(6) result )

DTSQR01

Purpose:
!>
!> DTSQR01 tests DGEQR , DGELQ, DGEMLQ and DGEMQR.
!>
Parameters
[in]TSSW
!>          TSSW is CHARACTER
!>          'TS' for testing tall skinny QR
!>               and anything else for testing short wide LQ
!>
[in]M
!>          M is INTEGER
!>          Number of rows in test matrix.
!>
[in]N
!>          N is INTEGER
!>          Number of columns in test matrix.
!>
[in]MB
!>          MB is INTEGER
!>          Number of row in row block in test matrix.
!>
[in]NB
!>          NB is INTEGER
!>          Number of columns in column block test matrix.
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (6)
!>          Results of each of the six tests below.
!>
!>          RESULT(1) = | A - Q R | or | A - L Q |
!>          RESULT(2) = | I - Q^H Q | or | I - Q Q^H |
!>          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 83 of file dtsqr01.f.

84 IMPLICIT NONE
85*
86* -- LAPACK test routine --
87* -- LAPACK is a software package provided by Univ. of Tennessee, --
88* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
89*
90* .. Scalar Arguments ..
91 CHARACTER TSSW
92 INTEGER M, N, MB, NB
93* .. Return values ..
94 DOUBLE PRECISION RESULT(6)
95*
96* =====================================================================
97*
98* ..
99* .. Local allocatable arrays
100 DOUBLE PRECISION, ALLOCATABLE :: AF(:,:), Q(:,:),
101 $ R(:,:), RWORK(:), WORK( : ), T(:),
102 $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:)
103*
104* .. Parameters ..
105 DOUBLE PRECISION ONE, ZERO
106 parameter( zero = 0.0, one = 1.0 )
107* ..
108* .. Local Scalars ..
109 LOGICAL TESTZEROS, TS
110 INTEGER INFO, J, K, L, LWORK, TSIZE, MNB
111 DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM
112* ..
113* .. Local Arrays ..
114 INTEGER ISEED( 4 )
115 DOUBLE PRECISION TQUERY( 5 ), WORKQUERY( 1 )
116* ..
117* .. External Functions ..
118 DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
119 LOGICAL LSAME
120 INTEGER ILAENV
121 EXTERNAL dlamch, dlange, dlansy, lsame, ilaenv
122* ..
123* .. Intrinsic Functions ..
124 INTRINSIC max, min
125* .. Scalars in Common ..
126 CHARACTER*32 srnamt
127* ..
128* .. Common blocks ..
129 COMMON / srnamc / srnamt
130* ..
131* .. Data statements ..
132 DATA iseed / 1988, 1989, 1990, 1991 /
133*
134* TEST TALL SKINNY OR SHORT WIDE
135*
136 ts = lsame(tssw, 'TS')
137*
138* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS
139*
140 testzeros = .false.
141*
142 eps = dlamch( 'Epsilon' )
143 k = min(m,n)
144 l = max(m,n,1)
145 mnb = max( mb, nb)
146 lwork = max(3,l)*mnb
147*
148* Dynamically allocate local arrays
149*
150 ALLOCATE ( a(m,n), af(m,n), q(l,l), r(m,l), rwork(l),
151 $ c(m,n), cf(m,n),
152 $ d(n,m), df(n,m), lq(l,n) )
153*
154* Put random numbers into A and copy to AF
155*
156 DO j=1,n
157 CALL dlarnv( 2, iseed, m, a( 1, j ) )
158 END DO
159 IF (testzeros) THEN
160 IF (m.GE.4) THEN
161 DO j=1,n
162 CALL dlarnv( 2, iseed, m/2, a( m/4, j ) )
163 END DO
164 END IF
165 END IF
166 CALL dlacpy( 'Full', m, n, a, m, af, m )
167*
168 IF (ts) THEN
169*
170* Factor the matrix A in the array AF.
171*
172 CALL dgeqr( m, n, af, m, tquery, -1, workquery, -1, info )
173 tsize = int( tquery( 1 ) )
174 lwork = int( workquery( 1 ) )
175 CALL dgemqr( 'L', 'N', m, m, k, af, m, tquery, tsize, cf, m,
176 $ workquery, -1, info)
177 lwork = max( lwork, int( workquery( 1 ) ) )
178 CALL dgemqr( 'L', 'N', m, n, k, af, m, tquery, tsize, cf, m,
179 $ workquery, -1, info)
180 lwork = max( lwork, int( workquery( 1 ) ) )
181 CALL dgemqr( 'L', 'T', m, n, k, af, m, tquery, tsize, cf, m,
182 $ workquery, -1, info)
183 lwork = max( lwork, int( workquery( 1 ) ) )
184 CALL dgemqr( 'R', 'N', n, m, k, af, m, tquery, tsize, df, n,
185 $ workquery, -1, info)
186 lwork = max( lwork, int( workquery( 1 ) ) )
187 CALL dgemqr( 'R', 'T', n, m, k, af, m, tquery, tsize, df, n,
188 $ workquery, -1, info)
189 lwork = max( lwork, int( workquery( 1 ) ) )
190 ALLOCATE ( t( tsize ) )
191 ALLOCATE ( work( lwork ) )
192 srnamt = 'DGEQR'
193 CALL dgeqr( m, n, af, m, t, tsize, work, lwork, info )
194*
195* Generate the m-by-m matrix Q
196*
197 CALL dlaset( 'Full', m, m, zero, one, q, m )
198 srnamt = 'DGEMQR'
199 CALL dgemqr( 'L', 'N', m, m, k, af, m, t, tsize, q, m,
200 $ work, lwork, info )
201*
202* Copy R
203*
204 CALL dlaset( 'Full', m, n, zero, zero, r, m )
205 CALL dlacpy( 'Upper', m, n, af, m, r, m )
206*
207* Compute |R - Q'*A| / |A| and store in RESULT(1)
208*
209 CALL dgemm( 'T', 'N', m, n, m, -one, q, m, a, m, one, r, m )
210 anorm = dlange( '1', m, n, a, m, rwork )
211 resid = dlange( '1', m, n, r, m, rwork )
212 IF( anorm.GT.zero ) THEN
213 result( 1 ) = resid / (eps*max(1,m)*anorm)
214 ELSE
215 result( 1 ) = zero
216 END IF
217*
218* Compute |I - Q'*Q| and store in RESULT(2)
219*
220 CALL dlaset( 'Full', m, m, zero, one, r, m )
221 CALL dsyrk( 'U', 'C', m, m, -one, q, m, one, r, m )
222 resid = dlansy( '1', 'Upper', m, r, m, rwork )
223 result( 2 ) = resid / (eps*max(1,m))
224*
225* Generate random m-by-n matrix C and a copy CF
226*
227 DO j=1,n
228 CALL dlarnv( 2, iseed, m, c( 1, j ) )
229 END DO
230 cnorm = dlange( '1', m, n, c, m, rwork)
231 CALL dlacpy( 'Full', m, n, c, m, cf, m )
232*
233* Apply Q to C as Q*C
234*
235 srnamt = 'DGEMQR'
236 CALL dgemqr( 'L', 'N', m, n, k, af, m, t, tsize, cf, m,
237 $ work, lwork, info)
238*
239* Compute |Q*C - Q*C| / |C|
240*
241 CALL dgemm( 'N', 'N', m, n, m, -one, q, m, c, m, one, cf, m )
242 resid = dlange( '1', m, n, cf, m, rwork )
243 IF( cnorm.GT.zero ) THEN
244 result( 3 ) = resid / (eps*max(1,m)*cnorm)
245 ELSE
246 result( 3 ) = zero
247 END IF
248*
249* Copy C into CF again
250*
251 CALL dlacpy( 'Full', m, n, c, m, cf, m )
252*
253* Apply Q to C as QT*C
254*
255 srnamt = 'DGEMQR'
256 CALL dgemqr( 'L', 'T', m, n, k, af, m, t, tsize, cf, m,
257 $ work, lwork, info)
258*
259* Compute |QT*C - QT*C| / |C|
260*
261 CALL dgemm( 'T', 'N', m, n, m, -one, q, m, c, m, one, cf, m )
262 resid = dlange( '1', m, n, cf, m, rwork )
263 IF( cnorm.GT.zero ) THEN
264 result( 4 ) = resid / (eps*max(1,m)*cnorm)
265 ELSE
266 result( 4 ) = zero
267 END IF
268*
269* Generate random n-by-m matrix D and a copy DF
270*
271 DO j=1,m
272 CALL dlarnv( 2, iseed, n, d( 1, j ) )
273 END DO
274 dnorm = dlange( '1', n, m, d, n, rwork)
275 CALL dlacpy( 'Full', n, m, d, n, df, n )
276*
277* Apply Q to D as D*Q
278*
279 srnamt = 'DGEMQR'
280 CALL dgemqr( 'R', 'N', n, m, k, af, m, t, tsize, df, n,
281 $ work, lwork, info)
282*
283* Compute |D*Q - D*Q| / |D|
284*
285 CALL dgemm( 'N', 'N', n, m, m, -one, d, n, q, m, one, df, n )
286 resid = dlange( '1', n, m, df, n, rwork )
287 IF( dnorm.GT.zero ) THEN
288 result( 5 ) = resid / (eps*max(1,m)*dnorm)
289 ELSE
290 result( 5 ) = zero
291 END IF
292*
293* Copy D into DF again
294*
295 CALL dlacpy( 'Full', n, m, d, n, df, n )
296*
297* Apply Q to D as D*QT
298*
299 CALL dgemqr( 'R', 'T', n, m, k, af, m, t, tsize, df, n,
300 $ work, lwork, info)
301*
302* Compute |D*QT - D*QT| / |D|
303*
304 CALL dgemm( 'N', 'T', n, m, m, -one, d, n, q, m, one, df, n )
305 resid = dlange( '1', n, m, df, n, rwork )
306 IF( cnorm.GT.zero ) THEN
307 result( 6 ) = resid / (eps*max(1,m)*dnorm)
308 ELSE
309 result( 6 ) = zero
310 END IF
311*
312* Short and wide
313*
314 ELSE
315 CALL dgelq( m, n, af, m, tquery, -1, workquery, -1, info )
316 tsize = int( tquery( 1 ) )
317 lwork = int( workquery( 1 ) )
318 CALL dgemlq( 'R', 'N', n, n, k, af, m, tquery, tsize, q, n,
319 $ workquery, -1, info )
320 lwork = max( lwork, int( workquery( 1 ) ) )
321 CALL dgemlq( 'L', 'N', n, m, k, af, m, tquery, tsize, df, n,
322 $ workquery, -1, info)
323 lwork = max( lwork, int( workquery( 1 ) ) )
324 CALL dgemlq( 'L', 'T', n, m, k, af, m, tquery, tsize, df, n,
325 $ workquery, -1, info)
326 lwork = max( lwork, int( workquery( 1 ) ) )
327 CALL dgemlq( 'R', 'N', m, n, k, af, m, tquery, tsize, cf, m,
328 $ workquery, -1, info)
329 lwork = max( lwork, int( workquery( 1 ) ) )
330 CALL dgemlq( 'R', 'T', m, n, k, af, m, tquery, tsize, cf, m,
331 $ workquery, -1, info)
332 lwork = max( lwork, int( workquery( 1 ) ) )
333 ALLOCATE ( t( tsize ) )
334 ALLOCATE ( work( lwork ) )
335 srnamt = 'DGELQ'
336 CALL dgelq( m, n, af, m, t, tsize, work, lwork, info )
337*
338*
339* Generate the n-by-n matrix Q
340*
341 CALL dlaset( 'Full', n, n, zero, one, q, n )
342 srnamt = 'DGEMLQ'
343 CALL dgemlq( 'R', 'N', n, n, k, af, m, t, tsize, q, n,
344 $ work, lwork, info )
345*
346* Copy R
347*
348 CALL dlaset( 'Full', m, n, zero, zero, lq, l )
349 CALL dlacpy( 'Lower', m, n, af, m, lq, l )
350*
351* Compute |L - A*Q'| / |A| and store in RESULT(1)
352*
353 CALL dgemm( 'N', 'T', m, n, n, -one, a, m, q, n, one, lq, l )
354 anorm = dlange( '1', m, n, a, m, rwork )
355 resid = dlange( '1', m, n, lq, l, rwork )
356 IF( anorm.GT.zero ) THEN
357 result( 1 ) = resid / (eps*max(1,n)*anorm)
358 ELSE
359 result( 1 ) = zero
360 END IF
361*
362* Compute |I - Q'*Q| and store in RESULT(2)
363*
364 CALL dlaset( 'Full', n, n, zero, one, lq, l )
365 CALL dsyrk( 'U', 'C', n, n, -one, q, n, one, lq, l )
366 resid = dlansy( '1', 'Upper', n, lq, l, rwork )
367 result( 2 ) = resid / (eps*max(1,n))
368*
369* Generate random m-by-n matrix C and a copy CF
370*
371 DO j=1,m
372 CALL dlarnv( 2, iseed, n, d( 1, j ) )
373 END DO
374 dnorm = dlange( '1', n, m, d, n, rwork)
375 CALL dlacpy( 'Full', n, m, d, n, df, n )
376*
377* Apply Q to C as Q*C
378*
379 CALL dgemlq( 'L', 'N', n, m, k, af, m, t, tsize, df, n,
380 $ work, lwork, info)
381*
382* Compute |Q*D - Q*D| / |D|
383*
384 CALL dgemm( 'N', 'N', n, m, n, -one, q, n, d, n, one, df, n )
385 resid = dlange( '1', n, m, df, n, rwork )
386 IF( dnorm.GT.zero ) THEN
387 result( 3 ) = resid / (eps*max(1,n)*dnorm)
388 ELSE
389 result( 3 ) = zero
390 END IF
391*
392* Copy D into DF again
393*
394 CALL dlacpy( 'Full', n, m, d, n, df, n )
395*
396* Apply Q to D as QT*D
397*
398 CALL dgemlq( 'L', 'T', n, m, k, af, m, t, tsize, df, n,
399 $ work, lwork, info)
400*
401* Compute |QT*D - QT*D| / |D|
402*
403 CALL dgemm( 'T', 'N', n, m, n, -one, q, n, d, n, one, df, n )
404 resid = dlange( '1', n, m, df, n, rwork )
405 IF( dnorm.GT.zero ) THEN
406 result( 4 ) = resid / (eps*max(1,n)*dnorm)
407 ELSE
408 result( 4 ) = zero
409 END IF
410*
411* Generate random n-by-m matrix D and a copy DF
412*
413 DO j=1,n
414 CALL dlarnv( 2, iseed, m, c( 1, j ) )
415 END DO
416 cnorm = dlange( '1', m, n, c, m, rwork)
417 CALL dlacpy( 'Full', m, n, c, m, cf, m )
418*
419* Apply Q to C as C*Q
420*
421 CALL dgemlq( 'R', 'N', m, n, k, af, m, t, tsize, cf, m,
422 $ work, lwork, info)
423*
424* Compute |C*Q - C*Q| / |C|
425*
426 CALL dgemm( 'N', 'N', m, n, n, -one, c, m, q, n, one, cf, m )
427 resid = dlange( '1', n, m, df, n, rwork )
428 IF( cnorm.GT.zero ) THEN
429 result( 5 ) = resid / (eps*max(1,n)*cnorm)
430 ELSE
431 result( 5 ) = zero
432 END IF
433*
434* Copy C into CF again
435*
436 CALL dlacpy( 'Full', m, n, c, m, cf, m )
437*
438* Apply Q to D as D*QT
439*
440 CALL dgemlq( 'R', 'T', m, n, k, af, m, t, tsize, cf, m,
441 $ work, lwork, info)
442*
443* Compute |C*QT - C*QT| / |C|
444*
445 CALL dgemm( 'N', 'T', m, n, n, -one, c, m, q, n, one, cf, m )
446 resid = dlange( '1', m, n, cf, m, rwork )
447 IF( cnorm.GT.zero ) THEN
448 result( 6 ) = resid / (eps*max(1,n)*cnorm)
449 ELSE
450 result( 6 ) = zero
451 END IF
452*
453 END IF
454*
455* Deallocate all arrays
456*
457 DEALLOCATE ( a, af, q, r, rwork, work, t, c, d, cf, df)
458*
459 RETURN
ilaenv
integer function ilaenv(ispec, name, opts, n1, n2, n3, n4)
ILAENV
Definition ilaenv.f:162

◆ schklqt()

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

SCHKLQT

Purpose:
!>
!> SCHKLQT tests SGELQT and SGEMLQT.
!>
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 schklqt.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, serrlqt, slqt04
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 ) = 'S'
148 path( 2: 3 ) = 'TQ'
149 nrun = 0
150 nfail = 0
151 nerrs = 0
152*
153* Test the error exits
154*
155 IF( tsterr ) CALL serrlqt( 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 DGELQT and DGEMLQT
175*
176 IF( (nb.LE.minmn).AND.(nb.GT.0) ) THEN
177 CALL slqt04( 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 SCHKLQT
206*
slqt04
subroutine slqt04(m, n, nb, result)
SLQT04
Definition slqt04.f:73
serrlqt
subroutine serrlqt(path, nunit)
SERRLQT
Definition serrlqt.f:55

◆ schklqtp()

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

SCHKLQTP

Purpose:
!>
!> SCHKLQTP tests STPLQT and STPMLQT.
!>
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 schklqtp.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, L, 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, serrlqtp, slqt05
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 ) = 'S'
148 path( 2: 3 ) = 'XQ'
149 nrun = 0
150 nfail = 0
151 nerrs = 0
152*
153* Test the error exits
154*
155 IF( tsterr ) CALL serrlqtp( path, nout )
156 infot = 0
157*
158* Do for each value of M
159*
160 DO i = 1, nm
161 m = mval( i )
162*
163* Do for each value of N
164*
165 DO j = 1, nn
166 n = nval( j )
167*
168* Do for each value of L
169*
170 minmn = min( m, n )
171 DO l = 0, minmn, max( minmn, 1 )
172*
173* Do for each possible value of NB
174*
175 DO k = 1, nnb
176 nb = nbval( k )
177*
178* Test DTPLQT and DTPMLQT
179*
180 IF( (nb.LE.m).AND.(nb.GT.0) ) THEN
181 CALL slqt05( m, n, l, nb, result )
182*
183* Print information about the tests that did not
184* pass the threshold.
185*
186 DO t = 1, ntests
187 IF( result( t ).GE.thresh ) THEN
188 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
189 $ CALL alahd( nout, path )
190 WRITE( nout, fmt = 9999 )m, n, nb, l,
191 $ t, result( t )
192 nfail = nfail + 1
193 END IF
194 END DO
195 nrun = nrun + ntests
196 END IF
197 END DO
198 END DO
199 END DO
200 END DO
201*
202* Print a summary of the results.
203*
204 CALL alasum( path, nout, nfail, nrun, nerrs )
205*
206 9999 FORMAT( ' M=', i5, ', N=', i5, ', NB=', i4,' L=', i4,
207 $ ' test(', i2, ')=', g12.5 )
208 RETURN
209*
210* End of SCHKQRTP
211*
slqt05
subroutine slqt05(m, n, l, nb, result)
SLQT05
Definition slqt05.f:79
serrlqtp
subroutine serrlqtp(path, nunit)
DERRLQTP
Definition serrlqtp.f:55

◆ schksy_rk()

subroutine schksy_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,
real, dimension( * ) a,
real, dimension( * ) afac,
real, dimension( * ) e,
real, dimension( * ) ainv,
real, dimension( * ) b,
real, dimension( * ) x,
real, dimension( * ) xact,
real, dimension( * ) work,
real, dimension( * ) rwork,
integer, dimension( * ) iwork,
integer nout )

SCHKSY_RK

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

◆ schktsqr()

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

SCHKQRT

Purpose:
!>
!> SCHKTSQR tests SGETSQR and SORMTSQR.
!>
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 schktsqr.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, INB,
126 $ MINMN, MB, IMB
127*
128* .. Local Arrays ..
129 REAL RESULT( NTESTS )
130* ..
131* .. External Subroutines ..
132 EXTERNAL alaerh, alahd, alasum, serrtsqr,
133 $ stsqr01, xlaenv
134* ..
135* .. Intrinsic Functions ..
136 INTRINSIC max, min
137* ..
138* .. Scalars in Common ..
139 LOGICAL LERR, OK
140 CHARACTER*32 SRNAMT
141 INTEGER INFOT, NUNIT
142* ..
143* .. Common blocks ..
144 COMMON / infoc / infot, nunit, ok, lerr
145 COMMON / srnamc / srnamt
146* ..
147* .. Executable Statements ..
148*
149* Initialize constants
150*
151 path( 1: 1 ) = 'S'
152 path( 2: 3 ) = 'TS'
153 nrun = 0
154 nfail = 0
155 nerrs = 0
156*
157* Test the error exits
158*
159 CALL xlaenv( 1, 0 )
160 CALL xlaenv( 2, 0 )
161 IF( tsterr ) CALL serrtsqr( path, nout )
162 infot = 0
163*
164* Do for each value of M in MVAL.
165*
166 DO i = 1, nm
167 m = mval( i )
168*
169* Do for each value of N in NVAL.
170*
171 DO j = 1, nn
172 n = nval( j )
173 IF (min(m,n).NE.0) THEN
174 DO inb = 1, nnb
175 mb = nbval( inb )
176 CALL xlaenv( 1, mb )
177 DO imb = 1, nnb
178 nb = nbval( imb )
179 CALL xlaenv( 2, nb )
180*
181* Test SGEQR and SGEMQR
182*
183 CALL stsqr01('TS', m, n, mb, nb, result )
184*
185* Print information about the tests that did not
186* pass the threshold.
187*
188 DO t = 1, ntests
189 IF( result( t ).GE.thresh ) THEN
190 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
191 $ CALL alahd( nout, path )
192 WRITE( nout, fmt = 9999 )m, n, mb, nb,
193 $ t, result( t )
194 nfail = nfail + 1
195 END IF
196 END DO
197 nrun = nrun + ntests
198 END DO
199 END DO
200 END IF
201 END DO
202 END DO
203*
204* Do for each value of M in MVAL.
205*
206 DO i = 1, nm
207 m = mval( i )
208*
209* Do for each value of N in NVAL.
210*
211 DO j = 1, nn
212 n = nval( j )
213 IF (min(m,n).NE.0) THEN
214 DO inb = 1, nnb
215 mb = nbval( inb )
216 CALL xlaenv( 1, mb )
217 DO imb = 1, nnb
218 nb = nbval( imb )
219 CALL xlaenv( 2, nb )
220*
221* Test SGEQR and SGEMQR
222*
223 CALL stsqr01('SW', m, n, mb, nb, result )
224*
225* Print information about the tests that did not
226* pass the threshold.
227*
228 DO t = 1, ntests
229 IF( result( t ).GE.thresh ) THEN
230 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
231 $ CALL alahd( nout, path )
232 WRITE( nout, fmt = 9998 )m, n, mb, nb,
233 $ t, result( t )
234 nfail = nfail + 1
235 END IF
236 END DO
237 nrun = nrun + ntests
238 END DO
239 END DO
240 END IF
241 END DO
242 END DO
243*
244* Print a summary of the results.
245*
246 CALL alasum( path, nout, nfail, nrun, nerrs )
247*
248 9999 FORMAT( 'TS: M=', i5, ', N=', i5, ', MB=', i5,
249 $ ', NB=', i5,' test(', i2, ')=', g12.5 )
250 9998 FORMAT( 'SW: M=', i5, ', N=', i5, ', MB=', i5,
251 $ ', NB=', i5,' test(', i2, ')=', g12.5 )
252 RETURN
253*
254* End of SCHKTSQR
255*
serrtsqr
subroutine serrtsqr(path, nunit)
DERRTSQR
Definition serrtsqr.f:55
stsqr01
subroutine stsqr01(tssw, m, n, mb, nb, result)
STSQR01
Definition stsqr01.f:84

◆ sdrvsy_rook()

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

SDRVSY_ROOK

Purpose:
!>
!> SDRVSY_ROOK tests the driver routines SSYSV_ROOK.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is DOUBLE PRECISION
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is 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 sdrvsy_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 A( * ), AFAC( * ), AINV( * ), B( * ),
167 $ RWORK( * ), 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 = 10, 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 PATH, MATPATH
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* .. External Functions ..
195 REAL SLANSY
196 EXTERNAL slansy
197* ..
198* .. External Subroutines ..
199 EXTERNAL aladhd, alaerh, alasvm, serrvx, sget04, slacpy,
200 $ slarhs, slaset, slatb4, slatms, spot02, spot05,
201 $ ssysv_rook, ssyt01_rook, ssytrf_rook,
202 $ ssytri_rook,
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 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 ) = 'Single precision'
228 path( 2: 3 ) = 'SR'
229*
230* Path to generate matrices
231*
232 matpath( 1: 1 ) = 'Single 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 serrvx( 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* Begin generate the test matrix A.
286*
287* Set up parameters with SLATB4 for the matrix generator
288* based on the type of matrix to be generated.
289*
290 CALL slatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
291 $ MODE, CNDNUM, DIST )
292*
293* Generate a matrix with SLATMS.
294*
295 srnamt = 'SLATMS'
296 CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE,
297 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
298 $ INFO )
299*
300* Check error code from SLATMS and handle error.
301*
302 IF( info.NE.0 ) THEN
303 CALL alaerh( path, 'SLATMS', info, 0, uplo, n, n, -1,
304 $ -1, -1, imat, nfail, nerrs, nout )
305*
306* Skip all tests for this generated matrix
307*
308 GO TO 160
309 END IF
310*
311* For types 3-6, zero one or more rows and columns of the
312* matrix to test that INFO is returned correctly.
313*
314 IF( zerot ) THEN
315 IF( imat.EQ.3 ) THEN
316 izero = 1
317 ELSE IF( imat.EQ.4 ) THEN
318 izero = n
319 ELSE
320 izero = n / 2 + 1
321 END IF
322*
323 IF( imat.LT.6 ) THEN
324*
325* Set row and column IZERO to zero.
326*
327 IF( iuplo.EQ.1 ) THEN
328 ioff = ( izero-1 )*lda
329 DO 20 i = 1, izero - 1
330 a( ioff+i ) = zero
331 20 CONTINUE
332 ioff = ioff + izero
333 DO 30 i = izero, n
334 a( ioff ) = zero
335 ioff = ioff + lda
336 30 CONTINUE
337 ELSE
338 ioff = izero
339 DO 40 i = 1, izero - 1
340 a( ioff ) = zero
341 ioff = ioff + lda
342 40 CONTINUE
343 ioff = ioff - izero
344 DO 50 i = izero, n
345 a( ioff+i ) = zero
346 50 CONTINUE
347 END IF
348 ELSE
349 ioff = 0
350 IF( iuplo.EQ.1 ) THEN
351*
352* Set the first IZERO rows and columns to zero.
353*
354 DO 70 j = 1, n
355 i2 = min( j, izero )
356 DO 60 i = 1, i2
357 a( ioff+i ) = zero
358 60 CONTINUE
359 ioff = ioff + lda
360 70 CONTINUE
361 ELSE
362*
363* Set the last IZERO rows and columns to zero.
364*
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 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 DSYSVX_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 = slansy( '1', uplo, n, a, lda, rwork )
399*
400* Factor the matrix A.
401*
402 CALL slacpy( uplo, n, n, a, lda, afac, lda )
403 CALL ssytrf_rook( uplo, n, afac, lda, iwork, work,
404 $ lwork, info )
405*
406* Compute inv(A) and take its norm.
407*
408 CALL slacpy( uplo, n, n, afac, lda, ainv, lda )
409 lwork = (n+nb+1)*(nb+3)
410 CALL ssytri_rook( uplo, n, ainv, lda, iwork,
411 $ work, info )
412 ainvnm = slansy( '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 = 'SLARHS'
426 CALL slarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
427 $ nrhs, a, lda, xact, lda, b, lda, iseed,
428 $ info )
429 xtype = 'C'
430*
431* --- Test SSYSV_ROOK ---
432*
433 IF( ifact.EQ.2 ) THEN
434 CALL slacpy( uplo, n, n, a, lda, afac, lda )
435 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
436*
437* Factor the matrix and solve the system using
438* SSYSV_ROOK.
439*
440 srnamt = 'SSYSV_ROOK'
441 CALL ssysv_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 SSYSV_ROOK and handle error.
462*
463 IF( info.NE.k ) THEN
464 CALL alaerh( path, 'SSYSV_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 ssyt01_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 slacpy( 'Full', n, nrhs, b, lda, work, lda )
482 CALL spot02( 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 sget04( 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 )'SSYSV_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 SDRVSY_ROOK
523*
slaset
subroutine slaset(uplo, m, n, alpha, beta, a, lda)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition slaset.f:110
ssytrf_rook
subroutine ssytrf_rook(uplo, n, a, lda, ipiv, work, lwork, info)
SSYTRF_ROOK
Definition ssytrf_rook.f:208
ssytri_rook
subroutine ssytri_rook(uplo, n, a, lda, ipiv, work, info)
SSYTRI_ROOK
Definition ssytri_rook.f:129
ssysv_rook
subroutine ssysv_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
SSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices
Definition ssysv_rook.f:204
serrvx
subroutine serrvx(path, nunit)
SERRVX
Definition serrvx.f:55
spot05
subroutine spot05(uplo, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
SPOT05
Definition spot05.f:164
ssyt01_rook
subroutine ssyt01_rook(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
SSYT01_ROOK
Definition ssyt01_rook.f:124

◆ serrlqt()

subroutine serrlqt ( character*3 path,
integer nunit )

SERRLQT

Purpose:
!>
!> DERRLQT tests the error exits for the DOUBLE PRECISION routines
!> that use the LQT 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 serrlqt.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 REAL A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
77 $ C( NMAX, NMAX )
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, sgelqt3, sgelqt,
81 $ sgemlqt
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 real
94* ..
95* .. Executable Statements ..
96*
97 nout = nunit
98 WRITE( nout, fmt = * )
99*
100* Set the variables to innocuous values.
101*
102 DO j = 1, nmax
103 DO i = 1, nmax
104 a( i, j ) = 1.d0 / real( i+j )
105 c( i, j ) = 1.d0 / real( i+j )
106 t( i, j ) = 1.d0 / real( i+j )
107 END DO
108 w( j ) = 0.d0
109 END DO
110 ok = .true.
111*
112* Error exits for LQT factorization
113*
114* SGELQT
115*
116 srnamt = 'SGELQT'
117 infot = 1
118 CALL sgelqt( -1, 0, 1, a, 1, t, 1, w, info )
119 CALL chkxer( 'SGELQT', infot, nout, lerr, ok )
120 infot = 2
121 CALL sgelqt( 0, -1, 1, a, 1, t, 1, w, info )
122 CALL chkxer( 'SGELQT', infot, nout, lerr, ok )
123 infot = 3
124 CALL sgelqt( 0, 0, 0, a, 1, t, 1, w, info )
125 CALL chkxer( 'SGELQT', infot, nout, lerr, ok )
126 infot = 5
127 CALL sgelqt( 2, 1, 1, a, 1, t, 1, w, info )
128 CALL chkxer( 'SGELQT', infot, nout, lerr, ok )
129 infot = 7
130 CALL sgelqt( 2, 2, 2, a, 2, t, 1, w, info )
131 CALL chkxer( 'SGELQT', infot, nout, lerr, ok )
132*
133* SGELQT3
134*
135 srnamt = 'SGELQT3'
136 infot = 1
137 CALL sgelqt3( -1, 0, a, 1, t, 1, info )
138 CALL chkxer( 'SGELQT3', infot, nout, lerr, ok )
139 infot = 2
140 CALL sgelqt3( 0, -1, a, 1, t, 1, info )
141 CALL chkxer( 'SGELQT3', infot, nout, lerr, ok )
142 infot = 4
143 CALL sgelqt3( 2, 2, a, 1, t, 1, info )
144 CALL chkxer( 'SGELQT3', infot, nout, lerr, ok )
145 infot = 6
146 CALL sgelqt3( 2, 2, a, 2, t, 1, info )
147 CALL chkxer( 'SGELQT3', infot, nout, lerr, ok )
148*
149* SGEMLQT
150*
151 srnamt = 'SGEMLQT'
152 infot = 1
153 CALL sgemlqt( '/', 'N', 0, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
154 CALL chkxer( 'SGEMLQT', infot, nout, lerr, ok )
155 infot = 2
156 CALL sgemlqt( 'L', '/', 0, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
157 CALL chkxer( 'SGEMLQT', infot, nout, lerr, ok )
158 infot = 3
159 CALL sgemlqt( 'L', 'N', -1, 0, 0, 1, a, 1, t, 1, c, 1, w, info )
160 CALL chkxer( 'SGEMLQT', infot, nout, lerr, ok )
161 infot = 4
162 CALL sgemlqt( 'L', 'N', 0, -1, 0, 1, a, 1, t, 1, c, 1, w, info )
163 CALL chkxer( 'SGEMLQT', infot, nout, lerr, ok )
164 infot = 5
165 CALL sgemlqt( 'L', 'N', 0, 0, -1, 1, a, 1, t, 1, c, 1, w, info )
166 CALL chkxer( 'SGEMLQT', infot, nout, lerr, ok )
167 infot = 5
168 CALL sgemlqt( 'R', 'N', 0, 0, -1, 1, a, 1, t, 1, c, 1, w, info )
169 CALL chkxer( 'SGEMLQT', infot, nout, lerr, ok )
170 infot = 6
171 CALL sgemlqt( 'L', 'N', 0, 0, 0, 0, a, 1, t, 1, c, 1, w, info )
172 CALL chkxer( 'SGEMLQT', infot, nout, lerr, ok )
173 infot = 8
174 CALL sgemlqt( 'R', 'N', 2, 2, 2, 1, a, 1, t, 1, c, 1, w, info )
175 CALL chkxer( 'SGEMLQT', infot, nout, lerr, ok )
176 infot = 8
177 CALL sgemlqt( 'L', 'N', 2, 2, 2, 1, a, 1, t, 1, c, 1, w, info )
178 CALL chkxer( 'SGEMLQT', infot, nout, lerr, ok )
179 infot = 10
180 CALL sgemlqt( 'R', 'N', 1, 1, 1, 1, a, 1, t, 0, c, 1, w, info )
181 CALL chkxer( 'SGEMLQT', infot, nout, lerr, ok )
182 infot = 12
183 CALL sgemlqt( 'L', 'N', 1, 1, 1, 1, a, 1, t, 1, c, 0, w, info )
184 CALL chkxer( 'SGEMLQT', infot, nout, lerr, ok )
185*
186* Print a summary line.
187*
188 CALL alaesm( path, ok, nout )
189*
190 RETURN
191*
192* End of SERRLQT
193*
sgemlqt
subroutine sgemlqt(side, trans, m, n, k, mb, v, ldv, t, ldt, c, ldc, work, info)
SGEMLQT
Definition sgemlqt.f:153
sgelqt3
recursive subroutine sgelqt3(m, n, a, lda, t, ldt, info)
SGELQT3
Definition sgelqt3.f:116
sgelqt
subroutine sgelqt(m, n, mb, a, lda, t, ldt, work, info)
SGELQT
Definition sgelqt.f:124

◆ serrlqtp()

subroutine serrlqtp ( character*3 path,
integer nunit )

DERRLQTP

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

◆ serrtsqr()

subroutine serrtsqr ( character*3 path,
integer nunit )

DERRTSQR

Purpose:
!>
!> DERRTSQR tests the error exits for the REAL routines
!> that use the TSQR 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 serrtsqr.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, MB, NB
74* ..
75* .. Local Arrays ..
76 REAL A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
77 $ C( NMAX, NMAX ), TAU(NMAX*2)
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, sgeqr,
81 $ sgemqr, sgelq, sgemlq
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 real
94* ..
95* .. Executable Statements ..
96*
97 nout = nunit
98 WRITE( nout, fmt = * )
99*
100* Set the variables to innocuous values.
101*
102 DO j = 1, nmax
103 DO i = 1, nmax
104 a( i, j ) = 1.d0 / real( i+j )
105 c( i, j ) = 1.d0 / real( i+j )
106 t( i, j ) = 1.d0 / real( i+j )
107 END DO
108 w( j ) = 0.d0
109 END DO
110 ok = .true.
111*
112* Error exits for TS factorization
113*
114* SGEQR
115*
116 srnamt = 'SGEQR'
117 infot = 1
118 CALL sgeqr( -1, 0, a, 1, tau, 1, w, 1, info )
119 CALL chkxer( 'SGEQR', infot, nout, lerr, ok )
120 infot = 2
121 CALL sgeqr( 0, -1, a, 1, tau, 1, w, 1, info )
122 CALL chkxer( 'SGEQR', infot, nout, lerr, ok )
123 infot = 4
124 CALL sgeqr( 1, 1, a, 0, tau, 1, w, 1, info )
125 CALL chkxer( 'SGEQR', infot, nout, lerr, ok )
126 infot = 6
127 CALL sgeqr( 3, 2, a, 3, tau, 1, w, 1, info )
128 CALL chkxer( 'SGEQR', infot, nout, lerr, ok )
129 infot = 8
130 CALL sgeqr( 3, 2, a, 3, tau, 7, w, 0, info )
131 CALL chkxer( 'SGEQR', infot, nout, lerr, ok )
132*
133* SLATSQR
134*
135 mb = 1
136 nb = 1
137 srnamt = 'SLATSQR'
138 infot = 1
139 CALL slatsqr( -1, 0, mb, nb, a, 1, tau, 1, w, 1, info )
140 CALL chkxer( 'SLATSQR', infot, nout, lerr, ok )
141 infot = 2
142 CALL slatsqr( 1, 2, mb, nb, a, 1, tau, 1, w, 1, info )
143 CALL chkxer( 'SLATSQR', infot, nout, lerr, ok )
144 CALL slatsqr( 0, -1, mb, nb, a, 1, tau, 1, w, 1, info )
145 CALL chkxer( 'SLATSQR', infot, nout, lerr, ok )
146 infot = 3
147 CALL slatsqr( 2, 1, -1, nb, a, 2, tau, 1, w, 1, info )
148 CALL chkxer( 'SLATSQR', infot, nout, lerr, ok )
149 infot = 4
150 CALL slatsqr( 2, 1, mb, 2, a, 2, tau, 1, w, 1, info )
151 CALL chkxer( 'SLATSQR', infot, nout, lerr, ok )
152 infot = 6
153 CALL slatsqr( 2, 1, mb, nb, a, 1, tau, 1, w, 1, info )
154 CALL chkxer( 'SLATSQR', infot, nout, lerr, ok )
155 infot = 8
156 CALL slatsqr( 2, 1, mb, nb, a, 2, tau, 0, w, 1, info )
157 CALL chkxer( 'SLATSQR', infot, nout, lerr, ok )
158 infot = 10
159 CALL slatsqr( 2, 1, mb, nb, a, 2, tau, 2, w, 0, info )
160 CALL chkxer( 'SLATSQR', infot, nout, lerr, ok )
161*
162* SGEMQR
163*
164 tau(1)=1
165 tau(2)=1
166 tau(3)=1
167 tau(4)=1
168 srnamt = 'SGEMQR'
169 nb=1
170 infot = 1
171 CALL sgemqr( '/', 'N', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
172 CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
173 infot = 2
174 CALL sgemqr( 'L', '/', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
175 CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
176 infot = 3
177 CALL sgemqr( 'L', 'N', -1, 0, 0, a, 1, tau, 1, c, 1, w,1,info)
178 CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
179 infot = 4
180 CALL sgemqr( 'L', 'N', 0, -1, 0, a, 1, tau, 1, c, 1, w,1,info)
181 CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
182 infot = 5
183 CALL sgemqr( 'L', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
184 CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
185 infot = 5
186 CALL sgemqr( 'R', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
187 CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
188 infot = 7
189 CALL sgemqr( 'L', 'N', 2, 1, 0, a, 0, tau, 1, c, 1, w, 1,info)
190 CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
191 infot = 9
192 CALL sgemqr( 'R', 'N', 2, 2, 1, a, 2, tau, 0, c, 1, w, 1,info)
193 CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
194 infot = 9
195 CALL sgemqr( 'L', 'N', 2, 2, 1, a, 2, tau, 0, c, 1, w, 1,info)
196 CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
197 infot = 11
198 CALL sgemqr( 'L', 'N', 2, 1, 1, a, 2, tau, 6, c, 0, w, 1,info)
199 CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
200 infot = 13
201 CALL sgemqr( 'L', 'N', 2, 2, 1, a, 2, tau, 6, c, 2, w, 0,info)
202 CALL chkxer( 'SGEMQR', infot, nout, lerr, ok )
203*
204* SGELQ
205*
206 srnamt = 'SGELQ'
207 infot = 1
208 CALL sgelq( -1, 0, a, 1, tau, 1, w, 1, info )
209 CALL chkxer( 'SGELQ', infot, nout, lerr, ok )
210 infot = 2
211 CALL sgelq( 0, -1, a, 1, tau, 1, w, 1, info )
212 CALL chkxer( 'SGELQ', infot, nout, lerr, ok )
213 infot = 4
214 CALL sgelq( 1, 1, a, 0, tau, 1, w, 1, info )
215 CALL chkxer( 'SGELQ', infot, nout, lerr, ok )
216 infot = 6
217 CALL sgelq( 2, 3, a, 3, tau, 1, w, 1, info )
218 CALL chkxer( 'SGELQ', infot, nout, lerr, ok )
219 infot = 8
220 CALL sgelq( 2, 3, a, 3, tau, 7, w, 0, info )
221 CALL chkxer( 'SGELQ', infot, nout, lerr, ok )
222*
223* SLASWLQ
224*
225 mb = 1
226 nb = 1
227 srnamt = 'SLASWLQ'
228 infot = 1
229 CALL slaswlq( -1, 0, mb, nb, a, 1, tau, 1, w, 1, info )
230 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
231 infot = 2
232 CALL slaswlq( 2, 1, mb, nb, a, 1, tau, 1, w, 1, info )
233 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
234 CALL slaswlq( 0, -1, mb, nb, a, 1, tau, 1, w, 1, info )
235 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
236 infot = 3
237 CALL slaswlq( 1, 2, -1, nb, a, 1, tau, 1, w, 1, info )
238 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
239 CALL slaswlq( 1, 1, 2, nb, a, 1, tau, 1, w, 1, info )
240 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
241 infot = 4
242 CALL slaswlq( 1, 2, mb, -1, a, 1, tau, 1, w, 1, info )
243 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
244 infot = 6
245 CALL slaswlq( 1, 2, mb, nb, a, 0, tau, 1, w, 1, info )
246 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
247 infot = 8
248 CALL slaswlq( 1, 2, mb, nb, a, 1, tau, 0, w, 1, info )
249 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
250 infot = 10
251 CALL slaswlq( 1, 2, mb, nb, a, 1, tau, 1, w, 0, info )
252 CALL chkxer( 'SLASWLQ', infot, nout, lerr, ok )
253*
254* SGEMLQ
255*
256 tau(1)=1
257 tau(2)=1
258 srnamt = 'SGEMLQ'
259 nb=1
260 infot = 1
261 CALL sgemlq( '/', 'N', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
262 CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
263 infot = 2
264 CALL sgemlq( 'L', '/', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
265 CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
266 infot = 3
267 CALL sgemlq( 'L', 'N', -1, 0, 0, a, 1, tau, 1, c, 1, w,1,info)
268 CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
269 infot = 4
270 CALL sgemlq( 'L', 'N', 0, -1, 0, a, 1, tau, 1, c, 1, w,1,info)
271 CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
272 infot = 5
273 CALL sgemlq( 'L', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
274 CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
275 infot = 5
276 CALL sgemlq( 'R', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
277 CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
278 infot = 7
279 CALL sgemlq( 'L', 'N', 1, 2, 0, a, 0, tau, 1, c, 1, w, 1,info)
280 CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
281 infot = 9
282 CALL sgemlq( 'R', 'N', 2, 2, 1, a, 1, tau, 0, c, 1, w, 1,info)
283 CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
284 infot = 9
285 CALL sgemlq( 'L', 'N', 2, 2, 1, a, 1, tau, 0, c, 1, w, 1,info)
286 CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
287 infot = 11
288 CALL sgemlq( 'L', 'N', 1, 2, 1, a, 1, tau, 6, c, 0, w, 1,info)
289 CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
290 infot = 13
291 CALL sgemlq( 'L', 'N', 2, 2, 1, a, 2, tau, 6, c, 2, w, 0,info)
292 CALL chkxer( 'SGEMLQ', infot, nout, lerr, ok )
293*
294* Print a summary line.
295*
296 CALL alaesm( path, ok, nout )
297*
298 RETURN
299*
300* End of SERRTSQR
301*
sgelq
subroutine sgelq(m, n, a, lda, t, tsize, work, lwork, info)
SGELQ
Definition sgelq.f:172
sgemlq
subroutine sgemlq(side, trans, m, n, k, a, lda, t, tsize, c, ldc, work, lwork, info)
SGEMLQ
Definition sgemlq.f:170
sgemqr
subroutine sgemqr(side, trans, m, n, k, a, lda, t, tsize, c, ldc, work, lwork, info)
SGEMQR
Definition sgemqr.f:172
sgeqr
subroutine sgeqr(m, n, a, lda, t, tsize, work, lwork, info)
SGEQR
Definition sgeqr.f:174
slaswlq
subroutine slaswlq(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
SLASWLQ
Definition slaswlq.f:164
slatsqr
subroutine slatsqr(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
SLATSQR
Definition slatsqr.f:166

◆ slqt04()

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

SLQT04

Purpose:
!>
!> SLQT04 tests SGELQT and SGEMLQT.
!>
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 - L Q |
!>          RESULT(2) = | I - Q Q^H |
!>          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 slqt04.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 REAL, ALLOCATABLE :: AF(:,:), Q(:,:),
89 $ L(:,:), RWORK(:), WORK( : ), T(:,:),
90 $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
91*
92* .. Parameters ..
93 REAL ONE, ZERO
94 parameter( zero = 0.0, one = 1.0 )
95* ..
96* .. Local Scalars ..
97 INTEGER INFO, J, K, LL, LWORK
98 REAL ANORM, EPS, RESID, CNORM, DNORM
99* ..
100* .. Local Arrays ..
101 INTEGER ISEED( 4 )
102* ..
103* .. External Functions ..
104 REAL SLAMCH, SLANGE, SLANSY
105 LOGICAL LSAME
106 EXTERNAL slamch, slange, slansy, lsame
107* ..
108* .. Intrinsic Functions ..
109 INTRINSIC max, min
110* ..
111* .. Data statements ..
112 DATA iseed / 1988, 1989, 1990, 1991 /
113*
114 eps = slamch( 'Epsilon' )
115 k = min(m,n)
116 ll = max(m,n)
117 lwork = max(2,ll)*max(2,ll)*nb
118*
119* Dynamically allocate local arrays
120*
121 ALLOCATE ( a(m,n), af(m,n), q(n,n), l(ll,n), rwork(ll),
122 $ work(lwork), t(nb,n), c(m,n), cf(m,n),
123 $ d(n,m), df(n,m) )
124*
125* Put random numbers into A and copy to AF
126*
127 ldt=nb
128 DO j=1,n
129 CALL slarnv( 2, iseed, m, a( 1, j ) )
130 END DO
131 CALL slacpy( 'Full', m, n, a, m, af, m )
132*
133* Factor the matrix A in the array AF.
134*
135 CALL sgelqt( m, n, nb, af, m, t, ldt, work, info )
136*
137* Generate the n-by-n matrix Q
138*
139 CALL slaset( 'Full', n, n, zero, one, q, n )
140 CALL sgemlqt( 'R', 'N', n, n, k, nb, af, m, t, ldt, q, n,
141 $ work, info )
142*
143* Copy R
144*
145 CALL slaset( 'Full', m, n, zero, zero, l, ll )
146 CALL slacpy( 'Lower', m, n, af, m, l, ll )
147*
148* Compute |L - A*Q'| / |A| and store in RESULT(1)
149*
150 CALL sgemm( 'N', 'T', m, n, n, -one, a, m, q, n, one, l, ll )
151 anorm = slange( '1', m, n, a, m, rwork )
152 resid = slange( '1', m, n, l, ll, rwork )
153 IF( anorm.GT.zero ) THEN
154 result( 1 ) = resid / (eps*max(1,m)*anorm)
155 ELSE
156 result( 1 ) = zero
157 END IF
158*
159* Compute |I - Q'*Q| and store in RESULT(2)
160*
161 CALL slaset( 'Full', n, n, zero, one, l, ll )
162 CALL ssyrk( 'U', 'C', n, n, -one, q, n, one, l, ll )
163 resid = slansy( '1', 'Upper', n, l, ll, rwork )
164 result( 2 ) = resid / (eps*max(1,n))
165*
166* Generate random m-by-n matrix C and a copy CF
167*
168 DO j=1,m
169 CALL slarnv( 2, iseed, n, d( 1, j ) )
170 END DO
171 dnorm = slange( '1', n, m, d, n, rwork)
172 CALL slacpy( 'Full', n, m, d, n, df, n )
173*
174* Apply Q to C as Q*C
175*
176 CALL sgemlqt( 'L', 'N', n, m, k, nb, af, m, t, nb, df, n,
177 $ work, info)
178*
179* Compute |Q*D - Q*D| / |D|
180*
181 CALL sgemm( 'N', 'N', n, m, n, -one, q, n, d, n, one, df, n )
182 resid = slange( '1', n, m, df, n, rwork )
183 IF( dnorm.GT.zero ) THEN
184 result( 3 ) = resid / (eps*max(1,m)*dnorm)
185 ELSE
186 result( 3 ) = zero
187 END IF
188*
189* Copy D into DF again
190*
191 CALL slacpy( 'Full', n, m, d, n, df, n )
192*
193* Apply Q to D as QT*D
194*
195 CALL sgemlqt( 'L', 'T', n, m, k, nb, af, m, t, nb, df, n,
196 $ work, info)
197*
198* Compute |QT*D - QT*D| / |D|
199*
200 CALL sgemm( 'T', 'N', n, m, n, -one, q, n, d, n, one, df, n )
201 resid = slange( '1', n, m, df, n, rwork )
202 IF( dnorm.GT.zero ) THEN
203 result( 4 ) = resid / (eps*max(1,m)*dnorm)
204 ELSE
205 result( 4 ) = zero
206 END IF
207*
208* Generate random n-by-m matrix D and a copy DF
209*
210 DO j=1,n
211 CALL slarnv( 2, iseed, m, c( 1, j ) )
212 END DO
213 cnorm = slange( '1', m, n, c, m, rwork)
214 CALL slacpy( 'Full', m, n, c, m, cf, m )
215*
216* Apply Q to C as C*Q
217*
218 CALL sgemlqt( 'R', 'N', m, n, k, nb, af, m, t, nb, cf, m,
219 $ work, info)
220*
221* Compute |C*Q - C*Q| / |C|
222*
223 CALL sgemm( 'N', 'N', m, n, n, -one, c, m, q, n, one, cf, m )
224 resid = slange( '1', n, m, df, n, rwork )
225 IF( cnorm.GT.zero ) THEN
226 result( 5 ) = resid / (eps*max(1,m)*dnorm)
227 ELSE
228 result( 5 ) = zero
229 END IF
230*
231* Copy C into CF again
232*
233 CALL slacpy( 'Full', m, n, c, m, cf, m )
234*
235* Apply Q to D as D*QT
236*
237 CALL sgemlqt( 'R', 'T', m, n, k, nb, af, m, t, nb, cf, m,
238 $ work, info)
239*
240* Compute |C*QT - C*QT| / |C|
241*
242 CALL sgemm( 'N', 'T', m, n, n, -one, c, m, q, n, one, cf, m )
243 resid = slange( '1', m, n, cf, m, rwork )
244 IF( cnorm.GT.zero ) THEN
245 result( 6 ) = resid / (eps*max(1,m)*dnorm)
246 ELSE
247 result( 6 ) = zero
248 END IF
249*
250* Deallocate all arrays
251*
252 DEALLOCATE ( a, af, q, l, rwork, work, t, c, d, cf, df)
253*
254 RETURN
slarnv
subroutine slarnv(idist, iseed, n, x)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition slarnv.f:97
ssyrk
subroutine ssyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
SSYRK
Definition ssyrk.f:169
sgemm
subroutine sgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
SGEMM
Definition sgemm.f:187

◆ slqt05()

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

SLQT05

Purpose:
!> SQRT05 tests STPLQT and STPMLQT.
!>
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 78 of file slqt05.f.

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

◆ stsqr01()

subroutine stsqr01 ( character tssw,
integer m,
integer n,
integer mb,
integer nb,
real, dimension(6) result )

STSQR01

Purpose:
!>
!> DTSQR01 tests DGEQR , DGELQ, DGEMLQ and DGEMQR.
!>
Parameters
[in]TSSW
!>          TSSW is CHARACTER
!>          'TS' for testing tall skinny QR
!>               and anything else for testing short wide LQ
!>
[in]M
!>          M is INTEGER
!>          Number of rows in test matrix.
!>
[in]N
!>          N is INTEGER
!>          Number of columns in test matrix.
!>
[in]MB
!>          MB is INTEGER
!>          Number of row in row block in test matrix.
!>
[in]NB
!>          NB is INTEGER
!>          Number of columns in column block test matrix.
!>
[out]RESULT
!>          RESULT is REAL array, dimension (6)
!>          Results of each of the six tests below.
!>
!>          RESULT(1) = | A - Q R | or | A - L Q |
!>          RESULT(2) = | I - Q^H Q | or | I - Q Q^H |
!>          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 83 of file stsqr01.f.

84 IMPLICIT NONE
85*
86* -- LAPACK test routine --
87* -- LAPACK is a software package provided by Univ. of Tennessee, --
88* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
89*
90* .. Scalar Arguments ..
91 CHARACTER TSSW
92 INTEGER M, N, MB, NB
93* .. Return values ..
94 REAL RESULT(6)
95*
96* =====================================================================
97*
98* ..
99* .. Local allocatable arrays
100 REAL, ALLOCATABLE :: AF(:,:), Q(:,:),
101 $ R(:,:), RWORK(:), WORK( : ), T(:),
102 $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:), LQ(:,:)
103*
104* .. Parameters ..
105 REAL ONE, ZERO
106 parameter( zero = 0.0, one = 1.0 )
107* ..
108* .. Local Scalars ..
109 LOGICAL TESTZEROS, TS
110 INTEGER INFO, J, K, L, LWORK, TSIZE, MNB
111 REAL ANORM, EPS, RESID, CNORM, DNORM
112* ..
113* .. Local Arrays ..
114 INTEGER ISEED( 4 )
115 REAL TQUERY( 5 ), WORKQUERY( 1 )
116* ..
117* .. External Functions ..
118 REAL SLAMCH, SLANGE, SLANSY
119 LOGICAL LSAME
120 INTEGER ILAENV
121 EXTERNAL slamch, slarnv, slange, slansy, lsame, ilaenv
122* ..
123* .. Intrinsic Functions ..
124 INTRINSIC max, min
125* .. Scalars in Common ..
126 CHARACTER*32 srnamt
127* ..
128* .. Common blocks ..
129 COMMON / srnamc / srnamt
130* ..
131* .. Data statements ..
132 DATA iseed / 1988, 1989, 1990, 1991 /
133*
134* TEST TALL SKINNY OR SHORT WIDE
135*
136 ts = lsame(tssw, 'TS')
137*
138* TEST MATRICES WITH HALF OF MATRIX BEING ZEROS
139*
140 testzeros = .false.
141*
142 eps = slamch( 'Epsilon' )
143 k = min(m,n)
144 l = max(m,n,1)
145 mnb = max( mb, nb)
146 lwork = max(3,l)*mnb
147*
148* Dynamically allocate local arrays
149*
150 ALLOCATE ( a(m,n), af(m,n), q(l,l), r(m,l), rwork(l),
151 $ c(m,n), cf(m,n),
152 $ d(n,m), df(n,m), lq(l,n) )
153*
154* Put random numbers into A and copy to AF
155*
156 DO j=1,n
157 CALL slarnv( 2, iseed, m, a( 1, j ) )
158 END DO
159 IF (testzeros) THEN
160 IF (m.GE.4) THEN
161 DO j=1,n
162 CALL slarnv( 2, iseed, m/2, a( m/4, j ) )
163 END DO
164 END IF
165 END IF
166 CALL slacpy( 'Full', m, n, a, m, af, m )
167*
168 IF (ts) THEN
169*
170* Factor the matrix A in the array AF.
171*
172 CALL sgeqr( m, n, af, m, tquery, -1, workquery, -1, info )
173 tsize = int( tquery( 1 ) )
174 lwork = int( workquery( 1 ) )
175 CALL sgemqr( 'L', 'N', m, m, k, af, m, tquery, tsize, cf, m,
176 $ workquery, -1, info)
177 lwork = max( lwork, int( workquery( 1 ) ) )
178 CALL sgemqr( 'L', 'N', m, n, k, af, m, tquery, tsize, cf, m,
179 $ workquery, -1, info)
180 lwork = max( lwork, int( workquery( 1 ) ) )
181 CALL sgemqr( 'L', 'T', m, n, k, af, m, tquery, tsize, cf, m,
182 $ workquery, -1, info)
183 lwork = max( lwork, int( workquery( 1 ) ) )
184 CALL sgemqr( 'R', 'N', n, m, k, af, m, tquery, tsize, df, n,
185 $ workquery, -1, info)
186 lwork = max( lwork, int( workquery( 1 ) ) )
187 CALL sgemqr( 'R', 'T', n, m, k, af, m, tquery, tsize, df, n,
188 $ workquery, -1, info)
189 lwork = max( lwork, int( workquery( 1 ) ) )
190 ALLOCATE ( t( tsize ) )
191 ALLOCATE ( work( lwork ) )
192 srnamt = 'SGEQR'
193 CALL sgeqr( m, n, af, m, t, tsize, work, lwork, info )
194*
195* Generate the m-by-m matrix Q
196*
197 CALL slaset( 'Full', m, m, zero, one, q, m )
198 srnamt = 'SGEMQR'
199 CALL sgemqr( 'L', 'N', m, m, k, af, m, t, tsize, q, m,
200 $ work, lwork, info )
201*
202* Copy R
203*
204 CALL slaset( 'Full', m, n, zero, zero, r, m )
205 CALL slacpy( 'Upper', m, n, af, m, r, m )
206*
207* Compute |R - Q'*A| / |A| and store in RESULT(1)
208*
209 CALL sgemm( 'T', 'N', m, n, m, -one, q, m, a, m, one, r, m )
210 anorm = slange( '1', m, n, a, m, rwork )
211 resid = slange( '1', m, n, r, m, rwork )
212 IF( anorm.GT.zero ) THEN
213 result( 1 ) = resid / (eps*max(1,m)*anorm)
214 ELSE
215 result( 1 ) = zero
216 END IF
217*
218* Compute |I - Q'*Q| and store in RESULT(2)
219*
220 CALL slaset( 'Full', m, m, zero, one, r, m )
221 CALL ssyrk( 'U', 'C', m, m, -one, q, m, one, r, m )
222 resid = slansy( '1', 'Upper', m, r, m, rwork )
223 result( 2 ) = resid / (eps*max(1,m))
224*
225* Generate random m-by-n matrix C and a copy CF
226*
227 DO j=1,n
228 CALL slarnv( 2, iseed, m, c( 1, j ) )
229 END DO
230 cnorm = slange( '1', m, n, c, m, rwork)
231 CALL slacpy( 'Full', m, n, c, m, cf, m )
232*
233* Apply Q to C as Q*C
234*
235 srnamt = 'DGEQR'
236 CALL sgemqr( 'L', 'N', m, n, k, af, m, t, tsize, cf, m,
237 $ work, lwork, info)
238*
239* Compute |Q*C - Q*C| / |C|
240*
241 CALL sgemm( 'N', 'N', m, n, m, -one, q, m, c, m, one, cf, m )
242 resid = slange( '1', m, n, cf, m, rwork )
243 IF( cnorm.GT.zero ) THEN
244 result( 3 ) = resid / (eps*max(1,m)*cnorm)
245 ELSE
246 result( 3 ) = zero
247 END IF
248*
249* Copy C into CF again
250*
251 CALL slacpy( 'Full', m, n, c, m, cf, m )
252*
253* Apply Q to C as QT*C
254*
255 srnamt = 'DGEQR'
256 CALL sgemqr( 'L', 'T', m, n, k, af, m, t, tsize, cf, m,
257 $ work, lwork, info)
258*
259* Compute |QT*C - QT*C| / |C|
260*
261 CALL sgemm( 'T', 'N', m, n, m, -one, q, m, c, m, one, cf, m )
262 resid = slange( '1', m, n, cf, m, rwork )
263 IF( cnorm.GT.zero ) THEN
264 result( 4 ) = resid / (eps*max(1,m)*cnorm)
265 ELSE
266 result( 4 ) = zero
267 END IF
268*
269* Generate random n-by-m matrix D and a copy DF
270*
271 DO j=1,m
272 CALL slarnv( 2, iseed, n, d( 1, j ) )
273 END DO
274 dnorm = slange( '1', n, m, d, n, rwork)
275 CALL slacpy( 'Full', n, m, d, n, df, n )
276*
277* Apply Q to D as D*Q
278*
279 srnamt = 'DGEQR'
280 CALL sgemqr( 'R', 'N', n, m, k, af, m, t, tsize, df, n,
281 $ work, lwork, info)
282*
283* Compute |D*Q - D*Q| / |D|
284*
285 CALL sgemm( 'N', 'N', n, m, m, -one, d, n, q, m, one, df, n )
286 resid = slange( '1', n, m, df, n, rwork )
287 IF( dnorm.GT.zero ) THEN
288 result( 5 ) = resid / (eps*max(1,m)*dnorm)
289 ELSE
290 result( 5 ) = zero
291 END IF
292*
293* Copy D into DF again
294*
295 CALL slacpy( 'Full', n, m, d, n, df, n )
296*
297* Apply Q to D as D*QT
298*
299 CALL sgemqr( 'R', 'T', n, m, k, af, m, t, tsize, df, n,
300 $ work, lwork, info)
301*
302* Compute |D*QT - D*QT| / |D|
303*
304 CALL sgemm( 'N', 'T', n, m, m, -one, d, n, q, m, one, df, n )
305 resid = slange( '1', n, m, df, n, rwork )
306 IF( cnorm.GT.zero ) THEN
307 result( 6 ) = resid / (eps*max(1,m)*dnorm)
308 ELSE
309 result( 6 ) = zero
310 END IF
311*
312* Short and wide
313*
314 ELSE
315 CALL sgelq( m, n, af, m, tquery, -1, workquery, -1, info )
316 tsize = int( tquery( 1 ) )
317 lwork = int( workquery( 1 ))
318 CALL sgemlq( 'R', 'N', n, n, k, af, m, tquery, tsize, q, n,
319 $ workquery, -1, info )
320 lwork = max( lwork, int( workquery( 1 ) ) )
321 CALL sgemlq( 'L', 'N', n, m, k, af, m, tquery, tsize, df, n,
322 $ workquery, -1, info)
323 lwork = max( lwork, int( workquery( 1 ) ) )
324 CALL sgemlq( 'L', 'T', n, m, k, af, m, tquery, tsize, df, n,
325 $ workquery, -1, info)
326 lwork = max( lwork, int( workquery( 1 ) ) )
327 CALL sgemlq( 'R', 'N', m, n, k, af, m, tquery, tsize, cf, m,
328 $ workquery, -1, info)
329 lwork = max( lwork, int( workquery( 1 ) ) )
330 CALL sgemlq( 'R', 'T', m, n, k, af, m, tquery, tsize, cf, m,
331 $ workquery, -1, info)
332 lwork = max( lwork, int( workquery( 1 ) ) )
333 ALLOCATE ( t( tsize ) )
334 ALLOCATE ( work( lwork ) )
335 srnamt = 'SGELQ'
336 CALL sgelq( m, n, af, m, t, tsize, work, lwork, info )
337*
338*
339* Generate the n-by-n matrix Q
340*
341 CALL slaset( 'Full', n, n, zero, one, q, n )
342 srnamt = 'SGEMLQ'
343 CALL sgemlq( 'R', 'N', n, n, k, af, m, t, tsize, q, n,
344 $ work, lwork, info )
345*
346* Copy R
347*
348 CALL slaset( 'Full', m, n, zero, zero, lq, l )
349 CALL slacpy( 'Lower', m, n, af, m, lq, l )
350*
351* Compute |L - A*Q'| / |A| and store in RESULT(1)
352*
353 CALL sgemm( 'N', 'T', m, n, n, -one, a, m, q, n, one, lq, l )
354 anorm = slange( '1', m, n, a, m, rwork )
355 resid = slange( '1', m, n, lq, l, rwork )
356 IF( anorm.GT.zero ) THEN
357 result( 1 ) = resid / (eps*max(1,n)*anorm)
358 ELSE
359 result( 1 ) = zero
360 END IF
361*
362* Compute |I - Q'*Q| and store in RESULT(2)
363*
364 CALL slaset( 'Full', n, n, zero, one, lq, l )
365 CALL ssyrk( 'U', 'C', n, n, -one, q, n, one, lq, l )
366 resid = slansy( '1', 'Upper', n, lq, l, rwork )
367 result( 2 ) = resid / (eps*max(1,n))
368*
369* Generate random m-by-n matrix C and a copy CF
370*
371 DO j=1,m
372 CALL slarnv( 2, iseed, n, d( 1, j ) )
373 END DO
374 dnorm = slange( '1', n, m, d, n, rwork)
375 CALL slacpy( 'Full', n, m, d, n, df, n )
376*
377* Apply Q to C as Q*C
378*
379 CALL sgemlq( 'L', 'N', n, m, k, af, m, t, tsize, df, n,
380 $ work, lwork, info)
381*
382* Compute |Q*D - Q*D| / |D|
383*
384 CALL sgemm( 'N', 'N', n, m, n, -one, q, n, d, n, one, df, n )
385 resid = slange( '1', n, m, df, n, rwork )
386 IF( dnorm.GT.zero ) THEN
387 result( 3 ) = resid / (eps*max(1,n)*dnorm)
388 ELSE
389 result( 3 ) = zero
390 END IF
391*
392* Copy D into DF again
393*
394 CALL slacpy( 'Full', n, m, d, n, df, n )
395*
396* Apply Q to D as QT*D
397*
398 CALL sgemlq( 'L', 'T', n, m, k, af, m, t, tsize, df, n,
399 $ work, lwork, info)
400*
401* Compute |QT*D - QT*D| / |D|
402*
403 CALL sgemm( 'T', 'N', n, m, n, -one, q, n, d, n, one, df, n )
404 resid = slange( '1', n, m, df, n, rwork )
405 IF( dnorm.GT.zero ) THEN
406 result( 4 ) = resid / (eps*max(1,n)*dnorm)
407 ELSE
408 result( 4 ) = zero
409 END IF
410*
411* Generate random n-by-m matrix D and a copy DF
412*
413 DO j=1,n
414 CALL slarnv( 2, iseed, m, c( 1, j ) )
415 END DO
416 cnorm = slange( '1', m, n, c, m, rwork)
417 CALL slacpy( 'Full', m, n, c, m, cf, m )
418*
419* Apply Q to C as C*Q
420*
421 CALL sgemlq( 'R', 'N', m, n, k, af, m, t, tsize, cf, m,
422 $ work, lwork, info)
423*
424* Compute |C*Q - C*Q| / |C|
425*
426 CALL sgemm( 'N', 'N', m, n, n, -one, c, m, q, n, one, cf, m )
427 resid = slange( '1', n, m, df, n, rwork )
428 IF( cnorm.GT.zero ) THEN
429 result( 5 ) = resid / (eps*max(1,n)*cnorm)
430 ELSE
431 result( 5 ) = zero
432 END IF
433*
434* Copy C into CF again
435*
436 CALL slacpy( 'Full', m, n, c, m, cf, m )
437*
438* Apply Q to D as D*QT
439*
440 CALL sgemlq( 'R', 'T', m, n, k, af, m, t, tsize, cf, m,
441 $ work, lwork, info)
442*
443* Compute |C*QT - C*QT| / |C|
444*
445 CALL sgemm( 'N', 'T', m, n, n, -one, c, m, q, n, one, cf, m )
446 resid = slange( '1', m, n, cf, m, rwork )
447 IF( cnorm.GT.zero ) THEN
448 result( 6 ) = resid / (eps*max(1,n)*cnorm)
449 ELSE
450 result( 6 ) = zero
451 END IF
452*
453 END IF
454*
455* Deallocate all arrays
456*
457 DEALLOCATE ( a, af, q, r, rwork, work, t, c, d, cf, df)
458*
459 RETURN

◆ zchklqt()

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

ZCHKLQT

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

Definition at line 100 of file zchklqt.f.

102 IMPLICIT NONE
103*
104* -- LAPACK test routine --
105* -- LAPACK is a software package provided by Univ. of Tennessee, --
106* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
107*
108* .. Scalar Arguments ..
109 LOGICAL TSTERR
110 INTEGER NM, NN, NNB, NOUT
111 DOUBLE PRECISION THRESH
112* ..
113* .. Array Arguments ..
114 INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
115* ..
116*
117* =====================================================================
118*
119* .. Parameters ..
120 INTEGER NTESTS
121 parameter( ntests = 6 )
122* ..
123* .. Local Scalars ..
124 CHARACTER*3 PATH
125 INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN,
126 $ MINMN
127*
128* .. Local Arrays ..
129 DOUBLE PRECISION RESULT( NTESTS )
130* ..
131* .. External Subroutines ..
132 EXTERNAL alaerh, alahd, alasum, zerrlqt, zlqt04
133* ..
134* .. Scalars in Common ..
135 LOGICAL LERR, OK
136 CHARACTER*32 SRNAMT
137 INTEGER INFOT, NUNIT
138* ..
139* .. Common blocks ..
140 COMMON / infoc / infot, nunit, ok, lerr
141 COMMON / srnamc / srnamt
142* ..
143* .. Executable Statements ..
144*
145* Initialize constants
146*
147 path( 1: 1 ) = 'Z'
148 path( 2: 3 ) = 'TQ'
149 nrun = 0
150 nfail = 0
151 nerrs = 0
152*
153* Test the error exits
154*
155 IF( tsterr ) CALL zerrlqt( 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 ZGELQT and ZUNMLQT
175*
176 IF( (nb.LE.minmn).AND.(nb.GT.0) ) THEN
177 CALL zlqt04( 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 ZCHKLQT
206*
zlqt04
subroutine zlqt04(m, n, nb, result)
DLQT04
Definition zlqt04.f:73
zerrlqt
subroutine zerrlqt(path, nunit)
ZERLQT
Definition zerrlqt.f:55

◆ zchklqtp()

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

ZCHKLQTP

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

Definition at line 100 of file zchklqtp.f.

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

◆ zchktsqr()

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

DCHKQRT

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

Definition at line 100 of file zchktsqr.f.

102 IMPLICIT NONE
103*
104* -- LAPACK test routine --
105* -- LAPACK is a software package provided by Univ. of Tennessee, --
106* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
107*
108* .. Scalar Arguments ..
109 LOGICAL TSTERR
110 INTEGER NM, NN, NNB, NOUT
111 DOUBLE PRECISION THRESH
112* ..
113* .. Array Arguments ..
114 INTEGER MVAL( * ), NBVAL( * ), NVAL( * )
115* ..
116*
117* =====================================================================
118*
119* .. Parameters ..
120 INTEGER NTESTS
121 parameter( ntests = 6 )
122* ..
123* .. Local Scalars ..
124 CHARACTER*3 PATH
125 INTEGER I, J, K, T, M, N, NB, NFAIL, NERRS, NRUN, INB,
126 $ MINMN, MB, IMB
127*
128* .. Local Arrays ..
129 DOUBLE PRECISION RESULT( NTESTS )
130* ..
131* .. External Subroutines ..
132 EXTERNAL alaerh, alahd, alasum, zerrtsqr,
133 $ ztsqr01, xlaenv
134* ..
135* .. Intrinsic Functions ..
136 INTRINSIC max, min
137* ..
138* .. Scalars in Common ..
139 LOGICAL LERR, OK
140 CHARACTER*32 SRNAMT
141 INTEGER INFOT, NUNIT
142* ..
143* .. Common blocks ..
144 COMMON / infoc / infot, nunit, ok, lerr
145 COMMON / srnamc / srnamt
146* ..
147* .. Executable Statements ..
148*
149* Initialize constants
150*
151 path( 1: 1 ) = 'Z'
152 path( 2: 3 ) = 'TS'
153 nrun = 0
154 nfail = 0
155 nerrs = 0
156*
157* Test the error exits
158*
159 CALL xlaenv( 1, 0 )
160 CALL xlaenv( 2, 0 )
161 IF( tsterr ) CALL zerrtsqr( path, nout )
162 infot = 0
163*
164* Do for each value of M in MVAL.
165*
166 DO i = 1, nm
167 m = mval( i )
168*
169* Do for each value of N in NVAL.
170*
171 DO j = 1, nn
172 n = nval( j )
173 IF (min(m,n).NE.0) THEN
174 DO inb = 1, nnb
175 mb = nbval( inb )
176 CALL xlaenv( 1, mb )
177 DO imb = 1, nnb
178 nb = nbval( imb )
179 CALL xlaenv( 2, nb )
180*
181* Test ZGEQR and ZGEMQR
182*
183 CALL ztsqr01( 'TS', m, n, mb, nb, result )
184*
185* Print information about the tests that did not
186* pass the threshold.
187*
188 DO t = 1, ntests
189 IF( result( t ).GE.thresh ) THEN
190 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
191 $ CALL alahd( nout, path )
192 WRITE( nout, fmt = 9999 )m, n, mb, nb,
193 $ t, result( t )
194 nfail = nfail + 1
195 END IF
196 END DO
197 nrun = nrun + ntests
198 END DO
199 END DO
200 END IF
201 END DO
202 END DO
203*
204* Do for each value of M in MVAL.
205*
206 DO i = 1, nm
207 m = mval( i )
208*
209* Do for each value of N in NVAL.
210*
211 DO j = 1, nn
212 n = nval( j )
213 IF (min(m,n).NE.0) THEN
214 DO inb = 1, nnb
215 mb = nbval( inb )
216 CALL xlaenv( 1, mb )
217 DO imb = 1, nnb
218 nb = nbval( imb )
219 CALL xlaenv( 2, nb )
220*
221* Test ZGELQ and ZGEMLQ
222*
223 CALL ztsqr01( 'SW', m, n, mb, nb, result )
224*
225* Print information about the tests that did not
226* pass the threshold.
227*
228 DO t = 1, ntests
229 IF( result( t ).GE.thresh ) THEN
230 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
231 $ CALL alahd( nout, path )
232 WRITE( nout, fmt = 9998 )m, n, mb, nb,
233 $ t, result( t )
234 nfail = nfail + 1
235 END IF
236 END DO
237 nrun = nrun + ntests
238 END DO
239 END DO
240 END IF
241 END DO
242 END DO
243*
244* Print a summary of the results.
245*
246 CALL alasum( path, nout, nfail, nrun, nerrs )
247*
248 9999 FORMAT( 'TS: M=', i5, ', N=', i5, ', MB=', i5,
249 $ ', NB=', i5,' test(', i2, ')=', g12.5 )
250 9998 FORMAT( 'SW: M=', i5, ', N=', i5, ', MB=', i5,
251 $ ', NB=', i5,' test(', i2, ')=', g12.5 )
252 RETURN
253*
254* End of ZCHKTSQR
255*
zerrtsqr
subroutine zerrtsqr(path, nunit)
ZERRTSQR
Definition zerrtsqr.f:55
ztsqr01
subroutine ztsqr01(tssw, m, n, mb, nb, result)
ZTSQR01
Definition ztsqr01.f:82

◆ zerrlqt()

subroutine zerrlqt ( character*3 path,
integer nunit )

ZERLQT

Purpose:
!>
!> ZERRLQT tests the error exits for the COMPLEX routines
!> that use the LQT 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 zerrlqt.f.

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

◆ zerrlqtp()

subroutine zerrlqtp ( character*3 path,
integer nunit )

ZERRLQTP

Purpose:
!>
!> ZERRLQTP tests the error exits for the complex routines
!> that use the LQT 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 zerrlqtp.f.

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

◆ zerrtsqr()

subroutine zerrtsqr ( character*3 path,
integer nunit )

ZERRTSQR

Purpose:
!>
!> ZERRTSQR tests the error exits for the ZOUBLE PRECISION routines
!> that use the TSQR 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 Zenver
NAG Ltd.

Definition at line 54 of file zerrtsqr.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, MB, NB
74* ..
75* .. Local Arrays ..
76 COMPLEX*16 A( NMAX, NMAX ), T( NMAX, NMAX ), W( NMAX ),
77 $ C( NMAX, NMAX ), TAU(NMAX)
78* ..
79* .. External Subroutines ..
80 EXTERNAL alaesm, chkxer, zgeqr,
81 $ zgemqr, zgelq, zgemlq
82* ..
83* .. Scalars in Common ..
84 LOGICAL LERR, OK
85 CHARACTER*32 SRNAMT
86 INTEGER INFOT, NOUT
87* ..
88* .. Common blocks ..
89 COMMON / infoc / infot, nout, ok, lerr
90 COMMON / srnamc / srnamt
91* ..
92* .. Intrinsic Functions ..
93 INTRINSIC dble
94* ..
95* .. Executable Statements ..
96*
97 nout = nunit
98 WRITE( nout, fmt = * )
99*
100* Set the variables to innocuous values.
101*
102 DO j = 1, nmax
103 DO i = 1, nmax
104 a( i, j ) = 1.d0 / dble( i+j )
105 c( i, j ) = 1.d0 / dble( i+j )
106 t( i, j ) = 1.d0 / dble( i+j )
107 END DO
108 w( j ) = 0.d0
109 END DO
110 ok = .true.
111*
112* Error exits for TS factorization
113*
114* ZGEQR
115*
116 srnamt = 'ZGEQR'
117 infot = 1
118 CALL zgeqr( -1, 0, a, 1, tau, 1, w, 1, info )
119 CALL chkxer( 'ZGEQR', infot, nout, lerr, ok )
120 infot = 2
121 CALL zgeqr( 0, -1, a, 1, tau, 1, w, 1, info )
122 CALL chkxer( 'ZGEQR', infot, nout, lerr, ok )
123 infot = 4
124 CALL zgeqr( 1, 1, a, 0, tau, 1, w, 1, info )
125 CALL chkxer( 'ZGEQR', infot, nout, lerr, ok )
126 infot = 6
127 CALL zgeqr( 3, 2, a, 3, tau, 1, w, 1, info )
128 CALL chkxer( 'ZGEQR', infot, nout, lerr, ok )
129 infot = 8
130 CALL zgeqr( 3, 2, a, 3, tau, 8, w, 0, info )
131 CALL chkxer( 'ZGEQR', infot, nout, lerr, ok )
132*
133* ZLATSQR
134*
135 mb = 1
136 nb = 1
137 srnamt = 'ZLATSQR'
138 infot = 1
139 CALL zlatsqr( -1, 0, mb, nb, a, 1, tau, 1, w, 1, info )
140 CALL chkxer( 'ZLATSQR', infot, nout, lerr, ok )
141 infot = 2
142 CALL zlatsqr( 1, 2, mb, nb, a, 1, tau, 1, w, 1, info )
143 CALL chkxer( 'ZLATSQR', infot, nout, lerr, ok )
144 CALL zlatsqr( 0, -1, mb, nb, a, 1, tau, 1, w, 1, info )
145 CALL chkxer( 'ZLATSQR', infot, nout, lerr, ok )
146 infot = 3
147 CALL zlatsqr( 2, 1, -1, nb, a, 2, tau, 1, w, 1, info )
148 CALL chkxer( 'ZLATSQR', infot, nout, lerr, ok )
149 infot = 4
150 CALL zlatsqr( 2, 1, mb, 2, a, 2, tau, 1, w, 1, info )
151 CALL chkxer( 'ZLATSQR', infot, nout, lerr, ok )
152 infot = 6
153 CALL zlatsqr( 2, 1, mb, nb, a, 1, tau, 1, w, 1, info )
154 CALL chkxer( 'ZLATSQR', infot, nout, lerr, ok )
155 infot = 8
156 CALL zlatsqr( 2, 1, mb, nb, a, 2, tau, 0, w, 1, info )
157 CALL chkxer( 'ZLATSQR', infot, nout, lerr, ok )
158 infot = 10
159 CALL zlatsqr( 2, 1, mb, nb, a, 2, tau, 2, w, 0, info )
160 CALL chkxer( 'ZLATSQR', infot, nout, lerr, ok )
161*
162* ZGEMQR
163*
164 tau(1)=1
165 tau(2)=1
166 srnamt = 'ZGEMQR'
167 nb=1
168 infot = 1
169 CALL zgemqr( '/', 'N', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
170 CALL chkxer( 'ZGEMQR', infot, nout, lerr, ok )
171 infot = 2
172 CALL zgemqr( 'L', '/', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
173 CALL chkxer( 'ZGEMQR', infot, nout, lerr, ok )
174 infot = 3
175 CALL zgemqr( 'L', 'N', -1, 0, 0, a, 1, tau, 1, c, 1, w,1,info)
176 CALL chkxer( 'ZGEMQR', infot, nout, lerr, ok )
177 infot = 4
178 CALL zgemqr( 'L', 'N', 0, -1, 0, a, 1, tau, 1, c, 1, w,1,info)
179 CALL chkxer( 'ZGEMQR', infot, nout, lerr, ok )
180 infot = 5
181 CALL zgemqr( 'L', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
182 CALL chkxer( 'ZGEMQR', infot, nout, lerr, ok )
183 infot = 5
184 CALL zgemqr( 'R', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
185 CALL chkxer( 'ZGEMQR', infot, nout, lerr, ok )
186 infot = 7
187 CALL zgemqr( 'L', 'N', 2, 1, 0, a, 0, tau, 1, c, 1, w, 1,info)
188 CALL chkxer( 'ZGEMQR', infot, nout, lerr, ok )
189 infot = 9
190 CALL zgemqr( 'R', 'N', 2, 2, 1, a, 2, tau, 0, c, 1, w, 1,info)
191 CALL chkxer( 'ZGEMQR', infot, nout, lerr, ok )
192 infot = 9
193 CALL zgemqr( 'L', 'N', 2, 2, 1, a, 2, tau, 0, c, 1, w, 1,info)
194 CALL chkxer( 'ZGEMQR', infot, nout, lerr, ok )
195 infot = 11
196 CALL zgemqr( 'L', 'N', 2, 1, 1, a, 2, tau, 6, c, 0, w, 1,info)
197 CALL chkxer( 'ZGEMQR', infot, nout, lerr, ok )
198 infot = 13
199 CALL zgemqr( 'L', 'N', 2, 2, 1, a, 2, tau, 6, c, 2, w, 0,info)
200 CALL chkxer( 'ZGEMQR', infot, nout, lerr, ok )
201*
202* ZGELQ
203*
204 srnamt = 'ZGELQ'
205 infot = 1
206 CALL zgelq( -1, 0, a, 1, tau, 1, w, 1, info )
207 CALL chkxer( 'ZGELQ', infot, nout, lerr, ok )
208 infot = 2
209 CALL zgelq( 0, -1, a, 1, tau, 1, w, 1, info )
210 CALL chkxer( 'ZGELQ', infot, nout, lerr, ok )
211 infot = 4
212 CALL zgelq( 1, 1, a, 0, tau, 1, w, 1, info )
213 CALL chkxer( 'ZGELQ', infot, nout, lerr, ok )
214 infot = 6
215 CALL zgelq( 2, 3, a, 3, tau, 1, w, 1, info )
216 CALL chkxer( 'ZGELQ', infot, nout, lerr, ok )
217 infot = 8
218 CALL zgelq( 2, 3, a, 3, tau, 8, w, 0, info )
219 CALL chkxer( 'ZGELQ', infot, nout, lerr, ok )
220*
221* ZLASWLQ
222*
223 mb = 1
224 nb = 1
225 srnamt = 'ZLASWLQ'
226 infot = 1
227 CALL zlaswlq( -1, 0, mb, nb, a, 1, tau, 1, w, 1, info )
228 CALL chkxer( 'ZLASWLQ', infot, nout, lerr, ok )
229 infot = 2
230 CALL zlaswlq( 2, 1, mb, nb, a, 1, tau, 1, w, 1, info )
231 CALL chkxer( 'ZLASWLQ', infot, nout, lerr, ok )
232 CALL zlaswlq( 0, -1, mb, nb, a, 1, tau, 1, w, 1, info )
233 CALL chkxer( 'ZLASWLQ', infot, nout, lerr, ok )
234 infot = 3
235 CALL zlaswlq( 1, 2, -1, nb, a, 1, tau, 1, w, 1, info )
236 CALL chkxer( 'ZLASWLQ', infot, nout, lerr, ok )
237 CALL zlaswlq( 1, 1, 2, nb, a, 1, tau, 1, w, 1, info )
238 CALL chkxer( 'ZLASWLQ', infot, nout, lerr, ok )
239 infot = 4
240 CALL zlaswlq( 1, 2, mb, -1, a, 1, tau, 1, w, 1, info )
241 CALL chkxer( 'ZLASWLQ', infot, nout, lerr, ok )
242 infot = 6
243 CALL zlaswlq( 1, 2, mb, nb, a, 0, tau, 1, w, 1, info )
244 CALL chkxer( 'ZLASWLQ', infot, nout, lerr, ok )
245 infot = 8
246 CALL zlaswlq( 1, 2, mb, nb, a, 1, tau, 0, w, 1, info )
247 CALL chkxer( 'ZLASWLQ', infot, nout, lerr, ok )
248 infot = 10
249 CALL zlaswlq( 1, 2, mb, nb, a, 1, tau, 1, w, 0, info )
250 CALL chkxer( 'ZLASWLQ', infot, nout, lerr, ok )
251*
252* ZGEMLQ
253*
254 tau(1)=1
255 tau(2)=1
256 srnamt = 'ZGEMLQ'
257 nb=1
258 infot = 1
259 CALL zgemlq( '/', 'N', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
260 CALL chkxer( 'ZGEMLQ', infot, nout, lerr, ok )
261 infot = 2
262 CALL zgemlq( 'L', '/', 0, 0, 0, a, 1, tau, 1, c, 1, w, 1,info)
263 CALL chkxer( 'ZGEMLQ', infot, nout, lerr, ok )
264 infot = 3
265 CALL zgemlq( 'L', 'N', -1, 0, 0, a, 1, tau, 1, c, 1, w,1,info)
266 CALL chkxer( 'ZGEMLQ', infot, nout, lerr, ok )
267 infot = 4
268 CALL zgemlq( 'L', 'N', 0, -1, 0, a, 1, tau, 1, c, 1, w,1,info)
269 CALL chkxer( 'ZGEMLQ', infot, nout, lerr, ok )
270 infot = 5
271 CALL zgemlq( 'L', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
272 CALL chkxer( 'ZGEMLQ', infot, nout, lerr, ok )
273 infot = 5
274 CALL zgemlq( 'R', 'N', 0, 0, -1, a, 1, tau, 1, c, 1, w,1,info)
275 CALL chkxer( 'ZGEMLQ', infot, nout, lerr, ok )
276 infot = 7
277 CALL zgemlq( 'L', 'N', 1, 2, 0, a, 0, tau, 1, c, 1, w, 1,info)
278 CALL chkxer( 'ZGEMLQ', infot, nout, lerr, ok )
279 infot = 9
280 CALL zgemlq( 'R', 'N', 2, 2, 1, a, 1, tau, 0, c, 1, w, 1,info)
281 CALL chkxer( 'ZGEMLQ', infot, nout, lerr, ok )
282 infot = 9
283 CALL zgemlq( 'L', 'N', 2, 2, 1, a, 1, tau, 0, c, 1, w, 1,info)
284 CALL chkxer( 'ZGEMLQ', infot, nout, lerr, ok )
285 infot = 11
286 CALL zgemlq( 'L', 'N', 1, 2, 1, a, 1, tau, 6, c, 0, w, 1,info)
287 CALL chkxer( 'ZGEMLQ', infot, nout, lerr, ok )
288 infot = 13
289 CALL zgemlq( 'L', 'N', 2, 2, 1, a, 2, tau, 6, c, 2, w, 0,info)
290 CALL chkxer( 'ZGEMLQ', infot, nout, lerr, ok )
291*
292* Print a summary line.
293*
294 CALL alaesm( path, ok, nout )
295*
296 RETURN
297*
298* End of ZERRTSQR
299*
zgelq
subroutine zgelq(m, n, a, lda, t, tsize, work, lwork, info)
ZGELQ
Definition zgelq.f:172
zgemlq
subroutine zgemlq(side, trans, m, n, k, a, lda, t, tsize, c, ldc, work, lwork, info)
ZGEMLQ
Definition zgemlq.f:169
zgemqr
subroutine zgemqr(side, trans, m, n, k, a, lda, t, tsize, c, ldc, work, lwork, info)
ZGEMQR
Definition zgemqr.f:172
zgeqr
subroutine zgeqr(m, n, a, lda, t, tsize, work, lwork, info)
ZGEQR
Definition zgeqr.f:174
zlaswlq
subroutine zlaswlq(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
ZLASWLQ
Definition zlaswlq.f:164
zlatsqr
subroutine zlatsqr(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
ZLATSQR
Definition zlatsqr.f:166

◆ zlqt04()

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

DLQT04

Purpose:
!>
!> ZLQT04 tests ZGELQT and ZUNMLQT.
!>
Parameters
[in]M
!>          M is INTEGER
!>          Number of rows in test matrix.
!>
[in]N
!>          N is INTEGER
!>          Number of columns in test matrix.
!>
[in]NB
!>          NB is INTEGER
!>          Block size of test matrix.  NB <= Min(M,N).
!>
[out]RESULT
!>          RESULT is DOUBLE PRECISION array, dimension (6)
!>          Results of each of the six tests below.
!>
!>          RESULT(1) = | A - L Q |
!>          RESULT(2) = | I - Q Q^H |
!>          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 zlqt04.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
81* .. Return values ..
82 DOUBLE PRECISION RESULT(6)
83*
84* =====================================================================
85*
86* ..
87* .. Local allocatable arrays
88 COMPLEX*16, ALLOCATABLE :: AF(:,:), Q(:,:),
89 $ L(:,:), RWORK(:), WORK( : ), T(:,:),
90 $ CF(:,:), DF(:,:), A(:,:), C(:,:), D(:,:)
91*
92* .. Parameters ..
93 DOUBLE PRECISION ZERO
94 COMPLEX*16 ONE, CZERO
95 parameter( zero = 0.0)
96 parameter( one = (1.0,0.0), czero=(0.0,0.0) )
97* ..
98* .. Local Scalars ..
99 INTEGER INFO, J, K, LL, LWORK, LDT
100 DOUBLE PRECISION ANORM, EPS, RESID, CNORM, DNORM
101* ..
102* .. Local Arrays ..
103 INTEGER ISEED( 4 )
104* ..
105* .. External Functions ..
106 DOUBLE PRECISION DLAMCH
107 DOUBLE PRECISION ZLANGE, ZLANSY
108 LOGICAL LSAME
109 EXTERNAL dlamch, zlange, zlansy, lsame
110* ..
111* .. Intrinsic Functions ..
112 INTRINSIC max, min
113* ..
114* .. Data statements ..
115 DATA iseed / 1988, 1989, 1990, 1991 /
116*
117 eps = dlamch( 'Epsilon' )
118 k = min(m,n)
119 ll = max(m,n)
120 lwork = max(2,ll)*max(2,ll)*nb
121*
122* Dynamically allocate local arrays
123*
124 ALLOCATE ( a(m,n), af(m,n), q(n,n), l(ll,n), rwork(ll),
125 $ work(lwork), t(nb,n), c(m,n), cf(m,n),
126 $ d(n,m), df(n,m) )
127*
128* Put random numbers into A and copy to AF
129*
130 ldt=nb
131 DO j=1,n
132 CALL zlarnv( 2, iseed, m, a( 1, j ) )
133 END DO
134 CALL zlacpy( 'Full', m, n, a, m, af, m )
135*
136* Factor the matrix A in the array AF.
137*
138 CALL zgelqt( m, n, nb, af, m, t, ldt, work, info )
139*
140* Generate the n-by-n matrix Q
141*
142 CALL zlaset( 'Full', n, n, czero, one, q, n )
143 CALL zgemlqt( 'R', 'N', n, n, k, nb, af, m, t, ldt, q, n,
144 $ work, info )
145*
146* Copy L
147*
148 CALL zlaset( 'Full', ll, n, czero, czero, l, ll )
149 CALL zlacpy( 'Lower', m, n, af, m, l, ll )
150*
151* Compute |L - A*Q'| / |A| and store in RESULT(1)
152*
153 CALL zgemm( 'N', 'C', m, n, n, -one, a, m, q, n, one, l, ll )
154 anorm = zlange( '1', m, n, a, m, rwork )
155 resid = zlange( '1', m, n, l, ll, rwork )
156 IF( anorm.GT.zero ) THEN
157 result( 1 ) = resid / (eps*max(1,m)*anorm)
158 ELSE
159 result( 1 ) = zero
160 END IF
161*
162* Compute |I - Q'*Q| and store in RESULT(2)
163*
164 CALL zlaset( 'Full', n, n, czero, one, l, ll )
165 CALL zherk( 'U', 'C', n, n, dreal(-one), q, n, dreal(one), l, ll)
166 resid = zlansy( '1', 'Upper', n, l, ll, rwork )
167 result( 2 ) = resid / (eps*max(1,n))
168*
169* Generate random m-by-n matrix C and a copy CF
170*
171 DO j=1,m
172 CALL zlarnv( 2, iseed, n, d( 1, j ) )
173 END DO
174 dnorm = zlange( '1', n, m, d, n, rwork)
175 CALL zlacpy( 'Full', n, m, d, n, df, n )
176*
177* Apply Q to C as Q*C
178*
179 CALL zgemlqt( 'L', 'N', n, m, k, nb, af, m, t, nb, df, n,
180 $ work, info)
181*
182* Compute |Q*D - Q*D| / |D|
183*
184 CALL zgemm( 'N', 'N', n, m, n, -one, q, n, d, n, one, df, n )
185 resid = zlange( '1', n, m, df, n, rwork )
186 IF( dnorm.GT.zero ) THEN
187 result( 3 ) = resid / (eps*max(1,m)*dnorm)
188 ELSE
189 result( 3 ) = zero
190 END IF
191*
192* Copy D into DF again
193*
194 CALL zlacpy( 'Full', n, m, d, n, df, n )
195*
196* Apply Q to D as QT*D
197*
198 CALL zgemlqt( 'L', 'C', n, m, k, nb, af, m, t, nb, df, n,
199 $ work, info)
200*
201* Compute |QT*D - QT*D| / |D|
202*
203 CALL zgemm( 'C', 'N', n, m, n, -one, q, n, d, n, one, df, n )
204 resid = zlange( '1', n, m, df, n, rwork )
205 IF( dnorm.GT.zero ) THEN
206 result( 4 ) = resid / (eps*max(1,m)*dnorm)
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,n
214 CALL zlarnv( 2, iseed, m, c( 1, j ) )
215 END DO
216 cnorm = zlange( '1', m, n, c, m, rwork)
217 CALL zlacpy( 'Full', m, n, c, m, cf, m )
218*
219* Apply Q to C as C*Q
220*
221 CALL zgemlqt( 'R', 'N', m, n, k, nb, af, m, t, nb, cf, m,
222 $ work, info)
223*
224* Compute |C*Q - C*Q| / |C|
225*
226 CALL zgemm( 'N', 'N', m, n, n, -one, c, m, q, n, one, cf, m )
227 resid = zlange( '1', n, m, df, n, rwork )
228 IF( cnorm.GT.zero ) THEN
229 result( 5 ) = resid / (eps*max(1,m)*dnorm)
230 ELSE
231 result( 5 ) = zero
232 END IF
233*
234* Copy C into CF again
235*
236 CALL zlacpy( 'Full', m, n, c, m, cf, m )
237*
238* Apply Q to D as D*QT
239*
240 CALL zgemlqt( 'R', 'C', m, n, k, nb, af, m, t, nb, cf, m,
241 $ work, info)
242*
243* Compute |C*QT - C*QT| / |C|
244*
245 CALL zgemm( 'N', 'C', m, n, n, -one, c, m, q, n, one, cf, m )
246 resid = zlange( '1', m, n, cf, m, 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, l, rwork, work, t, c, d, cf, df)
256*
257 RETURN
zlange
double precision function zlange(norm, m, n, a, lda, work)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition zlange.f:115
zlacpy
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
Definition zlacpy.f:103
zlarnv
subroutine zlarnv(idist, iseed, n, x)
ZLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition zlarnv.f:99
zlaset
subroutine zlaset(uplo, m, n, alpha, beta, a, lda)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition zlaset.f:106
zlansy
double precision function zlansy(norm, uplo, n, a, lda, work)
ZLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition zlansy.f:123
zherk
subroutine zherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
ZHERK
Definition zherk.f:173
zgemm
subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
ZGEMM
Definition zgemm.f:187

◆ zlqt05()

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

ZLQT05

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

Definition at line 79 of file zlqt05.f.

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