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

Functions

program schkaa
 SCHKAA
subroutine schkeq (thresh, nout)
 SCHKEQ
subroutine schkgb (dotype, nm, mval, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, a, la, afac, lafac, b, x, xact, work, rwork, iwork, nout)
 SCHKGB
subroutine schkge (dotype, nm, mval, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 SCHKGE
subroutine schkgt (dotype, nn, nval, nns, nsval, thresh, tsterr, a, af, b, x, xact, work, rwork, iwork, nout)
 SCHKGT
subroutine schklq (dotype, nm, mval, nn, nval, nnb, nbval, nxval, nrhs, thresh, tsterr, nmax, a, af, aq, al, ac, b, x, xact, tau, work, rwork, nout)
 SCHKLQ
subroutine schkorhr_col (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 SCHKORHR_COL
subroutine schkpb (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 SCHKPB
subroutine schkpo (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 SCHKPO
subroutine schkpp (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 SCHKPP
subroutine schkps (dotype, nn, nval, nnb, nbval, nrank, rankval, thresh, tsterr, nmax, a, afac, perm, piv, work, rwork, nout)
 SCHKPS
subroutine schkpt (dotype, nn, nval, nns, nsval, thresh, tsterr, a, d, e, b, x, xact, work, rwork, nout)
 SCHKPT
subroutine schkq3 (dotype, nm, mval, nn, nval, nnb, nbval, nxval, thresh, a, copya, s, tau, work, iwork, nout)
 SCHKQ3
subroutine schkql (dotype, nm, mval, nn, nval, nnb, nbval, nxval, nrhs, thresh, tsterr, nmax, a, af, aq, al, ac, b, x, xact, tau, work, rwork, nout)
 SCHKQL
subroutine schkqr (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)
 SCHKQR
subroutine schkqrt (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 SCHKQRT
subroutine schkqrtp (thresh, tsterr, nm, mval, nn, nval, nnb, nbval, nout)
 SCHKQRTP
program schkrfp
 SCHKRFP
subroutine schkrq (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)
 SCHKRQ
subroutine schksp (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 SCHKSP
subroutine schksy (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 SCHKSY
subroutine schksy_rook (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 SCHKSY_ROOK
subroutine schktb (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, ab, ainv, b, x, xact, work, rwork, iwork, nout)
 SCHKTB
subroutine schktp (dotype, nn, nval, nns, nsval, thresh, tsterr, nmax, ap, ainvp, b, x, xact, work, rwork, iwork, nout)
 SCHKTP
subroutine schktr (dotype, nn, nval, nnb, nbval, nns, nsval, thresh, tsterr, nmax, a, ainv, b, x, xact, work, rwork, iwork, nout)
 SCHKTR
subroutine schktz (dotype, nm, mval, nn, nval, thresh, tsterr, a, copya, s, tau, work, nout)
 SCHKTZ
subroutine sdrvgb (dotype, nn, nval, nrhs, thresh, tsterr, a, la, afb, lafb, asav, b, bsav, x, xact, s, work, rwork, iwork, nout)
 SDRVGB
subroutine sdrvge (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, asav, b, bsav, x, xact, s, work, rwork, iwork, nout)
 SDRVGE
subroutine sdrvgt (dotype, nn, nval, nrhs, thresh, tsterr, a, af, b, x, xact, work, rwork, iwork, nout)
 SDRVGT
subroutine sdrvls (dotype, nm, mval, nn, nval, nns, nsval, nnb, nbval, nxval, thresh, tsterr, a, copya, b, copyb, c, s, copys, nout)
 SDRVLS
subroutine sdrvpb (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, asav, b, bsav, x, xact, s, work, rwork, iwork, nout)
 SDRVPB
subroutine sdrvpo (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, asav, b, bsav, x, xact, s, work, rwork, iwork, nout)
 SDRVPO
subroutine sdrvpp (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, asav, b, bsav, x, xact, s, work, rwork, iwork, nout)
 SDRVPP
subroutine sdrvpt (dotype, nn, nval, nrhs, thresh, tsterr, a, d, e, b, x, xact, work, rwork, nout)
 SDRVPT
subroutine sdrvrf1 (nout, nn, nval, thresh, a, lda, arf, work)
 SDRVRF1
subroutine sdrvrf2 (nout, nn, nval, a, lda, arf, ap, asav)
 SDRVRF2
subroutine sdrvrf3 (nout, nn, nval, thresh, a, lda, arf, b1, b2, s_work_slange, s_work_sgeqrf, tau)
 SDRVRF3
subroutine sdrvrf4 (nout, nn, nval, thresh, c1, c2, ldc, crf, a, lda, s_work_slange)
 SDRVRF4
subroutine sdrvrfp (nout, nn, nval, nns, nsval, nnt, ntval, thresh, a, asav, afac, ainv, b, bsav, xact, x, arf, arfinv, s_work_slatms, s_work_spot01, s_temp_spot02, s_temp_spot03, s_work_slansy, s_work_spot02, s_work_spot03)
 SDRVRFP
subroutine sdrvsp (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 SDRVSP
subroutine sdrvsy (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
 SDRVSY
subroutine sdrvsy_rk (dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, e, ainv, b, x, xact, work, rwork, iwork, nout)
 SDRVSY_RK
subroutine sebchvxx (thresh, path)
 SEBCHVXX
subroutine serrge (path, nunit)
 SERRGE
subroutine serrgt (path, nunit)
 SERRGT
subroutine serrlq (path, nunit)
 SERRLQ
subroutine serrls (path, nunit)
 SERRLS
subroutine serrpo (path, nunit)
 SERRPO
subroutine serrps (path, nunit)
 SERRPS
subroutine serrql (path, nunit)
 SERRQL
subroutine serrqp (path, nunit)
 SERRQP
subroutine serrqr (path, nunit)
 SERRQR
subroutine serrqrt (path, nunit)
 SERRQRT
subroutine serrqrtp (path, nunit)
 SERRQRTP
subroutine serrrfp (nunit)
 SERRRFP
subroutine serrrq (path, nunit)
 SERRRQ
subroutine serrsy (path, nunit)
 SERRSY
subroutine serrtr (path, nunit)
 SERRTR
subroutine serrtz (path, nunit)
 SERRTZ
subroutine serrvx (path, nunit)
 SERRVX
subroutine sgbt01 (m, n, kl, ku, a, lda, afac, ldafac, ipiv, work, resid)
 SGBT01
subroutine sgbt02 (trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 SGBT02
subroutine sgbt05 (trans, n, kl, ku, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 SGBT05
subroutine sgelqs (m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
 SGELQS
logical function sgennd (m, n, a, lda)
 SGENND
subroutine sgeqls (m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
 SGEQLS
subroutine sgeqrs (m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
 SGEQRS
subroutine sgerqs (m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
 SGERQS
subroutine sget01 (m, n, a, lda, afac, ldafac, ipiv, rwork, resid)
 SGET01
subroutine sget02 (trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 SGET02
subroutine sget03 (n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
 SGET03
subroutine sget04 (n, nrhs, x, ldx, xact, ldxact, rcond, resid)
 SGET04
real function sget06 (rcond, rcondc)
 SGET06
subroutine sget07 (trans, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, chkferr, berr, reslts)
 SGET07
subroutine sgtt01 (n, dl, d, du, dlf, df, duf, du2, ipiv, work, ldwork, rwork, resid)
 SGTT01
subroutine sgtt02 (trans, n, nrhs, dl, d, du, x, ldx, b, ldb, resid)
 SGTT02
subroutine sgtt05 (trans, n, nrhs, dl, d, du, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 SGTT05
subroutine slahilb (n, nrhs, a, lda, x, ldx, b, ldb, work, info)
 SLAHILB
subroutine slaord (job, n, x, incx)
 SLAORD
subroutine slaptm (n, nrhs, alpha, d, e, x, ldx, beta, b, ldb)
 SLAPTM
subroutine slarhs (path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
 SLARHS
subroutine slatb4 (path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
 SLATB4
subroutine slatb5 (path, imat, n, type, kl, ku, anorm, mode, cndnum, dist)
 SLATB5
subroutine slattb (imat, uplo, trans, diag, iseed, n, kd, ab, ldab, b, work, info)
 SLATTB
subroutine slattp (imat, uplo, trans, diag, iseed, n, a, b, work, info)
 SLATTP
subroutine slattr (imat, uplo, trans, diag, iseed, n, a, lda, b, work, info)
 SLATTR
subroutine slavsp (uplo, trans, diag, n, nrhs, a, ipiv, b, ldb, info)
 SLAVSP
subroutine slavsy (uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
 SLAVSY
subroutine slavsy_rook (uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
 SLAVSY_ROOK
subroutine slqt01 (m, n, a, af, q, l, lda, tau, work, lwork, rwork, result)
 SLQT01
subroutine slqt02 (m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
 SLQT02
subroutine slqt03 (m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
 SLQT03
subroutine sorhr_col01 (m, n, mb1, nb1, nb2, result)
 SORHR_COL01
subroutine sorhr_col02 (m, n, mb1, nb1, nb2, result)
 SORHR_COL02
subroutine spbt01 (uplo, n, kd, a, lda, afac, ldafac, rwork, resid)
 SPBT01
subroutine spbt02 (uplo, n, kd, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 SPBT02
subroutine spbt05 (uplo, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 SPBT05
subroutine spot01 (uplo, n, a, lda, afac, ldafac, rwork, resid)
 SPOT01
subroutine spot02 (uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 SPOT02
subroutine spot03 (uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
 SPOT03
subroutine spot05 (uplo, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 SPOT05
subroutine sppt01 (uplo, n, a, afac, rwork, resid)
 SPPT01
subroutine sppt02 (uplo, n, nrhs, a, x, ldx, b, ldb, rwork, resid)
 SPPT02
subroutine sppt03 (uplo, n, a, ainv, work, ldwork, rwork, rcond, resid)
 SPPT03
subroutine sppt05 (uplo, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 SPPT05
subroutine spst01 (uplo, n, a, lda, afac, ldafac, perm, ldperm, piv, rwork, resid, rank)
 SPST01
subroutine sptt01 (n, d, e, df, ef, work, resid)
 SPTT01
subroutine sptt02 (n, nrhs, d, e, x, ldx, b, ldb, resid)
 SPTT02
subroutine sptt05 (n, nrhs, d, e, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 SPTT05
subroutine sqlt01 (m, n, a, af, q, l, lda, tau, work, lwork, rwork, result)
 SQLT01
subroutine sqlt02 (m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
 SQLT02
subroutine sqlt03 (m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
 SQLT03
real function sqpt01 (m, n, k, a, af, lda, tau, jpvt, work, lwork)
 SQPT01
subroutine sqrt01 (m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
 SQRT01
subroutine sqrt01p (m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
 SQRT01P
subroutine sqrt02 (m, n, k, a, af, q, r, lda, tau, work, lwork, rwork, result)
 SQRT02
subroutine sqrt03 (m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
 SQRT03
subroutine sqrt04 (m, n, nb, result)
 SQRT04
subroutine sqrt05 (m, n, l, nb, result)
 SQRT05
real function sqrt11 (m, k, a, lda, tau, work, lwork)
 SQRT11
real function sqrt12 (m, n, a, lda, s, work, lwork)
 SQRT12
subroutine sqrt13 (scale, m, n, a, lda, norma, iseed)
 SQRT13
real function sqrt14 (trans, m, n, nrhs, a, lda, x, ldx, work, lwork)
 SQRT14
subroutine sqrt15 (scale, rksel, m, n, nrhs, a, lda, b, ldb, s, rank, norma, normb, iseed, work, lwork)
 SQRT15
subroutine sqrt16 (trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
 SQRT16
real function sqrt17 (trans, iresid, m, n, nrhs, a, lda, x, ldx, b, ldb, c, work, lwork)
 SQRT17
subroutine srqt01 (m, n, a, af, q, r, lda, tau, work, lwork, rwork, result)
 SRQT01
subroutine srqt02 (m, n, k, a, af, q, r, lda, tau, work, lwork, rwork, result)
 SRQT02
subroutine srqt03 (m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
 SRQT03
real function srzt01 (m, n, a, af, lda, tau, work, lwork)
 SRZT01
real function srzt02 (m, n, af, lda, tau, work, lwork)
 SRZT02
subroutine sspt01 (uplo, n, a, afac, ipiv, c, ldc, rwork, resid)
 SSPT01
subroutine ssyt01 (uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
 SSYT01
subroutine ssyt01_3 (uplo, n, a, lda, afac, ldafac, e, ipiv, c, ldc, rwork, resid)
 SSYT01_3
subroutine ssyt01_rook (uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
 SSYT01_ROOK
subroutine stbt02 (uplo, trans, diag, n, kd, nrhs, ab, ldab, x, ldx, b, ldb, work, resid)
 STBT02
subroutine stbt03 (uplo, trans, diag, n, kd, nrhs, ab, ldab, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
 STBT03
subroutine stbt05 (uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 STBT05
subroutine stbt06 (rcond, rcondc, uplo, diag, n, kd, ab, ldab, work, rat)
 STBT06
subroutine stpt01 (uplo, diag, n, ap, ainvp, rcond, work, resid)
 STPT01
subroutine stpt02 (uplo, trans, diag, n, nrhs, ap, x, ldx, b, ldb, work, resid)
 STPT02
subroutine stpt03 (uplo, trans, diag, n, nrhs, ap, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
 STPT03
subroutine stpt05 (uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 STPT05
subroutine stpt06 (rcond, rcondc, uplo, diag, n, ap, work, rat)
 STPT06
subroutine strt01 (uplo, diag, n, a, lda, ainv, ldainv, rcond, work, resid)
 STRT01
subroutine strt02 (uplo, trans, diag, n, nrhs, a, lda, x, ldx, b, ldb, work, resid)
 STRT02
subroutine strt03 (uplo, trans, diag, n, nrhs, a, lda, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
 STRT03
subroutine strt05 (uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
 STRT05
subroutine strt06 (rcond, rcondc, uplo, diag, n, a, lda, work, rat)
 STRT06

Detailed Description

This is the group of real LAPACK TESTING LIN routines.

Function Documentation

◆ schkaa()

program schkaa

SCHKAA

Purpose:
!>
!> SCHKAA is the main test program for the REAL 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 REAL 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
!> SGE   11               List types on next line if 0 < NTYPES < 11
!> SGB    8               List types on next line if 0 < NTYPES <  8
!> SGT   12               List types on next line if 0 < NTYPES < 12
!> SPO    9               List types on next line if 0 < NTYPES <  9
!> SPS    9               List types on next line if 0 < NTYPES <  9
!> SPP    9               List types on next line if 0 < NTYPES <  9
!> SPB    8               List types on next line if 0 < NTYPES <  8
!> SPT   12               List types on next line if 0 < NTYPES < 12
!> SSY   10               List types on next line if 0 < NTYPES < 10
!> SSR   10               List types on next line if 0 < NTYPES < 10
!> SSK   10               List types on next line if 0 < NTYPES < 10
!> SSA   10               List types on next line if 0 < NTYPES < 10
!> SS2   10               List types on next line if 0 < NTYPES < 10
!> SSP   10               List types on next line if 0 < NTYPES < 10
!> STR   18               List types on next line if 0 < NTYPES < 18
!> STP   18               List types on next line if 0 < NTYPES < 18
!> STB   17               List types on next line if 0 < NTYPES < 17
!> SQR    8               List types on next line if 0 < NTYPES <  8
!> SRQ    8               List types on next line if 0 < NTYPES <  8
!> SLQ    8               List types on next line if 0 < NTYPES <  8
!> SQL    8               List types on next line if 0 < NTYPES <  8
!> SQP    6               List types on next line if 0 < NTYPES <  6
!> STZ    3               List types on next line if 0 < NTYPES <  3
!> SLS    6               List types on next line if 0 < NTYPES <  6
!> SEQ
!> SQT
!> SQX
!> STS
!> SHH
!> 
!>  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 110 of file schkaa.F.

◆ schkeq()

subroutine schkeq ( real thresh,
integer nout )

SCHKEQ

Purpose:
!>
!> SCHKEQ tests SGEEQU, SGBEQU, SPOEQU, SPPEQU and SPBEQU
!>
Parameters
[in]THRESH
!>          THRESH is REAL
!>          Threshold for testing routines. Should be between 2 and 10.
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 53 of file schkeq.f.

54*
55* -- LAPACK test routine --
56* -- LAPACK is a software package provided by Univ. of Tennessee, --
57* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
58*
59* .. Scalar Arguments ..
60 INTEGER NOUT
61 REAL THRESH
62* ..
63*
64* =====================================================================
65*
66* .. Parameters ..
67 REAL ZERO, ONE, TEN
68 parameter( zero = 0.0e0, one = 1.0e+0, ten = 1.0e1 )
69 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 REAL CCOND, EPS, NORM, RATIO, RCMAX, RCMIN, RCOND
80* ..
81* .. Local Arrays ..
82 REAL 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 REAL SLAMCH
88 EXTERNAL slamch
89* ..
90* .. External Subroutines ..
91 EXTERNAL sgbequ, sgeequ, spbequ, spoequ, sppequ
92* ..
93* .. Intrinsic Functions ..
94 INTRINSIC abs, max, min
95* ..
96* .. Executable Statements ..
97*
98 path( 1:1 ) = 'Single precision'
99 path( 2:3 ) = 'EQ'
100*
101 eps = slamch( '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 SGEEQU
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 sgeequ( 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 sgeequ( 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 sgeequ( 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 SGBEQU
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 sgbequ( 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 SPOEQU
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 spoequ( 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 spoequ( 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 SPPEQU
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 sppequ( '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 sppequ( '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 sppequ( '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 SPBEQU
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 spbequ( '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 spbequ( '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 spbequ( '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 spbequ( '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( ' SGEEQU failed test with value ', e10.3, ' exceeding',
474 $ ' threshold ', e10.3 )
475 9997 FORMAT( ' SGBEQU failed test with value ', e10.3, ' exceeding',
476 $ ' threshold ', e10.3 )
477 9996 FORMAT( ' SPOEQU failed test with value ', e10.3, ' exceeding',
478 $ ' threshold ', e10.3 )
479 9995 FORMAT( ' SPPEQU failed test with value ', e10.3, ' exceeding',
480 $ ' threshold ', e10.3 )
481 9994 FORMAT( ' SPBEQU failed test with value ', e10.3, ' exceeding',
482 $ ' threshold ', e10.3 )
483 RETURN
484*
485* End of SCHKEQ
486*
norm
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
sgbequ
subroutine sgbequ(m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, info)
SGBEQU
Definition sgbequ.f:153
sgeequ
subroutine sgeequ(m, n, a, lda, r, c, rowcnd, colcnd, amax, info)
SGEEQU
Definition sgeequ.f:139
spbequ
subroutine spbequ(uplo, n, kd, ab, ldab, s, scond, amax, info)
SPBEQU
Definition spbequ.f:129
sppequ
subroutine sppequ(uplo, n, ap, s, scond, amax, info)
SPPEQU
Definition sppequ.f:116
spoequ
subroutine spoequ(n, a, lda, s, scond, amax, info)
SPOEQU
Definition spoequ.f:112
slamch
real function slamch(cmach)
SLAMCH
Definition slamch.f:68
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21

◆ schkgb()

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

SCHKGB

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

191*
192* -- LAPACK test routine --
193* -- LAPACK is a software package provided by Univ. of Tennessee, --
194* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
195*
196* .. Scalar Arguments ..
197 LOGICAL TSTERR
198 INTEGER LA, LAFAC, NM, NN, NNB, NNS, NOUT
199 REAL THRESH
200* ..
201* .. Array Arguments ..
202 LOGICAL DOTYPE( * )
203 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
204 $ NVAL( * )
205 REAL A( * ), AFAC( * ), B( * ), RWORK( * ),
206 $ WORK( * ), X( * ), XACT( * )
207* ..
208*
209* =====================================================================
210*
211* .. Parameters ..
212 REAL ONE, ZERO
213 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL RESULT( NTESTS )
235* ..
236* .. External Functions ..
237 REAL SGET06, SLANGB, SLANGE
238 EXTERNAL sget06, slangb, slange
239* ..
240* .. External Subroutines ..
241 EXTERNAL alaerh, alahd, alasum, scopy, serrge, sgbcon,
242 $ sgbrfs, sgbt01, sgbt02, sgbt05, sgbtrf, sgbtrs,
243 $ sget04, slacpy, slarhs, slaset, slatb4, slatms,
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 ) = 'Single 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 serrge( 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 SLATB4 and generate a
381* test matrix with SLATMS.
382*
383 CALL slatb4( 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 = 'SLATMS'
391 CALL slatms( 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 SLATMS.
396*
397 IF( info.NE.0 ) THEN
398 CALL alaerh( path, 'SLATMS', 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 scopy( 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 scopy( 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 = SLANGB( 'O', N, KL, KU, A, LDA, RWORK )
451* ANORMI = SLANGB( '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 slacpy( 'Full', kl+ku+1, n, a, lda,
463 $ afac( kl+1 ), ldafac )
464 srnamt = 'SGBTRF'
465 CALL sgbtrf( m, n, kl, ku, afac, ldafac, iwork,
466 $ info )
467*
468* Check error code from SGBTRF.
469*
470 IF( info.NE.izero )
471 $ CALL alaerh( path, 'SGBTRF', 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 sgbt01( 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 = slangb( 'O', n, kl, ku, a, lda, rwork )
502 anormi = slangb( '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 slaset( 'Full', n, n, zero, one, work,
511 $ ldb )
512 srnamt = 'SGBTRS'
513 CALL sgbtrs( '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 = slange( '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 = slange( '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 = 'SLARHS'
569 CALL slarhs( path, xtype, ' ', trans, n,
570 $ n, kl, ku, nrhs, a, lda,
571 $ xact, ldb, b, ldb, iseed,
572 $ info )
573 xtype = 'C'
574 CALL slacpy( 'Full', n, nrhs, b, ldb, x,
575 $ ldb )
576*
577 srnamt = 'SGBTRS'
578 CALL sgbtrs( trans, n, kl, ku, nrhs, afac,
579 $ ldafac, iwork, x, ldb, info )
580*
581* Check error code from SGBTRS.
582*
583 IF( info.NE.0 )
584 $ CALL alaerh( path, 'SGBTRS', info, 0,
585 $ trans, n, n, kl, ku, -1,
586 $ imat, nfail, nerrs, nout )
587*
588 CALL slacpy( 'Full', n, nrhs, b, ldb,
589 $ work, ldb )
590 CALL sgbt02( 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 sget04( 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 = 'SGBRFS'
606 CALL sgbrfs( 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 SGBRFS.
613*
614 IF( info.NE.0 )
615 $ CALL alaerh( path, 'SGBRFS', info, 0,
616 $ trans, n, n, kl, ku, nrhs,
617 $ imat, nfail, nerrs, nout )
618*
619 CALL sget04( n, nrhs, x, ldb, xact, ldb,
620 $ rcondc, result( 4 ) )
621 CALL sgbt05( 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 = 'SGBCON'
654 CALL sgbcon( norm, n, kl, ku, afac, ldafac,
655 $ iwork, anorm, rcond, work,
656 $ iwork( n+1 ), info )
657*
658* Check error code from SGBCON.
659*
660 IF( info.NE.0 )
661 $ CALL alaerh( path, 'SGBCON', info, 0,
662 $ norm, n, n, kl, ku, -1, imat,
663 $ nfail, nerrs, nout )
664*
665 result( 7 ) = sget06( 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 SCHKGB, 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 SCHKGB, 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 SCHKGB
707*
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
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
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
alasum
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
alahd
subroutine alahd(iounit, path)
ALAHD
Definition alahd.f:107
alaerh
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
slangb
real function slangb(norm, n, kl, ku, ab, ldab, work)
SLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition slangb.f:124
sgbtrf
subroutine sgbtrf(m, n, kl, ku, ab, ldab, ipiv, info)
SGBTRF
Definition sgbtrf.f:144
sgbrfs
subroutine sgbrfs(trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
SGBRFS
Definition sgbrfs.f:205
sgbcon
subroutine sgbcon(norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond, work, iwork, info)
SGBCON
Definition sgbcon.f:146
sgbtrs
subroutine sgbtrs(trans, n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
SGBTRS
Definition sgbtrs.f:138
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
slatms
subroutine slatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
SLATMS
Definition slatms.f:321
scopy
subroutine scopy(n, sx, incx, sy, incy)
SCOPY
Definition scopy.f:82
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
serrge
subroutine serrge(path, nunit)
SERRGE
Definition serrge.f:55
sgbt05
subroutine sgbt05(trans, n, kl, ku, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
SGBT05
Definition sgbt05.f:176
sgbt02
subroutine sgbt02(trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
SGBT02
Definition sgbt02.f:149
sgbt01
subroutine sgbt01(m, n, kl, ku, a, lda, afac, ldafac, ipiv, work, resid)
SGBT01
Definition sgbt01.f:126
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
sget06
real function sget06(rcond, rcondc)
SGET06
Definition sget06.f:55

◆ schkge()

subroutine schkge ( logical, dimension( * ) dotype,
integer nm,
integer, dimension( * ) mval,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nns,
integer, dimension( * ) nsval,
real thresh,
logical tsterr,
integer nmax,
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 )

SCHKGE

Purpose:
!>
!> SCHKGE tests SGETRF, -TRI, -TRS, -RFS, and -CON.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is REAL
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for M or N, used in dimensioning
!>          the work arrays.
!>
[out]A
!>          A is REAL array, dimension (NMAX*NMAX)
!>
[out]AFAC
!>          AFAC is REAL array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is REAL array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is REAL array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is REAL array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is REAL array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is REAL array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL array, dimension
!>                      (max(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 schkge.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 REAL THRESH
194* ..
195* .. Array Arguments ..
196 LOGICAL DOTYPE( * )
197 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
198 $ NVAL( * )
199 REAL A( * ), AFAC( * ), AINV( * ), B( * ),
200 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
201* ..
202*
203* =====================================================================
204*
205* .. Parameters ..
206 REAL ONE, ZERO
207 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL RESULT( NTESTS )
229* ..
230* .. External Functions ..
231 REAL SGET06, SLANGE
232 EXTERNAL sget06, slange
233* ..
234* .. External Subroutines ..
235 EXTERNAL alaerh, alahd, alasum, serrge, sgecon, sgerfs,
236 $ sget01, sget02, sget03, sget04, sget07, sgetrf,
237 $ sgetri, sgetrs, slacpy, slarhs, slaset, slatb4,
238 $ slatms, 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 ) = 'Single 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 serrge( 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 SLATB4 and generate a test matrix
306* with SLATMS.
307*
308 CALL slatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
309 $ CNDNUM, DIST )
310*
311 srnamt = 'SLATMS'
312 CALL slatms( 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 SLATMS.
317*
318 IF( info.NE.0 ) THEN
319 CALL alaerh( path, 'SLATMS', 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 slaset( '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 = SLANGE( 'O', M, N, A, LDA, RWORK )
352* ANORMI = SLANGE( '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 slacpy( 'Full', m, n, a, lda, afac, lda )
363 srnamt = 'SGETRF'
364 CALL sgetrf( m, n, afac, lda, iwork, info )
365*
366* Check error code from SGETRF.
367*
368 IF( info.NE.izero )
369 $ CALL alaerh( path, 'SGETRF', 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 slacpy( 'Full', m, n, afac, lda, ainv, lda )
378 CALL sget01( 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 slacpy( 'Full', n, n, afac, lda, ainv, lda )
388 srnamt = 'SGETRI'
389 nrhs = nsval( 1 )
390 lwork = nmax*max( 3, nrhs )
391 CALL sgetri( n, ainv, lda, iwork, work, lwork,
392 $ info )
393*
394* Check error code from SGETRI.
395*
396 IF( info.NE.0 )
397 $ CALL alaerh( path, 'SGETRI', 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 sget03( n, a, lda, ainv, lda, work, lda,
406 $ rwork, rcondo, result( 2 ) )
407 anormo = slange( 'O', m, n, a, lda, rwork )
408*
409* Compute the infinity-norm condition number of A.
410*
411 anormi = slange( 'I', m, n, a, lda, rwork )
412 ainvnm = slange( '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 = slange( 'O', m, n, a, lda, rwork )
425 anormi = slange( '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 = 'SLARHS'
469 CALL slarhs( path, xtype, ' ', trans, n, n, kl,
470 $ ku, nrhs, a, lda, xact, lda, b,
471 $ lda, iseed, info )
472 xtype = 'C'
473*
474 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
475 srnamt = 'SGETRS'
476 CALL sgetrs( trans, n, nrhs, afac, lda, iwork,
477 $ x, lda, info )
478*
479* Check error code from SGETRS.
480*
481 IF( info.NE.0 )
482 $ CALL alaerh( path, 'SGETRS', info, 0, trans,
483 $ n, n, -1, -1, nrhs, imat, nfail,
484 $ nerrs, nout )
485*
486 CALL slacpy( 'Full', n, nrhs, b, lda, work,
487 $ lda )
488 CALL sget02( 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 sget04( 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 = 'SGERFS'
502 CALL sgerfs( 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 SGERFS.
508*
509 IF( info.NE.0 )
510 $ CALL alaerh( path, 'SGERFS', info, 0, trans,
511 $ n, n, -1, -1, nrhs, imat, nfail,
512 $ nerrs, nout )
513*
514 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
515 $ result( 5 ) )
516 CALL sget07( 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 = 'SGECON'
551 CALL sgecon( norm, n, afac, lda, anorm, rcond,
552 $ work, iwork( n+1 ), info )
553*
554* Check error code from SGECON.
555*
556 IF( info.NE.0 )
557 $ CALL alaerh( path, 'SGECON', 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 ) = sget06( 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 SCHKGE
597*
sgetrf
subroutine sgetrf(m, n, a, lda, ipiv, info)
SGETRF
Definition sgetrf.f:108
sgecon
subroutine sgecon(norm, n, a, lda, anorm, rcond, work, iwork, info)
SGECON
Definition sgecon.f:124
sgetrs
subroutine sgetrs(trans, n, nrhs, a, lda, ipiv, b, ldb, info)
SGETRS
Definition sgetrs.f:121
sgetri
subroutine sgetri(n, a, lda, ipiv, work, lwork, info)
SGETRI
Definition sgetri.f:114
sgerfs
subroutine sgerfs(trans, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
SGERFS
Definition sgerfs.f:185
sget02
subroutine sget02(trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
SGET02
Definition sget02.f:135
sget03
subroutine sget03(n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
SGET03
Definition sget03.f:109
sget01
subroutine sget01(m, n, a, lda, afac, ldafac, ipiv, rwork, resid)
SGET01
Definition sget01.f:107
sget07
subroutine sget07(trans, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, chkferr, berr, reslts)
SGET07
Definition sget07.f:165

◆ schkgt()

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

SCHKGT

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

Definition at line 144 of file schkgt.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 REAL THRESH
155* ..
156* .. Array Arguments ..
157 LOGICAL DOTYPE( * )
158 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
159 REAL A( * ), AF( * ), B( * ), RWORK( * ), WORK( * ),
160 $ X( * ), XACT( * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 REAL ONE, ZERO
167 parameter( one = 1.0e+0, zero = 0.0e+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 REAL AINVNM, ANORM, COND, RCOND, RCONDC, RCONDI,
181 $ RCONDO
182* ..
183* .. Local Arrays ..
184 CHARACTER TRANSS( 3 )
185 INTEGER ISEED( 4 ), ISEEDY( 4 )
186 REAL RESULT( NTESTS ), Z( 3 )
187* ..
188* .. External Functions ..
189 REAL SASUM, SGET06, SLANGT
190 EXTERNAL sasum, sget06, slangt
191* ..
192* .. External Subroutines ..
193 EXTERNAL alaerh, alahd, alasum, scopy, serrge, sget04,
194 $ sgtcon, sgtrfs, sgtt01, sgtt02, sgtt05, sgttrf,
195 $ sgttrs, slacpy, slagtm, slarnv, slatb4, slatms,
196 $ sscal
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 ) = 'Single 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 serrge( 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 SLATB4.
250*
251 CALL slatb4( 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 = 'SLATMS'
261 CALL slatms( 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 SLATMS.
266*
267 IF( info.NE.0 ) THEN
268 CALL alaerh( path, 'SLATMS', 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 scopy( n-1, af( 4 ), 3, a, 1 )
276 CALL scopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
277 END IF
278 CALL scopy( 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 slarnv( 2, iseed, n+2*m, a )
289 IF( anorm.NE.one )
290 $ CALL sscal( 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 scopy( n+2*m, a, 1, af, 1 )
345 srnamt = 'SGTTRF'
346 CALL sgttrf( n, af, af( m+1 ), af( n+m+1 ), af( n+2*m+1 ),
347 $ iwork, info )
348*
349* Check error code from SGTTRF.
350*
351 IF( info.NE.izero )
352 $ CALL alaerh( path, 'SGTTRF', info, izero, ' ', n, n, 1,
353 $ 1, -1, imat, nfail, nerrs, nout )
354 trfcon = info.NE.0
355*
356 CALL sgtt01( 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 = slangt( norm, n, a, a( m+1 ), a( n+m+1 ) )
378*
379 IF( .NOT.trfcon ) THEN
380*
381* Use SGTTRS 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 sgttrs( 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, sasum( 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 = 'SGTCON'
418 CALL sgtcon( 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 SGTCON.
423*
424 IF( info.NE.0 )
425 $ CALL alaerh( path, 'SGTCON', info, 0, norm, n, n, -1,
426 $ -1, -1, imat, nfail, nerrs, nout )
427*
428 result( 7 ) = sget06( 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 slarnv( 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 slagtm( 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 slacpy( 'Full', n, nrhs, b, lda, x, lda )
475 srnamt = 'SGTTRS'
476 CALL sgttrs( 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 SGTTRS.
481*
482 IF( info.NE.0 )
483 $ CALL alaerh( path, 'SGTTRS', info, 0, trans, n, n,
484 $ -1, -1, nrhs, imat, nfail, nerrs,
485 $ nout )
486*
487 CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
488 CALL sgtt02( 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 sget04( 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 = 'SGTRFS'
501 CALL sgtrfs( 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 SGTRFS.
508*
509 IF( info.NE.0 )
510 $ CALL alaerh( path, 'SGTRFS', info, 0, trans, n, n,
511 $ -1, -1, nrhs, imat, nfail, nerrs,
512 $ nout )
513*
514 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
515 $ result( 4 ) )
516 CALL sgtt05( 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 SCHKGT
552*
slarnv
subroutine slarnv(idist, iseed, n, x)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
Definition slarnv.f:97
sgtrfs
subroutine sgtrfs(trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
SGTRFS
Definition sgtrfs.f:209
sgtcon
subroutine sgtcon(norm, n, dl, d, du, du2, ipiv, anorm, rcond, work, iwork, info)
SGTCON
Definition sgtcon.f:146
sgttrf
subroutine sgttrf(n, dl, d, du, du2, ipiv, info)
SGTTRF
Definition sgttrf.f:124
sgttrs
subroutine sgttrs(trans, n, nrhs, dl, d, du, du2, ipiv, b, ldb, info)
SGTTRS
Definition sgttrs.f:138
slagtm
subroutine slagtm(trans, n, nrhs, alpha, dl, d, du, x, ldx, beta, b, ldb)
SLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matrix,...
Definition slagtm.f:145
slangt
real function slangt(norm, n, dl, d, du)
SLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition slangt.f:106
sscal
subroutine sscal(n, sa, sx, incx)
SSCAL
Definition sscal.f:79
sasum
real function sasum(n, sx, incx)
SASUM
Definition sasum.f:72
sgtt02
subroutine sgtt02(trans, n, nrhs, dl, d, du, x, ldx, b, ldb, resid)
SGTT02
Definition sgtt02.f:125
sgtt01
subroutine sgtt01(n, dl, d, du, dlf, df, duf, du2, ipiv, work, ldwork, rwork, resid)
SGTT01
Definition sgtt01.f:134
sgtt05
subroutine sgtt05(trans, n, nrhs, dl, d, du, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
SGTT05
Definition sgtt05.f:165

◆ schklq()

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

SCHKLQ

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

Definition at line 193 of file schklq.f.

196*
197* -- LAPACK test routine --
198* -- LAPACK is a software package provided by Univ. of Tennessee, --
199* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
200*
201* .. Scalar Arguments ..
202 LOGICAL TSTERR
203 INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
204 REAL THRESH
205* ..
206* .. Array Arguments ..
207 LOGICAL DOTYPE( * )
208 INTEGER MVAL( * ), NBVAL( * ), NVAL( * ),
209 $ NXVAL( * )
210 REAL 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 REAL ZERO
223 parameter( zero = 0.0e0 )
224* ..
225* .. Local Scalars ..
226 CHARACTER DIST, TYPE
227 CHARACTER*3 PATH
228 INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
229 $ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
230 $ NRUN, NT, NX
231 REAL ANORM, CNDNUM
232* ..
233* .. Local Arrays ..
234 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
235 REAL RESULT( NTESTS )
236* ..
237* .. External Subroutines ..
238 EXTERNAL alaerh, alahd, alasum, serrlq, sgelqs, sget02,
239 $ slacpy, slarhs, slatb4, slatms, slqt01, slqt02,
240 $ slqt03, 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 ) = 'Single 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 serrlq( 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 SLATB4 and generate a test matrix
298* with SLATMS.
299*
300 CALL slatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
301 $ CNDNUM, DIST )
302*
303 srnamt = 'SLATMS'
304 CALL slatms( 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 SLATMS.
309*
310 IF( info.NE.0 ) THEN
311 CALL alaerh( path, 'SLATMS', 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 SLQT01; other values are
318* used in the calls of SLQT02, 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 SGELQF
353*
354 CALL slqt01( m, n, a, af, aq, al, lda, tau,
355 $ work, lwork, rwork, result( 1 ) )
356 ELSE IF( m.LE.n ) THEN
357*
358* Test SORGLQ, using factorization
359* returned by SLQT01
360*
361 CALL slqt02( 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 SORMLQ, using factorization returned
367* by SLQT01
368*
369 CALL slqt03( 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 SGELQS to solve a system
374* with NRHS right hand sides and compute the
375* residual.
376*
377 IF( k.EQ.m .AND. inb.EQ.1 ) THEN
378*
379* Generate a solution and set the right
380* hand side.
381*
382 srnamt = 'SLARHS'
383 CALL slarhs( path, 'New', 'Full',
384 $ 'No transpose', m, n, 0, 0,
385 $ nrhs, a, lda, xact, lda, b, lda,
386 $ iseed, info )
387*
388 CALL slacpy( 'Full', m, nrhs, b, lda, x,
389 $ lda )
390 srnamt = 'SGELQS'
391 CALL sgelqs( m, n, nrhs, af, lda, tau, x,
392 $ lda, work, lwork, info )
393*
394* Check error code from SGELQS.
395*
396 IF( info.NE.0 )
397 $ CALL alaerh( path, 'SGELQS', info, 0, ' ',
398 $ m, n, nrhs, -1, nb, imat,
399 $ nfail, nerrs, nout )
400*
401 CALL sget02( 'No transpose', m, n, nrhs, a,
402 $ lda, x, lda, b, lda, rwork,
403 $ result( 7 ) )
404 nt = nt + 1
405 END IF
406 END IF
407*
408* Print information about the tests that did not
409* pass the threshold.
410*
411 DO 20 i = 1, nt
412 IF( result( i ).GE.thresh ) THEN
413 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
414 $ CALL alahd( nout, path )
415 WRITE( nout, fmt = 9999 )m, n, k, nb, nx,
416 $ imat, i, result( i )
417 nfail = nfail + 1
418 END IF
419 20 CONTINUE
420 nrun = nrun + nt
421 30 CONTINUE
422 40 CONTINUE
423 50 CONTINUE
424 60 CONTINUE
425 70 CONTINUE
426*
427* Print a summary of the results.
428*
429 CALL alasum( path, nout, nfail, nrun, nerrs )
430*
431 9999 FORMAT( ' M=', i5, ', N=', i5, ', K=', i5, ', NB=', i4, ', NX=',
432 $ i5, ', type ', i2, ', test(', i2, ')=', g12.5 )
433 RETURN
434*
435* End of SCHKLQ
436*
serrlq
subroutine serrlq(path, nunit)
SERRLQ
Definition serrlq.f:55
slqt02
subroutine slqt02(m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
SLQT02
Definition slqt02.f:135
sgelqs
subroutine sgelqs(m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
SGELQS
Definition sgelqs.f:121
slqt01
subroutine slqt01(m, n, a, af, q, l, lda, tau, work, lwork, rwork, result)
SLQT01
Definition slqt01.f:126
slqt03
subroutine slqt03(m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
SLQT03
Definition slqt03.f:136

◆ schkorhr_col()

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

SCHKORHR_COL

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

Definition at line 106 of file schkorhr_col.f.

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

◆ schkpb()

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

SCHKPB

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

172*
173* -- LAPACK test routine --
174* -- LAPACK is a software package provided by Univ. of Tennessee, --
175* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176*
177* .. Scalar Arguments ..
178 LOGICAL TSTERR
179 INTEGER NMAX, NN, NNB, NNS, NOUT
180 REAL THRESH
181* ..
182* .. Array Arguments ..
183 LOGICAL DOTYPE( * )
184 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
185 REAL A( * ), AFAC( * ), AINV( * ), B( * ),
186 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
187* ..
188*
189* =====================================================================
190*
191* .. Parameters ..
192 REAL ONE, ZERO
193 parameter( one = 1.0e+0, zero = 0.0e+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 REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC
208* ..
209* .. Local Arrays ..
210 INTEGER ISEED( 4 ), ISEEDY( 4 ), KDVAL( NBW )
211 REAL RESULT( NTESTS )
212* ..
213* .. External Functions ..
214 REAL SGET06, SLANGE, SLANSB
215 EXTERNAL sget06, slange, slansb
216* ..
217* .. External Subroutines ..
218 EXTERNAL alaerh, alahd, alasum, scopy, serrpo, sget04,
219 $ slacpy, slarhs, slaset, slatb4, slatms, spbcon,
220 $ spbrfs, spbt01, spbt02, spbt05, spbtrf, spbtrs,
221 $ sswap, 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 ) = 'Single 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 serrpo( 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 SLATB4 and generate a test
315* matrix with SLATMS.
316*
317 CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
318 $ MODE, CNDNUM, DIST )
319*
320 srnamt = 'SLATMS'
321 CALL slatms( 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 SLATMS.
326*
327 IF( info.NE.0 ) THEN
328 CALL alaerh( path, 'SLATMS', 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 scopy( izero-i1, work( iw ), 1,
342 $ a( ioff-izero+i1 ), 1 )
343 iw = iw + izero - i1
344 CALL scopy( i2-izero+1, work( iw ), 1,
345 $ a( ioff ), max( ldab-1, 1 ) )
346 ELSE
347 ioff = ( i1-1 )*ldab + 1
348 CALL scopy( 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 scopy( 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 sswap( izero-i1, a( ioff-izero+i1 ), 1,
384 $ work( iw ), 1 )
385 iw = iw + izero - i1
386 CALL sswap( i2-izero+1, a( ioff ),
387 $ max( ldab-1, 1 ), work( iw ), 1 )
388 ELSE
389 ioff = ( i1-1 )*ldab + 1
390 CALL sswap( 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 sswap( 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 slacpy( 'Full', kd+1, n, a, ldab, afac, ldab )
409 srnamt = 'SPBTRF'
410 CALL spbtrf( uplo, n, kd, afac, ldab, info )
411*
412* Check error code from SPBTRF.
413*
414 IF( info.NE.izero ) THEN
415 CALL alaerh( path, 'SPBTRF', 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 slacpy( 'Full', kd+1, n, afac, ldab, ainv,
431 $ ldab )
432 CALL spbt01( 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 slaset( 'Full', n, n, zero, one, ainv, lda )
455 srnamt = 'SPBTRS'
456 CALL spbtrs( uplo, n, kd, n, afac, ldab, ainv, lda,
457 $ info )
458*
459* Compute RCONDC = 1/(norm(A) * norm(inv(A))).
460*
461 anorm = slansb( '1', uplo, n, kd, a, ldab, rwork )
462 ainvnm = slange( '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 = 'SLARHS'
476 CALL slarhs( path, xtype, uplo, ' ', n, n, kd,
477 $ kd, nrhs, a, ldab, xact, lda, b,
478 $ lda, iseed, info )
479 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
480*
481 srnamt = 'SPBTRS'
482 CALL spbtrs( uplo, n, kd, nrhs, afac, ldab, x,
483 $ lda, info )
484*
485* Check error code from SPBTRS.
486*
487 IF( info.NE.0 )
488 $ CALL alaerh( path, 'SPBTRS', info, 0, uplo,
489 $ n, n, kd, kd, nrhs, imat, nfail,
490 $ nerrs, nout )
491*
492 CALL slacpy( 'Full', n, nrhs, b, lda, work,
493 $ lda )
494 CALL spbt02( 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 sget04( 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 = 'SPBRFS'
507 CALL spbrfs( 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 SPBRFS.
513*
514 IF( info.NE.0 )
515 $ CALL alaerh( path, 'SPBRFS', info, 0, uplo,
516 $ n, n, kd, kd, nrhs, imat, nfail,
517 $ nerrs, nout )
518*
519 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
520 $ result( 4 ) )
521 CALL spbt05( 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 = 'SPBCON'
544 CALL spbcon( uplo, n, kd, afac, ldab, anorm, rcond,
545 $ work, iwork, info )
546*
547* Check error code from SPBCON.
548*
549 IF( info.NE.0 )
550 $ CALL alaerh( path, 'SPBCON', info, 0, uplo, n,
551 $ n, kd, kd, -1, imat, nfail, nerrs,
552 $ nout )
553*
554 result( 7 ) = sget06( 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 SCHKPB
585*
slansb
real function slansb(norm, uplo, n, k, ab, ldab, work)
SLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition slansb.f:129
spbtrs
subroutine spbtrs(uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
SPBTRS
Definition spbtrs.f:121
spbcon
subroutine spbcon(uplo, n, kd, ab, ldab, anorm, rcond, work, iwork, info)
SPBCON
Definition spbcon.f:132
spbtrf
subroutine spbtrf(uplo, n, kd, ab, ldab, info)
SPBTRF
Definition spbtrf.f:142
spbrfs
subroutine spbrfs(uplo, n, kd, nrhs, ab, ldab, afb, ldafb, b, ldb, x, ldx, ferr, berr, work, iwork, info)
SPBRFS
Definition spbrfs.f:189
sswap
subroutine sswap(n, sx, incx, sy, incy)
SSWAP
Definition sswap.f:82
spbt02
subroutine spbt02(uplo, n, kd, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
SPBT02
Definition spbt02.f:136
serrpo
subroutine serrpo(path, nunit)
SERRPO
Definition serrpo.f:55
spbt01
subroutine spbt01(uplo, n, kd, a, lda, afac, ldafac, rwork, resid)
SPBT01
Definition spbt01.f:119
spbt05
subroutine spbt05(uplo, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
SPBT05
Definition spbt05.f:171

◆ schkpo()

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

SCHKPO

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

172*
173* -- LAPACK test routine --
174* -- LAPACK is a software package provided by Univ. of Tennessee, --
175* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176*
177* .. Scalar Arguments ..
178 LOGICAL TSTERR
179 INTEGER NMAX, NN, NNB, NNS, NOUT
180 REAL THRESH
181* ..
182* .. Array Arguments ..
183 LOGICAL DOTYPE( * )
184 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
185 REAL A( * ), AFAC( * ), AINV( * ), B( * ),
186 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
187* ..
188*
189* =====================================================================
190*
191* .. Parameters ..
192 REAL ZERO
193 parameter( zero = 0.0e+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 REAL ANORM, CNDNUM, RCOND, RCONDC
207* ..
208* .. Local Arrays ..
209 CHARACTER UPLOS( 2 )
210 INTEGER ISEED( 4 ), ISEEDY( 4 )
211 REAL RESULT( NTESTS )
212* ..
213* .. External Functions ..
214 REAL SGET06, SLANSY
215 EXTERNAL sget06, slansy
216* ..
217* .. External Subroutines ..
218 EXTERNAL alaerh, alahd, alasum, serrpo, sget04, slacpy,
219 $ slarhs, slatb4, slatms, spocon, sporfs, spot01,
220 $ spot02, spot03, spot05, spotrf, spotri, spotrs,
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 ) = 'Single 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 serrpo( 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 SLATB4 and generate a test matrix
289* with SLATMS.
290*
291 CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
292 $ CNDNUM, DIST )
293*
294 srnamt = 'SLATMS'
295 CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE,
296 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
297 $ INFO )
298*
299* Check error code from SLATMS.
300*
301 IF( info.NE.0 ) THEN
302 CALL alaerh( path, 'SLATMS', 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 slacpy( uplo, n, n, a, lda, afac, lda )
355 srnamt = 'SPOTRF'
356 CALL spotrf( uplo, n, afac, lda, info )
357*
358* Check error code from SPOTRF.
359*
360 IF( info.NE.izero ) THEN
361 CALL alaerh( path, 'SPOTRF', 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 slacpy( uplo, n, n, afac, lda, ainv, lda )
376 CALL spot01( 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 slacpy( uplo, n, n, afac, lda, ainv, lda )
383 srnamt = 'SPOTRI'
384 CALL spotri( uplo, n, ainv, lda, info )
385*
386* Check error code from SPOTRI.
387*
388 IF( info.NE.0 )
389 $ CALL alaerh( path, 'SPOTRI', info, 0, uplo, n, n,
390 $ -1, -1, -1, imat, nfail, nerrs, nout )
391*
392 CALL spot03( 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 = 'SLARHS'
422 CALL slarhs( path, xtype, uplo, ' ', n, n, kl, ku,
423 $ nrhs, a, lda, xact, lda, b, lda,
424 $ iseed, info )
425 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
426*
427 srnamt = 'SPOTRS'
428 CALL spotrs( uplo, n, nrhs, afac, lda, x, lda,
429 $ info )
430*
431* Check error code from SPOTRS.
432*
433 IF( info.NE.0 )
434 $ CALL alaerh( path, 'SPOTRS', info, 0, uplo, n,
435 $ n, -1, -1, nrhs, imat, nfail,
436 $ nerrs, nout )
437*
438 CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
439 CALL spot02( 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 sget04( 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 = 'SPORFS'
452 CALL sporfs( 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 SPORFS.
457*
458 IF( info.NE.0 )
459 $ CALL alaerh( path, 'SPORFS', info, 0, uplo, n,
460 $ n, -1, -1, nrhs, imat, nfail,
461 $ nerrs, nout )
462*
463 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
464 $ result( 5 ) )
465 CALL spot05( 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 = slansy( '1', uplo, n, a, lda, rwork )
488 srnamt = 'SPOCON'
489 CALL spocon( uplo, n, afac, lda, anorm, rcond, work,
490 $ iwork, info )
491*
492* Check error code from SPOCON.
493*
494 IF( info.NE.0 )
495 $ CALL alaerh( path, 'SPOCON', info, 0, uplo, n, n,
496 $ -1, -1, -1, imat, nfail, nerrs, nout )
497*
498 result( 8 ) = sget06( rcond, rcondc )
499*
500* Print the test ratio if it is .GE. THRESH.
501*
502 IF( result( 8 ).GE.thresh ) THEN
503 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
504 $ CALL alahd( nout, path )
505 WRITE( nout, fmt = 9997 )uplo, n, imat, 8,
506 $ result( 8 )
507 nfail = nfail + 1
508 END IF
509 nrun = nrun + 1
510 90 CONTINUE
511 100 CONTINUE
512 110 CONTINUE
513 120 CONTINUE
514*
515* Print a summary of the results.
516*
517 CALL alasum( path, nout, nfail, nrun, nerrs )
518*
519 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
520 $ i2, ', test ', i2, ', ratio =', g12.5 )
521 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
522 $ i2, ', test(', i2, ') =', g12.5 )
523 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
524 $ ', test(', i2, ') =', g12.5 )
525 RETURN
526*
527* End of SCHKPO
528*
sporfs
subroutine sporfs(uplo, n, nrhs, a, lda, af, ldaf, b, ldb, x, ldx, ferr, berr, work, iwork, info)
SPORFS
Definition sporfs.f:183
spotrs
subroutine spotrs(uplo, n, nrhs, a, lda, b, ldb, info)
SPOTRS
Definition spotrs.f:110
spocon
subroutine spocon(uplo, n, a, lda, anorm, rcond, work, iwork, info)
SPOCON
Definition spocon.f:121
spotri
subroutine spotri(uplo, n, a, lda, info)
SPOTRI
Definition spotri.f:95
spotrf
subroutine spotrf(uplo, n, a, lda, info)
SPOTRF
Definition spotrf.f:107
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
spot02
subroutine spot02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
SPOT02
Definition spot02.f:127
spot05
subroutine spot05(uplo, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
SPOT05
Definition spot05.f:164
spot03
subroutine spot03(uplo, n, a, lda, ainv, ldainv, work, ldwork, rwork, rcond, resid)
SPOT03
Definition spot03.f:125
spot01
subroutine spot01(uplo, n, a, lda, afac, ldafac, rwork, resid)
SPOT01
Definition spot01.f:104

◆ schkpp()

subroutine schkpp ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nns,
integer, dimension( * ) nsval,
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 )

SCHKPP

Purpose:
!>
!> SCHKPP tests SPPTRF, -TRI, -TRS, -RFS, and -CON
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is REAL
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is REAL array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AFAC
!>          AFAC is REAL array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AINV
!>          AINV is REAL array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is REAL array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is REAL array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is REAL array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is REAL array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL array, dimension
!>                      (max(NMAX,2*NSMAX))
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (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 schkpp.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 REAL THRESH
172* ..
173* .. Array Arguments ..
174 LOGICAL DOTYPE( * )
175 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
176 REAL A( * ), AFAC( * ), AINV( * ), B( * ),
177 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 REAL ZERO
184 parameter( zero = 0.0e+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 REAL ANORM, CNDNUM, RCOND, RCONDC
198* ..
199* .. Local Arrays ..
200 CHARACTER PACKS( 2 ), UPLOS( 2 )
201 INTEGER ISEED( 4 ), ISEEDY( 4 )
202 REAL RESULT( NTESTS )
203* ..
204* .. External Functions ..
205 REAL SGET06, SLANSP
206 EXTERNAL sget06, slansp
207* ..
208* .. External Subroutines ..
209 EXTERNAL alaerh, alahd, alasum, scopy, serrpo, sget04,
210 $ slacpy, slarhs, slatb4, slatms, sppcon, spprfs,
211 $ sppt01, sppt02, sppt03, sppt05, spptrf, spptri,
212 $ spptrs
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 ) = 'Single 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 serrpo( 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 SLATB4 and generate a test matrix
279* with SLATMS.
280*
281 CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
282 $ CNDNUM, DIST )
283*
284 srnamt = 'SLATMS'
285 CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE,
286 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
287 $ INFO )
288*
289* Check error code from SLATMS.
290*
291 IF( info.NE.0 ) THEN
292 CALL alaerh( path, 'SLATMS', 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 scopy( npp, a, 1, afac, 1 )
340 srnamt = 'SPPTRF'
341 CALL spptrf( uplo, n, afac, info )
342*
343* Check error code from SPPTRF.
344*
345 IF( info.NE.izero ) THEN
346 CALL alaerh( path, 'SPPTRF', 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 scopy( npp, afac, 1, ainv, 1 )
360 CALL sppt01( uplo, n, a, ainv, rwork, result( 1 ) )
361*
362*+ TEST 2
363* Form the inverse and compute the residual.
364*
365 CALL scopy( npp, afac, 1, ainv, 1 )
366 srnamt = 'SPPTRI'
367 CALL spptri( uplo, n, ainv, info )
368*
369* Check error code from SPPTRI.
370*
371 IF( info.NE.0 )
372 $ CALL alaerh( path, 'SPPTRI', info, 0, uplo, n, n, -1,
373 $ -1, -1, imat, nfail, nerrs, nout )
374*
375 CALL sppt03( 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 = 'SLARHS'
399 CALL slarhs( path, xtype, uplo, ' ', n, n, kl, ku,
400 $ nrhs, a, lda, xact, lda, b, lda, iseed,
401 $ info )
402 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
403*
404 srnamt = 'SPPTRS'
405 CALL spptrs( uplo, n, nrhs, afac, x, lda, info )
406*
407* Check error code from SPPTRS.
408*
409 IF( info.NE.0 )
410 $ CALL alaerh( path, 'SPPTRS', info, 0, uplo, n, n,
411 $ -1, -1, nrhs, imat, nfail, nerrs,
412 $ nout )
413*
414 CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
415 CALL sppt02( 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 sget04( 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 = 'SPPRFS'
428 CALL spprfs( uplo, n, nrhs, a, afac, b, lda, x, lda,
429 $ rwork, rwork( nrhs+1 ), work, iwork,
430 $ info )
431*
432* Check error code from SPPRFS.
433*
434 IF( info.NE.0 )
435 $ CALL alaerh( path, 'SPPRFS', info, 0, uplo, n, n,
436 $ -1, -1, nrhs, imat, nfail, nerrs,
437 $ nout )
438*
439 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
440 $ result( 5 ) )
441 CALL sppt05( 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 = slansp( '1', uplo, n, a, rwork )
464 srnamt = 'SPPCON'
465 CALL sppcon( uplo, n, afac, anorm, rcond, work, iwork,
466 $ info )
467*
468* Check error code from SPPCON.
469*
470 IF( info.NE.0 )
471 $ CALL alaerh( path, 'SPPCON', info, 0, uplo, n, n, -1,
472 $ -1, -1, imat, nfail, nerrs, nout )
473*
474 result( 8 ) = sget06( 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 SCHKPP
501*
slansp
real function slansp(norm, uplo, n, ap, work)
SLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition slansp.f:114
spptrf
subroutine spptrf(uplo, n, ap, info)
SPPTRF
Definition spptrf.f:119
spptrs
subroutine spptrs(uplo, n, nrhs, ap, b, ldb, info)
SPPTRS
Definition spptrs.f:108
spptri
subroutine spptri(uplo, n, ap, info)
SPPTRI
Definition spptri.f:93
sppcon
subroutine sppcon(uplo, n, ap, anorm, rcond, work, iwork, info)
SPPCON
Definition sppcon.f:118
spprfs
subroutine spprfs(uplo, n, nrhs, ap, afp, b, ldb, x, ldx, ferr, berr, work, iwork, info)
SPPRFS
Definition spprfs.f:171
sppt03
subroutine sppt03(uplo, n, a, ainv, work, ldwork, rwork, rcond, resid)
SPPT03
Definition sppt03.f:110
sppt05
subroutine sppt05(uplo, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
SPPT05
Definition sppt05.f:156
sppt01
subroutine sppt01(uplo, n, a, afac, rwork, resid)
SPPT01
Definition sppt01.f:93
sppt02
subroutine sppt02(uplo, n, nrhs, a, x, ldx, b, ldb, rwork, resid)
SPPT02
Definition sppt02.f:122

◆ schkps()

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

SCHKPS

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

Definition at line 151 of file schkps.f.

154*
155* -- LAPACK test routine --
156* -- LAPACK is a software package provided by Univ. of Tennessee, --
157* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
158*
159* .. Scalar Arguments ..
160 REAL THRESH
161 INTEGER NMAX, NN, NNB, NOUT, NRANK
162 LOGICAL TSTERR
163* ..
164* .. Array Arguments ..
165 REAL A( * ), AFAC( * ), PERM( * ), RWORK( * ),
166 $ WORK( * )
167 INTEGER NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * )
168 LOGICAL DOTYPE( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 REAL ONE
175 parameter( one = 1.0e+0 )
176 INTEGER NTYPES
177 parameter( ntypes = 9 )
178* ..
179* .. Local Scalars ..
180 REAL ANORM, CNDNUM, RESULT, TOL
181 INTEGER COMPRANK, I, IMAT, IN, INB, INFO, IRANK, IUPLO,
182 $ IZERO, KL, KU, LDA, MODE, N, NB, NERRS, NFAIL,
183 $ NIMAT, NRUN, RANK, RANKDIFF
184 CHARACTER DIST, TYPE, UPLO
185 CHARACTER*3 PATH
186* ..
187* .. Local Arrays ..
188 INTEGER ISEED( 4 ), ISEEDY( 4 )
189 CHARACTER UPLOS( 2 )
190* ..
191* .. External Subroutines ..
192 EXTERNAL alaerh, alahd, alasum, serrps, slacpy, slatb5,
193 $ slatmt, spst01, spstrf, xlaenv
194* ..
195* .. Scalars in Common ..
196 INTEGER INFOT, NUNIT
197 LOGICAL LERR, OK
198 CHARACTER*32 SRNAMT
199* ..
200* .. Common blocks ..
201 COMMON / infoc / infot, nunit, ok, lerr
202 COMMON / srnamc / srnamt
203* ..
204* .. Intrinsic Functions ..
205 INTRINSIC max, real, ceiling
206* ..
207* .. Data statements ..
208 DATA iseedy / 1988, 1989, 1990, 1991 /
209 DATA uplos / 'U', 'L' /
210* ..
211* .. Executable Statements ..
212*
213* Initialize constants and the random number seed.
214*
215 path( 1: 1 ) = 'Single 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 serrps( 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 * real( rankval( irank ) ) )
259 $ / 100.e+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 SLATB5 and generate a test matrix
268* with SLATMT.
269*
270 CALL slatb5( path, imat, n, TYPE, KL, KU, ANORM,
271 $ MODE, CNDNUM, DIST )
272*
273 srnamt = 'SLATMT'
274 CALL slatmt( 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 SLATMT.
279*
280 IF( info.NE.0 ) THEN
281 CALL alaerh( path, 'SLATMT', 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 slacpy( uplo, n, n, a, lda, afac, lda )
297 srnamt = 'SPSTRF'
298*
299* Use default tolerance
300*
301 tol = -one
302 CALL spstrf( uplo, n, afac, lda, piv, comprank,
303 $ tol, work, info )
304*
305* Check error code from SPSTRF.
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, 'SPSTRF', 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 spst01( 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 SCHKPS
359*
spstrf
subroutine spstrf(uplo, n, a, lda, piv, rank, tol, work, info)
SPSTRF computes the Cholesky factorization with complete pivoting of a real symmetric positive semide...
Definition spstrf.f:141
slatmt
subroutine slatmt(m, n, dist, iseed, sym, d, mode, cond, dmax, rank, kl, ku, pack, a, lda, work, info)
SLATMT
Definition slatmt.f:331
serrps
subroutine serrps(path, nunit)
SERRPS
Definition serrps.f:55
slatb5
subroutine slatb5(path, imat, n, type, kl, ku, anorm, mode, cndnum, dist)
SLATB5
Definition slatb5.f:114
spst01
subroutine spst01(uplo, n, a, lda, afac, ldafac, perm, ldperm, piv, rwork, resid, rank)
SPST01
Definition spst01.f:134

◆ schkpt()

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

SCHKPT

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

Definition at line 144 of file schkpt.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 REAL THRESH
155* ..
156* .. Array Arguments ..
157 LOGICAL DOTYPE( * )
158 INTEGER NSVAL( * ), NVAL( * )
159 REAL A( * ), B( * ), D( * ), E( * ), RWORK( * ),
160 $ WORK( * ), X( * ), XACT( * )
161* ..
162*
163* =====================================================================
164*
165* .. Parameters ..
166 REAL ONE, ZERO
167 parameter( one = 1.0e+0, zero = 0.0e+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 REAL AINVNM, ANORM, COND, DMAX, RCOND, RCONDC
181* ..
182* .. Local Arrays ..
183 INTEGER ISEED( 4 ), ISEEDY( 4 )
184 REAL RESULT( NTESTS ), Z( 3 )
185* ..
186* .. External Functions ..
187 INTEGER ISAMAX
188 REAL SASUM, SGET06, SLANST
189 EXTERNAL isamax, sasum, sget06, slanst
190* ..
191* .. External Subroutines ..
192 EXTERNAL alaerh, alahd, alasum, scopy, serrgt, sget04,
193 $ slacpy, slaptm, slarnv, slatb4, slatms, sptcon,
194 $ sptrfs, sptt01, sptt02, sptt05, spttrf, spttrs,
195 $ sscal
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 ) = 'Single 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 serrgt( 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 SLATB4.
247*
248 CALL slatb4( 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 = 'SLATMS'
258 CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE, COND,
259 $ ANORM, KL, KU, 'B', A, 2, WORK, INFO )
260*
261* Check the error code from SLATMS.
262*
263 IF( info.NE.0 ) THEN
264 CALL alaerh( path, 'SLATMS', 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 slarnv( 2, iseed, n, d )
290 CALL slarnv( 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 = isamax( n, d, 1 )
308 dmax = d( ix )
309 CALL sscal( n, anorm / dmax, d, 1 )
310 CALL sscal( 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 scopy( n, d, 1, d( n+1 ), 1 )
365 IF( n.GT.1 )
366 $ CALL scopy( 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 spttrf( n, d( n+1 ), e( n+1 ), info )
373*
374* Check error code from SPTTRF.
375*
376 IF( info.NE.izero ) THEN
377 CALL alaerh( path, 'SPTTRF', 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 sptt01( 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 = slanst( '1', n, d, e )
405*
406* Use SPTTRS 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 spttrs( n, 1, d( n+1 ), e( n+1 ), x, lda, info )
416 ainvnm = max( ainvnm, sasum( 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 slarnv( 2, iseed, n, xact( ix ) )
428 ix = ix + lda
429 60 CONTINUE
430*
431* Set the right hand side.
432*
433 CALL slaptm( 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 slacpy( 'Full', n, nrhs, b, lda, x, lda )
440 CALL spttrs( n, nrhs, d( n+1 ), e( n+1 ), x, lda, info )
441*
442* Check error code from SPTTRS.
443*
444 IF( info.NE.0 )
445 $ CALL alaerh( path, 'SPTTRS', info, 0, ' ', n, n, -1,
446 $ -1, nrhs, imat, nfail, nerrs, nout )
447*
448 CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
449 CALL sptt02( 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 sget04( 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 = 'SPTRFS'
462 CALL sptrfs( 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 SPTRFS.
466*
467 IF( info.NE.0 )
468 $ CALL alaerh( path, 'SPTRFS', info, 0, ' ', n, n, -1,
469 $ -1, nrhs, imat, nfail, nerrs, nout )
470*
471 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
472 $ result( 4 ) )
473 CALL sptt05( 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 = 'SPTCON'
497 CALL sptcon( n, d( n+1 ), e( n+1 ), anorm, rcond, rwork,
498 $ info )
499*
500* Check error code from SPTCON.
501*
502 IF( info.NE.0 )
503 $ CALL alaerh( path, 'SPTCON', info, 0, ' ', n, n, -1, -1,
504 $ -1, imat, nfail, nerrs, nout )
505*
506 result( 7 ) = sget06( 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 SCHKPT
531*
slanst
real function slanst(norm, n, d, e)
SLANST returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition slanst.f:100
spttrf
subroutine spttrf(n, d, e, info)
SPTTRF
Definition spttrf.f:91
isamax
integer function isamax(n, sx, incx)
ISAMAX
Definition isamax.f:71
sptcon
subroutine sptcon(n, d, e, anorm, rcond, work, info)
SPTCON
Definition sptcon.f:118
sptrfs
subroutine sptrfs(n, nrhs, d, e, df, ef, b, ldb, x, ldx, ferr, berr, work, info)
SPTRFS
Definition sptrfs.f:163
spttrs
subroutine spttrs(n, nrhs, d, e, b, ldb, info)
SPTTRS
Definition spttrs.f:109
serrgt
subroutine serrgt(path, nunit)
SERRGT
Definition serrgt.f:55
sptt01
subroutine sptt01(n, d, e, df, ef, work, resid)
SPTT01
Definition sptt01.f:91
sptt02
subroutine sptt02(n, nrhs, d, e, x, ldx, b, ldb, resid)
SPTT02
Definition sptt02.f:104
slaptm
subroutine slaptm(n, nrhs, alpha, d, e, x, ldx, beta, b, ldb)
SLAPTM
Definition slaptm.f:116
sptt05
subroutine sptt05(n, nrhs, d, e, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
SPTT05
Definition sptt05.f:150

◆ schkq3()

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

SCHKQ3

Purpose:
!>
!> SCHKQ3 tests SGEQP3.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB and NX contained in the
!>          vectors NBVAL and NXVAL.  The blocking parameters are used
!>          in pairs (NB,NX).
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NXVAL
!>          NXVAL is INTEGER array, dimension (NNB)
!>          The values of the crossover point NX.
!>
[in]THRESH
!>          THRESH is REAL
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[out]A
!>          A is REAL 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 REAL array, dimension (MMAX*NMAX)
!>
[out]S
!>          S is REAL array, dimension
!>                      (min(MMAX,NMAX))
!>
[out]TAU
!>          TAU is REAL array, dimension (MMAX)
!>
[out]WORK
!>          WORK is REAL 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 schkq3.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 REAL THRESH
161* ..
162* .. Array Arguments ..
163 LOGICAL DOTYPE( * )
164 INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NVAL( * ),
165 $ NXVAL( * )
166 REAL 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 REAL ONE, ZERO
178 parameter( one = 1.0e0, zero = 0.0e0 )
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 REAL EPS
186* ..
187* .. Local Arrays ..
188 INTEGER ISEED( 4 ), ISEEDY( 4 )
189 REAL RESULT( NTESTS )
190* ..
191* .. External Functions ..
192 REAL SLAMCH, SQPT01, SQRT11, SQRT12
193 EXTERNAL slamch, sqpt01, sqrt11, sqrt12
194* ..
195* .. External Subroutines ..
196 EXTERNAL alahd, alasum, icopy, sgeqp3, slacpy, slaord,
197 $ slaset, slatms, 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 ) = 'Single 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 = slamch( '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 slaset( 'Full', m, n, zero, zero, copya, lda )
269 DO 30 i = 1, mnmin
270 s( i ) = zero
271 30 CONTINUE
272 ELSE
273 CALL slatms( 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 slaord( '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 slacpy( '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 = 'SGEQP3'
319 CALL sgeqp3( m, n, a, lda, iwork( n+1 ), tau, work,
320 $ lw, info )
321*
322* Compute norm(svd(a) - svd(r))
323*
324 result( 1 ) = sqrt12( m, n, a, lda, s, work,
325 $ lwork )
326*
327* Compute norm( A*P - Q*R )
328*
329 result( 2 ) = sqpt01( m, n, mnmin, copya, a, lda, tau,
330 $ iwork( n+1 ), work, lwork )
331*
332* Compute Q'*Q
333*
334 result( 3 ) = sqrt11( 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 )'SGEQP3', 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 SCHKQ3
364*
icopy
subroutine icopy(n, sx, incx, sy, incy)
ICOPY
Definition icopy.f:75
sgeqp3
subroutine sgeqp3(m, n, a, lda, jpvt, tau, work, lwork, info)
SGEQP3
Definition sgeqp3.f:151
sqrt11
real function sqrt11(m, k, a, lda, tau, work, lwork)
SQRT11
Definition sqrt11.f:98
sqrt12
real function sqrt12(m, n, a, lda, s, work, lwork)
SQRT12
Definition sqrt12.f:89
sqpt01
real function sqpt01(m, n, k, a, af, lda, tau, jpvt, work, lwork)
SQPT01
Definition sqpt01.f:120
slaord
subroutine slaord(job, n, x, incx)
SLAORD
Definition slaord.f:73

◆ schkql()

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

SCHKQL

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

Definition at line 193 of file schkql.f.

196*
197* -- LAPACK test routine --
198* -- LAPACK is a software package provided by Univ. of Tennessee, --
199* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
200*
201* .. Scalar Arguments ..
202 LOGICAL TSTERR
203 INTEGER NM, NMAX, NN, NNB, NOUT, NRHS
204 REAL THRESH
205* ..
206* .. Array Arguments ..
207 LOGICAL DOTYPE( * )
208 INTEGER MVAL( * ), NBVAL( * ), NVAL( * ),
209 $ NXVAL( * )
210 REAL 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 REAL ZERO
223 parameter( zero = 0.0e0 )
224* ..
225* .. Local Scalars ..
226 CHARACTER DIST, TYPE
227 CHARACTER*3 PATH
228 INTEGER I, IK, IM, IMAT, IN, INB, INFO, K, KL, KU, LDA,
229 $ LWORK, M, MINMN, MODE, N, NB, NERRS, NFAIL, NK,
230 $ NRUN, NT, NX
231 REAL ANORM, CNDNUM
232* ..
233* .. Local Arrays ..
234 INTEGER ISEED( 4 ), ISEEDY( 4 ), KVAL( 4 )
235 REAL RESULT( NTESTS )
236* ..
237* .. External Subroutines ..
238 EXTERNAL alaerh, alahd, alasum, serrql, sgeqls, sget02,
239 $ slacpy, slarhs, slatb4, slatms, sqlt01, sqlt02,
240 $ sqlt03, 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 ) = 'Single 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 serrql( 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 SLATB4 and generate a test matrix
298* with SLATMS.
299*
300 CALL slatb4( path, imat, m, n, TYPE, KL, KU, ANORM, MODE,
301 $ CNDNUM, DIST )
302*
303 srnamt = 'SLATMS'
304 CALL slatms( 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 SLATMS.
309*
310 IF( info.NE.0 ) THEN
311 CALL alaerh( path, 'SLATMS', 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 SQLT01; other values are
318* used in the calls of SQLT02, 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 SGEQLF
353*
354 CALL sqlt01( m, n, a, af, aq, al, lda, tau,
355 $ work, lwork, rwork, result( 1 ) )
356 ELSE IF( m.GE.n ) THEN
357*
358* Test SORGQL, using factorization
359* returned by SQLT01
360*
361 CALL sqlt02( 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 SORMQL, using factorization returned
367* by SQLT01
368*
369 CALL sqlt03( 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 SGEQLS 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 = 'SLARHS'
383 CALL slarhs( path, 'New', 'Full',
384 $ 'No transpose', m, n, 0, 0,
385 $ nrhs, a, lda, xact, lda, b, lda,
386 $ iseed, info )
387*
388 CALL slacpy( 'Full', m, nrhs, b, lda, x,
389 $ lda )
390 srnamt = 'SGEQLS'
391 CALL sgeqls( m, n, nrhs, af, lda, tau, x,
392 $ lda, work, lwork, info )
393*
394* Check error code from SGEQLS.
395*
396 IF( info.NE.0 )
397 $ CALL alaerh( path, 'SGEQLS', info, 0, ' ',
398 $ m, n, nrhs, -1, nb, imat,
399 $ nfail, nerrs, nout )
400*
401 CALL sget02( '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 SCHKQL
436*
sqlt03
subroutine sqlt03(m, n, k, af, c, cc, q, lda, tau, work, lwork, rwork, result)
SQLT03
Definition sqlt03.f:136
sqlt02
subroutine sqlt02(m, n, k, a, af, q, l, lda, tau, work, lwork, rwork, result)
SQLT02
Definition sqlt02.f:136
serrql
subroutine serrql(path, nunit)
SERRQL
Definition serrql.f:55
sqlt01
subroutine sqlt01(m, n, a, af, q, l, lda, tau, work, lwork, rwork, result)
SQLT01
Definition sqlt01.f:126
sgeqls
subroutine sgeqls(m, n, nrhs, a, lda, tau, b, ldb, work, lwork, info)
SGEQLS
Definition sgeqls.f:122

◆ schkqr()

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

SCHKQR

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

Definition at line 198 of file schkqr.f.

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

◆ schkqrt()

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

SCHKQRT

Purpose:
!>
!> SCHKQRT tests SGEQRT and SGEMQRT.
!>
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 98 of file schkqrt.f.

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

◆ schkqrtp()

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

SCHKQRTP

Purpose:
!>
!> SCHKQRTP tests STPQRT and STPMQRT.
!>
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 schkqrtp.f.

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

◆ schkrfp()

program schkrfp

SCHKRFP

Purpose:
!>
!> SCHKRFP is the main test program for the REAL 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 schkrfp.f.

◆ schkrq()

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

SCHKRQ

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

Definition at line 198 of file schkrq.f.

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

◆ schksp()

subroutine schksp ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nns,
integer, dimension( * ) nsval,
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 )

SCHKSP

Purpose:
!>
!> SCHKSP tests SSPTRF, -TRI, -TRS, -RFS, and -CON
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is REAL
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is REAL array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AFAC
!>          AFAC is REAL array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AINV
!>          AINV is REAL array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]B
!>          B is REAL array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is REAL array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is REAL array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is REAL array, dimension
!>                      (NMAX*max(2,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL 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 schksp.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 REAL THRESH
172* ..
173* .. Array Arguments ..
174 LOGICAL DOTYPE( * )
175 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
176 REAL A( * ), AFAC( * ), AINV( * ), B( * ),
177 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 REAL ZERO
184 parameter( zero = 0.0e+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 REAL ANORM, CNDNUM, RCOND, RCONDC
198* ..
199* .. Local Arrays ..
200 CHARACTER UPLOS( 2 )
201 INTEGER ISEED( 4 ), ISEEDY( 4 )
202 REAL RESULT( NTESTS )
203* ..
204* .. External Functions ..
205 LOGICAL LSAME
206 REAL SGET06, SLANSP
207 EXTERNAL lsame, sget06, slansp
208* ..
209* .. External Subroutines ..
210 EXTERNAL alaerh, alahd, alasum, scopy, serrsy, sget04,
211 $ slacpy, slarhs, slatb4, slatms, sppt02, sppt03,
212 $ sppt05, sspcon, ssprfs, sspt01, ssptrf, ssptri,
213 $ ssptrs
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 ) = 'Single 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 serrsy( 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 SLATB4 and generate a test matrix
285* with SLATMS.
286*
287 CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
288 $ CNDNUM, DIST )
289*
290 srnamt = 'SLATMS'
291 CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE,
292 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
293 $ INFO )
294*
295* Check error code from SLATMS.
296*
297 IF( info.NE.0 ) THEN
298 CALL alaerh( path, 'SLATMS', 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 scopy( npp, a, 1, afac, 1 )
374 srnamt = 'SSPTRF'
375 CALL ssptrf( 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 SSPTRF.
395*
396 IF( info.NE.k )
397 $ CALL alaerh( path, 'SSPTRF', 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 sspt01( 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 scopy( npp, afac, 1, ainv, 1 )
417 srnamt = 'SSPTRI'
418 CALL ssptri( uplo, n, ainv, iwork, work, info )
419*
420* Check error code from SSPTRI.
421*
422 IF( info.NE.0 )
423 $ CALL alaerh( path, 'SSPTRI', info, 0, uplo, n, n,
424 $ -1, -1, -1, imat, nfail, nerrs, nout )
425*
426 CALL sppt03( 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 = 'SLARHS'
459 CALL slarhs( path, xtype, uplo, ' ', n, n, kl, ku,
460 $ nrhs, a, lda, xact, lda, b, lda, iseed,
461 $ info )
462 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
463*
464 srnamt = 'SSPTRS'
465 CALL ssptrs( uplo, n, nrhs, afac, iwork, x, lda,
466 $ info )
467*
468* Check error code from SSPTRS.
469*
470 IF( info.NE.0 )
471 $ CALL alaerh( path, 'SSPTRS', info, 0, uplo, n, n,
472 $ -1, -1, nrhs, imat, nfail, nerrs,
473 $ nout )
474*
475 CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
476 CALL sppt02( 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 sget04( 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 = 'SSPRFS'
489 CALL ssprfs( 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 SSPRFS.
494*
495 IF( info.NE.0 )
496 $ CALL alaerh( path, 'SSPRFS', info, 0, uplo, n, n,
497 $ -1, -1, nrhs, imat, nfail, nerrs,
498 $ nout )
499*
500 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
501 $ result( 5 ) )
502 CALL sppt05( 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 = slansp( '1', uplo, n, a, rwork )
526 srnamt = 'SSPCON'
527 CALL sspcon( uplo, n, afac, iwork, anorm, rcond, work,
528 $ iwork( n+1 ), info )
529*
530* Check error code from SSPCON.
531*
532 IF( info.NE.0 )
533 $ CALL alaerh( path, 'SSPCON', info, 0, uplo, n, n, -1,
534 $ -1, -1, imat, nfail, nerrs, nout )
535*
536 result( 8 ) = sget06( 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 SCHKSP
563*
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
ssptrf
subroutine ssptrf(uplo, n, ap, ipiv, info)
SSPTRF
Definition ssptrf.f:157
ssprfs
subroutine ssprfs(uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
SSPRFS
Definition ssprfs.f:179
sspcon
subroutine sspcon(uplo, n, ap, ipiv, anorm, rcond, work, iwork, info)
SSPCON
Definition sspcon.f:125
ssptri
subroutine ssptri(uplo, n, ap, ipiv, work, info)
SSPTRI
Definition ssptri.f:109
ssptrs
subroutine ssptrs(uplo, n, nrhs, ap, ipiv, b, ldb, info)
SSPTRS
Definition ssptrs.f:115
serrsy
subroutine serrsy(path, nunit)
SERRSY
Definition serrsy.f:55
sspt01
subroutine sspt01(uplo, n, a, afac, ipiv, c, ldc, rwork, resid)
SSPT01
Definition sspt01.f:110

◆ schksy()

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

SCHKSY

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

Definition at line 167 of file schksy.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 REAL THRESH
179* ..
180* .. Array Arguments ..
181 LOGICAL DOTYPE( * )
182 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
183 REAL A( * ), AFAC( * ), AINV( * ), B( * ),
184 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
185* ..
186*
187* =====================================================================
188*
189* .. Parameters ..
190 REAL ZERO
191 parameter( zero = 0.0e+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 REAL ANORM, CNDNUM, RCOND, RCONDC
205* ..
206* .. Local Arrays ..
207 CHARACTER UPLOS( 2 )
208 INTEGER ISEED( 4 ), ISEEDY( 4 )
209 REAL RESULT( NTESTS )
210* ..
211* .. External Functions ..
212 REAL SGET06, SLANSY
213 EXTERNAL sget06, slansy
214* ..
215* .. External Subroutines ..
216 EXTERNAL alaerh, alahd, alasum, serrsy, sget04, slacpy,
217 $ slarhs, slatb4, slatms, spot02, spot03, spot05,
218 $ ssycon, ssyconv, ssyrfs, ssyt01, ssytrf,
219 $ ssytri2, ssytrs, ssytrs2, 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 ) = 'Single 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 serrsy( 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* Set up parameters with SLATB4 for the matrix generator
296* based on the type of matrix to be generated.
297*
298 CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
299 $ CNDNUM, DIST )
300*
301* Generate a matrix with SLATMS.
302*
303 srnamt = 'SLATMS'
304 CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE,
305 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
306 $ INFO )
307*
308* Check error code from SLATMS and handle error.
309*
310 IF( info.NE.0 ) THEN
311 CALL alaerh( path, 'SLATMS', info, 0, uplo, n, n, -1,
312 $ -1, -1, imat, nfail, nerrs, nout )
313*
314* Skip all tests for this generated matrix
315*
316 GO TO 160
317 END IF
318*
319* For matrix types 3-6, zero one or more rows and
320* columns of the matrix to test that INFO is returned
321* correctly.
322*
323 IF( zerot ) THEN
324 IF( imat.EQ.3 ) THEN
325 izero = 1
326 ELSE IF( imat.EQ.4 ) THEN
327 izero = n
328 ELSE
329 izero = n / 2 + 1
330 END IF
331*
332 IF( imat.LT.6 ) THEN
333*
334* Set row and column IZERO to zero.
335*
336 IF( iuplo.EQ.1 ) THEN
337 ioff = ( izero-1 )*lda
338 DO 20 i = 1, izero - 1
339 a( ioff+i ) = zero
340 20 CONTINUE
341 ioff = ioff + izero
342 DO 30 i = izero, n
343 a( ioff ) = zero
344 ioff = ioff + lda
345 30 CONTINUE
346 ELSE
347 ioff = izero
348 DO 40 i = 1, izero - 1
349 a( ioff ) = zero
350 ioff = ioff + lda
351 40 CONTINUE
352 ioff = ioff - izero
353 DO 50 i = izero, n
354 a( ioff+i ) = zero
355 50 CONTINUE
356 END IF
357 ELSE
358 IF( iuplo.EQ.1 ) THEN
359*
360* Set the first IZERO rows and columns to zero.
361*
362 ioff = 0
363 DO 70 j = 1, n
364 i2 = min( j, izero )
365 DO 60 i = 1, i2
366 a( ioff+i ) = zero
367 60 CONTINUE
368 ioff = ioff + lda
369 70 CONTINUE
370 ELSE
371*
372* Set the last IZERO rows and columns to zero.
373*
374 ioff = 0
375 DO 90 j = 1, n
376 i1 = max( j, izero )
377 DO 80 i = i1, n
378 a( ioff+i ) = zero
379 80 CONTINUE
380 ioff = ioff + lda
381 90 CONTINUE
382 END IF
383 END IF
384 ELSE
385 izero = 0
386 END IF
387*
388* End generate the test matrix A.
389*
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 slacpy( 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 = 'SSYTRF'
414 CALL ssytrf( 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 SSYTRF and handle error.
435*
436 IF( info.NE.k )
437 $ CALL alaerh( path, 'SSYTRF', 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 ssyt01( 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 slacpy( uplo, n, n, afac, lda, ainv, lda )
463 srnamt = 'SSYTRI2'
464 lwork = (n+nb+1)*(nb+3)
465 CALL ssytri2( uplo, n, ainv, lda, iwork, work,
466 $ lwork, info )
467*
468* Check error code from SSYTRI2 and handle error.
469*
470 IF( info.NE.0 )
471 $ CALL alaerh( path, 'SSYTRI2', 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 spot03( 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 DSYTRS)
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 = 'SLARHS'
522 CALL slarhs( path, xtype, uplo, ' ', n, n, kl, ku,
523 $ nrhs, a, lda, xact, lda, b, lda,
524 $ iseed, info )
525 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
526*
527 srnamt = 'SSYTRS'
528 CALL ssytrs( uplo, n, nrhs, afac, lda, iwork, x,
529 $ lda, info )
530*
531* Check error code from SSYTRS and handle error.
532*
533 IF( info.NE.0 )
534 $ CALL alaerh( path, 'SSYTRS', info, 0, uplo, n,
535 $ n, -1, -1, nrhs, imat, nfail,
536 $ nerrs, nout )
537*
538 CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
539*
540* Compute the residual for the solution
541*
542 CALL spot02( uplo, n, nrhs, a, lda, x, lda, work,
543 $ lda, rwork, result( 3 ) )
544*
545*+ TEST 4 (Using DSYTRS2)
546* Solve and compute residual for A * X = B.
547*
548* Choose a set of NRHS random solution vectors
549* stored in XACT and set up the right hand side B
550*
551 srnamt = 'SLARHS'
552 CALL slarhs( path, xtype, uplo, ' ', n, n, kl, ku,
553 $ nrhs, a, lda, xact, lda, b, lda,
554 $ iseed, info )
555 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
556*
557 srnamt = 'DSYTRS2'
558 CALL ssytrs2( uplo, n, nrhs, afac, lda, iwork, x,
559 $ lda, work, info )
560*
561* Check error code from SSYTRS2 and handle error.
562*
563 IF( info.NE.0 )
564 $ CALL alaerh( path, 'SSYTRS2', info, 0, uplo, n,
565 $ n, -1, -1, nrhs, imat, nfail,
566 $ nerrs, nout )
567*
568 CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
569*
570* Compute the residual for the solution
571*
572 CALL spot02( uplo, n, nrhs, a, lda, x, lda, work,
573 $ lda, rwork, result( 4 ) )
574*
575*+ TEST 5
576* Check solution from generated exact solution.
577*
578 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
579 $ result( 5 ) )
580*
581*+ TESTS 6, 7, and 8
582* Use iterative refinement to improve the solution.
583*
584 srnamt = 'SSYRFS'
585 CALL ssyrfs( uplo, n, nrhs, a, lda, afac, lda,
586 $ iwork, b, lda, x, lda, rwork,
587 $ rwork( nrhs+1 ), work, iwork( n+1 ),
588 $ info )
589*
590* Check error code from SSYRFS and handle error.
591*
592 IF( info.NE.0 )
593 $ CALL alaerh( path, 'SSYRFS', info, 0, uplo, n,
594 $ n, -1, -1, nrhs, imat, nfail,
595 $ nerrs, nout )
596*
597 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
598 $ result( 6 ) )
599 CALL spot05( uplo, n, nrhs, a, lda, b, lda, x, lda,
600 $ xact, lda, rwork, rwork( nrhs+1 ),
601 $ result( 7 ) )
602*
603* Print information about the tests that did not pass
604* the threshold.
605*
606 DO 120 k = 3, 8
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 = 9998 )uplo, n, nrhs,
611 $ imat, k, result( k )
612 nfail = nfail + 1
613 END IF
614 120 CONTINUE
615 nrun = nrun + 6
616*
617* End do for each value of NRHS in NSVAL.
618*
619 130 CONTINUE
620*
621*+ TEST 9
622* Get an estimate of RCOND = 1/CNDNUM.
623*
624 140 CONTINUE
625 anorm = slansy( '1', uplo, n, a, lda, rwork )
626 srnamt = 'SSYCON'
627 CALL ssycon( uplo, n, afac, lda, iwork, anorm, rcond,
628 $ work, iwork( n+1 ), info )
629*
630* Check error code from SSYCON and handle error.
631*
632 IF( info.NE.0 )
633 $ CALL alaerh( path, 'SSYCON', info, 0, uplo, n, n,
634 $ -1, -1, -1, imat, nfail, nerrs, nout )
635*
636* Compute the test ratio to compare to values of RCOND
637*
638 result( 9 ) = sget06( rcond, rcondc )
639*
640* Print information about the tests that did not pass
641* the threshold.
642*
643 IF( result( 9 ).GE.thresh ) THEN
644 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
645 $ CALL alahd( nout, path )
646 WRITE( nout, fmt = 9997 )uplo, n, imat, 9,
647 $ result( 9 )
648 nfail = nfail + 1
649 END IF
650 nrun = nrun + 1
651 150 CONTINUE
652*
653 160 CONTINUE
654 170 CONTINUE
655 180 CONTINUE
656*
657* Print a summary of the results.
658*
659 CALL alasum( path, nout, nfail, nrun, nerrs )
660*
661 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
662 $ i2, ', test ', i2, ', ratio =', g12.5 )
663 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
664 $ i2, ', test(', i2, ') =', g12.5 )
665 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
666 $ ', test(', i2, ') =', g12.5 )
667 RETURN
668*
669* End of SCHKSY
670*
ssycon
subroutine ssycon(uplo, n, a, lda, ipiv, anorm, rcond, work, iwork, info)
SSYCON
Definition ssycon.f:130
ssytrs2
subroutine ssytrs2(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, info)
SSYTRS2
Definition ssytrs2.f:132
ssyconv
subroutine ssyconv(uplo, way, n, a, lda, ipiv, e, info)
SSYCONV
Definition ssyconv.f:114
ssyrfs
subroutine ssyrfs(uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, ferr, berr, work, iwork, info)
SSYRFS
Definition ssyrfs.f:191
ssytri2
subroutine ssytri2(uplo, n, a, lda, ipiv, work, lwork, info)
SSYTRI2
Definition ssytri2.f:127
ssytrf
subroutine ssytrf(uplo, n, a, lda, ipiv, work, lwork, info)
SSYTRF
Definition ssytrf.f:182
ssytrs
subroutine ssytrs(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
SSYTRS
Definition ssytrs.f:120
ssyt01
subroutine ssyt01(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
SSYT01
Definition ssyt01.f:124

◆ schksy_rook()

subroutine schksy_rook ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nnb,
integer, dimension( * ) nbval,
integer nns,
integer, dimension( * ) nsval,
real thresh,
logical tsterr,
integer nmax,
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 )

SCHKSY_ROOK

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

Definition at line 168 of file schksy_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 REAL THRESH
180* ..
181* .. Array Arguments ..
182 LOGICAL DOTYPE( * )
183 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
184 REAL A( * ), AFAC( * ), AINV( * ), B( * ),
185 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
186* ..
187*
188* =====================================================================
189*
190* .. Parameters ..
191 REAL ZERO, ONE
192 parameter( zero = 0.0d+0, one = 1.0d+0 )
193 REAL 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 REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX,
208 $ SING_MIN, RCOND, RCONDC, STEMP
209* ..
210* .. Local Arrays ..
211 CHARACTER UPLOS( 2 )
212 INTEGER ISEED( 4 ), ISEEDY( 4 )
213 REAL BLOCK( 2, 2 ), RESULT( NTESTS ), SDUMMY( 1 )
214* ..
215* .. External Functions ..
216 REAL SGET06, SLANGE, SLANSY
217 EXTERNAL sget06, slange, slansy
218* ..
219* .. External Subroutines ..
220 EXTERNAL alaerh, alahd, alasum, serrsy, sget04, slacpy,
221 $ slarhs, slatb4, slatms, spot02, spot03, sgesvd,
222 $ ssycon_rook, ssyt01_rook, ssytrf_rook,
223 $ ssytri_rook, ssytrs_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 ) = 'Single precision'
250 path( 2: 3 ) = 'SR'
251*
252* Path to generate matrices
253*
254 matpath( 1: 1 ) = 'Single 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 serrsy( 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 SLATB4 for the matrix generator
310* based on the type of matrix to be generated.
311*
312 CALL slatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
313 $ MODE, CNDNUM, DIST )
314*
315* Generate a matrix with SLATMS.
316*
317 srnamt = 'SLATMS'
318 CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE,
319 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
320 $ INFO )
321*
322* Check error code from SLATMS and handle error.
323*
324 IF( info.NE.0 ) THEN
325 CALL alaerh( path, 'SLATMS', 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 slacpy( 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 = 'SSYTRF_ROOK'
428 CALL ssytrf_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 SSYTRF_ROOK and handle error.
449*
450 IF( info.NE.k)
451 $ CALL alaerh( path, 'SSYTRF_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 ssyt01_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 slacpy( uplo, n, n, afac, lda, ainv, lda )
478 srnamt = 'SSYTRI_ROOK'
479 CALL ssytri_rook( uplo, n, ainv, lda, iwork, work,
480 $ info )
481*
482* Check error code from SSYTRI_ROOK and handle error.
483*
484 IF( info.NE.0 )
485 $ CALL alaerh( path, 'SSYTRI_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 spot03( 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 stemp = 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 stemp = slange( '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 stemp = slange( 'M', k-2, 2,
541 $ afac( ( k-2 )*lda+1 ), lda, rwork )
542 k = k - 1
543*
544 END IF
545*
546* STEMP should be bounded by CONST
547*
548 stemp = stemp - const + thresh
549 IF( stemp.GT.result( 3 ) )
550 $ result( 3 ) = stemp
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 stemp = slange( '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 stemp = slange( 'M', n-k-1, 2,
579 $ afac( ( k-1 )*lda+k+2 ), lda, rwork )
580 k = k + 1
581*
582 END IF
583*
584* STEMP should be bounded by CONST
585*
586 stemp = stemp - const + thresh
587 IF( stemp.GT.result( 3 ) )
588 $ result( 3 ) = stemp
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 stemp = zero
603*
604 const = ( one+alpha ) / ( one-alpha )
605 CALL slacpy( 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 sgesvd( 'N', 'N', 2, 2, block, 2, rwork,
628 $ sdummy, 1, sdummy, 1,
629 $ work, 10, info )
630*
631*
632 sing_max = rwork( 1 )
633 sing_min = rwork( 2 )
634*
635 stemp = sing_max / sing_min
636*
637* STEMP should be bounded by CONST
638*
639 stemp = stemp - const + thresh
640 IF( stemp.GT.result( 4 ) )
641 $ result( 4 ) = stemp
642 k = k - 1
643*
644 END IF
645*
646 k = k - 1
647*
648 GO TO 160
649 170 CONTINUE
650*
651 ELSE
652*
653* Loop forward for UPLO = 'L'
654*
655 k = 1
656 180 CONTINUE
657 IF( k.GE.n )
658 $ GO TO 190
659*
660 IF( iwork( k ).LT.zero ) THEN
661*
662* Get the two singular values
663* (real and non-negative) of a 2-by-2 block,
664* store them in RWORK array
665*
666 block( 1, 1 ) = afac( ( k-1 )*lda+k )
667 block( 2, 1 ) = afac( ( k-1 )*lda+k+1 )
668 block( 1, 2 ) = block( 2, 1 )
669 block( 2, 2 ) = afac( k*lda+k+1 )
670*
671 CALL sgesvd( 'N', 'N', 2, 2, block, 2, rwork,
672 $ sdummy, 1, sdummy, 1,
673 $ work, 10, info )
674*
675*
676 sing_max = rwork( 1 )
677 sing_min = rwork( 2 )
678*
679 stemp = sing_max / sing_min
680*
681* STEMP should be bounded by CONST
682*
683 stemp = stemp - const + thresh
684 IF( stemp.GT.result( 4 ) )
685 $ result( 4 ) = stemp
686 k = k + 1
687*
688 END IF
689*
690 k = k + 1
691*
692 GO TO 180
693 190 CONTINUE
694 END IF
695*
696* Print information about the tests that did not pass
697* the threshold.
698*
699 DO 200 k = 3, 4
700 IF( result( k ).GE.thresh ) THEN
701 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
702 $ CALL alahd( nout, path )
703 WRITE( nout, fmt = 9999 )uplo, n, nb, imat, k,
704 $ result( k )
705 nfail = nfail + 1
706 END IF
707 200 CONTINUE
708 nrun = nrun + 2
709*
710* Skip the other tests if this is not the first block
711* size.
712*
713 IF( inb.GT.1 )
714 $ GO TO 240
715*
716* Do only the condition estimate if INFO is not 0.
717*
718 IF( trfcon ) THEN
719 rcondc = zero
720 GO TO 230
721 END IF
722*
723* Do for each value of NRHS in NSVAL.
724*
725 DO 220 irhs = 1, nns
726 nrhs = nsval( irhs )
727*
728*+ TEST 5 ( Using TRS_ROOK)
729* Solve and compute residual for A * X = B.
730*
731* Choose a set of NRHS random solution vectors
732* stored in XACT and set up the right hand side B
733*
734 srnamt = 'SLARHS'
735 CALL slarhs( matpath, xtype, uplo, ' ', n, n,
736 $ kl, ku, nrhs, a, lda, xact, lda,
737 $ b, lda, iseed, info )
738 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
739*
740 srnamt = 'SSYTRS_ROOK'
741 CALL ssytrs_rook( uplo, n, nrhs, afac, lda, iwork,
742 $ x, lda, info )
743*
744* Check error code from SSYTRS_ROOK and handle error.
745*
746 IF( info.NE.0 )
747 $ CALL alaerh( path, 'SSYTRS_ROOK', info, 0,
748 $ uplo, n, n, -1, -1, nrhs, imat,
749 $ nfail, nerrs, nout )
750*
751 CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
752*
753* Compute the residual for the solution
754*
755 CALL spot02( uplo, n, nrhs, a, lda, x, lda, work,
756 $ lda, rwork, result( 5 ) )
757*
758*+ TEST 6
759* Check solution from generated exact solution.
760*
761 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
762 $ result( 6 ) )
763*
764* Print information about the tests that did not pass
765* the threshold.
766*
767 DO 210 k = 5, 6
768 IF( result( k ).GE.thresh ) THEN
769 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
770 $ CALL alahd( nout, path )
771 WRITE( nout, fmt = 9998 )uplo, n, nrhs,
772 $ imat, k, result( k )
773 nfail = nfail + 1
774 END IF
775 210 CONTINUE
776 nrun = nrun + 2
777*
778* End do for each value of NRHS in NSVAL.
779*
780 220 CONTINUE
781*
782*+ TEST 7
783* Get an estimate of RCOND = 1/CNDNUM.
784*
785 230 CONTINUE
786 anorm = slansy( '1', uplo, n, a, lda, rwork )
787 srnamt = 'SSYCON_ROOK'
788 CALL ssycon_rook( uplo, n, afac, lda, iwork, anorm,
789 $ rcond, work, iwork( n+1 ), info )
790*
791* Check error code from SSYCON_ROOK and handle error.
792*
793 IF( info.NE.0 )
794 $ CALL alaerh( path, 'SSYCON_ROOK', info, 0,
795 $ uplo, n, n, -1, -1, -1, imat,
796 $ nfail, nerrs, nout )
797*
798* Compute the test ratio to compare values of RCOND
799*
800 result( 7 ) = sget06( rcond, rcondc )
801*
802* Print information about the tests that did not pass
803* the threshold.
804*
805 IF( result( 7 ).GE.thresh ) THEN
806 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
807 $ CALL alahd( nout, path )
808 WRITE( nout, fmt = 9997 )uplo, n, imat, 7,
809 $ result( 7 )
810 nfail = nfail + 1
811 END IF
812 nrun = nrun + 1
813 240 CONTINUE
814*
815 250 CONTINUE
816 260 CONTINUE
817 270 CONTINUE
818*
819* Print a summary of the results.
820*
821 CALL alasum( path, nout, nfail, nrun, nerrs )
822*
823 9999 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NB =', i4, ', type ',
824 $ i2, ', test ', i2, ', ratio =', g12.5 )
825 9998 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ', NRHS=', i3, ', type ',
826 $ i2, ', test(', i2, ') =', g12.5 )
827 9997 FORMAT( ' UPLO = ''', a1, ''', N =', i5, ',', 10x, ' type ', i2,
828 $ ', test(', i2, ') =', g12.5 )
829 RETURN
830*
831* End of SCHKSY_ROOK
832*
alpha
#define alpha
Definition eval.h:35
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
ssycon_rook
subroutine ssycon_rook(uplo, n, a, lda, ipiv, anorm, rcond, work, iwork, info)
SSYCON_ROOK
Definition ssycon_rook.f:144
ssytrf_rook
subroutine ssytrf_rook(uplo, n, a, lda, ipiv, work, lwork, info)
SSYTRF_ROOK
Definition ssytrf_rook.f:208
ssytrs_rook
subroutine ssytrs_rook(uplo, n, nrhs, a, lda, ipiv, b, ldb, info)
SSYTRS_ROOK
Definition ssytrs_rook.f:136
ssytri_rook
subroutine ssytri_rook(uplo, n, a, lda, ipiv, work, info)
SSYTRI_ROOK
Definition ssytri_rook.f:129
ssyt01_rook
subroutine ssyt01_rook(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
SSYT01_ROOK
Definition ssyt01_rook.f:124

◆ schktb()

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

SCHKTB

Purpose:
!>
!> SCHKTB tests STBTRS, -RFS, and -CON, and SLATBS.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is REAL
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The leading dimension of the work arrays.
!>          NMAX >= the maximum value of N in NVAL.
!>
[out]AB
!>          AB is REAL array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is REAL array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is REAL array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is REAL array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is REAL array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is REAL array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL array, dimension
!>                      (max(NMAX,2*NSMAX))
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (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 schktb.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 REAL THRESH
164* ..
165* .. Array Arguments ..
166 LOGICAL DOTYPE( * )
167 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
168 REAL 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 REAL ONE, ZERO
182 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL RESULT( NTESTS )
197* ..
198* .. External Functions ..
199 LOGICAL LSAME
200 REAL SLANTB, SLANTR
201 EXTERNAL lsame, slantb, slantr
202* ..
203* .. External Subroutines ..
204 EXTERNAL alaerh, alahd, alasum, scopy, serrtr, sget04,
205 $ slacpy, slarhs, slaset, slatbs, slattb, stbcon,
206 $ stbrfs, stbsv, stbt02, stbt03, stbt05, stbt06,
207 $ stbtrs
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 ) = 'Single 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 serrtr( 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 SLATTB to generate a triangular test matrix.
289*
290 srnamt = 'SLATTB'
291 CALL slattb( 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 slaset( 'Full', n, n, zero, one, ainv, lda )
306 IF( lsame( uplo, 'U' ) ) THEN
307 DO 20 j = 1, n
308 CALL stbsv( 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 stbsv( 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 = slantb( '1', uplo, diag, n, kd, ab, ldab,
322 $ rwork )
323 ainvnm = slantr( '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 = slantb( 'I', uplo, diag, n, kd, ab, ldab,
334 $ rwork )
335 ainvnm = slantr( '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 = 'SLARHS'
364 CALL slarhs( path, xtype, uplo, trans, n, n, kd,
365 $ idiag, nrhs, ab, ldab, xact, lda,
366 $ b, lda, iseed, info )
367 xtype = 'C'
368 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
369*
370 srnamt = 'STBTRS'
371 CALL stbtrs( uplo, trans, diag, n, kd, nrhs, ab,
372 $ ldab, x, lda, info )
373*
374* Check error code from STBTRS.
375*
376 IF( info.NE.0 )
377 $ CALL alaerh( path, 'STBTRS', info, 0,
378 $ uplo // trans // diag, n, n, kd,
379 $ kd, nrhs, imat, nfail, nerrs,
380 $ nout )
381*
382 CALL stbt02( 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 sget04( 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 = 'STBRFS'
397 CALL stbrfs( 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 STBRFS.
403*
404 IF( info.NE.0 )
405 $ CALL alaerh( path, 'STBRFS', info, 0,
406 $ uplo // trans // diag, n, n, kd,
407 $ kd, nrhs, imat, nfail, nerrs,
408 $ nout )
409*
410 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
411 $ result( 3 ) )
412 CALL stbt05( 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 = 'STBCON'
445 CALL stbcon( norm, uplo, diag, n, kd, ab, ldab,
446 $ rcond, work, iwork, info )
447*
448* Check error code from STBCON.
449*
450 IF( info.NE.0 )
451 $ CALL alaerh( path, 'STBCON', info, 0,
452 $ norm // uplo // diag, n, n, kd, kd,
453 $ -1, imat, nfail, nerrs, nout )
454*
455 CALL stbt06( 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 ) 'STBCON', 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 SLATBS.
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 SLATTB to generate a triangular test matrix.
494*
495 srnamt = 'SLATTB'
496 CALL slattb( 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 = 'SLATBS'
503 CALL scopy( n, x, 1, b, 1 )
504 CALL slatbs( uplo, trans, diag, 'N', n, kd, ab,
505 $ ldab, b, scale, rwork, info )
506*
507* Check error code from SLATBS.
508*
509 IF( info.NE.0 )
510 $ CALL alaerh( path, 'SLATBS', info, 0,
511 $ uplo // trans // diag // 'N', n, n,
512 $ kd, kd, -1, imat, nfail, nerrs,
513 $ nout )
514*
515 CALL stbt03( 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 scopy( n, x, 1, b, 1 )
523 CALL slatbs( uplo, trans, diag, 'Y', n, kd, ab,
524 $ ldab, b, scale, rwork, info )
525*
526* Check error code from SLATBS.
527*
528 IF( info.NE.0 )
529 $ CALL alaerh( path, 'SLATBS', info, 0,
530 $ uplo // trans // diag // 'Y', n, n,
531 $ kd, kd, -1, imat, nfail, nerrs,
532 $ nout )
533*
534 CALL stbt03( 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 )'SLATBS', 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 )'SLATBS', 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 SCHKTB
578*
slantr
real function slantr(norm, uplo, diag, m, n, a, lda, work)
SLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition slantr.f:141
slatbs
subroutine slatbs(uplo, trans, diag, normin, n, kd, ab, ldab, x, scale, cnorm, info)
SLATBS solves a triangular banded system of equations.
Definition slatbs.f:242
slantb
real function slantb(norm, uplo, diag, n, k, ab, ldab, work)
SLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition slantb.f:140
stbtrs
subroutine stbtrs(uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, info)
STBTRS
Definition stbtrs.f:146
stbrfs
subroutine stbrfs(uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, ferr, berr, work, iwork, info)
STBRFS
Definition stbrfs.f:188
stbcon
subroutine stbcon(norm, uplo, diag, n, kd, ab, ldab, rcond, work, iwork, info)
STBCON
Definition stbcon.f:143
stbsv
subroutine stbsv(uplo, trans, diag, n, k, a, lda, x, incx)
STBSV
Definition stbsv.f:189
stbt02
subroutine stbt02(uplo, trans, diag, n, kd, nrhs, ab, ldab, x, ldx, b, ldb, work, resid)
STBT02
Definition stbt02.f:154
slattb
subroutine slattb(imat, uplo, trans, diag, iseed, n, kd, ab, ldab, b, work, info)
SLATTB
Definition slattb.f:135
stbt03
subroutine stbt03(uplo, trans, diag, n, kd, nrhs, ab, ldab, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
STBT03
Definition stbt03.f:175
stbt06
subroutine stbt06(rcond, rcondc, uplo, diag, n, kd, ab, ldab, work, rat)
STBT06
Definition stbt06.f:125
serrtr
subroutine serrtr(path, nunit)
SERRTR
Definition serrtr.f:55
stbt05
subroutine stbt05(uplo, trans, diag, n, kd, nrhs, ab, ldab, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
STBT05
Definition stbt05.f:189

◆ schktp()

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

SCHKTP

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

Definition at line 154 of file schktp.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 REAL THRESH
166* ..
167* .. Array Arguments ..
168 LOGICAL DOTYPE( * )
169 INTEGER IWORK( * ), NSVAL( * ), NVAL( * )
170 REAL 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 REAL ONE, ZERO
184 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL RESULT( NTESTS )
198* ..
199* .. External Functions ..
200 LOGICAL LSAME
201 REAL SLANTP
202 EXTERNAL lsame, slantp
203* ..
204* .. External Subroutines ..
205 EXTERNAL alaerh, alahd, alasum, scopy, serrtr, sget04,
206 $ slacpy, slarhs, slatps, slattp, stpcon, stprfs,
207 $ stpt01, stpt02, stpt03, stpt05, stpt06, stptri,
208 $ stptrs
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 ) = 'Single 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 serrtr( 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 SLATTP to generate a triangular test matrix.
268*
269 srnamt = 'SLATTP'
270 CALL slattp( 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 scopy( lap, ap, 1, ainvp, 1 )
286 srnamt = 'STPTRI'
287 CALL stptri( uplo, diag, n, ainvp, info )
288*
289* Check error code from STPTRI.
290*
291 IF( info.NE.0 )
292 $ CALL alaerh( path, 'STPTRI', 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 = slantp( 'I', uplo, diag, n, ap, rwork )
298 ainvnm = slantp( '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 stpt01( 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 = 'SLARHS'
343 CALL slarhs( path, xtype, uplo, trans, n, n, 0,
344 $ idiag, nrhs, ap, lap, xact, lda, b,
345 $ lda, iseed, info )
346 xtype = 'C'
347 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
348*
349 srnamt = 'STPTRS'
350 CALL stptrs( uplo, trans, diag, n, nrhs, ap, x,
351 $ lda, info )
352*
353* Check error code from STPTRS.
354*
355 IF( info.NE.0 )
356 $ CALL alaerh( path, 'STPTRS', info, 0,
357 $ uplo // trans // diag, n, n, -1,
358 $ -1, -1, imat, nfail, nerrs, nout )
359*
360 CALL stpt02( 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 sget04( 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 = 'STPRFS'
374 CALL stprfs( 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 STPRFS.
379*
380 IF( info.NE.0 )
381 $ CALL alaerh( path, 'STPRFS', info, 0,
382 $ uplo // trans // diag, n, n, -1,
383 $ -1, nrhs, imat, nfail, nerrs,
384 $ nout )
385*
386 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
387 $ result( 4 ) )
388 CALL stpt05( 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 = 'STPCON'
421 CALL stpcon( norm, uplo, diag, n, ap, rcond, work,
422 $ iwork, info )
423*
424* Check error code from STPCON.
425*
426 IF( info.NE.0 )
427 $ CALL alaerh( path, 'STPCON', info, 0,
428 $ norm // uplo // diag, n, n, -1, -1,
429 $ -1, imat, nfail, nerrs, nout )
430*
431 CALL stpt06( 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 ) 'STPCON', 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 SLATPS.
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 SLATTP to generate a triangular test matrix.
469*
470 srnamt = 'SLATTP'
471 CALL slattp( 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 = 'SLATPS'
478 CALL scopy( n, x, 1, b, 1 )
479 CALL slatps( uplo, trans, diag, 'N', n, ap, b, scale,
480 $ rwork, info )
481*
482* Check error code from SLATPS.
483*
484 IF( info.NE.0 )
485 $ CALL alaerh( path, 'SLATPS', info, 0,
486 $ uplo // trans // diag // 'N', n, n,
487 $ -1, -1, -1, imat, nfail, nerrs, nout )
488*
489 CALL stpt03( 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 scopy( n, x, 1, b( n+1 ), 1 )
497 CALL slatps( uplo, trans, diag, 'Y', n, ap, b( n+1 ),
498 $ scale, rwork, info )
499*
500* Check error code from SLATPS.
501*
502 IF( info.NE.0 )
503 $ CALL alaerh( path, 'SLATPS', info, 0,
504 $ uplo // trans // diag // 'Y', n, n,
505 $ -1, -1, -1, imat, nfail, nerrs, nout )
506*
507 CALL stpt03( 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 )'SLATPS', 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 )'SLATPS', 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 SCHKTP
551*
slatps
subroutine slatps(uplo, trans, diag, normin, n, ap, x, scale, cnorm, info)
SLATPS solves a triangular system of equations with the matrix held in packed storage.
Definition slatps.f:229
slantp
real function slantp(norm, uplo, diag, n, ap, work)
SLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition slantp.f:124
stptrs
subroutine stptrs(uplo, trans, diag, n, nrhs, ap, b, ldb, info)
STPTRS
Definition stptrs.f:130
stprfs
subroutine stprfs(uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, ferr, berr, work, iwork, info)
STPRFS
Definition stprfs.f:175
stptri
subroutine stptri(uplo, diag, n, ap, info)
STPTRI
Definition stptri.f:117
stpcon
subroutine stpcon(norm, uplo, diag, n, ap, rcond, work, iwork, info)
STPCON
Definition stpcon.f:130
stpt05
subroutine stpt05(uplo, trans, diag, n, nrhs, ap, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
STPT05
Definition stpt05.f:174
stpt01
subroutine stpt01(uplo, diag, n, ap, ainvp, rcond, work, resid)
STPT01
Definition stpt01.f:108
stpt02
subroutine stpt02(uplo, trans, diag, n, nrhs, ap, x, ldx, b, ldb, work, resid)
STPT02
Definition stpt02.f:142
slattp
subroutine slattp(imat, uplo, trans, diag, iseed, n, a, b, work, info)
SLATTP
Definition slattp.f:125
stpt03
subroutine stpt03(uplo, trans, diag, n, nrhs, ap, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
STPT03
Definition stpt03.f:161
stpt06
subroutine stpt06(rcond, rcondc, uplo, diag, n, ap, work, rat)
STPT06
Definition stpt06.f:111

◆ schktr()

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

SCHKTR

Purpose:
!>
!> SCHKTR tests STRTRI, -TRS, -RFS, and -CON, and SLATRS
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]NNB
!>          NNB is INTEGER
!>          The number of values of NB contained in the vector NBVAL.
!>
[in]NBVAL
!>          NBVAL is INTEGER array, dimension (NNB)
!>          The values of the blocksize NB.
!>
[in]NNS
!>          NNS is INTEGER
!>          The number of values of NRHS contained in the vector NSVAL.
!>
[in]NSVAL
!>          NSVAL is INTEGER array, dimension (NNS)
!>          The values of the number of right hand sides NRHS.
!>
[in]THRESH
!>          THRESH is REAL
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The leading dimension of the work arrays.
!>          NMAX >= the maximum value of N in NVAL.
!>
[out]A
!>          A is REAL array, dimension (NMAX*NMAX)
!>
[out]AINV
!>          AINV is REAL array, dimension (NMAX*NMAX)
!>
[out]B
!>          B is REAL array, dimension (NMAX*NSMAX)
!>          where NSMAX is the largest entry in NSVAL.
!>
[out]X
!>          X is REAL array, dimension (NMAX*NSMAX)
!>
[out]XACT
!>          XACT is REAL array, dimension (NMAX*NSMAX)
!>
[out]WORK
!>          WORK is REAL array, dimension
!>                      (NMAX*max(3,NSMAX))
!>
[out]RWORK
!>          RWORK is REAL array, dimension
!>                      (max(NMAX,2*NSMAX))
!>
[out]IWORK
!>          IWORK is INTEGER array, dimension (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 schktr.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 REAL THRESH
176* ..
177* .. Array Arguments ..
178 LOGICAL DOTYPE( * )
179 INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * )
180 REAL 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 REAL ONE, ZERO
194 parameter( one = 1.0e0, zero = 0.0e0 )
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 REAL 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 REAL RESULT( NTESTS )
208* ..
209* .. External Functions ..
210 LOGICAL LSAME
211 REAL SLANTR
212 EXTERNAL lsame, slantr
213* ..
214* .. External Subroutines ..
215 EXTERNAL alaerh, alahd, alasum, scopy, serrtr, sget04,
216 $ slacpy, slarhs, slatrs, slattr, strcon, strrfs,
217 $ strt01, strt02, strt03, strt05, strt06, strtri,
218 $ strtrs, 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 ) = 'Single 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 serrtr( 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 SLATTR to generate a triangular test matrix.
278*
279 srnamt = 'SLATTR'
280 CALL slattr( 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 slacpy( uplo, n, n, a, lda, ainv, lda )
302 srnamt = 'STRTRI'
303 CALL strtri( uplo, diag, n, ainv, lda, info )
304*
305* Check error code from STRTRI.
306*
307 IF( info.NE.0 )
308 $ CALL alaerh( path, 'STRTRI', 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 = slantr( 'I', uplo, diag, n, n, a, lda, rwork )
315 ainvnm = slantr( '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 strt01( 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 = 'SLARHS'
367 CALL slarhs( path, xtype, uplo, trans, n, n, 0,
368 $ idiag, nrhs, a, lda, xact, lda, b,
369 $ lda, iseed, info )
370 xtype = 'C'
371 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
372*
373 srnamt = 'STRTRS'
374 CALL strtrs( uplo, trans, diag, n, nrhs, a, lda,
375 $ x, lda, info )
376*
377* Check error code from STRTRS.
378*
379 IF( info.NE.0 )
380 $ CALL alaerh( path, 'STRTRS', 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 strt02( 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 sget04( 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 = 'STRRFS'
404 CALL strrfs( 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 STRRFS.
410*
411 IF( info.NE.0 )
412 $ CALL alaerh( path, 'STRRFS', info, 0,
413 $ uplo // trans // diag, n, n, -1,
414 $ -1, nrhs, imat, nfail, nerrs,
415 $ nout )
416*
417 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
418 $ result( 4 ) )
419 CALL strt05( 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 = 'STRCON'
451 CALL strcon( norm, uplo, diag, n, a, lda, rcond,
452 $ work, iwork, info )
453*
454* Check error code from STRCON.
455*
456 IF( info.NE.0 )
457 $ CALL alaerh( path, 'STRCON', info, 0,
458 $ norm // uplo // diag, n, n, -1, -1,
459 $ -1, imat, nfail, nerrs, nout )
460*
461 CALL strt06( 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 SLATRS.
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 SLATTR to generate a triangular test matrix.
500*
501 srnamt = 'SLATTR'
502 CALL slattr( 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 = 'SLATRS'
509 CALL scopy( n, x, 1, b, 1 )
510 CALL slatrs( uplo, trans, diag, 'N', n, a, lda, b,
511 $ scale, rwork, info )
512*
513* Check error code from SLATRS.
514*
515 IF( info.NE.0 )
516 $ CALL alaerh( path, 'SLATRS', info, 0,
517 $ uplo // trans // diag // 'N', n, n,
518 $ -1, -1, -1, imat, nfail, nerrs, nout )
519*
520 CALL strt03( 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 scopy( n, x, 1, b( n+1 ), 1 )
528 CALL slatrs( uplo, trans, diag, 'Y', n, a, lda,
529 $ b( n+1 ), scale, rwork, info )
530*
531* Check error code from SLATRS.
532*
533 IF( info.NE.0 )
534 $ CALL alaerh( path, 'SLATRS', info, 0,
535 $ uplo // trans // diag // 'Y', n, n,
536 $ -1, -1, -1, imat, nfail, nerrs, nout )
537*
538 CALL strt03( 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 )'SLATRS', 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 )'SLATRS', 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 SCHKTR
582*
slatrs
subroutine slatrs(uplo, trans, diag, normin, n, a, lda, x, scale, cnorm, info)
SLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
Definition slatrs.f:238
strtrs
subroutine strtrs(uplo, trans, diag, n, nrhs, a, lda, b, ldb, info)
STRTRS
Definition strtrs.f:140
strtri
subroutine strtri(uplo, diag, n, a, lda, info)
STRTRI
Definition strtri.f:109
strcon
subroutine strcon(norm, uplo, diag, n, a, lda, rcond, work, iwork, info)
STRCON
Definition strcon.f:137
strrfs
subroutine strrfs(uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, ferr, berr, work, iwork, info)
STRRFS
Definition strrfs.f:182
slattr
subroutine slattr(imat, uplo, trans, diag, iseed, n, a, lda, b, work, info)
SLATTR
Definition slattr.f:133
strt01
subroutine strt01(uplo, diag, n, a, lda, ainv, ldainv, rcond, work, resid)
STRT01
Definition strt01.f:124
strt02
subroutine strt02(uplo, trans, diag, n, nrhs, a, lda, x, ldx, b, ldb, work, resid)
STRT02
Definition strt02.f:150
strt05
subroutine strt05(uplo, trans, diag, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
STRT05
Definition strt05.f:181
strt03
subroutine strt03(uplo, trans, diag, n, nrhs, a, lda, scale, cnorm, tscal, x, ldx, b, ldb, work, resid)
STRT03
Definition strt03.f:169
strt06
subroutine strt06(rcond, rcondc, uplo, diag, n, a, lda, work, rat)
STRT06
Definition strt06.f:121

◆ schktz()

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

SCHKTZ

Purpose:
!>
!> SCHKTZ tests STZRZF.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NM
!>          NM is INTEGER
!>          The number of values of M contained in the vector MVAL.
!>
[in]MVAL
!>          MVAL is INTEGER array, dimension (NM)
!>          The values of the matrix row dimension M.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix column dimension N.
!>
[in]THRESH
!>          THRESH is REAL
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is REAL 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 REAL array, dimension (MMAX*NMAX)
!>
[out]S
!>          S is REAL array, dimension
!>                      (min(MMAX,NMAX))
!>
[out]TAU
!>          TAU is REAL array, dimension (MMAX)
!>
[out]WORK
!>          WORK is REAL 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 schktz.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 REAL THRESH
141* ..
142* .. Array Arguments ..
143 LOGICAL DOTYPE( * )
144 INTEGER MVAL( * ), NVAL( * )
145 REAL 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 REAL ONE, ZERO
157 parameter( one = 1.0e0, zero = 0.0e0 )
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 REAL EPS
164* ..
165* .. Local Arrays ..
166 INTEGER ISEED( 4 ), ISEEDY( 4 )
167 REAL RESULT( NTESTS )
168* ..
169* .. External Functions ..
170 REAL SLAMCH, SQRT12, SRZT01, SRZT02
171 EXTERNAL slamch, sqrt12, srzt01, srzt02
172* ..
173* .. External Subroutines ..
174 EXTERNAL alahd, alasum, serrtz, sgeqr2, slacpy, slaord,
175 $ slaset, slatms, stzrzf
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 ) = 'Single 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 = slamch( 'Epsilon' )
205*
206* Test the error exits
207*
208 IF( tsterr )
209 $ CALL serrtz( 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 STZRQF
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 slaset( 'Full', m, n, zero, zero, a, lda )
246 DO 30 i = 1, mnmin
247 s( i ) = zero
248 30 CONTINUE
249 ELSE
250 CALL slatms( m, n, 'Uniform', iseed,
251 $ 'Nonsymmetric', s, imode,
252 $ one / eps, one, m, n, 'No packing', a,
253 $ lda, work, info )
254 CALL sgeqr2( m, n, a, lda, work, work( mnmin+1 ),
255 $ info )
256 CALL slaset( 'Lower', m-1, n, zero, zero, a( 2 ),
257 $ lda )
258 CALL slaord( 'Decreasing', mnmin, s, 1 )
259 END IF
260*
261* Save A and its singular values
262*
263 CALL slacpy( 'All', m, n, a, lda, copya, lda )
264*
265* Call STZRZF to reduce the upper trapezoidal matrix to
266* upper triangular form.
267*
268 srnamt = 'STZRZF'
269 CALL stzrzf( m, n, a, lda, tau, work, lwork, info )
270*
271* Compute norm(svd(a) - svd(r))
272*
273 result( 1 ) = sqrt12( m, m, a, lda, s, work,
274 $ lwork )
275*
276* Compute norm( A - R*Q )
277*
278 result( 2 ) = srzt01( m, n, copya, a, lda, tau, work,
279 $ lwork )
280*
281* Compute norm(Q'*Q - I).
282*
283 result( 3 ) = srzt02( 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 SCHKTZ
311*
sgeqr2
subroutine sgeqr2(m, n, a, lda, tau, work, info)
SGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
Definition sgeqr2.f:130
stzrzf
subroutine stzrzf(m, n, a, lda, tau, work, lwork, info)
STZRZF
Definition stzrzf.f:151
serrtz
subroutine serrtz(path, nunit)
SERRTZ
Definition serrtz.f:54
srzt02
real function srzt02(m, n, af, lda, tau, work, lwork)
SRZT02
Definition srzt02.f:91
srzt01
real function srzt01(m, n, a, af, lda, tau, work, lwork)
SRZT01
Definition srzt01.f:98

◆ sdrvgb()

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

SDRVGB

SDRVGBX

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

172*
173* -- LAPACK test routine --
174* -- LAPACK is a software package provided by Univ. of Tennessee, --
175* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
176*
177* .. Scalar Arguments ..
178 LOGICAL TSTERR
179 INTEGER LA, LAFB, NN, NOUT, NRHS
180 REAL THRESH
181* ..
182* .. Array Arguments ..
183 LOGICAL DOTYPE( * )
184 INTEGER IWORK( * ), NVAL( * )
185 REAL A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ),
186 $ RWORK( * ), S( * ), WORK( * ), X( * ),
187 $ XACT( * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 REAL ONE, ZERO
194 parameter( one = 1.0e+0, zero = 0.0e+0 )
195 INTEGER NTYPES
196 parameter( ntypes = 8 )
197 INTEGER NTESTS
198 parameter( ntests = 7 )
199 INTEGER NTRAN
200 parameter( ntran = 3 )
201* ..
202* .. Local Scalars ..
203 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
204 CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
205 CHARACTER*3 PATH
206 INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN,
207 $ INFO, IOFF, ITRAN, IZERO, J, K, K1, KL, KU,
208 $ LDA, LDAFB, LDB, MODE, N, NB, NBMIN, NERRS,
209 $ NFACT, NFAIL, NIMAT, NKL, NKU, NRUN, NT
210 REAL AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV,
211 $ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO,
212 $ ROLDC, ROLDI, ROLDO, ROWCND, RPVGRW
213* ..
214* .. Local Arrays ..
215 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
216 INTEGER ISEED( 4 ), ISEEDY( 4 )
217 REAL RESULT( NTESTS )
218* ..
219* .. External Functions ..
220 LOGICAL LSAME
221 REAL SGET06, SLAMCH, SLANGB, SLANGE, SLANTB
222 EXTERNAL lsame, sget06, slamch, slangb, slange, slantb
223* ..
224* .. External Subroutines ..
225 EXTERNAL aladhd, alaerh, alasvm, serrvx, sgbequ, sgbsv,
226 $ sgbsvx, sgbt01, sgbt02, sgbt05, sgbtrf, sgbtrs,
227 $ sget04, slacpy, slaqgb, slarhs, slaset, slatb4,
228 $ slatms, 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 ) = 'Single 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 serrvx( 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 SLATB4 and generate a
356* test matrix with SLATMS.
357*
358 CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
359 $ MODE, CNDNUM, DIST )
360 rcondc = one / cndnum
361*
362 srnamt = 'SLATMS'
363 CALL slatms( 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 SLATMS.
368*
369 IF( info.NE.0 ) THEN
370 CALL alaerh( path, 'SLATMS', 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 slacpy( 'Full', kl+ku+1, n, a, lda, asav, lda )
408*
409 DO 110 iequed = 1, 4
410 equed = equeds( iequed )
411 IF( iequed.EQ.1 ) THEN
412 nfact = 3
413 ELSE
414 nfact = 1
415 END IF
416*
417 DO 100 ifact = 1, nfact
418 fact = facts( ifact )
419 prefac = lsame( fact, 'F' )
420 nofact = lsame( fact, 'N' )
421 equil = lsame( fact, 'E' )
422*
423 IF( zerot ) THEN
424 IF( prefac )
425 $ GO TO 100
426 rcondo = zero
427 rcondi = zero
428*
429 ELSE IF( .NOT.nofact ) THEN
430*
431* Compute the condition number for comparison
432* with the value returned by SGESVX (FACT =
433* 'N' reuses the condition number from the
434* previous iteration with FACT = 'F').
435*
436 CALL slacpy( '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 sgbequ( 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 slaqgb( 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 SGET04.
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 = slangb( '1', n, kl, ku, afb( kl+1 ),
478 $ ldafb, rwork )
479 anormi = slangb( 'I', n, kl, ku, afb( kl+1 ),
480 $ ldafb, rwork )
481*
482* Factor the matrix A.
483*
484 CALL sgbtrf( n, n, kl, ku, afb, ldafb, iwork,
485 $ info )
486*
487* Form the inverse of A.
488*
489 CALL slaset( 'Full', n, n, zero, one, work,
490 $ ldb )
491 srnamt = 'SGBTRS'
492 CALL sgbtrs( '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 = slange( '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 = slange( '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 slacpy( '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 = 'SLARHS'
538 CALL slarhs( path, xtype, 'Full', trans, n,
539 $ n, kl, ku, nrhs, a, lda, xact,
540 $ ldb, b, ldb, iseed, info )
541 xtype = 'C'
542 CALL slacpy( 'Full', n, nrhs, b, ldb, bsav,
543 $ ldb )
544*
545 IF( nofact .AND. itran.EQ.1 ) THEN
546*
547* --- Test SGBSV ---
548*
549* Compute the LU factorization of the matrix
550* and solve the system.
551*
552 CALL slacpy( 'Full', kl+ku+1, n, a, lda,
553 $ afb( kl+1 ), ldafb )
554 CALL slacpy( 'Full', n, nrhs, b, ldb, x,
555 $ ldb )
556*
557 srnamt = 'SGBSV '
558 CALL sgbsv( n, kl, ku, nrhs, afb, ldafb,
559 $ iwork, x, ldb, info )
560*
561* Check error code from SGBSV .
562*
563 IF( info.NE.izero )
564 $ CALL alaerh( path, 'SGBSV ', 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 sgbt01( 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 slacpy( 'Full', n, nrhs, b, ldb,
582 $ work, ldb )
583 CALL sgbt02( '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 sget04( 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 )'SGBSV ',
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 SGBSVX ---
612*
613 IF( .NOT.prefac )
614 $ CALL slaset( 'Full', 2*kl+ku+1, n, zero,
615 $ zero, afb, ldafb )
616 CALL slaset( '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 slaqgb( 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 SGBSVX.
630*
631 srnamt = 'SGBSVX'
632 CALL sgbsvx( 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 SGBSVX.
639*
640 IF( info.NE.izero )
641 $ CALL alaerh( path, 'SGBSVX', info, izero,
642 $ fact // trans, n, n, kl, ku,
643 $ nrhs, imat, nfail, nerrs,
644 $ nout )
645*
646* Compare WORK(1) from SGBSVX 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 = slantb( '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 = slantb( 'M', 'U', 'N', n, kl+ku,
669 $ afb, ldafb, work )
670 IF( rpvgrw.EQ.zero ) THEN
671 rpvgrw = one
672 ELSE
673 rpvgrw = slangb( '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 $ slamch( 'E' )
680*
681 IF( .NOT.prefac ) THEN
682*
683* Reconstruct matrix from factors and
684* compute residual.
685*
686 CALL sgbt01( 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 slacpy( 'Full', n, nrhs, bsav, ldb,
700 $ work, ldb )
701 CALL sgbt02( 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 sget04( 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 sget04( 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 sgbt05( 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 SGBSVX with the computed
735* value in RCONDC.
736*
737 result( 6 ) = sget06( rcond, rcondc )
738*
739* Print information about the tests that did
740* not pass the threshold.
741*
742 IF( .NOT.trfcon ) THEN
743 DO 80 k = k1, ntests
744 IF( result( k ).GE.thresh ) THEN
745 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
746 $ CALL aladhd( nout, path )
747 IF( prefac ) THEN
748 WRITE( nout, fmt = 9995 )
749 $ 'SGBSVX', fact, trans, n, kl,
750 $ ku, equed, imat, k,
751 $ result( k )
752 ELSE
753 WRITE( nout, fmt = 9996 )
754 $ 'SGBSVX', 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 )'SGBSVX',
768 $ fact, trans, n, kl, ku, equed,
769 $ imat, 1, result( 1 )
770 ELSE
771 WRITE( nout, fmt = 9996 )'SGBSVX',
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 )'SGBSVX',
783 $ fact, trans, n, kl, ku, equed,
784 $ imat, 6, result( 6 )
785 ELSE
786 WRITE( nout, fmt = 9996 )'SGBSVX',
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 )'SGBSVX',
798 $ fact, trans, n, kl, ku, equed,
799 $ imat, 7, result( 7 )
800 ELSE
801 WRITE( nout, fmt = 9996 )'SGBSVX',
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 SDRVGB, LA=', i5, ' is too small for N=', i5,
823 $ ', KU=', i5, ', KL=', i5, / ' ==> Increase LA to at least ',
824 $ i5 )
825 9998 FORMAT( ' *** In SDRVGB, 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 SDRVGB
839*
alasvm
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
Definition alasvm.f:73
aladhd
subroutine aladhd(iounit, path)
ALADHD
Definition aladhd.f:90
slaqgb
subroutine slaqgb(m, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd, amax, equed)
SLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ.
Definition slaqgb.f:159
sgbsvx
subroutine sgbsvx(fact, trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, equed, r, c, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, info)
SGBSVX computes the solution to system of linear equations A * X = B for GB matrices
Definition sgbsvx.f:368
sgbsv
subroutine sgbsv(n, kl, ku, nrhs, ab, ldab, ipiv, b, ldb, info)
SGBSV computes the solution to system of linear equations A * X = B for GB matrices (simple driver)
Definition sgbsv.f:162
serrvx
subroutine serrvx(path, nunit)
SERRVX
Definition serrvx.f:55

◆ sdrvge()

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

SDRVGE

SDRVGEX

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

164*
165* -- LAPACK test routine --
166* -- LAPACK is a software package provided by Univ. of Tennessee, --
167* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
168*
169* .. Scalar Arguments ..
170 LOGICAL TSTERR
171 INTEGER NMAX, NN, NOUT, NRHS
172 REAL THRESH
173* ..
174* .. Array Arguments ..
175 LOGICAL DOTYPE( * )
176 INTEGER IWORK( * ), NVAL( * )
177 REAL A( * ), AFAC( * ), ASAV( * ), B( * ),
178 $ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
179 $ X( * ), XACT( * )
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 REAL ONE, ZERO
186 parameter( one = 1.0e+0, zero = 0.0e+0 )
187 INTEGER NTYPES
188 parameter( ntypes = 11 )
189 INTEGER NTESTS
190 parameter( ntests = 7 )
191 INTEGER NTRAN
192 parameter( ntran = 3 )
193* ..
194* .. Local Scalars ..
195 LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT
196 CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE
197 CHARACTER*3 PATH
198 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, ITRAN,
199 $ IZERO, K, K1, KL, KU, LDA, LWORK, MODE, N, NB,
200 $ NBMIN, NERRS, NFACT, NFAIL, NIMAT, NRUN, NT
201 REAL AINVNM, AMAX, ANORM, ANORMI, ANORMO, CNDNUM,
202 $ COLCND, RCOND, RCONDC, RCONDI, RCONDO, ROLDC,
203 $ ROLDI, ROLDO, ROWCND, RPVGRW
204* ..
205* .. Local Arrays ..
206 CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN )
207 INTEGER ISEED( 4 ), ISEEDY( 4 )
208 REAL RESULT( NTESTS )
209* ..
210* .. External Functions ..
211 LOGICAL LSAME
212 REAL SGET06, SLAMCH, SLANGE, SLANTR
213 EXTERNAL lsame, sget06, slamch, slange, slantr
214* ..
215* .. External Subroutines ..
216 EXTERNAL aladhd, alaerh, alasvm, serrvx, sgeequ, sgesv,
217 $ sgesvx, sget01, sget02, sget04, sget07, sgetrf,
218 $ sgetri, slacpy, slaqge, slarhs, slaset, slatb4,
219 $ slatms, 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 ) = 'Single 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 serrvx( 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 SLATB4 and generate a test matrix
289* with SLATMS.
290*
291 CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
292 $ CNDNUM, DIST )
293 rcondc = one / cndnum
294*
295 srnamt = 'SLATMS'
296 CALL slatms( 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 SLATMS.
301*
302 IF( info.NE.0 ) THEN
303 CALL alaerh( path, 'SLATMS', 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 slaset( '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 slacpy( '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 SGESVX (FACT = 'N' reuses
360* the condition number from the previous iteration
361* with FACT = 'F').
362*
363 CALL slacpy( '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 sgeequ( 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 slaqge( 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 SGET04.
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 = slange( '1', n, n, afac, lda, rwork )
401 anormi = slange( 'I', n, n, afac, lda, rwork )
402*
403* Factor the matrix A.
404*
405 srnamt = 'SGETRF'
406 CALL sgetrf( n, n, afac, lda, iwork, info )
407*
408* Form the inverse of A.
409*
410 CALL slacpy( 'Full', n, n, afac, lda, a, lda )
411 lwork = nmax*max( 3, nrhs )
412 srnamt = 'SGETRI'
413 CALL sgetri( n, a, lda, iwork, work, lwork, info )
414*
415* Compute the 1-norm condition number of A.
416*
417 ainvnm = slange( '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 = slange( '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 slacpy( 'Full', n, n, asav, lda, a, lda )
448*
449* Form an exact solution and set the right hand side.
450*
451 srnamt = 'SLARHS'
452 CALL slarhs( path, xtype, 'Full', trans, n, n, kl,
453 $ ku, nrhs, a, lda, xact, lda, b, lda,
454 $ iseed, info )
455 xtype = 'C'
456 CALL slacpy( 'Full', n, nrhs, b, lda, bsav, lda )
457*
458 IF( nofact .AND. itran.EQ.1 ) THEN
459*
460* --- Test SGESV ---
461*
462* Compute the LU factorization of the matrix and
463* solve the system.
464*
465 CALL slacpy( 'Full', n, n, a, lda, afac, lda )
466 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
467*
468 srnamt = 'SGESV '
469 CALL sgesv( n, nrhs, afac, lda, iwork, x, lda,
470 $ info )
471*
472* Check error code from SGESV .
473*
474 IF( info.NE.izero )
475 $ CALL alaerh( path, 'SGESV ', 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 sget01( 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 slacpy( 'Full', n, nrhs, b, lda, work,
490 $ lda )
491 CALL sget02( '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 sget04( 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 )'SGESV ', 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 SGESVX ---
518*
519 IF( .NOT.prefac )
520 $ CALL slaset( 'Full', n, n, zero, zero, afac,
521 $ lda )
522 CALL slaset( '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 slaqge( 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 SGESVX.
534*
535 srnamt = 'SGESVX'
536 CALL sgesvx( 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 SGESVX.
543*
544 IF( info.NE.izero )
545 $ CALL alaerh( path, 'SGESVX', info, izero,
546 $ fact // trans, n, n, -1, -1, nrhs,
547 $ imat, nfail, nerrs, nout )
548*
549* Compare WORK(1) from SGESVX with the computed
550* reciprocal pivot growth factor RPVGRW
551*
552 IF( info.NE.0 .AND. info.LE.n) THEN
553 rpvgrw = slantr( 'M', 'U', 'N', info, info,
554 $ afac, lda, work )
555 IF( rpvgrw.EQ.zero ) THEN
556 rpvgrw = one
557 ELSE
558 rpvgrw = slange( 'M', n, info, a, lda,
559 $ work ) / rpvgrw
560 END IF
561 ELSE
562 rpvgrw = slantr( 'M', 'U', 'N', n, n, afac, lda,
563 $ work )
564 IF( rpvgrw.EQ.zero ) THEN
565 rpvgrw = one
566 ELSE
567 rpvgrw = slange( '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 $ slamch( 'E' )
574*
575 IF( .NOT.prefac ) THEN
576*
577* Reconstruct matrix from factors and compute
578* residual.
579*
580 CALL sget01( 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 slacpy( 'Full', n, nrhs, bsav, lda, work,
593 $ lda )
594 CALL sget02( 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 sget04( 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 sget04( 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 sget07( 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 SGESVX with the computed value
625* in RCONDC.
626*
627 result( 6 ) = sget06( 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 )'SGESVX',
639 $ fact, trans, n, equed, imat, k,
640 $ result( k )
641 ELSE
642 WRITE( nout, fmt = 9998 )'SGESVX',
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 )'SGESVX', fact,
656 $ trans, n, equed, imat, 1, result( 1 )
657 ELSE
658 WRITE( nout, fmt = 9998 )'SGESVX', 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 )'SGESVX', fact,
669 $ trans, n, equed, imat, 6, result( 6 )
670 ELSE
671 WRITE( nout, fmt = 9998 )'SGESVX', 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 )'SGESVX', fact,
682 $ trans, n, equed, imat, 7, result( 7 )
683 ELSE
684 WRITE( nout, fmt = 9998 )'SGESVX', 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 SDRVGE
713*
slaqge
subroutine slaqge(m, n, a, lda, r, c, rowcnd, colcnd, amax, equed)
SLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sgeequ.
Definition slaqge.f:142
sgesv
subroutine sgesv(n, nrhs, a, lda, ipiv, b, ldb, info)
SGESV computes the solution to system of linear equations A * X = B for GE matrices (simple driver)
Definition sgesv.f:122
sgesvx
subroutine sgesvx(fact, trans, n, nrhs, a, lda, af, ldaf, ipiv, equed, r, c, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, info)
SGESVX computes the solution to system of linear equations A * X = B for GE matrices
Definition sgesvx.f:349

◆ sdrvgt()

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

SDRVGT

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

139*
140* -- LAPACK test routine --
141* -- LAPACK is a software package provided by Univ. of Tennessee, --
142* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
143*
144* .. Scalar Arguments ..
145 LOGICAL TSTERR
146 INTEGER NN, NOUT, NRHS
147 REAL THRESH
148* ..
149* .. Array Arguments ..
150 LOGICAL DOTYPE( * )
151 INTEGER IWORK( * ), NVAL( * )
152 REAL A( * ), AF( * ), B( * ), RWORK( * ), WORK( * ),
153 $ X( * ), XACT( * )
154* ..
155*
156* =====================================================================
157*
158* .. Parameters ..
159 REAL ONE, ZERO
160 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL RESULT( NTESTS ), Z( 3 )
180* ..
181* .. External Functions ..
182 REAL SASUM, SGET06, SLANGT
183 EXTERNAL sasum, sget06, slangt
184* ..
185* .. External Subroutines ..
186 EXTERNAL aladhd, alaerh, alasvm, scopy, serrvx, sget04,
187 $ sgtsv, sgtsvx, sgtt01, sgtt02, sgtt05, sgttrf,
188 $ sgttrs, slacpy, slagtm, slarnv, slaset, slatb4,
189 $ slatms, sscal
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 ) = 'Single 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 serrvx( 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 SLATB4.
243*
244 CALL slatb4( 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 = 'SLATMS'
254 CALL slatms( 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 SLATMS.
259*
260 IF( info.NE.0 ) THEN
261 CALL alaerh( path, 'SLATMS', 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 scopy( n-1, af( 4 ), 3, a, 1 )
269 CALL scopy( n-1, af( 3 ), 3, a( n+m+1 ), 1 )
270 END IF
271 CALL scopy( 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 slarnv( 2, iseed, n+2*m, a )
282 IF( anorm.NE.one )
283 $ CALL sscal( 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 SGTSVX.
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 scopy( n+2*m, a, 1, af, 1 )
351*
352* Compute the 1-norm and infinity-norm of A.
353*
354 anormo = slangt( '1', n, a, a( m+1 ), a( n+m+1 ) )
355 anormi = slangt( 'I', n, a, a( m+1 ), a( n+m+1 ) )
356*
357* Factor the matrix A.
358*
359 CALL sgttrf( n, af, af( m+1 ), af( n+m+1 ),
360 $ af( n+2*m+1 ), iwork, info )
361*
362* Use SGTTRS 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 sgttrs( '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, sasum( 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 SGTTRS 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 sgttrs( '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, sasum( 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 slarnv( 2, iseed, n, xact( ix ) )
422 ix = ix + lda
423 70 CONTINUE
424*
425* Set the right hand side.
426*
427 CALL slagtm( 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 SGTSV ---
433*
434* Solve the system using Gaussian elimination with
435* partial pivoting.
436*
437 CALL scopy( n+2*m, a, 1, af, 1 )
438 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
439*
440 srnamt = 'SGTSV '
441 CALL sgtsv( n, nrhs, af, af( m+1 ), af( n+m+1 ), x,
442 $ lda, info )
443*
444* Check error code from SGTSV .
445*
446 IF( info.NE.izero )
447 $ CALL alaerh( path, 'SGTSV ', 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 slacpy( 'Full', n, nrhs, b, lda, work,
456 $ lda )
457 CALL sgtt02( 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 sget04( 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 )'SGTSV ', 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 SGTSVX ---
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 slaset( 'Full', n, nrhs, zero, zero, x, lda )
494*
495* Solve the system and compute the condition number and
496* error bounds using SGTSVX.
497*
498 srnamt = 'SGTSVX'
499 CALL sgtsvx( 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 SGTSVX.
506*
507 IF( info.NE.izero )
508 $ CALL alaerh( path, 'SGTSVX', 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 sgtt01( 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 slacpy( 'Full', n, nrhs, b, lda, work, lda )
531 CALL sgtt02( 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 sget04( n, nrhs, x, lda, xact, lda, rcondc,
538 $ result( 3 ) )
539*
540* Check the error bounds from iterative refinement.
541*
542 CALL sgtt05( 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 )'SGTSVX', 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 ) = sget06( 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 )'SGTSVX', 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 SDRVGT
589*
sgtsv
subroutine sgtsv(n, nrhs, dl, d, du, b, ldb, info)
SGTSV computes the solution to system of linear equations A * X = B for GT matrices
Definition sgtsv.f:127
sgtsvx
subroutine sgtsvx(fact, trans, n, nrhs, dl, d, du, dlf, df, duf, du2, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, info)
SGTSVX computes the solution to system of linear equations A * X = B for GT matrices
Definition sgtsvx.f:293

◆ sdrvls()

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

SDRVLS

Purpose:
!>
!> SDRVLS tests the least squares driver routines SGELS, SGETSLS, SGELSS, SGELSY,
!> and SGELSD.
!>
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 REAL
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[out]A
!>          A is REAL 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 REAL array, dimension (MMAX*NMAX)
!>
[out]B
!>          B is REAL 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 REAL array, dimension (MMAX*NSMAX)
!>
[out]C
!>          C is REAL array, dimension (MMAX*NSMAX)
!>
[out]S
!>          S is REAL array, dimension
!>                      (min(MMAX,NMAX))
!>
[out]COPYS
!>          COPYS is REAL array, dimension
!>                      (min(MMAX,NMAX))
!>
[in]NOUT
!>          NOUT is INTEGER
!>          The unit number for output.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 189 of file sdrvls.f.

192*
193* -- LAPACK test routine --
194* -- LAPACK is a software package provided by Univ. of Tennessee, --
195* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
196*
197* .. Scalar Arguments ..
198 LOGICAL TSTERR
199 INTEGER NM, NN, NNB, NNS, NOUT
200 REAL THRESH
201* ..
202* .. Array Arguments ..
203 LOGICAL DOTYPE( * )
204 INTEGER MVAL( * ), NBVAL( * ), NSVAL( * ),
205 $ NVAL( * ), NXVAL( * )
206 REAL 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 REAL ONE, TWO, ZERO
218 parameter( one = 1.0e0, two = 2.0e0, zero = 0.0e0 )
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_SGELS, LWORK_SGETSLS, LWORK_SGELSS,
229 $ LWORK_SGELSY, LWORK_SGELSD
230 REAL EPS, NORMA, NORMB, RCOND
231* ..
232* .. Local Arrays ..
233 INTEGER ISEED( 4 ), ISEEDY( 4 ), IWQ( 1 )
234 REAL RESULT( NTESTS ), WQ( 1 )
235* ..
236* .. Allocatable Arrays ..
237 REAL, ALLOCATABLE :: WORK (:)
238 INTEGER, ALLOCATABLE :: IWORK (:)
239* ..
240* .. External Functions ..
241 REAL SASUM, SLAMCH, SQRT12, SQRT14, SQRT17
242 EXTERNAL sasum, slamch, sqrt12, sqrt14, sqrt17
243* ..
244* .. External Subroutines ..
245 EXTERNAL alaerh, alahd, alasvm, saxpy, serrls, sgels,
246 $ sgelsd, sgelss, sgelsy, sgemm, slacpy,
247 $ slarnv, sqrt13, sqrt15, sqrt16, sscal,
248 $ xlaenv, sgetsls
249* ..
250* .. Intrinsic Functions ..
251 INTRINSIC int, log, max, min, real, 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 ) = 'SINGLE 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 = slamch( '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 serrls( 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* SQRT14, SQRT17 (two side cases), SQRT15 and SQRT12
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 SGELS
357 CALL sgels( trans, m, n, nrhs, a, lda,
358 $ b, ldb, wq( 1 ), -1, info )
359 lwork_sgels = int( wq( 1 ) )
360* Compute workspace needed for SGETSLS
361 CALL sgetsls( trans, m, n, nrhs, a, lda,
362 $ b, ldb, wq( 1 ), -1, info )
363 lwork_sgetsls = int( wq( 1 ) )
364 ENDDO
365 END IF
366* Compute workspace needed for SGELSY
367 CALL sgelsy( m, n, nrhs, a, lda, b, ldb, iwq,
368 $ rcond, crank, wq, -1, info )
369 lwork_sgelsy = int( wq( 1 ) )
370* Compute workspace needed for SGELSS
371 CALL sgelss( m, n, nrhs, a, lda, b, ldb, s,
372 $ rcond, crank, wq, -1 , info )
373 lwork_sgelss = int( wq( 1 ) )
374* Compute workspace needed for SGELSD
375 CALL sgelsd( m, n, nrhs, a, lda, b, ldb, s,
376 $ rcond, crank, wq, -1, iwq, info )
377 lwork_sgelsd = int( wq( 1 ) )
378* Compute LIWORK workspace needed for SGELSY and SGELSD
379 liwork = max( liwork, n, iwq( 1 ) )
380* Compute LWORK workspace needed for all functions
381 lwork = max( lwork, lwork_sgels, lwork_sgetsls,
382 $ lwork_sgelsy, lwork_sgelss,
383 $ lwork_sgelsd )
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 SGELS
418*
419* Generate a matrix of scaling type ISCALE
420*
421 CALL sqrt13( 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 slarnv( 2, iseed, ncols*nrhs,
444 $ work )
445 CALL sscal( ncols*nrhs,
446 $ one / real( ncols ), work,
447 $ 1 )
448 END IF
449 CALL sgemm( trans, 'No transpose', nrows,
450 $ nrhs, ncols, one, copya, lda,
451 $ work, ldwork, zero, b, ldb )
452 CALL slacpy( '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 slacpy( 'Full', m, n, copya, lda,
459 $ a, lda )
460 CALL slacpy( 'Full', nrows, nrhs,
461 $ copyb, ldb, b, ldb )
462 END IF
463 srnamt = 'SGELS '
464 CALL sgels( trans, m, n, nrhs, a, lda, b,
465 $ ldb, work, lwork, info )
466 IF( info.NE.0 )
467 $ CALL alaerh( path, 'SGELS ', 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 slacpy( 'Full', nrows, nrhs,
477 $ copyb, ldb, c, ldb )
478 CALL sqrt16( 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 ) = sqrt17( 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 ) = sqrt14( 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 SGETSLS
519*
520* Generate a matrix of scaling type ISCALE
521*
522 CALL sqrt13( 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 slarnv( 2, iseed, ncols*nrhs,
547 $ work )
548 CALL sscal( ncols*nrhs,
549 $ one / real( ncols ), work,
550 $ 1 )
551 END IF
552 CALL sgemm( trans, 'No transpose', nrows,
553 $ nrhs, ncols, one, copya, lda,
554 $ work, ldwork, zero, b, ldb )
555 CALL slacpy( '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 slacpy( 'Full', m, n, copya, lda,
562 $ a, lda )
563 CALL slacpy( 'Full', nrows, nrhs,
564 $ copyb, ldb, b, ldb )
565 END IF
566 srnamt = 'SGETSLS '
567 CALL sgetsls( trans, m, n, nrhs, a,
568 $ lda, b, ldb, work, lwork, info )
569 IF( info.NE.0 )
570 $ CALL alaerh( path, 'SGETSLS ', 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 slacpy( 'Full', nrows, nrhs,
580 $ copyb, ldb, c, ldb )
581 CALL sqrt16( 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 ) = sqrt17( 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 ) = sqrt14( 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 sqrt15( 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 SGELSY
641*
642* SGELSY: 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 slacpy( 'Full', m, n, copya, lda, a, lda )
654 CALL slacpy( 'Full', m, nrhs, copyb, ldb, b,
655 $ ldb )
656*
657 srnamt = 'SGELSY'
658 CALL sgelsy( m, n, nrhs, a, lda, b, ldb, iwork,
659 $ rcond, crank, work, lwlsy, info )
660 IF( info.NE.0 )
661 $ CALL alaerh( path, 'SGELSY', 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 ) = sqrt12( crank, crank, a, lda,
669 $ copys, work, lwork )
670*
671* Test 4: Compute error in solution
672* workspace: M*NRHS + M
673*
674 CALL slacpy( 'Full', m, nrhs, copyb, ldb, work,
675 $ ldwork )
676 CALL sqrt16( '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 ) = sqrt17( '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 ) = sqrt14( 'No transpose', m, n,
696 $ nrhs, copya, lda, b, ldb,
697 $ work, lwork )
698*
699* Test SGELSS
700*
701* SGELSS: Compute the minimum-norm solution X
702* to min( norm( A * X - B ) )
703* using the SVD.
704*
705 CALL slacpy( 'Full', m, n, copya, lda, a, lda )
706 CALL slacpy( 'Full', m, nrhs, copyb, ldb, b,
707 $ ldb )
708 srnamt = 'SGELSS'
709 CALL sgelss( m, n, nrhs, a, lda, b, ldb, s,
710 $ rcond, crank, work, lwork, info )
711 IF( info.NE.0 )
712 $ CALL alaerh( path, 'SGELSS', 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 saxpy( mnmin, -one, copys, 1, s, 1 )
723 result( 7 ) = sasum( mnmin, s, 1 ) /
724 $ sasum( mnmin, copys, 1 ) /
725 $ ( eps*real( mnmin ) )
726 ELSE
727 result( 7 ) = zero
728 END IF
729*
730* Test 8: Compute error in solution
731*
732 CALL slacpy( 'Full', m, nrhs, copyb, ldb, work,
733 $ ldwork )
734 CALL sqrt16( '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 ) = sqrt17( '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 ) = sqrt14( 'No transpose', m, n,
751 $ nrhs, copya, lda, b, ldb,
752 $ work, lwork )
753*
754* Test SGELSD
755*
756* SGELSD: 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 slacpy( 'Full', m, n, copya, lda, a, lda )
767 CALL slacpy( 'Full', m, nrhs, copyb, ldb, b,
768 $ ldb )
769*
770 srnamt = 'SGELSD'
771 CALL sgelsd( 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, 'SGELSD', 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 saxpy( mnmin, -one, copys, 1, s, 1 )
783 result( 11 ) = sasum( mnmin, s, 1 ) /
784 $ sasum( mnmin, copys, 1 ) /
785 $ ( eps*real( mnmin ) )
786 ELSE
787 result( 11 ) = zero
788 END IF
789*
790* Test 12: Compute error in solution
791*
792 CALL slacpy( 'Full', m, nrhs, copyb, ldb, work,
793 $ ldwork )
794 CALL sqrt16( '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 ) = sqrt17( '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 ) = sqrt14( '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 SDRVLS
852*
sgelsd
subroutine sgelsd(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, work, lwork, iwork, info)
SGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices
Definition sgelsd.f:210
sgelss
subroutine sgelss(m, n, nrhs, a, lda, b, ldb, s, rcond, rank, work, lwork, info)
SGELSS solves overdetermined or underdetermined systems for GE matrices
Definition sgelss.f:172
sgetsls
subroutine sgetsls(trans, m, n, nrhs, a, lda, b, ldb, work, lwork, info)
SGETSLS
Definition sgetsls.f:162
sgelsy
subroutine sgelsy(m, n, nrhs, a, lda, b, ldb, jpvt, rcond, rank, work, lwork, info)
SGELSY solves overdetermined or underdetermined systems for GE matrices
Definition sgelsy.f:204
sgels
subroutine sgels(trans, m, n, nrhs, a, lda, b, ldb, work, lwork, info)
SGELS solves overdetermined or underdetermined systems for GE matrices
Definition sgels.f:183
saxpy
subroutine saxpy(n, sa, sx, incx, sy, incy)
SAXPY
Definition saxpy.f:89
sgemm
subroutine sgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
SGEMM
Definition sgemm.f:187
sqrt16
subroutine sqrt16(trans, m, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
SQRT16
Definition sqrt16.f:133
sqrt15
subroutine sqrt15(scale, rksel, m, n, nrhs, a, lda, b, ldb, s, rank, norma, normb, iseed, work, lwork)
SQRT15
Definition sqrt15.f:148
sqrt14
real function sqrt14(trans, m, n, nrhs, a, lda, x, ldx, work, lwork)
SQRT14
Definition sqrt14.f:116
sqrt17
real function sqrt17(trans, iresid, m, n, nrhs, a, lda, x, ldx, b, ldb, c, work, lwork)
SQRT17
Definition sqrt17.f:153
serrls
subroutine serrls(path, nunit)
SERRLS
Definition serrls.f:55
sqrt13
subroutine sqrt13(scale, m, n, a, lda, norma, iseed)
SQRT13
Definition sqrt13.f:91

◆ sdrvpb()

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

SDRVPB

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

Definition at line 161 of file sdrvpb.f.

164*
165* -- LAPACK test routine --
166* -- LAPACK is a software package provided by Univ. of Tennessee, --
167* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
168*
169* .. Scalar Arguments ..
170 LOGICAL TSTERR
171 INTEGER NMAX, NN, NOUT, NRHS
172 REAL THRESH
173* ..
174* .. Array Arguments ..
175 LOGICAL DOTYPE( * )
176 INTEGER IWORK( * ), NVAL( * )
177 REAL A( * ), AFAC( * ), ASAV( * ), B( * ),
178 $ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
179 $ X( * ), XACT( * )
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 REAL ONE, ZERO
186 parameter( one = 1.0e+0, zero = 0.0e+0 )
187 INTEGER NTYPES, 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 REAL 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 REAL RESULT( NTESTS )
207* ..
208* .. External Functions ..
209 LOGICAL LSAME
210 REAL SGET06, SLANGE, SLANSB
211 EXTERNAL lsame, sget06, slange, slansb
212* ..
213* .. External Subroutines ..
214 EXTERNAL aladhd, alaerh, alasvm, scopy, serrvx, sget04,
215 $ slacpy, slaqsb, slarhs, slaset, slatb4, slatms,
216 $ spbequ, spbsv, spbsvx, spbt01, spbt02, spbt05,
217 $ spbtrf, spbtrs, sswap, 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 ) = 'Single 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 serrvx( 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 SLATB4 and generate a test
319* matrix with SLATMS.
320*
321 CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM,
322 $ MODE, CNDNUM, DIST )
323*
324 srnamt = 'SLATMS'
325 CALL slatms( 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 SLATMS.
330*
331 IF( info.NE.0 ) THEN
332 CALL alaerh( path, 'SLATMS', 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 scopy( izero-i1, work( iw ), 1,
346 $ a( ioff-izero+i1 ), 1 )
347 iw = iw + izero - i1
348 CALL scopy( i2-izero+1, work( iw ), 1,
349 $ a( ioff ), max( ldab-1, 1 ) )
350 ELSE
351 ioff = ( i1-1 )*ldab + 1
352 CALL scopy( 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 scopy( 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 sswap( izero-i1, a( ioff-izero+i1 ), 1,
388 $ work( iw ), 1 )
389 iw = iw + izero - i1
390 CALL sswap( i2-izero+1, a( ioff ),
391 $ max( ldab-1, 1 ), work( iw ), 1 )
392 ELSE
393 ioff = ( i1-1 )*ldab + 1
394 CALL sswap( 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 sswap( 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 slacpy( '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 SPBSVX (FACT =
430* 'N' reuses the condition number from the
431* previous iteration with FACT = 'F').
432*
433 CALL slacpy( '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 spbequ( 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 slaqsb( 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 SGET04.
455*
456 IF( equil )
457 $ roldc = rcondc
458*
459* Compute the 1-norm of A.
460*
461 anorm = slansb( '1', uplo, n, kd, afac, ldab,
462 $ rwork )
463*
464* Factor the matrix A.
465*
466 CALL spbtrf( uplo, n, kd, afac, ldab, info )
467*
468* Form the inverse of A.
469*
470 CALL slaset( 'Full', n, n, zero, one, a,
471 $ lda )
472 srnamt = 'SPBTRS'
473 CALL spbtrs( uplo, n, kd, n, afac, ldab, a,
474 $ lda, info )
475*
476* Compute the 1-norm condition number of A.
477*
478 ainvnm = slange( '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 slacpy( '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 = 'SLARHS'
495 CALL slarhs( path, xtype, uplo, ' ', n, n, kd,
496 $ kd, nrhs, a, ldab, xact, lda, b,
497 $ lda, iseed, info )
498 xtype = 'C'
499 CALL slacpy( 'Full', n, nrhs, b, lda, bsav,
500 $ lda )
501*
502 IF( nofact ) THEN
503*
504* --- Test SPBSV ---
505*
506* Compute the L*L' or U'*U factorization of the
507* matrix and solve the system.
508*
509 CALL slacpy( 'Full', kd+1, n, a, ldab, afac,
510 $ ldab )
511 CALL slacpy( 'Full', n, nrhs, b, lda, x,
512 $ lda )
513*
514 srnamt = 'SPBSV '
515 CALL spbsv( uplo, n, kd, nrhs, afac, ldab, x,
516 $ lda, info )
517*
518* Check error code from SPBSV .
519*
520 IF( info.NE.izero ) THEN
521 CALL alaerh( path, 'SPBSV ', 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 spbt01( uplo, n, kd, a, ldab, afac,
533 $ ldab, rwork, result( 1 ) )
534*
535* Compute residual of the computed solution.
536*
537 CALL slacpy( 'Full', n, nrhs, b, lda, work,
538 $ lda )
539 CALL spbt02( 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 sget04( 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 )'SPBSV ',
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 SPBSVX ---
566*
567 IF( .NOT.prefac )
568 $ CALL slaset( 'Full', kd+1, n, zero, zero,
569 $ afac, ldab )
570 CALL slaset( '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 slaqsb( 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 SPBSVX.
583*
584 srnamt = 'SPBSVX'
585 CALL spbsvx( 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 SPBSVX.
591*
592 IF( info.NE.izero ) THEN
593 CALL alaerh( path, 'SPBSVX', 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 spbt01( 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 slacpy( 'Full', n, nrhs, bsav, lda,
616 $ work, lda )
617 CALL spbt02( 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 sget04( n, nrhs, x, lda, xact, lda,
626 $ rcondc, result( 3 ) )
627 ELSE
628 CALL sget04( 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 spbt05( 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 SPBSVX with the computed
644* value in RCONDC.
645*
646 result( 6 ) = sget06( 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 )'SPBSVX',
657 $ fact, uplo, n, kd, equed, imat, k,
658 $ result( k )
659 ELSE
660 WRITE( nout, fmt = 9998 )'SPBSVX',
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 SDRVPB
689*
slaqsb
subroutine slaqsb(uplo, n, kd, ab, ldab, s, scond, amax, equed)
SLAQSB scales a symmetric/Hermitian band matrix, using scaling factors computed by spbequ.
Definition slaqsb.f:140
spbsv
subroutine spbsv(uplo, n, kd, nrhs, ab, ldab, b, ldb, info)
SPBSV computes the solution to system of linear equations A * X = B for OTHER matrices
Definition spbsv.f:164
spbsvx
subroutine spbsvx(fact, uplo, n, kd, nrhs, ab, ldab, afb, ldafb, equed, s, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, info)
SPBSVX computes the solution to system of linear equations A * X = B for OTHER matrices
Definition spbsvx.f:343

◆ sdrvpo()

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

SDRVPO

SDRVPOX

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

Definition at line 161 of file sdrvpo.f.

164*
165* -- LAPACK test routine --
166* -- LAPACK is a software package provided by Univ. of Tennessee, --
167* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
168*
169* .. Scalar Arguments ..
170 LOGICAL TSTERR
171 INTEGER NMAX, NN, NOUT, NRHS
172 REAL THRESH
173* ..
174* .. Array Arguments ..
175 LOGICAL DOTYPE( * )
176 INTEGER IWORK( * ), NVAL( * )
177 REAL A( * ), AFAC( * ), ASAV( * ), B( * ),
178 $ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
179 $ X( * ), XACT( * )
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 REAL ONE, ZERO
186 parameter( one = 1.0e+0, zero = 0.0e+0 )
187 INTEGER NTYPES
188 parameter( ntypes = 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 REAL 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 REAL RESULT( NTESTS )
206* ..
207* .. External Functions ..
208 LOGICAL LSAME
209 REAL SGET06, SLANSY
210 EXTERNAL lsame, sget06, slansy
211* ..
212* .. External Subroutines ..
213 EXTERNAL aladhd, alaerh, alasvm, serrvx, sget04, slacpy,
214 $ slaqsy, slarhs, slaset, slatb4, slatms, spoequ,
215 $ sposv, sposvx, spot01, spot02, spot05, spotrf,
216 $ spotri, 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 ) = 'Single 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 serrvx( 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 SLATB4 and generate a test matrix
291* with SLATMS.
292*
293 CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
294 $ CNDNUM, DIST )
295*
296 srnamt = 'SLATMS'
297 CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE,
298 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
299 $ INFO )
300*
301* Check error code from SLATMS.
302*
303 IF( info.NE.0 ) THEN
304 CALL alaerh( path, 'SLATMS', 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 slacpy( 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 SPOSVX (FACT = 'N' reuses
375* the condition number from the previous iteration
376* with FACT = 'F').
377*
378 CALL slacpy( 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 spoequ( 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 slaqsy( 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 SGET04.
399*
400 IF( equil )
401 $ roldc = rcondc
402*
403* Compute the 1-norm of A.
404*
405 anorm = slansy( '1', uplo, n, afac, lda, rwork )
406*
407* Factor the matrix A.
408*
409 CALL spotrf( uplo, n, afac, lda, info )
410*
411* Form the inverse of A.
412*
413 CALL slacpy( uplo, n, n, afac, lda, a, lda )
414 CALL spotri( uplo, n, a, lda, info )
415*
416* Compute the 1-norm condition number of A.
417*
418 ainvnm = slansy( '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 slacpy( uplo, n, n, asav, lda, a, lda )
429*
430* Form an exact solution and set the right hand side.
431*
432 srnamt = 'SLARHS'
433 CALL slarhs( path, xtype, uplo, ' ', n, n, kl, ku,
434 $ nrhs, a, lda, xact, lda, b, lda,
435 $ iseed, info )
436 xtype = 'C'
437 CALL slacpy( 'Full', n, nrhs, b, lda, bsav, lda )
438*
439 IF( nofact ) THEN
440*
441* --- Test SPOSV ---
442*
443* Compute the L*L' or U'*U factorization of the
444* matrix and solve the system.
445*
446 CALL slacpy( uplo, n, n, a, lda, afac, lda )
447 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
448*
449 srnamt = 'SPOSV '
450 CALL sposv( uplo, n, nrhs, afac, lda, x, lda,
451 $ info )
452*
453* Check error code from SPOSV .
454*
455 IF( info.NE.izero ) THEN
456 CALL alaerh( path, 'SPOSV ', 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 spot01( uplo, n, a, lda, afac, lda, rwork,
468 $ result( 1 ) )
469*
470* Compute residual of the computed solution.
471*
472 CALL slacpy( 'Full', n, nrhs, b, lda, work,
473 $ lda )
474 CALL spot02( uplo, n, nrhs, a, lda, x, lda,
475 $ work, lda, rwork, result( 2 ) )
476*
477* Check solution from generated exact solution.
478*
479 CALL sget04( 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 )'SPOSV ', 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 SPOSVX ---
500*
501 IF( .NOT.prefac )
502 $ CALL slaset( uplo, n, n, zero, zero, afac, lda )
503 CALL slaset( '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 slaqsy( 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 SPOSVX.
515*
516 srnamt = 'SPOSVX'
517 CALL sposvx( 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 SPOSVX.
523*
524 IF( info.NE.izero ) THEN
525 CALL alaerh( path, 'SPOSVX', 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 spot01( 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 slacpy( 'Full', n, nrhs, bsav, lda, work,
547 $ lda )
548 CALL spot02( 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 sget04( n, nrhs, x, lda, xact, lda,
557 $ rcondc, result( 3 ) )
558 ELSE
559 CALL sget04( 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 spot05( 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 SPOSVX with the computed value
574* in RCONDC.
575*
576 result( 6 ) = sget06( 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 )'SPOSVX', fact,
587 $ uplo, n, equed, imat, k, result( k )
588 ELSE
589 WRITE( nout, fmt = 9998 )'SPOSVX', 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 SDRVPO
616*
sposv
subroutine sposv(uplo, n, nrhs, a, lda, b, ldb, info)
SPOSV computes the solution to system of linear equations A * X = B for PO matrices
Definition sposv.f:130
sposvx
subroutine sposvx(fact, uplo, n, nrhs, a, lda, af, ldaf, equed, s, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, info)
SPOSVX computes the solution to system of linear equations A * X = B for PO matrices
Definition sposvx.f:307
slaqsy
subroutine slaqsy(uplo, n, a, lda, s, scond, amax, equed)
SLAQSY scales a symmetric/Hermitian matrix, using scaling factors computed by spoequ.
Definition slaqsy.f:133

◆ sdrvpp()

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

SDRVPP

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

Definition at line 164 of file sdrvpp.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 REAL THRESH
176* ..
177* .. Array Arguments ..
178 LOGICAL DOTYPE( * )
179 INTEGER IWORK( * ), NVAL( * )
180 REAL A( * ), AFAC( * ), ASAV( * ), B( * ),
181 $ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
182 $ X( * ), XACT( * )
183* ..
184*
185* =====================================================================
186*
187* .. Parameters ..
188 REAL ONE, ZERO
189 parameter( one = 1.0e+0, zero = 0.0e+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 REAL 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 REAL RESULT( NTESTS )
209* ..
210* .. External Functions ..
211 LOGICAL LSAME
212 REAL SGET06, SLANSP
213 EXTERNAL lsame, sget06, slansp
214* ..
215* .. External Subroutines ..
216 EXTERNAL aladhd, alaerh, alasvm, scopy, serrvx, sget04,
217 $ slacpy, slaqsp, slarhs, slaset, slatb4, slatms,
218 $ sppequ, sppsv, sppsvx, sppt01, sppt02, sppt05,
219 $ spptrf, spptri
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 ) = 'Single 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 serrvx( 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 SLATB4 and generate a test matrix
288* with SLATMS.
289*
290 CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
291 $ CNDNUM, DIST )
292 rcondc = one / cndnum
293*
294 srnamt = 'SLATMS'
295 CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE,
296 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
297 $ INFO )
298*
299* Check error code from SLATMS.
300*
301 IF( info.NE.0 ) THEN
302 CALL alaerh( path, 'SLATMS', 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 scopy( 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 SPPSVX (FACT = 'N' reuses
373* the condition number from the previous iteration
374* with FACT = 'F').
375*
376 CALL scopy( 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 sppequ( 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 slaqsp( 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 SGET04.
397*
398 IF( equil )
399 $ roldc = rcondc
400*
401* Compute the 1-norm of A.
402*
403 anorm = slansp( '1', uplo, n, afac, rwork )
404*
405* Factor the matrix A.
406*
407 CALL spptrf( uplo, n, afac, info )
408*
409* Form the inverse of A.
410*
411 CALL scopy( npp, afac, 1, a, 1 )
412 CALL spptri( uplo, n, a, info )
413*
414* Compute the 1-norm condition number of A.
415*
416 ainvnm = slansp( '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 scopy( npp, asav, 1, a, 1 )
427*
428* Form an exact solution and set the right hand side.
429*
430 srnamt = 'SLARHS'
431 CALL slarhs( path, xtype, uplo, ' ', n, n, kl, ku,
432 $ nrhs, a, lda, xact, lda, b, lda,
433 $ iseed, info )
434 xtype = 'C'
435 CALL slacpy( 'Full', n, nrhs, b, lda, bsav, lda )
436*
437 IF( nofact ) THEN
438*
439* --- Test SPPSV ---
440*
441* Compute the L*L' or U'*U factorization of the
442* matrix and solve the system.
443*
444 CALL scopy( npp, a, 1, afac, 1 )
445 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
446*
447 srnamt = 'SPPSV '
448 CALL sppsv( uplo, n, nrhs, afac, x, lda, info )
449*
450* Check error code from SPPSV .
451*
452 IF( info.NE.izero ) THEN
453 CALL alaerh( path, 'SPPSV ', 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 sppt01( uplo, n, a, afac, rwork,
465 $ result( 1 ) )
466*
467* Compute residual of the computed solution.
468*
469 CALL slacpy( 'Full', n, nrhs, b, lda, work,
470 $ lda )
471 CALL sppt02( uplo, n, nrhs, a, x, lda, work,
472 $ lda, rwork, result( 2 ) )
473*
474* Check solution from generated exact solution.
475*
476 CALL sget04( 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 )'SPPSV ', 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 SPPSVX ---
497*
498 IF( .NOT.prefac .AND. npp.GT.0 )
499 $ CALL slaset( 'Full', npp, 1, zero, zero, afac,
500 $ npp )
501 CALL slaset( '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 slaqsp( 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 SPPSVX.
512*
513 srnamt = 'SPPSVX'
514 CALL sppsvx( 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 SPPSVX.
519*
520 IF( info.NE.izero ) THEN
521 CALL alaerh( path, 'SPPSVX', 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 sppt01( 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 slacpy( 'Full', n, nrhs, bsav, lda, work,
543 $ lda )
544 CALL sppt02( 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 sget04( n, nrhs, x, lda, xact, lda,
553 $ rcondc, result( 3 ) )
554 ELSE
555 CALL sget04( 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 sppt05( 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 SPPSVX with the computed value
570* in RCONDC.
571*
572 result( 6 ) = sget06( 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 )'SPPSVX', fact,
583 $ uplo, n, equed, imat, k, result( k )
584 ELSE
585 WRITE( nout, fmt = 9998 )'SPPSVX', 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 SDRVPP
613*
slaqsp
subroutine slaqsp(uplo, n, ap, s, scond, amax, equed)
SLAQSP scales a symmetric/Hermitian matrix in packed storage, using scaling factors computed by sppeq...
Definition slaqsp.f:125
sppsvx
subroutine sppsvx(fact, uplo, n, nrhs, ap, afp, equed, s, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, info)
SPPSVX computes the solution to system of linear equations A * X = B for OTHER matrices
Definition sppsvx.f:311
sppsv
subroutine sppsv(uplo, n, nrhs, ap, b, ldb, info)
SPPSV computes the solution to system of linear equations A * X = B for OTHER matrices
Definition sppsv.f:144

◆ sdrvpt()

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

SDRVPT

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

140*
141* -- LAPACK test routine --
142* -- LAPACK is a software package provided by Univ. of Tennessee, --
143* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
144*
145* .. Scalar Arguments ..
146 LOGICAL TSTERR
147 INTEGER NN, NOUT, NRHS
148 REAL THRESH
149* ..
150* .. Array Arguments ..
151 LOGICAL DOTYPE( * )
152 INTEGER NVAL( * )
153 REAL A( * ), B( * ), D( * ), E( * ), RWORK( * ),
154 $ WORK( * ), X( * ), XACT( * )
155* ..
156*
157* =====================================================================
158*
159* .. Parameters ..
160 REAL ONE, ZERO
161 parameter( one = 1.0e+0, zero = 0.0e+0 )
162 INTEGER NTYPES
163 parameter( ntypes = 12 )
164 INTEGER NTESTS
165 parameter( ntests = 6 )
166* ..
167* .. Local Scalars ..
168 LOGICAL 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 REAL AINVNM, ANORM, COND, DMAX, RCOND, RCONDC
175* ..
176* .. Local Arrays ..
177 INTEGER ISEED( 4 ), ISEEDY( 4 )
178 REAL RESULT( NTESTS ), Z( 3 )
179* ..
180* .. External Functions ..
181 INTEGER ISAMAX
182 REAL SASUM, SGET06, SLANST
183 EXTERNAL isamax, sasum, sget06, slanst
184* ..
185* .. External Subroutines ..
186 EXTERNAL aladhd, alaerh, alasvm, scopy, serrvx, sget04,
187 $ slacpy, slaptm, slarnv, slaset, slatb4, slatms,
188 $ sptsv, sptsvx, sptt01, sptt02, sptt05, spttrf,
189 $ spttrs, sscal
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 ) = 'Single 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 serrvx( 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 SLATB4.
241*
242 CALL slatb4( 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 = 'SLATMS'
252 CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE, COND,
253 $ ANORM, KL, KU, 'B', A, 2, WORK, INFO )
254*
255* Check the error code from SLATMS.
256*
257 IF( info.NE.0 ) THEN
258 CALL alaerh( path, 'SLATMS', 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 slarnv( 2, iseed, n, d )
284 CALL slarnv( 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 = isamax( n, d, 1 )
302 dmax = d( ix )
303 CALL sscal( n, anorm / dmax, d, 1 )
304 IF( n.GT.1 )
305 $ CALL sscal( 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 slarnv( 2, iseed, n, xact( ix ) )
364 ix = ix + lda
365 40 CONTINUE
366*
367* Set the right hand side.
368*
369 CALL slaptm( 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 SPTSVX.
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 = slanst( '1', n, d, e )
391*
392 CALL scopy( n, d, 1, d( n+1 ), 1 )
393 IF( n.GT.1 )
394 $ CALL scopy( n-1, e, 1, e( n+1 ), 1 )
395*
396* Factor the matrix A.
397*
398 CALL spttrf( n, d( n+1 ), e( n+1 ), info )
399*
400* Use SPTTRS 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 spttrs( n, 1, d( n+1 ), e( n+1 ), x, lda,
410 $ info )
411 ainvnm = max( ainvnm, sasum( 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 SPTSV --
426*
427 CALL scopy( n, d, 1, d( n+1 ), 1 )
428 IF( n.GT.1 )
429 $ CALL scopy( n-1, e, 1, e( n+1 ), 1 )
430 CALL slacpy( '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 = 'SPTSV '
435 CALL sptsv( n, nrhs, d( n+1 ), e( n+1 ), x, lda,
436 $ info )
437*
438* Check error code from SPTSV .
439*
440 IF( info.NE.izero )
441 $ CALL alaerh( path, 'SPTSV ', 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 sptt01( n, d, e, d( n+1 ), e( n+1 ), work,
451 $ result( 1 ) )
452*
453* Compute the residual in the solution.
454*
455 CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
456 CALL sptt02( n, nrhs, d, e, x, lda, work, lda,
457 $ result( 2 ) )
458*
459* Check solution from generated exact solution.
460*
461 CALL sget04( 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 )'SPTSV ', 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 SPTSVX ---
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 slaset( 'Full', n, nrhs, zero, zero, x, lda )
496*
497* Solve the system and compute the condition number and
498* error bounds using SPTSVX.
499*
500 srnamt = 'SPTSVX'
501 CALL sptsvx( 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 SPTSVX.
506*
507 IF( info.NE.izero )
508 $ CALL alaerh( path, 'SPTSVX', 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 sptt01( 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 slacpy( 'Full', n, nrhs, b, lda, work, lda )
526 CALL sptt02( n, nrhs, d, e, x, lda, work, lda,
527 $ result( 2 ) )
528*
529* Check solution from generated exact solution.
530*
531 CALL sget04( n, nrhs, x, lda, xact, lda, rcondc,
532 $ result( 3 ) )
533*
534* Check error bounds from iterative refinement.
535*
536 CALL sptt05( 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 ) = sget06( 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 )'SPTSVX', 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 SDRVPT
574*
sptsv
subroutine sptsv(n, nrhs, d, e, b, ldb, info)
SPTSV computes the solution to system of linear equations A * X = B for PT matrices
Definition sptsv.f:114
sptsvx
subroutine sptsvx(fact, n, nrhs, d, e, df, ef, b, ldb, x, ldx, rcond, ferr, berr, work, info)
SPTSVX computes the solution to system of linear equations A * X = B for PT matrices
Definition sptsvx.f:228

◆ sdrvrf1()

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

SDRVRF1

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

Definition at line 93 of file sdrvrf1.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 REAL THRESH
102* ..
103* .. Array Arguments ..
104 INTEGER NVAL( NN )
105 REAL A( LDA, * ), ARF( * ), WORK( * )
106* ..
107*
108* =====================================================================
109* ..
110* .. Parameters ..
111 REAL ONE
112 parameter( one = 1.0e+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 REAL EPS, LARGE, NORMA, NORMARF, SMALL
121* ..
122* .. Local Arrays ..
123 CHARACTER UPLOS( 2 ), FORMS( 2 ), NORMS( 4 )
124 INTEGER ISEED( 4 ), ISEEDY( 4 )
125 REAL RESULT( NTESTS )
126* ..
127* .. External Functions ..
128 REAL SLAMCH, SLANSY, SLANSF, SLARND
129 EXTERNAL slamch, slansy, slansf, slarnd
130* ..
131* .. External Subroutines ..
132 EXTERNAL strttf
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 = slamch( 'Precision' )
159 small = slamch( '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* Quick Return if possible
173 IF ( n .EQ. 0 ) EXIT
174*
175* IIT = 1 : random matrix
176* IIT = 2 : random matrix scaled near underflow
177* IIT = 3 : random matrix scaled near overflow
178*
179 DO j = 1, n
180 DO i = 1, n
181 a( i, j) = slarnd( 2, iseed )
182 END DO
183 END DO
184*
185 IF ( iit.EQ.2 ) THEN
186 DO j = 1, n
187 DO i = 1, n
188 a( i, j) = a( i, j ) * large
189 END DO
190 END DO
191 END IF
192*
193 IF ( iit.EQ.3 ) THEN
194 DO j = 1, n
195 DO i = 1, n
196 a( i, j) = a( i, j) * small
197 END DO
198 END DO
199 END IF
200*
201* Do first for UPLO = 'U', then for UPLO = 'L'
202*
203 DO 110 iuplo = 1, 2
204*
205 uplo = uplos( iuplo )
206*
207* Do first for CFORM = 'N', then for CFORM = 'C'
208*
209 DO 100 iform = 1, 2
210*
211 cform = forms( iform )
212*
213 srnamt = 'STRTTF'
214 CALL strttf( cform, uplo, n, a, lda, arf, info )
215*
216* Check error code from STRTTF
217*
218 IF( info.NE.0 ) THEN
219 IF( nfail.EQ.0 .AND. nerrs.EQ.0 ) THEN
220 WRITE( nout, * )
221 WRITE( nout, fmt = 9999 )
222 END IF
223 WRITE( nout, fmt = 9998 ) srnamt, uplo, cform, n
224 nerrs = nerrs + 1
225 GO TO 100
226 END IF
227*
228 DO 90 inorm = 1, 4
229*
230* Check all four norms: 'M', '1', 'I', 'F'
231*
232 norm = norms( inorm )
233 normarf = slansf( norm, cform, uplo, n, arf, work )
234 norma = slansy( norm, uplo, n, a, lda, work )
235*
236 result(1) = ( norma - normarf ) / norma / eps
237 nrun = nrun + 1
238*
239 IF( result(1).GE.thresh ) THEN
240 IF( nfail.EQ.0 .AND. nerrs.EQ.0 ) THEN
241 WRITE( nout, * )
242 WRITE( nout, fmt = 9999 )
243 END IF
244 WRITE( nout, fmt = 9997 ) 'SLANSF',
245 + n, iit, uplo, cform, norm, result(1)
246 nfail = nfail + 1
247 END IF
248 90 CONTINUE
249 100 CONTINUE
250 110 CONTINUE
251 120 CONTINUE
252 130 CONTINUE
253*
254* Print a summary of the results.
255*
256 IF ( nfail.EQ.0 ) THEN
257 WRITE( nout, fmt = 9996 ) 'SLANSF', nrun
258 ELSE
259 WRITE( nout, fmt = 9995 ) 'SLANSF', nfail, nrun
260 END IF
261 IF ( nerrs.NE.0 ) THEN
262 WRITE( nout, fmt = 9994 ) nerrs, 'SLANSF'
263 END IF
264*
265 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing SLANSF
266 + ***')
267 9998 FORMAT( 1x, ' Error in ',a6,' with UPLO=''',a1,''', FORM=''',
268 + a1,''', N=',i5)
269 9997 FORMAT( 1x, ' Failure in ',a6,' N=',i5,' TYPE=',i5,' UPLO=''',
270 + a1, ''', FORM =''',a1,''', NORM=''',a1,''', test=',g12.5)
271 9996 FORMAT( 1x, 'All tests for ',a6,' auxiliary routine passed the ',
272 + 'threshold ( ',i5,' tests run)')
273 9995 FORMAT( 1x, a6, ' auxiliary routine: ',i5,' out of ',i5,
274 + ' tests failed to pass the threshold')
275 9994 FORMAT( 26x, i5,' error message recorded (',a6,')')
276*
277 RETURN
278*
279* End of SDRVRF1
280*
strttf
subroutine strttf(transr, uplo, n, a, lda, arf, info)
STRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full packed f...
Definition strttf.f:194
slansf
real function slansf(norm, transr, uplo, n, a, work)
SLANSF
Definition slansf.f:209
slarnd
real function slarnd(idist, iseed)
SLARND
Definition slarnd.f:73

◆ sdrvrf2()

subroutine sdrvrf2 ( integer nout,
integer nn,
integer, dimension( nn ) nval,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) arf,
real, dimension(*) ap,
real, dimension( lda, * ) asav )

SDRVRF2

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

Definition at line 88 of file sdrvrf2.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 REAL 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 REAL SLARND
116 EXTERNAL slarnd
117* ..
118* .. External Subroutines ..
119 EXTERNAL stfttr, stfttp, strttf, strttp, stpttr, stpttf
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) = slarnd( 2, iseed )
166 END DO
167 END DO
168*
169 srnamt = 'DTRTTF'
170 CALL strttf( cform, uplo, n, a, lda, arf, info )
171*
172 srnamt = 'DTFTTP'
173 CALL stfttp( cform, uplo, n, arf, ap, info )
174*
175 srnamt = 'DTPTTR'
176 CALL stpttr( 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 strttp( uplo, n, a, lda, ap, info )
201*
202 srnamt = 'DTPTTF'
203 CALL stpttf( cform, uplo, n, ap, arf, info )
204*
205 srnamt = 'DTFTTR'
206 CALL stfttr( 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 SDRVRF2
260*
stpttf
subroutine stpttf(transr, uplo, n, ap, arf, info)
STPTTF copies a triangular matrix from the standard packed format (TP) to the rectangular full packed...
Definition stpttf.f:186
stfttp
subroutine stfttp(transr, uplo, n, arf, ap, info)
STFTTP copies a triangular matrix from the rectangular full packed format (TF) to the standard packed...
Definition stfttp.f:187
strttp
subroutine strttp(uplo, n, a, lda, ap, info)
STRTTP copies a triangular matrix from the standard full format (TR) to the standard packed format (T...
Definition strttp.f:104
stpttr
subroutine stpttr(uplo, n, ap, a, lda, info)
STPTTR copies a triangular matrix from the standard packed format (TP) to the standard full format (T...
Definition stpttr.f:104
stfttr
subroutine stfttr(transr, uplo, n, arf, a, lda, info)
STFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard full f...
Definition stfttr.f:196

◆ sdrvrf3()

subroutine sdrvrf3 ( integer nout,
integer nn,
integer, dimension( nn ) nval,
real thresh,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) arf,
real, dimension( lda, * ) b1,
real, dimension( lda, * ) b2,
real, dimension( * ) s_work_slange,
real, dimension( * ) s_work_sgeqrf,
real, dimension( * ) tau )

SDRVRF3

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

Definition at line 116 of file sdrvrf3.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 REAL THRESH
126* ..
127* .. Array Arguments ..
128 INTEGER NVAL( NN )
129 REAL A( LDA, * ), ARF( * ), B1( LDA, * ),
130 + B2( LDA, * ), S_WORK_SGEQRF( * ),
131 + S_WORK_SLANGE( * ), TAU( * )
132* ..
133*
134* =====================================================================
135* ..
136* .. Parameters ..
137 REAL ZERO, ONE
138 parameter( zero = ( 0.0e+0, 0.0e+0 ) ,
139 + one = ( 1.0e+0, 0.0e+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 REAL 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 REAL RESULT( NTESTS )
154* ..
155* .. External Functions ..
156 REAL SLAMCH, SLANGE, SLARND
157 EXTERNAL slamch, slange, slarnd
158* ..
159* .. External Subroutines ..
160 EXTERNAL strttf, sgeqrf, sgeqlf, stfsm, strsm
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 = slamch( '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 = slarnd( 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) = slarnd( 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 = 'SGEQRF'
272 CALL sgeqrf( na, na, a, lda, tau,
273 + s_work_sgeqrf, lda,
274 + info )
275 ELSE
276*
277* The case IUPLO.EQ.2 is when SIDE.EQ.'L'
278* -> QL factorization.
279*
280 srnamt = 'SGELQF'
281 CALL sgelqf( na, na, a, lda, tau,
282 + s_work_sgeqrf, lda,
283 + info )
284 END IF
285*
286* Store a copy of A in RFP format (in ARF).
287*
288 srnamt = 'STRTTF'
289 CALL strttf( 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) = slarnd( 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 STRSM
304*
305 srnamt = 'STRSM'
306 CALL strsm( 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 STFSM
311*
312 srnamt = 'STFSM'
313 CALL stfsm( 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) = slange( 'I', m, n, b1, lda,
326 + s_work_slange )
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 ) 'STFSM',
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 ) 'STFSM', nrun
355 ELSE
356 WRITE( nout, fmt = 9995 ) 'STFSM', nfail, nrun
357 END IF
358*
359 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing STFSM
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 SDRVRF3
372*
sgeqrf
subroutine sgeqrf(m, n, a, lda, tau, work, lwork, info)
SGEQRF
Definition sgeqrf.f:146
sgelqf
subroutine sgelqf(m, n, a, lda, tau, work, lwork, info)
SGELQF
Definition sgelqf.f:143
sgeqlf
subroutine sgeqlf(m, n, a, lda, tau, work, lwork, info)
SGEQLF
Definition sgeqlf.f:138
stfsm
subroutine stfsm(transr, side, uplo, trans, diag, m, n, alpha, a, b, ldb)
STFSM solves a matrix equation (one operand is a triangular matrix in RFP format).
Definition stfsm.f:277
strsm
subroutine strsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
STRSM
Definition strsm.f:181

◆ sdrvrf4()

subroutine sdrvrf4 ( integer nout,
integer nn,
integer, dimension( nn ) nval,
real thresh,
real, dimension( ldc, * ) c1,
real, dimension( ldc, *) c2,
integer ldc,
real, dimension( * ) crf,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) s_work_slange )

SDRVRF4

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

Definition at line 116 of file sdrvrf4.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 REAL THRESH
126* ..
127* .. Array Arguments ..
128 INTEGER NVAL( NN )
129 REAL A( LDA, * ), C1( LDC, * ), C2( LDC, *),
130 + CRF( * ), S_WORK_SLANGE( * )
131* ..
132*
133* =====================================================================
134* ..
135* .. Parameters ..
136 REAL ZERO, ONE
137 parameter( zero = 0.0e+0, one = 1.0e+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 REAL ALPHA, BETA, EPS, NORMA, NORMC
146* ..
147* .. Local Arrays ..
148 CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 )
149 INTEGER ISEED( 4 ), ISEEDY( 4 )
150 REAL RESULT( NTESTS )
151* ..
152* .. External Functions ..
153 REAL SLAMCH, SLARND, SLANGE
154 EXTERNAL slamch, slarnd, slange
155* ..
156* .. External Subroutines ..
157 EXTERNAL ssyrk, ssfrk, stfttr, strttf
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 = slamch( '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 = slarnd( 2, iseed )
219 beta = slarnd( 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) = slarnd( 2, iseed )
236 END DO
237 END DO
238*
239 norma = slange( 'I', n, k, a, lda,
240 + s_work_slange )
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) = slarnd( 2, iseed )
250 END DO
251 END DO
252*
253 norma = slange( 'I', k, n, a, lda,
254 + s_work_slange )
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) = slarnd( 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 SLANGE and
271* not SLANSY for C1.)
272*
273 normc = slange( 'I', n, n, c1, ldc,
274 + s_work_slange )
275*
276 srnamt = 'STRTTF'
277 CALL strttf( cform, uplo, n, c1, ldc, crf,
278 + info )
279*
280* call ssyrk the BLAS routine -> gives C1
281*
282 srnamt = 'SSYRK '
283 CALL ssyrk( uplo, trans, n, k, alpha, a, lda,
284 + beta, c1, ldc )
285*
286* call ssfrk the RFP routine -> gives CRF
287*
288 srnamt = 'SSFRK '
289 CALL ssfrk( cform, uplo, trans, n, k, alpha, a,
290 + lda, beta, crf )
291*
292* convert CRF in full format -> gives C2
293*
294 srnamt = 'STFTTR'
295 CALL stfttr( 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 SLANSY,
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 -> SLANGE
310*
311 result(1) = slange( 'I', n, n, c1, ldc,
312 + s_work_slange )
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 ) 'SSFRK',
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 ) 'SSFRK', nrun
339 ELSE
340 WRITE( nout, fmt = 9995 ) 'SSFRK', nfail, nrun
341 END IF
342*
343 9999 FORMAT( 1x, ' *** Error(s) or Failure(s) while testing SSFRK
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 SDRVRF4
356*
ssfrk
subroutine ssfrk(transr, uplo, trans, n, k, alpha, a, lda, beta, c)
SSFRK performs a symmetric rank-k operation for matrix in RFP format.
Definition ssfrk.f:166
ssyrk
subroutine ssyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
SSYRK
Definition ssyrk.f:169

◆ sdrvrfp()

subroutine sdrvrfp ( integer nout,
integer nn,
integer, dimension( nn ) nval,
integer nns,
integer, dimension( nns ) nsval,
integer nnt,
integer, dimension( nnt ) ntval,
real thresh,
real, dimension( * ) a,
real, dimension( * ) asav,
real, dimension( * ) afac,
real, dimension( * ) ainv,
real, dimension( * ) b,
real, dimension( * ) bsav,
real, dimension( * ) xact,
real, dimension( * ) x,
real, dimension( * ) arf,
real, dimension( * ) arfinv,
real, dimension( * ) s_work_slatms,
real, dimension( * ) s_work_spot01,
real, dimension( * ) s_temp_spot02,
real, dimension( * ) s_temp_spot03,
real, dimension( * ) s_work_slansy,
real, dimension( * ) s_work_spot02,
real, dimension( * ) s_work_spot03 )

SDRVRFP

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

Definition at line 232 of file sdrvrfp.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 REAL THRESH
246* ..
247* .. Array Arguments ..
248 INTEGER NVAL( NN ), NSVAL( NNS ), NTVAL( NNT )
249 REAL A( * )
250 REAL AINV( * )
251 REAL ASAV( * )
252 REAL B( * )
253 REAL BSAV( * )
254 REAL AFAC( * )
255 REAL ARF( * )
256 REAL ARFINV( * )
257 REAL XACT( * )
258 REAL X( * )
259 REAL S_WORK_SLATMS( * )
260 REAL S_WORK_SPOT01( * )
261 REAL S_TEMP_SPOT02( * )
262 REAL S_TEMP_SPOT03( * )
263 REAL S_WORK_SLANSY( * )
264 REAL S_WORK_SPOT02( * )
265 REAL S_WORK_SPOT03( * )
266* ..
267*
268* =====================================================================
269*
270* .. Parameters ..
271 REAL ONE, ZERO
272 parameter( one = 1.0e+0, zero = 0.0e+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 REAL ANORM, AINVNM, CNDNUM, RCONDC
284* ..
285* .. Local Arrays ..
286 CHARACTER UPLOS( 2 ), FORMS( 2 )
287 INTEGER ISEED( 4 ), ISEEDY( 4 )
288 REAL RESULT( NTESTS )
289* ..
290* .. External Functions ..
291 REAL SLANSY
292 EXTERNAL slansy
293* ..
294* .. External Subroutines ..
295 EXTERNAL aladhd, alaerh, alasvm, sget04, stfttr, slacpy,
296 + slarhs, slatb4, slatms, spftri, spftrf, spftrs,
297 + spot01, spot02, spot03, spotri, spotrf, strttf
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 SLATB4 and generate a test
355* matrix with SLATMS.
356*
357 CALL slatb4( 'SPO', imat, n, n, ctype, kl, ku,
358 + anorm, mode, cndnum, dist )
359*
360 srnamt = 'SLATMS'
361 CALL slatms( n, n, dist, iseed, ctype,
362 + s_work_slatms,
363 + mode, cndnum, anorm, kl, ku, uplo, a,
364 + lda, s_work_slatms, info )
365*
366* Check error code from SLATMS.
367*
368 IF( info.NE.0 ) THEN
369 CALL alaerh( 'SPF', 'SLATMS', 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 slacpy( 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 = slansy( '1', uplo, n, a, lda,
428 + s_work_slansy )
429*
430* Factor the matrix A.
431*
432 CALL spotrf( uplo, n, a, lda, info )
433*
434* Form the inverse of A.
435*
436 CALL spotri( 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 = slansy( '1', uplo, n, a, lda,
443 + s_work_slansy )
444 rcondc = ( one / anorm ) / ainvnm
445*
446* Restore the matrix A.
447*
448 CALL slacpy( 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 = 'SLARHS'
456 CALL slarhs( 'SPO', 'N', uplo, ' ', n, n, kl, ku,
457 + nrhs, a, lda, xact, lda, b, lda,
458 + iseed, info )
459 CALL slacpy( '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 slacpy( uplo, n, n, a, lda, afac, lda )
465 CALL slacpy( 'Full', n, nrhs, b, ldb, x, ldb )
466*
467 srnamt = 'STRTTF'
468 CALL strttf( cform, uplo, n, afac, lda, arf, info )
469 srnamt = 'SPFTRF'
470 CALL spftrf( cform, uplo, n, arf, info )
471*
472* Check error code from SPFTRF.
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( 'SPF', 'SPFSV ', 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 = 'SPFTRS'
493 CALL spftrs( cform, uplo, n, nrhs, arf, x, ldb,
494 + info )
495*
496 srnamt = 'STFTTR'
497 CALL stfttr( cform, uplo, n, arf, afac, lda, info )
498*
499* Reconstruct matrix from factors and compute
500* residual.
501*
502 CALL slacpy( uplo, n, n, afac, lda, asav, lda )
503 CALL spot01( uplo, n, a, lda, afac, lda,
504 + s_work_spot01, result( 1 ) )
505 CALL slacpy( 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 slacpy( 'A', n+1, n/2, arf, n+1, arfinv,
511 + n+1 )
512 ELSE
513 CALL slacpy( 'A', n, (n+1)/2, arf, n, arfinv,
514 + n )
515 END IF
516*
517 srnamt = 'SPFTRI'
518 CALL spftri( cform, uplo, n, arfinv , info )
519*
520 srnamt = 'STFTTR'
521 CALL stfttr( cform, uplo, n, arfinv, ainv, lda,
522 + info )
523*
524* Check error code from SPFTRI.
525*
526 IF( info.NE.0 )
527 + CALL alaerh( 'SPO', 'SPFTRI', info, 0, uplo, n,
528 + n, -1, -1, -1, imat, nfail, nerrs,
529 + nout )
530*
531 CALL spot03( uplo, n, a, lda, ainv, lda,
532 + s_temp_spot03, lda, s_work_spot03,
533 + rcondc, result( 2 ) )
534*
535* Compute residual of the computed solution.
536*
537 CALL slacpy( 'Full', n, nrhs, b, lda,
538 + s_temp_spot02, lda )
539 CALL spot02( uplo, n, nrhs, a, lda, x, lda,
540 + s_temp_spot02, lda, s_work_spot02,
541 + result( 3 ) )
542*
543* Check solution from generated exact solution.
544
545 CALL sget04( 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, 'SPF' )
556 WRITE( nout, fmt = 9999 )'SPFSV ', 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( 'SPF', 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 SDRVRFP
578*
spftri
subroutine spftri(transr, uplo, n, a, info)
SPFTRI
Definition spftri.f:191
spftrs
subroutine spftrs(transr, uplo, n, nrhs, a, b, ldb, info)
SPFTRS
Definition spftrs.f:199
spftrf
subroutine spftrf(transr, uplo, n, a, info)
SPFTRF
Definition spftrf.f:198

◆ sdrvsp()

subroutine sdrvsp ( 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 )

SDRVSP

Purpose:
!>
!> SDRVSP tests the driver routines SSPSV and -SVX.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is REAL
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is REAL array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AFAC
!>          AFAC is REAL array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[out]AINV
!>          AINV is REAL array, dimension
!>                      (NMAX*(NMAX+1)/2)
!>
[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 153 of file sdrvsp.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 REAL THRESH
165* ..
166* .. Array Arguments ..
167 LOGICAL DOTYPE( * )
168 INTEGER IWORK( * ), NVAL( * )
169 REAL A( * ), AFAC( * ), AINV( * ), B( * ),
170 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
171* ..
172*
173* =====================================================================
174*
175* .. Parameters ..
176 REAL ONE, ZERO
177 parameter( one = 1.0e+0, zero = 0.0e+0 )
178 INTEGER NTYPES, NTESTS
179 parameter( ntypes = 10, ntests = 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 REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC
191* ..
192* .. Local Arrays ..
193 CHARACTER FACTS( NFACT )
194 INTEGER ISEED( 4 ), ISEEDY( 4 )
195 REAL RESULT( NTESTS )
196* ..
197* .. External Functions ..
198 REAL SGET06, SLANSP
199 EXTERNAL sget06, slansp
200* ..
201* .. External Subroutines ..
202 EXTERNAL aladhd, alaerh, alasvm, scopy, serrvx, sget04,
203 $ slacpy, slarhs, slaset, slatb4, slatms, sppt02,
204 $ sppt05, sspsv, sspsvx, sspt01, ssptrf, ssptri
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 ) = 'Single 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 serrvx( 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 SLATB4 and generate a test matrix
278* with SLATMS.
279*
280 CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
281 $ CNDNUM, DIST )
282*
283 srnamt = 'SLATMS'
284 CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE,
285 $ CNDNUM, ANORM, KL, KU, PACKIT, A, LDA, WORK,
286 $ INFO )
287*
288* Check error code from SLATMS.
289*
290 IF( info.NE.0 ) THEN
291 CALL alaerh( path, 'SLATMS', 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 SSPSVX.
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 = slansp( '1', uplo, n, a, rwork )
382*
383* Factor the matrix A.
384*
385 CALL scopy( npp, a, 1, afac, 1 )
386 CALL ssptrf( uplo, n, afac, iwork, info )
387*
388* Compute inv(A) and take its norm.
389*
390 CALL scopy( npp, afac, 1, ainv, 1 )
391 CALL ssptri( uplo, n, ainv, iwork, work, info )
392 ainvnm = slansp( '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 = 'SLARHS'
406 CALL slarhs( path, xtype, uplo, ' ', n, n, kl, ku,
407 $ nrhs, a, lda, xact, lda, b, lda, iseed,
408 $ info )
409 xtype = 'C'
410*
411* --- Test SSPSV ---
412*
413 IF( ifact.EQ.2 ) THEN
414 CALL scopy( npp, a, 1, afac, 1 )
415 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
416*
417* Factor the matrix and solve the system using SSPSV.
418*
419 srnamt = 'SSPSV '
420 CALL sspsv( 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 SSPSV .
441*
442 IF( info.NE.k ) THEN
443 CALL alaerh( path, 'SSPSV ', 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 sspt01( uplo, n, a, afac, iwork, ainv, lda,
455 $ rwork, result( 1 ) )
456*
457* Compute residual of the computed solution.
458*
459 CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
460 CALL sppt02( uplo, n, nrhs, a, x, lda, work, lda,
461 $ rwork, result( 2 ) )
462*
463* Check solution from generated exact solution.
464*
465 CALL sget04( 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 )'SSPSV ', 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 SSPSVX ---
486*
487 IF( ifact.EQ.2 .AND. npp.GT.0 )
488 $ CALL slaset( 'Full', npp, 1, zero, zero, afac,
489 $ npp )
490 CALL slaset( 'Full', n, nrhs, zero, zero, x, lda )
491*
492* Solve the system and compute the condition number and
493* error bounds using SSPSVX.
494*
495 srnamt = 'SSPSVX'
496 CALL sspsvx( 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 SSPSVX.
519*
520 IF( info.NE.k ) THEN
521 CALL alaerh( path, 'SSPSVX', 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 sspt01( 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 slacpy( 'Full', n, nrhs, b, lda, work, lda )
543 CALL sppt02( 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 sget04( n, nrhs, x, lda, xact, lda, rcondc,
549 $ result( 3 ) )
550*
551* Check the error bounds from iterative refinement.
552*
553 CALL sppt05( 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 SSPSVX with the computed value
561* in RCONDC.
562*
563 result( 6 ) = sget06( 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 )'SSPSVX', 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 SDRVSP
596*
sspsvx
subroutine sspsvx(fact, uplo, n, nrhs, ap, afp, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, info)
SSPSVX computes the solution to system of linear equations A * X = B for OTHER matrices
Definition sspsvx.f:276
sspsv
subroutine sspsv(uplo, n, nrhs, ap, ipiv, b, ldb, info)
SSPSV computes the solution to system of linear equations A * X = B for OTHER matrices
Definition sspsv.f:162

◆ sdrvsy()

subroutine sdrvsy ( 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

SDRVSYX

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

152*
153* -- LAPACK test routine --
154* -- LAPACK is a software package provided by Univ. of Tennessee, --
155* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
156*
157* .. Scalar Arguments ..
158 LOGICAL TSTERR
159 INTEGER NMAX, NN, NOUT, NRHS
160 REAL THRESH
161* ..
162* .. Array Arguments ..
163 LOGICAL DOTYPE( * )
164 INTEGER IWORK( * ), NVAL( * )
165 REAL A( * ), AFAC( * ), AINV( * ), B( * ),
166 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
167* ..
168*
169* =====================================================================
170*
171* .. Parameters ..
172 REAL ONE, ZERO
173 parameter( one = 1.0e+0, zero = 0.0e+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 REAL AINVNM, ANORM, CNDNUM, RCOND, RCONDC
187* ..
188* .. Local Arrays ..
189 CHARACTER FACTS( NFACT ), UPLOS( 2 )
190 INTEGER ISEED( 4 ), ISEEDY( 4 )
191 REAL RESULT( NTESTS )
192* ..
193* .. External Functions ..
194 REAL SGET06, SLANSY
195 EXTERNAL sget06, slansy
196* ..
197* .. External Subroutines ..
198 EXTERNAL aladhd, alaerh, alasvm, serrvx, sget04, slacpy,
199 $ slarhs, slaset, slatb4, slatms, spot02, spot05,
200 $ ssysv, ssysvx, ssyt01, ssytrf, ssytri2, 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 ) = 'Single 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 serrvx( 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 SLATB4 and generate a test matrix
274* with SLATMS.
275*
276 CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
277 $ CNDNUM, DIST )
278*
279 srnamt = 'SLATMS'
280 CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE,
281 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
282 $ INFO )
283*
284* Check error code from SLATMS.
285*
286 IF( info.NE.0 ) THEN
287 CALL alaerh( path, 'SLATMS', 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 SSYSVX.
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 = slansy( '1', uplo, n, a, lda, rwork )
378*
379* Factor the matrix A.
380*
381 CALL slacpy( uplo, n, n, a, lda, afac, lda )
382 CALL ssytrf( uplo, n, afac, lda, iwork, work,
383 $ lwork, info )
384*
385* Compute inv(A) and take its norm.
386*
387 CALL slacpy( uplo, n, n, afac, lda, ainv, lda )
388 lwork = (n+nb+1)*(nb+3)
389 CALL ssytri2( uplo, n, ainv, lda, iwork, work,
390 $ lwork, info )
391 ainvnm = slansy( '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 = 'SLARHS'
405 CALL slarhs( path, xtype, uplo, ' ', n, n, kl, ku,
406 $ nrhs, a, lda, xact, lda, b, lda, iseed,
407 $ info )
408 xtype = 'C'
409*
410* --- Test SSYSV ---
411*
412 IF( ifact.EQ.2 ) THEN
413 CALL slacpy( uplo, n, n, a, lda, afac, lda )
414 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
415*
416* Factor the matrix and solve the system using SSYSV.
417*
418 srnamt = 'SSYSV '
419 CALL ssysv( 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 SSYSV .
440*
441 IF( info.NE.k ) THEN
442 CALL alaerh( path, 'SSYSV ', 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 ssyt01( uplo, n, a, lda, afac, lda, iwork,
454 $ ainv, lda, rwork, result( 1 ) )
455*
456* Compute residual of the computed solution.
457*
458 CALL slacpy( 'Full', n, nrhs, b, lda, work, lda )
459 CALL spot02( uplo, n, nrhs, a, lda, x, lda, work,
460 $ lda, rwork, result( 2 ) )
461*
462* Check solution from generated exact solution.
463*
464 CALL sget04( 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 )'SSYSV ', 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 SSYSVX ---
485*
486 IF( ifact.EQ.2 )
487 $ CALL slaset( uplo, n, n, zero, zero, afac, lda )
488 CALL slaset( 'Full', n, nrhs, zero, zero, x, lda )
489*
490* Solve the system and compute the condition number and
491* error bounds using SSYSVX.
492*
493 srnamt = 'SSYSVX'
494 CALL ssysvx( 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 SSYSVX.
517*
518 IF( info.NE.k ) THEN
519 CALL alaerh( path, 'SSYSVX', 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 ssyt01( 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 slacpy( 'Full', n, nrhs, b, lda, work, lda )
542 CALL spot02( 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 sget04( n, nrhs, x, lda, xact, lda, rcondc,
548 $ result( 3 ) )
549*
550* Check the error bounds from iterative refinement.
551*
552 CALL spot05( 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 SSYSVX with the computed value
560* in RCONDC.
561*
562 result( 6 ) = sget06( 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 )'SSYSVX', 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 SDRVSY
595*
ssysv
subroutine ssysv(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
SSYSV computes the solution to system of linear equations A * X = B for SY matrices
Definition ssysv.f:171
ssysvx
subroutine ssysvx(fact, uplo, n, nrhs, a, lda, af, ldaf, ipiv, b, ldb, x, ldx, rcond, ferr, berr, work, lwork, iwork, info)
SSYSVX computes the solution to system of linear equations A * X = B for SY matrices
Definition ssysvx.f:284

◆ sdrvsy_rk()

subroutine sdrvsy_rk ( logical, dimension( * ) dotype,
integer nn,
integer, dimension( * ) nval,
integer nrhs,
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 )

SDRVSY_RK

Purpose:
!> SDRVSY_RK tests the driver routines SSYSV_RK.
!>
Parameters
[in]DOTYPE
!>          DOTYPE is LOGICAL array, dimension (NTYPES)
!>          The matrix types to be used for testing.  Matrices of type j
!>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
!>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
!>
[in]NN
!>          NN is INTEGER
!>          The number of values of N contained in the vector NVAL.
!>
[in]NVAL
!>          NVAL is INTEGER array, dimension (NN)
!>          The values of the matrix dimension N.
!>
[in]NRHS
!>          NRHS is INTEGER
!>          The number of right hand side vectors to be generated for
!>          each linear system.
!>
[in]THRESH
!>          THRESH is REAL
!>          The threshold value for the test ratios.  A result is
!>          included in the output file if RESULT >= THRESH.  To have
!>          every test ratio printed, use THRESH = 0.
!>
[in]TSTERR
!>          TSTERR is LOGICAL
!>          Flag that indicates whether error exits are to be tested.
!>
[in]NMAX
!>          NMAX is INTEGER
!>          The maximum value permitted for N, used in dimensioning the
!>          work arrays.
!>
[out]A
!>          A is 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*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 153 of file sdrvsy_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 REAL THRESH
165* ..
166* .. Array Arguments ..
167 LOGICAL DOTYPE( * )
168 INTEGER IWORK( * ), NVAL( * )
169 REAL A( * ), AFAC( * ), AINV( * ), B( * ), E( * ),
170 $ RWORK( * ), WORK( * ), X( * ), XACT( * )
171* ..
172*
173* =====================================================================
174*
175* .. Parameters ..
176 REAL ONE, ZERO
177 parameter( one = 1.0e+0, zero = 0.0e+0 )
178 INTEGER NTYPES, NTESTS
179 parameter( ntypes = 10, ntests = 3 )
180 INTEGER NFACT
181 parameter( nfact = 2 )
182* ..
183* .. Local Scalars ..
184 LOGICAL ZEROT
185 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
186 CHARACTER*3 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 REAL AINVNM, ANORM, CNDNUM, RCONDC
191* ..
192* .. Local Arrays ..
193 CHARACTER FACTS( NFACT ), UPLOS( 2 )
194 INTEGER ISEED( 4 ), ISEEDY( 4 )
195 REAL RESULT( NTESTS )
196* ..
197* .. External Functions ..
198 REAL SLANSY
199 EXTERNAL slansy
200* ..
201* .. External Subroutines ..
202 EXTERNAL aladhd, alaerh, alasvm, serrvx, sget04, slacpy,
203 $ slarhs, slatb4, slatms, spot02, ssysv_rk,
204 $ ssyt01_3, ssytrf_rk, ssytri_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 ) = 'Single precision'
229 path( 2: 3 ) = 'SK'
230*
231* Path to generate matrices
232*
233 matpath( 1: 1 ) = 'Single 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 serrvx( 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 SLATB4 for the matrix generator
289* based on the type of matrix to be generated.
290*
291 CALL slatb4( matpath, imat, n, n, TYPE, KL, KU, ANORM,
292 $ MODE, CNDNUM, DIST )
293*
294* Generate a matrix with SLATMS.
295*
296 srnamt = 'SLATMS'
297 CALL slatms( n, n, dist, iseed, TYPE, RWORK, MODE,
298 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
299 $ INFO )
300*
301* Check error code from SLATMS and handle error.
302*
303 IF( info.NE.0 ) THEN
304 CALL alaerh( path, 'SLATMS', 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 = 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_rk( uplo, n, afac, lda, e, 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*
411* We need to compute the inverse to compute
412* RCONDC that is used later in TEST3.
413*
414 CALL ssytri_3( uplo, n, ainv, lda, e, iwork,
415 $ work, lwork, info )
416 ainvnm = slansy( '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 = 'SLARHS'
430 CALL slarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
431 $ nrhs, a, lda, xact, lda, b, lda, iseed,
432 $ info )
433 xtype = 'C'
434*
435* --- Test SSYSV_RK ---
436*
437 IF( ifact.EQ.2 ) THEN
438 CALL slacpy( uplo, n, n, a, lda, afac, lda )
439 CALL slacpy( 'Full', n, nrhs, b, lda, x, lda )
440*
441* Factor the matrix and solve the system using
442* SSYSV_RK.
443*
444 srnamt = 'SSYSV_RK'
445 CALL ssysv_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 SSYSV_RK and handle error.
466*
467 IF( info.NE.k ) THEN
468 CALL alaerh( path, 'SSYSV_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 ssyt01_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 slacpy( 'Full', n, nrhs, b, lda, work, lda )
486 CALL spot02( 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 sget04( 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 )'SSYSV_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 SDRVSY_RK
527*
ssyt01_3
subroutine ssyt01_3(uplo, n, a, lda, afac, ldafac, e, ipiv, c, ldc, rwork, resid)
SSYT01_3
Definition ssyt01_3.f:140
ssysv_rk
subroutine ssysv_rk(uplo, n, nrhs, a, lda, e, ipiv, b, ldb, work, lwork, info)
SSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices
Definition ssysv_rk.f:228
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

◆ sebchvxx()

subroutine sebchvxx ( real thresh,
character*3 path )

SEBCHVXX

Purpose:
!>
!>  SEBCHVXX will run S**SVXX on a series of Hilbert matrices and then
!>  compare the error bounds returned by SGESVXX 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, SGESVXX 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 SGESVXX.  Let RCONDc be the RCOND returned by SGESVXX
!>          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 )).
!>
!>       7. 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 sebchvxx.f.

96 IMPLICIT NONE
97* .. Scalar Arguments ..
98 REAL THRESH
99 CHARACTER*3 PATH
100
101 INTEGER NMAX, NPARAMS, NERRBND, NTESTS, KL, KU
102 parameter(nmax = 6, nparams = 2, nerrbnd = 3,
103 $ ntests = 6)
104
105* .. Local Scalars ..
106 INTEGER N, NRHS, INFO, I ,J, k, NFAIL, LDA, LDAB,
107 $ LDAFB, N_AUX_TESTS
108 CHARACTER FACT, TRANS, UPLO, EQUED
109 CHARACTER*2 C2
110 CHARACTER(3) NGUAR, CGUAR
111 LOGICAL printed_guide
112 REAL NCOND, CCOND, M, NORMDIF, NORMT, RCOND,
113 $ RNORM, RINORM, SUMR, SUMRI, EPS,
114 $ BERR(NMAX), RPVGRW, ORCOND,
115 $ CWISE_ERR, NWISE_ERR, CWISE_BND, NWISE_BND,
116 $ CWISE_RCOND, NWISE_RCOND,
117 $ CONDTHRESH, ERRTHRESH
118
119* .. Local Arrays ..
120 REAL TSTRAT(NTESTS), RINV(NMAX), PARAMS(NPARAMS),
121 $ A(NMAX, NMAX), ACOPY(NMAX, NMAX),
122 $ INVHILB(NMAX, NMAX), R(NMAX), C(NMAX), S(NMAX),
123 $ WORK(NMAX * 5), B(NMAX, NMAX), X(NMAX, NMAX),
124 $ DIFF(NMAX, NMAX), AF(NMAX, NMAX),
125 $ AB( (NMAX-1)+(NMAX-1)+1, NMAX ),
126 $ ABCOPY( (NMAX-1)+(NMAX-1)+1, NMAX ),
127 $ AFB( 2*(NMAX-1)+(NMAX-1)+1, NMAX ),
128 $ ERRBND_N(NMAX*3), ERRBND_C(NMAX*3)
129 INTEGER IWORK(NMAX), IPIV(NMAX)
130
131* .. External Functions ..
132 REAL SLAMCH
133
134* .. External Subroutines ..
135 EXTERNAL slahilb, sgesvxx, ssysvxx, sposvxx, sgbsvxx,
136 $ slacpy, lsamen
137 LOGICAL LSAMEN
138
139* .. Intrinsic Functions ..
140 INTRINSIC sqrt, max, abs
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 = slamch('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(real(n)), 10.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 slahilb(n, n, a, lda, invhilb, lda, b, lda, work, info)
178
179* Copy A into ACOPY.
180 CALL slacpy('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.0e+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.0e+0
198 END DO
199 END DO
200 CALL slacpy('ALL', kl+ku+1, n, ab, ldab, abcopy, ldab)
201
202* Call S**SVXX with default PARAMS and N_ERR_BND = 3.
203 IF ( lsamen( 2, c2, 'SY' ) ) THEN
204 CALL ssysvxx(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 sposvxx(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 sgbsvxx(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 sgesvxx(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 S**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
252 rinorm = 0
253 IF ( lsamen( 2, c2, 'PO' ) .OR. lsamen( 2, c2, 'SY' ) ) THEN
254 DO i = 1, n
255 sumr = 0
256 sumri = 0
257 DO j = 1, n
258 sumr = sumr + abs(s(i) * a(i,j) * s(j))
259 sumri = sumri + abs(invhilb(i, j) / s(j) / s(i))
260 END DO
261 rnorm = max(rnorm,sumr)
262 rinorm = max(rinorm,sumri)
263 END DO
264 ELSE IF ( lsamen( 2, c2, 'GE' ) .OR. lsamen( 2, c2, 'GB' ) )
265 $ THEN
266 DO i = 1, n
267 sumr = 0
268 sumri = 0
269 DO j = 1, n
270 sumr = sumr + abs(r(i) * a(i,j) * c(j))
271 sumri = sumri + abs(invhilb(i, j) / r(j) / c(i))
272 END DO
273 rnorm = max(rnorm,sumr)
274 rinorm = max(rinorm,sumri)
275 END DO
276 END IF
277
278 rnorm = rnorm / a(1, 1)
279 rcond = 1.0/(rnorm * rinorm)
280
281* Calculating the R for normwise rcond.
282 DO i = 1, n
283 rinv(i) = 0.0
284 END DO
285 DO j = 1, n
286 DO i = 1, n
287 rinv(i) = rinv(i) + abs(a(i,j))
288 END DO
289 END DO
290
291* Calculating the Normwise rcond.
292 rinorm = 0.0
293 DO i = 1, n
294 sumri = 0.0
295 DO j = 1, n
296 sumri = sumri + abs(invhilb(i,j) * rinv(j))
297 END DO
298 rinorm = max(rinorm, sumri)
299 END DO
300
301! invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm
302! by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix)
303 ncond = a(1,1) / rinorm
304
305 condthresh = m * eps
306 errthresh = m * eps
307
308 DO k = 1, nrhs
309 normt = 0.0
310 normdif = 0.0
311 cwise_err = 0.0
312 DO i = 1, n
313 normt = max(abs(invhilb(i, k)), normt)
314 normdif = max(abs(x(i,k) - invhilb(i,k)), normdif)
315 IF (invhilb(i,k) .NE. 0.0) THEN
316 cwise_err = max(abs(x(i,k) - invhilb(i,k))
317 $ /abs(invhilb(i,k)), cwise_err)
318 ELSE IF (x(i, k) .NE. 0.0) THEN
319 cwise_err = slamch('OVERFLOW')
320 END IF
321 END DO
322 IF (normt .NE. 0.0) THEN
323 nwise_err = normdif / normt
324 ELSE IF (normdif .NE. 0.0) THEN
325 nwise_err = slamch('OVERFLOW')
326 ELSE
327 nwise_err = 0.0
328 ENDIF
329
330 DO i = 1, n
331 rinv(i) = 0.0
332 END DO
333 DO j = 1, n
334 DO i = 1, n
335 rinv(i) = rinv(i) + abs(a(i, j) * invhilb(j, k))
336 END DO
337 END DO
338 rinorm = 0.0
339 DO i = 1, n
340 sumri = 0.0
341 DO j = 1, n
342 sumri = sumri
343 $ + abs(invhilb(i, j) * rinv(j) / invhilb(i, k))
344 END DO
345 rinorm = max(rinorm, sumri)
346 END DO
347! invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm
348! by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix)
349 ccond = a(1,1)/rinorm
350
351! Forward error bound tests
352 nwise_bnd = errbnd_n(k + (bnd_i-1)*nrhs)
353 cwise_bnd = errbnd_c(k + (bnd_i-1)*nrhs)
354 nwise_rcond = errbnd_n(k + (cond_i-1)*nrhs)
355 cwise_rcond = errbnd_c(k + (cond_i-1)*nrhs)
356! write (*,*) 'nwise : ', n, k, ncond, nwise_rcond,
357! $ condthresh, ncond.ge.condthresh
358! write (*,*) 'nwise2: ', k, nwise_bnd, nwise_err, errthresh
359
360 IF (ncond .GE. condthresh) THEN
361 nguar = 'YES'
362 IF (nwise_bnd .GT. errthresh) THEN
363 tstrat(1) = 1/(2.0*eps)
364 ELSE
365
366 IF (nwise_bnd .NE. 0.0) THEN
367 tstrat(1) = nwise_err / nwise_bnd
368 ELSE IF (nwise_err .NE. 0.0) THEN
369 tstrat(1) = 1/(16.0*eps)
370 ELSE
371 tstrat(1) = 0.0
372 END IF
373 IF (tstrat(1) .GT. 1.0) THEN
374 tstrat(1) = 1/(4.0*eps)
375 END IF
376 END IF
377 ELSE
378 nguar = 'NO'
379 IF (nwise_bnd .LT. 1.0) THEN
380 tstrat(1) = 1/(8.0*eps)
381 ELSE
382 tstrat(1) = 1.0
383 END IF
384 END IF
385! write (*,*) 'cwise : ', n, k, ccond, cwise_rcond,
386! $ condthresh, ccond.ge.condthresh
387! write (*,*) 'cwise2: ', k, cwise_bnd, cwise_err, errthresh
388 IF (ccond .GE. condthresh) THEN
389 cguar = 'YES'
390
391 IF (cwise_bnd .GT. errthresh) THEN
392 tstrat(2) = 1/(2.0*eps)
393 ELSE
394 IF (cwise_bnd .NE. 0.0) THEN
395 tstrat(2) = cwise_err / cwise_bnd
396 ELSE IF (cwise_err .NE. 0.0) THEN
397 tstrat(2) = 1/(16.0*eps)
398 ELSE
399 tstrat(2) = 0.0
400 END IF
401 IF (tstrat(2) .GT. 1.0) tstrat(2) = 1/(4.0*eps)
402 END IF
403 ELSE
404 cguar = 'NO'
405 IF (cwise_bnd .LT. 1.0) THEN
406 tstrat(2) = 1/(8.0*eps)
407 ELSE
408 tstrat(2) = 1.0
409 END IF
410 END IF
411
412! Backwards error test
413 tstrat(3) = berr(k)/eps
414
415! Condition number tests
416 tstrat(4) = rcond / orcond
417 IF (rcond .GE. condthresh .AND. tstrat(4) .LT. 1.0)
418 $ tstrat(4) = 1.0 / tstrat(4)
419
420 tstrat(5) = ncond / nwise_rcond
421 IF (ncond .GE. condthresh .AND. tstrat(5) .LT. 1.0)
422 $ tstrat(5) = 1.0 / tstrat(5)
423
424 tstrat(6) = ccond / nwise_rcond
425 IF (ccond .GE. condthresh .AND. tstrat(6) .LT. 1.0)
426 $ tstrat(6) = 1.0 / tstrat(6)
427
428 DO i = 1, ntests
429 IF (tstrat(i) .GT. thresh) THEN
430 IF (.NOT.printed_guide) THEN
431 WRITE(*,*)
432 WRITE( *, 9996) 1
433 WRITE( *, 9995) 2
434 WRITE( *, 9994) 3
435 WRITE( *, 9993) 4
436 WRITE( *, 9992) 5
437 WRITE( *, 9991) 6
438 WRITE( *, 9990) 7
439 WRITE( *, 9989) 8
440 WRITE(*,*)
441 printed_guide = .true.
442 END IF
443 WRITE( *, 9999) c2, n, k, nguar, cguar, i, tstrat(i)
444 nfail = nfail + 1
445 END IF
446 END DO
447 END DO
448
449c$$$ WRITE(*,*)
450c$$$ WRITE(*,*) 'Normwise Error Bounds'
451c$$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,nwise_i,bnd_i)
452c$$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,nwise_i,cond_i)
453c$$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,nwise_i,rawbnd_i)
454c$$$ WRITE(*,*)
455c$$$ WRITE(*,*) 'Componentwise Error Bounds'
456c$$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,cwise_i,bnd_i)
457c$$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,cwise_i,cond_i)
458c$$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,cwise_i,rawbnd_i)
459c$$$ print *, 'Info: ', info
460c$$$ WRITE(*,*)
461* WRITE(*,*) 'TSTRAT: ',TSTRAT
462
463 END DO
464
465 WRITE(*,*)
466 IF( nfail .GT. 0 ) THEN
467 WRITE(*,9998) c2, nfail, ntests*n+n_aux_tests
468 ELSE
469 WRITE(*,9997) c2
470 END IF
471 9999 FORMAT( ' S', a2, 'SVXX: N =', i2, ', RHS = ', i2,
472 $ ', NWISE GUAR. = ', a, ', CWISE GUAR. = ', a,
473 $ ' test(',i1,') =', g12.5 )
474 9998 FORMAT( ' S', a2, 'SVXX: ', i6, ' out of ', i6,
475 $ ' tests failed to pass the threshold' )
476 9997 FORMAT( ' S', a2, 'SVXX passed the tests of error bounds' )
477* Test ratios.
478 9996 FORMAT( 3x, i2, ': Normwise guaranteed forward error', / 5x,
479 $ 'Guaranteed case: if norm ( abs( Xc - Xt )',
480 $ .LE.' / norm ( Xt ) ERRBND( *, nwise_i, bnd_i ), then',
481 $ / 5x,
482 $ .LE.'ERRBND( *, nwise_i, bnd_i ) MAX(SQRT(N), 10) * EPS')
483 9995 FORMAT( 3x, i2, ': Componentwise guaranteed forward error' )
484 9994 FORMAT( 3x, i2, ': Backwards error' )
485 9993 FORMAT( 3x, i2, ': Reciprocal condition number' )
486 9992 FORMAT( 3x, i2, ': Reciprocal normwise condition number' )
487 9991 FORMAT( 3x, i2, ': Raw normwise error estimate' )
488 9990 FORMAT( 3x, i2, ': Reciprocal componentwise condition number' )
489 9989 FORMAT( 3x, i2, ': Raw componentwise error estimate' )
490
491 8000 FORMAT( ' S', a2, 'SVXX: N =', i2, ', INFO = ', i3,
492 $ ', ORCOND = ', g12.5, ', real RCOND = ', g12.5 )
493*
494* End of SEBCHVXX
495*
lsamen
logical function lsamen(n, ca, cb)
LSAMEN
Definition lsamen.f:74
sgbsvxx
subroutine sgbsvxx(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)
SGBSVXX computes the solution to system of linear equations A * X = B for GB matrices
Definition sgbsvxx.f:563
sgesvxx
subroutine sgesvxx(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)
SGESVXX computes the solution to system of linear equations A * X = B for GE matrices
Definition sgesvxx.f:543
sposvxx
subroutine sposvxx(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)
SPOSVXX computes the solution to system of linear equations A * X = B for PO matrices
Definition sposvxx.f:497
ssysvxx
subroutine ssysvxx(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)
SSYSVXX
Definition ssysvxx.f:508
slahilb
subroutine slahilb(n, nrhs, a, lda, x, ldx, b, ldb, work, info)
SLAHILB
Definition slahilb.f:124

◆ serrge()

subroutine serrge ( character*3 path,
integer nunit )

SERRGE

SERRGEX

Purpose:
!>
!> SERRGE tests the error exits for the REAL 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:
!>
!> SERRGE tests the error exits for the REAL routines
!> for general matrices.
!>
!> Note that this file is used only when the XBLAS are available,
!> otherwise serrge.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 serrge.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 REAL ANRM, CCOND, RCOND
75* ..
76* .. Local Arrays ..
77 INTEGER IP( NMAX ), IW( NMAX )
78 REAL 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, sgbcon, sgbequ, sgbrfs, sgbtf2,
87 $ sgbtrf, sgbtrs, sgecon, sgeequ, sgerfs, sgetf2,
88 $ sgetrf, sgetri, sgetrs
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 real
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. / real( i+j )
113 af( i, j ) = 1. / real( i+j )
114 10 CONTINUE
115 b( j ) = 0.
116 r1( j ) = 0.
117 r2( j ) = 0.
118 w( j ) = 0.
119 x( j ) = 0.
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* SGETRF
131*
132 srnamt = 'SGETRF'
133 infot = 1
134 CALL sgetrf( -1, 0, a, 1, ip, info )
135 CALL chkxer( 'SGETRF', infot, nout, lerr, ok )
136 infot = 2
137 CALL sgetrf( 0, -1, a, 1, ip, info )
138 CALL chkxer( 'SGETRF', infot, nout, lerr, ok )
139 infot = 4
140 CALL sgetrf( 2, 1, a, 1, ip, info )
141 CALL chkxer( 'SGETRF', infot, nout, lerr, ok )
142*
143* SGETF2
144*
145 srnamt = 'SGETF2'
146 infot = 1
147 CALL sgetf2( -1, 0, a, 1, ip, info )
148 CALL chkxer( 'SGETF2', infot, nout, lerr, ok )
149 infot = 2
150 CALL sgetf2( 0, -1, a, 1, ip, info )
151 CALL chkxer( 'SGETF2', infot, nout, lerr, ok )
152 infot = 4
153 CALL sgetf2( 2, 1, a, 1, ip, info )
154 CALL chkxer( 'SGETF2', infot, nout, lerr, ok )
155*
156* SGETRI
157*
158 srnamt = 'SGETRI'
159 infot = 1
160 CALL sgetri( -1, a, 1, ip, w, lw, info )
161 CALL chkxer( 'SGETRI', infot, nout, lerr, ok )
162 infot = 3
163 CALL sgetri( 2, a, 1, ip, w, lw, info )
164 CALL chkxer( 'SGETRI', infot, nout, lerr, ok )
165*
166* SGETRS
167*
168 srnamt = 'SGETRS'
169 infot = 1
170 CALL sgetrs( '/', 0, 0, a, 1, ip, b, 1, info )
171 CALL chkxer( 'SGETRS', infot, nout, lerr, ok )
172 infot = 2
173 CALL sgetrs( 'N', -1, 0, a, 1, ip, b, 1, info )
174 CALL chkxer( 'SGETRS', infot, nout, lerr, ok )
175 infot = 3
176 CALL sgetrs( 'N', 0, -1, a, 1, ip, b, 1, info )
177 CALL chkxer( 'SGETRS', infot, nout, lerr, ok )
178 infot = 5
179 CALL sgetrs( 'N', 2, 1, a, 1, ip, b, 2, info )
180 CALL chkxer( 'SGETRS', infot, nout, lerr, ok )
181 infot = 8
182 CALL sgetrs( 'N', 2, 1, a, 2, ip, b, 1, info )
183 CALL chkxer( 'SGETRS', infot, nout, lerr, ok )
184*
185* SGERFS
186*
187 srnamt = 'SGERFS'
188 infot = 1
189 CALL sgerfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
190 $ iw, info )
191 CALL chkxer( 'SGERFS', infot, nout, lerr, ok )
192 infot = 2
193 CALL sgerfs( 'N', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
194 $ w, iw, info )
195 CALL chkxer( 'SGERFS', infot, nout, lerr, ok )
196 infot = 3
197 CALL sgerfs( 'N', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
198 $ w, iw, info )
199 CALL chkxer( 'SGERFS', infot, nout, lerr, ok )
200 infot = 5
201 CALL sgerfs( 'N', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
202 $ iw, info )
203 CALL chkxer( 'SGERFS', infot, nout, lerr, ok )
204 infot = 7
205 CALL sgerfs( 'N', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
206 $ iw, info )
207 CALL chkxer( 'SGERFS', infot, nout, lerr, ok )
208 infot = 10
209 CALL sgerfs( 'N', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
210 $ iw, info )
211 CALL chkxer( 'SGERFS', infot, nout, lerr, ok )
212 infot = 12
213 CALL sgerfs( 'N', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
214 $ iw, info )
215 CALL chkxer( 'SGERFS', infot, nout, lerr, ok )
216*
217* SGECON
218*
219 srnamt = 'SGECON'
220 infot = 1
221 CALL sgecon( '/', 0, a, 1, anrm, rcond, w, iw, info )
222 CALL chkxer( 'SGECON', infot, nout, lerr, ok )
223 infot = 2
224 CALL sgecon( '1', -1, a, 1, anrm, rcond, w, iw, info )
225 CALL chkxer( 'SGECON', infot, nout, lerr, ok )
226 infot = 4
227 CALL sgecon( '1', 2, a, 1, anrm, rcond, w, iw, info )
228 CALL chkxer( 'SGECON', infot, nout, lerr, ok )
229*
230* SGEEQU
231*
232 srnamt = 'SGEEQU'
233 infot = 1
234 CALL sgeequ( -1, 0, a, 1, r1, r2, rcond, ccond, anrm, info )
235 CALL chkxer( 'SGEEQU', infot, nout, lerr, ok )
236 infot = 2
237 CALL sgeequ( 0, -1, a, 1, r1, r2, rcond, ccond, anrm, info )
238 CALL chkxer( 'SGEEQU', infot, nout, lerr, ok )
239 infot = 4
240 CALL sgeequ( 2, 2, a, 1, r1, r2, rcond, ccond, anrm, info )
241 CALL chkxer( 'SGEEQU', 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* SGBTRF
249*
250 srnamt = 'SGBTRF'
251 infot = 1
252 CALL sgbtrf( -1, 0, 0, 0, a, 1, ip, info )
253 CALL chkxer( 'SGBTRF', infot, nout, lerr, ok )
254 infot = 2
255 CALL sgbtrf( 0, -1, 0, 0, a, 1, ip, info )
256 CALL chkxer( 'SGBTRF', infot, nout, lerr, ok )
257 infot = 3
258 CALL sgbtrf( 1, 1, -1, 0, a, 1, ip, info )
259 CALL chkxer( 'SGBTRF', infot, nout, lerr, ok )
260 infot = 4
261 CALL sgbtrf( 1, 1, 0, -1, a, 1, ip, info )
262 CALL chkxer( 'SGBTRF', infot, nout, lerr, ok )
263 infot = 6
264 CALL sgbtrf( 2, 2, 1, 1, a, 3, ip, info )
265 CALL chkxer( 'SGBTRF', infot, nout, lerr, ok )
266*
267* SGBTF2
268*
269 srnamt = 'SGBTF2'
270 infot = 1
271 CALL sgbtf2( -1, 0, 0, 0, a, 1, ip, info )
272 CALL chkxer( 'SGBTF2', infot, nout, lerr, ok )
273 infot = 2
274 CALL sgbtf2( 0, -1, 0, 0, a, 1, ip, info )
275 CALL chkxer( 'SGBTF2', infot, nout, lerr, ok )
276 infot = 3
277 CALL sgbtf2( 1, 1, -1, 0, a, 1, ip, info )
278 CALL chkxer( 'SGBTF2', infot, nout, lerr, ok )
279 infot = 4
280 CALL sgbtf2( 1, 1, 0, -1, a, 1, ip, info )
281 CALL chkxer( 'SGBTF2', infot, nout, lerr, ok )
282 infot = 6
283 CALL sgbtf2( 2, 2, 1, 1, a, 3, ip, info )
284 CALL chkxer( 'SGBTF2', infot, nout, lerr, ok )
285*
286* SGBTRS
287*
288 srnamt = 'SGBTRS'
289 infot = 1
290 CALL sgbtrs( '/', 0, 0, 0, 1, a, 1, ip, b, 1, info )
291 CALL chkxer( 'SGBTRS', infot, nout, lerr, ok )
292 infot = 2
293 CALL sgbtrs( 'N', -1, 0, 0, 1, a, 1, ip, b, 1, info )
294 CALL chkxer( 'SGBTRS', infot, nout, lerr, ok )
295 infot = 3
296 CALL sgbtrs( 'N', 1, -1, 0, 1, a, 1, ip, b, 1, info )
297 CALL chkxer( 'SGBTRS', infot, nout, lerr, ok )
298 infot = 4
299 CALL sgbtrs( 'N', 1, 0, -1, 1, a, 1, ip, b, 1, info )
300 CALL chkxer( 'SGBTRS', infot, nout, lerr, ok )
301 infot = 5
302 CALL sgbtrs( 'N', 1, 0, 0, -1, a, 1, ip, b, 1, info )
303 CALL chkxer( 'SGBTRS', infot, nout, lerr, ok )
304 infot = 7
305 CALL sgbtrs( 'N', 2, 1, 1, 1, a, 3, ip, b, 2, info )
306 CALL chkxer( 'SGBTRS', infot, nout, lerr, ok )
307 infot = 10
308 CALL sgbtrs( 'N', 2, 0, 0, 1, a, 1, ip, b, 1, info )
309 CALL chkxer( 'SGBTRS', infot, nout, lerr, ok )
310*
311* SGBRFS
312*
313 srnamt = 'SGBRFS'
314 infot = 1
315 CALL sgbrfs( '/', 0, 0, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
316 $ r2, w, iw, info )
317 CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
318 infot = 2
319 CALL sgbrfs( 'N', -1, 0, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
320 $ r2, w, iw, info )
321 CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
322 infot = 3
323 CALL sgbrfs( 'N', 1, -1, 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
324 $ r2, w, iw, info )
325 CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
326 infot = 4
327 CALL sgbrfs( 'N', 1, 0, -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1,
328 $ r2, w, iw, info )
329 CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
330 infot = 5
331 CALL sgbrfs( 'N', 1, 0, 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1,
332 $ r2, w, iw, info )
333 CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
334 infot = 7
335 CALL sgbrfs( 'N', 2, 1, 1, 1, a, 2, af, 4, ip, b, 2, x, 2, r1,
336 $ r2, w, iw, info )
337 CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
338 infot = 9
339 CALL sgbrfs( 'N', 2, 1, 1, 1, a, 3, af, 3, ip, b, 2, x, 2, r1,
340 $ r2, w, iw, info )
341 CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
342 infot = 12
343 CALL sgbrfs( 'N', 2, 0, 0, 1, a, 1, af, 1, ip, b, 1, x, 2, r1,
344 $ r2, w, iw, info )
345 CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
346 infot = 14
347 CALL sgbrfs( 'N', 2, 0, 0, 1, a, 1, af, 1, ip, b, 2, x, 1, r1,
348 $ r2, w, iw, info )
349 CALL chkxer( 'SGBRFS', infot, nout, lerr, ok )
350*
351* SGBCON
352*
353 srnamt = 'SGBCON'
354 infot = 1
355 CALL sgbcon( '/', 0, 0, 0, a, 1, ip, anrm, rcond, w, iw, info )
356 CALL chkxer( 'SGBCON', infot, nout, lerr, ok )
357 infot = 2
358 CALL sgbcon( '1', -1, 0, 0, a, 1, ip, anrm, rcond, w, iw,
359 $ info )
360 CALL chkxer( 'SGBCON', infot, nout, lerr, ok )
361 infot = 3
362 CALL sgbcon( '1', 1, -1, 0, a, 1, ip, anrm, rcond, w, iw,
363 $ info )
364 CALL chkxer( 'SGBCON', infot, nout, lerr, ok )
365 infot = 4
366 CALL sgbcon( '1', 1, 0, -1, a, 1, ip, anrm, rcond, w, iw,
367 $ info )
368 CALL chkxer( 'SGBCON', infot, nout, lerr, ok )
369 infot = 6
370 CALL sgbcon( '1', 2, 1, 1, a, 3, ip, anrm, rcond, w, iw, info )
371 CALL chkxer( 'SGBCON', infot, nout, lerr, ok )
372*
373* SGBEQU
374*
375 srnamt = 'SGBEQU'
376 infot = 1
377 CALL sgbequ( -1, 0, 0, 0, a, 1, r1, r2, rcond, ccond, anrm,
378 $ info )
379 CALL chkxer( 'SGBEQU', infot, nout, lerr, ok )
380 infot = 2
381 CALL sgbequ( 0, -1, 0, 0, a, 1, r1, r2, rcond, ccond, anrm,
382 $ info )
383 CALL chkxer( 'SGBEQU', infot, nout, lerr, ok )
384 infot = 3
385 CALL sgbequ( 1, 1, -1, 0, a, 1, r1, r2, rcond, ccond, anrm,
386 $ info )
387 CALL chkxer( 'SGBEQU', infot, nout, lerr, ok )
388 infot = 4
389 CALL sgbequ( 1, 1, 0, -1, a, 1, r1, r2, rcond, ccond, anrm,
390 $ info )
391 CALL chkxer( 'SGBEQU', infot, nout, lerr, ok )
392 infot = 6
393 CALL sgbequ( 2, 2, 1, 1, a, 2, r1, r2, rcond, ccond, anrm,
394 $ info )
395 CALL chkxer( 'SGBEQU', 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 SERRGE
405*
chkxer
subroutine chkxer(srnamt, infot, nout, lerr, ok)
Definition cblat2.f:3196
alaesm
subroutine alaesm(path, ok, nout)
ALAESM
Definition alaesm.f:63
sgbtf2
subroutine sgbtf2(m, n, kl, ku, ab, ldab, ipiv, info)
SGBTF2 computes the LU factorization of a general band matrix using the unblocked version of the algo...
Definition sgbtf2.f:145
sgetf2
subroutine sgetf2(m, n, a, lda, ipiv, info)
SGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row inter...
Definition sgetf2.f:108

◆ serrgt()

subroutine serrgt ( character*3 path,
integer nunit )

SERRGT

Purpose:
!>
!> SERRGT tests the error exits for the REAL 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 serrgt.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 REAL ANORM, RCOND
75* ..
76* .. Local Arrays ..
77 INTEGER IP( NMAX ), IW( NMAX )
78 REAL 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, sgtcon, sgtrfs, sgttrf, sgttrs,
88 $ sptcon, sptrfs, spttrf, spttrs
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.
105 d( 2 ) = 2.
106 df( 1 ) = 1.
107 df( 2 ) = 2.
108 e( 1 ) = 3.
109 e( 2 ) = 4.
110 ef( 1 ) = 3.
111 ef( 2 ) = 4.
112 anorm = 1.0
113 ok = .true.
114*
115 IF( lsamen( 2, c2, 'GT' ) ) THEN
116*
117* Test error exits for the general tridiagonal routines.
118*
119* SGTTRF
120*
121 srnamt = 'SGTTRF'
122 infot = 1
123 CALL sgttrf( -1, c, d, e, f, ip, info )
124 CALL chkxer( 'SGTTRF', infot, nout, lerr, ok )
125*
126* SGTTRS
127*
128 srnamt = 'SGTTRS'
129 infot = 1
130 CALL sgttrs( '/', 0, 0, c, d, e, f, ip, x, 1, info )
131 CALL chkxer( 'SGTTRS', infot, nout, lerr, ok )
132 infot = 2
133 CALL sgttrs( 'N', -1, 0, c, d, e, f, ip, x, 1, info )
134 CALL chkxer( 'SGTTRS', infot, nout, lerr, ok )
135 infot = 3
136 CALL sgttrs( 'N', 0, -1, c, d, e, f, ip, x, 1, info )
137 CALL chkxer( 'SGTTRS', infot, nout, lerr, ok )
138 infot = 10
139 CALL sgttrs( 'N', 2, 1, c, d, e, f, ip, x, 1, info )
140 CALL chkxer( 'SGTTRS', infot, nout, lerr, ok )
141*
142* SGTRFS
143*
144 srnamt = 'SGTRFS'
145 infot = 1
146 CALL sgtrfs( '/', 0, 0, c, d, e, cf, df, ef, f, ip, b, 1, x, 1,
147 $ r1, r2, w, iw, info )
148 CALL chkxer( 'SGTRFS', infot, nout, lerr, ok )
149 infot = 2
150 CALL sgtrfs( 'N', -1, 0, c, d, e, cf, df, ef, f, ip, b, 1, x,
151 $ 1, r1, r2, w, iw, info )
152 CALL chkxer( 'SGTRFS', infot, nout, lerr, ok )
153 infot = 3
154 CALL sgtrfs( 'N', 0, -1, c, d, e, cf, df, ef, f, ip, b, 1, x,
155 $ 1, r1, r2, w, iw, info )
156 CALL chkxer( 'SGTRFS', infot, nout, lerr, ok )
157 infot = 13
158 CALL sgtrfs( 'N', 2, 1, c, d, e, cf, df, ef, f, ip, b, 1, x, 2,
159 $ r1, r2, w, iw, info )
160 CALL chkxer( 'SGTRFS', infot, nout, lerr, ok )
161 infot = 15
162 CALL sgtrfs( 'N', 2, 1, c, d, e, cf, df, ef, f, ip, b, 2, x, 1,
163 $ r1, r2, w, iw, info )
164 CALL chkxer( 'SGTRFS', infot, nout, lerr, ok )
165*
166* SGTCON
167*
168 srnamt = 'SGTCON'
169 infot = 1
170 CALL sgtcon( '/', 0, c, d, e, f, ip, anorm, rcond, w, iw,
171 $ info )
172 CALL chkxer( 'SGTCON', infot, nout, lerr, ok )
173 infot = 2
174 CALL sgtcon( 'I', -1, c, d, e, f, ip, anorm, rcond, w, iw,
175 $ info )
176 CALL chkxer( 'SGTCON', infot, nout, lerr, ok )
177 infot = 8
178 CALL sgtcon( 'I', 0, c, d, e, f, ip, -anorm, rcond, w, iw,
179 $ info )
180 CALL chkxer( 'SGTCON', 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* SPTTRF
188*
189 srnamt = 'SPTTRF'
190 infot = 1
191 CALL spttrf( -1, d, e, info )
192 CALL chkxer( 'SPTTRF', infot, nout, lerr, ok )
193*
194* SPTTRS
195*
196 srnamt = 'SPTTRS'
197 infot = 1
198 CALL spttrs( -1, 0, d, e, x, 1, info )
199 CALL chkxer( 'SPTTRS', infot, nout, lerr, ok )
200 infot = 2
201 CALL spttrs( 0, -1, d, e, x, 1, info )
202 CALL chkxer( 'SPTTRS', infot, nout, lerr, ok )
203 infot = 6
204 CALL spttrs( 2, 1, d, e, x, 1, info )
205 CALL chkxer( 'SPTTRS', infot, nout, lerr, ok )
206*
207* SPTRFS
208*
209 srnamt = 'SPTRFS'
210 infot = 1
211 CALL sptrfs( -1, 0, d, e, df, ef, b, 1, x, 1, r1, r2, w, info )
212 CALL chkxer( 'SPTRFS', infot, nout, lerr, ok )
213 infot = 2
214 CALL sptrfs( 0, -1, d, e, df, ef, b, 1, x, 1, r1, r2, w, info )
215 CALL chkxer( 'SPTRFS', infot, nout, lerr, ok )
216 infot = 8
217 CALL sptrfs( 2, 1, d, e, df, ef, b, 1, x, 2, r1, r2, w, info )
218 CALL chkxer( 'SPTRFS', infot, nout, lerr, ok )
219 infot = 10
220 CALL sptrfs( 2, 1, d, e, df, ef, b, 2, x, 1, r1, r2, w, info )
221 CALL chkxer( 'SPTRFS', infot, nout, lerr, ok )
222*
223* SPTCON
224*
225 srnamt = 'SPTCON'
226 infot = 1
227 CALL sptcon( -1, d, e, anorm, rcond, w, info )
228 CALL chkxer( 'SPTCON', infot, nout, lerr, ok )
229 infot = 4
230 CALL sptcon( 0, d, e, -anorm, rcond, w, info )
231 CALL chkxer( 'SPTCON', 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 SERRGT
241*

◆ serrlq()

subroutine serrlq ( character*3 path,
integer nunit )

SERRLQ

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

◆ serrls()

subroutine serrls ( character*3 path,
integer nunit )

SERRLS

Purpose:
!>
!> SERRLS tests the error exits for the REAL least squares
!> driver routines (SGELS, 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 serrls.f.

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX
69 parameter( nmax = 2 )
70* ..
71* .. Local Scalars ..
72 CHARACTER*2 C2
73 INTEGER INFO, IRNK
74 REAL RCOND
75* ..
76* .. Local Arrays ..
77 INTEGER IP( NMAX )
78 REAL 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, sgels, sgelsd, sgelss, sgelsy
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.0e+0
103 a( 1, 2 ) = 2.0e+0
104 a( 2, 2 ) = 3.0e+0
105 a( 2, 1 ) = 4.0e+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* SGELS
113*
114 srnamt = 'SGELS '
115 infot = 1
116 CALL sgels( '/', 0, 0, 0, a, 1, b, 1, w, 1, info )
117 CALL chkxer( 'SGELS ', infot, nout, lerr, ok )
118 infot = 2
119 CALL sgels( 'N', -1, 0, 0, a, 1, b, 1, w, 1, info )
120 CALL chkxer( 'SGELS ', infot, nout, lerr, ok )
121 infot = 3
122 CALL sgels( 'N', 0, -1, 0, a, 1, b, 1, w, 1, info )
123 CALL chkxer( 'SGELS ', infot, nout, lerr, ok )
124 infot = 4
125 CALL sgels( 'N', 0, 0, -1, a, 1, b, 1, w, 1, info )
126 CALL chkxer( 'SGELS ', infot, nout, lerr, ok )
127 infot = 6
128 CALL sgels( 'N', 2, 0, 0, a, 1, b, 2, w, 2, info )
129 CALL chkxer( 'SGELS ', infot, nout, lerr, ok )
130 infot = 8
131 CALL sgels( 'N', 2, 0, 0, a, 2, b, 1, w, 2, info )
132 CALL chkxer( 'SGELS ', infot, nout, lerr, ok )
133 infot = 10
134 CALL sgels( 'N', 1, 1, 0, a, 1, b, 1, w, 1, info )
135 CALL chkxer( 'SGELS ', infot, nout, lerr, ok )
136*
137* SGELSS
138*
139 srnamt = 'SGELSS'
140 infot = 1
141 CALL sgelss( -1, 0, 0, a, 1, b, 1, s, rcond, irnk, w, 1, info )
142 CALL chkxer( 'SGELSS', infot, nout, lerr, ok )
143 infot = 2
144 CALL sgelss( 0, -1, 0, a, 1, b, 1, s, rcond, irnk, w, 1, info )
145 CALL chkxer( 'SGELSS', infot, nout, lerr, ok )
146 infot = 3
147 CALL sgelss( 0, 0, -1, a, 1, b, 1, s, rcond, irnk, w, 1, info )
148 CALL chkxer( 'SGELSS', infot, nout, lerr, ok )
149 infot = 5
150 CALL sgelss( 2, 0, 0, a, 1, b, 2, s, rcond, irnk, w, 2, info )
151 CALL chkxer( 'SGELSS', infot, nout, lerr, ok )
152 infot = 7
153 CALL sgelss( 2, 0, 0, a, 2, b, 1, s, rcond, irnk, w, 2, info )
154 CALL chkxer( 'SGELSS', infot, nout, lerr, ok )
155*
156* SGELSY
157*
158 srnamt = 'SGELSY'
159 infot = 1
160 CALL sgelsy( -1, 0, 0, a, 1, b, 1, ip, rcond, irnk, w, 10,
161 $ info )
162 CALL chkxer( 'SGELSY', infot, nout, lerr, ok )
163 infot = 2
164 CALL sgelsy( 0, -1, 0, a, 1, b, 1, ip, rcond, irnk, w, 10,
165 $ info )
166 CALL chkxer( 'SGELSY', infot, nout, lerr, ok )
167 infot = 3
168 CALL sgelsy( 0, 0, -1, a, 1, b, 1, ip, rcond, irnk, w, 10,
169 $ info )
170 CALL chkxer( 'SGELSY', infot, nout, lerr, ok )
171 infot = 5
172 CALL sgelsy( 2, 0, 0, a, 1, b, 2, ip, rcond, irnk, w, 10,
173 $ info )
174 CALL chkxer( 'SGELSY', infot, nout, lerr, ok )
175 infot = 7
176 CALL sgelsy( 2, 0, 0, a, 2, b, 1, ip, rcond, irnk, w, 10,
177 $ info )
178 CALL chkxer( 'SGELSY', infot, nout, lerr, ok )
179 infot = 12
180 CALL sgelsy( 2, 2, 1, a, 2, b, 2, ip, rcond, irnk, w, 1, info )
181 CALL chkxer( 'SGELSY', infot, nout, lerr, ok )
182*
183* SGELSD
184*
185 srnamt = 'SGELSD'
186 infot = 1
187 CALL sgelsd( -1, 0, 0, a, 1, b, 1, s, rcond, irnk, w, 10,
188 $ ip, info )
189 CALL chkxer( 'SGELSD', infot, nout, lerr, ok )
190 infot = 2
191 CALL sgelsd( 0, -1, 0, a, 1, b, 1, s, rcond, irnk, w, 10,
192 $ ip, info )
193 CALL chkxer( 'SGELSD', infot, nout, lerr, ok )
194 infot = 3
195 CALL sgelsd( 0, 0, -1, a, 1, b, 1, s, rcond, irnk, w, 10,
196 $ ip, info )
197 CALL chkxer( 'SGELSD', infot, nout, lerr, ok )
198 infot = 5
199 CALL sgelsd( 2, 0, 0, a, 1, b, 2, s, rcond, irnk, w, 10,
200 $ ip, info )
201 CALL chkxer( 'SGELSD', infot, nout, lerr, ok )
202 infot = 7
203 CALL sgelsd( 2, 0, 0, a, 2, b, 1, s, rcond, irnk, w, 10,
204 $ ip, info )
205 CALL chkxer( 'SGELSD', infot, nout, lerr, ok )
206 infot = 12
207 CALL sgelsd( 2, 2, 1, a, 2, b, 2, s, rcond, irnk, w, 1, ip,
208 $ info )
209 CALL chkxer( 'SGELSD', 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 SERRLS
219*

◆ serrpo()

subroutine serrpo ( character*3 path,
integer nunit )

SERRPO

SERRPOX

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

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX
69 parameter( nmax = 4 )
70* ..
71* .. Local Scalars ..
72 CHARACTER*2 C2
73 INTEGER I, INFO, J
74 REAL ANRM, RCOND
75* ..
76* .. Local Arrays ..
77 INTEGER IW( NMAX )
78 REAL 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, spbcon, spbequ, spbrfs, spbtf2,
87 $ spbtrf, spbtrs, spocon, spoequ, sporfs, spotf2,
88 $ spotrf, spotri, spotrs, sppcon, sppequ, spprfs,
89 $ spptrf, spptri, spptrs
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 real
102* ..
103* .. Executable Statements ..
104*
105 nout = nunit
106 WRITE( nout, fmt = * )
107 c2 = path( 2: 3 )
108*
109* Set the variables to innocuous values.
110*
111 DO 20 j = 1, nmax
112 DO 10 i = 1, nmax
113 a( i, j ) = 1. / real( i+j )
114 af( i, j ) = 1. / real( i+j )
115 10 CONTINUE
116 b( j ) = 0.
117 r1( j ) = 0.
118 r2( j ) = 0.
119 w( j ) = 0.
120 x( j ) = 0.
121 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* SPOTRF
131*
132 srnamt = 'SPOTRF'
133 infot = 1
134 CALL spotrf( '/', 0, a, 1, info )
135 CALL chkxer( 'SPOTRF', infot, nout, lerr, ok )
136 infot = 2
137 CALL spotrf( 'U', -1, a, 1, info )
138 CALL chkxer( 'SPOTRF', infot, nout, lerr, ok )
139 infot = 4
140 CALL spotrf( 'U', 2, a, 1, info )
141 CALL chkxer( 'SPOTRF', infot, nout, lerr, ok )
142*
143* SPOTF2
144*
145 srnamt = 'SPOTF2'
146 infot = 1
147 CALL spotf2( '/', 0, a, 1, info )
148 CALL chkxer( 'SPOTF2', infot, nout, lerr, ok )
149 infot = 2
150 CALL spotf2( 'U', -1, a, 1, info )
151 CALL chkxer( 'SPOTF2', infot, nout, lerr, ok )
152 infot = 4
153 CALL spotf2( 'U', 2, a, 1, info )
154 CALL chkxer( 'SPOTF2', infot, nout, lerr, ok )
155*
156* SPOTRI
157*
158 srnamt = 'SPOTRI'
159 infot = 1
160 CALL spotri( '/', 0, a, 1, info )
161 CALL chkxer( 'SPOTRI', infot, nout, lerr, ok )
162 infot = 2
163 CALL spotri( 'U', -1, a, 1, info )
164 CALL chkxer( 'SPOTRI', infot, nout, lerr, ok )
165 infot = 4
166 CALL spotri( 'U', 2, a, 1, info )
167 CALL chkxer( 'SPOTRI', infot, nout, lerr, ok )
168*
169* SPOTRS
170*
171 srnamt = 'SPOTRS'
172 infot = 1
173 CALL spotrs( '/', 0, 0, a, 1, b, 1, info )
174 CALL chkxer( 'SPOTRS', infot, nout, lerr, ok )
175 infot = 2
176 CALL spotrs( 'U', -1, 0, a, 1, b, 1, info )
177 CALL chkxer( 'SPOTRS', infot, nout, lerr, ok )
178 infot = 3
179 CALL spotrs( 'U', 0, -1, a, 1, b, 1, info )
180 CALL chkxer( 'SPOTRS', infot, nout, lerr, ok )
181 infot = 5
182 CALL spotrs( 'U', 2, 1, a, 1, b, 2, info )
183 CALL chkxer( 'SPOTRS', infot, nout, lerr, ok )
184 infot = 7
185 CALL spotrs( 'U', 2, 1, a, 2, b, 1, info )
186 CALL chkxer( 'SPOTRS', infot, nout, lerr, ok )
187*
188* SPORFS
189*
190 srnamt = 'SPORFS'
191 infot = 1
192 CALL sporfs( '/', 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w, iw,
193 $ info )
194 CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
195 infot = 2
196 CALL sporfs( 'U', -1, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
197 $ iw, info )
198 CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
199 infot = 3
200 CALL sporfs( 'U', 0, -1, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
201 $ iw, info )
202 CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
203 infot = 5
204 CALL sporfs( 'U', 2, 1, a, 1, af, 2, b, 2, x, 2, r1, r2, w, iw,
205 $ info )
206 CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
207 infot = 7
208 CALL sporfs( 'U', 2, 1, a, 2, af, 1, b, 2, x, 2, r1, r2, w, iw,
209 $ info )
210 CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
211 infot = 9
212 CALL sporfs( 'U', 2, 1, a, 2, af, 2, b, 1, x, 2, r1, r2, w, iw,
213 $ info )
214 CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
215 infot = 11
216 CALL sporfs( 'U', 2, 1, a, 2, af, 2, b, 2, x, 1, r1, r2, w, iw,
217 $ info )
218 CALL chkxer( 'SPORFS', infot, nout, lerr, ok )
219*
220* SPOCON
221*
222 srnamt = 'SPOCON'
223 infot = 1
224 CALL spocon( '/', 0, a, 1, anrm, rcond, w, iw, info )
225 CALL chkxer( 'SPOCON', infot, nout, lerr, ok )
226 infot = 2
227 CALL spocon( 'U', -1, a, 1, anrm, rcond, w, iw, info )
228 CALL chkxer( 'SPOCON', infot, nout, lerr, ok )
229 infot = 4
230 CALL spocon( 'U', 2, a, 1, anrm, rcond, w, iw, info )
231 CALL chkxer( 'SPOCON', infot, nout, lerr, ok )
232*
233* SPOEQU
234*
235 srnamt = 'SPOEQU'
236 infot = 1
237 CALL spoequ( -1, a, 1, r1, rcond, anrm, info )
238 CALL chkxer( 'SPOEQU', infot, nout, lerr, ok )
239 infot = 3
240 CALL spoequ( 2, a, 1, r1, rcond, anrm, info )
241 CALL chkxer( 'SPOEQU', 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* SPPTRF
249*
250 srnamt = 'SPPTRF'
251 infot = 1
252 CALL spptrf( '/', 0, a, info )
253 CALL chkxer( 'SPPTRF', infot, nout, lerr, ok )
254 infot = 2
255 CALL spptrf( 'U', -1, a, info )
256 CALL chkxer( 'SPPTRF', infot, nout, lerr, ok )
257*
258* SPPTRI
259*
260 srnamt = 'SPPTRI'
261 infot = 1
262 CALL spptri( '/', 0, a, info )
263 CALL chkxer( 'SPPTRI', infot, nout, lerr, ok )
264 infot = 2
265 CALL spptri( 'U', -1, a, info )
266 CALL chkxer( 'SPPTRI', infot, nout, lerr, ok )
267*
268* SPPTRS
269*
270 srnamt = 'SPPTRS'
271 infot = 1
272 CALL spptrs( '/', 0, 0, a, b, 1, info )
273 CALL chkxer( 'SPPTRS', infot, nout, lerr, ok )
274 infot = 2
275 CALL spptrs( 'U', -1, 0, a, b, 1, info )
276 CALL chkxer( 'SPPTRS', infot, nout, lerr, ok )
277 infot = 3
278 CALL spptrs( 'U', 0, -1, a, b, 1, info )
279 CALL chkxer( 'SPPTRS', infot, nout, lerr, ok )
280 infot = 6
281 CALL spptrs( 'U', 2, 1, a, b, 1, info )
282 CALL chkxer( 'SPPTRS', infot, nout, lerr, ok )
283*
284* SPPRFS
285*
286 srnamt = 'SPPRFS'
287 infot = 1
288 CALL spprfs( '/', 0, 0, a, af, b, 1, x, 1, r1, r2, w, iw,
289 $ info )
290 CALL chkxer( 'SPPRFS', infot, nout, lerr, ok )
291 infot = 2
292 CALL spprfs( 'U', -1, 0, a, af, b, 1, x, 1, r1, r2, w, iw,
293 $ info )
294 CALL chkxer( 'SPPRFS', infot, nout, lerr, ok )
295 infot = 3
296 CALL spprfs( 'U', 0, -1, a, af, b, 1, x, 1, r1, r2, w, iw,
297 $ info )
298 CALL chkxer( 'SPPRFS', infot, nout, lerr, ok )
299 infot = 7
300 CALL spprfs( 'U', 2, 1, a, af, b, 1, x, 2, r1, r2, w, iw,
301 $ info )
302 CALL chkxer( 'SPPRFS', infot, nout, lerr, ok )
303 infot = 9
304 CALL spprfs( 'U', 2, 1, a, af, b, 2, x, 1, r1, r2, w, iw,
305 $ info )
306 CALL chkxer( 'SPPRFS', infot, nout, lerr, ok )
307*
308* SPPCON
309*
310 srnamt = 'SPPCON'
311 infot = 1
312 CALL sppcon( '/', 0, a, anrm, rcond, w, iw, info )
313 CALL chkxer( 'SPPCON', infot, nout, lerr, ok )
314 infot = 2
315 CALL sppcon( 'U', -1, a, anrm, rcond, w, iw, info )
316 CALL chkxer( 'SPPCON', infot, nout, lerr, ok )
317*
318* SPPEQU
319*
320 srnamt = 'SPPEQU'
321 infot = 1
322 CALL sppequ( '/', 0, a, r1, rcond, anrm, info )
323 CALL chkxer( 'SPPEQU', infot, nout, lerr, ok )
324 infot = 2
325 CALL sppequ( 'U', -1, a, r1, rcond, anrm, info )
326 CALL chkxer( 'SPPEQU', 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* SPBTRF
334*
335 srnamt = 'SPBTRF'
336 infot = 1
337 CALL spbtrf( '/', 0, 0, a, 1, info )
338 CALL chkxer( 'SPBTRF', infot, nout, lerr, ok )
339 infot = 2
340 CALL spbtrf( 'U', -1, 0, a, 1, info )
341 CALL chkxer( 'SPBTRF', infot, nout, lerr, ok )
342 infot = 3
343 CALL spbtrf( 'U', 1, -1, a, 1, info )
344 CALL chkxer( 'SPBTRF', infot, nout, lerr, ok )
345 infot = 5
346 CALL spbtrf( 'U', 2, 1, a, 1, info )
347 CALL chkxer( 'SPBTRF', infot, nout, lerr, ok )
348*
349* SPBTF2
350*
351 srnamt = 'SPBTF2'
352 infot = 1
353 CALL spbtf2( '/', 0, 0, a, 1, info )
354 CALL chkxer( 'SPBTF2', infot, nout, lerr, ok )
355 infot = 2
356 CALL spbtf2( 'U', -1, 0, a, 1, info )
357 CALL chkxer( 'SPBTF2', infot, nout, lerr, ok )
358 infot = 3
359 CALL spbtf2( 'U', 1, -1, a, 1, info )
360 CALL chkxer( 'SPBTF2', infot, nout, lerr, ok )
361 infot = 5
362 CALL spbtf2( 'U', 2, 1, a, 1, info )
363 CALL chkxer( 'SPBTF2', infot, nout, lerr, ok )
364*
365* SPBTRS
366*
367 srnamt = 'SPBTRS'
368 infot = 1
369 CALL spbtrs( '/', 0, 0, 0, a, 1, b, 1, info )
370 CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
371 infot = 2
372 CALL spbtrs( 'U', -1, 0, 0, a, 1, b, 1, info )
373 CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
374 infot = 3
375 CALL spbtrs( 'U', 1, -1, 0, a, 1, b, 1, info )
376 CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
377 infot = 4
378 CALL spbtrs( 'U', 0, 0, -1, a, 1, b, 1, info )
379 CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
380 infot = 6
381 CALL spbtrs( 'U', 2, 1, 1, a, 1, b, 1, info )
382 CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
383 infot = 8
384 CALL spbtrs( 'U', 2, 0, 1, a, 1, b, 1, info )
385 CALL chkxer( 'SPBTRS', infot, nout, lerr, ok )
386*
387* SPBRFS
388*
389 srnamt = 'SPBRFS'
390 infot = 1
391 CALL spbrfs( '/', 0, 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
392 $ iw, info )
393 CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
394 infot = 2
395 CALL spbrfs( 'U', -1, 0, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
396 $ iw, info )
397 CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
398 infot = 3
399 CALL spbrfs( 'U', 1, -1, 0, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
400 $ iw, info )
401 CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
402 infot = 4
403 CALL spbrfs( 'U', 0, 0, -1, a, 1, af, 1, b, 1, x, 1, r1, r2, w,
404 $ iw, info )
405 CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
406 infot = 6
407 CALL spbrfs( 'U', 2, 1, 1, a, 1, af, 2, b, 2, x, 2, r1, r2, w,
408 $ iw, info )
409 CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
410 infot = 8
411 CALL spbrfs( 'U', 2, 1, 1, a, 2, af, 1, b, 2, x, 2, r1, r2, w,
412 $ iw, info )
413 CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
414 infot = 10
415 CALL spbrfs( 'U', 2, 0, 1, a, 1, af, 1, b, 1, x, 2, r1, r2, w,
416 $ iw, info )
417 CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
418 infot = 12
419 CALL spbrfs( 'U', 2, 0, 1, a, 1, af, 1, b, 2, x, 1, r1, r2, w,
420 $ iw, info )
421 CALL chkxer( 'SPBRFS', infot, nout, lerr, ok )
422*
423* SPBCON
424*
425 srnamt = 'SPBCON'
426 infot = 1
427 CALL spbcon( '/', 0, 0, a, 1, anrm, rcond, w, iw, info )
428 CALL chkxer( 'SPBCON', infot, nout, lerr, ok )
429 infot = 2
430 CALL spbcon( 'U', -1, 0, a, 1, anrm, rcond, w, iw, info )
431 CALL chkxer( 'SPBCON', infot, nout, lerr, ok )
432 infot = 3
433 CALL spbcon( 'U', 1, -1, a, 1, anrm, rcond, w, iw, info )
434 CALL chkxer( 'SPBCON', infot, nout, lerr, ok )
435 infot = 5
436 CALL spbcon( 'U', 2, 1, a, 1, anrm, rcond, w, iw, info )
437 CALL chkxer( 'SPBCON', infot, nout, lerr, ok )
438*
439* SPBEQU
440*
441 srnamt = 'SPBEQU'
442 infot = 1
443 CALL spbequ( '/', 0, 0, a, 1, r1, rcond, anrm, info )
444 CALL chkxer( 'SPBEQU', infot, nout, lerr, ok )
445 infot = 2
446 CALL spbequ( 'U', -1, 0, a, 1, r1, rcond, anrm, info )
447 CALL chkxer( 'SPBEQU', infot, nout, lerr, ok )
448 infot = 3
449 CALL spbequ( 'U', 1, -1, a, 1, r1, rcond, anrm, info )
450 CALL chkxer( 'SPBEQU', infot, nout, lerr, ok )
451 infot = 5
452 CALL spbequ( 'U', 2, 1, a, 1, r1, rcond, anrm, info )
453 CALL chkxer( 'SPBEQU', 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 SERRPO
463*
spbtf2
subroutine spbtf2(uplo, n, kd, ab, ldab, info)
SPBTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite band matrix (un...
Definition spbtf2.f:142
spotf2
subroutine spotf2(uplo, n, a, lda, info)
SPOTF2 computes the Cholesky factorization of a symmetric/Hermitian positive definite matrix (unblock...
Definition spotf2.f:109

◆ serrps()

subroutine serrps ( character*3 path,
integer nunit )

SERRPS

Purpose:
!>
!> SERRPS tests the error exits for the REAL routines
!> for SPSTRF..
!>
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 serrps.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 REAL A( NMAX, NMAX ), WORK( 2*NMAX )
76 INTEGER PIV( NMAX )
77* ..
78* .. External Subroutines ..
79 EXTERNAL alaesm, chkxer, spstf2, spstrf
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 real
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.0 / real( i+j )
103*
104 100 CONTINUE
105 piv( j ) = j
106 work( j ) = 0.
107 work( nmax+j ) = 0.
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* SPSTRF
117*
118 srnamt = 'SPSTRF'
119 infot = 1
120 CALL spstrf( '/', 0, a, 1, piv, rank, -1.0, work, info )
121 CALL chkxer( 'SPSTRF', infot, nout, lerr, ok )
122 infot = 2
123 CALL spstrf( 'U', -1, a, 1, piv, rank, -1.0, work, info )
124 CALL chkxer( 'SPSTRF', infot, nout, lerr, ok )
125 infot = 4
126 CALL spstrf( 'U', 2, a, 1, piv, rank, -1.0, work, info )
127 CALL chkxer( 'SPSTRF', infot, nout, lerr, ok )
128*
129* SPSTF2
130*
131 srnamt = 'SPSTF2'
132 infot = 1
133 CALL spstf2( '/', 0, a, 1, piv, rank, -1.0, work, info )
134 CALL chkxer( 'SPSTF2', infot, nout, lerr, ok )
135 infot = 2
136 CALL spstf2( 'U', -1, a, 1, piv, rank, -1.0, work, info )
137 CALL chkxer( 'SPSTF2', infot, nout, lerr, ok )
138 infot = 4
139 CALL spstf2( 'U', 2, a, 1, piv, rank, -1.0, work, info )
140 CALL chkxer( 'SPSTF2', 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 SERRPS
150*
spstf2
subroutine spstf2(uplo, n, a, lda, piv, rank, tol, work, info)
SPSTF2 computes the Cholesky factorization with complete pivoting of a real symmetric positive semide...
Definition spstf2.f:141

◆ serrql()

subroutine serrql ( character*3 path,
integer nunit )

SERRQL

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

◆ serrqp()

subroutine serrqp ( character*3 path,
integer nunit )

SERRQP

Purpose:
!>
!> SERRQP tests the error exits for SGEQP3.
!>
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 serrqp.f.

54*
55* -- LAPACK test routine --
56* -- LAPACK is a software package provided by Univ. of Tennessee, --
57* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
58*
59* .. Scalar Arguments ..
60 CHARACTER*3 PATH
61 INTEGER NUNIT
62* ..
63*
64* =====================================================================
65*
66* .. Parameters ..
67 INTEGER NMAX
68 parameter( nmax = 3 )
69* ..
70* .. Local Scalars ..
71 CHARACTER*2 C2
72 INTEGER INFO, LW
73* ..
74* .. Local Arrays ..
75 INTEGER IP( NMAX )
76 REAL 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, sgeqp3
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.0e+0
101 a( 1, 2 ) = 2.0e+0
102 a( 2, 2 ) = 3.0e+0
103 a( 2, 1 ) = 4.0e+0
104 ok = .true.
105*
106 IF( lsamen( 2, c2, 'QP' ) ) THEN
107*
108* Test error exits for QR factorization with pivoting
109*
110* SGEQP3
111*
112 srnamt = 'SGEQP3'
113 infot = 1
114 CALL sgeqp3( -1, 0, a, 1, ip, tau, w, lw, info )
115 CALL chkxer( 'SGEQP3', infot, nout, lerr, ok )
116 infot = 2
117 CALL sgeqp3( 1, -1, a, 1, ip, tau, w, lw, info )
118 CALL chkxer( 'SGEQP3', infot, nout, lerr, ok )
119 infot = 4
120 CALL sgeqp3( 2, 3, a, 1, ip, tau, w, lw, info )
121 CALL chkxer( 'SGEQP3', infot, nout, lerr, ok )
122 infot = 8
123 CALL sgeqp3( 2, 2, a, 2, ip, tau, w, lw-10, info )
124 CALL chkxer( 'SGEQP3', 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 SERRQP
134*

◆ serrqr()

subroutine serrqr ( character*3 path,
integer nunit )

SERRQR

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

◆ serrqrt()

subroutine serrqrt ( character*3 path,
integer nunit )

SERRQRT

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

◆ serrqrtp()

subroutine serrqrtp ( character*3 path,
integer nunit )

SERRQRTP

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

◆ serrrfp()

subroutine serrrfp ( integer nunit)

SERRRFP

Purpose:
!>
!> SERRRFP tests the error exits for the REAL driver routines
!> for solving linear systems of equations.
!>
!> SDRVRFP tests the REAL LAPACK RFP routines:
!>     STFSM, STFTRI, SSFRK, STFTTP, STFTTR, SPFTRF, SPFTRS, STPTTF,
!>     STPTTR, STRTTF, and STRTTP
!>
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 serrrfp.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 REAL ALPHA, BETA
67* ..
68* .. Local Arrays ..
69 REAL A( 1, 1), B( 1, 1)
70* ..
71* .. External Subroutines ..
72 EXTERNAL chkxer, stfsm, stftri, ssfrk, stfttp, stfttr,
73 + spftri, spftrf, spftrs, stpttf, stpttr, strttf,
74 + strttp
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.0e+0
90 b( 1, 1 ) = 1.0e+0
91 alpha = 1.0e+0
92 beta = 1.0e+0
93*
94 srnamt = 'SPFTRF'
95 infot = 1
96 CALL spftrf( '/', 'U', 0, a, info )
97 CALL chkxer( 'SPFTRF', infot, nout, lerr, ok )
98 infot = 2
99 CALL spftrf( 'N', '/', 0, a, info )
100 CALL chkxer( 'SPFTRF', infot, nout, lerr, ok )
101 infot = 3
102 CALL spftrf( 'N', 'U', -1, a, info )
103 CALL chkxer( 'SPFTRF', infot, nout, lerr, ok )
104*
105 srnamt = 'SPFTRS'
106 infot = 1
107 CALL spftrs( '/', 'U', 0, 0, a, b, 1, info )
108 CALL chkxer( 'SPFTRS', infot, nout, lerr, ok )
109 infot = 2
110 CALL spftrs( 'N', '/', 0, 0, a, b, 1, info )
111 CALL chkxer( 'SPFTRS', infot, nout, lerr, ok )
112 infot = 3
113 CALL spftrs( 'N', 'U', -1, 0, a, b, 1, info )
114 CALL chkxer( 'SPFTRS', infot, nout, lerr, ok )
115 infot = 4
116 CALL spftrs( 'N', 'U', 0, -1, a, b, 1, info )
117 CALL chkxer( 'SPFTRS', infot, nout, lerr, ok )
118 infot = 7
119 CALL spftrs( 'N', 'U', 0, 0, a, b, 0, info )
120 CALL chkxer( 'SPFTRS', infot, nout, lerr, ok )
121*
122 srnamt = 'SPFTRI'
123 infot = 1
124 CALL spftri( '/', 'U', 0, a, info )
125 CALL chkxer( 'SPFTRI', infot, nout, lerr, ok )
126 infot = 2
127 CALL spftri( 'N', '/', 0, a, info )
128 CALL chkxer( 'SPFTRI', infot, nout, lerr, ok )
129 infot = 3
130 CALL spftri( 'N', 'U', -1, a, info )
131 CALL chkxer( 'SPFTRI', infot, nout, lerr, ok )
132*
133 srnamt = 'STFSM '
134 infot = 1
135 CALL stfsm( '/', 'L', 'U', 'T', 'U', 0, 0, alpha, a, b, 1 )
136 CALL chkxer( 'STFSM ', infot, nout, lerr, ok )
137 infot = 2
138 CALL stfsm( 'N', '/', 'U', 'T', 'U', 0, 0, alpha, a, b, 1 )
139 CALL chkxer( 'STFSM ', infot, nout, lerr, ok )
140 infot = 3
141 CALL stfsm( 'N', 'L', '/', 'T', 'U', 0, 0, alpha, a, b, 1 )
142 CALL chkxer( 'STFSM ', infot, nout, lerr, ok )
143 infot = 4
144 CALL stfsm( 'N', 'L', 'U', '/', 'U', 0, 0, alpha, a, b, 1 )
145 CALL chkxer( 'STFSM ', infot, nout, lerr, ok )
146 infot = 5
147 CALL stfsm( 'N', 'L', 'U', 'T', '/', 0, 0, alpha, a, b, 1 )
148 CALL chkxer( 'STFSM ', infot, nout, lerr, ok )
149 infot = 6
150 CALL stfsm( 'N', 'L', 'U', 'T', 'U', -1, 0, alpha, a, b, 1 )
151 CALL chkxer( 'STFSM ', infot, nout, lerr, ok )
152 infot = 7
153 CALL stfsm( 'N', 'L', 'U', 'T', 'U', 0, -1, alpha, a, b, 1 )
154 CALL chkxer( 'STFSM ', infot, nout, lerr, ok )
155 infot = 11
156 CALL stfsm( 'N', 'L', 'U', 'T', 'U', 0, 0, alpha, a, b, 0 )
157 CALL chkxer( 'STFSM ', infot, nout, lerr, ok )
158*
159 srnamt = 'STFTRI'
160 infot = 1
161 CALL stftri( '/', 'L', 'N', 0, a, info )
162 CALL chkxer( 'STFTRI', infot, nout, lerr, ok )
163 infot = 2
164 CALL stftri( 'N', '/', 'N', 0, a, info )
165 CALL chkxer( 'STFTRI', infot, nout, lerr, ok )
166 infot = 3
167 CALL stftri( 'N', 'L', '/', 0, a, info )
168 CALL chkxer( 'STFTRI', infot, nout, lerr, ok )
169 infot = 4
170 CALL stftri( 'N', 'L', 'N', -1, a, info )
171 CALL chkxer( 'STFTRI', infot, nout, lerr, ok )
172*
173 srnamt = 'STFTTR'
174 infot = 1
175 CALL stfttr( '/', 'U', 0, a, b, 1, info )
176 CALL chkxer( 'STFTTR', infot, nout, lerr, ok )
177 infot = 2
178 CALL stfttr( 'N', '/', 0, a, b, 1, info )
179 CALL chkxer( 'STFTTR', infot, nout, lerr, ok )
180 infot = 3
181 CALL stfttr( 'N', 'U', -1, a, b, 1, info )
182 CALL chkxer( 'STFTTR', infot, nout, lerr, ok )
183 infot = 6
184 CALL stfttr( 'N', 'U', 0, a, b, 0, info )
185 CALL chkxer( 'STFTTR', infot, nout, lerr, ok )
186*
187 srnamt = 'STRTTF'
188 infot = 1
189 CALL strttf( '/', 'U', 0, a, 1, b, info )
190 CALL chkxer( 'STRTTF', infot, nout, lerr, ok )
191 infot = 2
192 CALL strttf( 'N', '/', 0, a, 1, b, info )
193 CALL chkxer( 'STRTTF', infot, nout, lerr, ok )
194 infot = 3
195 CALL strttf( 'N', 'U', -1, a, 1, b, info )
196 CALL chkxer( 'STRTTF', infot, nout, lerr, ok )
197 infot = 5
198 CALL strttf( 'N', 'U', 0, a, 0, b, info )
199 CALL chkxer( 'STRTTF', infot, nout, lerr, ok )
200*
201 srnamt = 'STFTTP'
202 infot = 1
203 CALL stfttp( '/', 'U', 0, a, b, info )
204 CALL chkxer( 'STFTTP', infot, nout, lerr, ok )
205 infot = 2
206 CALL stfttp( 'N', '/', 0, a, b, info )
207 CALL chkxer( 'STFTTP', infot, nout, lerr, ok )
208 infot = 3
209 CALL stfttp( 'N', 'U', -1, a, b, info )
210 CALL chkxer( 'STFTTP', infot, nout, lerr, ok )
211*
212 srnamt = 'STPTTF'
213 infot = 1
214 CALL stpttf( '/', 'U', 0, a, b, info )
215 CALL chkxer( 'STPTTF', infot, nout, lerr, ok )
216 infot = 2
217 CALL stpttf( 'N', '/', 0, a, b, info )
218 CALL chkxer( 'STPTTF', infot, nout, lerr, ok )
219 infot = 3
220 CALL stpttf( 'N', 'U', -1, a, b, info )
221 CALL chkxer( 'STPTTF', infot, nout, lerr, ok )
222*
223 srnamt = 'STRTTP'
224 infot = 1
225 CALL strttp( '/', 0, a, 1, b, info )
226 CALL chkxer( 'STRTTP', infot, nout, lerr, ok )
227 infot = 2
228 CALL strttp( 'U', -1, a, 1, b, info )
229 CALL chkxer( 'STRTTP', infot, nout, lerr, ok )
230 infot = 4
231 CALL strttp( 'U', 0, a, 0, b, info )
232 CALL chkxer( 'STRTTP', infot, nout, lerr, ok )
233*
234 srnamt = 'STPTTR'
235 infot = 1
236 CALL stpttr( '/', 0, a, b, 1, info )
237 CALL chkxer( 'STPTTR', infot, nout, lerr, ok )
238 infot = 2
239 CALL stpttr( 'U', -1, a, b, 1, info )
240 CALL chkxer( 'STPTTR', infot, nout, lerr, ok )
241 infot = 5
242 CALL stpttr( 'U', 0, a, b, 0, info )
243 CALL chkxer( 'STPTTR', infot, nout, lerr, ok )
244*
245 srnamt = 'SSFRK '
246 infot = 1
247 CALL ssfrk( '/', 'U', 'N', 0, 0, alpha, a, 1, beta, b )
248 CALL chkxer( 'SSFRK ', infot, nout, lerr, ok )
249 infot = 2
250 CALL ssfrk( 'N', '/', 'N', 0, 0, alpha, a, 1, beta, b )
251 CALL chkxer( 'SSFRK ', infot, nout, lerr, ok )
252 infot = 3
253 CALL ssfrk( 'N', 'U', '/', 0, 0, alpha, a, 1, beta, b )
254 CALL chkxer( 'SSFRK ', infot, nout, lerr, ok )
255 infot = 4
256 CALL ssfrk( 'N', 'U', 'N', -1, 0, alpha, a, 1, beta, b )
257 CALL chkxer( 'SSFRK ', infot, nout, lerr, ok )
258 infot = 5
259 CALL ssfrk( 'N', 'U', 'N', 0, -1, alpha, a, 1, beta, b )
260 CALL chkxer( 'SSFRK ', infot, nout, lerr, ok )
261 infot = 8
262 CALL ssfrk( 'N', 'U', 'N', 0, 0, alpha, a, 0, beta, b )
263 CALL chkxer( 'SSFRK ', 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, 'REAL 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 SERRRFP
280*
stftri
subroutine stftri(transr, uplo, diag, n, a, info)
STFTRI
Definition stftri.f:201

◆ serrrq()

subroutine serrrq ( character*3 path,
integer nunit )

SERRRQ

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

◆ serrsy()

subroutine serrsy ( character*3 path,
integer nunit )

SERRSY

SERRSYX

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

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX
69 parameter( nmax = 4 )
70* ..
71* .. Local Scalars ..
72 CHARACTER*2 C2
73 INTEGER I, INFO, J
74 REAL ANRM, RCOND
75* ..
76* .. Local Arrays ..
77 INTEGER IP( NMAX ), IW( NMAX )
78 REAL 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, sspcon, ssprfs, ssptrf, ssptri,
88 $ ssptrs, ssycon, ssycon_3, ssycon_rook, ssyrfs,
89 $ ssytf2_rk, ssytf2_rook, ssytrf, ssytrf_rk,
90 $ ssytrf_rook, ssytri, ssytf2, ssytri_3,
91 $ ssytri_3x, ssytri_rook, ssytrf_aa, ssytri2,
92 $ ssytri2x, ssytrs, ssytrs_3, ssytrs_rook,
93 $ ssytrs_aa, ssytrf_aa_2stage, ssytrs_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 real
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. / real( i+j )
118 af( i, j ) = 1. / real( i+j )
119 10 CONTINUE
120 b( j ) = 0.e+0
121 e( j ) = 0.e+0
122 r1( j ) = 0.e+0
123 r2( j ) = 0.e+0
124 w( j ) = 0.e+0
125 x( j ) = 0.e+0
126 ip( j ) = j
127 iw( j ) = j
128 20 CONTINUE
129 anrm = 1.0
130 rcond = 1.0
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* SSYTRF
140*
141 srnamt = 'SSYTRF'
142 infot = 1
143 CALL ssytrf( '/', 0, a, 1, ip, w, 1, info )
144 CALL chkxer( 'SSYTRF', infot, nout, lerr, ok )
145 infot = 2
146 CALL ssytrf( 'U', -1, a, 1, ip, w, 1, info )
147 CALL chkxer( 'SSYTRF', infot, nout, lerr, ok )
148 infot = 4
149 CALL ssytrf( 'U', 2, a, 1, ip, w, 4, info )
150 CALL chkxer( 'SSYTRF', infot, nout, lerr, ok )
151 infot = 7
152 CALL ssytrf( 'U', 0, a, 1, ip, w, 0, info )
153 CALL chkxer( 'SSYTRF', infot, nout, lerr, ok )
154 infot = 7
155 CALL ssytrf( 'U', 0, a, 1, ip, w, -2, info )
156 CALL chkxer( 'SSYTRF', infot, nout, lerr, ok )
157*
158* SSYTF2
159*
160 srnamt = 'SSYTF2'
161 infot = 1
162 CALL ssytf2( '/', 0, a, 1, ip, info )
163 CALL chkxer( 'SSYTF2', infot, nout, lerr, ok )
164 infot = 2
165 CALL ssytf2( 'U', -1, a, 1, ip, info )
166 CALL chkxer( 'SSYTF2', infot, nout, lerr, ok )
167 infot = 4
168 CALL ssytf2( 'U', 2, a, 1, ip, info )
169 CALL chkxer( 'SSYTF2', infot, nout, lerr, ok )
170*
171* SSYTRI
172*
173 srnamt = 'SSYTRI'
174 infot = 1
175 CALL ssytri( '/', 0, a, 1, ip, w, info )
176 CALL chkxer( 'SSYTRI', infot, nout, lerr, ok )
177 infot = 2
178 CALL ssytri( 'U', -1, a, 1, ip, w, info )
179 CALL chkxer( 'SSYTRI', infot, nout, lerr, ok )
180 infot = 4
181 CALL ssytri( 'U', 2, a, 1, ip, w, info )
182 CALL chkxer( 'SSYTRI', infot, nout, lerr, ok )
183*
184* SSYTRI2
185*
186 srnamt = 'SSYTRI2'
187 infot = 1
188 CALL ssytri2( '/', 0, a, 1, ip, w, iw(1), info )
189 CALL chkxer( 'SSYTRI2', infot, nout, lerr, ok )
190 infot = 2
191 CALL ssytri2( 'U', -1, a, 1, ip, w, iw(1), info )
192 CALL chkxer( 'SSYTRI2', infot, nout, lerr, ok )
193 infot = 4
194 CALL ssytri2( 'U', 2, a, 1, ip, w, iw(1), info )
195 CALL chkxer( 'SSYTRI2', infot, nout, lerr, ok )
196*
197* SSYTRI2X
198*
199 srnamt = 'SSYTRI2X'
200 infot = 1
201 CALL ssytri2x( '/', 0, a, 1, ip, w, 1, info )
202 CALL chkxer( 'SSYTRI2X', infot, nout, lerr, ok )
203 infot = 2
204 CALL ssytri2x( 'U', -1, a, 1, ip, w, 1, info )
205 CALL chkxer( 'SSYTRI2X', infot, nout, lerr, ok )
206 infot = 4
207 CALL ssytri2x( 'U', 2, a, 1, ip, w, 1, info )
208 CALL chkxer( 'SSYTRI2X', infot, nout, lerr, ok )
209*
210* SSYTRS
211*
212 srnamt = 'SSYTRS'
213 infot = 1
214 CALL ssytrs( '/', 0, 0, a, 1, ip, b, 1, info )
215 CALL chkxer( 'SSYTRS', infot, nout, lerr, ok )
216 infot = 2
217 CALL ssytrs( 'U', -1, 0, a, 1, ip, b, 1, info )
218 CALL chkxer( 'SSYTRS', infot, nout, lerr, ok )
219 infot = 3
220 CALL ssytrs( 'U', 0, -1, a, 1, ip, b, 1, info )
221 CALL chkxer( 'SSYTRS', infot, nout, lerr, ok )
222 infot = 5
223 CALL ssytrs( 'U', 2, 1, a, 1, ip, b, 2, info )
224 CALL chkxer( 'SSYTRS', infot, nout, lerr, ok )
225 infot = 8
226 CALL ssytrs( 'U', 2, 1, a, 2, ip, b, 1, info )
227 CALL chkxer( 'SSYTRS', infot, nout, lerr, ok )
228*
229* SSYRFS
230*
231 srnamt = 'SSYRFS'
232 infot = 1
233 CALL ssyrfs( '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2, w,
234 $ iw, info )
235 CALL chkxer( 'SSYRFS', infot, nout, lerr, ok )
236 infot = 2
237 CALL ssyrfs( 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
238 $ w, iw, info )
239 CALL chkxer( 'SSYRFS', infot, nout, lerr, ok )
240 infot = 3
241 CALL ssyrfs( 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1, r1, r2,
242 $ w, iw, info )
243 CALL chkxer( 'SSYRFS', infot, nout, lerr, ok )
244 infot = 5
245 CALL ssyrfs( 'U', 2, 1, a, 1, af, 2, ip, b, 2, x, 2, r1, r2, w,
246 $ iw, info )
247 CALL chkxer( 'SSYRFS', infot, nout, lerr, ok )
248 infot = 7
249 CALL ssyrfs( 'U', 2, 1, a, 2, af, 1, ip, b, 2, x, 2, r1, r2, w,
250 $ iw, info )
251 CALL chkxer( 'SSYRFS', infot, nout, lerr, ok )
252 infot = 10
253 CALL ssyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 1, x, 2, r1, r2, w,
254 $ iw, info )
255 CALL chkxer( 'SSYRFS', infot, nout, lerr, ok )
256 infot = 12
257 CALL ssyrfs( 'U', 2, 1, a, 2, af, 2, ip, b, 2, x, 1, r1, r2, w,
258 $ iw, info )
259 CALL chkxer( 'SSYRFS', infot, nout, lerr, ok )
260*
261* SSYCON
262*
263 srnamt = 'SSYCON'
264 infot = 1
265 CALL ssycon( '/', 0, a, 1, ip, anrm, rcond, w, iw, info )
266 CALL chkxer( 'SSYCON', infot, nout, lerr, ok )
267 infot = 2
268 CALL ssycon( 'U', -1, a, 1, ip, anrm, rcond, w, iw, info )
269 CALL chkxer( 'SSYCON', infot, nout, lerr, ok )
270 infot = 4
271 CALL ssycon( 'U', 2, a, 1, ip, anrm, rcond, w, iw, info )
272 CALL chkxer( 'SSYCON', infot, nout, lerr, ok )
273 infot = 6
274 CALL ssycon( 'U', 1, a, 1, ip, -1.0, rcond, w, iw, info )
275 CALL chkxer( 'SSYCON', 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* SSYTRF_ROOK
284*
285 srnamt = 'SSYTRF_ROOK'
286 infot = 1
287 CALL ssytrf_rook( '/', 0, a, 1, ip, w, 1, info )
288 CALL chkxer( 'SSYTRF_ROOK', infot, nout, lerr, ok )
289 infot = 2
290 CALL ssytrf_rook( 'U', -1, a, 1, ip, w, 1, info )
291 CALL chkxer( 'SSYTRF_ROOK', infot, nout, lerr, ok )
292 infot = 4
293 CALL ssytrf_rook( 'U', 2, a, 1, ip, w, 4, info )
294 CALL chkxer( 'SSYTRF_ROOK', infot, nout, lerr, ok )
295 infot = 7
296 CALL ssytrf_rook( 'U', 0, a, 1, ip, w, 0, info )
297 CALL chkxer( 'SSYTRF_ROOK', infot, nout, lerr, ok )
298 infot = 7
299 CALL ssytrf_rook( 'U', 0, a, 1, ip, w, -2, info )
300 CALL chkxer( 'SSYTRF_ROOK', infot, nout, lerr, ok )
301*
302* SSYTF2_ROOK
303*
304 srnamt = 'SSYTF2_ROOK'
305 infot = 1
306 CALL ssytf2_rook( '/', 0, a, 1, ip, info )
307 CALL chkxer( 'SSYTF2_ROOK', infot, nout, lerr, ok )
308 infot = 2
309 CALL ssytf2_rook( 'U', -1, a, 1, ip, info )
310 CALL chkxer( 'SSYTF2_ROOK', infot, nout, lerr, ok )
311 infot = 4
312 CALL ssytf2_rook( 'U', 2, a, 1, ip, info )
313 CALL chkxer( 'SSYTF2_ROOK', infot, nout, lerr, ok )
314*
315* SSYTRI_ROOK
316*
317 srnamt = 'SSYTRI_ROOK'
318 infot = 1
319 CALL ssytri_rook( '/', 0, a, 1, ip, w, info )
320 CALL chkxer( 'SSYTRI_ROOK', infot, nout, lerr, ok )
321 infot = 2
322 CALL ssytri_rook( 'U', -1, a, 1, ip, w, info )
323 CALL chkxer( 'SSYTRI_ROOK', infot, nout, lerr, ok )
324 infot = 4
325 CALL ssytri_rook( 'U', 2, a, 1, ip, w, info )
326 CALL chkxer( 'SSYTRI_ROOK', infot, nout, lerr, ok )
327*
328* SSYTRS_ROOK
329*
330 srnamt = 'SSYTRS_ROOK'
331 infot = 1
332 CALL ssytrs_rook( '/', 0, 0, a, 1, ip, b, 1, info )
333 CALL chkxer( 'SSYTRS_ROOK', infot, nout, lerr, ok )
334 infot = 2
335 CALL ssytrs_rook( 'U', -1, 0, a, 1, ip, b, 1, info )
336 CALL chkxer( 'SSYTRS_ROOK', infot, nout, lerr, ok )
337 infot = 3
338 CALL ssytrs_rook( 'U', 0, -1, a, 1, ip, b, 1, info )
339 CALL chkxer( 'SSYTRS_ROOK', infot, nout, lerr, ok )
340 infot = 5
341 CALL ssytrs_rook( 'U', 2, 1, a, 1, ip, b, 2, info )
342 CALL chkxer( 'SSYTRS_ROOK', infot, nout, lerr, ok )
343 infot = 8
344 CALL ssytrs_rook( 'U', 2, 1, a, 2, ip, b, 1, info )
345 CALL chkxer( 'SSYTRS_ROOK', infot, nout, lerr, ok )
346*
347* SSYCON_ROOK
348*
349 srnamt = 'SSYCON_ROOK'
350 infot = 1
351 CALL ssycon_rook( '/', 0, a, 1, ip, anrm, rcond, w, iw, info )
352 CALL chkxer( 'SSYCON_ROOK', infot, nout, lerr, ok )
353 infot = 2
354 CALL ssycon_rook( 'U', -1, a, 1, ip, anrm, rcond, w, iw, info )
355 CALL chkxer( 'SSYCON_ROOK', infot, nout, lerr, ok )
356 infot = 4
357 CALL ssycon_rook( 'U', 2, a, 1, ip, anrm, rcond, w, iw, info )
358 CALL chkxer( 'SSYCON_ROOK', infot, nout, lerr, ok )
359 infot = 6
360 CALL ssycon_rook( 'U', 1, a, 1, ip, -1.0, rcond, w, iw, info )
361 CALL chkxer( 'SSYCON_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* SSYTRF_RK
374*
375 srnamt = 'SSYTRF_RK'
376 infot = 1
377 CALL ssytrf_rk( '/', 0, a, 1, e, ip, w, 1, info )
378 CALL chkxer( 'SSYTRF_RK', infot, nout, lerr, ok )
379 infot = 2
380 CALL ssytrf_rk( 'U', -1, a, 1, e, ip, w, 1, info )
381 CALL chkxer( 'SSYTRF_RK', infot, nout, lerr, ok )
382 infot = 4
383 CALL ssytrf_rk( 'U', 2, a, 1, e, ip, w, 4, info )
384 CALL chkxer( 'SSYTRF_RK', infot, nout, lerr, ok )
385 infot = 8
386 CALL ssytrf_rk( 'U', 0, a, 1, e, ip, w, 0, info )
387 CALL chkxer( 'SSYTRF_RK', infot, nout, lerr, ok )
388 infot = 8
389 CALL ssytrf_rk( 'U', 0, a, 1, e, ip, w, -2, info )
390 CALL chkxer( 'SSYTRF_RK', infot, nout, lerr, ok )
391*
392* SSYTF2_RK
393*
394 srnamt = 'SSYTF2_RK'
395 infot = 1
396 CALL ssytf2_rk( '/', 0, a, 1, e, ip, info )
397 CALL chkxer( 'SSYTF2_RK', infot, nout, lerr, ok )
398 infot = 2
399 CALL ssytf2_rk( 'U', -1, a, 1, e, ip, info )
400 CALL chkxer( 'SSYTF2_RK', infot, nout, lerr, ok )
401 infot = 4
402 CALL ssytf2_rk( 'U', 2, a, 1, e, ip, info )
403 CALL chkxer( 'SSYTF2_RK', infot, nout, lerr, ok )
404*
405* SSYTRI_3
406*
407 srnamt = 'SSYTRI_3'
408 infot = 1
409 CALL ssytri_3( '/', 0, a, 1, e, ip, w, 1, info )
410 CALL chkxer( 'SSYTRI_3', infot, nout, lerr, ok )
411 infot = 2
412 CALL ssytri_3( 'U', -1, a, 1, e, ip, w, 1, info )
413 CALL chkxer( 'SSYTRI_3', infot, nout, lerr, ok )
414 infot = 4
415 CALL ssytri_3( 'U', 2, a, 1, e, ip, w, 1, info )
416 CALL chkxer( 'SSYTRI_3', infot, nout, lerr, ok )
417 infot = 8
418 CALL ssytri_3( 'U', 0, a, 1, e, ip, w, 0, info )
419 CALL chkxer( 'SSYTRI_3', infot, nout, lerr, ok )
420 infot = 8
421 CALL ssytri_3( 'U', 0, a, 1, e, ip, w, -2, info )
422 CALL chkxer( 'SSYTRI_3', infot, nout, lerr, ok )
423*
424* SSYTRI_3X
425*
426 srnamt = 'SSYTRI_3X'
427 infot = 1
428 CALL ssytri_3x( '/', 0, a, 1, e, ip, w, 1, info )
429 CALL chkxer( 'SSYTRI_3X', infot, nout, lerr, ok )
430 infot = 2
431 CALL ssytri_3x( 'U', -1, a, 1, e, ip, w, 1, info )
432 CALL chkxer( 'SSYTRI_3X', infot, nout, lerr, ok )
433 infot = 4
434 CALL ssytri_3x( 'U', 2, a, 1, e, ip, w, 1, info )
435 CALL chkxer( 'SSYTRI_3X', infot, nout, lerr, ok )
436*
437* SSYTRS_3
438*
439 srnamt = 'SSYTRS_3'
440 infot = 1
441 CALL ssytrs_3( '/', 0, 0, a, 1, e, ip, b, 1, info )
442 CALL chkxer( 'SSYTRS_3', infot, nout, lerr, ok )
443 infot = 2
444 CALL ssytrs_3( 'U', -1, 0, a, 1, e, ip, b, 1, info )
445 CALL chkxer( 'SSYTRS_3', infot, nout, lerr, ok )
446 infot = 3
447 CALL ssytrs_3( 'U', 0, -1, a, 1, e, ip, b, 1, info )
448 CALL chkxer( 'SSYTRS_3', infot, nout, lerr, ok )
449 infot = 5
450 CALL ssytrs_3( 'U', 2, 1, a, 1, e, ip, b, 2, info )
451 CALL chkxer( 'SSYTRS_3', infot, nout, lerr, ok )
452 infot = 9
453 CALL ssytrs_3( 'U', 2, 1, a, 2, e, ip, b, 1, info )
454 CALL chkxer( 'SSYTRS_3', infot, nout, lerr, ok )
455*
456* SSYCON_3
457*
458 srnamt = 'SSYCON_3'
459 infot = 1
460 CALL ssycon_3( '/', 0, a, 1, e, ip, anrm, rcond, w, iw,
461 $ info )
462 CALL chkxer( 'SSYCON_3', infot, nout, lerr, ok )
463 infot = 2
464 CALL ssycon_3( 'U', -1, a, 1, e, ip, anrm, rcond, w, iw,
465 $ info )
466 CALL chkxer( 'SSYCON_3', infot, nout, lerr, ok )
467 infot = 4
468 CALL ssycon_3( 'U', 2, a, 1, e, ip, anrm, rcond, w, iw,
469 $ info )
470 CALL chkxer( 'SSYCON_3', infot, nout, lerr, ok )
471 infot = 7
472 CALL ssycon_3( 'U', 1, a, 1, e, ip, -1.0e0, rcond, w, iw,
473 $ info)
474 CALL chkxer( 'SSYCON_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* SSYTRF_AA
482*
483 srnamt = 'SSYTRF_AA'
484 infot = 1
485 CALL ssytrf_aa( '/', 0, a, 1, ip, w, 1, info )
486 CALL chkxer( 'SSYTRF_AA', infot, nout, lerr, ok )
487 infot = 2
488 CALL ssytrf_aa( 'U', -1, a, 1, ip, w, 1, info )
489 CALL chkxer( 'SSYTRF_AA', infot, nout, lerr, ok )
490 infot = 4
491 CALL ssytrf_aa( 'U', 2, a, 1, ip, w, 4, info )
492 CALL chkxer( 'SSYTRF_AA', infot, nout, lerr, ok )
493 infot = 7
494 CALL ssytrf_aa( 'U', 0, a, 1, ip, w, 0, info )
495 CALL chkxer( 'SSYTRF_AA', infot, nout, lerr, ok )
496 infot = 7
497 CALL ssytrf_aa( 'U', 0, a, 1, ip, w, -2, info )
498 CALL chkxer( 'SSYTRF_AA', infot, nout, lerr, ok )
499*
500* SSYTRS_AA
501*
502 srnamt = 'SSYTRS_AA'
503 infot = 1
504 CALL ssytrs_aa( '/', 0, 0, a, 1, ip, b, 1, w, 1, info )
505 CALL chkxer( 'SSYTRS_AA', infot, nout, lerr, ok )
506 infot = 2
507 CALL ssytrs_aa( 'U', -1, 0, a, 1, ip, b, 1, w, 1, info )
508 CALL chkxer( 'SSYTRS_AA', infot, nout, lerr, ok )
509 infot = 3
510 CALL ssytrs_aa( 'U', 0, -1, a, 1, ip, b, 1, w, 1, info )
511 CALL chkxer( 'SSYTRS_AA', infot, nout, lerr, ok )
512 infot = 5
513 CALL ssytrs_aa( 'U', 2, 1, a, 1, ip, b, 2, w, 1, info )
514 CALL chkxer( 'SSYTRS_AA', infot, nout, lerr, ok )
515 infot = 8
516 CALL ssytrs_aa( 'U', 2, 1, a, 2, ip, b, 1, w, 1, info )
517 CALL chkxer( 'SSYTRS_AA', infot, nout, lerr, ok )
518 infot = 10
519 CALL ssytrs_aa( 'U', 0, 1, a, 2, ip, b, 1, w, 0, info )
520 CALL chkxer( 'SSYTRS_AA', infot, nout, lerr, ok )
521 infot = 10
522 CALL ssytrs_aa( 'U', 0, 1, a, 2, ip, b, 1, w, -2, info )
523 CALL chkxer( 'SSYTRS_AA', infot, nout, lerr, ok )
524 ELSE IF( lsamen( 2, c2, 'S2' ) ) THEN
525*
526* Test error exits of the routines that use factorization
527* of a symmetric indefinite matrix with Aasen's algorithm.
528*
529* SSYTRF_AA_2STAGE
530*
531 srnamt = 'SSYTRF_AA_2STAGE'
532 infot = 1
533 CALL ssytrf_aa_2stage( '/', 0, a, 1, a, 1, ip, ip, w, 1,
534 $ info )
535 CALL chkxer( 'SSYTRF_AA_2STAGE', infot, nout, lerr, ok )
536 infot = 2
537 CALL ssytrf_aa_2stage( 'U', -1, a, 1, a, 1, ip, ip, w, 1,
538 $ info )
539 CALL chkxer( 'SSYTRF_AA_2STAGE', infot, nout, lerr, ok )
540 infot = 4
541 CALL ssytrf_aa_2stage( 'U', 2, a, 1, a, 2, ip, ip, w, 1,
542 $ info )
543 CALL chkxer( 'SSYTRF_AA_2STAGE', infot, nout, lerr, ok )
544 infot = 6
545 CALL ssytrf_aa_2stage( 'U', 2, a, 2, a, 1, ip, ip, w, 1,
546 $ info )
547 CALL chkxer( 'SSYTRF_AA_2STAGE', infot, nout, lerr, ok )
548 infot = 10
549 CALL ssytrf_aa_2stage( 'U', 2, a, 2, a, 8, ip, ip, w, 0,
550 $ info )
551 CALL chkxer( 'SSYTRF_AA_2STAGE', infot, nout, lerr, ok )
552*
553* SSYTRS_AA_2STAGE
554*
555 srnamt = 'SSYTRS_AA_2STAGE'
556 infot = 1
557 CALL ssytrs_aa_2stage( '/', 0, 0, a, 1, a, 1, ip, ip,
558 $ b, 1, info )
559 CALL chkxer( 'SSYTRS_AA_2STAGE', infot, nout, lerr, ok )
560 infot = 2
561 CALL ssytrs_aa_2stage( 'U', -1, 0, a, 1, a, 1, ip, ip,
562 $ b, 1, info )
563 CALL chkxer( 'SSYTRS_AA_2STAGE', infot, nout, lerr, ok )
564 infot = 3
565 CALL ssytrs_aa_2stage( 'U', 0, -1, a, 1, a, 1, ip, ip,
566 $ b, 1, info )
567 CALL chkxer( 'SSYTRS_AA_2STAGE', infot, nout, lerr, ok )
568 infot = 5
569 CALL ssytrs_aa_2stage( 'U', 2, 1, a, 1, a, 1, ip, ip,
570 $ b, 1, info )
571 CALL chkxer( 'SSYTRS_AA_2STAGE', infot, nout, lerr, ok )
572 infot = 7
573 CALL ssytrs_aa_2stage( 'U', 2, 1, a, 2, a, 1, ip, ip,
574 $ b, 1, info )
575 CALL chkxer( 'SSYTRS_AA_2STAGE', infot, nout, lerr, ok )
576 infot = 11
577 CALL ssytrs_aa_2stage( 'U', 2, 1, a, 2, a, 8, ip, ip,
578 $ b, 1, info )
579 CALL chkxer( 'SSYTRS_AA_STAGE', infot, nout, lerr, ok )
580*
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* SSPTRF
588*
589 srnamt = 'SSPTRF'
590 infot = 1
591 CALL ssptrf( '/', 0, a, ip, info )
592 CALL chkxer( 'SSPTRF', infot, nout, lerr, ok )
593 infot = 2
594 CALL ssptrf( 'U', -1, a, ip, info )
595 CALL chkxer( 'SSPTRF', infot, nout, lerr, ok )
596*
597* SSPTRI
598*
599 srnamt = 'SSPTRI'
600 infot = 1
601 CALL ssptri( '/', 0, a, ip, w, info )
602 CALL chkxer( 'SSPTRI', infot, nout, lerr, ok )
603 infot = 2
604 CALL ssptri( 'U', -1, a, ip, w, info )
605 CALL chkxer( 'SSPTRI', infot, nout, lerr, ok )
606*
607* SSPTRS
608*
609 srnamt = 'SSPTRS'
610 infot = 1
611 CALL ssptrs( '/', 0, 0, a, ip, b, 1, info )
612 CALL chkxer( 'SSPTRS', infot, nout, lerr, ok )
613 infot = 2
614 CALL ssptrs( 'U', -1, 0, a, ip, b, 1, info )
615 CALL chkxer( 'SSPTRS', infot, nout, lerr, ok )
616 infot = 3
617 CALL ssptrs( 'U', 0, -1, a, ip, b, 1, info )
618 CALL chkxer( 'SSPTRS', infot, nout, lerr, ok )
619 infot = 7
620 CALL ssptrs( 'U', 2, 1, a, ip, b, 1, info )
621 CALL chkxer( 'SSPTRS', infot, nout, lerr, ok )
622*
623* SSPRFS
624*
625 srnamt = 'SSPRFS'
626 infot = 1
627 CALL ssprfs( '/', 0, 0, a, af, ip, b, 1, x, 1, r1, r2, w, iw,
628 $ info )
629 CALL chkxer( 'SSPRFS', infot, nout, lerr, ok )
630 infot = 2
631 CALL ssprfs( 'U', -1, 0, a, af, ip, b, 1, x, 1, r1, r2, w, iw,
632 $ info )
633 CALL chkxer( 'SSPRFS', infot, nout, lerr, ok )
634 infot = 3
635 CALL ssprfs( 'U', 0, -1, a, af, ip, b, 1, x, 1, r1, r2, w, iw,
636 $ info )
637 CALL chkxer( 'SSPRFS', infot, nout, lerr, ok )
638 infot = 8
639 CALL ssprfs( 'U', 2, 1, a, af, ip, b, 1, x, 2, r1, r2, w, iw,
640 $ info )
641 CALL chkxer( 'SSPRFS', infot, nout, lerr, ok )
642 infot = 10
643 CALL ssprfs( 'U', 2, 1, a, af, ip, b, 2, x, 1, r1, r2, w, iw,
644 $ info )
645 CALL chkxer( 'SSPRFS', infot, nout, lerr, ok )
646*
647* SSPCON
648*
649 srnamt = 'SSPCON'
650 infot = 1
651 CALL sspcon( '/', 0, a, ip, anrm, rcond, w, iw, info )
652 CALL chkxer( 'SSPCON', infot, nout, lerr, ok )
653 infot = 2
654 CALL sspcon( 'U', -1, a, ip, anrm, rcond, w, iw, info )
655 CALL chkxer( 'SSPCON', infot, nout, lerr, ok )
656 infot = 5
657 CALL sspcon( 'U', 1, a, ip, -1.0, rcond, w, iw, info )
658 CALL chkxer( 'SSPCON', 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 SERRSY
668*
ssytrs_aa
subroutine ssytrs_aa(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
SSYTRS_AA
Definition ssytrs_aa.f:131
ssytri
subroutine ssytri(uplo, n, a, lda, ipiv, work, info)
SSYTRI
Definition ssytri.f:114
ssytri2x
subroutine ssytri2x(uplo, n, a, lda, ipiv, work, nb, info)
SSYTRI2X
Definition ssytri2x.f:120
ssytf2_rook
subroutine ssytf2_rook(uplo, n, a, lda, ipiv, info)
SSYTF2_ROOK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-...
Definition ssytf2_rook.f:194
ssytrf_aa
subroutine ssytrf_aa(uplo, n, a, lda, ipiv, work, lwork, info)
SSYTRF_AA
Definition ssytrf_aa.f:132
ssytrf_aa_2stage
subroutine ssytrf_aa_2stage(uplo, n, a, lda, tb, ltb, ipiv, ipiv2, work, lwork, info)
SSYTRF_AA_2STAGE
Definition ssytrf_aa_2stage.f:160
ssytrs_aa_2stage
subroutine ssytrs_aa_2stage(uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, info)
SSYTRS_AA_2STAGE
Definition ssytrs_aa_2stage.f:139
ssytf2
subroutine ssytf2(uplo, n, a, lda, ipiv, info)
SSYTF2 computes the factorization of a real symmetric indefinite matrix, using the diagonal pivoting ...
Definition ssytf2.f:195
ssycon_3
subroutine ssycon_3(uplo, n, a, lda, e, ipiv, anorm, rcond, work, iwork, info)
SSYCON_3
Definition ssycon_3.f:171
ssytf2_rk
subroutine ssytf2_rk(uplo, n, a, lda, e, ipiv, info)
SSYTF2_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bunch-Ka...
Definition ssytf2_rk.f:241
ssytri_3x
subroutine ssytri_3x(uplo, n, a, lda, e, ipiv, work, nb, info)
SSYTRI_3X
Definition ssytri_3x.f:159
ssytrs_3
subroutine ssytrs_3(uplo, n, nrhs, a, lda, e, ipiv, b, ldb, info)
SSYTRS_3
Definition ssytrs_3.f:165

◆ serrtr()

subroutine serrtr ( character*3 path,
integer nunit )

SERRTR

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

◆ serrtz()

subroutine serrtz ( character*3 path,
integer nunit )

SERRTZ

Purpose:
!>
!> SERRTZ 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 serrtz.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 REAL 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, stzrzf
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.e+0
99 a( 1, 2 ) = 2.e+0
100 a( 2, 2 ) = 3.e+0
101 a( 2, 1 ) = 4.e+0
102 w( 1 ) = 0.0e+0
103 w( 2 ) = 0.0e+0
104 ok = .true.
105*
106 IF( lsamen( 2, c2, 'TZ' ) ) THEN
107*
108* Test error exits for the trapezoidal routines.
109*
110* STZRZF
111*
112 srnamt = 'STZRZF'
113 infot = 1
114 CALL stzrzf( -1, 0, a, 1, tau, w, 1, info )
115 CALL chkxer( 'STZRZF', infot, nout, lerr, ok )
116 infot = 2
117 CALL stzrzf( 1, 0, a, 1, tau, w, 1, info )
118 CALL chkxer( 'STZRZF', infot, nout, lerr, ok )
119 infot = 4
120 CALL stzrzf( 2, 2, a, 1, tau, w, 1, info )
121 CALL chkxer( 'STZRZF', infot, nout, lerr, ok )
122 infot = 7
123 CALL stzrzf( 2, 2, a, 2, tau, w, 0, info )
124 CALL chkxer( 'STZRZF', infot, nout, lerr, ok )
125 infot = 7
126 CALL stzrzf( 2, 3, a, 2, tau, w, 1, info )
127 CALL chkxer( 'STZRZF', 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 SERRTZ
137*

◆ serrvx()

subroutine serrvx ( character*3 path,
integer nunit )

SERRVX

SERRVXX

Purpose:
!>
!> SERRVX tests the error exits for the REAL 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 serrvx.f.

55*
56* -- LAPACK test routine --
57* -- LAPACK is a software package provided by Univ. of Tennessee, --
58* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
59*
60* .. Scalar Arguments ..
61 CHARACTER*3 PATH
62 INTEGER NUNIT
63* ..
64*
65* =====================================================================
66*
67* .. Parameters ..
68 INTEGER NMAX
69 parameter( nmax = 4 )
70* ..
71* .. Local Scalars ..
72 CHARACTER EQ
73 CHARACTER*2 C2
74 INTEGER I, INFO, J
75 REAL RCOND
76* ..
77* .. Local Arrays ..
78 INTEGER IP( NMAX ), IW( NMAX )
79 REAL 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, sgbsv, sgbsvx, sgesv, sgesvx, sgtsv,
89 $ sgtsvx, spbsv, spbsvx, sposv, sposvx, sppsv,
90 $ sppsvx, sptsv, sptsvx, sspsv, sspsvx, ssysv,
91 $ ssysv_aa, ssysv_rk, ssysv_rook, ssysvx,
92 $ ssysv_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 real
105* ..
106* .. Executable Statements ..
107*
108 nout = nunit
109 WRITE( nout, fmt = * )
110 c2 = path( 2: 3 )
111*
112* Set the variables to innocuous values.
113*
114 DO 20 j = 1, nmax
115 DO 10 i = 1, nmax
116 a( i, j ) = 1. / real( i+j )
117 af( i, j ) = 1. / real( i+j )
118 10 CONTINUE
119 b( j ) = 0.e+0
120 e( j ) = 0.e+0
121 r1( j ) = 0.e+0
122 r2( j ) = 0.e+0
123 w( j ) = 0.e+0
124 x( j ) = 0.e+0
125 c( j ) = 0.e+0
126 r( j ) = 0.e+0
127 ip( j ) = j
128 20 CONTINUE
129 eq = ' '
130 ok = .true.
131*
132 IF( lsamen( 2, c2, 'GE' ) ) THEN
133*
134* SGESV
135*
136 srnamt = 'SGESV '
137 infot = 1
138 CALL sgesv( -1, 0, a, 1, ip, b, 1, info )
139 CALL chkxer( 'SGESV ', infot, nout, lerr, ok )
140 infot = 2
141 CALL sgesv( 0, -1, a, 1, ip, b, 1, info )
142 CALL chkxer( 'SGESV ', infot, nout, lerr, ok )
143 infot = 4
144 CALL sgesv( 2, 1, a, 1, ip, b, 2, info )
145 CALL chkxer( 'SGESV ', infot, nout, lerr, ok )
146 infot = 7
147 CALL sgesv( 2, 1, a, 2, ip, b, 1, info )
148 CALL chkxer( 'SGESV ', infot, nout, lerr, ok )
149*
150* SGESVX
151*
152 srnamt = 'SGESVX'
153 infot = 1
154 CALL sgesvx( '/', '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( 'SGESVX', infot, nout, lerr, ok )
157 infot = 2
158 CALL sgesvx( '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( 'SGESVX', infot, nout, lerr, ok )
161 infot = 3
162 CALL sgesvx( '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( 'SGESVX', infot, nout, lerr, ok )
165 infot = 4
166 CALL sgesvx( '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( 'SGESVX', infot, nout, lerr, ok )
169 infot = 6
170 CALL sgesvx( '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( 'SGESVX', infot, nout, lerr, ok )
173 infot = 8
174 CALL sgesvx( '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( 'SGESVX', infot, nout, lerr, ok )
177 infot = 10
178 eq = '/'
179 CALL sgesvx( '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( 'SGESVX', infot, nout, lerr, ok )
182 infot = 11
183 eq = 'R'
184 CALL sgesvx( '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( 'SGESVX', infot, nout, lerr, ok )
187 infot = 12
188 eq = 'C'
189 CALL sgesvx( '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( 'SGESVX', infot, nout, lerr, ok )
192 infot = 14
193 CALL sgesvx( '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( 'SGESVX', infot, nout, lerr, ok )
196 infot = 16
197 CALL sgesvx( '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( 'SGESVX', infot, nout, lerr, ok )
200*
201 ELSE IF( lsamen( 2, c2, 'GB' ) ) THEN
202*
203* SGBSV
204*
205 srnamt = 'SGBSV '
206 infot = 1
207 CALL sgbsv( -1, 0, 0, 0, a, 1, ip, b, 1, info )
208 CALL chkxer( 'SGBSV ', infot, nout, lerr, ok )
209 infot = 2
210 CALL sgbsv( 1, -1, 0, 0, a, 1, ip, b, 1, info )
211 CALL chkxer( 'SGBSV ', infot, nout, lerr, ok )
212 infot = 3
213 CALL sgbsv( 1, 0, -1, 0, a, 1, ip, b, 1, info )
214 CALL chkxer( 'SGBSV ', infot, nout, lerr, ok )
215 infot = 4
216 CALL sgbsv( 0, 0, 0, -1, a, 1, ip, b, 1, info )
217 CALL chkxer( 'SGBSV ', infot, nout, lerr, ok )
218 infot = 6
219 CALL sgbsv( 1, 1, 1, 0, a, 3, ip, b, 1, info )
220 CALL chkxer( 'SGBSV ', infot, nout, lerr, ok )
221 infot = 9
222 CALL sgbsv( 2, 0, 0, 0, a, 1, ip, b, 1, info )
223 CALL chkxer( 'SGBSV ', infot, nout, lerr, ok )
224*
225* SGBSVX
226*
227 srnamt = 'SGBSVX'
228 infot = 1
229 CALL sgbsvx( '/', '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( 'SGBSVX', infot, nout, lerr, ok )
232 infot = 2
233 CALL sgbsvx( '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( 'SGBSVX', infot, nout, lerr, ok )
236 infot = 3
237 CALL sgbsvx( '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( 'SGBSVX', infot, nout, lerr, ok )
240 infot = 4
241 CALL sgbsvx( '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( 'SGBSVX', infot, nout, lerr, ok )
244 infot = 5
245 CALL sgbsvx( '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( 'SGBSVX', infot, nout, lerr, ok )
248 infot = 6
249 CALL sgbsvx( '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( 'SGBSVX', infot, nout, lerr, ok )
252 infot = 8
253 CALL sgbsvx( '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( 'SGBSVX', infot, nout, lerr, ok )
256 infot = 10
257 CALL sgbsvx( '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( 'SGBSVX', infot, nout, lerr, ok )
260 infot = 12
261 eq = '/'
262 CALL sgbsvx( '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( 'SGBSVX', infot, nout, lerr, ok )
265 infot = 13
266 eq = 'R'
267 CALL sgbsvx( '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( 'SGBSVX', infot, nout, lerr, ok )
270 infot = 14
271 eq = 'C'
272 CALL sgbsvx( '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( 'SGBSVX', infot, nout, lerr, ok )
275 infot = 16
276 CALL sgbsvx( '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( 'SGBSVX', infot, nout, lerr, ok )
279 infot = 18
280 CALL sgbsvx( '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( 'SGBSVX', infot, nout, lerr, ok )
283*
284 ELSE IF( lsamen( 2, c2, 'GT' ) ) THEN
285*
286* SGTSV
287*
288 srnamt = 'SGTSV '
289 infot = 1
290 CALL sgtsv( -1, 0, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ), b, 1,
291 $ info )
292 CALL chkxer( 'SGTSV ', infot, nout, lerr, ok )
293 infot = 2
294 CALL sgtsv( 0, -1, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ), b, 1,
295 $ info )
296 CALL chkxer( 'SGTSV ', infot, nout, lerr, ok )
297 infot = 7
298 CALL sgtsv( 2, 0, a( 1, 1 ), a( 1, 2 ), a( 1, 3 ), b, 1, info )
299 CALL chkxer( 'SGTSV ', infot, nout, lerr, ok )
300*
301* SGTSVX
302*
303 srnamt = 'SGTSVX'
304 infot = 1
305 CALL sgtsvx( '/', '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( 'SGTSVX', infot, nout, lerr, ok )
309 infot = 2
310 CALL sgtsvx( '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( 'SGTSVX', infot, nout, lerr, ok )
314 infot = 3
315 CALL sgtsvx( '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( 'SGTSVX', infot, nout, lerr, ok )
319 infot = 4
320 CALL sgtsvx( '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( 'SGTSVX', infot, nout, lerr, ok )
324 infot = 14
325 CALL sgtsvx( '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( 'SGTSVX', infot, nout, lerr, ok )
329 infot = 16
330 CALL sgtsvx( '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( 'SGTSVX', infot, nout, lerr, ok )
334*
335 ELSE IF( lsamen( 2, c2, 'PO' ) ) THEN
336*
337* SPOSV
338*
339 srnamt = 'SPOSV '
340 infot = 1
341 CALL sposv( '/', 0, 0, a, 1, b, 1, info )
342 CALL chkxer( 'SPOSV ', infot, nout, lerr, ok )
343 infot = 2
344 CALL sposv( 'U', -1, 0, a, 1, b, 1, info )
345 CALL chkxer( 'SPOSV ', infot, nout, lerr, ok )
346 infot = 3
347 CALL sposv( 'U', 0, -1, a, 1, b, 1, info )
348 CALL chkxer( 'SPOSV ', infot, nout, lerr, ok )
349 infot = 5
350 CALL sposv( 'U', 2, 0, a, 1, b, 2, info )
351 CALL chkxer( 'SPOSV ', infot, nout, lerr, ok )
352 infot = 7
353 CALL sposv( 'U', 2, 0, a, 2, b, 1, info )
354 CALL chkxer( 'SPOSV ', infot, nout, lerr, ok )
355*
356* SPOSVX
357*
358 srnamt = 'SPOSVX'
359 infot = 1
360 CALL sposvx( '/', 'U', 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
361 $ rcond, r1, r2, w, iw, info )
362 CALL chkxer( 'SPOSVX', infot, nout, lerr, ok )
363 infot = 2
364 CALL sposvx( 'N', '/', 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
365 $ rcond, r1, r2, w, iw, info )
366 CALL chkxer( 'SPOSVX', infot, nout, lerr, ok )
367 infot = 3
368 CALL sposvx( 'N', 'U', -1, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
369 $ rcond, r1, r2, w, iw, info )
370 CALL chkxer( 'SPOSVX', infot, nout, lerr, ok )
371 infot = 4
372 CALL sposvx( 'N', 'U', 0, -1, a, 1, af, 1, eq, c, b, 1, x, 1,
373 $ rcond, r1, r2, w, iw, info )
374 CALL chkxer( 'SPOSVX', infot, nout, lerr, ok )
375 infot = 6
376 CALL sposvx( 'N', 'U', 2, 0, a, 1, af, 2, eq, c, b, 2, x, 2,
377 $ rcond, r1, r2, w, iw, info )
378 CALL chkxer( 'SPOSVX', infot, nout, lerr, ok )
379 infot = 8
380 CALL sposvx( 'N', 'U', 2, 0, a, 2, af, 1, eq, c, b, 2, x, 2,
381 $ rcond, r1, r2, w, iw, info )
382 CALL chkxer( 'SPOSVX', infot, nout, lerr, ok )
383 infot = 9
384 eq = '/'
385 CALL sposvx( 'F', 'U', 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
386 $ rcond, r1, r2, w, iw, info )
387 CALL chkxer( 'SPOSVX', infot, nout, lerr, ok )
388 infot = 10
389 eq = 'Y'
390 CALL sposvx( 'F', 'U', 1, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
391 $ rcond, r1, r2, w, iw, info )
392 CALL chkxer( 'SPOSVX', infot, nout, lerr, ok )
393 infot = 12
394 CALL sposvx( 'N', 'U', 2, 0, a, 2, af, 2, eq, c, b, 1, x, 2,
395 $ rcond, r1, r2, w, iw, info )
396 CALL chkxer( 'SPOSVX', infot, nout, lerr, ok )
397 infot = 14
398 CALL sposvx( 'N', 'U', 2, 0, a, 2, af, 2, eq, c, b, 2, x, 1,
399 $ rcond, r1, r2, w, iw, info )
400 CALL chkxer( 'SPOSVX', infot, nout, lerr, ok )
401*
402 ELSE IF( lsamen( 2, c2, 'PP' ) ) THEN
403*
404* SPPSV
405*
406 srnamt = 'SPPSV '
407 infot = 1
408 CALL sppsv( '/', 0, 0, a, b, 1, info )
409 CALL chkxer( 'SPPSV ', infot, nout, lerr, ok )
410 infot = 2
411 CALL sppsv( 'U', -1, 0, a, b, 1, info )
412 CALL chkxer( 'SPPSV ', infot, nout, lerr, ok )
413 infot = 3
414 CALL sppsv( 'U', 0, -1, a, b, 1, info )
415 CALL chkxer( 'SPPSV ', infot, nout, lerr, ok )
416 infot = 6
417 CALL sppsv( 'U', 2, 0, a, b, 1, info )
418 CALL chkxer( 'SPPSV ', infot, nout, lerr, ok )
419*
420* SPPSVX
421*
422 srnamt = 'SPPSVX'
423 infot = 1
424 CALL sppsvx( '/', 'U', 0, 0, a, af, eq, c, b, 1, x, 1, rcond,
425 $ r1, r2, w, iw, info )
426 CALL chkxer( 'SPPSVX', infot, nout, lerr, ok )
427 infot = 2
428 CALL sppsvx( 'N', '/', 0, 0, a, af, eq, c, b, 1, x, 1, rcond,
429 $ r1, r2, w, iw, info )
430 CALL chkxer( 'SPPSVX', infot, nout, lerr, ok )
431 infot = 3
432 CALL sppsvx( 'N', 'U', -1, 0, a, af, eq, c, b, 1, x, 1, rcond,
433 $ r1, r2, w, iw, info )
434 CALL chkxer( 'SPPSVX', infot, nout, lerr, ok )
435 infot = 4
436 CALL sppsvx( 'N', 'U', 0, -1, a, af, eq, c, b, 1, x, 1, rcond,
437 $ r1, r2, w, iw, info )
438 CALL chkxer( 'SPPSVX', infot, nout, lerr, ok )
439 infot = 7
440 eq = '/'
441 CALL sppsvx( 'F', 'U', 0, 0, a, af, eq, c, b, 1, x, 1, rcond,
442 $ r1, r2, w, iw, info )
443 CALL chkxer( 'SPPSVX', infot, nout, lerr, ok )
444 infot = 8
445 eq = 'Y'
446 CALL sppsvx( 'F', 'U', 1, 0, a, af, eq, c, b, 1, x, 1, rcond,
447 $ r1, r2, w, iw, info )
448 CALL chkxer( 'SPPSVX', infot, nout, lerr, ok )
449 infot = 10
450 CALL sppsvx( 'N', 'U', 2, 0, a, af, eq, c, b, 1, x, 2, rcond,
451 $ r1, r2, w, iw, info )
452 CALL chkxer( 'SPPSVX', infot, nout, lerr, ok )
453 infot = 12
454 CALL sppsvx( 'N', 'U', 2, 0, a, af, eq, c, b, 2, x, 1, rcond,
455 $ r1, r2, w, iw, info )
456 CALL chkxer( 'SPPSVX', infot, nout, lerr, ok )
457*
458 ELSE IF( lsamen( 2, c2, 'PB' ) ) THEN
459*
460* SPBSV
461*
462 srnamt = 'SPBSV '
463 infot = 1
464 CALL spbsv( '/', 0, 0, 0, a, 1, b, 1, info )
465 CALL chkxer( 'SPBSV ', infot, nout, lerr, ok )
466 infot = 2
467 CALL spbsv( 'U', -1, 0, 0, a, 1, b, 1, info )
468 CALL chkxer( 'SPBSV ', infot, nout, lerr, ok )
469 infot = 3
470 CALL spbsv( 'U', 1, -1, 0, a, 1, b, 1, info )
471 CALL chkxer( 'SPBSV ', infot, nout, lerr, ok )
472 infot = 4
473 CALL spbsv( 'U', 0, 0, -1, a, 1, b, 1, info )
474 CALL chkxer( 'SPBSV ', infot, nout, lerr, ok )
475 infot = 6
476 CALL spbsv( 'U', 1, 1, 0, a, 1, b, 2, info )
477 CALL chkxer( 'SPBSV ', infot, nout, lerr, ok )
478 infot = 8
479 CALL spbsv( 'U', 2, 0, 0, a, 1, b, 1, info )
480 CALL chkxer( 'SPBSV ', infot, nout, lerr, ok )
481*
482* SPBSVX
483*
484 srnamt = 'SPBSVX'
485 infot = 1
486 CALL spbsvx( '/', 'U', 0, 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
487 $ rcond, r1, r2, w, iw, info )
488 CALL chkxer( 'SPBSVX', infot, nout, lerr, ok )
489 infot = 2
490 CALL spbsvx( 'N', '/', 0, 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
491 $ rcond, r1, r2, w, iw, info )
492 CALL chkxer( 'SPBSVX', infot, nout, lerr, ok )
493 infot = 3
494 CALL spbsvx( '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( 'SPBSVX', infot, nout, lerr, ok )
497 infot = 4
498 CALL spbsvx( '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( 'SPBSVX', infot, nout, lerr, ok )
501 infot = 5
502 CALL spbsvx( '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( 'SPBSVX', infot, nout, lerr, ok )
505 infot = 7
506 CALL spbsvx( '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( 'SPBSVX', infot, nout, lerr, ok )
509 infot = 9
510 CALL spbsvx( '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( 'SPBSVX', infot, nout, lerr, ok )
513 infot = 10
514 eq = '/'
515 CALL spbsvx( '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( 'SPBSVX', infot, nout, lerr, ok )
518 infot = 11
519 eq = 'Y'
520 CALL spbsvx( '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( 'SPBSVX', infot, nout, lerr, ok )
523 infot = 13
524 CALL spbsvx( '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( 'SPBSVX', infot, nout, lerr, ok )
527 infot = 15
528 CALL spbsvx( '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( 'SPBSVX', infot, nout, lerr, ok )
531*
532 ELSE IF( lsamen( 2, c2, 'PT' ) ) THEN
533*
534* SPTSV
535*
536 srnamt = 'SPTSV '
537 infot = 1
538 CALL sptsv( -1, 0, a( 1, 1 ), a( 1, 2 ), b, 1, info )
539 CALL chkxer( 'SPTSV ', infot, nout, lerr, ok )
540 infot = 2
541 CALL sptsv( 0, -1, a( 1, 1 ), a( 1, 2 ), b, 1, info )
542 CALL chkxer( 'SPTSV ', infot, nout, lerr, ok )
543 infot = 6
544 CALL sptsv( 2, 0, a( 1, 1 ), a( 1, 2 ), b, 1, info )
545 CALL chkxer( 'SPTSV ', infot, nout, lerr, ok )
546*
547* SPTSVX
548*
549 srnamt = 'SPTSVX'
550 infot = 1
551 CALL sptsvx( '/', 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( 'SPTSVX', infot, nout, lerr, ok )
554 infot = 2
555 CALL sptsvx( '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( 'SPTSVX', infot, nout, lerr, ok )
558 infot = 3
559 CALL sptsvx( '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( 'SPTSVX', infot, nout, lerr, ok )
562 infot = 9
563 CALL sptsvx( '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( 'SPTSVX', infot, nout, lerr, ok )
566 infot = 11
567 CALL sptsvx( '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( 'SPTSVX', infot, nout, lerr, ok )
570*
571 ELSE IF( lsamen( 2, c2, 'SY' ) ) THEN
572*
573* SSYSV
574*
575 srnamt = 'SSYSV '
576 infot = 1
577 CALL ssysv( '/', 0, 0, a, 1, ip, b, 1, w, 1, info )
578 CALL chkxer( 'SSYSV ', infot, nout, lerr, ok )
579 infot = 2
580 CALL ssysv( 'U', -1, 0, a, 1, ip, b, 1, w, 1, info )
581 CALL chkxer( 'SSYSV ', infot, nout, lerr, ok )
582 infot = 3
583 CALL ssysv( 'U', 0, -1, a, 1, ip, b, 1, w, 1, info )
584 CALL chkxer( 'SSYSV ', infot, nout, lerr, ok )
585 infot = 8
586 CALL ssysv( 'U', 2, 0, a, 2, ip, b, 1, w, 1, info )
587 CALL chkxer( 'SSYSV ', infot, nout, lerr, ok )
588 infot = 10
589 CALL ssysv( 'U', 0, 0, a, 1, ip, b, 1, w, 0, info )
590 CALL chkxer( 'SSYSV ', infot, nout, lerr, ok )
591 infot = 10
592 CALL ssysv( 'U', 0, 0, a, 1, ip, b, 1, w, -2, info )
593 CALL chkxer( 'SSYSV ', infot, nout, lerr, ok )
594*
595* SSYSVX
596*
597 srnamt = 'SSYSVX'
598 infot = 1
599 CALL ssysvx( '/', 'U', 0, 0, a, 1, af, 1, ip, b, 1, x, 1,
600 $ rcond, r1, r2, w, 1, iw, info )
601 CALL chkxer( 'SSYSVX', infot, nout, lerr, ok )
602 infot = 2
603 CALL ssysvx( 'N', '/', 0, 0, a, 1, af, 1, ip, b, 1, x, 1,
604 $ rcond, r1, r2, w, 1, iw, info )
605 CALL chkxer( 'SSYSVX', infot, nout, lerr, ok )
606 infot = 3
607 CALL ssysvx( 'N', 'U', -1, 0, a, 1, af, 1, ip, b, 1, x, 1,
608 $ rcond, r1, r2, w, 1, iw, info )
609 CALL chkxer( 'SSYSVX', infot, nout, lerr, ok )
610 infot = 4
611 CALL ssysvx( 'N', 'U', 0, -1, a, 1, af, 1, ip, b, 1, x, 1,
612 $ rcond, r1, r2, w, 1, iw, info )
613 CALL chkxer( 'SSYSVX', infot, nout, lerr, ok )
614 infot = 6
615 CALL ssysvx( 'N', 'U', 2, 0, a, 1, af, 2, ip, b, 2, x, 2,
616 $ rcond, r1, r2, w, 4, iw, info )
617 CALL chkxer( 'SSYSVX', infot, nout, lerr, ok )
618 infot = 8
619 CALL ssysvx( 'N', 'U', 2, 0, a, 2, af, 1, ip, b, 2, x, 2,
620 $ rcond, r1, r2, w, 4, iw, info )
621 CALL chkxer( 'SSYSVX', infot, nout, lerr, ok )
622 infot = 11
623 CALL ssysvx( 'N', 'U', 2, 0, a, 2, af, 2, ip, b, 1, x, 2,
624 $ rcond, r1, r2, w, 4, iw, info )
625 CALL chkxer( 'SSYSVX', infot, nout, lerr, ok )
626 infot = 13
627 CALL ssysvx( 'N', 'U', 2, 0, a, 2, af, 2, ip, b, 2, x, 1,
628 $ rcond, r1, r2, w, 4, iw, info )
629 CALL chkxer( 'SSYSVX', infot, nout, lerr, ok )
630 infot = 18
631 CALL ssysvx( 'N', 'U', 2, 0, a, 2, af, 2, ip, b, 2, x, 2,
632 $ rcond, r1, r2, w, 3, iw, info )
633 CALL chkxer( 'SSYSVX', infot, nout, lerr, ok )
634*
635*
636 ELSE IF( lsamen( 2, c2, 'SR' ) ) THEN
637*
638* SSYSV_ROOK
639*
640 srnamt = 'SSYSV_ROOK'
641 infot = 1
642 CALL ssysv_rook( '/', 0, 0, a, 1, ip, b, 1, w, 1, info )
643 CALL chkxer( 'SSYSV_ROOK', infot, nout, lerr, ok )
644 infot = 2
645 CALL ssysv_rook( 'U', -1, 0, a, 1, ip, b, 1, w, 1, info )
646 CALL chkxer( 'SSYSV_ROOK', infot, nout, lerr, ok )
647 infot = 3
648 CALL ssysv_rook( 'U', 0, -1, a, 1, ip, b, 1, w, 1, info )
649 CALL chkxer( 'SSYSV_ROOK', infot, nout, lerr, ok )
650 infot = 8
651 CALL ssysv_rook( 'U', 2, 0, a, 2, ip, b, 1, w, 1, info )
652 CALL chkxer( 'SSYSV_ROOK', infot, nout, lerr, ok )
653 infot = 10
654 CALL ssysv_rook( 'U', 0, 0, a, 1, ip, b, 1, w, 0, info )
655 CALL chkxer( 'SSYSV_ROOK', infot, nout, lerr, ok )
656 infot = 10
657 CALL ssysv_rook( 'U', 0, 0, a, 1, ip, b, 1, w, -2, info )
658 CALL chkxer( 'SSYSV_ROOK', infot, nout, lerr, ok )
659*
660 ELSE IF( lsamen( 2, c2, 'SK' ) ) THEN
661*
662* SSYSV_RK
663*
664* Test error exits of the driver that uses factorization
665* of a symmetric indefinite matrix with rook
666* (bounded Bunch-Kaufman) pivoting with the new storage
667* format for factors L ( or U) and D.
668*
669* L (or U) is stored in A, diagonal of D is stored on the
670* diagonal of A, subdiagonal of D is stored in a separate array E.
671*
672 srnamt = 'SSYSV_RK'
673 infot = 1
674 CALL ssysv_rk( '/', 0, 0, a, 1, e, ip, b, 1, w, 1, info )
675 CALL chkxer( 'SSYSV_RK', infot, nout, lerr, ok )
676 infot = 2
677 CALL ssysv_rk( 'U', -1, 0, a, 1, e, ip, b, 1, w, 1, info )
678 CALL chkxer( 'SSYSV_RK', infot, nout, lerr, ok )
679 infot = 3
680 CALL ssysv_rk( 'U', 0, -1, a, 1, e, ip, b, 1, w, 1, info )
681 CALL chkxer( 'SSYSV_RK', infot, nout, lerr, ok )
682 infot = 5
683 CALL ssysv_rk( 'U', 2, 0, a, 1, e, ip, b, 2, w, 1, info )
684 CALL chkxer( 'SSYSV_RK', infot, nout, lerr, ok )
685 infot = 9
686 CALL ssysv_rk( 'U', 2, 0, a, 2, e, ip, b, 1, w, 1, info )
687 CALL chkxer( 'SSYSV_RK', infot, nout, lerr, ok )
688 infot = 11
689 CALL ssysv_rk( 'U', 0, 0, a, 1, e, ip, b, 1, w, 0, info )
690 CALL chkxer( 'SSYSV_RK', infot, nout, lerr, ok )
691 infot = 11
692 CALL ssysv_rk( 'U', 0, 0, a, 1, e, ip, b, 1, w, -2, info )
693 CALL chkxer( 'SSYSV_RK', infot, nout, lerr, ok )
694*
695 ELSE IF( lsamen( 2, c2, 'SA' ) ) THEN
696*
697* SSYSV_AA
698*
699 srnamt = 'SSYSV_AA'
700 infot = 1
701 CALL ssysv_aa( '/', 0, 0, a, 1, ip, b, 1, w, 1, info )
702 CALL chkxer( 'SSYSV_AA', infot, nout, lerr, ok )
703 infot = 2
704 CALL ssysv_aa( 'U', -1, 0, a, 1, ip, b, 1, w, 1, info )
705 CALL chkxer( 'SSYSV_AA', infot, nout, lerr, ok )
706 infot = 3
707 CALL ssysv_aa( 'U', 0, -1, a, 1, ip, b, 1, w, 1, info )
708 CALL chkxer( 'SSYSV_AA', infot, nout, lerr, ok )
709 infot = 8
710 CALL ssysv_aa( 'U', 2, 0, a, 2, ip, b, 1, w, 1, info )
711 CALL chkxer( 'SSYSV_AA', infot, nout, lerr, ok )
712*
713 ELSE IF( lsamen( 2, c2, 'S2' ) ) THEN
714*
715* DSYSV_AASEN_2STAGE
716*
717 srnamt = 'SSYSV_AA_2STAGE'
718 infot = 1
719 CALL ssysv_aa_2stage( '/', 0, 0, a, 1, a, 1, ip, ip, b, 1,
720 $ w, 1, info )
721 CALL chkxer( 'SSYSV_AA_2STAGE', infot, nout, lerr, ok )
722 infot = 2
723 CALL ssysv_aa_2stage( 'U', -1, 0, a, 1, a, 1, ip, ip, b, 1,
724 $ w, 1, info )
725 CALL chkxer( 'SSYSV_AA_2STAGE', infot, nout, lerr, ok )
726 infot = 3
727 CALL ssysv_aa_2stage( 'U', 0, -1, a, 1, a, 1, ip, ip, b, 1,
728 $ w, 1, info )
729 CALL chkxer( 'SSYSV_AA_2STAGE', infot, nout, lerr, ok )
730 infot = 5
731 CALL ssysv_aa_2stage( 'U', 2, 1, a, 1, a, 1, ip, ip, b, 1,
732 $ w, 1, info )
733 CALL chkxer( 'SSYSV_AA_2STAGE', infot, nout, lerr, ok )
734 infot = 11
735 CALL ssysv_aa_2stage( 'U', 2, 1, a, 2, a, 8, ip, ip, b, 1,
736 $ w, 1, info )
737 CALL chkxer( 'SSYSV_AA_2STAGE', infot, nout, lerr, ok )
738 infot = 7
739 CALL ssysv_aa_2stage( 'U', 2, 1, a, 2, a, 1, ip, ip, b, 2,
740 $ w, 1, info )
741 CALL chkxer( 'SSYSV_AA_2STAGE', infot, nout, lerr, ok )
742*
743 ELSE IF( lsamen( 2, c2, 'SP' ) ) THEN
744*
745* SSPSV
746*
747 srnamt = 'SSPSV '
748 infot = 1
749 CALL sspsv( '/', 0, 0, a, ip, b, 1, info )
750 CALL chkxer( 'SSPSV ', infot, nout, lerr, ok )
751 infot = 2
752 CALL sspsv( 'U', -1, 0, a, ip, b, 1, info )
753 CALL chkxer( 'SSPSV ', infot, nout, lerr, ok )
754 infot = 3
755 CALL sspsv( 'U', 0, -1, a, ip, b, 1, info )
756 CALL chkxer( 'SSPSV ', infot, nout, lerr, ok )
757 infot = 7
758 CALL sspsv( 'U', 2, 0, a, ip, b, 1, info )
759 CALL chkxer( 'SSPSV ', infot, nout, lerr, ok )
760*
761* SSPSVX
762*
763 srnamt = 'SSPSVX'
764 infot = 1
765 CALL sspsvx( '/', 'U', 0, 0, a, af, ip, b, 1, x, 1, rcond, r1,
766 $ r2, w, iw, info )
767 CALL chkxer( 'SSPSVX', infot, nout, lerr, ok )
768 infot = 2
769 CALL sspsvx( 'N', '/', 0, 0, a, af, ip, b, 1, x, 1, rcond, r1,
770 $ r2, w, iw, info )
771 CALL chkxer( 'SSPSVX', infot, nout, lerr, ok )
772 infot = 3
773 CALL sspsvx( 'N', 'U', -1, 0, a, af, ip, b, 1, x, 1, rcond, r1,
774 $ r2, w, iw, info )
775 CALL chkxer( 'SSPSVX', infot, nout, lerr, ok )
776 infot = 4
777 CALL sspsvx( 'N', 'U', 0, -1, a, af, ip, b, 1, x, 1, rcond, r1,
778 $ r2, w, iw, info )
779 CALL chkxer( 'SSPSVX', infot, nout, lerr, ok )
780 infot = 9
781 CALL sspsvx( 'N', 'U', 2, 0, a, af, ip, b, 1, x, 2, rcond, r1,
782 $ r2, w, iw, info )
783 CALL chkxer( 'SSPSVX', infot, nout, lerr, ok )
784 infot = 11
785 CALL sspsvx( 'N', 'U', 2, 0, a, af, ip, b, 2, x, 1, rcond, r1,
786 $ r2, w, iw, info )
787 CALL chkxer( 'SSPSVX', infot, nout, lerr, ok )
788 END IF
789*
790* Print a summary line.
791*
792 IF( ok ) THEN
793 WRITE( nout, fmt = 9999 )path
794 ELSE
795 WRITE( nout, fmt = 9998 )path
796 END IF
797*
798 9999 FORMAT( 1x, a3, ' drivers passed the tests of the error exits' )
799 9998 FORMAT( ' *** ', a3, ' drivers failed the tests of the error ',
800 $ 'exits ***' )
801*
802 RETURN
803*
804* End of SERRVX
805*
ssysv_aa_2stage
subroutine ssysv_aa_2stage(uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, work, lwork, info)
SSYSV_AA_2STAGE computes the solution to system of linear equations A * X = B for SY matrices
Definition ssysv_aa_2stage.f:187
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
ssysv_aa
subroutine ssysv_aa(uplo, n, nrhs, a, lda, ipiv, b, ldb, work, lwork, info)
SSYSV_AA computes the solution to system of linear equations A * X = B for SY matrices
Definition ssysv_aa.f:162

◆ sgbt01()

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

SGBT01

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

Definition at line 124 of file sgbt01.f.

126*
127* -- LAPACK test routine --
128* -- LAPACK is a software package provided by Univ. of Tennessee, --
129* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
130*
131* .. Scalar Arguments ..
132 INTEGER KL, KU, LDA, LDAFAC, M, N
133 REAL RESID
134* ..
135* .. Array Arguments ..
136 INTEGER IPIV( * )
137 REAL A( LDA, * ), AFAC( LDAFAC, * ), WORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ZERO, ONE
144 parameter( zero = 0.0e+0, one = 1.0e+0 )
145* ..
146* .. Local Scalars ..
147 INTEGER I, I1, I2, IL, IP, IW, J, JL, JU, JUA, KD, LENJ
148 REAL ANORM, EPS, T
149* ..
150* .. External Functions ..
151 REAL SASUM, SLAMCH
152 EXTERNAL sasum, slamch
153* ..
154* .. External Subroutines ..
155 EXTERNAL saxpy, scopy
156* ..
157* .. Intrinsic Functions ..
158 INTRINSIC max, min, real
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 = slamch( '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, sasum( 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 scopy( 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 saxpy( 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 saxpy( 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, sasum( 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 / real( n ) ) / anorm ) / eps
235 END IF
236*
237 RETURN
238*
239* End of SGBT01
240*

◆ sgbt02()

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

SGBT02

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

Definition at line 147 of file sgbt02.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 REAL RESID
158* ..
159* .. Array Arguments ..
160 REAL A( LDA, * ), B( LDB, * ), X( LDX, * ),
161 $ RWORK( * )
162* ..
163*
164* =====================================================================
165*
166* .. Parameters ..
167 REAL ZERO, ONE
168 parameter( zero = 0.0e+0, one = 1.0e+0 )
169* ..
170* .. Local Scalars ..
171 INTEGER I1, I2, J, KD, N1
172 REAL ANORM, BNORM, EPS, TEMP, XNORM
173* ..
174* .. External Functions ..
175 LOGICAL LSAME, SISNAN
176 REAL SASUM, SLAMCH
177 EXTERNAL lsame, sasum, sisnan, slamch
178* ..
179* .. External Subroutines ..
180 EXTERNAL sgbmv
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 = slamch( '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 = sasum( i2-i1+1, a( i1, j ), 1 )
208 IF( anorm.LT.temp .OR. sisnan( 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. sisnan( 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 sgbmv( 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 = sasum( n1, b( 1, j ), 1 )
253 xnorm = sasum( 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 SGBT02
264*
sisnan
logical function sisnan(sin)
SISNAN tests input for NaN.
Definition sisnan.f:59
sgbmv
subroutine sgbmv(trans, m, n, kl, ku, alpha, a, lda, x, incx, beta, y, incy)
SGBMV
Definition sgbmv.f:185

◆ sgbt05()

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

SGBT05

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

Definition at line 174 of file sgbt05.f.

176*
177* -- LAPACK test routine --
178* -- LAPACK is a software package provided by Univ. of Tennessee, --
179* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
180*
181* .. Scalar Arguments ..
182 CHARACTER TRANS
183 INTEGER KL, KU, LDAB, LDB, LDX, LDXACT, N, NRHS
184* ..
185* .. Array Arguments ..
186 REAL AB( LDAB, * ), B( LDB, * ), BERR( * ),
187 $ FERR( * ), RESLTS( * ), X( LDX, * ),
188 $ XACT( LDXACT, * )
189* ..
190*
191* =====================================================================
192*
193* .. Parameters ..
194 REAL ZERO, ONE
195 parameter( zero = 0.0e+0, one = 1.0e+0 )
196* ..
197* .. Local Scalars ..
198 LOGICAL NOTRAN
199 INTEGER I, IMAX, J, K, NZ
200 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
201* ..
202* .. External Functions ..
203 LOGICAL LSAME
204 INTEGER ISAMAX
205 REAL SLAMCH
206 EXTERNAL lsame, isamax, slamch
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 = slamch( 'Epsilon' )
222 unfl = slamch( '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 = isamax( 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 SGBT05
290*

◆ sgelqs()

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

SGELQS

Purpose:
!>
!> Compute a minimum-norm solution
!>     min || A*X - B ||
!> using the LQ factorization
!>     A = L*Q
!> computed by SGELQF.
!>
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 REAL array, dimension (LDA,N)
!>          Details of the LQ factorization of the original matrix A as
!>          returned by SGELQF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= M.
!>
[in]TAU
!>          TAU is REAL array, dimension (M)
!>          Details of the orthogonal matrix Q.
!>
[in,out]B
!>          B is REAL 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 REAL 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 sgelqs.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 REAL A( LDA, * ), B( LDB, * ), TAU( * ),
131 $ WORK( LWORK )
132* ..
133*
134* =====================================================================
135*
136* .. Parameters ..
137 REAL ZERO, ONE
138 parameter( zero = 0.0e+0, one = 1.0e+0 )
139* ..
140* .. External Subroutines ..
141 EXTERNAL slaset, sormlq, strsm, 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( 'SGELQS', -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 strsm( '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 slaset( 'Full', n-m, nrhs, zero, zero, b( m+1, 1 ), ldb )
184*
185* B := Q' * B
186*
187 CALL sormlq( 'Left', 'Transpose', n, nrhs, m, a, lda, tau, b, ldb,
188 $ work, lwork, info )
189*
190 RETURN
191*
192* End of SGELQS
193*
xerbla
subroutine xerbla(srname, info)
XERBLA
Definition xerbla.f:60

◆ sgennd()

logical function sgennd ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda )

SGENND

Purpose:
!>
!>    SGENND 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 REAL 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 sgennd.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 REAL A( LDA, * )
78* ..
79*
80* =====================================================================
81*
82* .. Parameters ..
83 REAL ZERO
84 parameter( zero = 0.0e0 )
85* ..
86* .. Local Scalars ..
87 INTEGER I, K
88* ..
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 sgennd = .false.
97 RETURN
98 END IF
99 END DO
100 sgennd = .true.
101 RETURN

◆ sgeqls()

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

SGEQLS

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

◆ sgeqrs()

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

SGEQRS

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

◆ sgerqs()

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

SGERQS

Purpose:
!>
!> Compute a minimum-norm solution
!>     min || A*X - B ||
!> using the RQ factorization
!>     A = R*Q
!> computed by SGERQF.
!>
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 REAL array, dimension (LDA,N)
!>          Details of the RQ factorization of the original matrix A as
!>          returned by SGERQF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= M.
!>
[in]TAU
!>          TAU is REAL array, dimension (M)
!>          Details of the orthogonal matrix Q.
!>
[in,out]B
!>          B is REAL 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 REAL 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 sgerqs.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 REAL A( LDA, * ), B( LDB, * ), TAU( * ),
132 $ WORK( LWORK )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 REAL ZERO, ONE
139 parameter( zero = 0.0e+0, one = 1.0e+0 )
140* ..
141* .. External Subroutines ..
142 EXTERNAL slaset, sormrq, strsm, 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( 'SGERQS', -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 strsm( '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 slaset( 'Full', n-m, nrhs, zero, zero, b, ldb )
184*
185* B := Q' * B
186*
187 CALL sormrq( 'Left', 'Transpose', n, nrhs, m, a, lda, tau, b, ldb,
188 $ work, lwork, info )
189*
190 RETURN
191*
192* End of SGERQS
193*

◆ sget01()

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

SGET01

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

Definition at line 105 of file sget01.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 REAL RESID
115* ..
116* .. Array Arguments ..
117 INTEGER IPIV( * )
118 REAL A( LDA, * ), AFAC( LDAFAC, * ), RWORK( * )
119* ..
120*
121* =====================================================================
122*
123*
124* .. Parameters ..
125 REAL ZERO, ONE
126 parameter( zero = 0.0e+0, one = 1.0e+0 )
127* ..
128* .. Local Scalars ..
129 INTEGER I, J, K
130 REAL ANORM, EPS, T
131* ..
132* .. External Functions ..
133 REAL SDOT, SLAMCH, SLANGE
134 EXTERNAL sdot, slamch, slange
135* ..
136* .. External Subroutines ..
137 EXTERNAL sgemv, slaswp, sscal, strmv
138* ..
139* .. Intrinsic Functions ..
140 INTRINSIC min, real
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 = slamch( 'Epsilon' )
154 anorm = slange( '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 strmv( '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 sscal( m-k, t, afac( k+1, k ), 1 )
171 CALL sgemv( '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 + sdot( k-1, afac( k, 1 ), ldafac,
179 $ afac( 1, k ), 1 )
180*
181* Compute elements (1:K-1,K)
182*
183 CALL strmv( 'Lower', 'No transpose', 'Unit', k-1, afac,
184 $ ldafac, afac( 1, k ), 1 )
185 END IF
186 10 CONTINUE
187 CALL slaswp( 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 = slange( '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 / real( n ) ) / anorm ) / eps
206 END IF
207*
208 RETURN
209*
210* End of SGET01
211*
slaswp
subroutine slaswp(n, a, lda, k1, k2, ipiv, incx)
SLASWP performs a series of row interchanges on a general rectangular matrix.
Definition slaswp.f:115
sdot
real function sdot(n, sx, incx, sy, incy)
SDOT
Definition sdot.f:82
sgemv
subroutine sgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
SGEMV
Definition sgemv.f:156
strmv
subroutine strmv(uplo, trans, diag, n, a, lda, x, incx)
STRMV
Definition strmv.f:147

◆ sget02()

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

SGET02

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

Definition at line 133 of file sget02.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 REAL RESID
144* ..
145* .. Array Arguments ..
146 REAL A( LDA, * ), B( LDB, * ), RWORK( * ),
147 $ X( LDX, * )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 REAL ZERO, ONE
154 parameter( zero = 0.0e+0, one = 1.0e+0 )
155* ..
156* .. Local Scalars ..
157 INTEGER J, N1, N2
158 REAL ANORM, BNORM, EPS, XNORM
159* ..
160* .. External Functions ..
161 LOGICAL LSAME
162 REAL SASUM, SLAMCH, SLANGE
163 EXTERNAL lsame, sasum, slamch, slange
164* ..
165* .. External Subroutines ..
166 EXTERNAL sgemm
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 = slamch( 'Epsilon' )
191 IF( lsame( trans, 'N' ) ) THEN
192 anorm = slange( '1', m, n, a, lda, rwork )
193 ELSE
194 anorm = slange( '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 sgemm( 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 = sasum( n1, b( 1, j ), 1 )
212 xnorm = sasum( 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 SGET02
223*

◆ sget03()

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

SGET03

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

Definition at line 107 of file sget03.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 REAL RCOND, RESID
117* ..
118* .. Array Arguments ..
119 REAL A( LDA, * ), AINV( LDAINV, * ), RWORK( * ),
120 $ WORK( LDWORK, * )
121* ..
122*
123* =====================================================================
124*
125* .. Parameters ..
126 REAL ZERO, ONE
127 parameter( zero = 0.0e+0, one = 1.0e+0 )
128* ..
129* .. Local Scalars ..
130 INTEGER I
131 REAL AINVNM, ANORM, EPS
132* ..
133* .. External Functions ..
134 REAL SLAMCH, SLANGE
135 EXTERNAL slamch, slange
136* ..
137* .. External Subroutines ..
138 EXTERNAL sgemm
139* ..
140* .. Intrinsic Functions ..
141 INTRINSIC real
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 = slamch( 'Epsilon' )
156 anorm = slange( '1', n, n, a, lda, rwork )
157 ainvnm = slange( '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 sgemm( 'No transpose', 'No transpose', n, n, n, -one,
168 $ ainv, 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 = slange( '1', n, n, work, ldwork, rwork )
176*
177 resid = ( ( resid*rcond ) / eps ) / real( n )
178*
179 RETURN
180*
181* End of SGET03
182*

◆ sget04()

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

SGET04

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

Definition at line 101 of file sget04.f.

102*
103* -- LAPACK test routine --
104* -- LAPACK is a software package provided by Univ. of Tennessee, --
105* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
106*
107* .. Scalar Arguments ..
108 INTEGER LDX, LDXACT, N, NRHS
109 REAL RCOND, RESID
110* ..
111* .. Array Arguments ..
112 REAL X( LDX, * ), XACT( LDXACT, * )
113* ..
114*
115* =====================================================================
116*
117* .. Parameters ..
118 REAL ZERO
119 parameter( zero = 0.0e+0 )
120* ..
121* .. Local Scalars ..
122 INTEGER I, IX, J
123 REAL DIFFNM, EPS, XNORM
124* ..
125* .. External Functions ..
126 INTEGER ISAMAX
127 REAL SLAMCH
128 EXTERNAL isamax, slamch
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 = slamch( 'Epsilon' )
145 IF( rcond.LT.zero ) THEN
146 resid = 1.0 / 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 = isamax( 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.0 / eps
165 ELSE
166 resid = max( resid, ( diffnm / xnorm )*rcond )
167 END IF
168 20 CONTINUE
169 IF( resid*eps.LT.1.0 )
170 $ resid = resid / eps
171*
172 RETURN
173*
174* End of SGET04
175*

◆ sget06()

real function sget06 ( real rcond,
real rcondc )

SGET06

Purpose:
!>
!> SGET06 computes a test ratio to compare two values for RCOND.
!>
Parameters
[in]RCOND
!>          RCOND is REAL
!>          The estimate of the reciprocal of the condition number of A,
!>          as computed by SGECON.
!>
[in]RCONDC
!>          RCONDC is REAL
!>          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 sget06.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 REAL RCOND, RCONDC
62* ..
63*
64* =====================================================================
65*
66* .. Parameters ..
67 REAL ZERO, ONE
68 parameter( zero = 0.0e+0, one = 1.0e+0 )
69* ..
70* .. Local Scalars ..
71 REAL EPS, RAT
72* ..
73* .. External Functions ..
74 REAL SLAMCH
75 EXTERNAL slamch
76* ..
77* .. Intrinsic Functions ..
78 INTRINSIC max, min
79* ..
80* .. Executable Statements ..
81*
82 eps = slamch( '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 sget06 = rat
98 RETURN
99*
100* End of SGET06
101*

◆ sget07()

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

SGET07

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

Definition at line 163 of file sget07.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 REAL A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
177 $ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 REAL ZERO, ONE
184 parameter( zero = 0.0e+0, one = 1.0e+0 )
185* ..
186* .. Local Scalars ..
187 LOGICAL NOTRAN
188 INTEGER I, IMAX, J, K
189 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
190* ..
191* .. External Functions ..
192 LOGICAL LSAME
193 INTEGER ISAMAX
194 REAL SLAMCH
195 EXTERNAL lsame, isamax, slamch
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 = slamch( 'Epsilon' )
211 unfl = slamch( '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 = isamax( 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 SGET07
281*

◆ sgtt01()

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

SGTT01

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

Definition at line 132 of file sgtt01.f.

134*
135* -- LAPACK test routine --
136* -- LAPACK is a software package provided by Univ. of Tennessee, --
137* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
138*
139* .. Scalar Arguments ..
140 INTEGER LDWORK, N
141 REAL RESID
142* ..
143* .. Array Arguments ..
144 INTEGER IPIV( * )
145 REAL D( * ), DF( * ), DL( * ), DLF( * ), DU( * ),
146 $ DU2( * ), DUF( * ), RWORK( * ),
147 $ WORK( LDWORK, * )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 REAL ONE, ZERO
154 parameter( one = 1.0e+0, zero = 0.0e+0 )
155* ..
156* .. Local Scalars ..
157 INTEGER I, IP, J, LASTJ
158 REAL ANORM, EPS, LI
159* ..
160* .. External Functions ..
161 REAL SLAMCH, SLANGT, SLANHS
162 EXTERNAL slamch, slangt, slanhs
163* ..
164* .. Intrinsic Functions ..
165 INTRINSIC min
166* ..
167* .. External Subroutines ..
168 EXTERNAL saxpy, sswap
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 = slamch( '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 saxpy( 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 sswap( 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 = slangt( '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 = slanhs( '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 SGTT01
256*
slanhs
real function slanhs(norm, n, a, lda, work)
SLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
Definition slanhs.f:108

◆ sgtt02()

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

SGTT02

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

Definition at line 123 of file sgtt02.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 REAL RESID
134* ..
135* .. Array Arguments ..
136 REAL B( LDB, * ), D( * ), DL( * ), DU( * ),
137 $ X( LDX, * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ONE, ZERO
144 parameter( one = 1.0e+0, zero = 0.0e+0 )
145* ..
146* .. Local Scalars ..
147 INTEGER J
148 REAL ANORM, BNORM, EPS, XNORM
149* ..
150* .. External Functions ..
151 LOGICAL LSAME
152 REAL SASUM, SLAMCH, SLANGT
153 EXTERNAL lsame, sasum, slamch, slangt
154* ..
155* .. External Subroutines ..
156 EXTERNAL slagtm
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 = slangt( '1', n, dl, d, du )
174 ELSE
175 anorm = slangt( 'I', n, dl, d, du )
176 END IF
177*
178* Exit with RESID = 1/EPS if ANORM = 0.
179*
180 eps = slamch( '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 slagtm( trans, n, nrhs, -one, dl, d, du, x, ldx, one, b,
189 $ ldb )
190*
191 DO 10 j = 1, nrhs
192 bnorm = sasum( n, b( 1, j ), 1 )
193 xnorm = sasum( 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 SGTT02
204*

◆ sgtt05()

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

SGTT05

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

Definition at line 163 of file sgtt05.f.

165*
166* -- LAPACK test routine --
167* -- LAPACK is a software package provided by Univ. of Tennessee, --
168* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
169*
170* .. Scalar Arguments ..
171 CHARACTER TRANS
172 INTEGER LDB, LDX, LDXACT, N, NRHS
173* ..
174* .. Array Arguments ..
175 REAL B( LDB, * ), BERR( * ), D( * ), DL( * ),
176 $ DU( * ), FERR( * ), RESLTS( * ), X( LDX, * ),
177 $ XACT( LDXACT, * )
178* ..
179*
180* =====================================================================
181*
182* .. Parameters ..
183 REAL ZERO, ONE
184 parameter( zero = 0.0e+0, one = 1.0e+0 )
185* ..
186* .. Local Scalars ..
187 LOGICAL NOTRAN
188 INTEGER I, IMAX, J, K, NZ
189 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
190* ..
191* .. External Functions ..
192 LOGICAL LSAME
193 INTEGER ISAMAX
194 REAL SLAMCH
195 EXTERNAL lsame, isamax, slamch
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 = slamch( 'Epsilon' )
211 unfl = slamch( '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 = isamax( 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 SGTT05
295*

◆ slahilb()

subroutine slahilb ( integer n,
integer nrhs,
real, dimension(lda, n) a,
integer lda,
real, dimension(ldx, nrhs) x,
integer ldx,
real, dimension(ldb, nrhs) b,
integer ldb,
real, dimension(n) work,
integer info )

SLAHILB

Purpose:
!>
!> SLAHILB 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 REAL 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 REAL array, dimension (LDX, NRHS)
!>          The generated exact solutions.  Currently, the first NRHS
!>          columns of the inverse Hilbert matrix.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= N.
!>
[out]B
!>          B is REAL array, dimension (LDB, NRHS)
!>          The generated right-hand sides.  Currently, the first NRHS
!>          columns of LCM(1, 2, ..., 2*N-1) * the identity matrix.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= N.
!>
[out]WORK
!>          WORK is REAL array, dimension (N)
!>
[out]INFO
!>          INFO is INTEGER
!>          = 0: successful exit
!>          = 1: N is too large; the data is still generated but may not
!>               be not exact.
!>          < 0: if INFO = -i, the i-th argument had an illegal value
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 123 of file slahilb.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 REAL 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* .. External Functions
150 EXTERNAL slaset
151 INTRINSIC real
152* ..
153* .. Executable Statements ..
154*
155* Test the input arguments
156*
157 info = 0
158 IF (n .LT. 0 .OR. n .GT. nmax_approx) THEN
159 info = -1
160 ELSE IF (nrhs .LT. 0) THEN
161 info = -2
162 ELSE IF (lda .LT. n) THEN
163 info = -4
164 ELSE IF (ldx .LT. n) THEN
165 info = -6
166 ELSE IF (ldb .LT. n) THEN
167 info = -8
168 END IF
169 IF (info .LT. 0) THEN
170 CALL xerbla('SLAHILB', -info)
171 RETURN
172 END IF
173 IF (n .GT. nmax_exact) THEN
174 info = 1
175 END IF
176*
177* Compute M = the LCM of the integers [1, 2*N-1]. The largest
178* reasonable N is small enough that integers suffice (up to N = 11).
179 m = 1
180 DO i = 2, (2*n-1)
181 tm = m
182 ti = i
183 r = mod(tm, ti)
184 DO WHILE (r .NE. 0)
185 tm = ti
186 ti = r
187 r = mod(tm, ti)
188 END DO
189 m = (m / ti) * i
190 END DO
191*
192* Generate the scaled Hilbert matrix in A
193 DO j = 1, n
194 DO i = 1, n
195 a(i, j) = real(m) / (i + j - 1)
196 END DO
197 END DO
198*
199* Generate matrix B as simply the first NRHS columns of M * the
200* identity.
201 CALL slaset('Full', n, nrhs, 0.0, real(m), b, ldb)
202*
203* Generate the true solutions in X. Because B = the first NRHS
204* columns of M*I, the true solutions are just the first NRHS columns
205* of the inverse Hilbert matrix.
206 work(1) = n
207 DO j = 2, n
208 work(j) = ( ( (work(j-1)/(j-1)) * (j-1 - n) ) /(j-1) )
209 $ * (n +j -1)
210 END DO
211*
212 DO j = 1, nrhs
213 DO i = 1, n
214 x(i, j) = (work(i)*work(j)) / (i + j - 1)
215 END DO
216 END DO
217*

◆ slaord()

subroutine slaord ( character job,
integer n,
real, dimension( * ) x,
integer incx )

SLAORD

Purpose:
!>
!> SLAORD 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 REAL 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 slaord.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 REAL X( * )
84* ..
85*
86* =====================================================================
87*
88* .. Local Scalars ..
89 INTEGER I, INC, IX, IXNEXT
90 REAL 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 SLAORD
147*

◆ slaptm()

subroutine slaptm ( integer n,
integer nrhs,
real alpha,
real, dimension( * ) d,
real, dimension( * ) e,
real, dimension( ldx, * ) x,
integer ldx,
real beta,
real, dimension( ldb, * ) b,
integer ldb )

SLAPTM

Purpose:
!>
!> SLAPTM 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 REAL
!>          The scalar alpha.  ALPHA must be 1. or -1.; otherwise,
!>          it is assumed to be 0.
!>
[in]D
!>          D is REAL array, dimension (N)
!>          The n diagonal elements of the tridiagonal matrix A.
!>
[in]E
!>          E is REAL array, dimension (N-1)
!>          The (n-1) subdiagonal or superdiagonal elements of A.
!>
[in]X
!>          X is REAL array, dimension (LDX,NRHS)
!>          The N by NRHS matrix X.
!>
[in]LDX
!>          LDX is INTEGER
!>          The leading dimension of the array X.  LDX >= max(N,1).
!>
[in]BETA
!>          BETA is REAL
!>          The scalar beta.  BETA must be 0., 1., or -1.; otherwise,
!>          it is assumed to be 1.
!>
[in,out]B
!>          B is REAL 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 slaptm.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 REAL ALPHA, BETA
124* ..
125* .. Array Arguments ..
126 REAL B( LDB, * ), D( * ), E( * ), X( LDX, * )
127* ..
128*
129* =====================================================================
130*
131* .. Parameters ..
132 REAL ONE, ZERO
133 parameter( one = 1.0e+0, zero = 0.0e+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 SLAPTM
199*

◆ slarhs()

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

SLARHS

Purpose:
!>
!> SLARHS 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 REAL 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) REAL 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 REAL 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
!>          SLATMS).  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 slarhs.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 REAL A( LDA, * ), B( LDB, * ), X( LDX, * )
218* ..
219*
220* =====================================================================
221*
222* .. Parameters ..
223 REAL ONE, ZERO
224 parameter( one = 1.0e+0, zero = 0.0e+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 sgbmv, sgemm, slacpy, slarnv, ssbmv, sspmv,
238 $ ssymm, stbmv, stpmv, strmm, 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, 'Single 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( 'SLARHS', -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 slarnv( 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 sgemm( 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 ssymm( '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 sgbmv( 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 ssbmv( 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 sspmv( 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 slacpy( '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 strmm( '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 slacpy( '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 stpmv( 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 slacpy( '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 stbmv( 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( 'SLARHS', -info )
404 END IF
405*
406 RETURN
407*
408* End of SLARHS
409*
stbmv
subroutine stbmv(uplo, trans, diag, n, k, a, lda, x, incx)
STBMV
Definition stbmv.f:186
stpmv
subroutine stpmv(uplo, trans, diag, n, ap, x, incx)
STPMV
Definition stpmv.f:142
ssbmv
subroutine ssbmv(uplo, n, k, alpha, a, lda, x, incx, beta, y, incy)
SSBMV
Definition ssbmv.f:184
sspmv
subroutine sspmv(uplo, n, alpha, ap, x, incx, beta, y, incy)
SSPMV
Definition sspmv.f:147
ssymm
subroutine ssymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
SSYMM
Definition ssymm.f:189
strmm
subroutine strmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
STRMM
Definition strmm.f:177

◆ slatb4()

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

SLATB4

Purpose:
!>
!> SLATB4 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 REAL
!>          The desired norm of the matrix to be generated.  The diagonal
!>          matrix of singular values or eigenvalues is scaled by this
!>          value.
!>
[out]MODE
!>          MODE is INTEGER
!>          A key indicating how to choose the vector of eigenvalues.
!>
[out]CNDNUM
!>          CNDNUM is REAL
!>          The desired condition number.
!>
[out]DIST
!>          DIST is CHARACTER*1
!>          The type of distribution to be used by the random number
!>          generator.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

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

◆ slatb5()

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

SLATB5

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

Definition at line 112 of file slatb5.f.

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

◆ slattb()

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

SLATTB

Purpose:
!>
!> SLATTB 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
!>          SLATMS).  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 REAL 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 REAL array, dimension (N)
!>
[out]WORK
!>          WORK is REAL 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 slattb.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 REAL AB( LDAB, * ), B( * ), WORK( * )
147* ..
148*
149* =====================================================================
150*
151* .. Parameters ..
152 REAL ONE, TWO, ZERO
153 parameter( one = 1.0e+0, two = 2.0e+0, zero = 0.0e+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 REAL 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 ISAMAX
167 REAL SLAMCH, SLARND
168 EXTERNAL lsame, isamax, slamch, slarnd
169* ..
170* .. External Subroutines ..
171 EXTERNAL scopy, slabad, slarnv, slatb4, slatms, sscal,
172 $ sswap
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC abs, max, min, real, sign, sqrt
176* ..
177* .. Executable Statements ..
178*
179 path( 1: 1 ) = 'Single precision'
180 path( 2: 3 ) = 'TB'
181 unfl = slamch( 'Safe minimum' )
182 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
183 smlnum = unfl
184 bignum = ( one-ulp ) / smlnum
185 CALL slabad( smlnum, bignum )
186 IF( ( imat.GE.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 SLATB4 to set parameters for SLATMS.
199*
200 upper = lsame( uplo, 'U' )
201 IF( upper ) THEN
202 CALL slatb4( 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 slatb4( 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 slatms( 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 ) = real( 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 ) = real( 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, slarnd( 2, iseed ) )
277 lenj = ( n-3 ) / 2
278 CALL slarnv( 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, slarnd( 2, iseed ) )
284 lenj = ( n-3 ) / 2
285 CALL slarnv( 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, slarnd( 2, iseed ) )
309 sfac = sqrt( tnorm )
310 plus1 = sign( sfac, slarnd( 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 = slarnd( 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 scopy( n-1, work, 1, ab( kd, 2 ), ldab )
336 CALL scopy( n-2, work( n+1 ), 1, ab( kd-1, 3 ), ldab )
337 ELSE
338 CALL scopy( n-1, work, 1, ab( 2, 1 ), ldab )
339 CALL scopy( 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 slarnv( 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 slarnv( 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 slarnv( 2, iseed, n, b )
371 iy = isamax( n, b, 1 )
372 bnorm = abs( b( iy ) )
373 bscal = bignum / max( one, bnorm )
374 CALL sscal( 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 slarnv( 2, iseed, n, b )
383 tscal = one / real( kd+1 )
384 IF( upper ) THEN
385 DO 140 j = 1, n
386 lenj = min( j, kd+1 )
387 CALL slarnv( 2, iseed, lenj, ab( kd+2-lenj, j ) )
388 CALL sscal( 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 slarnv( 2, iseed, lenj, ab( 1, j ) )
396 IF( lenj.GT.1 )
397 $ CALL sscal( 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 slarnv( 2, iseed, n, b )
410 IF( upper ) THEN
411 DO 160 j = 1, n
412 lenj = min( j, kd+1 )
413 CALL slarnv( 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 slarnv( 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 / real( kd+1 )
487 tscal = smlnum**texp
488 CALL slarnv( 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 slarnv( 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 slarnv( 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 slarnv( 2, iseed, n, b )
538 CALL sscal( 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 / real( 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 / real( kd+2 ) )
564 $ / real( kd+3 )
565 ab( kd+1, i-1 ) = one
566 b( i-1 ) = texp*real( ( kd+1 )*( kd+1 )+kd )
567 END IF
568 texp = texp*two
569 320 CONTINUE
570 b( max( 1, j-kd+1 ) ) = ( real( kd+2 ) /
571 $ real( 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 / real( 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 $ real( kd+2 ) ) / real( kd+3 )
584 ab( 1, i+1 ) = one
585 b( i+1 ) = texp*real( ( kd+1 )*( kd+1 )+kd )
586 END IF
587 texp = texp*two
588 340 CONTINUE
589 b( min( n, j+kd-1 ) ) = ( real( kd+2 ) /
590 $ real( 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 ) = real( 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 slarnv( 2, iseed, lenj, ab( kd+1-lenj, j ) )
610 ab( kd+1, j ) = real( 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 slarnv( 2, iseed, lenj, ab( 2, j ) )
617 ab( 1, j ) = real( j )
618 380 CONTINUE
619 END IF
620*
621* Set the right hand side so that the largest value is BIGNUM.
622*
623 CALL slarnv( 2, iseed, n, b )
624 iy = isamax( n, b, 1 )
625 bnorm = abs( b( iy ) )
626 bscal = bignum / max( one, bnorm )
627 CALL sscal( 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, real( kd ) )
636 tscal = bignum*( real( kd ) / real( kd+1 ) )
637 IF( upper ) THEN
638 DO 400 j = 1, n
639 lenj = min( j, kd+1 )
640 CALL slarnv( 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 slarnv( 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 slarnv( 2, iseed, n, b )
657 CALL sscal( 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 sswap( 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 sswap( 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 SLATTB
681*

◆ slattp()

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

SLATTP

Purpose:
!>
!> SLATTP 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
!>          SLATMS).  Modified on exit.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix to be generated.
!>
[out]A
!>          A is REAL 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 REAL array, dimension (N)
!>          The right hand side vector, if IMAT > 10.
!>
[out]WORK
!>          WORK is REAL 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 slattp.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 REAL A( * ), B( * ), WORK( * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 REAL ONE, TWO, ZERO
143 parameter( one = 1.0e+0, two = 2.0e+0, zero = 0.0e+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 REAL 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 ISAMAX
159 REAL SLAMCH, SLARND
160 EXTERNAL lsame, isamax, slamch, slarnd
161* ..
162* .. External Subroutines ..
163 EXTERNAL slabad, slarnv, slatb4, slatms, srot, srotg,
164 $ sscal
165* ..
166* .. Intrinsic Functions ..
167 INTRINSIC abs, max, real, sign, sqrt
168* ..
169* .. Executable Statements ..
170*
171 path( 1: 1 ) = 'Single precision'
172 path( 2: 3 ) = 'TP'
173 unfl = slamch( 'Safe minimum' )
174 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
175 smlnum = unfl
176 bignum = ( one-ulp ) / smlnum
177 CALL slabad( 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 SLATB4 to set parameters for SLATMS.
191*
192 upper = lsame( uplo, 'U' )
193 IF( upper ) THEN
194 CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
195 $ CNDNUM, DIST )
196 packit = 'C'
197 ELSE
198 CALL slatb4( 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 slatms( 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.25
321 sfac = 0.5
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 = slarnd( 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 / real( 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 srotg( 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 srot( 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 srotg( ra, rb, c, s )
426*
427* Multiply by [ c -s; s c] on the right.
428*
429 IF( n.GT.j+1 )
430 $ CALL srot( 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 slarnv( 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 slarnv( 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 slarnv( 2, iseed, n, b )
481 iy = isamax( n, b, 1 )
482 bnorm = abs( b( iy ) )
483 bscal = bignum / max( one, bnorm )
484 CALL sscal( 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 slarnv( 2, iseed, n, b )
493 tscal = one / max( one, real( n-1 ) )
494 IF( upper ) THEN
495 jc = 1
496 DO 200 j = 1, n
497 CALL slarnv( 2, iseed, j-1, a( jc ) )
498 CALL sscal( j-1, tscal, a( jc ), 1 )
499 a( jc+j-1 ) = sign( one, slarnd( 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 slarnv( 2, iseed, n-j, a( jc+1 ) )
507 CALL sscal( n-j, tscal, a( jc+1 ), 1 )
508 a( jc ) = sign( one, slarnd( 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 slarnv( 2, iseed, n, b )
521 IF( upper ) THEN
522 jc = 1
523 DO 220 j = 1, n
524 CALL slarnv( 2, iseed, j-1, a( jc ) )
525 a( jc+j-1 ) = sign( one, slarnd( 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 slarnv( 2, iseed, n-j, a( jc+1 ) )
533 a( jc ) = sign( one, slarnd( 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, real( n-1 ) )
604 tscal = smlnum**texp
605 CALL slarnv( 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 slarnv( 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 slarnv( 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 slarnv( 2, iseed, n, b )
661 CALL sscal( 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 / real( n+1 )
680 a( jc+j-1 ) = one
681 b( j ) = texp*( one-ulp )
682 jc = jc - j + 1
683 a( jc ) = -( tscal / real( n+1 ) ) / real( n+2 )
684 a( jc+j-2 ) = one
685 b( j-1 ) = texp*real( n*n+n-1 )
686 texp = texp*two
687 jc = jc - j + 2
688 370 CONTINUE
689 b( 1 ) = ( real( n+1 ) / real( n+2 ) )*tscal
690 ELSE
691 jc = 1
692 DO 380 j = 1, n - 1, 2
693 a( jc+n-j ) = -tscal / real( 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 / real( n+1 ) ) / real( n+2 )
698 a( jc ) = one
699 b( j+1 ) = texp*real( n*n+n-1 )
700 texp = texp*two
701 jc = jc + n - j
702 380 CONTINUE
703 b( n ) = ( real( n+1 ) / real( 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 slarnv( 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 slarnv( 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 slarnv( 2, iseed, n, b )
732 iy = isamax( n, b, 1 )
733 bnorm = abs( b( iy ) )
734 bscal = bignum / max( one, bnorm )
735 CALL sscal( 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, real( n-1 ) )
744 tscal = bignum*( real( n-1 ) / max( one, real( n ) ) )
745 IF( upper ) THEN
746 jc = 1
747 DO 420 j = 1, n
748 CALL slarnv( 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 slarnv( 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 slarnv( 2, iseed, n, b )
767 CALL sscal( 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 SLATTP
808*
srot
subroutine srot(n, sx, incx, sy, incy, c, s)
SROT
Definition srot.f:92
srotg
subroutine srotg(a, b, c, s)
SROTG
Definition srotg.f90:93
jc
subroutine jc(p, t, a, b, cm, cn, tref, tm, epsm, sigmam, jc_yield, tan_jc)
Definition sigeps106.F:339

◆ slattr()

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

SLATTR

Purpose:
!>
!> SLATTR 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
!>          SLATMS).  Modified on exit.
!>
[in]N
!>          N is INTEGER
!>          The order of the matrix to be generated.
!>
[out]A
!>          A is REAL 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 REAL array, dimension (N)
!>          The right hand side vector, if IMAT > 10.
!>
[out]WORK
!>          WORK is REAL 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 slattr.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 REAL A( LDA, * ), B( * ), WORK( * )
145* ..
146*
147* =====================================================================
148*
149* .. Parameters ..
150 REAL ONE, TWO, ZERO
151 parameter( one = 1.0e+0, two = 2.0e+0, zero = 0.0e+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 REAL 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 ISAMAX
165 REAL SLAMCH, SLARND
166 EXTERNAL lsame, isamax, slamch, slarnd
167* ..
168* .. External Subroutines ..
169 EXTERNAL scopy, slabad, slarnv, slatb4, slatms, srot,
170 $ srotg, sscal, sswap
171* ..
172* .. Intrinsic Functions ..
173 INTRINSIC abs, max, real, sign, sqrt
174* ..
175* .. Executable Statements ..
176*
177 path( 1: 1 ) = 'Single precision'
178 path( 2: 3 ) = 'TR'
179 unfl = slamch( 'Safe minimum' )
180 ulp = slamch( 'Epsilon' )*slamch( 'Base' )
181 smlnum = unfl
182 bignum = ( one-ulp ) / smlnum
183 CALL slabad( 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 SLATB4 to set parameters for SLATMS.
197*
198 upper = lsame( uplo, 'U' )
199 IF( upper ) THEN
200 CALL slatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
201 $ CNDNUM, DIST )
202 ELSE
203 CALL slatb4( 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 slatms( 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.25
317 sfac = 0.5
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 = slarnd( 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. / ( 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 scopy( n-3, work, 1, a( 2, 3 ), lda+1 )
348 IF( n.GT.4 )
349 $ CALL scopy( 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 scopy( n-3, work, 1, a( 3, 2 ), lda+1 )
359 IF( n.GT.4 )
360 $ CALL scopy( 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.0
375 CALL srotg( ra, rb, c, s )
376*
377* Multiply by [ c s; -s c] on the left.
378*
379 IF( n.GT.j+1 )
380 $ CALL srot( 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 srot( 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.0
396 CALL srotg( ra, rb, c, s )
397*
398* Multiply by [ c -s; s c] on the right.
399*
400 IF( n.GT.j+1 )
401 $ CALL srot( 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 srot( 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 slarnv( 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 slarnv( 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 slarnv( 2, iseed, n, b )
441 iy = isamax( n, b, 1 )
442 bnorm = abs( b( iy ) )
443 bscal = bignum / max( one, bnorm )
444 CALL sscal( 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 slarnv( 2, iseed, n, b )
453 tscal = one / max( one, real( n-1 ) )
454 IF( upper ) THEN
455 DO 160 j = 1, n
456 CALL slarnv( 2, iseed, j, a( 1, j ) )
457 CALL sscal( 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 slarnv( 2, iseed, n-j+1, a( j, j ) )
464 IF( n.GT.j )
465 $ CALL sscal( 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 slarnv( 2, iseed, n, b )
478 IF( upper ) THEN
479 DO 180 j = 1, n
480 CALL slarnv( 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 slarnv( 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, real( n-1 ) )
553 tscal = smlnum**texp
554 CALL slarnv( 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.
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.
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 slarnv( 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 slarnv( 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 slarnv( 2, iseed, n, b )
602 CALL sscal( 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.
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 / real( n+1 )
622 a( j, j ) = one
623 b( j ) = texp*( one-ulp )
624 a( 1, j-1 ) = -( tscal / real( n+1 ) ) / real( n+2 )
625 a( j-1, j-1 ) = one
626 b( j-1 ) = texp*real( n*n+n-1 )
627 texp = texp*2.
628 340 CONTINUE
629 b( 1 ) = ( real( n+1 ) / real( n+2 ) )*tscal
630 ELSE
631 DO 350 j = 1, n - 1, 2
632 a( n, j ) = -tscal / real( n+1 )
633 a( j, j ) = one
634 b( j ) = texp*( one-ulp )
635 a( n, j+1 ) = -( tscal / real( n+1 ) ) / real( n+2 )
636 a( j+1, j+1 ) = one
637 b( j+1 ) = texp*real( n*n+n-1 )
638 texp = texp*2.
639 350 CONTINUE
640 b( n ) = ( real( n+1 ) / real( 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 slarnv( 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 slarnv( 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 slarnv( 2, iseed, n, b )
665 iy = isamax( n, b, 1 )
666 bnorm = abs( b( iy ) )
667 bscal = bignum / max( one, bnorm )
668 CALL sscal( 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: SLATRS no longer can handle this case
676*
677 tleft = bignum / max( one, real( n-1 ) )
678 tscal = bignum*( real( n-1 ) / max( one, real( n ) ) )
679 IF( upper ) THEN
680 DO 390 j = 1, n
681 CALL slarnv( 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 slarnv( 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 slarnv( 2, iseed, n, b )
695 CALL sscal( 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 sswap( 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 sswap( 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 SLATTR
717*

◆ slavsp()

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

SLAVSP

Purpose:
!>
!> SLAVSP  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 SSPTRF.
!>
!> 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 REAL 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 SSPTRF.
!>
[in]IPIV
!>          IPIV is INTEGER array, dimension (N)
!>          The pivot indices from SSPTRF.
!>
[in,out]B
!>          B is REAL 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 slavsp.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 REAL A( * ), B( LDB, * )
142* ..
143*
144* =====================================================================
145*
146* .. Parameters ..
147 REAL ONE
148 parameter( one = 1.0e+0 )
149* ..
150* .. Local Scalars ..
151 LOGICAL NOUNIT
152 INTEGER J, K, KC, KCNEXT, KP
153 REAL D11, D12, D21, D22, T1, T2
154* ..
155* .. External Functions ..
156 LOGICAL LSAME
157 EXTERNAL lsame
158* ..
159* .. External Subroutines ..
160 EXTERNAL sgemv, sger, sscal, sswap, 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( 'SLAVSP ', -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 sscal( 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 sger( 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 sswap( 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 sger( k-1, nrhs, one, a( kc ), 1, b( k, 1 ), ldb,
268 $ b( 1, 1 ), ldb )
269 CALL sger( 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 sswap( 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 sscal( 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 sger( 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 sswap( 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 sger( n-k, nrhs, one, a( kc+1 ), 1, b( k, 1 ),
356 $ ldb, b( k+1, 1 ), ldb )
357 CALL sger( 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 sswap( 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 sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
405*
406* Apply the transformation
407*
408 CALL sgemv( 'Transpose', k-1, nrhs, one, b, ldb,
409 $ a( kc ), 1, one, b( k, 1 ), ldb )
410 END IF
411 IF( nounit )
412 $ CALL sscal( 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 sswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
426 $ ldb )
427*
428* Apply the transformations
429*
430 CALL sgemv( 'Transpose', k-2, nrhs, one, b, ldb,
431 $ a( kc ), 1, one, b( k, 1 ), ldb )
432 CALL sgemv( '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 sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
480*
481* Apply the transformation
482*
483 CALL sgemv( '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 sscal( 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 sswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
502 $ ldb )
503*
504* Apply the transformation
505*
506 CALL sgemv( '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 sgemv( '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 SLAVSP
539*
sger
subroutine sger(m, n, alpha, x, incx, y, incy, a, lda)
SGER
Definition sger.f:130

◆ slavsy()

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

SLAVSY

Purpose:
!>
!> SLAVSY  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 SSYTRF.
!>
!> 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 REAL array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by SSYTRF.
!>          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 SSYTRF.
!>
!>          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 REAL 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 slavsy.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 REAL A( LDA, * ), B( LDB, * )
167* ..
168*
169* =====================================================================
170*
171* .. Parameters ..
172 REAL ONE
173 parameter( one = 1.0e+0 )
174* ..
175* .. Local Scalars ..
176 LOGICAL NOUNIT
177 INTEGER J, K, KP
178 REAL D11, D12, D21, D22, T1, T2
179* ..
180* .. External Functions ..
181 LOGICAL LSAME
182 EXTERNAL lsame
183* ..
184* .. External Subroutines ..
185 EXTERNAL sgemv, sger, sscal, sswap, 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( 'SLAVSY ', -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 sscal( 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 sger( 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 sswap( 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 sger( k-1, nrhs, one, a( 1, k ), 1, b( k, 1 ),
290 $ ldb, b( 1, 1 ), ldb )
291 CALL sger( 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 sswap( 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 sscal( 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 sger( 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 sswap( 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 sger( n-k, nrhs, one, a( k+1, k ), 1, b( k, 1 ),
373 $ ldb, b( k+1, 1 ), ldb )
374 CALL sger( 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 sswap( 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 sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
419*
420* Apply the transformation
421*
422 CALL sgemv( '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 sscal( 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 sswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
439 $ ldb )
440*
441* Apply the transformations
442*
443 CALL sgemv( 'Transpose', k-2, nrhs, one, b, ldb,
444 $ a( 1, k ), 1, one, b( k, 1 ), ldb )
445 CALL sgemv( '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 sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
491*
492* Apply the transformation
493*
494 CALL sgemv( '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 sscal( 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 sswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
511 $ ldb )
512*
513* Apply the transformation
514*
515 CALL sgemv( '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 sgemv( '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 SLAVSY
547*

◆ slavsy_rook()

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

SLAVSY_ROOK

Purpose:
!>
!> SLAVSY_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 SSYTRF_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 REAL array, dimension (LDA,N)
!>          The block diagonal matrix D and the multipliers used to
!>          obtain the factor U or L as computed by SSYTRF_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 SSYTRF_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 REAL 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 slavsy_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 REAL A( LDA, * ), B( LDB, * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 REAL ONE
175 parameter( one = 1.0e+0 )
176* ..
177* .. Local Scalars ..
178 LOGICAL NOUNIT
179 INTEGER J, K, KP
180 REAL D11, D12, D21, D22, T1, T2
181* ..
182* .. External Functions ..
183 LOGICAL LSAME
184 EXTERNAL lsame
185* ..
186* .. External Subroutines ..
187 EXTERNAL sgemv, sger, sscal, sswap, 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( 'SLAVSY_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 sscal( 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 sger( 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 sswap( 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 sger( k-1, nrhs, one, a( 1, k ), 1, b( k, 1 ),
292 $ ldb, b( 1, 1 ), ldb )
293 CALL sger( 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 sswap( 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 sswap( 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 sscal( 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 sger( 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 sswap( 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 sger( n-k, nrhs, one, a( k+1, k ), 1, b( k, 1 ),
385 $ ldb, b( k+1, 1 ), ldb )
386 CALL sger( 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 sswap( 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 sswap( 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 sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
440*
441* Apply the transformation
442*
443 CALL sgemv( '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 sscal( 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 sswap( 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 sswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
466 $ ldb )
467*
468* Apply the transformations
469*
470 CALL sgemv( 'Transpose', k-2, nrhs, one, b, ldb,
471 $ a( 1, k ), 1, one, b( k, 1 ), ldb )
472 CALL sgemv( '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 sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
518*
519* Apply the transformation
520*
521 CALL sgemv( '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 sscal( 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 sswap( 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 sswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
544 $ ldb )
545*
546* Apply the transformation
547*
548 CALL sgemv( '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 sgemv( '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 SLAVSY_ROOK
580*

◆ slqt01()

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

SLQT01

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

Definition at line 124 of file slqt01.f.

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

◆ slqt02()

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

SLQT02

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

Definition at line 133 of file slqt02.f.

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

◆ slqt03()

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

SLQT03

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

Definition at line 134 of file slqt03.f.

136*
137* -- LAPACK test routine --
138* -- LAPACK is a software package provided by Univ. of Tennessee, --
139* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
140*
141* .. Scalar Arguments ..
142 INTEGER K, LDA, LWORK, M, N
143* ..
144* .. Array Arguments ..
145 REAL AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
146 $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
147 $ WORK( LWORK )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 REAL ONE
154 parameter( one = 1.0e0 )
155 REAL ROGUE
156 parameter( rogue = -1.0e+10 )
157* ..
158* .. Local Scalars ..
159 CHARACTER SIDE, TRANS
160 INTEGER INFO, ISIDE, ITRANS, J, MC, NC
161 REAL CNORM, EPS, RESID
162* ..
163* .. External Functions ..
164 LOGICAL LSAME
165 REAL SLAMCH, SLANGE
166 EXTERNAL lsame, slamch, slange
167* ..
168* .. External Subroutines ..
169 EXTERNAL sgemm, slacpy, slarnv, slaset, sorglq, sormlq
170* ..
171* .. Local Arrays ..
172 INTEGER ISEED( 4 )
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC max, real
176* ..
177* .. Scalars in Common ..
178 CHARACTER*32 SRNAMT
179* ..
180* .. Common blocks ..
181 COMMON / srnamc / srnamt
182* ..
183* .. Data statements ..
184 DATA iseed / 1988, 1989, 1990, 1991 /
185* ..
186* .. Executable Statements ..
187*
188 eps = slamch( 'Epsilon' )
189*
190* Copy the first k rows of the factorization to the array Q
191*
192 CALL slaset( 'Full', n, n, rogue, rogue, q, lda )
193 CALL slacpy( 'Upper', k, n-1, af( 1, 2 ), lda, q( 1, 2 ), lda )
194*
195* Generate the n-by-n matrix Q
196*
197 srnamt = 'SORGLQ'
198 CALL sorglq( 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 slarnv( 2, iseed, mc, c( 1, j ) )
215 10 CONTINUE
216 cnorm = slange( '1', mc, nc, c, lda, rwork )
217 IF( cnorm.EQ.0.0 )
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 slacpy( 'Full', mc, nc, c, lda, cc, lda )
230*
231* Apply Q or Q' to C
232*
233 srnamt = 'SORMLQ'
234 CALL sormlq( 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 sgemm( trans, 'No transpose', mc, nc, mc, -one, q,
241 $ lda, c, lda, one, cc, lda )
242 ELSE
243 CALL sgemm( '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 = slange( '1', mc, nc, cc, lda, rwork )
250 result( ( iside-1 )*2+itrans ) = resid /
251 $ ( real( max( 1, n ) )*cnorm*eps )
252*
253 20 CONTINUE
254 30 CONTINUE
255*
256 RETURN
257*
258* End of SLQT03
259*

◆ sorhr_col01()

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

SORHR_COL01

Purpose:
!>
!> SORHR_COL01 tests SORGTSQR and SORHR_COL using SLATSQR, SGEMQRT.
!> Therefore, SLATSQR (part of SGEQR), SGEMQRT (part of SGEMQR)
!> have to be tested before this test.
!>
!>
Parameters
[in]M
!>          M is INTEGER
!>          Number of rows in test matrix.
!>
[in]N
!>          N is INTEGER
!>          Number of columns in test matrix.
!>
[in]MB1
!>          MB1 is INTEGER
!>          Number of row in row block in an input test matrix.
!>
[in]NB1
!>          NB1 is INTEGER
!>          Number of columns in column block an input test matrix.
!>
[in]NB2
!>          NB2 is INTEGER
!>          Number of columns in column block in an output test matrix.
!>
[out]RESULT
!>          RESULT is REAL array, dimension (6)
!>          Results of each of the six tests below.
!>
!>            A is a m-by-n test input matrix to be factored.
!>            so that A = Q_gr * ( R )
!>                               ( 0 ),
!>
!>            Q_qr is an implicit m-by-m orthogonal Q matrix, the result
!>            of factorization in blocked WY-representation,
!>            stored in SGEQRT 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 SGEMQRT,
!>
!>            Q * C, (Q**H) * C, D * Q, D * (Q**H)  are
!>            computed using SGEMM.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 118 of file sorhr_col01.f.

119 IMPLICIT NONE
120*
121* -- LAPACK test routine --
122* -- LAPACK is a software package provided by Univ. of Tennessee, --
123* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
124*
125* .. Scalar Arguments ..
126 INTEGER M, N, MB1, NB1, NB2
127* .. Return values ..
128 REAL RESULT(6)
129*
130* =====================================================================
131*
132* ..
133* .. Local allocatable arrays
134 REAL , ALLOCATABLE :: A(:,:), AF(:,:), Q(:,:), R(:,:),
135 $ RWORK(:), WORK( : ), T1(:,:), T2(:,:), DIAG(:),
136 $ C(:,:), CF(:,:), D(:,:), DF(:,:)
137*
138* .. Parameters ..
139 REAL ONE, ZERO
140 parameter( zero = 0.0e+0, one = 1.0e+0 )
141* ..
142* .. Local Scalars ..
143 LOGICAL TESTZEROS
144 INTEGER INFO, I, J, K, L, LWORK, NB1_UB, NB2_UB, NRB
145 REAL ANORM, EPS, RESID, CNORM, DNORM
146* ..
147* .. Local Arrays ..
148 INTEGER ISEED( 4 )
149 REAL WORKQUERY( 1 )
150* ..
151* .. External Functions ..
152 REAL SLAMCH, SLANGE, SLANSY
153 EXTERNAL slamch, slange, slansy
154* ..
155* .. External Subroutines ..
156 EXTERNAL slacpy, slarnv, slaset, slatsqr, sorhr_col,
157 $ sorgtsqr, sscal, sgemm, sgemqrt, ssyrk
158* ..
159* .. Intrinsic Functions ..
160 INTRINSIC ceiling, real, 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 = slamch( '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 slarnv( 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 slarnv( 2, iseed, m/2, a( m/4, j ) )
194 END DO
195 END IF
196 END IF
197 CALL slacpy( 'Full', m, n, a, m, af, m )
198*
199* Number of row blocks in SLATSQR
200*
201 nrb = max( 1, ceiling( real( m - n ) / real( 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* SLATSQR requires NB1 to be bounded by N.
210*
211 nb1_ub = min( nb1, n)
212*
213* SGEMQRT requires NB2 to be bounded by N.
214*
215 nb2_ub = min( nb2, n)
216*
217 CALL slatsqr( m, n, mb1, nb1_ub, af, m, t1, nb1,
218 $ workquery, -1, info )
219 lwork = int( workquery( 1 ) )
220 CALL sorgtsqr( m, n, mb1, nb1, af, m, t1, nb1, workquery, -1,
221 $ info )
222
223 lwork = max( lwork, int( workquery( 1 ) ) )
224*
225* In SGEMQRT, 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 = 'SLATSQR'
240 CALL slatsqr( 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 = 'SLACPY'
246 CALL slacpy( 'U', n, n, af, m, r, m )
247*
248* Reconstruct the orthogonal matrix Q.
249*
250 srnamt = 'SORGTSQR'
251 CALL sorgtsqr( 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 = 'SORHR_COL'
258 CALL sorhr_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 SGEQRT. 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 = 'SLACPY'
268 CALL slacpy( 'U', n, n, r, m, af, m )
269*
270 DO i = 1, n
271 IF( diag( i ).EQ.-one ) THEN
272 CALL sscal( 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 slaset( 'Full', m, m, zero, one, q, m )
282*
283 srnamt = 'SGEMQRT'
284 CALL sgemqrt( 'L', 'N', m, m, k, nb2_ub, af, m, t2, nb2, q, m,
285 $ work, info )
286*
287* Copy R
288*
289 CALL slaset( 'Full', m, n, zero, zero, r, m )
290*
291 CALL slacpy( '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 sgemm( 'T', 'N', m, n, m, -one, q, m, a, m, one, r, m )
297*
298 anorm = slange( '1', m, n, a, m, rwork )
299 resid = slange( '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 slaset( 'Full', m, m, zero, one, r, m )
310 CALL ssyrk( 'U', 'T', m, m, -one, q, m, one, r, m )
311 resid = slansy( '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 slarnv( 2, iseed, m, c( 1, j ) )
318 END DO
319 cnorm = slange( '1', m, n, c, m, rwork )
320 CALL slacpy( 'Full', m, n, c, m, cf, m )
321*
322* Apply Q to C as Q*C = CF
323*
324 srnamt = 'SGEMQRT'
325 CALL sgemqrt( '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 sgemm( 'N', 'N', m, n, m, -one, q, m, c, m, one, cf, m )
332 resid = slange( '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 slacpy( 'Full', m, n, c, m, cf, m )
342*
343* Apply Q to C as (Q**T)*C = CF
344*
345 srnamt = 'SGEMQRT'
346 CALL sgemqrt( '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 sgemm( 'T', 'N', m, n, m, -one, q, m, c, m, one, cf, m )
353 resid = slange( '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 slarnv( 2, iseed, n, d( 1, j ) )
364 END DO
365 dnorm = slange( '1', n, m, d, n, rwork )
366 CALL slacpy( 'Full', n, m, d, n, df, n )
367*
368* Apply Q to D as D*Q = DF
369*
370 srnamt = 'SGEMQRT'
371 CALL sgemqrt( '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 sgemm( 'N', 'N', n, m, m, -one, d, n, q, m, one, df, n )
378 resid = slange( '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 slacpy( 'Full', n, m, d, n, df, n )
388*
389* Apply Q to D as D*QT = DF
390*
391 srnamt = 'SGEMQRT'
392 CALL sgemqrt( '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 sgemm( 'N', 'T', n, m, m, -one, d, n, q, m, one, df, n )
399 resid = slange( '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 SORHR_COL01
414*
slatsqr
subroutine slatsqr(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
SLATSQR
Definition slatsqr.f:166
sorgtsqr
subroutine sorgtsqr(m, n, mb, nb, a, lda, t, ldt, work, lwork, info)
SORGTSQR
Definition sorgtsqr.f:175
sorhr_col
subroutine sorhr_col(m, n, nb, a, lda, t, ldt, d, info)
SORHR_COL
Definition sorhr_col.f:259

◆ sorhr_col02()

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

SORHR_COL02

Purpose:
!>
!> SORHR_COL02 tests SORGTSQR_ROW and SORHR_COL inside SGETSQRHRT
!> (which calls SLATSQR, SORGTSQR_ROW and SORHR_COL) using SGEMQRT.
!> Therefore, SLATSQR (part of SGEQR), SGEMQRT (part of SGEMQR)
!> have to be tested before this test.
!>
!>
Parameters
[in]M
!>          M is INTEGER
!>          Number of rows in test matrix.
!>
[in]N
!>          N is INTEGER
!>          Number of columns in test matrix.
!>
[in]MB1
!>          MB1 is INTEGER
!>          Number of row in row block in an input test matrix.
!>
[in]NB1
!>          NB1 is INTEGER
!>          Number of columns in column block an input test matrix.
!>
[in]NB2
!>          NB2 is INTEGER
!>          Number of columns in column block in an output test matrix.
!>
[out]RESULT
!>          RESULT is REAL array, dimension (6)
!>          Results of each of the six tests below.
!>
!>            A is a m-by-n test input matrix to be factored.
!>            so that A = Q_gr * ( R )
!>                               ( 0 ),
!>
!>            Q_qr is an implicit m-by-m orthogonal Q matrix, the result
!>            of factorization in blocked WY-representation,
!>            stored in SGEQRT 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 SGEMQRT,
!>
!>            Q * C, (Q**H) * C, D * Q, D * (Q**H)  are
!>            computed using SGEMM.
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 119 of file sorhr_col02.f.

120 IMPLICIT NONE
121*
122* -- LAPACK test routine --
123* -- LAPACK is a software package provided by Univ. of Tennessee, --
124* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
125*
126* .. Scalar Arguments ..
127 INTEGER M, N, MB1, NB1, NB2
128* .. Return values ..
129 REAL RESULT(6)
130*
131* =====================================================================
132*
133* ..
134* .. Local allocatable arrays
135 REAL , ALLOCATABLE :: A(:,:), AF(:,:), Q(:,:), R(:,:),
136 $ RWORK(:), WORK( : ), T1(:,:), T2(:,:), DIAG(:),
137 $ C(:,:), CF(:,:), D(:,:), DF(:,:)
138*
139* .. Parameters ..
140 REAL ONE, ZERO
141 parameter( zero = 0.0e+0, one = 1.0e+0 )
142* ..
143* .. Local Scalars ..
144 LOGICAL TESTZEROS
145 INTEGER INFO, J, K, L, LWORK, NB2_UB, NRB
146 REAL ANORM, EPS, RESID, CNORM, DNORM
147* ..
148* .. Local Arrays ..
149 INTEGER ISEED( 4 )
150 REAL WORKQUERY( 1 )
151* ..
152* .. External Functions ..
153 REAL SLAMCH, SLANGE, SLANSY
154 EXTERNAL slamch, slange, slansy
155* ..
156* .. External Subroutines ..
157 EXTERNAL slacpy, slarnv, slaset, sgetsqrhrt,
158 $ sscal, sgemm, sgemqrt, ssyrk
159* ..
160* .. Intrinsic Functions ..
161 INTRINSIC ceiling, real, 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 = slamch( '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 slarnv( 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 slarnv( 2, iseed, m/2, a( m/4, j ) )
195 END DO
196 END IF
197 END IF
198 CALL slacpy( 'Full', m, n, a, m, af, m )
199*
200* Number of row blocks in SLATSQR
201*
202 nrb = max( 1, ceiling( real( m - n ) / real( 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* SGEMQRT requires NB2 to be bounded by N.
211*
212 nb2_ub = min( nb2, n)
213*
214 CALL sgetsqrhrt( m, n, mb1, nb1, nb2, af, m, t2, nb2,
215 $ workquery, -1, info )
216*
217 lwork = int( workquery( 1 ) )
218*
219* In SGEMQRT, WORK is N*NB2_UB if SIDE = 'L',
220* or M*NB2_UB if SIDE = 'R'.
221*
222 lwork = max( lwork, nb2_ub * n, nb2_ub * m )
223*
224 ALLOCATE ( work( lwork ) )
225*
226* End allocate memory for WORK.
227*
228*
229* Begin Householder reconstruction routines
230*
231* Factor the matrix A in the array AF.
232*
233 srnamt = 'SGETSQRHRT'
234 CALL sgetsqrhrt( m, n, mb1, nb1, nb2, af, m, t2, nb2,
235 $ work, lwork, info )
236*
237* End Householder reconstruction routines.
238*
239*
240* Generate the m-by-m matrix Q
241*
242 CALL slaset( 'Full', m, m, zero, one, q, m )
243*
244 srnamt = 'SGEMQRT'
245 CALL sgemqrt( 'L', 'N', m, m, k, nb2_ub, af, m, t2, nb2, q, m,
246 $ work, info )
247*
248* Copy R
249*
250 CALL slaset( 'Full', m, n, zero, zero, r, m )
251*
252 CALL slacpy( 'Upper', m, n, af, m, r, m )
253*
254* TEST 1
255* Compute |R - (Q**T)*A| / ( eps * m * |A| ) and store in RESULT(1)
256*
257 CALL sgemm( 'T', 'N', m, n, m, -one, q, m, a, m, one, r, m )
258*
259 anorm = slange( '1', m, n, a, m, rwork )
260 resid = slange( '1', m, n, r, m, rwork )
261 IF( anorm.GT.zero ) THEN
262 result( 1 ) = resid / ( eps * max( 1, m ) * anorm )
263 ELSE
264 result( 1 ) = zero
265 END IF
266*
267* TEST 2
268* Compute |I - (Q**T)*Q| / ( eps * m ) and store in RESULT(2)
269*
270 CALL slaset( 'Full', m, m, zero, one, r, m )
271 CALL ssyrk( 'U', 'T', m, m, -one, q, m, one, r, m )
272 resid = slansy( '1', 'Upper', m, r, m, rwork )
273 result( 2 ) = resid / ( eps * max( 1, m ) )
274*
275* Generate random m-by-n matrix C
276*
277 DO j = 1, n
278 CALL slarnv( 2, iseed, m, c( 1, j ) )
279 END DO
280 cnorm = slange( '1', m, n, c, m, rwork )
281 CALL slacpy( 'Full', m, n, c, m, cf, m )
282*
283* Apply Q to C as Q*C = CF
284*
285 srnamt = 'SGEMQRT'
286 CALL sgemqrt( 'L', 'N', m, n, k, nb2_ub, af, m, t2, nb2, cf, m,
287 $ work, info )
288*
289* TEST 3
290* Compute |CF - Q*C| / ( eps * m * |C| )
291*
292 CALL sgemm( 'N', 'N', m, n, m, -one, q, m, c, m, one, cf, m )
293 resid = slange( '1', m, n, cf, m, rwork )
294 IF( cnorm.GT.zero ) THEN
295 result( 3 ) = resid / ( eps * max( 1, m ) * cnorm )
296 ELSE
297 result( 3 ) = zero
298 END IF
299*
300* Copy C into CF again
301*
302 CALL slacpy( 'Full', m, n, c, m, cf, m )
303*
304* Apply Q to C as (Q**T)*C = CF
305*
306 srnamt = 'SGEMQRT'
307 CALL sgemqrt( 'L', 'T', m, n, k, nb2_ub, af, m, t2, nb2, cf, m,
308 $ work, info )
309*
310* TEST 4
311* Compute |CF - (Q**T)*C| / ( eps * m * |C|)
312*
313 CALL sgemm( 'T', 'N', m, n, m, -one, q, m, c, m, one, cf, m )
314 resid = slange( '1', m, n, cf, m, rwork )
315 IF( cnorm.GT.zero ) THEN
316 result( 4 ) = resid / ( eps * max( 1, m ) * cnorm )
317 ELSE
318 result( 4 ) = zero
319 END IF
320*
321* Generate random n-by-m matrix D and a copy DF
322*
323 DO j = 1, m
324 CALL slarnv( 2, iseed, n, d( 1, j ) )
325 END DO
326 dnorm = slange( '1', n, m, d, n, rwork )
327 CALL slacpy( 'Full', n, m, d, n, df, n )
328*
329* Apply Q to D as D*Q = DF
330*
331 srnamt = 'SGEMQRT'
332 CALL sgemqrt( 'R', 'N', n, m, k, nb2_ub, af, m, t2, nb2, df, n,
333 $ work, info )
334*
335* TEST 5
336* Compute |DF - D*Q| / ( eps * m * |D| )
337*
338 CALL sgemm( 'N', 'N', n, m, m, -one, d, n, q, m, one, df, n )
339 resid = slange( '1', n, m, df, n, rwork )
340 IF( dnorm.GT.zero ) THEN
341 result( 5 ) = resid / ( eps * max( 1, m ) * dnorm )
342 ELSE
343 result( 5 ) = zero
344 END IF
345*
346* Copy D into DF again
347*
348 CALL slacpy( 'Full', n, m, d, n, df, n )
349*
350* Apply Q to D as D*QT = DF
351*
352 srnamt = 'SGEMQRT'
353 CALL sgemqrt( 'R', 'T', n, m, k, nb2_ub, af, m, t2, nb2, df, n,
354 $ work, info )
355*
356* TEST 6
357* Compute |DF - D*(Q**T)| / ( eps * m * |D| )
358*
359 CALL sgemm( 'N', 'T', n, m, m, -one, d, n, q, m, one, df, n )
360 resid = slange( '1', n, m, df, n, rwork )
361 IF( dnorm.GT.zero ) THEN
362 result( 6 ) = resid / ( eps * max( 1, m ) * dnorm )
363 ELSE
364 result( 6 ) = zero
365 END IF
366*
367* Deallocate all arrays
368*
369 DEALLOCATE ( a, af, q, r, rwork, work, t1, t2, diag,
370 $ c, d, cf, df )
371*
372 RETURN
373*
374* End of SORHR_COL02
375*
sgetsqrhrt
subroutine sgetsqrhrt(m, n, mb1, nb1, nb2, a, lda, t, ldt, work, lwork, info)
SGETSQRHRT
Definition sgetsqrhrt.f:179

◆ spbt01()

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

SPBT01

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

Definition at line 117 of file spbt01.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 REAL RESID
128* ..
129* .. Array Arguments ..
130 REAL A( LDA, * ), AFAC( LDAFAC, * ), RWORK( * )
131* ..
132*
133* =====================================================================
134*
135*
136* .. Parameters ..
137 REAL ZERO, ONE
138 parameter( zero = 0.0e+0, one = 1.0e+0 )
139* ..
140* .. Local Scalars ..
141 INTEGER I, J, K, KC, KLEN, ML, MU
142 REAL ANORM, EPS, T
143* ..
144* .. External Functions ..
145 LOGICAL LSAME
146 REAL SDOT, SLAMCH, SLANSB
147 EXTERNAL lsame, sdot, slamch, slansb
148* ..
149* .. External Subroutines ..
150 EXTERNAL sscal, ssyr, strmv
151* ..
152* .. Intrinsic Functions ..
153 INTRINSIC max, min, real
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 = slamch( 'Epsilon' )
167 anorm = slansb( '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 = sdot( 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 strmv( '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 ssyr( '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 sscal( 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 = slansb( 'I', uplo, n, kd, afac, ldafac, rwork )
236*
237 resid = ( ( resid / real( n ) ) / anorm ) / eps
238*
239 RETURN
240*
241* End of SPBT01
242*
ssyr
subroutine ssyr(uplo, n, alpha, x, incx, a, lda)
SSYR
Definition ssyr.f:132

◆ spbt02()

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

SPBT02

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

Definition at line 134 of file spbt02.f.

136*
137* -- LAPACK test routine --
138* -- LAPACK is a software package provided by Univ. of Tennessee, --
139* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
140*
141* .. Scalar Arguments ..
142 CHARACTER UPLO
143 INTEGER KD, LDA, LDB, LDX, N, NRHS
144 REAL RESID
145* ..
146* .. Array Arguments ..
147 REAL A( LDA, * ), B( LDB, * ), RWORK( * ),
148 $ X( LDX, * )
149* ..
150*
151* =====================================================================
152*
153* .. Parameters ..
154 REAL ZERO, ONE
155 parameter( zero = 0.0e+0, one = 1.0e+0 )
156* ..
157* .. Local Scalars ..
158 INTEGER J
159 REAL ANORM, BNORM, EPS, XNORM
160* ..
161* .. External Functions ..
162 REAL SASUM, SLAMCH, SLANSB
163 EXTERNAL sasum, slamch, slansb
164* ..
165* .. External Subroutines ..
166 EXTERNAL ssbmv
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 = slamch( 'Epsilon' )
183 anorm = slansb( '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 ssbmv( 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 = sasum( n, b( 1, j ), 1 )
202 xnorm = sasum( 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 SPBT02
213*

◆ spbt05()

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

SPBT05

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

Definition at line 169 of file spbt05.f.

171*
172* -- LAPACK test routine --
173* -- LAPACK is a software package provided by Univ. of Tennessee, --
174* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
175*
176* .. Scalar Arguments ..
177 CHARACTER UPLO
178 INTEGER KD, LDAB, LDB, LDX, LDXACT, N, NRHS
179* ..
180* .. Array Arguments ..
181 REAL AB( LDAB, * ), B( LDB, * ), BERR( * ),
182 $ FERR( * ), RESLTS( * ), X( LDX, * ),
183 $ XACT( LDXACT, * )
184* ..
185*
186* =====================================================================
187*
188* .. Parameters ..
189 REAL ZERO, ONE
190 parameter( zero = 0.0e+0, one = 1.0e+0 )
191* ..
192* .. Local Scalars ..
193 LOGICAL UPPER
194 INTEGER I, IMAX, J, K, NZ
195 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
196* ..
197* .. External Functions ..
198 LOGICAL LSAME
199 INTEGER ISAMAX
200 REAL SLAMCH
201 EXTERNAL lsame, isamax, slamch
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 = slamch( 'Epsilon' )
217 unfl = slamch( '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 = isamax( 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 SPBT05
291*

◆ spot01()

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

SPOT01

Purpose:
!>
!> SPOT01 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 REAL 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 REAL 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 REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          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 spot01.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 REAL RESID
113* ..
114* .. Array Arguments ..
115 REAL A( LDA, * ), AFAC( LDAFAC, * ), RWORK( * )
116* ..
117*
118* =====================================================================
119*
120* .. Parameters ..
121 REAL ZERO, ONE
122 parameter( zero = 0.0e+0, one = 1.0e+0 )
123* ..
124* .. Local Scalars ..
125 INTEGER I, J, K
126 REAL ANORM, EPS, T
127* ..
128* .. External Functions ..
129 LOGICAL LSAME
130 REAL SDOT, SLAMCH, SLANSY
131 EXTERNAL lsame, sdot, slamch, slansy
132* ..
133* .. External Subroutines ..
134 EXTERNAL sscal, ssyr, strmv
135* ..
136* .. Intrinsic Functions ..
137 INTRINSIC real
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 = slamch( 'Epsilon' )
151 anorm = slansy( '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 = sdot( 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 strmv( '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 ssyr( '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 sscal( 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 = slansy( '1', uplo, n, afac, ldafac, rwork )
213*
214 resid = ( ( resid / real( n ) ) / anorm ) / eps
215*
216 RETURN
217*
218* End of SPOT01
219*

◆ spot02()

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

SPOT02

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

Definition at line 125 of file spot02.f.

127*
128* -- LAPACK test routine --
129* -- LAPACK is a software package provided by Univ. of Tennessee, --
130* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
131*
132* .. Scalar Arguments ..
133 CHARACTER UPLO
134 INTEGER LDA, LDB, LDX, N, NRHS
135 REAL RESID
136* ..
137* .. Array Arguments ..
138 REAL A( LDA, * ), B( LDB, * ), RWORK( * ),
139 $ X( LDX, * )
140* ..
141*
142* =====================================================================
143*
144* .. Parameters ..
145 REAL ZERO, ONE
146 parameter( zero = 0.0e+0, one = 1.0e+0 )
147* ..
148* .. Local Scalars ..
149 INTEGER J
150 REAL ANORM, BNORM, EPS, XNORM
151* ..
152* .. External Functions ..
153 REAL SASUM, SLAMCH, SLANSY
154 EXTERNAL sasum, slamch, slansy
155* ..
156* .. External Subroutines ..
157 EXTERNAL ssymm
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 = slamch( 'Epsilon' )
174 anorm = slansy( '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 ssymm( '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 = sasum( n, b( 1, j ), 1 )
191 xnorm = sasum( 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 SPOT02
202*

◆ spot03()

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

SPOT03

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

Definition at line 123 of file spot03.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 REAL RCOND, RESID
134* ..
135* .. Array Arguments ..
136 REAL A( LDA, * ), AINV( LDAINV, * ), RWORK( * ),
137 $ WORK( LDWORK, * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ZERO, ONE
144 parameter( zero = 0.0e+0, one = 1.0e+0 )
145* ..
146* .. Local Scalars ..
147 INTEGER I, J
148 REAL AINVNM, ANORM, EPS
149* ..
150* .. External Functions ..
151 LOGICAL LSAME
152 REAL SLAMCH, SLANGE, SLANSY
153 EXTERNAL lsame, slamch, slange, slansy
154* ..
155* .. External Subroutines ..
156 EXTERNAL ssymm
157* ..
158* .. Intrinsic Functions ..
159 INTRINSIC real
160* ..
161* .. Executable Statements ..
162*
163* Quick exit if N = 0.
164*
165 IF( n.LE.0 ) THEN
166 rcond = one
167 resid = zero
168 RETURN
169 END IF
170*
171* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
172*
173 eps = slamch( 'Epsilon' )
174 anorm = slansy( '1', uplo, n, a, lda, rwork )
175 ainvnm = slansy( '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 SSYMM 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 ssymm( '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 = slange( '1', n, n, work, ldwork, rwork )
211*
212 resid = ( ( resid*rcond ) / eps ) / real( n )
213*
214 RETURN
215*
216* End of SPOT03
217*

◆ spot05()

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

SPOT05

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

Definition at line 162 of file spot05.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 REAL A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
175 $ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
176* ..
177*
178* =====================================================================
179*
180* .. Parameters ..
181 REAL ZERO, ONE
182 parameter( zero = 0.0e+0, one = 1.0e+0 )
183* ..
184* .. Local Scalars ..
185 LOGICAL UPPER
186 INTEGER I, IMAX, J, K
187 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
188* ..
189* .. External Functions ..
190 LOGICAL LSAME
191 INTEGER ISAMAX
192 REAL SLAMCH
193 EXTERNAL lsame, isamax, slamch
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 = slamch( 'Epsilon' )
209 unfl = slamch( '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 = isamax( 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 SPOT05
283*

◆ sppt01()

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

SPPT01

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

Definition at line 92 of file sppt01.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 REAL RESID
102* ..
103* .. Array Arguments ..
104 REAL A( * ), AFAC( * ), RWORK( * )
105* ..
106*
107* =====================================================================
108*
109* .. Parameters ..
110 REAL ZERO, ONE
111 parameter( zero = 0.0e+0, one = 1.0e+0 )
112* ..
113* .. Local Scalars ..
114 INTEGER I, K, KC, NPP
115 REAL ANORM, EPS, T
116* ..
117* .. External Functions ..
118 LOGICAL LSAME
119 REAL SDOT, SLAMCH, SLANSP
120 EXTERNAL lsame, sdot, slamch, slansp
121* ..
122* .. External Subroutines ..
123 EXTERNAL sscal, sspr, stpmv
124* ..
125* .. Intrinsic Functions ..
126 INTRINSIC real
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 = slamch( 'Epsilon' )
140 anorm = slansp( '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 = sdot( 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 stpmv( '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 sspr( '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 sscal( 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 = slansp( '1', uplo, n, afac, rwork )
198*
199 resid = ( ( resid / real( n ) ) / anorm ) / eps
200*
201 RETURN
202*
203* End of SPPT01
204*
sspr
subroutine sspr(uplo, n, alpha, x, incx, ap)
SSPR
Definition sspr.f:127

◆ sppt02()

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

SPPT02

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

Definition at line 120 of file sppt02.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 REAL RESID
131* ..
132* .. Array Arguments ..
133 REAL A( * ), B( LDB, * ), RWORK( * ), X( LDX, * )
134* ..
135*
136* =====================================================================
137*
138* .. Parameters ..
139 REAL ZERO, ONE
140 parameter( zero = 0.0e+0, one = 1.0e+0 )
141* ..
142* .. Local Scalars ..
143 INTEGER J
144 REAL ANORM, BNORM, EPS, XNORM
145* ..
146* .. External Functions ..
147 REAL SASUM, SLAMCH, SLANSP
148 EXTERNAL sasum, slamch, slansp
149* ..
150* .. External Subroutines ..
151 EXTERNAL sspmv
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 = slamch( 'Epsilon' )
168 anorm = slansp( '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 sspmv( 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 = sasum( n, b( 1, j ), 1 )
186 xnorm = sasum( 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 SPPT02
197*

◆ sppt03()

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

SPPT03

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

Definition at line 108 of file sppt03.f.

110*
111* -- LAPACK test routine --
112* -- LAPACK is a software package provided by Univ. of Tennessee, --
113* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
114*
115* .. Scalar Arguments ..
116 CHARACTER UPLO
117 INTEGER LDWORK, N
118 REAL RCOND, RESID
119* ..
120* .. Array Arguments ..
121 REAL A( * ), AINV( * ), RWORK( * ),
122 $ WORK( LDWORK, * )
123* ..
124*
125* =====================================================================
126*
127* .. Parameters ..
128 REAL ZERO, ONE
129 parameter( zero = 0.0e+0, one = 1.0e+0 )
130* ..
131* .. Local Scalars ..
132 INTEGER I, J, JJ
133 REAL AINVNM, ANORM, EPS
134* ..
135* .. External Functions ..
136 LOGICAL LSAME
137 REAL SLAMCH, SLANGE, SLANSP
138 EXTERNAL lsame, slamch, slange, slansp
139* ..
140* .. Intrinsic Functions ..
141 INTRINSIC real
142* ..
143* .. External Subroutines ..
144 EXTERNAL scopy, sspmv
145* ..
146* .. Executable Statements ..
147*
148* Quick exit if N = 0.
149*
150 IF( n.LE.0 ) THEN
151 rcond = one
152 resid = zero
153 RETURN
154 END IF
155*
156* Exit with RESID = 1/EPS if ANORM = 0 or AINVNM = 0.
157*
158 eps = slamch( 'Epsilon' )
159 anorm = slansp( '1', uplo, n, a, rwork )
160 ainvnm = slansp( '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 scopy( j, ainv( jj ), 1, work( 1, j+1 ), 1 )
180 CALL scopy( 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 scopy( n-1, ainv( jj ), 1, work( n, 2 ), ldwork )
185*
186* Multiply by A
187*
188 DO 20 j = 1, n - 1
189 CALL sspmv( 'Upper', n, -one, a, work( 1, j+1 ), 1, zero,
190 $ work( 1, j ), 1 )
191 20 CONTINUE
192 CALL sspmv( '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 scopy( n-1, ainv( 2 ), 1, work( 1, 1 ), ldwork )
204 jj = n + 1
205 DO 30 j = 2, n
206 CALL scopy( n-j+1, ainv( jj ), 1, work( j, j-1 ), 1 )
207 CALL scopy( 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 sspmv( 'Lower', n, -one, a, work( 1, j-1 ), 1, zero,
215 $ work( 1, j ), 1 )
216 40 CONTINUE
217 CALL sspmv( '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 = slange( '1', n, n, work, ldwork, rwork )
231*
232 resid = ( ( resid*rcond ) / eps ) / real( n )
233*
234 RETURN
235*
236* End of SPPT03
237*

◆ sppt05()

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

SPPT05

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

Definition at line 154 of file sppt05.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 REAL AP( * ), B( LDB, * ), BERR( * ), FERR( * ),
167 $ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
168* ..
169*
170* =====================================================================
171*
172* .. Parameters ..
173 REAL ZERO, ONE
174 parameter( zero = 0.0e+0, one = 1.0e+0 )
175* ..
176* .. Local Scalars ..
177 LOGICAL UPPER
178 INTEGER I, IMAX, J, JC, K
179 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
180* ..
181* .. External Functions ..
182 LOGICAL LSAME
183 INTEGER ISAMAX
184 REAL SLAMCH
185 EXTERNAL lsame, isamax, slamch
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 = slamch( 'Epsilon' )
201 unfl = slamch( '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 = isamax( 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 SPPT05
280*

◆ spst01()

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

SPST01

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

Definition at line 132 of file spst01.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 REAL RESID
141 INTEGER LDA, LDAFAC, LDPERM, N, RANK
142 CHARACTER UPLO
143* ..
144* .. Array Arguments ..
145 REAL A( LDA, * ), AFAC( LDAFAC, * ),
146 $ PERM( LDPERM, * ), RWORK( * )
147 INTEGER PIV( * )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 REAL ZERO, ONE
154 parameter( zero = 0.0e+0, one = 1.0e+0 )
155* ..
156* .. Local Scalars ..
157 REAL ANORM, EPS, T
158 INTEGER I, J, K
159* ..
160* .. External Functions ..
161 REAL SDOT, SLAMCH, SLANSY
162 LOGICAL LSAME
163 EXTERNAL sdot, slamch, slansy, lsame
164* ..
165* .. External Subroutines ..
166 EXTERNAL sscal, ssyr, strmv
167* ..
168* .. Intrinsic Functions ..
169 INTRINSIC real
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 = slamch( 'Epsilon' )
183 anorm = slansy( '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 = sdot( 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 strmv( '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 ssyr( '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 sscal( 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 = slansy( '1', uplo, n, perm, ldafac, rwork )
296*
297 resid = ( ( resid / real( n ) ) / anorm ) / eps
298*
299 RETURN
300*
301* End of SPST01
302*

◆ sptt01()

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

SPTT01

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

Definition at line 90 of file sptt01.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 REAL RESID
99* ..
100* .. Array Arguments ..
101 REAL D( * ), DF( * ), E( * ), EF( * ), WORK( * )
102* ..
103*
104* =====================================================================
105*
106* .. Parameters ..
107 REAL ONE, ZERO
108 parameter( one = 1.0e+0, zero = 0.0e+0 )
109* ..
110* .. Local Scalars ..
111 INTEGER I
112 REAL ANORM, DE, EPS
113* ..
114* .. External Functions ..
115 REAL SLAMCH
116 EXTERNAL slamch
117* ..
118* .. Intrinsic Functions ..
119 INTRINSIC abs, max, real
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 = slamch( '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 / real( n ) ) / anorm ) / eps
164 END IF
165*
166 RETURN
167*
168* End of SPTT01
169*

◆ sptt02()

subroutine sptt02 ( integer n,
integer nrhs,
real, dimension( * ) d,
real, dimension( * ) e,
real, dimension( ldx, * ) x,
integer ldx,
real, dimension( ldb, * ) b,
integer ldb,
real resid )

SPTT02

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

Definition at line 103 of file sptt02.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 REAL RESID
112* ..
113* .. Array Arguments ..
114 REAL B( LDB, * ), D( * ), E( * ), X( LDX, * )
115* ..
116*
117* =====================================================================
118*
119* .. Parameters ..
120 REAL ONE, ZERO
121 parameter( one = 1.0e+0, zero = 0.0e+0 )
122* ..
123* .. Local Scalars ..
124 INTEGER J
125 REAL ANORM, BNORM, EPS, XNORM
126* ..
127* .. External Functions ..
128 REAL SASUM, SLAMCH, SLANST
129 EXTERNAL sasum, slamch, slanst
130* ..
131* .. Intrinsic Functions ..
132 INTRINSIC max
133* ..
134* .. External Subroutines ..
135 EXTERNAL slaptm
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 = slanst( '1', n, d, e )
149*
150* Exit with RESID = 1/EPS if ANORM = 0.
151*
152 eps = slamch( '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 slaptm( 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 = sasum( n, b( 1, j ), 1 )
168 xnorm = sasum( 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 SPTT02
179*

◆ sptt05()

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

SPTT05

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

Definition at line 148 of file sptt05.f.

150*
151* -- LAPACK test routine --
152* -- LAPACK is a software package provided by Univ. of Tennessee, --
153* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
154*
155* .. Scalar Arguments ..
156 INTEGER LDB, LDX, LDXACT, N, NRHS
157* ..
158* .. Array Arguments ..
159 REAL B( LDB, * ), BERR( * ), D( * ), E( * ),
160 $ FERR( * ), RESLTS( * ), X( LDX, * ),
161 $ XACT( LDXACT, * )
162* ..
163*
164* =====================================================================
165*
166* .. Parameters ..
167 REAL ZERO, ONE
168 parameter( zero = 0.0e+0, one = 1.0e+0 )
169* ..
170* .. Local Scalars ..
171 INTEGER I, IMAX, J, K, NZ
172 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
173* ..
174* .. External Functions ..
175 INTEGER ISAMAX
176 REAL SLAMCH
177 EXTERNAL isamax, slamch
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 = slamch( 'Epsilon' )
193 unfl = slamch( '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 = isamax( 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 SPTT05
257*

◆ sqlt01()

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

SQLT01

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

Definition at line 124 of file sqlt01.f.

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

◆ sqlt02()

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

SQLT02

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

Definition at line 134 of file sqlt02.f.

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

◆ sqlt03()

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

SQLT03

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

Definition at line 134 of file sqlt03.f.

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

◆ sqpt01()

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

SQPT01

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

◆ sqrt01()

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

SQRT01

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

Definition at line 124 of file sqrt01.f.

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

◆ sqrt01p()

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

SQRT01P

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

Definition at line 124 of file sqrt01p.f.

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

◆ sqrt02()

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

SQRT02

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

Definition at line 133 of file sqrt02.f.

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

◆ sqrt03()

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

SQRT03

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

Definition at line 134 of file sqrt03.f.

136*
137* -- LAPACK test routine --
138* -- LAPACK is a software package provided by Univ. of Tennessee, --
139* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
140*
141* .. Scalar Arguments ..
142 INTEGER K, LDA, LWORK, M, N
143* ..
144* .. Array Arguments ..
145 REAL AF( LDA, * ), C( LDA, * ), CC( LDA, * ),
146 $ Q( LDA, * ), RESULT( * ), RWORK( * ), TAU( * ),
147 $ WORK( LWORK )
148* ..
149*
150* =====================================================================
151*
152* .. Parameters ..
153 REAL ONE
154 parameter( one = 1.0e0 )
155 REAL ROGUE
156 parameter( rogue = -1.0e+10 )
157* ..
158* .. Local Scalars ..
159 CHARACTER SIDE, TRANS
160 INTEGER INFO, ISIDE, ITRANS, J, MC, NC
161 REAL CNORM, EPS, RESID
162* ..
163* .. External Functions ..
164 LOGICAL LSAME
165 REAL SLAMCH, SLANGE
166 EXTERNAL lsame, slamch, slange
167* ..
168* .. External Subroutines ..
169 EXTERNAL sgemm, slacpy, slarnv, slaset, sorgqr, sormqr
170* ..
171* .. Local Arrays ..
172 INTEGER ISEED( 4 )
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC max, real
176* ..
177* .. Scalars in Common ..
178 CHARACTER*32 SRNAMT
179* ..
180* .. Common blocks ..
181 COMMON / srnamc / srnamt
182* ..
183* .. Data statements ..
184 DATA iseed / 1988, 1989, 1990, 1991 /
185* ..
186* .. Executable Statements ..
187*
188 eps = slamch( 'Epsilon' )
189*
190* Copy the first k columns of the factorization to the array Q
191*
192 CALL slaset( 'Full', m, m, rogue, rogue, q, lda )
193 CALL slacpy( 'Lower', m-1, k, af( 2, 1 ), lda, q( 2, 1 ), lda )
194*
195* Generate the m-by-m matrix Q
196*
197 srnamt = 'SORGQR'
198 CALL sorgqr( 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 slarnv( 2, iseed, mc, c( 1, j ) )
215 10 CONTINUE
216 cnorm = slange( '1', mc, nc, c, lda, rwork )
217 IF( cnorm.EQ.0.0 )
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 slacpy( 'Full', mc, nc, c, lda, cc, lda )
230*
231* Apply Q or Q' to C
232*
233 srnamt = 'SORMQR'
234 CALL sormqr( 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 sgemm( trans, 'No transpose', mc, nc, mc, -one, q,
241 $ lda, c, lda, one, cc, lda )
242 ELSE
243 CALL sgemm( '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 = slange( '1', mc, nc, cc, lda, rwork )
250 result( ( iside-1 )*2+itrans ) = resid /
251 $ ( real( max( 1, m ) )*cnorm*eps )
252*
253 20 CONTINUE
254 30 CONTINUE
255*
256 RETURN
257*
258* End of SQRT03
259*

◆ sqrt04()

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

SQRT04

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

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

◆ sqrt05()

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

SQRT05

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

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

◆ sqrt11()

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

SQRT11

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

◆ sqrt12()

real function sqrt12 ( integer m,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) s,
real, dimension( lwork ) work,
integer lwork )

SQRT12

Purpose:
!>
!> SQRT12 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 REAL array, dimension (LDA,N)
!>          The M-by-N matrix A. Only the upper trapezoid is referenced.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.
!>
[in]S
!>          S is REAL array, dimension (min(M,N))
!>          The singular values of the matrix A.
!>
[out]WORK
!>          WORK is REAL 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 sqrt12.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 REAL A( LDA, * ), S( * ), WORK( LWORK )
99* ..
100*
101* =====================================================================
102*
103* .. Parameters ..
104 REAL ZERO, ONE
105 parameter( zero = 0.0e0, one = 1.0e0 )
106* ..
107* .. Local Scalars ..
108 INTEGER I, INFO, ISCL, J, MN
109 REAL ANRM, BIGNUM, NRMSVL, SMLNUM
110* ..
111* .. External Functions ..
112 REAL SASUM, SLAMCH, SLANGE, SNRM2
113 EXTERNAL sasum, slamch, slange, snrm2
114* ..
115* .. External Subroutines ..
116 EXTERNAL saxpy, sbdsqr, sgebd2, slabad, slascl, slaset,
117 $ xerbla
118* ..
119* .. Intrinsic Functions ..
120 INTRINSIC max, min, real
121* ..
122* .. Local Arrays ..
123 REAL DUMMY( 1 )
124* ..
125* .. Executable Statements ..
126*
127 sqrt12 = 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( 'SQRT12', 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 = snrm2( mn, s, 1 )
144*
145* Copy upper triangle of A into work
146*
147 CALL slaset( '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 = slamch( 'S' ) / slamch( 'P' )
157 bignum = one / smlnum
158 CALL slabad( smlnum, bignum )
159*
160* Scale work if max entry outside range [SMLNUM,BIGNUM]
161*
162 anrm = slange( '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 slascl( '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 slascl( '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 sgebd2( 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 sbdsqr( '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 slascl( '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 slascl( '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 saxpy( mn, -one, s, 1, work( m*n+1 ), 1 )
210 sqrt12 = sasum( mn, work( m*n+1 ), 1 ) /
211 $ ( slamch( 'Epsilon' )*real( max( m, n ) ) )
212 IF( nrmsvl.NE.zero )
213 $ sqrt12 = sqrt12 / nrmsvl
214*
215 RETURN
216*
217* End of SQRT12
218*
slascl
subroutine slascl(type, kl, ku, cfrom, cto, m, n, a, lda, info)
SLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
Definition slascl.f:143
sbdsqr
subroutine sbdsqr(uplo, n, ncvt, nru, ncc, d, e, vt, ldvt, u, ldu, c, ldc, work, info)
SBDSQR
Definition sbdsqr.f:240
sgebd2
subroutine sgebd2(m, n, a, lda, d, e, tauq, taup, work, info)
SGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm.
Definition sgebd2.f:189
snrm2
real(wp) function snrm2(n, x, incx)
SNRM2
Definition snrm2.f90:89

◆ sqrt13()

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

SQRT13

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

Definition at line 90 of file sqrt13.f.

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

◆ sqrt14()

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

SQRT14

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

◆ sqrt15()

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

SQRT15

Purpose:
!>
!> SQRT15 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 REAL 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 REAL array, dimension (LDB, NRHS)
!>          A matrix that is in the range space of matrix A.
!>
[in]LDB
!>          LDB is INTEGER
!>          The leading dimension of the array B.
!>
[out]S
!>          S is REAL array, dimension MIN(M,N)
!>          Singular values of A.
!>
[out]RANK
!>          RANK is INTEGER
!>          number of nonzero singular values of A.
!>
[out]NORMA
!>          NORMA is REAL
!>          one-norm of A.
!>
[out]NORMB
!>          NORMB is REAL
!>          one-norm of B.
!>
[in,out]ISEED
!>          ISEED is integer array, dimension (4)
!>          seed for random number generator.
!>
[out]WORK
!>          WORK is REAL 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 sqrt15.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 REAL NORMA, NORMB
156* ..
157* .. Array Arguments ..
158 INTEGER ISEED( 4 )
159 REAL A( LDA, * ), B( LDB, * ), S( * ), WORK( LWORK )
160* ..
161*
162* =====================================================================
163*
164* .. Parameters ..
165 REAL ZERO, ONE, TWO, SVMIN
166 parameter( zero = 0.0e0, one = 1.0e0, two = 2.0e0,
167 $ svmin = 0.1e0 )
168* ..
169* .. Local Scalars ..
170 INTEGER INFO, J, MN
171 REAL BIGNUM, EPS, SMLNUM, TEMP
172* ..
173* .. Local Arrays ..
174 REAL DUMMY( 1 )
175* ..
176* .. External Functions ..
177 REAL SASUM, SLAMCH, SLANGE, SLARND, SNRM2
178 EXTERNAL sasum, slamch, slange, slarnd, snrm2
179* ..
180* .. External Subroutines ..
181 EXTERNAL sgemm, slaord, slarf, slarnv, slaror, slascl,
182 $ slaset, sscal, 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( 'SQRT15', 16 )
192 RETURN
193 END IF
194*
195 smlnum = slamch( 'Safe minimum' )
196 bignum = one / smlnum
197 eps = slamch( '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( 'SQRT15', 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 = slarnd( 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 slaord( 'Decreasing', rank, s, 1 )
229*
230* Generate 'rank' columns of a random orthogonal matrix in A
231*
232 CALL slarnv( 2, iseed, m, work )
233 CALL sscal( m, one / snrm2( m, work, 1 ), work, 1 )
234 CALL slaset( 'Full', m, rank, zero, one, a, lda )
235 CALL slarf( '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 slarnv( 2, iseed, rank*nrhs, work )
243 CALL sgemm( '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 sscal( m, s( j ), a( 1, j ), 1 )
252 40 CONTINUE
253 IF( rank.LT.n )
254 $ CALL slaset( 'Full', m, n-rank, zero, zero, a( 1, rank+1 ),
255 $ lda )
256 CALL slaror( '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 slaset( 'Full', m, n, zero, zero, a, lda )
269 CALL slaset( '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 = slange( '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 slascl( 'General', 0, 0, norma, bignum, m, n, a,
283 $ lda, info )
284 CALL slascl( 'General', 0, 0, norma, bignum, mn, 1, s,
285 $ mn, info )
286 CALL slascl( '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 slascl( 'General', 0, 0, norma, smlnum, m, n, a,
293 $ lda, info )
294 CALL slascl( 'General', 0, 0, norma, smlnum, mn, 1, s,
295 $ mn, info )
296 CALL slascl( 'General', 0, 0, norma, smlnum, m, nrhs, b,
297 $ ldb, info )
298 ELSE
299 CALL xerbla( 'SQRT15', 1 )
300 RETURN
301 END IF
302 END IF
303 END IF
304*
305 norma = sasum( mn, s, 1 )
306 normb = slange( 'One-norm', m, nrhs, b, ldb, dummy )
307*
308 RETURN
309*
310* End of SQRT15
311*
slarf
subroutine slarf(side, m, n, v, incv, tau, c, ldc, work)
SLARF applies an elementary reflector to a general rectangular matrix.
Definition slarf.f:124
slaror
subroutine slaror(side, init, m, n, a, lda, iseed, x, info)
SLAROR
Definition slaror.f:146

◆ sqrt16()

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

SQRT16

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

Definition at line 131 of file sqrt16.f.

133*
134* -- LAPACK test routine --
135* -- LAPACK is a software package provided by Univ. of Tennessee, --
136* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
137*
138* .. Scalar Arguments ..
139 CHARACTER TRANS
140 INTEGER LDA, LDB, LDX, M, N, NRHS
141 REAL RESID
142* ..
143* .. Array Arguments ..
144 REAL A( LDA, * ), B( LDB, * ), RWORK( * ),
145 $ X( LDX, * )
146* ..
147*
148* =====================================================================
149*
150* .. Parameters ..
151 REAL ZERO, ONE
152 parameter( zero = 0.0e+0, one = 1.0e+0 )
153* ..
154* .. Local Scalars ..
155 INTEGER J, N1, N2
156 REAL ANORM, BNORM, EPS, XNORM
157* ..
158* .. External Functions ..
159 LOGICAL LSAME
160 REAL SASUM, SLAMCH, SLANGE
161 EXTERNAL lsame, sasum, slamch, slange
162* ..
163* .. External Subroutines ..
164 EXTERNAL sgemm
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 = slange( 'I', m, n, a, lda, rwork )
180 n1 = n
181 n2 = m
182 ELSE
183 anorm = slange( '1', m, n, a, lda, rwork )
184 n1 = m
185 n2 = n
186 END IF
187*
188 eps = slamch( 'Epsilon' )
189*
190* Compute B - A*X (or B - A'*X ) and store in B.
191*
192 CALL sgemm( 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 = sasum( n1, b( 1, j ), 1 )
201 xnorm = sasum( 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 SQRT16
215*

◆ sqrt17()

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

SQRT17

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

◆ srqt01()

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

SRQT01

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

Definition at line 124 of file srqt01.f.

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

◆ srqt02()

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

SRQT02

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

Definition at line 134 of file srqt02.f.

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

◆ srqt03()

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

SRQT03

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

Definition at line 134 of file srqt03.f.

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

◆ srzt01()

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

SRZT01

Purpose:
!>
!> SRZT01 returns
!>      || A - R*Q || / ( M * eps * ||A|| )
!> for an upper trapezoidal A that was factored with STZRZF.
!>
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 REAL array, dimension (LDA,N)
!>          The original upper trapezoidal M by N matrix A.
!>
[in]AF
!>          AF is REAL array, dimension (LDA,N)
!>          The output of STZRZF 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 REAL array, dimension (M)
!>          Details of the Householder transformations as returned by
!>          STZRZF.
!>
[out]WORK
!>          WORK is REAL 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 srzt01.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 REAL A( LDA, * ), AF( LDA, * ), TAU( * ),
108 $ WORK( LWORK )
109* ..
110*
111* =====================================================================
112*
113* .. Parameters ..
114 REAL ZERO, ONE
115 parameter( zero = 0.0e+0, one = 1.0e+0 )
116* ..
117* .. Local Scalars ..
118 INTEGER I, INFO, J
119 REAL NORMA
120* ..
121* .. Local Arrays ..
122 REAL RWORK( 1 )
123* ..
124* .. External Functions ..
125 REAL SLAMCH, SLANGE
126 EXTERNAL slamch, slange
127* ..
128* .. External Subroutines ..
129 EXTERNAL saxpy, slaset, sormrz, xerbla
130* ..
131* .. Intrinsic Functions ..
132 INTRINSIC max, real
133* ..
134* .. Executable Statements ..
135*
136 srzt01 = zero
137*
138 IF( lwork.LT.m*n+m ) THEN
139 CALL xerbla( 'SRZT01', 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 = slange( 'One-norm', m, n, a, lda, rwork )
149*
150* Copy upper triangle R
151*
152 CALL slaset( '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 sormrz( '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 saxpy( m, -one, a( 1, i ), 1, work( ( i-1 )*m+1 ), 1 )
168 30 CONTINUE
169*
170 srzt01 = slange( 'One-norm', m, n, work, m, rwork )
171*
172 srzt01 = srzt01 / ( slamch( 'Epsilon' )*real( max( m, n ) ) )
173 IF( norma.NE.zero )
174 $ srzt01 = srzt01 / norma
175*
176 RETURN
177*
178* End of SRZT01
179*
sormrz
subroutine sormrz(side, trans, m, n, k, l, a, lda, tau, c, ldc, work, lwork, info)
SORMRZ
Definition sormrz.f:187

◆ srzt02()

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

SRZT02

Purpose:
!>
!> SRZT02 returns
!>      || I - Q'*Q || / ( M * eps)
!> where the matrix Q is defined by the Householder transformations
!> generated by STZRZF.
!>
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 REAL array, dimension (LDA,N)
!>          The output of STZRZF.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array AF.
!>
[in]TAU
!>          TAU is REAL array, dimension (M)
!>          Details of the Householder transformations as returned by
!>          STZRZF.
!>
[out]WORK
!>          WORK is REAL 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 srzt02.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 REAL AF( LDA, * ), TAU( * ), WORK( LWORK )
101* ..
102*
103* =====================================================================
104*
105* .. Parameters ..
106 REAL ZERO, ONE
107 parameter( zero = 0.0e+0, one = 1.0e+0 )
108* ..
109* .. Local Scalars ..
110 INTEGER I, INFO
111* ..
112* .. Local Arrays ..
113 REAL RWORK( 1 )
114* ..
115* .. External Functions ..
116 REAL SLAMCH, SLANGE
117 EXTERNAL slamch, slange
118* ..
119* .. External Subroutines ..
120 EXTERNAL slaset, sormrz, xerbla
121* ..
122* .. Intrinsic Functions ..
123 INTRINSIC max, real
124* ..
125* .. Executable Statements ..
126*
127 srzt02 = zero
128*
129 IF( lwork.LT.n*n+n ) THEN
130 CALL xerbla( 'SRZT02', 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 slaset( 'Full', n, n, zero, one, work, n )
142*
143* Q := P(1) * ... * P(m) * Q
144*
145 CALL sormrz( '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 sormrz( '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 srzt02 = slange( 'One-norm', n, n, work, n, rwork ) /
160 $ ( slamch( 'Epsilon' )*real( max( m, n ) ) )
161 RETURN
162*
163* End of SRZT02
164*

◆ sspt01()

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

SSPT01

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

Definition at line 109 of file sspt01.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 REAL RESID
119* ..
120* .. Array Arguments ..
121 INTEGER IPIV( * )
122 REAL A( * ), AFAC( * ), C( LDC, * ), RWORK( * )
123* ..
124*
125* =====================================================================
126*
127* .. Parameters ..
128 REAL ZERO, ONE
129 parameter( zero = 0.0e+0, one = 1.0e+0 )
130* ..
131* .. Local Scalars ..
132 INTEGER I, INFO, J, JC
133 REAL ANORM, EPS
134* ..
135* .. External Functions ..
136 LOGICAL LSAME
137 REAL SLAMCH, SLANSP, SLANSY
138 EXTERNAL lsame, slamch, slansp, slansy
139* ..
140* .. External Subroutines ..
141 EXTERNAL slavsp, slaset
142* ..
143* .. Intrinsic Functions ..
144 INTRINSIC real
145* ..
146* .. Executable Statements ..
147*
148* Quick exit if N = 0.
149*
150 IF( n.LE.0 ) THEN
151 resid = zero
152 RETURN
153 END IF
154*
155* Determine EPS and the norm of A.
156*
157 eps = slamch( 'Epsilon' )
158 anorm = slansp( '1', uplo, n, a, rwork )
159*
160* Initialize C to the identity matrix.
161*
162 CALL slaset( 'Full', n, n, zero, one, c, ldc )
163*
164* Call SLAVSP to form the product D * U' (or D * L' ).
165*
166 CALL slavsp( uplo, 'Transpose', 'Non-unit', n, n, afac, ipiv, c,
167 $ ldc, info )
168*
169* Call SLAVSP again to multiply by U ( or L ).
170*
171 CALL slavsp( 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 = slansy( '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 / real( n ) ) / anorm ) / eps
203 END IF
204*
205 RETURN
206*
207* End of SSPT01
208*
slavsp
subroutine slavsp(uplo, trans, diag, n, nrhs, a, ipiv, b, ldb, info)
SLAVSP
Definition slavsp.f:130

◆ ssyt01()

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

SSYT01

Purpose:
!>
!> SSYT01 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 REAL 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 REAL array, dimension (LDAFAC,N)
!>          The factored form of the matrix A.  AFAC contains the block
!>          diagonal matrix D and the multipliers used to obtain the
!>          factor L or U from the block L*D*L' or U*D*U' factorization
!>          as computed by SSYTRF.
!>
[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 SSYTRF.
!>
[out]C
!>          C is REAL array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 122 of file ssyt01.f.

124*
125* -- LAPACK test routine --
126* -- LAPACK is a software package provided by Univ. of Tennessee, --
127* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
128*
129* .. Scalar Arguments ..
130 CHARACTER UPLO
131 INTEGER LDA, LDAFAC, LDC, N
132 REAL RESID
133* ..
134* .. Array Arguments ..
135 INTEGER IPIV( * )
136 REAL A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
137 $ RWORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ZERO, ONE
144 parameter( zero = 0.0e+0, one = 1.0e+0 )
145* ..
146* .. Local Scalars ..
147 INTEGER I, INFO, J
148 REAL ANORM, EPS
149* ..
150* .. External Functions ..
151 LOGICAL LSAME
152 REAL SLAMCH, SLANSY
153 EXTERNAL lsame, slamch, slansy
154* ..
155* .. External Subroutines ..
156 EXTERNAL slaset, slavsy
157* ..
158* .. Intrinsic Functions ..
159 INTRINSIC real
160* ..
161* .. Executable Statements ..
162*
163* Quick exit if N = 0.
164*
165 IF( n.LE.0 ) THEN
166 resid = zero
167 RETURN
168 END IF
169*
170* Determine EPS and the norm of A.
171*
172 eps = slamch( 'Epsilon' )
173 anorm = slansy( '1', uplo, n, a, lda, rwork )
174*
175* Initialize C to the identity matrix.
176*
177 CALL slaset( 'Full', n, n, zero, one, c, ldc )
178*
179* Call SLAVSY to form the product D * U' (or D * L' ).
180*
181 CALL slavsy( uplo, 'Transpose', 'Non-unit', n, n, afac, ldafac,
182 $ ipiv, c, ldc, info )
183*
184* Call SLAVSY again to multiply by U (or L ).
185*
186 CALL slavsy( 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 = slansy( '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 / real( n ) ) / anorm ) / eps
214 END IF
215*
216 RETURN
217*
218* End of SSYT01
219*
slavsy
subroutine slavsy(uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
SLAVSY
Definition slavsy.f:155

◆ ssyt01_3()

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

SSYT01_3

Purpose:
!>
!> SSYT01_3 reconstructs a symmetric indefinite matrix A from its
!> block L*D*L' or U*D*U' factorization computed by SSYTRF_RK
!> (or SSYTRF_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 SSYTRF_RK and SSYTRF_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 SSYTRF_RK (or SSYTRF_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 ssyt01_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 REAL RESID
149* ..
150* .. Array Arguments ..
151 INTEGER IPIV( * )
152 REAL A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
153 $ E( * ), RWORK( * )
154* ..
155*
156* =====================================================================
157*
158* .. Parameters ..
159 REAL ZERO, ONE
160 parameter( zero = 0.0e+0, one = 1.0e+0 )
161* ..
162* .. Local Scalars ..
163 INTEGER I, INFO, J
164 REAL ANORM, EPS
165* ..
166* .. External Functions ..
167 LOGICAL LSAME
168 REAL SLAMCH, SLANSY
169 EXTERNAL lsame, slamch, slansy
170* ..
171* .. External Subroutines ..
172 EXTERNAL slaset, slavsy_rook, ssyconvf_rook
173* ..
174* .. Intrinsic Functions ..
175 INTRINSIC real
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 ssyconvf_rook( uplo, 'R', n, afac, ldafac, e, ipiv, info )
189*
190* 1) Determine EPS and the norm of A.
191*
192 eps = slamch( 'Epsilon' )
193 anorm = slansy( '1', uplo, n, a, lda, rwork )
194*
195* 2) Initialize C to the identity matrix.
196*
197 CALL slaset( 'Full', n, n, zero, one, c, ldc )
198*
199* 3) Call SLAVSY_ROOK to form the product D * U' (or D * L' ).
200*
201 CALL slavsy_rook( uplo, 'Transpose', 'Non-unit', n, n, afac,
202 $ ldafac, ipiv, c, ldc, info )
203*
204* 4) Call SLAVSY_ROOK again to multiply by U (or L ).
205*
206 CALL slavsy_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 = slansy( '1', uplo, n, c, ldc, rwork )
228*
229 IF( anorm.LE.zero ) THEN
230 IF( resid.NE.zero )
231 $ resid = one / eps
232 ELSE
233 resid = ( ( resid / real( n ) ) / anorm ) / eps
234 END IF
235
236*
237* b) Convert to factor of L (or U)
238*
239 CALL ssyconvf_rook( uplo, 'C', n, afac, ldafac, e, ipiv, info )
240*
241 RETURN
242*
243* End of SSYT01_3
244*
slavsy_rook
subroutine slavsy_rook(uplo, trans, diag, n, nrhs, a, lda, ipiv, b, ldb, info)
SLAVSY_ROOK
Definition slavsy_rook.f:157
ssyconvf_rook
subroutine ssyconvf_rook(uplo, way, n, a, lda, e, ipiv, info)
SSYCONVF_ROOK
Definition ssyconvf_rook.f:197

◆ ssyt01_rook()

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

SSYT01_ROOK

Purpose:
!>
!> SSYT01_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 REAL 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 REAL array, dimension (LDAFAC,N)
!>          The factored form of the matrix A.  AFAC contains the block
!>          diagonal matrix D and the multipliers used to obtain the
!>          factor L or U from the block L*D*L' or U*D*U' factorization
!>          as computed by SSYTRF_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 SSYTRF_ROOK.
!>
[out]C
!>          C is REAL array, dimension (LDC,N)
!>
[in]LDC
!>          LDC is INTEGER
!>          The leading dimension of the array C.  LDC >= max(1,N).
!>
[out]RWORK
!>          RWORK is REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
!>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 122 of file ssyt01_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 REAL RESID
133* ..
134* .. Array Arguments ..
135 INTEGER IPIV( * )
136 REAL A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
137 $ RWORK( * )
138* ..
139*
140* =====================================================================
141*
142* .. Parameters ..
143 REAL ZERO, ONE
144 parameter( zero = 0.0e+0, one = 1.0e+0 )
145* ..
146* .. Local Scalars ..
147 INTEGER I, INFO, J
148 REAL ANORM, EPS
149* ..
150* .. External Functions ..
151 LOGICAL LSAME
152 REAL SLAMCH, SLANSY
153 EXTERNAL lsame, slamch, slansy
154* ..
155* .. External Subroutines ..
156 EXTERNAL slaset, slavsy_rook
157* ..
158* .. Intrinsic Functions ..
159 INTRINSIC real
160* ..
161* .. Executable Statements ..
162*
163* Quick exit if N = 0.
164*
165 IF( n.LE.0 ) THEN
166 resid = zero
167 RETURN
168 END IF
169*
170* Determine EPS and the norm of A.
171*
172 eps = slamch( 'Epsilon' )
173 anorm = slansy( '1', uplo, n, a, lda, rwork )
174*
175* Initialize C to the identity matrix.
176*
177 CALL slaset( 'Full', n, n, zero, one, c, ldc )
178*
179* Call SLAVSY_ROOK to form the product D * U' (or D * L' ).
180*
181 CALL slavsy_rook( uplo, 'Transpose', 'Non-unit', n, n, afac,
182 $ ldafac, ipiv, c, ldc, info )
183*
184* Call SLAVSY_ROOK again to multiply by U (or L ).
185*
186 CALL slavsy_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 = slansy( '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 / real( n ) ) / anorm ) / eps
214 END IF
215*
216 RETURN
217*
218* End of SSYT01_ROOK
219*

◆ stbt02()

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

STBT02

Purpose:
!>
!> STBT02 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 REAL 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 REAL 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 REAL 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 REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*x - b) / ( norm(op(A)) * norm(x) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 152 of file stbt02.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 REAL RESID
163* ..
164* .. Array Arguments ..
165 REAL AB( LDAB, * ), B( LDB, * ), WORK( * ),
166 $ X( LDX, * )
167* ..
168*
169* =====================================================================
170*
171* .. Parameters ..
172 REAL ZERO, ONE
173 parameter( zero = 0.0e+0, one = 1.0e+0 )
174* ..
175* .. Local Scalars ..
176 INTEGER J
177 REAL ANORM, BNORM, EPS, XNORM
178* ..
179* .. External Functions ..
180 LOGICAL LSAME
181 REAL SASUM, SLAMCH, SLANTB
182 EXTERNAL lsame, sasum, slamch, slantb
183* ..
184* .. External Subroutines ..
185 EXTERNAL saxpy, scopy, stbmv
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 = slantb( '1', uplo, diag, n, kd, ab, ldab, work )
203 ELSE
204 anorm = slantb( 'I', uplo, diag, n, kd, ab, ldab, work )
205 END IF
206*
207* Exit with RESID = 1/EPS if ANORM = 0.
208*
209 eps = slamch( '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 scopy( n, x( 1, j ), 1, work, 1 )
221 CALL stbmv( uplo, trans, diag, n, kd, ab, ldab, work, 1 )
222 CALL saxpy( n, -one, b( 1, j ), 1, work, 1 )
223 bnorm = sasum( n, work, 1 )
224 xnorm = sasum( 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 STBT02
235*

◆ stbt03()

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

STBT03

Purpose:
!>
!> STBT03 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 REAL array, dimension (LDAB,N)
!>          The upper or lower triangular band matrix A, stored in the
!>          first kd+1 rows of the array. The j-th column of A is stored
!>          in the j-th column of the array AB as follows:
!>          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
!>          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
!>
[in]LDAB
!>          LDAB is INTEGER
!>          The leading dimension of the array AB.  LDAB >= KD+1.
!>
[in]SCALE
!>          SCALE is REAL
!>          The scaling factor s used in solving the triangular system.
!>
[in]CNORM
!>          CNORM is REAL array, dimension (N)
!>          The 1-norms of the columns of A, not counting the diagonal.
!>
[in]TSCAL
!>          TSCAL is REAL
!>          The scaling factor used in computing the 1-norms in CNORM.
!>          CNORM actually contains the column norms of TSCAL*A.
!>
[in]X
!>          X is REAL 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 REAL 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 REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 172 of file stbt03.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 REAL RESID, SCALE, TSCAL
184* ..
185* .. Array Arguments ..
186 REAL AB( LDAB, * ), B( LDB, * ), CNORM( * ),
187 $ WORK( * ), X( LDX, * )
188* ..
189*
190* =====================================================================
191*
192* .. Parameters ..
193 REAL ONE, ZERO
194 parameter( one = 1.0e+0, zero = 0.0e+0 )
195* ..
196* .. Local Scalars ..
197 INTEGER IX, J
198 REAL BIGNUM, EPS, ERR, SMLNUM, TNORM, XNORM, XSCAL
199* ..
200* .. External Functions ..
201 LOGICAL LSAME
202 INTEGER ISAMAX
203 REAL SLAMCH
204 EXTERNAL lsame, isamax, slamch
205* ..
206* .. External Subroutines ..
207 EXTERNAL saxpy, scopy, slabad, sscal, stbmv
208* ..
209* .. Intrinsic Functions ..
210 INTRINSIC abs, max, real
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 = slamch( 'Epsilon' )
221 smlnum = slamch( 'Safe minimum' )
222 bignum = one / smlnum
223 CALL slabad( smlnum, bignum )
224*
225* Compute the norm of the triangular matrix A using the column
226* norms already computed by SLATBS.
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 scopy( n, x( 1, j ), 1, work, 1 )
252 ix = isamax( n, work, 1 )
253 xnorm = max( one, abs( x( ix, j ) ) )
254 xscal = ( one / xnorm ) / real( kd+1 )
255 CALL sscal( n, xscal, work, 1 )
256 CALL stbmv( uplo, trans, diag, n, kd, ab, ldab, work, 1 )
257 CALL saxpy( n, -scale*xscal, b( 1, j ), 1, work, 1 )
258 ix = isamax( n, work, 1 )
259 err = tscal*abs( work( ix ) )
260 ix = isamax( 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 STBT03
282*

◆ stbt05()

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

STBT05

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

Definition at line 187 of file stbt05.f.

189*
190* -- LAPACK test routine --
191* -- LAPACK is a software package provided by Univ. of Tennessee, --
192* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
193*
194* .. Scalar Arguments ..
195 CHARACTER DIAG, TRANS, UPLO
196 INTEGER KD, LDAB, LDB, LDX, LDXACT, N, NRHS
197* ..
198* .. Array Arguments ..
199 REAL AB( LDAB, * ), B( LDB, * ), BERR( * ),
200 $ FERR( * ), RESLTS( * ), X( LDX, * ),
201 $ XACT( LDXACT, * )
202* ..
203*
204* =====================================================================
205*
206* .. Parameters ..
207 REAL ZERO, ONE
208 parameter( zero = 0.0e+0, one = 1.0e+0 )
209* ..
210* .. Local Scalars ..
211 LOGICAL NOTRAN, UNIT, UPPER
212 INTEGER I, IFU, IMAX, J, K, NZ
213 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
214* ..
215* .. External Functions ..
216 LOGICAL LSAME
217 INTEGER ISAMAX
218 REAL SLAMCH
219 EXTERNAL lsame, isamax, slamch
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 = slamch( 'Epsilon' )
235 unfl = slamch( 'Safe minimum' )
236 ovfl = one / unfl
237 upper = lsame( uplo, 'U' )
238 notran = lsame( trans, 'N' )
239 unit = lsame( diag, 'U' )
240 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 = isamax( 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 STBT05
330*

◆ stbt06()

subroutine stbt06 ( real rcond,
real rcondc,
character uplo,
character diag,
integer n,
integer kd,
real, dimension( ldab, * ) ab,
integer ldab,
real, dimension( * ) work,
real rat )

STBT06

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

Definition at line 123 of file stbt06.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 REAL RAT, RCOND, RCONDC
134* ..
135* .. Array Arguments ..
136 REAL AB( LDAB, * ), WORK( * )
137* ..
138*
139* =====================================================================
140*
141* .. Parameters ..
142 REAL ZERO, ONE
143 parameter( zero = 0.0e+0, one = 1.0e+0 )
144* ..
145* .. Local Scalars ..
146 REAL ANORM, BIGNUM, EPS, RMAX, RMIN, SMLNUM
147* ..
148* .. External Functions ..
149 REAL SLAMCH, SLANTB
150 EXTERNAL slamch, slantb
151* ..
152* .. Intrinsic Functions ..
153 INTRINSIC max, min
154* ..
155* .. External Subroutines ..
156 EXTERNAL slabad
157* ..
158* .. Executable Statements ..
159*
160 eps = slamch( '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 = slamch( 'Safe minimum' )
193 bignum = one / smlnum
194 CALL slabad( smlnum, bignum )
195 anorm = slantb( '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 STBT06
203*

◆ stpt01()

subroutine stpt01 ( character uplo,
character diag,
integer n,
real, dimension( * ) ap,
real, dimension( * ) ainvp,
real rcond,
real, dimension( * ) work,
real resid )

STPT01

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

Definition at line 107 of file stpt01.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 REAL RCOND, RESID
117* ..
118* .. Array Arguments ..
119 REAL AINVP( * ), AP( * ), WORK( * )
120* ..
121*
122* =====================================================================
123*
124* .. Parameters ..
125 REAL ZERO, ONE
126 parameter( zero = 0.0e+0, one = 1.0e+0 )
127* ..
128* .. Local Scalars ..
129 LOGICAL UNITD
130 INTEGER J, JC
131 REAL AINVNM, ANORM, EPS
132* ..
133* .. External Functions ..
134 LOGICAL LSAME
135 REAL SLAMCH, SLANTP
136 EXTERNAL lsame, slamch, slantp
137* ..
138* .. External Subroutines ..
139 EXTERNAL stpmv
140* ..
141* .. Intrinsic Functions ..
142 INTRINSIC real
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 = slamch( 'Epsilon' )
157 anorm = slantp( '1', uplo, diag, n, ap, work )
158 ainvnm = slantp( '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 stpmv( '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 stpmv( '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 = slantp( '1', uplo, 'Non-unit', n, ainvp, work )
206*
207 resid = ( ( resid*rcond ) / real( n ) ) / eps
208*
209 RETURN
210*
211* End of STPT01
212*

◆ stpt02()

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

STPT02

Purpose:
!>
!> STPT02 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 REAL 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 REAL 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 REAL 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 REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*X - B) / ( norm(op(A)) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 140 of file stpt02.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 REAL RESID
151* ..
152* .. Array Arguments ..
153 REAL AP( * ), B( LDB, * ), WORK( * ), X( LDX, * )
154* ..
155*
156* =====================================================================
157*
158* .. Parameters ..
159 REAL ZERO, ONE
160 parameter( zero = 0.0e+0, one = 1.0e+0 )
161* ..
162* .. Local Scalars ..
163 INTEGER J
164 REAL ANORM, BNORM, EPS, XNORM
165* ..
166* .. External Functions ..
167 LOGICAL LSAME
168 REAL SASUM, SLAMCH, SLANTP
169 EXTERNAL lsame, sasum, slamch, slantp
170* ..
171* .. External Subroutines ..
172 EXTERNAL saxpy, scopy, stpmv
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 = slantp( '1', uplo, diag, n, ap, work )
190 ELSE
191 anorm = slantp( 'I', uplo, diag, n, ap, work )
192 END IF
193*
194* Exit with RESID = 1/EPS if ANORM = 0.
195*
196 eps = slamch( '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 scopy( n, x( 1, j ), 1, work, 1 )
208 CALL stpmv( uplo, trans, diag, n, ap, work, 1 )
209 CALL saxpy( n, -one, b( 1, j ), 1, work, 1 )
210 bnorm = sasum( n, work, 1 )
211 xnorm = sasum( 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 STPT02
222*

◆ stpt03()

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

STPT03

Purpose:
!>
!> STPT03 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 REAL array, dimension (N*(N+1)/2)
!>          The upper or lower triangular matrix A, packed columnwise in
!>          a linear array.  The j-th column of A is stored in the array
!>          AP as follows:
!>          if UPLO = 'U', AP((j-1)*j/2 + i) = A(i,j) for 1<=i<=j;
!>          if UPLO = 'L',
!>             AP((j-1)*(n-j) + j*(j+1)/2 + i-j) = A(i,j) for j<=i<=n.
!>
[in]SCALE
!>          SCALE is REAL
!>          The scaling factor s used in solving the triangular system.
!>
[in]CNORM
!>          CNORM is REAL array, dimension (N)
!>          The 1-norms of the columns of A, not counting the diagonal.
!>
[in]TSCAL
!>          TSCAL is REAL
!>          The scaling factor used in computing the 1-norms in CNORM.
!>          CNORM actually contains the column norms of TSCAL*A.
!>
[in]X
!>          X is REAL 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 REAL 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 REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 159 of file stpt03.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 REAL RESID, SCALE, TSCAL
170* ..
171* .. Array Arguments ..
172 REAL AP( * ), B( LDB, * ), CNORM( * ), WORK( * ),
173 $ X( LDX, * )
174* ..
175*
176* =====================================================================
177*
178* .. Parameters ..
179 REAL ONE, ZERO
180 parameter( one = 1.0e+0, zero = 0.0e+0 )
181* ..
182* .. Local Scalars ..
183 INTEGER IX, J, JJ
184 REAL BIGNUM, EPS, ERR, SMLNUM, TNORM, XNORM, XSCAL
185* ..
186* .. External Functions ..
187 LOGICAL LSAME
188 INTEGER ISAMAX
189 REAL SLAMCH
190 EXTERNAL lsame, isamax, slamch
191* ..
192* .. External Subroutines ..
193 EXTERNAL saxpy, scopy, slabad, sscal, stpmv
194* ..
195* .. Intrinsic Functions ..
196 INTRINSIC abs, max, real
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 = slamch( 'Epsilon' )
207 smlnum = slamch( 'Safe minimum' )
208 bignum = one / smlnum
209 CALL slabad( smlnum, bignum )
210*
211* Compute the norm of the triangular matrix A using the column
212* norms already computed by SLATPS.
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 scopy( n, x( 1, j ), 1, work, 1 )
241 ix = isamax( n, work, 1 )
242 xnorm = max( one, abs( x( ix, j ) ) )
243 xscal = ( one / xnorm ) / real( n )
244 CALL sscal( n, xscal, work, 1 )
245 CALL stpmv( uplo, trans, diag, n, ap, work, 1 )
246 CALL saxpy( n, -scale*xscal, b( 1, j ), 1, work, 1 )
247 ix = isamax( n, work, 1 )
248 err = tscal*abs( work( ix ) )
249 ix = isamax( 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 STPT03
271*

◆ stpt05()

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

STPT05

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

Definition at line 172 of file stpt05.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 REAL AP( * ), B( LDB, * ), BERR( * ), FERR( * ),
185 $ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
186* ..
187*
188* =====================================================================
189*
190* .. Parameters ..
191 REAL ZERO, ONE
192 parameter( zero = 0.0e+0, one = 1.0e+0 )
193* ..
194* .. Local Scalars ..
195 LOGICAL NOTRAN, UNIT, UPPER
196 INTEGER I, IFU, IMAX, J, JC, K
197 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
198* ..
199* .. External Functions ..
200 LOGICAL LSAME
201 INTEGER ISAMAX
202 REAL SLAMCH
203 EXTERNAL lsame, isamax, slamch
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 = slamch( 'Epsilon' )
219 unfl = slamch( '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 = isamax( 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 STPT05
320*

◆ stpt06()

subroutine stpt06 ( real rcond,
real rcondc,
character uplo,
character diag,
integer n,
real, dimension( * ) ap,
real, dimension( * ) work,
real rat )

STPT06

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

Definition at line 110 of file stpt06.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 REAL RAT, RCOND, RCONDC
120* ..
121* .. Array Arguments ..
122 REAL AP( * ), WORK( * )
123* ..
124*
125* =====================================================================
126*
127* .. Parameters ..
128 REAL ZERO, ONE
129 parameter( zero = 0.0e+0, one = 1.0e+0 )
130* ..
131* .. Local Scalars ..
132 REAL ANORM, BIGNUM, EPS, RMAX, RMIN, SMLNUM
133* ..
134* .. External Functions ..
135 REAL SLAMCH, SLANTP
136 EXTERNAL slamch, slantp
137* ..
138* .. Intrinsic Functions ..
139 INTRINSIC max, min
140* ..
141* .. External Subroutines ..
142 EXTERNAL slabad
143* ..
144* .. Executable Statements ..
145*
146 eps = slamch( '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 = slamch( 'Safe minimum' )
179 bignum = one / smlnum
180 CALL slabad( smlnum, bignum )
181 anorm = slantp( '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 STPT06
189*

◆ strt01()

subroutine strt01 ( character uplo,
character diag,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( ldainv, * ) ainv,
integer ldainv,
real rcond,
real, dimension( * ) work,
real resid )

STRT01

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

Definition at line 122 of file strt01.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 REAL RCOND, RESID
133* ..
134* .. Array Arguments ..
135 REAL A( LDA, * ), AINV( LDAINV, * ), WORK( * )
136* ..
137*
138* =====================================================================
139*
140* .. Parameters ..
141 REAL ZERO, ONE
142 parameter( zero = 0.0e+0, one = 1.0e+0 )
143* ..
144* .. Local Scalars ..
145 INTEGER J
146 REAL AINVNM, ANORM, EPS
147* ..
148* .. External Functions ..
149 LOGICAL LSAME
150 REAL SLAMCH, SLANTR
151 EXTERNAL lsame, slamch, slantr
152* ..
153* .. External Subroutines ..
154 EXTERNAL strmv
155* ..
156* .. Intrinsic Functions ..
157 INTRINSIC real
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 = slamch( 'Epsilon' )
172 anorm = slantr( '1', uplo, diag, n, n, a, lda, work )
173 ainvnm = slantr( '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 strmv( '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 strmv( '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 = slantr( '1', uplo, 'Non-unit', n, n, ainv, ldainv, work )
212*
213 resid = ( ( resid*rcond ) / real( n ) ) / eps
214*
215 RETURN
216*
217* End of STRT01
218*

◆ strt02()

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

STRT02

Purpose:
!>
!> STRT02 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 REAL 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 REAL 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 REAL 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 REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*X - B) / ( norm(op(A)) * norm(X) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 148 of file strt02.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 REAL RESID
159* ..
160* .. Array Arguments ..
161 REAL A( LDA, * ), B( LDB, * ), WORK( * ),
162 $ X( LDX, * )
163* ..
164*
165* =====================================================================
166*
167* .. Parameters ..
168 REAL ZERO, ONE
169 parameter( zero = 0.0e+0, one = 1.0e+0 )
170* ..
171* .. Local Scalars ..
172 INTEGER J
173 REAL ANORM, BNORM, EPS, XNORM
174* ..
175* .. External Functions ..
176 LOGICAL LSAME
177 REAL SASUM, SLAMCH, SLANTR
178 EXTERNAL lsame, sasum, slamch, slantr
179* ..
180* .. External Subroutines ..
181 EXTERNAL saxpy, scopy, strmv
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 = slantr( '1', uplo, diag, n, n, a, lda, work )
199 ELSE
200 anorm = slantr( 'I', uplo, diag, n, n, a, lda, work )
201 END IF
202*
203* Exit with RESID = 1/EPS if ANORM = 0.
204*
205 eps = slamch( '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 scopy( n, x( 1, j ), 1, work, 1 )
217 CALL strmv( uplo, trans, diag, n, a, lda, work, 1 )
218 CALL saxpy( n, -one, b( 1, j ), 1, work, 1 )
219 bnorm = sasum( n, work, 1 )
220 xnorm = sasum( 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 STRT02
231*

◆ strt03()

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

STRT03

Purpose:
!>
!> STRT03 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 REAL array, dimension (LDA,N)
!>          The triangular matrix A.  If UPLO = 'U', the leading n by n
!>          upper triangular part of the array A contains the upper
!>          triangular matrix, and the strictly lower triangular part of
!>          A is not referenced.  If UPLO = 'L', the leading n by n lower
!>          triangular part of the array A contains the lower triangular
!>          matrix, and the strictly upper triangular part of A is not
!>          referenced.  If DIAG = 'U', the diagonal elements of A are
!>          also not referenced and are assumed to be 1.
!>
[in]LDA
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,N).
!>
[in]SCALE
!>          SCALE is REAL
!>          The scaling factor s used in solving the triangular system.
!>
[in]CNORM
!>          CNORM is REAL array, dimension (N)
!>          The 1-norms of the columns of A, not counting the diagonal.
!>
[in]TSCAL
!>          TSCAL is REAL
!>          The scaling factor used in computing the 1-norms in CNORM.
!>          CNORM actually contains the column norms of TSCAL*A.
!>
[in]X
!>          X is REAL 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 REAL 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 REAL array, dimension (N)
!>
[out]RESID
!>          RESID is REAL
!>          The maximum over the number of right hand sides of
!>          norm(op(A)*x - s*b) / ( norm(op(A)) * norm(x) * EPS ).
!>
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 167 of file strt03.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 REAL RESID, SCALE, TSCAL
178* ..
179* .. Array Arguments ..
180 REAL A( LDA, * ), B( LDB, * ), CNORM( * ),
181 $ WORK( * ), X( LDX, * )
182* ..
183*
184* =====================================================================
185*
186* .. Parameters ..
187 REAL ONE, ZERO
188 parameter( one = 1.0e+0, zero = 0.0e+0 )
189* ..
190* .. Local Scalars ..
191 INTEGER IX, J
192 REAL BIGNUM, EPS, ERR, SMLNUM, TNORM, XNORM, XSCAL
193* ..
194* .. External Functions ..
195 LOGICAL LSAME
196 INTEGER ISAMAX
197 REAL SLAMCH
198 EXTERNAL lsame, isamax, slamch
199* ..
200* .. External Subroutines ..
201 EXTERNAL saxpy, scopy, slabad, sscal, strmv
202* ..
203* .. Intrinsic Functions ..
204 INTRINSIC abs, max, real
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 = slamch( 'Epsilon' )
215 smlnum = slamch( 'Safe minimum' )
216 bignum = one / smlnum
217 CALL slabad( smlnum, bignum )
218*
219* Compute the norm of the triangular matrix A using the column
220* norms already computed by SLATRS.
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 scopy( n, x( 1, j ), 1, work, 1 )
239 ix = isamax( n, work, 1 )
240 xnorm = max( one, abs( x( ix, j ) ) )
241 xscal = ( one / xnorm ) / real( n )
242 CALL sscal( n, xscal, work, 1 )
243 CALL strmv( uplo, trans, diag, n, a, lda, work, 1 )
244 CALL saxpy( n, -scale*xscal, b( 1, j ), 1, work, 1 )
245 ix = isamax( n, work, 1 )
246 err = tscal*abs( work( ix ) )
247 ix = isamax( 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 STRT03
269*

◆ strt05()

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

STRT05

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

Definition at line 179 of file strt05.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 REAL A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
192 $ RESLTS( * ), X( LDX, * ), XACT( LDXACT, * )
193* ..
194*
195* =====================================================================
196*
197* .. Parameters ..
198 REAL ZERO, ONE
199 parameter( zero = 0.0e+0, one = 1.0e+0 )
200* ..
201* .. Local Scalars ..
202 LOGICAL NOTRAN, UNIT, UPPER
203 INTEGER I, IFU, IMAX, J, K
204 REAL AXBI, DIFF, EPS, ERRBND, OVFL, TMP, UNFL, XNORM
205* ..
206* .. External Functions ..
207 LOGICAL LSAME
208 INTEGER ISAMAX
209 REAL SLAMCH
210 EXTERNAL lsame, isamax, slamch
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 = slamch( 'Epsilon' )
226 unfl = slamch( '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 = isamax( 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 STRT05
319*

◆ strt06()

subroutine strt06 ( real rcond,
real rcondc,
character uplo,
character diag,
integer n,
real, dimension( lda, * ) a,
integer lda,
real, dimension( * ) work,
real rat )

STRT06

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

Definition at line 119 of file strt06.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 REAL RAT, RCOND, RCONDC
130* ..
131* .. Array Arguments ..
132 REAL A( LDA, * ), WORK( * )
133* ..
134*
135* =====================================================================
136*
137* .. Parameters ..
138 REAL ZERO, ONE
139 parameter( zero = 0.0e+0, one = 1.0e+0 )
140* ..
141* .. Local Scalars ..
142 REAL ANORM, BIGNUM, EPS, RMAX, RMIN, SMLNUM
143* ..
144* .. External Functions ..
145 REAL SLAMCH, SLANTR
146 EXTERNAL slamch, slantr
147* ..
148* .. Intrinsic Functions ..
149 INTRINSIC max, min
150* ..
151* .. External Subroutines ..
152 EXTERNAL slabad
153* ..
154* .. Executable Statements ..
155*
156 eps = slamch( '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 = slamch( 'Safe minimum' )
189 bignum = one / smlnum
190 CALL slabad( smlnum, bignum )
191 anorm = slantr( '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 STRT06
199*