diff options
| author | Julie <julie@cs.utk.edu> | 2016-11-15 20:39:35 -0800 |
|---|---|---|
| committer | Julie <julie@cs.utk.edu> | 2016-11-15 20:39:35 -0800 |
| commit | ead2c73f1a6dad1342bf32987c0b2f2eaf61f18a (patch) | |
| tree | b82e9ad49e12960ad410a418d03d68adc7e2e653 /TESTING | |
| parent | 39698bc46ca55081ebd94c81c5c95771c9f125cd (diff) | |
Added (S,D,C,Z) (SY,HE) routines, drivers for new rook code
Close #82
Added routines for new factorization code for symmetric indefinite
( or Hermitian indefinite ) matrices with bounded Bunch-Kaufman
( rook ) pivoting algorithm.
New more efficient storage format for factors U ( or L ),
block-diagonal matrix D, and pivoting information stored in IPIV:
factor L is stored explicitly in lower triangle of A;
diagonal of D is stored on the diagonal of A;
subdiagonal elements of D are stored in array E;
IPIV format is the same as in *_ROOK routines, but differs
from SY Bunch-Kaufman routines (e.g. *SYTRF).
The factorization output of these new rook _RK routines is not
compatible
with the existing _ROOK routines and vice versa. This new factorization
format is designed in such a way, that there is a possibility in the
future
to write new Bunch-Kaufman routines that conform to this new
factorization format.
Then the future Bunch-Kaufman routines could share solver
*TRS_3,inversion *TRI_3
and condition estimator *CON_3.
To convert between the factorization formats in both ways the following
routines
are developed:
CONVERSION ROUTINES BETWEEN FACTORIZATION FORMATS
DOUBLE PRECISION (symmetric indefinite matrices):
new file: SRC/dsyconvf.f
new file: SRC/dsyconvf_rook.f
REAL (symmetric indefinite matrices):
new file: SRC/csyconvf.f
new file: SRC/csyconvf_rook.f
COMPLEX*16 (symmetric indefinite and Hermitian indefinite matrices):
new file: SRC/zsyconvf.f
new file: SRC/zsyconvf_rook.f
COMPLEX (symmetric indefinite and Hermitian indefinite matrices):
new file: SRC/ssyconvf.f
new file: SRC/ssyconvf_rook.f
*SYCONVF routine converts between old Bunch-Kaufman storage format (
denote (L1,D1,IPIV1) )
that is used by *SYTRF and new rook storage format ( denote (L2,D2,
IPIV2))
that is used by *SYTRF_RK
*SYCONVF_ROOK routine between old rook storage format ( denote
(L1,D1,IPIV2) )
that is used by *SYTRF_ROOK and new rook storage format ( denote
(L2,D2, IPIV2))
that is used by *SYTRF_RK
ROUTINES AND DRIVERS
DOUBLE PRECISION (symmetric indefinite matrices):
new file: SRC/dsytf2_rk.f BLAS2 unblocked factorization
new file: SRC/dlasyf_rk.f BLAS3 auxiliary blocked partial
factorization
new file: SRC/dsytrf_rk.f BLAS3 blocked factorization
new file: SRC/dsytrs_3.f BLAS3 solver
new file: SRC/dsycon_3.f BLAS3 condition number estimator
new file: SRC/dsytri_3.f BLAS3 inversion, sets the size of work array
and calls *sytri_3x
new file: SRC/dsytri_3x.f BLAS3 auxiliary inversion, actually
computes blocked inversion
new file: SRC/dsysv_rk.f BLAS3 solver driver
REAL (symmetric indefinite matrices):
new file: SRC/ssytf2_rk.f BLAS2 unblocked factorization
new file: SRC/slasyf_rk.f BLAS3 auxiliary blocked partial
factorization
new file: SRC/ssytrf_rk.f BLAS3 blocked factorization
new file: SRC/ssytrs_3.f BLAS3 solver
new file: SRC/ssycon_3.f BLAS3 condition number estimator
new file: SRC/ssytri_3.f BLAS3 inversion, sets the size of work array
and calls *sytri_3x
new file: SRC/ssytri_3x.f BLAS3 auxiliary inversion, actually
computes blocked inversion
new file: SRC/ssysv_rk.f BLAS3 solver driver
COMPLEX*16 (symmetric indefinite matrices):
new file: SRC/zsytf2_rk.f BLAS2 unblocked factorization
new file: SRC/zlasyf_rk.f BLAS3 auxiliary blocked partial
factorization
new file: SRC/zsytrf_rk.f BLAS3 blocked factorization
new file: SRC/zsytrs_3.f BLAS3 solver
new file: SRC/zsycon_3.f BLAS3 condition number estimator
new file: SRC/zsytri_3.f BLAS3 inversion, sets the size of work array
and calls *sytri_3x
new file: SRC/zsytri_3x.f BLAS3 auxiliary inversion, actually
computes blocked inversion
new file: SRC/zsysv_rk.f BLAS3 solver driver
COMPLEX*16 (Hermitian indefinite matrices):
new file: SRC/zhetf2_rk.f BLAS2 unblocked factorization
new file: SRC/zlahef_rk.f BLAS3 auxiliary blocked partial
factorization
new file: SRC/zhetrf_rk.f BLAS3 blocked factorization
new file: SRC/zhetrs_3.f BLAS3 solver
new file: SRC/zhecon_3.f BLAS3 condition number estimator
new file: SRC/zhetri_3.f BLAS3 inversion, sets the size of work array
and calls *sytri_3x
new file: SRC/zhetri_3x.f BLAS3 auxiliary inversion, actually
computes blocked inversion
new file: SRC/zhesv_rk.f BLAS3 solver driver
COMPLEX (symmetric indefinite matrices):
new file: SRC/csytf2_rk.f BLAS2 unblocked factorization
new file: SRC/clasyf_rk.f BLAS3 auxiliary blocked partial
factorization
new file: SRC/csytrf_rk.f BLAS3 blocked factorization
new file: SRC/csytrs_3.f BLAS3 solver
new file: SRC/csycon_3.f BLAS3 condition number estimator
new file: SRC/csytri_3.f BLAS3 inversion, sets the size of work array
and calls *sytri_3x
new file: SRC/csytri_3x.f BLAS3 auxiliary inversion, actually
computes blocked inversion
new file: SRC/csysv_rk.f BLAS3 solver driver
COMPLEX (Hermitian indefinite matrices):
new file: SRC/chetf2_rk.f BLAS2 unblocked factorization
new file: SRC/clahef_rk.f BLAS3 auxiliary blocked partial
factorization
new file: SRC/chetrf_rk.f BLAS3 blocked factorization
new file: SRC/chetrs_3.f BLAS3 solver
new file: SRC/checon_3.f BLAS3 condition number estimator
new file: SRC/chetri_3.f BLAS3 inversion, sets the size of work array
and calls *sytri_3x
new file: SRC/chetri_3x.f BLAS3 auxiliary inversion, actually
computes blocked inversion
new file: SRC/chesv_rk.f BLAS3 solver driver
MISC
modified: SRC/CMakeLists.txt
modified: SRC/Makefile
TEST CODE
modified: TESTING/LIN/CMakeLists.txt
modified: TESTING/LIN/Makefile
modified: TESTING/LIN/aladhd.f
modified: TESTING/LIN/alaerh.f
modified: TESTING/LIN/alahd.f
DOUBLE PRECISION (symmetric indefinite matrices):
modified: TESTING/LIN/dchkaa.f
modified: TESTING/LIN/derrsy.f
modified: TESTING/LIN/derrsyx.f
modified: TESTING/LIN/derrvx.f
modified: TESTING/LIN/derrvxx.f
modified: TESTING/dtest.in
new file: TESTING/LIN/dchksy_rk.f
new file: TESTING/LIN/ddrvsy_rk.f
new file: TESTING/LIN/dsyt01_3.f
REAL (symmetric indefinite matrices):
modified: TESTING/LIN/schkaa.f
modified: TESTING/LIN/serrsy.f
modified: TESTING/LIN/serrsyx.f
modified: TESTING/LIN/serrvx.f
modified: TESTING/LIN/serrvxx.f
modified: TESTING/stest.in
new file: TESTING/LIN/schksy_rk.f
new file: TESTING/LIN/sdrvsy_rk.f
new file: TESTING/LIN/ssyt01_3.f
COMPLEX*16 (symmetric indefinite and Hermitian indefinite matrices):
modified: TESTING/LIN/zchkaa.f
modified: TESTING/LIN/zerrsy.f
modified: TESTING/LIN/zerrsyx.f
modified: TESTING/LIN/zerrhe.f
modified: TESTING/LIN/zerrhex.f
modified: TESTING/LIN/zerrvx.f
modified: TESTING/LIN/zerrvxx.f
modified: TESTING/ztest.in
new file: TESTING/LIN/zchksy_rk.f
new file: TESTING/LIN/zdrvsy_rk.f
new file: TESTING/LIN/zsyt01_3.f
new file: TESTING/LIN/zchkhe_rk.f
new file: TESTING/LIN/zdrvhe_rk.f
new file: TESTING/LIN/zhet01_3.f
COMPLEX (symmetric indefinite and Hermitian indefinite matrices):
modified: TESTING/LIN/cchkaa.f
modified: TESTING/LIN/cerrsy.f
modified: TESTING/LIN/cerrsyx.f
modified: TESTING/LIN/cerrhe.f
modified: TESTING/LIN/cerrhex.f
modified: TESTING/LIN/cerrvx.f
modified: TESTING/LIN/cerrvxx.f
modified: TESTING/ctest.in
new file: TESTING/LIN/cchksy_rk.f
new file: TESTING/LIN/cdrvsy_rk.f
new file: TESTING/LIN/csyt01_3.f
new file: TESTING/LIN/cchkhe_rk.f
new file: TESTING/LIN/cdrvhe_rk.f
new file: TESTING/LIN/chet01_3.f
Diffstat (limited to 'TESTING')
51 files changed, 12941 insertions, 562 deletions
diff --git a/TESTING/LIN/CMakeLists.txt b/TESTING/LIN/CMakeLists.txt index 02a18e14..b3627a3f 100644 --- a/TESTING/LIN/CMakeLists.txt +++ b/TESTING/LIN/CMakeLists.txt @@ -10,10 +10,10 @@ set(SLINTST schkaa.f schkeq.f schkgb.f schkge.f schkgt.f schklq.f schkpb.f schkpo.f schkps.f schkpp.f schkpt.f schkq3.f schkql.f schkqr.f schkrq.f - schksp.f schksy.f schksy_rook.f schksy_aa.f schktb.f schktp.f schktr.f + schksp.f schksy.f schksy_rook.f schksy_rk.f schksy_aa.f schktb.f schktp.f schktr.f schktz.f sdrvgt.f sdrvls.f sdrvpb.f - sdrvpp.f sdrvpt.f sdrvsp.f sdrvsy.f sdrvsy_rook.f sdrvsy_aa.f + sdrvpp.f sdrvpt.f sdrvsp.f sdrvsy.f sdrvsy_rook.f sdrvsy_rk.f sdrvsy_aa.f serrgt.f serrlq.f serrls.f serrpo.f serrps.f serrql.f serrqp.f serrqr.f serrrq.f serrsy.f serrtr.f serrtz.f serrvx.f @@ -29,7 +29,7 @@ set(SLINTST schkaa.f sqrt01.f sqrt01p.f sqrt02.f sqrt03.f sqrt11.f sqrt12.f sqrt13.f sqrt14.f sqrt15.f sqrt16.f sqrt17.f srqt01.f srqt02.f srqt03.f srzt01.f srzt02.f - sspt01.f ssyt01.f ssyt01_rook.f ssyt01_aa.f + sspt01.f ssyt01.f ssyt01_rook.f ssyt01_3.f ssyt01_aa.f stbt02.f stbt03.f stbt05.f stbt06.f stpt01.f stpt02.f stpt03.f stpt05.f stpt06.f strt01.f strt02.f strt03.f strt05.f strt06.f @@ -46,13 +46,13 @@ endif() set(CLINTST cchkaa.f cchkeq.f cchkgb.f cchkge.f cchkgt.f - cchkhe.f cchkhe_rook.f cchkhe_aa.f cchkhp.f cchklq.f cchkpb.f + cchkhe.f cchkhe_rook.f cchkhe_rk.f cchkhe_aa.f cchkhp.f cchklq.f cchkpb.f cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkql.f - cchkqr.f cchkrq.f cchksp.f cchksy.f cchksy_rook.f cchktb.f + cchkqr.f cchkrq.f cchksp.f cchksy.f cchksy_rook.f cchksy_rk.f cchktb.f cchktp.f cchktr.f cchktz.f - cdrvgt.f cdrvhe.f cdrvhe_rook.f cdrvhe_aa.f cdrvhp.f + cdrvgt.f cdrvhe.f cdrvhe_rook.f cdrvhe_rk.f cdrvhe_aa.f cdrvhp.f cdrvls.f cdrvpb.f cdrvpp.f cdrvpt.f - cdrvsp.f cdrvsy.f cdrvsy_rook.f + cdrvsp.f cdrvsy.f cdrvsy_rook.f cdrvsy_rk.f cerrgt.f cerrhe.f cerrlq.f cerrls.f cerrps.f cerrql.f cerrqp.f cerrqr.f cerrrq.f cerrsy.f cerrtr.f cerrtz.f @@ -60,7 +60,8 @@ set(CLINTST cchkaa.f cgbt01.f cgbt02.f cgbt05.f cgelqs.f cgeqls.f cgeqrs.f cgerqs.f cget01.f cget02.f cget03.f cget04.f cget07.f cgtt01.f cgtt02.f - cgtt05.f chet01.f chet01_rook.f chet01_aa.f chpt01.f claipd.f claptm.f clarhs.f clatb4.f clatb5.f + cgtt05.f chet01.f chet01_rook.f chet01_3.f chet01_aa.f + chpt01.f claipd.f claptm.f clarhs.f clatb4.f clatb5.f clatsp.f clatsy.f clattb.f clattp.f clattr.f clavhe.f clavhe_rook.f clavhp.f clavsp.f clavsy.f clavsy_rook.f clqt01.f clqt02.f clqt03.f cpbt01.f cpbt02.f cpbt05.f @@ -71,7 +72,7 @@ set(CLINTST cchkaa.f cqrt12.f cqrt13.f cqrt14.f cqrt15.f cqrt16.f cqrt17.f crqt01.f crqt02.f crqt03.f crzt01.f crzt02.f csbmv.f cspt01.f - cspt02.f cspt03.f csyt01.f csyt01_rook.f csyt02.f csyt03.f + cspt02.f cspt03.f csyt01.f csyt01_rook.f csyt01_3.f csyt02.f csyt03.f ctbt02.f ctbt03.f ctbt05.f ctbt06.f ctpt01.f ctpt02.f ctpt03.f ctpt05.f ctpt06.f ctrt01.f ctrt02.f ctrt03.f ctrt05.f ctrt06.f @@ -91,10 +92,10 @@ set(DLINTST dchkaa.f dchkeq.f dchkgb.f dchkge.f dchkgt.f dchklq.f dchkpb.f dchkpo.f dchkps.f dchkpp.f dchkpt.f dchkq3.f dchkql.f dchkqr.f dchkrq.f - dchksp.f dchksy.f dchksy_rook.f dchksy_aa.f dchktb.f dchktp.f dchktr.f + dchksp.f dchksy.f dchksy_rook.f dchksy_rk.f dchksy_aa.f dchktb.f dchktp.f dchktr.f dchktz.f ddrvgt.f ddrvls.f ddrvpb.f - ddrvpp.f ddrvpt.f ddrvsp.f ddrvsy.f ddrvsy_rook.f ddrvsy_aa.f + ddrvpp.f ddrvpt.f ddrvsp.f ddrvsy.f ddrvsy_rook.f ddrvsy_rk.f ddrvsy_aa.f derrgt.f derrlq.f derrls.f derrps.f derrql.f derrqp.f derrqr.f derrrq.f derrsy.f derrtr.f derrtz.f derrvx.f @@ -110,7 +111,7 @@ set(DLINTST dchkaa.f dqrt01.f dqrt01p.f dqrt02.f dqrt03.f dqrt11.f dqrt12.f dqrt13.f dqrt14.f dqrt15.f dqrt16.f dqrt17.f drqt01.f drqt02.f drqt03.f drzt01.f drzt02.f - dspt01.f dsyt01.f dsyt01_rook.f dsyt01_aa.f + dspt01.f dsyt01.f dsyt01_rook.f dsyt01_3.f dsyt01_aa.f dtbt02.f dtbt03.f dtbt05.f dtbt06.f dtpt01.f dtpt02.f dtpt03.f dtpt05.f dtpt06.f dtrt01.f dtrt02.f dtrt03.f dtrt05.f dtrt06.f @@ -129,13 +130,13 @@ endif() set(ZLINTST zchkaa.f zchkeq.f zchkgb.f zchkge.f zchkgt.f - zchkhe.f zchkhe_rook.f zchkhe_aa.f zchkhp.f zchklq.f zchkpb.f + zchkhe.f zchkhe_rook.f zchkhe_rk.f zchkhe_aa.f zchkhp.f zchklq.f zchkpb.f zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkql.f - zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_rook.f zchktb.f + zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_rook.f zchksy_rk.f zchktb.f zchktp.f zchktr.f zchktz.f - zdrvgt.f zdrvhe.f zdrvhe_rook.f zdrvhe_aa.f zdrvhp.f + zdrvgt.f zdrvhe.f zdrvhe_rook.f zdrvhe_rk.f zdrvhe_aa.f zdrvhp.f zdrvls.f zdrvpb.f zdrvpp.f zdrvpt.f - zdrvsp.f zdrvsy.f zdrvsy_rook.f + zdrvsp.f zdrvsy.f zdrvsy_rook.f zdrvsy_rk.f zerrgt.f zerrhe.f zerrlq.f zerrls.f zerrps.f zerrql.f zerrqp.f zerrqr.f zerrrq.f zerrsy.f zerrtr.f zerrtz.f @@ -143,7 +144,8 @@ set(ZLINTST zchkaa.f zgbt01.f zgbt02.f zgbt05.f zgelqs.f zgeqls.f zgeqrs.f zgerqs.f zget01.f zget02.f zget03.f zget04.f zget07.f zgtt01.f zgtt02.f - zgtt05.f zhet01.f zhet01_rook.f zhet01_aa.f zhpt01.f zlaipd.f zlaptm.f zlarhs.f zlatb4.f zlatb5.f + zgtt05.f zhet01.f zhet01_rook.f zhet01_3.f zhet01_aa.f + zhpt01.f zlaipd.f zlaptm.f zlarhs.f zlatb4.f zlatb5.f zlatsp.f zlatsy.f zlattb.f zlattp.f zlattr.f zlavhe.f zlavhe_rook.f zlavhp.f zlavsp.f zlavsy.f zlavsy_rook.f zlqt01.f zlqt02.f zlqt03.f zpbt01.f zpbt02.f zpbt05.f @@ -154,7 +156,7 @@ set(ZLINTST zchkaa.f zqrt12.f zqrt13.f zqrt14.f zqrt15.f zqrt16.f zqrt17.f zrqt01.f zrqt02.f zrqt03.f zrzt01.f zrzt02.f zsbmv.f zspt01.f - zspt02.f zspt03.f zsyt01.f zsyt01_rook.f zsyt02.f zsyt03.f + zspt02.f zspt03.f zsyt01.f zsyt01_rook.f zsyt01_3.f zsyt02.f zsyt03.f ztbt02.f ztbt03.f ztbt05.f ztbt06.f ztpt01.f ztpt02.f ztpt03.f ztpt05.f ztpt06.f ztrt01.f ztrt02.f ztrt03.f ztrt05.f ztrt06.f diff --git a/TESTING/LIN/Makefile b/TESTING/LIN/Makefile index a9d1d177..15d5e94f 100644 --- a/TESTING/LIN/Makefile +++ b/TESTING/LIN/Makefile @@ -51,10 +51,10 @@ SLINTST = schkaa.o \ schkeq.o schkgb.o schkge.o schkgt.o \ schklq.o schkpb.o schkpo.o schkps.o schkpp.o \ schkpt.o schkq3.o schkql.o schkqr.o schkrq.o \ - schksp.o schksy.o schksy_rook.o schksy_aa.o schktb.o schktp.o schktr.o \ + schksp.o schksy.o schksy_rook.o schksy_rk.o schksy_aa.o schktb.o schktp.o schktr.o \ schktz.o \ sdrvgt.o sdrvls.o sdrvpb.o \ - sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy_rook.o sdrvsy_aa.o\ + sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy_rook.o sdrvsy_rk.o sdrvsy_aa.o\ serrgt.o serrlq.o serrls.o \ serrps.o serrql.o serrqp.o serrqr.o \ serrrq.o serrtr.o serrtz.o \ @@ -70,7 +70,7 @@ SLINTST = schkaa.o \ sqrt01.o sqrt01p.o sqrt02.o sqrt03.o sqrt11.o sqrt12.o \ sqrt13.o sqrt14.o sqrt15.o sqrt16.o sqrt17.o \ srqt01.o srqt02.o srqt03.o srzt01.o srzt02.o \ - sspt01.o ssyt01.o ssyt01_rook.o ssyt01_aa.o\ + sspt01.o ssyt01.o ssyt01_rook.o ssyt01_3.o ssyt01_aa.o\ stbt02.o stbt03.o stbt05.o stbt06.o stpt01.o \ stpt02.o stpt03.o stpt05.o stpt06.o strt01.o \ strt02.o strt03.o strt05.o strt06.o \ @@ -88,20 +88,21 @@ endif CLINTST = cchkaa.o \ cchkeq.o cchkgb.o cchkge.o cchkgt.o \ - cchkhe.o cchkhe_rook.o cchkhe_aa.o cchkhp.o cchklq.o cchkpb.o \ + cchkhe.o cchkhe_rook.o cchkhe_rk.o cchkhe_aa.o cchkhp.o cchklq.o cchkpb.o \ cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkql.o \ - cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_rook.o cchktb.o \ + cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_rook.o cchksy_rk.o cchktb.o \ cchktp.o cchktr.o cchktz.o \ - cdrvgt.o cdrvhe_rook.o cdrvhe_aa.o cdrvhp.o \ + cdrvgt.o cdrvhe_rook.o cdrvhe_rk.o cdrvhe_aa.o cdrvhp.o \ cdrvls.o cdrvpb.o cdrvpp.o cdrvpt.o \ - cdrvsp.o cdrvsy_rook.o \ + cdrvsp.o cdrvsy_rook.o cdrvsy_rk.o \ cerrgt.o cerrlq.o \ cerrls.o cerrps.o cerrql.o cerrqp.o \ cerrqr.o cerrrq.o cerrtr.o cerrtz.o \ cgbt01.o cgbt02.o cgbt05.o cgelqs.o cgeqls.o cgeqrs.o \ cgerqs.o cget01.o cget02.o \ cget03.o cget04.o cget07.o cgtt01.o cgtt02.o \ - cgtt05.o chet01.o chet01_rook.o chet01_aa.o chpt01.o claipd.o claptm.o clarhs.o clatb4.o clatb5.o \ + cgtt05.o chet01.o chet01_rook.o chet01_3.o \ + chet01_aa.o chpt01.o claipd.o claptm.o clarhs.o clatb4.o clatb5.o \ clatsp.o clatsy.o clattb.o clattp.o clattr.o \ clavhe.o clavhe_rook.o clavhp.o clavsp.o clavsy.o clavsy_rook.o clqt01.o \ clqt02.o clqt03.o cpbt01.o cpbt02.o cpbt05.o \ @@ -112,7 +113,7 @@ CLINTST = cchkaa.o \ cqrt12.o cqrt13.o cqrt14.o cqrt15.o cqrt16.o \ cqrt17.o crqt01.o crqt02.o crqt03.o crzt01.o crzt02.o \ csbmv.o cspt01.o \ - cspt02.o cspt03.o csyt01.o csyt01_rook.o csyt02.o csyt03.o \ + cspt02.o cspt03.o csyt01.o csyt01_rook.o csyt01_3.o csyt02.o csyt03.o \ ctbt02.o ctbt03.o ctbt05.o ctbt06.o ctpt01.o \ ctpt02.o ctpt03.o ctpt05.o ctpt06.o ctrt01.o \ ctrt02.o ctrt03.o ctrt05.o ctrt06.o \ @@ -133,10 +134,10 @@ DLINTST = dchkaa.o \ dchkeq.o dchkgb.o dchkge.o dchkgt.o \ dchklq.o dchkpb.o dchkpo.o dchkps.o dchkpp.o \ dchkpt.o dchkq3.o dchkql.o dchkqr.o dchkrq.o \ - dchksp.o dchksy.o dchksy_rook.o dchksy_aa.o dchktb.o dchktp.o dchktr.o \ + dchksp.o dchksy.o dchksy_rook.o dchksy_rk.o dchksy_aa.o dchktb.o dchktp.o dchktr.o \ dchktz.o \ ddrvgt.o ddrvls.o ddrvpb.o \ - ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy_rook.o ddrvsy_aa.o\ + ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy_rook.o ddrvsy_rk.o ddrvsy_aa.o \ derrgt.o derrlq.o derrls.o \ derrps.o derrql.o derrqp.o derrqr.o \ derrrq.o derrtr.o derrtz.o \ @@ -152,7 +153,7 @@ DLINTST = dchkaa.o \ dqrt01.o dqrt01p.o dqrt02.o dqrt03.o dqrt11.o dqrt12.o \ dqrt13.o dqrt14.o dqrt15.o dqrt16.o dqrt17.o \ drqt01.o drqt02.o drqt03.o drzt01.o drzt02.o \ - dspt01.o dsyt01.o dsyt01_rook.o dsyt01_aa.o\ + dspt01.o dsyt01.o dsyt01_rook.o dsyt01_3.o dsyt01_aa.o\ dtbt02.o dtbt03.o dtbt05.o dtbt06.o dtpt01.o \ dtpt02.o dtpt03.o dtpt05.o dtpt06.o dtrt01.o \ dtrt02.o dtrt03.o dtrt05.o dtrt06.o \ @@ -171,20 +172,21 @@ endif ZLINTST = zchkaa.o \ zchkeq.o zchkgb.o zchkge.o zchkgt.o \ - zchkhe.o zchkhe_rook.o zchkhe_aa.o zchkhp.o zchklq.o zchkpb.o \ + zchkhe.o zchkhe_rook.o zchkhe_rk.o zchkhe_aa.o zchkhp.o zchklq.o zchkpb.o \ zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkql.o \ - zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_rook.o zchktb.o \ + zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_rook.o zchksy_rk.o zchktb.o \ zchktp.o zchktr.o zchktz.o \ - zdrvgt.o zdrvhe_rook.o zdrvhe_aa.o zdrvhp.o \ + zdrvgt.o zdrvhe_rook.o zdrvhe_rk.o zdrvhe_aa.o zdrvhp.o \ zdrvls.o zdrvpb.o zdrvpp.o zdrvpt.o \ - zdrvsp.o zdrvsy_rook.o \ + zdrvsp.o zdrvsy_rook.o zdrvsy_rk.o \ zerrgt.o zerrlq.o \ zerrls.o zerrps.o zerrql.o zerrqp.o \ zerrqr.o zerrrq.o zerrtr.o zerrtz.o \ zgbt01.o zgbt02.o zgbt05.o zgelqs.o zgeqls.o zgeqrs.o \ zgerqs.o zget01.o zget02.o \ zget03.o zget04.o zget07.o zgtt01.o zgtt02.o \ - zgtt05.o zhet01.o zhet01_rook.o zhet01_aa.o zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o zlatb5.o \ + zgtt05.o zhet01.o zhet01_rook.o zhet01_3.o \ + zhet01_aa.o zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o zlatb5.o \ zlatsp.o zlatsy.o zlattb.o zlattp.o zlattr.o \ zlavhe.o zlavhe_rook.o zlavhp.o zlavsp.o zlavsy.o zlavsy_rook.o zlqt01.o \ zlqt02.o zlqt03.o zpbt01.o zpbt02.o zpbt05.o \ @@ -195,7 +197,7 @@ ZLINTST = zchkaa.o \ zqrt12.o zqrt13.o zqrt14.o zqrt15.o zqrt16.o \ zqrt17.o zrqt01.o zrqt02.o zrqt03.o zrzt01.o zrzt02.o \ zsbmv.o zspt01.o \ - zspt02.o zspt03.o zsyt01.o zsyt01_rook.o zsyt02.o zsyt03.o \ + zspt02.o zspt03.o zsyt01.o zsyt01_rook.o zsyt01_3.o zsyt02.o zsyt03.o \ ztbt02.o ztbt03.o ztbt05.o ztbt06.o ztpt01.o \ ztpt02.o ztpt03.o ztpt05.o ztpt06.o ztrt01.o \ ztrt02.o ztrt03.o ztrt05.o ztrt06.o \ diff --git a/TESTING/LIN/aladhd.f b/TESTING/LIN/aladhd.f index a45a56f3..130c57a8 100644 --- a/TESTING/LIN/aladhd.f +++ b/TESTING/LIN/aladhd.f @@ -50,7 +50,12 @@ *> _SY: Symmetric indefinite, *> with partial (Bunch-Kaufman) pivoting *> _SR: Symmetric indefinite, -*> with "rook" (bounded Bunch-Kaufman) pivoting +*> with rook (bounded Bunch-Kaufman) pivoting +*> _SK: Symmetric indefinite, +*> with rook (bounded Bunch-Kaufman) pivoting +*> ( new storage format for factors: +*> L and diagonal of D is stored in A, +*> subdiagonal of D is stored in E ) *> _SP: Symmetric indefinite packed, *> with partial (Bunch-Kaufman) pivoting *> _HA: (complex) Hermitian , @@ -58,7 +63,12 @@ *> _HE: (complex) Hermitian indefinite, *> with partial (Bunch-Kaufman) pivoting *> _HR: (complex) Hermitian indefinite, -*> with "rook" (bounded Bunch-Kaufman) pivoting +*> with rook (bounded Bunch-Kaufman) pivoting +*> _HK: (complex) Hermitian indefinite, +*> with rook (bounded Bunch-Kaufman) pivoting +*> ( new storage format for factors: +*> L and diagonal of D is stored in A, +*> subdiagonal of D is stored in E ) *> _HP: (complex) Hermitian indefinite packed, *> with partial (Bunch-Kaufman) pivoting *> The first character must be one of S, D, C, or Z (C or Z only @@ -73,17 +83,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date November 2016 * *> \ingroup aux_lin * * ===================================================================== SUBROUTINE ALADHD( IOUNIT, PATH ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2013 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -257,10 +267,16 @@ WRITE( IOUNIT, FMT = 9976 )6 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * - ELSE IF( LSAMEN( 2, P2, 'SR' ) ) THEN + ELSE IF( LSAMEN( 2, P2, 'SR' ) .OR. LSAMEN( 2, P2, 'SK') ) THEN * * SR: Symmetric indefinite full, -* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* with rook (bounded Bunch-Kaufman) pivoting algorithm +* +* SK: Symmetric indefinite full, +* with rook (bounded Bunch-Kaufman) pivoting algorithm, +* ( new storage format for factors: +* L and diagonal of D is stored in A, +* subdiagonal of D is stored in E ) * WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric' * @@ -322,10 +338,16 @@ WRITE( IOUNIT, FMT = 9976 )6 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * - ELSE IF( LSAMEN( 2, P2, 'HR' ) ) THEN + ELSE IF( LSAMEN( 2, P2, 'HR' ) .OR. LSAMEN( 2, P2, 'HK' ) ) THEN * * HR: Hermitian indefinite full, -* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* with rook (bounded Bunch-Kaufman) pivoting algorithm +* +* HK: Hermitian indefinite full, +* with rook (bounded Bunch-Kaufman) pivoting algorithm, +* ( new storage format for factors: +* L and diagonal of D is stored in A, +* subdiagonal of D is stored in E ) * WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian' * diff --git a/TESTING/LIN/alaerh.f b/TESTING/LIN/alaerh.f index 4fec4522..0346e10e 100644 --- a/TESTING/LIN/alaerh.f +++ b/TESTING/LIN/alaerh.f @@ -139,7 +139,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date November 2016 * *> \ingroup aux_lin * @@ -147,10 +147,10 @@ SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, $ N5, IMAT, NFAIL, NERRS, NOUT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2013 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -489,20 +489,28 @@ * ELSE IF( LSAMEN( 2, P2, 'SY' ) $ .OR. LSAMEN( 2, P2, 'SR' ) + $ .OR. LSAMEN( 2, P2, 'SK' ) $ .OR. LSAMEN( 2, P2, 'HE' ) - $ .OR. LSAMEN( 2, P2, 'HA' ) - $ .OR. LSAMEN( 2, P2, 'HR' ) ) THEN + $ .OR. LSAMEN( 2, P2, 'HR' ) + $ .OR. LSAMEN( 2, P2, 'HK' ) + $ .OR. LSAMEN( 2, P2, 'HA' ) ) THEN * * xSY: symmetric indefinite matrices * with partial (Bunch-Kaufman) pivoting; * xSR: symmetric indefinite matrices * with rook (bounded Bunch-Kaufman) pivoting; +* xSK: symmetric indefinite matrices +* with rook (bounded Bunch-Kaufman) pivoting, +* new storage format; * xHE: Hermitian indefinite matrices * with partial (Bunch-Kaufman) pivoting. -* xHA: Hermitian matrices -* Aasen Algorithm * xHR: Hermitian indefinite matrices * with rook (bounded Bunch-Kaufman) pivoting; +* xHK: Hermitian indefinite matrices +* with rook (bounded Bunch-Kaufman) pivoting, +* new storage format; +* xHA: Hermitian matrices +* Aasen Algorithm * UPLO = OPTS( 1: 1 ) IF( LSAMEN( 3, C3, 'TRF' ) ) THEN diff --git a/TESTING/LIN/alahd.f b/TESTING/LIN/alahd.f index 7919957f..d124d770 100644 --- a/TESTING/LIN/alahd.f +++ b/TESTING/LIN/alahd.f @@ -50,15 +50,25 @@ *> _SY: Symmetric indefinite, *> with partial (Bunch-Kaufman) pivoting *> _SR: Symmetric indefinite, -*> with "rook" (bounded Bunch-Kaufman) pivoting +*> with rook (bounded Bunch-Kaufman) pivoting +*> _SK: Symmetric indefinite, +*> with rook (bounded Bunch-Kaufman) pivoting +*> ( new storage format for factors: +*> L and diagonal of D is stored in A, +*> subdiagonal of D is stored in E ) *> _SP: Symmetric indefinite packed, *> with partial (Bunch-Kaufman) pivoting *> _HA: (complex) Hermitian , *> with Aasen Algorithm *> _HE: (complex) Hermitian indefinite, *> with partial (Bunch-Kaufman) pivoting -*> _HR: Symmetric indefinite, -*> with "rook" (bounded Bunch-Kaufman) pivoting +*> _HR: (complex) Hermitian indefinite, +*> with rook (bounded Bunch-Kaufman) pivoting +*> _HK: (complex) Hermitian indefinite, +*> with rook (bounded Bunch-Kaufman) pivoting +*> ( new storage format for factors: +*> L and diagonal of D is stored in A, +*> subdiagonal of D is stored in E ) *> _HP: (complex) Hermitian indefinite packed, *> with partial (Bunch-Kaufman) pivoting *> _TR: Triangular @@ -88,17 +98,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date November 2016 * *> \ingroup aux_lin * * ===================================================================== SUBROUTINE ALAHD( IOUNIT, PATH ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -304,10 +314,16 @@ WRITE( IOUNIT, FMT = 9955 )9 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * - ELSE IF( LSAMEN( 2, P2, 'SR' ) ) THEN + ELSE IF( LSAMEN( 2, P2, 'SR' ) .OR. LSAMEN( 2, P2, 'SK') ) THEN * * SR: Symmetric indefinite full, -* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* with rook (bounded Bunch-Kaufman) pivoting algorithm +* +* SK: Symmetric indefinite full, +* with rook (bounded Bunch-Kaufman) pivoting algorithm, +* ( new storage format for factors: +* L and diagonal of D is stored in A, +* subdiagonal of D is stored in E ) * WRITE( IOUNIT, FMT = 9892 )PATH, 'Symmetric' * @@ -401,10 +417,16 @@ WRITE( IOUNIT, FMT = 9955 )9 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * - ELSE IF( LSAMEN( 2, P2, 'HR' ) ) THEN + ELSE IF( LSAMEN( 2, P2, 'HR' ) .OR. LSAMEN( 2, P2, 'HR' ) ) THEN +* +* HR: Hermitian indefinite full, +* with rook (bounded Bunch-Kaufman) pivoting algorithm * -* HR: Symmetric indefinite full, -* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* HK: Hermitian indefinite full, +* with rook (bounded Bunch-Kaufman) pivoting algorithm, +* ( new storage format for factors: +* L and diagonal of D is stored in A, +* subdiagonal of D is stored in E ) * WRITE( IOUNIT, FMT = 9892 )PATH, 'Hermitian' * diff --git a/TESTING/LIN/cchkaa.f b/TESTING/LIN/cchkaa.f index cffaa1d6..cf04e78d 100644 --- a/TESTING/LIN/cchkaa.f +++ b/TESTING/LIN/cchkaa.f @@ -51,9 +51,11 @@ *> CPT 12 List types on next line if 0 < NTYPES < 12 *> CHE 10 List types on next line if 0 < NTYPES < 10 *> CHR 10 List types on next line if 0 < NTYPES < 10 +*> CHK 10 List types on next line if 0 < NTYPES < 10 *> CHA 10 List types on next line if 0 < NTYPES < 10 *> CHP 10 List types on next line if 0 < NTYPES < 10 *> CSY 11 List types on next line if 0 < NTYPES < 11 +*> CSK 11 List types on next line if 0 < NTYPES < 11 *> CSR 11 List types on next line if 0 < NTYPES < 11 *> CSP 11 List types on next line if 0 < NTYPES < 11 *> CTR 18 List types on next line if 0 < NTYPES < 18 @@ -151,7 +153,7 @@ $ RANKVAL( MAXIN ), PIV( NMAX ) REAL RWORK( 150*NMAX+2*MAXRHS ), S( 2*NMAX ) COMPLEX A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ), - $ WORK( NMAX, NMAX+MAXRHS+10 ) + $ E( NMAX ), WORK( NMAX, NMAX+MAXRHS+10 ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN @@ -160,14 +162,15 @@ * .. * .. External Subroutines .. EXTERNAL ALAREQ, CCHKEQ, CCHKGB, CCHKGE, CCHKGT, CCHKHE, - $ CCHKHE_ROOK, CCHKHE_AA, CCHKHP, CCHKLQ, CCHKPB, - $ CCHKPO, CCHKPS, CCHKPP, CCHKPT, CCHKQ3, CCHKQL, - $ CCHKQR, CCHKRQ, CCHKSP, CCHKSY, CCHKSY_ROOK, - $ CCHKTB, CCHKTP, CCHKTR, CCHKTZ, CDRVGB, CDRVGE, - $ CDRVGT, CDRVHE, CDRVHE_ROOK, CDRVHE_AA, CDRVHP, + $ CCHKHE_ROOK, CCHKHE_RK, CCHKHE_AA, CCHKLQ, + $ CCHKPB,CCHKPO, CCHKPS, CCHKPP, CCHKPT, CCHKQ3, + $ CCHKQL, CCHKQR, CCHKRQ, CCHKSP, CCHKSY, + $ CCHKSY_ROOK, CCHKSY_RK, CCHKTB, CCHKTP, + $ CCHKTR, CCHKTZ, CDRVGB, CDRVGE, CDRVGT, CDRVHE, + $ CDRVHE_ROOK, CDRVHE_RK, CDRVHE_AA, CDRVHP, $ CDRVLS, CDRVPB, CDRVPO, CDRVPP, CDRVPT, CDRVSP, - $ CDRVSY, CDRVSY_ROOK, ILAVER, CCHKQRT, CCHKQRTP - + $ CDRVSY, CDRVSY_ROOK, CDRVSY_RK, ILAVER, CCHKQRT, + $ CCHKQRTP * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -642,55 +645,82 @@ WRITE( NOUT, FMT = 9988 )PATH END IF * - ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * -* HA: Hermitian matrices, -* Aasen Algorithm +* HR: Hermitian indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm * NTYPES = 10 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN - CALL CCHKHE_AA( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, - $ NSVAL, THRESH, TSTERR, LDA, - $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), - $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), - $ WORK, RWORK, IWORK, NOUT ) + CALL CCHKHE_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH END IF * IF( TSTDRV ) THEN - CALL CDRVHE_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, - $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), - $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), - $ WORK, RWORK, IWORK, NOUT ) + CALL CDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, + $ RWORK, IWORK, NOUT ) ELSE WRITE( NOUT, FMT = 9988 )PATH END IF * - ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN * -* HR: Hermitian indefinite matrices, -* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* HK: Hermitian indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm, +* differnet matrix storage format than HR path version. * NTYPES = 10 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN - CALL CCHKHE_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, - $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), - $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), - $ WORK, RWORK, IWORK, NOUT ) + CALL CCHKHE_RK( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH END IF * IF( TSTDRV ) THEN - CALL CDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, - $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), - $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, - $ RWORK, IWORK, NOUT ) + CALL CDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, + $ RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN +* +* HA: Hermitian matrices, +* Aasen Algorithm +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL CCHKHE_AA( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, + $ NSVAL, THRESH, TSTERR, LDA, + $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL CDRVHE_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) ELSE WRITE( NOUT, FMT = 9988 )PATH END IF @@ -750,7 +780,7 @@ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * * SR: symmetric indefinite matrices, -* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* with bounded Bunch-Kaufman (rook) pivoting algorithm * NTYPES = 11 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) @@ -773,6 +803,33 @@ WRITE( NOUT, FMT = 9988 )PATH END IF * + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* SK: symmetric indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm, +* differnet matrix storage format than SR path version. +* + NTYPES = 11 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL CCHKSY_RK( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL CDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, + $ RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF +* ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * * SP: symmetric indefinite packed matrices, diff --git a/TESTING/LIN/cchkhe_rk.f b/TESTING/LIN/cchkhe_rk.f new file mode 100644 index 00000000..a4d5ee62 --- /dev/null +++ b/TESTING/LIN/cchkhe_rk.f @@ -0,0 +1,859 @@ +*> \brief \b CCHKHE_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKHE_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, +* X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* REAL RWORK( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKHE_RK tests CHETRF_RK, -TRI_3, -TRS_3, +*> and -CON_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CCHKHE_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL ONEHALF + PARAMETER ( ONEHALF = 0.5E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA, + $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, + $ NRUN, NT + REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX, + $ SING_MIN, RCOND, RCONDC, STEMP +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ), IDUMMY( 1 ) + REAL RESULT( NTESTS ) + COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 ) +* .. +* .. External Functions .. + REAL CLANGE, CLANHE, SGET06 + EXTERNAL CLANGE, CLANHE, SGET06 +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, CERRHE, CGESVD, CGET04, + $ CLACPY, CLARHS, CLATB4, CLATMS, CPOT02, CPOT03, + $ CHECON_3, CHET01_3, CHETRF_RK, CHETRI_3, + $ CHETRS_3, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC CONJG, MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'HK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'HE' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRHE( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with CLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from CLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'CHETRF_RK' + CALL CHETRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from CHETRF_RK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'CHETRF_RK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL CHET01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'CHETRI_3' +* +* Another reason that we need to compute the invesrse +* is that CPOT03 produces RCONDC which is used later +* in TEST6 and TEST7. +* + LWORK = (N+NB+1)*(NB+3) + CALL CHETRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Check error code from ZHETRI_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CHETRI_3', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a Hermitian matrix times +* its inverse. +* + CALL CPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + STEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) / + $ ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in U +* + STEMP = CLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + STEMP = CLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in L +* + STEMP = CLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + STEMP = CLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +* +*+ TEST 4 +* Compute largest 2-Norm (condition number) +* of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + STEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )* + $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) ) + CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 ) + BLOCK( 1, 2 ) = E( K ) + BLOCK( 2, 1 ) = CONJG( BLOCK( 1, 2 ) ) + BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K ) +* + CALL CGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ CDUMMY, 1, CDUMMY, 1, + $ WORK, 6, RWORK( 3 ), INFO ) +* +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + STEMP = SING_MAX / SING_MIN +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K ) + BLOCK( 2, 1 ) = E( K ) + BLOCK( 1, 2 ) = CONJG( BLOCK( 2, 1 ) ) + BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 ) +* + CALL CGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ CDUMMY, 1, CDUMMY, 1, + $ WORK, 6, RWORK(3), INFO ) +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + STEMP = SING_MAX / SING_MIN +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +* Begin loop over NRHS values +* +* +*+ TEST 5 ( Using TRS_3) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'CHETRS_3' + CALL CHETRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, INFO ) +* +* Check error code from CHETRS_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CHETRS_3', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'CHECON_3' + CALL CHECON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM, + $ RCOND, WORK, INFO ) +* +* Check error code from CHECON_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CHECON_3', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare values of RCOND +* + RESULT( 7 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of CCHKHE_RK +* + END diff --git a/TESTING/LIN/cchksy_rk.f b/TESTING/LIN/cchksy_rk.f new file mode 100644 index 00000000..ba9687c5 --- /dev/null +++ b/TESTING/LIN/cchksy_rk.f @@ -0,0 +1,867 @@ +*> \brief \b CCHKSY_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, +* X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* REAL RWORK( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKSY_RK tests CSYTRF_RK, -TRI_3, -TRS_3, +*> and -CON_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL ONEHALF + PARAMETER ( ONEHALF = 0.5E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) + INTEGER NTYPES + PARAMETER ( NTYPES = 11 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA, + $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, + $ NRUN, NT + REAL ALPHA, ANORM, CNDNUM, CONST, SING_MAX, + $ SING_MIN, RCOND, RCONDC, STEMP +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) + COMPLEX BLOCK( 2, 2 ), CDUMMY( 1 ) +* .. +* .. External Functions .. + REAL CLANGE, CLANSY, SGET06 + EXTERNAL CLANGE, CLANSY, SGET06 +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, CERRSY, CGESVD, CGET04, + $ CLACPY, CLARHS, CLATB4, CLATMS, CLATSY, CSYT02, + $ CSYT03, CSYCON_3, CSYT01_3, CSYTRF_RK, + $ CSYTRI_3, CSYTRS_3, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'SK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRSY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate test matrix A. +* + IF( IMAT.NE.NTYPES ) THEN +* +* Set up parameters with CLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from CLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* + ELSE +* +* For matrix kind IMAT = 11, generate special block +* diagonal matrix to test alternate code +* for the 2 x 2 blocks. +* + CALL CLATSY( UPLO, N, A, LDA, ISEED ) +* + END IF +* +* End generate test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'CSYTRF_RK' + CALL CSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from CSYTRF_RK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'CSYTRF_RK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL CSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'CSYTRI_3' +* +* Another reason that we need to compute the invesrse +* is that CSYT03 produces RCONDC which is used later +* in TEST6 and TEST7. +* + LWORK = (N+NB+1)*(NB+3) + CALL CSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Check error code from CSYTRI_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CSYTRI_3', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a symmetric matrix times +* its inverse. +* + CALL CSYT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + STEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) / + $ ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in U +* + STEMP = CLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + STEMP = CLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in L +* + STEMP = CLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + STEMP = CLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +* +*+ TEST 4 +* Compute largest 2-Norm (condition number) +* of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + STEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )* + $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 ) + BLOCK( 1, 2 ) = E( K ) + BLOCK( 2, 1 ) = BLOCK( 1, 2 ) + BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K ) +* + CALL CGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ CDUMMY, 1, CDUMMY, 1, + $ WORK, 6, RWORK( 3 ), INFO ) +* +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + STEMP = SING_MAX / SING_MIN +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K ) + BLOCK( 2, 1 ) = E( K ) + BLOCK( 1, 2 ) = BLOCK( 2, 1 ) + BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 ) +* + CALL CGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ CDUMMY, 1, CDUMMY, 1, + $ WORK, 6, RWORK(3), INFO ) +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + STEMP = SING_MAX / SING_MIN +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 5 ( Using TRS_3) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'CSYTRS_3' + CALL CSYTRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, INFO ) +* +* Check error code from CSYTRS_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CSYTRS_3', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL CSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'CSYCON_3' + CALL CSYCON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM, + $ RCOND, WORK, INFO ) +* +* Check error code from CSYCON_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'CSYCON_3', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare values of RCOND +* + RESULT( 7 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test(', I2, ') =', G12.5 ) + RETURN +* +* End of CCHKSY_RK +* + END diff --git a/TESTING/LIN/cdrvhe_rk.f b/TESTING/LIN/cdrvhe_rk.f new file mode 100644 index 00000000..36a9a930 --- /dev/null +++ b/TESTING/LIN/cdrvhe_rk.f @@ -0,0 +1,534 @@ +*> \brief \b CDRVHE_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, +* RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* REAL RWORK( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDRVHE_RK tests the driver routines CHESV_RK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + REAL AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) + +* .. +* .. External Functions .. + REAL CLANHE + EXTERNAL CLANHE +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, CERRVX, CGET04, + $ CLACPY, CLARHS, CLATB4, CLATMS, CHESV_RK, + $ CHET01_3, CPOT02, CHETRF_RK, CHETRI_3 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'HK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'HE' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with CLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from CLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of +* the matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL CHETRF_RK( UPLO, N, AFAC, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) +* +* We need to copute the invesrse to compute +* RCONDC that is used later in TEST3. +* + CALL CSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, + $ WORK, LWORK, INFO ) + AINVNM = CLANHE( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test CHESV_RK --- +* + IF( IFACT.EQ.2 ) THEN + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* CHESV_RK. +* + SRNAMT = 'CHESV_RK' + CALL CHESV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from CHESV_RK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'CHESV_RK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL CHET01_3( UPLO, N, A, LDA, AFAC, LDA, E, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'CHESV_RK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of CDRVHE_RK +* + END diff --git a/TESTING/LIN/cdrvsy_rk.f b/TESTING/LIN/cdrvsy_rk.f new file mode 100644 index 00000000..900ce441 --- /dev/null +++ b/TESTING/LIN/cdrvsy_rk.f @@ -0,0 +1,542 @@ +*> \brief \b CDRVSY_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, +* RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* REAL RWORK( * ) +* COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CDRVSY_RK tests the driver routines CSYSV_RK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX array, dimension (NMAX) +*> \param[out] AINV +*> +*> \verbatim +*> AINV is COMPLEX array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL RWORK( * ) + COMPLEX A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 11, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + REAL AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) + +* .. +* .. External Functions .. + REAL CLANSY + EXTERNAL CLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, CERRVX, CGET04, + $ CLACPY, CLARHS, CLATB4, CLATMS, CLATSY, + $ CSYSV_RK, CSYT01_3, CSYT02, CSYTRF_RK, CSYTRI_3 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'SK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Complex precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* + IF( IMAT.NE.NTYPES ) THEN +* +* Begin generate the test matrix A. +* +* Set up parameters with CLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL CLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with CLATMS. +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from CLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of +* the matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* + ELSE +* +* IMAT = NTYPES: Use a special block diagonal matrix to +* test alternate code for the 2-by-2 blocks. +* + CALL CLATSY( UPLO, N, A, LDA, ISEED ) + END IF +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL CSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL CLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) +* +* We need to copute the invesrse to compute +* RCONDC that is used later in TEST3. +* + CALL CSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, + $ WORK, LWORK, INFO ) + AINVNM = CLANSY( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'CLARHS' + CALL CLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test CSYSV_RK --- +* + IF( IFACT.EQ.2 ) THEN + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* CSYSV_RK. +* + SRNAMT = 'CSYSV_RK' + CALL CSYSV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from CSYSV_RK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'CSYSV_RK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL CSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL CSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'CSYSV_RK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of CDRVSY_RK +* + END diff --git a/TESTING/LIN/cerrhe.f b/TESTING/LIN/cerrhe.f index 22defe6e..3711b8e3 100644 --- a/TESTING/LIN/cerrhe.f +++ b/TESTING/LIN/cerrhe.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date November 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRHE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2013 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -81,18 +81,20 @@ INTEGER IP( NMAX ) REAL R( NMAX ), R1( NMAX ), R2( NMAX ) COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHECON, CHECON_ROOK, CHERFS, CHETF2, - $ CHETF2_ROOK, CHETRF, CHETRF_ROOK, CHETRF_AA, - $ CHETRI, CHETRI_ROOK, CHETRI2, CHETRS, - $ CHETRS_ROOK, CHETRS_AA, CHKXER, CHPCON, CHPRFS, - $ CHPTRF, CHPTRI, CHPTRS + EXTERNAL ALAESM, CHECON, CSYCON_3, CHECON_ROOK, CHERFS, + $ CHETF2, CHETF2_RK, CHETF2_ROOK, CHETRF_AA, + $ CHETRF, CHETRF_RK, CHETRF_ROOK, CHETRI, + $ CHETRI_3, CHETRI_3X, CHETRI_ROOK, CHETRI2, + $ CHETRI2X, CHETRS, CHETRS_3, CHETRS_ROOK, + $ CHETRS_AA, CHKXER, CHPCON, CHPRFS, CHPTRF, + $ CHPTRI, CHPTRS * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -119,22 +121,23 @@ A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 IP( J ) = J 20 CONTINUE ANRM = 1.0 OK = .TRUE. * -* Test error exits of the routines that use factorization -* of a Hermitian indefinite matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. -* IF( LSAMEN( 2, C2, 'HE' ) ) THEN * +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * CHETRF * SRNAMT = 'CHETRF' @@ -147,6 +150,12 @@ INFOT = 4 CALL CHETRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) * * CHETF2 * @@ -187,6 +196,19 @@ CALL CHETRI2( 'U', 2, A, 1, IP, W, 1, INFO ) CALL CHKXER( 'CHETRI2', INFOT, NOUT, LERR, OK ) * +* CHETRI2X +* + SRNAMT = 'CHETRI2X' + INFOT = 1 + CALL CHETRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK ) +* * CHETRS * SRNAMT = 'CHETRS' @@ -254,12 +276,12 @@ CALL CHECON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CHECON', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN +* * Test error exits of the routines that use factorization -* of a Hermitian indefinite matrix with "rook" +* of a Hermitian indefinite matrix with rook * (bounded Bunch-Kaufman) diagonal pivoting method. * - ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN -* * CHETRF_ROOK * SRNAMT = 'CHETRF_ROOK' @@ -272,6 +294,12 @@ INFOT = 4 CALL CHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) * * CHETF2_ROOK * @@ -334,10 +362,119 @@ CALL CHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN +* * Test error exits of the routines that use factorization -* of a Hermitian indefinite matrix with Aasen's algorithm. +* of a Hermitian indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* CHETRF_RK +* + SRNAMT = 'CHETRF_RK' + INFOT = 1 + CALL CHETRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) +* +* CHETF2_RK * - ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN + SRNAMT = 'CHETF2_RK' + INFOT = 1 + CALL CHETF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK ) +* +* CHETRI_3 +* + SRNAMT = 'CHETRI_3' + INFOT = 1 + CALL CHETRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) +* +* CHETRI_3X +* + SRNAMT = 'CHETRI_3X' + INFOT = 1 + CALL CHETRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK ) +* +* CHETRS_3 +* + SRNAMT = 'CHETRS_3' + INFOT = 1 + CALL CHETRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHETRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHETRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CHETRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) +* +* CHECON_3 +* + SRNAMT = 'CHECON_3' + INFOT = 1 + CALL CHECON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHECON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHECON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHECON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, INFO) + CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with Aasen's algorithm. * * CHETRF_AA * diff --git a/TESTING/LIN/cerrhex.f b/TESTING/LIN/cerrhex.f index a6ee9fa9..662892e3 100644 --- a/TESTING/LIN/cerrhex.f +++ b/TESTING/LIN/cerrhex.f @@ -51,17 +51,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date November 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRHE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -87,18 +87,19 @@ $ S( NMAX ), ERR_BNDS_N( NMAX, 3 ), $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHECON, CHECON_ROOK, CHERFS, CHETF2, - $ CHETF2_ROOK, CHETRF, CHETRF_ROOK, CHETRI, - $ CHETRI_ROOK, CHETRI2, CHETRS, CHETRS_ROOK, - $ CHKXER, CHPCON, CHPRFS, CHPTRF, CHPTRI, CHPTRS, - $ CHERFSX + EXTERNAL ALAESM, CHECON, CHECON_3, CHECON_ROOK, CHERFS, + $ CHETF2, CHETF2_RK, CHETF2_ROOK, CHETRF, + $ CHETRF_RK, CHETRF_ROOK, CHETRI, CHETRI_3, + $ CHETRI_3X, CHETRI_ROOK, CHETRI2, CHETRI2X, + $ CHETRS, CHETRS_3, CHETRS_ROOK, CHKXER, CHPCON, + $ CHPRFS, CHPTRF, CHPTRI, CHPTRS, CHERFSX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -125,23 +126,23 @@ A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. - S( J ) = 0. + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 IP( J ) = J 20 CONTINUE ANRM = 1.0 OK = .TRUE. * -* Test error exits of the routines that use factorization -* of a Hermitian indefinite matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. -* IF( LSAMEN( 2, C2, 'HE' ) ) THEN * +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * CHETRF * SRNAMT = 'CHETRF' @@ -154,6 +155,12 @@ INFOT = 4 CALL CHETRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CHETRF', INFOT, NOUT, LERR, OK ) * * CHETF2 * @@ -194,6 +201,19 @@ CALL CHETRI2( 'U', 2, A, 1, IP, W, 1, INFO ) CALL CHKXER( 'CHETRI2', INFOT, NOUT, LERR, OK ) * +* CHETRI2X +* + SRNAMT = 'CHETRI2X' + INFOT = 1 + CALL CHETRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI2X', INFOT, NOUT, LERR, OK ) +* * CHETRS * SRNAMT = 'CHETRS' @@ -308,12 +328,12 @@ $ PARAMS, W, R, INFO ) CALL CHKXER( 'CHERFSX', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN +* * Test error exits of the routines that use factorization -* of a Hermitian indefinite matrix with "rook" +* of a Hermitian indefinite matrix with rook * (bounded Bunch-Kaufman) diagonal pivoting method. * - ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN -* * CHETRF_ROOK * SRNAMT = 'CHETRF_ROOK' @@ -326,6 +346,12 @@ INFOT = 4 CALL CHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHETRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CHETRF_ROOK', INFOT, NOUT, LERR, OK ) * * CHETF2_ROOK * @@ -388,12 +414,121 @@ CALL CHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CHECON_ROOK', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* CHETRF_RK +* + SRNAMT = 'CHETRF_RK' + INFOT = 1 + CALL CHETRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'CHETRF_RK', INFOT, NOUT, LERR, OK ) +* +* CHETF2_RK +* + SRNAMT = 'CHETF2_RK' + INFOT = 1 + CALL CHETF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'CHETF2_RK', INFOT, NOUT, LERR, OK ) +* +* CHETRI_3 +* + SRNAMT = 'CHETRI_3' + INFOT = 1 + CALL CHETRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHETRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'CHETRI_3', INFOT, NOUT, LERR, OK ) +* +* CHETRI_3X +* + SRNAMT = 'CHETRI_3X' + INFOT = 1 + CALL CHETRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHETRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CHETRI_3X', INFOT, NOUT, LERR, OK ) +* +* CHETRS_3 +* + SRNAMT = 'CHETRS_3' + INFOT = 1 + CALL CHETRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHETRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHETRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHETRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CHETRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'CHETRS_3', INFOT, NOUT, LERR, OK ) +* +* CHECON_3 +* + SRNAMT = 'CHECON_3' + INFOT = 1 + CALL CHECON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHECON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHECON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CHECON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, INFO) + CALL CHKXER( 'CHECON_3', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN +* * Test error exits of the routines that use factorization * of a Hermitian indefinite packed matrix with patrial * (Bunch-Kaufman) diagonal pivoting method. * - ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN -* * CHPTRF * SRNAMT = 'CHPTRF' diff --git a/TESTING/LIN/cerrsy.f b/TESTING/LIN/cerrsy.f index b9e43855..c7613bd6 100644 --- a/TESTING/LIN/cerrsy.f +++ b/TESTING/LIN/cerrsy.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date November 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2013 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -80,7 +80,7 @@ INTEGER IP( NMAX ) REAL R( NMAX ), R1( NMAX ), R2( NMAX ) COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -88,9 +88,11 @@ * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, CSPCON, CSPRFS, CSPTRF, CSPTRI, - $ CSPTRS, CSYCON, CSYCON_ROOK, CSYRFS, CSYTF2, - $ CSYTF2_ROOK, CSYTRF, CSYTRF_ROOK, CSYTRI, - $ CSYTRI_ROOK, CSYTRI2, CSYTRS, CSYTRS_ROOK + $ CSPTRS, CSYCON, CSYCON_3, CSYCON_ROOK, CSYRFS, + $ CSYTF2, CSYTF2_RK, CSYTF2_ROOK, CSYTRF, + $ CSYTRF_RK, CSYTRF_ROOK, CSYTRI, CSYTRI_3, + $ CSYTRI_3X, CSYTRI_ROOK, CSYTRI2, CSYTRI2X, + $ CSYTRS, CSYTRS_3, CSYTRS_ROOK * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -117,22 +119,23 @@ A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. + B( J ) = 0.E0 + E( J ) = 0.E0 + R1( J ) = 0.E0 + R2( J ) = 0.E0 + W( J ) = 0.E0 + X( J ) = 0.E0 IP( J ) = J 20 CONTINUE ANRM = 1.0 OK = .TRUE. * -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. -* IF( LSAMEN( 2, C2, 'SY' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * CSYTRF * SRNAMT = 'CSYTRF' @@ -145,6 +148,12 @@ INFOT = 4 CALL CSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK ) * * CSYTF2 * @@ -185,6 +194,19 @@ CALL CSYTRI2( 'U', 2, A, 1, IP, W, 1, INFO ) CALL CHKXER( 'CSYTRI2', INFOT, NOUT, LERR, OK ) * +* CSYTRI2X +* + SRNAMT = 'CSYTRI2X' + INFOT = 1 + CALL CSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK ) +* * CSYTRS * SRNAMT = 'CSYTRS' @@ -252,12 +274,12 @@ CALL CSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CSYCON', INFOT, NOUT, LERR, OK ) * -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with "rook" -* (bounded Bunch-Kaufman) diagonal pivoting method. -* ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) diagonal pivoting method. +* * CSYTRF_ROOK * SRNAMT = 'CSYTRF_ROOK' @@ -270,6 +292,12 @@ INFOT = 4 CALL CSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) * * CSYTF2_ROOK * @@ -332,12 +360,121 @@ CALL CSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK ) * -* Test error exits of the routines that use factorization -* of a symmetric indefinite packed matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* CSYTRF_RK +* + SRNAMT = 'CSYTRF_RK' + INFOT = 1 + CALL CSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) +* +* CSYTF2_RK +* + SRNAMT = 'CSYTF2_RK' + INFOT = 1 + CALL CSYTF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK ) +* +* CSYTRI_3 +* + SRNAMT = 'CSYTRI_3' + INFOT = 1 + CALL CSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) +* +* CSYTRI_3X +* + SRNAMT = 'CSYTRI_3X' + INFOT = 1 + CALL CSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK ) +* +* CSYTRS_3 +* + SRNAMT = 'CSYTRS_3' + INFOT = 1 + CALL CSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) +* +* CSYCON_3 +* + SRNAMT = 'CSYCON_3' + INFOT = 1 + CALL CSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYCON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, INFO) + CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite packed matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * CSPTRF * SRNAMT = 'CSPTRF' diff --git a/TESTING/LIN/cerrsyx.f b/TESTING/LIN/cerrsyx.f index b0cc0d34..0356be30 100644 --- a/TESTING/LIN/cerrsyx.f +++ b/TESTING/LIN/cerrsyx.f @@ -51,17 +51,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date November 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -86,7 +86,7 @@ $ S( NMAX ), ERR_BNDS_N( NMAX, 3 ), $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -124,23 +124,23 @@ A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. - S( J ) = 0. + B( J ) = 0.E0 + E( J ) = 0.E0 + R1( J ) = 0.E0 + R2( J ) = 0.E0 + W( J ) = 0.E0 + X( J ) = 0.E0 IP( J ) = J 20 CONTINUE ANRM = 1.0 OK = .TRUE. -* -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. -* + IF( LSAMEN( 2, C2, 'SY' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * CSYTRF * SRNAMT = 'CSYTRF' @@ -153,6 +153,12 @@ INFOT = 4 CALL CSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CSYTRF', INFOT, NOUT, LERR, OK ) * * CSYTF2 * @@ -193,6 +199,19 @@ CALL CSYTRI2( 'U', 2, A, 1, IP, W, 1, INFO ) CALL CHKXER( 'CSYTRI2', INFOT, NOUT, LERR, OK ) * +* CSYTRI2X +* + SRNAMT = 'CSYTRI2X' + INFOT = 1 + CALL CSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI2X', INFOT, NOUT, LERR, OK ) +* * CSYTRS * SRNAMT = 'CSYTRS' @@ -307,12 +326,12 @@ CALL CSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CSYCON', INFOT, NOUT, LERR, OK ) * -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with "rook" -* (bounded Bunch-Kaufman) diagonal pivoting method. -* ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) diagonal pivoting method. +* * CSYTRF_ROOK * SRNAMT = 'CSYTRF_ROOK' @@ -325,6 +344,12 @@ INFOT = 4 CALL CSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'CSYTRF_ROOK', INFOT, NOUT, LERR, OK ) * * CSYTF2_ROOK * @@ -387,12 +412,121 @@ CALL CSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'CSYCON_ROOK', INFOT, NOUT, LERR, OK ) * -* Test error exits of the routines that use factorization -* of a symmetric indefinite packed matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* CSYTRF_RK +* + SRNAMT = 'CSYTRF_RK' + INFOT = 1 + CALL CSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'CSYTRF_RK', INFOT, NOUT, LERR, OK ) +* +* CSYTF2_RK +* + SRNAMT = 'CSYTF2_RK' + INFOT = 1 + CALL CSYTF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'CSYTF2_RK', INFOT, NOUT, LERR, OK ) +* +* CSYTRI_3 +* + SRNAMT = 'CSYTRI_3' + INFOT = 1 + CALL CSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'CSYTRI_3', INFOT, NOUT, LERR, OK ) +* +* CSYTRI_3X +* + SRNAMT = 'CSYTRI_3X' + INFOT = 1 + CALL CSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'CSYTRI_3X', INFOT, NOUT, LERR, OK ) +* +* CSYTRS_3 +* + SRNAMT = 'CSYTRS_3' + INFOT = 1 + CALL CSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'CSYTRS_3', INFOT, NOUT, LERR, OK ) +* +* CSYCON_3 +* + SRNAMT = 'CSYCON_3' + INFOT = 1 + CALL CSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CSYCON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, INFO) + CALL CHKXER( 'CSYCON_3', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite packed matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * CSPTRF * SRNAMT = 'CSPTRF' diff --git a/TESTING/LIN/cerrvx.f b/TESTING/LIN/cerrvx.f index 13496241..655155a7 100644 --- a/TESTING/LIN/cerrvx.f +++ b/TESTING/LIN/cerrvx.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date November 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2013 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -82,7 +82,7 @@ REAL C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ), $ RF( NMAX ), RW( NMAX ) COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -90,10 +90,11 @@ * .. * .. External Subroutines .. EXTERNAL CGBSV, CGBSVX, CGESV, CGESVX, CGTSV, CGTSVX, - $ CHESV, CHESV_ROOK, CHESVX, CHKXER, CHPSV, - $ CHPSVX, CPBSV, CPBSVX, CPOSV, CPOSVX, CPPSV, - $ CPPSVX, CPTSV, CPTSVX, CSPSV, CSPSVX, CSYSV, - $ CSYSV_AA, CSYSV_ROOK, CSYSVX + $ CHESV, CHESV_RK ,CHESV_ROOK, CHESVX, CHKXER, + $ CHPSV, CHPSVX, CPBSV, CPBSVX, CPOSV, CPOSVX, + $ CPPSV, CPPSVX, CPTSV, CPTSVX, CSPSV, CSPSVX, + $ CSYSV, CSYSV_AA, CSYSV_RK, CSYSV_ROOK, + $ CSYSVX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -120,13 +121,14 @@ A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. - C( J ) = 0. - R( J ) = 0. + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 + C( J ) = 0.E+0 + R( J ) = 0.E+0 IP( J ) = J 20 CONTINUE EQ = ' ' @@ -591,6 +593,12 @@ INFOT = 8 CALL CHESV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHESV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHESV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK ) * * CHESVX * @@ -632,42 +640,82 @@ $ RCOND, R1, R2, W, 3, RW, INFO ) CALL CHKXER( 'CHESVX', INFOT, NOUT, LERR, OK ) * - ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN -* -* CHESV_AA -* - SRNAMT = 'CHESV_AA' - INFOT = 1 - CALL CHESV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHESV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHESV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CHESV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK ) -* - ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * * CHESV_ROOK * - SRNAMT = 'CHESV_ROOK' - INFOT = 1 - CALL CHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + SRNAMT = 'CHESV_ROOK' + INFOT = 1 + CALL CHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN +* +* CHESV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'CHESV_RK' + INFOT = 1 + CALL CHESV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHESV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHESV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHESV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CHESV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN +* +* CHESV_AASEN +* + SRNAMT = 'CHESV_AA' + INFOT = 1 + CALL CHESV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHESV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHESV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHESV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_AA', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * @@ -732,6 +780,12 @@ INFOT = 8 CALL CSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK ) * * CSYSVX * @@ -790,6 +844,47 @@ INFOT = 8 CALL CSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* CSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'CSYSV_RK' + INFOT = 1 + CALL CSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/TESTING/LIN/cerrvxx.f b/TESTING/LIN/cerrvxx.f index 82a93a5e..09c2749e 100644 --- a/TESTING/LIN/cerrvxx.f +++ b/TESTING/LIN/cerrvxx.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date November 2016 * *> \ingroup complex_lin * * ===================================================================== SUBROUTINE CERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -85,7 +85,7 @@ $ RF( NMAX ), RW( NMAX ), ERR_BNDS_N( NMAX, 3 ), $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -93,11 +93,11 @@ * .. * .. External Subroutines .. EXTERNAL CGBSV, CGBSVX, CGESV, CGESVX, CGTSV, CGTSVX, - $ CHESV, CHESV_ROOK, CHESVX, CHKXER, CHPSV, - $ CHPSVX, CPBSV, CPBSVX, CPOSV, CPOSVX, CPPSV, - $ CPPSVX, CPTSV, CPTSVX, CSPSV, CSPSVX, CSYSV, - $ CSYSV_ROOK, CSYSVX, CGESVXX, CPOSVXX, CSYSVXX, - $ CHESVXX, CGBSVXX + $ CHESV, CHESV_RK, CHESV_ROOK, CHESVX, CHKXER, + $ CHPSV, CHPSVX, CPBSV, CPBSVX, CPOSV, CPOSVX, + $ CPPSV, CPPSVX, CPTSV, CPTSVX, CSPSV, CSPSVX, + $ CSYSV, CSYSV_RK, CSYSV_ROOK, CSYSVX, CGESVXX, + $ CPOSVXX, CSYSVXX, CHESVXX, CGBSVXX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -124,13 +124,14 @@ A( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) AF( I, J ) = CMPLX( 1. / REAL( I+J ), -1. / REAL( I+J ) ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. - C( J ) = 0. - R( J ) = 0. + B( J ) = 0.E+0 + E( J ) = 0E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 + C( J ) = 0.E+0 + R( J ) = 0.E+0 IP( J ) = J 20 CONTINUE EQ = ' ' @@ -804,6 +805,12 @@ INFOT = 8 CALL CHESV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHESV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHESV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CHESV ', INFOT, NOUT, LERR, OK ) * * CHESVX * @@ -907,19 +914,60 @@ * * CHESV_ROOK * - SRNAMT = 'CHESV_ROOK' - INFOT = 1 - CALL CHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL CHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL CHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL CHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + SRNAMT = 'CHESV_ROOK' + INFOT = 1 + CALL CHESV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHESV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHESV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CHESV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN +* +* CHESV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'CHESV_RK' + INFOT = 1 + CALL CHESV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHESV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHESV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHESV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CHESV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CHESV_RK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * @@ -984,6 +1032,12 @@ INFOT = 8 CALL CSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CSYSV ', INFOT, NOUT, LERR, OK ) * * CSYSVX * @@ -1110,6 +1164,47 @@ INFOT = 8 CALL CSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CSYSV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* CSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'CSYSV_RK' + INFOT = 1 + CALL CSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'CSYSV_RK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/TESTING/LIN/chet01_3.f b/TESTING/LIN/chet01_3.f new file mode 100644 index 00000000..7b26c398 --- /dev/null +++ b/TESTING/LIN/chet01_3.f @@ -0,0 +1,264 @@ +*> \brief \b CHET01_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CHET01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, +* LDC, RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* REAL RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL RWORK( * ) +* COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CHET01_3 reconstructs a Hermitian indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization computed by CHETRF_RK +*> (or CHETRF_BK) and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The original Hermitian matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (LDAFAC,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by CHETRF_RK and CHETRF_BK: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. +*> LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from CHETRF_RK (or CHETRF_BK). +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> 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 ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2016 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CHET01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + REAL RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL RWORK( * ) + COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + REAL ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + REAL CLANHE, SLAMCH + EXTERNAL LSAME, CLANHE, SLAMCH +* .. +* .. External Subroutines .. + EXTERNAL CLASET, CLAVHE_ROOK, CSYCONVF_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC AIMAG, REAL +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* a) Revert to multiplyers of L +* + CALL CSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO ) +* +* 1) Determine EPS and the norm of A. +* + EPS = SLAMCH( 'Epsilon' ) + ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Check the imaginary parts of the diagonal elements and return with +* an error code if any are nonzero. +* + DO J = 1, N + IF( AIMAG( AFAC( J, J ) ).NE.ZERO ) THEN + RESID = ONE / EPS + RETURN + END IF + END DO +* +* 2) Initialize C to the identity matrix. +* + CALL CLASET( 'Full', N, N, CZERO, CONE, C, LDC ) +* +* 3) Call CLAVHE_ROOK to form the product D * U' (or D * L' ). +* + CALL CLAVHE_ROOK( UPLO, 'Conjugate', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 4) Call ZLAVHE_RK again to multiply by U (or L ). +* + CALL CLAVHE_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 5) Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J - 1 + C( I, J ) = C( I, J ) - A( I, J ) + END DO + C( J, J ) = C( J, J ) - REAL( A( J, J ) ) + END DO + ELSE + DO J = 1, N + C( J, J ) = C( J, J ) - REAL( A( J, J ) ) + DO I = J + 1, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* 6) Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = CLANHE( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID/REAL( N ) )/ANORM ) / EPS + END IF +* +* b) Convert to factor of L (or U) +* + CALL CSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO ) +* + RETURN +* +* End of CHET01_3 +* + END diff --git a/TESTING/LIN/csyt01_3.f b/TESTING/LIN/csyt01_3.f new file mode 100644 index 00000000..730d681a --- /dev/null +++ b/TESTING/LIN/csyt01_3.f @@ -0,0 +1,253 @@ +*> \brief \b CSYT01_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, +* LDC, RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* REAL RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* REAL RWORK( * ) +* COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CSYT01_3 reconstructs a symmetric indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization computed by CSYTRF_RK +*> (or CSYTRF_BK) and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> 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 +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> The original symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is COMPLEX array, dimension (LDAFAC,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by CSYTRF_RK and CSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. +*> LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from CSYTRF_RK (or CSYTRF_BK). +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> 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 ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2016 +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + REAL RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL RWORK( * ) + COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + COMPLEX CZERO, CONE + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ), + $ CONE = ( 1.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + REAL ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, CLANSY + EXTERNAL LSAME, SLAMCH, CLANSY +* .. +* .. External Subroutines .. + EXTERNAL CLASET, CLAVSY_ROOK, CSYCONVF_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* a) Revert to multiplyers of L +* + CALL CSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO ) +* +* 1) Determine EPS and the norm of A. +* + EPS = SLAMCH( 'Epsilon' ) + ANORM = CLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* 2) Initialize C to the identity matrix. +* + CALL CLASET( 'Full', N, N, CZERO, CONE, C, LDC ) +* +* 3) Call ZLAVSY_ROOK to form the product D * U' (or D * L' ). +* + CALL CLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 4) Call ZLAVSY_ROOK again to multiply by U (or L ). +* + CALL CLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 5) Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* 6) Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = CLANSY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS + END IF + +* +* b) Convert to factor of L (or U) +* + CALL CSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO ) +* + RETURN +* +* End of CSYT01_3 +* + END diff --git a/TESTING/LIN/dchkaa.f b/TESTING/LIN/dchkaa.f index 8bcb8217..5d122d38 100644 --- a/TESTING/LIN/dchkaa.f +++ b/TESTING/LIN/dchkaa.f @@ -49,9 +49,10 @@ *> DPP 9 List types on next line if 0 < NTYPES < 9 *> DPB 8 List types on next line if 0 < NTYPES < 8 *> DPT 12 List types on next line if 0 < NTYPES < 12 -*> DSA 10 List types on next line if 0 < NTYPES < 10 *> DSY 10 List types on next line if 0 < NTYPES < 10 *> DSR 10 List types on next line if 0 < NTYPES < 10 +*> DSK 10 List types on next line if 0 < NTYPES < 10 +*> DSA 10 List types on next line if 0 < NTYPES < 10 *> DSP 10 List types on next line if 0 < NTYPES < 10 *> DTR 18 List types on next line if 0 < NTYPES < 18 *> DTP 18 List types on next line if 0 < NTYPES < 18 @@ -147,8 +148,8 @@ $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) DOUBLE PRECISION A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ), - $ RWORK( 5*NMAX+2*MAXRHS ), S( 2*NMAX ), - $ WORK( NMAX, NMAX+MAXRHS+30 ) + $ E( NMAX ), RWORK( 5*NMAX+2*MAXRHS ), + $ S( 2*NMAX ), WORK( NMAX, NMAX+MAXRHS+30 ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN @@ -159,10 +160,11 @@ EXTERNAL ALAREQ, DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ, $ DCHKPB, DCHKPO, DCHKPS, DCHKPP, DCHKPT, DCHKQ3, $ DCHKQL, DCHKQR, DCHKRQ, DCHKSP, DCHKSY, - $ DCHKSY_ROOK, DCHKSY_AA, DCHKTB, DCHKTP, DCHKTR, - $ DCHKTZ, DDRVGB, DDRVGE, DDRVGT, DDRVLS, DDRVPB, - $ DDRVPO, DDRVPP, DDRVPT, DDRVSP, DDRVSY, - $ DDRVSY_ROOK, DDRVSY_AA, ILAVER, DCHKQRT, + $ DCHKSY_ROOK, DCHKSY_RK, DCHKSY_AA, DCHKTB, + $ DCHKTP, DCHKTR, DCHKTZ, DDRVGB, DDRVGE, + $ DDRVGT, DDRVLS, DDRVPB, DDRVPO, DDRVPP, + $ DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK, DDRVSY_RK, + $ DDRVSY_AA, ILAVER, DCHKQRT, $ DCHKQRTP, DCHKLQTP, DCHKTSQR, DCHKLQT * .. @@ -643,8 +645,8 @@ * ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * -* SR: symmetric indefinite matrices with Rook pivoting, -* with rook (bounded Bunch-Kaufman) pivoting algorithm +* SR: symmetric indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm * NTYPES = 10 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) @@ -667,9 +669,36 @@ WRITE( NOUT, FMT = 9988 )PATH END IF * + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* SK: symmetric indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm, +* differnet matrix storage format than SR path version. +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL DCHKSY_RK( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL DDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF +* ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN * -* SY: symmetric indefinite matrices, +* SA: symmetric indefinite matrices, * with partial (Aasen's) pivoting algorithm * NTYPES = 10 diff --git a/TESTING/LIN/dchksy_rk.f b/TESTING/LIN/dchksy_rk.f new file mode 100644 index 00000000..9907d701 --- /dev/null +++ b/TESTING/LIN/dchksy_rk.f @@ -0,0 +1,846 @@ +*> \brief \b DCHKSY_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, +* X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* DOUBLE PRECISION A( * ), AFAC( * ), E( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DCHKSY_RK tests DSYTRF_RK, -TRI_3, -TRS_3, and -CON_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (NMAX*NSMAX), +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (NMAX*NSMAX), +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is DOUBLE PRECISION array, dimension (NMAX*NSMAX), +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, + $ MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, + $ NT + DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, SING_MAX, + $ SING_MIN, RCOND, RCONDC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER IDUMMY( 1 ), ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION BLOCK( 2, 2 ), DDUMMY( 1 ), RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DGET06, DLANGE, DLANSY + EXTERNAL DGET06, DLANGE, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRSY, DGESVD, DGET04, + $ DLACPY, DLARHS, DLATB4, DLATMS, DPOT02, DPOT03, + $ DSYCON_3, DSYT01_3, DSYTRF_RK, DSYTRI_3, + $ DSYTRS_3, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'SK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Double precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL DERRSY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with DLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL DLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with DLATMS. +* + SRNAMT = 'DLATMS' + CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from DLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'DSYTRF_RK' + CALL DSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from DSYTRF_RK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'DSYTRF_RK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL DSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'DSYTRI_3' +* +* Another reason that we need to compute the invesrse +* is that DPOT03 produces RCONDC which is used later +* in TEST6 and TEST7. +* + LWORK = (N+NB+1)*(NB+3) + CALL DSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Check error code from DSYTRI_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'DSYTRI_3', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a symmetric matrix times +* its inverse. +* + CALL DPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + DTEMP = ZERO +* + CONST = ONE / ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in U +* + DTEMP = DLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + DTEMP = DLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in L +* + DTEMP = DLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + DTEMP = DLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +*+ TEST 4 +* Compute largest 2-Norm (condition number) +* of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + DTEMP = ZERO +* + CONST = ( ONE+ALPHA ) / ( ONE-ALPHA ) + CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 ) + BLOCK( 1, 2 ) = E( K ) + BLOCK( 2, 1 ) = BLOCK( 1, 2 ) + BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K ) +* + CALL DGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ DDUMMY, 1, DDUMMY, 1, + $ WORK, 10, INFO ) +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + DTEMP = SING_MAX / SING_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K ) + BLOCK( 2, 1 ) = E( K ) + BLOCK( 1, 2 ) = BLOCK( 2, 1 ) + BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 ) +* + CALL DGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ DDUMMY, 1, DDUMMY, 1, + $ WORK, 10, INFO ) +* +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + DTEMP = SING_MAX / SING_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 5 ( Using TRS_3) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'DLARHS' + CALL DLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'DSYTRS_3' + CALL DSYTRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, INFO ) +* +* Check error code from DSYTRS_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'DSYTRS_3', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'DSYCON_3' + CALL DSYCON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM, + $ RCOND, WORK, IWORK( N+1 ), INFO ) +* +* Check error code from DSYCON_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'DSYCON_3', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare to values of RCOND +* + RESULT( 7 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 ) UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test(', I2, ') =', G12.5 ) + RETURN +* +* End of DCHKSY_RK +* + END diff --git a/TESTING/LIN/ddrvsy_rk.f b/TESTING/LIN/ddrvsy_rk.f new file mode 100644 index 00000000..be8a233e --- /dev/null +++ b/TESTING/LIN/ddrvsy_rk.f @@ -0,0 +1,531 @@ +*> \brief \b DDRVSY_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, +* $ RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> DDRVSY_RK tests the driver routines DSYSV_RK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is DOUBLE PRECISION array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLANSY + EXTERNAL DLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGET04, DLACPY, + $ DLARHS, DLATB4, DLATMS, DPOT02, DSYSV_RK, + $ DSYT01_3, DSYTRF_RK, DSYTRI_3, XLAENV +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'SK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Double precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL DERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with DLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL DLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with DLATMS. +* + SRNAMT = 'DLATMS' + CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from DLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of the +* matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IOFF = 0 + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL DSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL DLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) +* +* We need to copute the invesrse to compute +* RCONDC that is used later in TEST3. +* + CALL DSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, + $ WORK, LWORK, INFO ) + AINVNM = DLANSY( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'DLARHS' + CALL DLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test DSYSV_RK --- +* + IF( IFACT.EQ.2 ) THEN + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* DSYSV_RK. +* + SRNAMT = 'DSYSV_RK' + CALL DSYSV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from DSYSV_RK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'DSYSV_RK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL DSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'DSYSV_RK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of DDRVSY_RK +* + END diff --git a/TESTING/LIN/derrsy.f b/TESTING/LIN/derrsy.f index a453ab19..056e931b 100644 --- a/TESTING/LIN/derrsy.f +++ b/TESTING/LIN/derrsy.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date November 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -79,7 +79,8 @@ * .. Local Arrays .. INTEGER IP( NMAX ), IW( NMAX ) DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX ) + $ E( NMAX ), R1( NMAX ), R2( NMAX ), W( 3*NMAX ), + $ X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -87,10 +88,12 @@ * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, DSPCON, DSPRFS, DSPTRF, DSPTRI, - $ DSPTRS, DSYCON, DSYCON_ROOK, DSYRFS, DSYTF2, - $ DSYTF2_ROOK, DSYTRF, DSYTRF_ROOK, DSYTRF_AA, - $ DSYTRI, DSYTRI_ROOK, DSYTRI2, DSYTRS, - $ DSYTRS_ROOK, DSYTRS_AA + $ DSPTRS, DSYCON, DSYCON_3, DSYCON_ROOK, DSYRFS, + $ DSYTF2, DSYTF2_RK, DSYTF2_ROOK, DSYTRF, + $ DSYTRF_RK, DSYTRF_ROOK, DSYTRF_AA, DSYTRI, + $ DSYTRI_3, DSYTRI_3X, DSYTRI_ROOK, DSYTRI2, + $ DSYTRI2X, DSYTRS, DSYTRS_3, DSYTRS_ROOK, + $ DSYTRS_AA * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -118,6 +121,7 @@ AF( I, J ) = 1.D0 / DBLE( I+J ) 10 CONTINUE B( J ) = 0.D0 + E( J ) = 0.D0 R1( J ) = 0.D0 R2( J ) = 0.D0 W( J ) = 0.D0 @@ -147,6 +151,12 @@ INFOT = 4 CALL DSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK ) * * DSYTF2 * @@ -187,6 +197,19 @@ CALL DSYTRI2( 'U', 2, A, 1, IP, W, IW(1), INFO ) CALL CHKXER( 'DSYTRI2', INFOT, NOUT, LERR, OK ) * +* DSYTRI2X +* + SRNAMT = 'DSYTRI2X' + INFOT = 1 + CALL DSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK ) +* * DSYTRS * SRNAMT = 'DSYTRS' @@ -272,6 +295,12 @@ INFOT = 4 CALL DSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) * * DSYTF2_ROOK * @@ -334,6 +363,119 @@ CALL DSYCON_ROOK( 'U', 1, A, 1, IP, -1.0D0, RCOND, W, IW, INFO) CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* DSYTRF_RK +* + SRNAMT = 'DSYTRF_RK' + INFOT = 1 + CALL DSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRF_RK( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) +* +* DSYTF2_RK +* + SRNAMT = 'DSYTF2_RK' + INFOT = 1 + CALL DSYTF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK ) +* +* DSYTRI_3 +* + SRNAMT = 'DSYTRI_3' + INFOT = 1 + CALL DSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) +* +* DSYTRI_3X +* + SRNAMT = 'DSYTRI_3X' + INFOT = 1 + CALL DSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK ) +* +* DSYTRS_3 +* + SRNAMT = 'DSYTRS_3' + INFOT = 1 + CALL DSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) +* +* DSYCON_3 +* + SRNAMT = 'DSYCON_3' + INFOT = 1 + CALL DSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYCON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, IW, + $ INFO) + CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK ) +* ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN * * Test error exits of the routines that use factorization @@ -370,6 +512,7 @@ INFOT = 8 CALL DSYTRS_AA( 'U', 2, 1, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'DSYTRS_AA', INFOT, NOUT, LERR, OK ) +* ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * * Test error exits of the routines that use factorization diff --git a/TESTING/LIN/derrsyx.f b/TESTING/LIN/derrsyx.f index 635868df..7c7df446 100644 --- a/TESTING/LIN/derrsyx.f +++ b/TESTING/LIN/derrsyx.f @@ -51,17 +51,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date November 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -83,8 +83,8 @@ * .. Local Arrays .. INTEGER IP( NMAX ), IW( NMAX ) DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX ), - $ S( NMAX ), ERR_BNDS_N( NMAX, 3 ), + $ E( NMAX ), R1( NMAX ), R2( NMAX ), W( 3*NMAX ), + $ X( NMAX ), S( NMAX ), ERR_BNDS_N( NMAX, 3 ), $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) * .. * .. External Functions .. @@ -92,11 +92,12 @@ EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, DSPCON, DSYCON_ROOK, DSPRFS, - $ DSPTRF, DSPTRI, DSPTRS, DSYCON, DSYRFS, DSYTF2, - $ DSYTF2_ROOK, DSYTRF, DSYTRF_ROOK, DSYTRI, - $ DSYTRI_ROOK, DSYTRI2, DSYTRS, DSYTRS_ROOK, - $ DSYRFSX + EXTERNAL ALAESM, CHKXER, DSPCON, DSPRFS, DSPTRF, DSPTRI, + $ DSPTRS, DSYCON, DSYCON_3, DSYCON_ROOK, DSYRFS, + $ DSYTF2, DSYTF2_RK, DSYTF2_ROOK, DSYTRF, + $ DSYTRF_RK, DSYTRF_ROOK, DSYTRI, DSYTRI_3, + $ DSYTRI_3X, DSYTRI_ROOK, DSYTRI2, DSYTRI2X, + $ DSYTRS, DSYTRS_3, DSYTRS_ROOK, DSYRFSX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -124,6 +125,7 @@ AF( I, J ) = 1.D0 / DBLE( I+J ) 10 CONTINUE B( J ) = 0.D0 + E( J ) = 0.D0 R1( J ) = 0.D0 R2( J ) = 0.D0 W( J ) = 0.D0 @@ -154,6 +156,12 @@ INFOT = 4 CALL DSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'DSYTRF', INFOT, NOUT, LERR, OK ) * * DSYTF2 * @@ -194,6 +202,19 @@ CALL DSYTRI2( 'U', 2, A, 1, IP, W, IW, INFO ) CALL CHKXER( 'DSYTRI2', INFOT, NOUT, LERR, OK ) * +* DSYTRI2X +* + SRNAMT = 'DSYTRI2X' + INFOT = 1 + CALL DSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI2X', INFOT, NOUT, LERR, OK ) +* * DSYTRS * SRNAMT = 'DSYTRS' @@ -326,6 +347,12 @@ INFOT = 4 CALL DSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'DSYTRF_ROOK', INFOT, NOUT, LERR, OK ) * * DSYTF2_ROOK * @@ -388,6 +415,119 @@ CALL DSYCON_ROOK( 'U', 1, A, 1, IP, -1.0D0, RCOND, W, IW, INFO) CALL CHKXER( 'DSYCON_ROOK', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* DSYTRF_RK +* + SRNAMT = 'DSYTRF_RK' + INFOT = 1 + CALL DSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRF_RK( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'DSYTRF_RK', INFOT, NOUT, LERR, OK ) +* +* DSYTF2_RK +* + SRNAMT = 'DSYTF2_RK' + INFOT = 1 + CALL DSYTF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'DSYTF2_RK', INFOT, NOUT, LERR, OK ) +* +* DSYTRI_3 +* + SRNAMT = 'DSYTRI_3' + INFOT = 1 + CALL DSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'DSYTRI_3', INFOT, NOUT, LERR, OK ) +* +* DSYTRI_3X +* + SRNAMT = 'DSYTRI_3X' + INFOT = 1 + CALL DSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'DSYTRI_3X', INFOT, NOUT, LERR, OK ) +* +* DSYTRS_3 +* + SRNAMT = 'DSYTRS_3' + INFOT = 1 + CALL DSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'DSYTRS_3', INFOT, NOUT, LERR, OK ) +* +* DSYCON_3 +* + SRNAMT = 'DSYCON_3' + INFOT = 1 + CALL DSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSYCON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, IW, + $ INFO) + CALL CHKXER( 'DSYCON_3', INFOT, NOUT, LERR, OK ) +* ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * * Test error exits of the routines that use factorization diff --git a/TESTING/LIN/derrvx.f b/TESTING/LIN/derrvx.f index ff57aa7e..c18f9ab0 100644 --- a/TESTING/LIN/derrvx.f +++ b/TESTING/LIN/derrvx.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2016 * *> \ingroup double_lin * * ===================================================================== SUBROUTINE DERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -80,8 +80,8 @@ * .. Local Arrays .. INTEGER IP( NMAX ), IW( NMAX ) DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ C( NMAX ), E( NMAX ), R( NMAX ), R1( NMAX ), + $ R2( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -91,7 +91,7 @@ EXTERNAL CHKXER, DGBSV, DGBSVX, DGESV, DGESVX, DGTSV, $ DGTSVX, DPBSV, DPBSVX, DPOSV, DPOSVX, DPPSV, $ DPPSVX, DPTSV, DPTSVX, DSPSV, DSPSVX, DSYSV, - $ DSYSV_AA, DSYSV_ROOK, DSYSVX + $ DSYSV_AA, DSYSV_RK, DSYSV_ROOK, DSYSVX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -118,13 +118,14 @@ A( I, J ) = 1.D0 / DBLE( I+J ) AF( I, J ) = 1.D0 / DBLE( I+J ) 10 CONTINUE - B( J ) = 0.D0 - R1( J ) = 0.D0 - R2( J ) = 0.D0 - W( J ) = 0.D0 - X( J ) = 0.D0 - C( J ) = 0.D0 - R( J ) = 0.D0 + B( J ) = 0.D+0 + E( J ) = 0.D+0 + R1( J ) = 0.D+0 + R2( J ) = 0.D+0 + W( J ) = 0.D+0 + X( J ) = 0.D+0 + C( J ) = 0.D+0 + R( J ) = 0.D+0 IP( J ) = J 20 CONTINUE EQ = ' ' @@ -583,9 +584,18 @@ INFOT = 3 CALL DSYSV( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYSV( 'U', 2, 0, A, 1, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL DSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK ) * * DSYSVX * @@ -627,25 +637,6 @@ $ RCOND, R1, R2, W, 3, IW, INFO ) CALL CHKXER( 'DSYSVX', INFOT, NOUT, LERR, OK ) * - ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN -* -* DSYSV_AA -* - SRNAMT = 'DSYSV_AA' - INFOT = 1 - CALL DSYSV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL DSYSV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL DSYSV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL DSYSV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK ) -* - ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * * DSYSV_ROOK @@ -660,9 +651,71 @@ INFOT = 3 CALL DSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYSV_ROOK( 'U', 2, 0, A, 1, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL DSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* DSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'DSYSV_RK' + INFOT = 1 + CALL DSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN +* +* DSYSV_AA +* + SRNAMT = 'DSYSV_AA' + INFOT = 1 + CALL DSYSV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYSV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYSV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYSV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_AA', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/TESTING/LIN/derrvxx.f b/TESTING/LIN/derrvxx.f index b28e01cb..d29797b4 100644 --- a/TESTING/LIN/derrvxx.f +++ b/TESTING/LIN/derrvxx.f @@ -82,9 +82,10 @@ * .. Local Arrays .. INTEGER IP( NMAX ), IW( NMAX ) DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ), - $ W( 2*NMAX ), X( NMAX ), ERR_BNDS_N( NMAX, 3 ), - $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) + $ C( NMAX ), E( NMAX ), R( NMAX ), R1( NMAX ), + $ R2( NMAX ), W( 2*NMAX ), X( NMAX ), + $ ERR_BNDS_N( NMAX, 3 ), ERR_BNDS_C( NMAX, 3 ), + $ PARAMS( 1 ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -94,7 +95,8 @@ EXTERNAL CHKXER, DGBSV, DGBSVX, DGESV, DGESVX, DGTSV, $ DGTSVX, DPBSV, DPBSVX, DPOSV, DPOSVX, DPPSV, $ DPPSVX, DPTSV, DPTSVX, DSPSV, DSPSVX, DSYSV, - $ DSYSVX, DGESVXX, DSYSVXX, DPOSVXX, DGBSVXX + $ DSYSV_RK, DSYSV_ROOK, DSYSVX, DGESVXX, DSYSVXX, + $ DPOSVXX, DGBSVXX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -121,13 +123,14 @@ A( I, J ) = 1.D0 / DBLE( I+J ) AF( I, J ) = 1.D0 / DBLE( I+J ) 10 CONTINUE - B( J ) = 0.D0 - R1( J ) = 0.D0 - R2( J ) = 0.D0 - W( J ) = 0.D0 - X( J ) = 0.D0 - C( J ) = 0.D0 - R( J ) = 0.D0 + B( J ) = 0.D+0 + E( J ) = 0.D+0 + R1( J ) = 0.D+0 + R2( J ) = 0.D+0 + W( J ) = 0.D+0 + X( J ) = 0.D+0 + C( J ) = 0.D+0 + R( J ) = 0.D+0 IP( J ) = J 20 CONTINUE EQ = ' ' @@ -795,9 +798,18 @@ INFOT = 3 CALL DSYSV( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYSV( 'U', 2, 0, A, 1, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) INFOT = 8 CALL DSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'DSYSV ', INFOT, NOUT, LERR, OK ) * * DSYSVX * @@ -907,6 +919,68 @@ $ ERR_BNDS_C, NPARAMS, PARAMS, W, IW, INFO ) CALL CHKXER( 'DSYSVXX', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* +* DSYSV_ROOK +* + SRNAMT = 'DSYSV_ROOK' + INFOT = 1 + CALL DSYSV_ROOK( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYSV_ROOK( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYSV_ROOK( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYSV_ROOK( 'U', 2, 0, A, 1, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'DSYSV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* DSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'DSYSV_RK' + INFOT = 1 + CALL DSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'DSYSV_RK', INFOT, NOUT, LERR, OK ) +* ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * * DSPSV diff --git a/TESTING/LIN/dsyt01_3.f b/TESTING/LIN/dsyt01_3.f new file mode 100644 index 00000000..92e4aefe --- /dev/null +++ b/TESTING/LIN/dsyt01_3.f @@ -0,0 +1,248 @@ +*> \brief \b DSYT01_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, +* LDC, RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* $ E( * ), RWORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSYT01_3 reconstructs a symmetric indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization computed by DSYTRF_RK +*> (or DSYTRF_BK) and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> 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 +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The original symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is DOUBLE PRECISION array, dimension (LDAFAC,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by DSYTRF_RK and DSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. +*> LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> 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 refernced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from DSYTRF_RK (or DSYTRF_BK). +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> 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 ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2016 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ E( * ), RWORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + DOUBLE PRECISION ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DLASET, DLAVSY_ROOK, DSYCONVF_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* a) Revert to multiplyers of L +* + CALL DSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO ) +* +* 1) Determine EPS and the norm of A. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* 2) Initialize C to the identity matrix. +* + CALL DLASET( 'Full', N, N, ZERO, ONE, C, LDC ) +* +* 3) Call DLAVSY_ROOK to form the product D * U' (or D * L' ). +* + CALL DLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 4) Call DLAVSY_ROOK again to multiply by U (or L ). +* + CALL DLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 5) Compute the difference C - A. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* 6) Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = DLANSY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS + END IF + +* +* b) Convert to factor of L (or U) +* + CALL DSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO ) +* + RETURN +* +* End of DSYT01_3 +* + END diff --git a/TESTING/LIN/schkaa.f b/TESTING/LIN/schkaa.f index 37984e14..675e32f1 100644 --- a/TESTING/LIN/schkaa.f +++ b/TESTING/LIN/schkaa.f @@ -51,6 +51,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 *> 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 @@ -146,8 +148,8 @@ $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) REAL A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ), - $ RWORK( 5*NMAX+2*MAXRHS ), S( 2*NMAX ), - $ WORK( NMAX, NMAX+MAXRHS+30 ) + $ E( NMAX ), RWORK( 5*NMAX+2*MAXRHS ), + $ S( 2*NMAX ), WORK( NMAX, NMAX+MAXRHS+30 ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN @@ -158,11 +160,11 @@ EXTERNAL ALAREQ, SCHKEQ, SCHKGB, SCHKGE, SCHKGT, SCHKLQ, $ SCHKPB, SCHKPO, SCHKPS, SCHKPP, SCHKPT, SCHKQ3, $ SCHKQL, SCHKQR, SCHKRQ, SCHKSP, SCHKSY, - $ SCHKSY_ROOK, SCHKSY_AA, SCHKTB, SCHKTP, SCHKTR, - $ SCHKTZ, SDRVGB, SDRVGE, SDRVGT, SDRVLS, SDRVPB, - $ SDRVPO, SDRVPP, SDRVPT, SDRVSP, SDRVSY, - $ SDRVSY_ROOK, SDRVSY_AA, ILAVER, SCHKLQTP, - $ SCHKQRT, SCHKQRTP + $ SCHKSY_ROOK, SCHKSY_RK, SCHKSY_AA, SCHKTB, + $ SCHKTP, SCHKTR, SCHKTZ, SDRVGB, SDRVGE, SDRVGT, + $ SDRVLS, SDRVPB, SDRVPO, SDRVPP, SDRVPT, SDRVSP, + $ SDRVSY, SDRVSY_ROOK, SDRVSY_RK, SDRVSY_AA, + $ ILAVER, SCHKLQTP, SCHKQRT, SCHKQRTP * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -641,8 +643,8 @@ * ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * -* SR: symmetric indefinite matrices with Rook pivoting, -* with rook (bounded Bunch-Kaufman) pivoting algorithm +* SR: symmetric indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm * NTYPES = 10 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) @@ -665,9 +667,36 @@ WRITE( NOUT, FMT = 9988 )PATH END IF * + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* SK: symmetric indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm, +* differnet matrix storage format than SR path version. +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL SCHKSY_RK( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL SDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF +* ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN * -* SY: symmetric indefinite matrices, +* SA: symmetric indefinite matrices, * with partial (Aasen's) pivoting algorithm * NTYPES = 10 diff --git a/TESTING/LIN/schksy_rk.f b/TESTING/LIN/schksy_rk.f new file mode 100644 index 00000000..6205f6c1 --- /dev/null +++ b/TESTING/LIN/schksy_rk.f @@ -0,0 +1,846 @@ +*> \brief \b SCHKSY_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, +* X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* REAL A( * ), AFAC( * ), E( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> SCHKSY_RK tests SSYTRF_RK, -TRI_3, -TRS_3, and -CON_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is REAL array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is REAL array, dimension (NMAX*NSMAX), +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is REAL array, dimension (NMAX*NSMAX), +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is REAL array, dimension (NMAX*NSMAX), +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE SCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + REAL A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + REAL EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, IUPLO, IZERO, J, K, KL, KU, LDA, LWORK, + $ MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, NRUN, + $ NT + REAL ALPHA, ANORM, CNDNUM, CONST, STEMP, SING_MAX, + $ SING_MIN, RCOND, RCONDC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER IDUMMY( 1 ), ISEED( 4 ), ISEEDY( 4 ) + REAL BLOCK( 2, 2 ), SDUMMY( 1 ), RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL SGET06, SLANGE, SLANSY + EXTERNAL SGET06, SLANGE, SLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, SERRSY, SGESVD, SGET04, + $ SLACPY, SLARHS, SLATB4, SLATMS, SPOT02, SPOT03, + $ SSYCON_3, SSYT01_3, SSYTRF_RK, SSYTRI_3, + $ SSYTRS_3, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'SK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Single precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL SERRSY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with SLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL SLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with SLATMS. +* + SRNAMT = 'SLATMS' + CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from SLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'SSYTRF_RK' + CALL SSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from DSYTRF_RK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'SSYTRF_RK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL SSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'SSYTRI_3' +* +* Another reason that we need to compute the invesrse +* is that SPOT03 produces RCONDC which is used later +* in TEST6 and TEST7. +* + LWORK = (N+NB+1)*(NB+3) + CALL SSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Check error code from SSYTRI_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'SSYTRI_3', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a symmetric matrix times +* its inverse. +* + CALL SPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + STEMP = ZERO +* + CONST = ONE / ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in U +* + STEMP = SLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + STEMP = SLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in L +* + STEMP = SLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + STEMP = SLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = STEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +*+ TEST 4 +* Compute largest 2-Norm (condition number) +* of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + STEMP = ZERO +* + CONST = ( ONE+ALPHA ) / ( ONE-ALPHA ) + CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 ) + BLOCK( 1, 2 ) = E( K ) + BLOCK( 2, 1 ) = BLOCK( 1, 2 ) + BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K ) +* + CALL SGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ SDUMMY, 1, SDUMMY, 1, + $ WORK, 10, INFO ) +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + STEMP = SING_MAX / SING_MIN +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K ) + BLOCK( 2, 1 ) = E( K ) + BLOCK( 1, 2 ) = BLOCK( 2, 1 ) + BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 ) +* + CALL SGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ SDUMMY, 1, SDUMMY, 1, + $ WORK, 10, INFO ) +* +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + STEMP = SING_MAX / SING_MIN +* +* STEMP should be bounded by CONST +* + STEMP = STEMP - CONST + THRESH + IF( STEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = STEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 5 ( Using TRS_3) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'SLARHS' + CALL SLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'SSYTRS_3' + CALL SSYTRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, INFO ) +* +* Check error code from SSYTRS_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'SSYTRS_3', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'SSYCON_3' + CALL SSYCON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM, + $ RCOND, WORK, IWORK( N+1 ), INFO ) +* +* Check error code from DSYCON_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'SSYCON_3', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare to values of RCOND +* + RESULT( 7 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 ) UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test(', I2, ') =', G12.5 ) + RETURN +* +* End of SCHKSY_RK +* + END diff --git a/TESTING/LIN/sdrvsy_rk.f b/TESTING/LIN/sdrvsy_rk.f new file mode 100644 index 00000000..f91d2e0e --- /dev/null +++ b/TESTING/LIN/sdrvsy_rk.f @@ -0,0 +1,531 @@ +*> \brief \b SDRVSY_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, +* $ RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* REAL A( * ), AFAC( * ), E( * ), AINV( * ), B( * ), +* $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> SDRVSY_RK tests the driver routines SSYSV_RK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is REAL array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is REAL array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is REAL array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ RWORK( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + REAL AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL SLANSY + EXTERNAL SLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGET04, SLACPY, + $ SLARHS, SLATB4, SLATMS, SPOT02, SSYSV_RK, + $ SSYT01_3, SSYTRF_RK, SSYTRI_3, XLAENV +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'SK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Single precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL SERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with SLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL SLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with SLATMS. +* + SRNAMT = 'SLATMS' + CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK, + $ INFO ) +* +* Check error code from SLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of the +* matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IOFF = 0 + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL SSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL SLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) +* +* We need to copute the invesrse to compute +* RCONDC that is used later in TEST3. +* + CALL SSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, + $ WORK, LWORK, INFO ) + AINVNM = SLANSY( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'SLARHS' + CALL SLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test SSYSV_RK --- +* + IF( IFACT.EQ.2 ) THEN + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* SSYSV_RK. +* + SRNAMT = 'SSYSV_RK' + CALL SSYSV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from SSYSV_RK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'SSYSV_RK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL SSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'SSYSV_RK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of SDRVSY_RK +* + END diff --git a/TESTING/LIN/serrsy.f b/TESTING/LIN/serrsy.f index 8fd38687..bf69893a 100644 --- a/TESTING/LIN/serrsy.f +++ b/TESTING/LIN/serrsy.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date November 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -79,18 +79,20 @@ * .. Local Arrays .. INTEGER IP( NMAX ), IW( NMAX ) REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX ) + $ E( NMAX ), R1( NMAX ), R2( NMAX ), W( 3*NMAX ), + $ X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, SSPCON, SSYCON_ROOK, SSPRFS, - $ SSPTRF, SSPTRI, SSPTRS, SSYCON, SSYRFS, SSYTF2, - $ SSYTF2_ROOK, SSYTRF, SSYTRF_ROOK, SSYTRF_AA, - $ SSYTRI, SSYTRI_ROOK, SSYTRI2, SSYTRS, - $ SSYTRS_ROOK, SSYTRS_AA + EXTERNAL ALAESM, CHKXER, SSPCON, SSPRFS, SSPTRF, SSPTRI, + $ SSPTRS, SSYCON, SSYCON_3, SSYCON_ROOK, SSYRFS, + $ SSYTF2_RK, SSYTF2_ROOK, SSYTRF, SSYTRF_RK, + $ SSYTRF_ROOK, SSYTRI, SSYTF2, SSYTRI_3, + $ SSYTRI_3X, SSYTRI_ROOK, SSYTRF_AA, SSYTRI2, + $ SYTRI2X, SSYTRS, SSYTRS_3, SSYTRS_ROOK, SSYTRS_AA * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -117,11 +119,12 @@ A( I, J ) = 1. / REAL( I+J ) AF( I, J ) = 1. / REAL( I+J ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 IP( J ) = J IW( J ) = J 20 CONTINUE @@ -147,6 +150,12 @@ INFOT = 4 CALL SSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK ) * * SSYTF2 * @@ -187,6 +196,19 @@ CALL SSYTRI2( 'U', 2, A, 1, IP, W, IW(1), INFO ) CALL CHKXER( 'SSYTRI2', INFOT, NOUT, LERR, OK ) * +* SSYTRI2X +* + SRNAMT = 'SSYTRI2X' + INFOT = 1 + CALL SSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK ) +* * SSYTRS * SRNAMT = 'SSYTRS' @@ -272,6 +294,12 @@ INFOT = 4 CALL SSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) * * SSYTF2_ROOK * @@ -334,9 +362,118 @@ CALL SSYCON_ROOK( 'U', 1, A, 1, IP, -1.0, RCOND, W, IW, INFO ) CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* * Test error exits of the routines that use factorization -* of a symmetric indefinite packed matrix with patrial -* (Bunch-Kaufman) pivoting. +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* SSYTRF_RK +* + SRNAMT = 'SSYTRF_RK' + INFOT = 1 + CALL SSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) +* +* SSYTF2_RK +* + SRNAMT = 'SSYTF2_RK' + INFOT = 1 + CALL SSYTF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK ) +* +* SSYTRI_3 +* + SRNAMT = 'SSYTRI_3' + INFOT = 1 + CALL SSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) +* +* SSYTRI_3X +* + SRNAMT = 'SSYTRI_3X' + INFOT = 1 + CALL SSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK ) +* +* SSYTRS_3 +* + SRNAMT = 'SSYTRS_3' + INFOT = 1 + CALL SSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) +* +* SSYCON_3 +* + SRNAMT = 'SSYCON_3' + INFOT = 1 + CALL SSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYCON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, IW, + $ INFO) + CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN * @@ -374,8 +511,13 @@ INFOT = 8 CALL SSYTRS_AA( 'U', 2, 1, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'SSYTRS_AA', INFOT, NOUT, LERR, OK ) +* ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite packed matrix with patrial +* (Bunch-Kaufman) pivoting. +* * SSPTRF * SRNAMT = 'SSPTRF' diff --git a/TESTING/LIN/serrsyx.f b/TESTING/LIN/serrsyx.f index 9d5baaed..91ce5fc9 100644 --- a/TESTING/LIN/serrsyx.f +++ b/TESTING/LIN/serrsyx.f @@ -51,17 +51,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date November 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -83,8 +83,8 @@ * .. Local Arrays .. INTEGER IP( NMAX ), IW( NMAX ) REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ R1( NMAX ), R2( NMAX ), W( 3*NMAX ), X( NMAX ), - $ S( NMAX ), ERR_BNDS_N( NMAX, 3 ), + $ E( NMAX ), R1( NMAX ), R2( NMAX ), W( 3*NMAX ), + $ X( NMAX ), S( NMAX ), ERR_BNDS_N( NMAX, 3 ), $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) * .. * .. External Functions .. @@ -93,10 +93,11 @@ * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, SSPCON, SSPRFS, SSPTRF, SSPTRI, - $ SSPTRS, SSYCON, SSYCON_ROOK,SSYRFS, SSYTF2, - $ SSYTF2_ROOK, SSYTRF, SSYTRF_ROOK, SSYTRI, - $ SSYTRI_ROOK, SSYTRI2, SSYTRS, SSYTRS_ROOK, - $ SSYRFSX + $ SSPTRS, SSYCON, SSYCON_3, SSYCON_ROOK, SSYRFS, + $ SSYTF2, SSYTF2_RK, SSYTF2_ROOK, SSYTRF, + $ SSYTRF_RK, SSYTRF_ROOK, SSYTRI, SSYTRI_3, + $ SSYTRI_3X, SSYTRI_ROOK, SSYTRI2, SSYTRI2X, + $ SSYTRS, SSYTRS_3, SSYTRS_ROOK, SSYRFSX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -123,12 +124,12 @@ A( I, J ) = 1. / REAL( I+J ) AF( I, J ) = 1. / REAL( I+J ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. - S( J ) = 0. + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 IP( J ) = J IW( J ) = J 20 CONTINUE @@ -154,6 +155,12 @@ INFOT = 4 CALL SSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'SSYTRF', INFOT, NOUT, LERR, OK ) * * SSYTF2 * @@ -194,6 +201,19 @@ CALL SSYTRI2( 'U', 2, A, 1, IP, W, IW, INFO ) CALL CHKXER( 'SSYTRI', INFOT, NOUT, LERR, OK ) * +* SSYTRI2X +* + SRNAMT = 'SSYTRI2X' + INFOT = 1 + CALL SSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI2X', INFOT, NOUT, LERR, OK ) +* * SSYTRS * SRNAMT = 'SSYTRS' @@ -326,6 +346,12 @@ INFOT = 4 CALL SSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'SSYTRF_ROOK', INFOT, NOUT, LERR, OK ) * * SSYTF2_ROOK * @@ -388,12 +414,125 @@ CALL SSYCON_ROOK( 'U', 1, A, 1, IP, -1.0, RCOND, W, IW, INFO ) CALL CHKXER( 'SSYCON_ROOK', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* * Test error exits of the routines that use factorization -* of a symmetric indefinite packed matrix with patrial -* (Bunch-Kaufman) pivoting. +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* SSYTRF_RK +* + SRNAMT = 'SSYTRF_RK' + INFOT = 1 + CALL SSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'SSYTRF_RK', INFOT, NOUT, LERR, OK ) +* +* SSYTF2_RK +* + SRNAMT = 'SSYTF2_RK' + INFOT = 1 + CALL SSYTF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'SSYTF2_RK', INFOT, NOUT, LERR, OK ) +* +* SSYTRI_3 +* + SRNAMT = 'SSYTRI_3' + INFOT = 1 + CALL SSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'SSYTRI_3', INFOT, NOUT, LERR, OK ) +* +* SSYTRI_3X +* + SRNAMT = 'SSYTRI_3X' + INFOT = 1 + CALL SSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'SSYTRI_3X', INFOT, NOUT, LERR, OK ) +* +* SSYTRS_3 +* + SRNAMT = 'SSYTRS_3' + INFOT = 1 + CALL SSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'SSYTRS_3', INFOT, NOUT, LERR, OK ) +* +* SSYCON_3 +* + SRNAMT = 'SSYCON_3' + INFOT = 1 + CALL SSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SSYCON_3( 'U', 1, A, 1, E, IP, -1.0E0, RCOND, W, IW, + $ INFO) + CALL CHKXER( 'SSYCON_3', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite packed matrix with patrial +* (Bunch-Kaufman) pivoting. +* * SSPTRF * SRNAMT = 'SSPTRF' diff --git a/TESTING/LIN/serrvx.f b/TESTING/LIN/serrvx.f index 6bb49238..09e83397 100644 --- a/TESTING/LIN/serrvx.f +++ b/TESTING/LIN/serrvx.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date April 2012 +*> \date November 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.4.1) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* April 2012 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -80,8 +80,8 @@ * .. Local Arrays .. INTEGER IP( NMAX ), IW( NMAX ) REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ C( NMAX ), E( NMAX ), R( NMAX ), R1( NMAX ), + $ R2( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -91,7 +91,7 @@ EXTERNAL CHKXER, SGBSV, SGBSVX, SGESV, SGESVX, SGTSV, $ SGTSVX, SPBSV, SPBSVX, SPOSV, SPOSVX, SPPSV, $ SPPSVX, SPTSV, SPTSVX, SSPSV, SSPSVX, SSYSV, - $ SSYSV_AA, SSYSV_ROOK, SSYSVX + $ SSYSV_AA, SSYSV_RK, SSYSV_ROOK, SSYSVX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -118,13 +118,14 @@ A( I, J ) = 1. / REAL( I+J ) AF( I, J ) = 1. / REAL( I+J ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. - C( J ) = 0. - R( J ) = 0. + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 + C( J ) = 0.E+0 + R( J ) = 0.E+0 IP( J ) = J 20 CONTINUE EQ = ' ' @@ -586,6 +587,12 @@ INFOT = 8 CALL SSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK ) * * SSYSVX * @@ -627,23 +634,6 @@ $ RCOND, R1, R2, W, 3, IW, INFO ) CALL CHKXER( 'SSYSVX', INFOT, NOUT, LERR, OK ) * - ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN -* -* SSYSV_AA -* - SRNAMT = 'SSYSV_AA' - INFOT = 1 - CALL SSYSV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL SSYSV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL SSYSV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL SSYSV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * @@ -662,6 +652,65 @@ INFOT = 8 CALL SSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* SSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'SSYSV_RK' + INFOT = 1 + CALL SSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SA' ) ) THEN +* +* SSYSV_AA +* + SRNAMT = 'SSYSV_AA' + INFOT = 1 + CALL SSYSV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYSV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYSV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSYSV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_AA', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/TESTING/LIN/serrvxx.f b/TESTING/LIN/serrvxx.f index 146e8b37..02459133 100644 --- a/TESTING/LIN/serrvxx.f +++ b/TESTING/LIN/serrvxx.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date November 2016 * *> \ingroup single_lin * * ===================================================================== SUBROUTINE SERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -82,9 +82,10 @@ * .. Local Arrays .. INTEGER IP( NMAX ), IW( NMAX ) REAL A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ), - $ W( 2*NMAX ), X( NMAX ), ERR_BNDS_N( NMAX, 3 ), - $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) + $ C( NMAX ), E( NMAX ), R( NMAX ), R1( NMAX ), + $ R2( NMAX ), W( 2*NMAX ), X( NMAX ), + $ ERR_BNDS_N( NMAX, 3 ), ERR_BNDS_C( NMAX, 3 ), + $ PARAMS( 1 ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -94,8 +95,8 @@ EXTERNAL CHKXER, SGBSV, SGBSVX, SGESV, SGESVX, SGTSV, $ SGTSVX, SPBSV, SPBSVX, SPOSV, SPOSVX, SPPSV, $ SPPSVX, SPTSV, SPTSVX, SSPSV, SSPSVX, SSYSV, - $ SSYSV_ROOK, SSYSVX, SGESVXX, SSYSVXX, SPOSVXX, - $ SGBSVXX + $ SSYSV_RK, SSYSV_ROOK, SSYSVX, SGESVXX, SSYSVXX, + $ SPOSVXX, SGBSVXX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -122,13 +123,14 @@ A( I, J ) = 1. / REAL( I+J ) AF( I, J ) = 1. / REAL( I+J ) 10 CONTINUE - B( J ) = 0. - R1( J ) = 0. - R2( J ) = 0. - W( J ) = 0. - X( J ) = 0. - C( J ) = 0. - R( J ) = 0. + B( J ) = 0.E+0 + E( J ) = 0.E+0 + R1( J ) = 0.E+0 + R2( J ) = 0.E+0 + W( J ) = 0.E+0 + X( J ) = 0.E+0 + C( J ) = 0.E+0 + R( J ) = 0.E+0 IP( J ) = J 20 CONTINUE EQ = ' ' @@ -799,6 +801,12 @@ INFOT = 8 CALL SSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'SSYSV ', INFOT, NOUT, LERR, OK ) * * SSYSVX * @@ -908,6 +916,8 @@ $ ERR_BNDS_C, NPARAMS, PARAMS, W, IW, INFO ) CALL CHKXER( 'SSYSVXX', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN +* * SSYSV_ROOK * SRNAMT = 'SSYSV_ROOK' @@ -923,6 +933,47 @@ INFOT = 8 CALL SSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'SSYSV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* SSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'SSYSV_RK' + INFOT = 1 + CALL SSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'SSYSV_RK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/TESTING/LIN/ssyt01_3.f b/TESTING/LIN/ssyt01_3.f new file mode 100644 index 00000000..8364d021 --- /dev/null +++ b/TESTING/LIN/ssyt01_3.f @@ -0,0 +1,248 @@ +*> \brief \b SSYT01_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, +* LDC, RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* $ E( * ), RWORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> 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 +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> The original symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. +*> LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> 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 refernced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from SSYTRF_RK (or SSYTRF_BK). +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> 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 ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2016 +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + REAL RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + REAL A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ E( * ), RWORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + REAL ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SLAMCH, SLANSY + EXTERNAL LSAME, SLAMCH, SLANSY +* .. +* .. External Subroutines .. + EXTERNAL SLASET, SLAVSY_ROOK, SSYCONVF_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* a) Revert to multiplyers of L +* + CALL SSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO ) +* +* 1) Determine EPS and the norm of A. +* + EPS = SLAMCH( 'Epsilon' ) + ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* 2) Initialize C to the identity matrix. +* + CALL SLASET( 'Full', N, N, ZERO, ONE, C, LDC ) +* +* 3) Call SLAVSY_ROOK to form the product D * U' (or D * L' ). +* + CALL SLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 4) Call SLAVSY_ROOK again to multiply by U (or L ). +* + CALL SLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 5) Compute the difference C - A. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* 6) Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = SLANSY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS + END IF + +* +* b) Convert to factor of L (or U) +* + CALL SSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO ) +* + RETURN +* +* End of SSYT01_3 +* + END diff --git a/TESTING/LIN/zchkaa.f b/TESTING/LIN/zchkaa.f index 766f873f..f9be8451 100644 --- a/TESTING/LIN/zchkaa.f +++ b/TESTING/LIN/zchkaa.f @@ -50,11 +50,13 @@ *> ZPB 8 List types on next line if 0 < NTYPES < 8 *> ZPT 12 List types on next line if 0 < NTYPES < 12 *> ZHE 10 List types on next line if 0 < NTYPES < 10 -*> ZHA 10 List types on next line if 0 < NTYPES < 10 *> ZHR 10 List types on next line if 0 < NTYPES < 10 +*> ZHK 10 List types on next line if 0 < NTYPES < 10 +*> ZHA 10 List types on next line if 0 < NTYPES < 10 *> ZHP 10 List types on next line if 0 < NTYPES < 10 *> ZSY 11 List types on next line if 0 < NTYPES < 11 *> ZSR 11 List types on next line if 0 < NTYPES < 11 +*> ZSK 11 List types on next line if 0 < NTYPES < 11 *> ZSP 11 List types on next line if 0 < NTYPES < 11 *> ZTR 18 List types on next line if 0 < NTYPES < 18 *> ZTP 18 List types on next line if 0 < NTYPES < 18 @@ -151,7 +153,7 @@ $ RANKVAL( MAXIN ), PIV( NMAX ) DOUBLE PRECISION RWORK( 150*NMAX+2*MAXRHS ), S( 2*NMAX ) COMPLEX*16 A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ), - $ WORK( NMAX, NMAX+MAXRHS+10 ) + $ E( NMAX ), WORK( NMAX, NMAX+MAXRHS+10 ) * .. * .. External Functions .. LOGICAL LSAME, LSAMEN @@ -160,14 +162,15 @@ * .. * .. External Subroutines .. EXTERNAL ALAREQ, ZCHKEQ, ZCHKGB, ZCHKGE, ZCHKGT, ZCHKHE, - $ ZCHKHE_ROOK, ZCHKHE_AA, ZCHKHP, ZCHKLQ, ZCHKPB, - $ ZCHKPO, ZCHKPS, ZCHKPP, ZCHKPT, ZCHKQ3, ZCHKQL, - $ ZCHKQR, ZCHKRQ, ZCHKSP, ZCHKSY, ZCHKSY_ROOK, - $ ZCHKTB, ZCHKTP, ZCHKTR, ZCHKTZ, ZDRVGB, ZDRVGE, - $ ZDRVGT, ZDRVHE, ZDRVHE_ROOK, ZDRVHE_AA, ZDRVHP, - $ ZDRVLS, ZDRVPB, ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP, - $ ZDRVSY, ZDRVSY_ROOK, ILAVER, ZCHKQRT, ZCHKQRTP, - $ ZCHKLQT, ZCHKLQTP, ZCHKTSQR + $ ZCHKHE_ROOK, ZCHKHE_RK, ZCHKHE_AA, ZCHKHP, + $ ZCHKLQ, ZCHKPB, ZCHKPO, ZCHKPS, ZCHKPP, ZCHKPT, + $ ZCHKQ3, ZCHKQL, ZCHKQR, ZCHKRQ, ZCHKSP, ZCHKSY, + $ ZCHKSY_ROOK, ZCHKSY_RK, ZCHKTB, ZCHKTP, ZCHKTR, + $ ZCHKTZ, ZDRVGB, ZDRVGE, ZDRVGT, ZDRVHE, ZDRVHE_ROOK, + $ ZDRVHE_RK, ZDRVHE_AA, ZDRVHP, ZDRVLS, ZDRVPB, + $ ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP, ZDRVSY, ZDRVSY_ROOK, + $ ZDRVSY_RK, ILAVER, ZCHKQRT, ZCHKQRTP, ZCHKLQT, + $ ZCHKLQTP, ZCHKTSQR * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -640,56 +643,83 @@ ELSE WRITE( NOUT, FMT = 9988 )PATH END IF + + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * - ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN -* -* HA: Hermitian indefinite matrices, -* with partial (Aasen's) pivoting algorithm +* HR: Hermitian indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm, * NTYPES = 10 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN - CALL ZCHKHE_AA( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, - $ NSVAL, THRESH, TSTERR, LDA, - $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), - $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), - $ WORK, RWORK, IWORK, NOUT ) + CALL ZCHKHE_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH END IF * IF( TSTDRV ) THEN - CALL ZDRVHE_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, - $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), - $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), - $ WORK, RWORK, IWORK, NOUT ) + CALL ZDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, + $ RWORK, IWORK, NOUT ) ELSE WRITE( NOUT, FMT = 9988 )PATH END IF * - ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN * -* HR: Hermitian indefinite matrices, -* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* HK: Hermitian indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm, +* differnet matrix storage format than HR path version. * NTYPES = 10 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) * IF( TSTCHK ) THEN - CALL ZCHKHE_ROOK(DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + CALL ZCHKHE_RK ( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), - $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), - $ WORK, RWORK, IWORK, NOUT ) + $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT ) ELSE WRITE( NOUT, FMT = 9989 )PATH END IF * IF( TSTDRV ) THEN - CALL ZDRVHE_ROOK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, - $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), - $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, - $ RWORK, IWORK, NOUT ) + CALL ZDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, + $ RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF +* + ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN +* +* HA: Hermitian indefinite matrices, +* with partial (Aasen's) pivoting algorithm +* + NTYPES = 10 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL ZCHKHE_AA( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, + $ NSVAL, THRESH, TSTERR, LDA, + $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL ZDRVHE_AA( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), + $ WORK, RWORK, IWORK, NOUT ) ELSE WRITE( NOUT, FMT = 9988 )PATH END IF @@ -748,7 +778,7 @@ ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * * SR: symmetric indefinite matrices, -* with "rook" (bounded Bunch-Kaufman) pivoting algorithm +* with bounded Bunch-Kaufman (rook) pivoting algorithm * NTYPES = 11 CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) @@ -771,6 +801,33 @@ WRITE( NOUT, FMT = 9988 )PATH END IF * + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* SK: symmetric indefinite matrices, +* with bounded Bunch-Kaufman (rook) pivoting algorithm, +* differnet matrix storage format than SR path version. +* + NTYPES = 11 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL ZCHKSY_RK( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL, + $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ), + $ E, A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), + $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* + IF( TSTDRV ) THEN + CALL ZDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ LDA, A( 1, 1 ), A( 1, 2 ), E, A( 1, 3 ), + $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, + $ RWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9988 )PATH + END IF +* ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * * SP: symmetric indefinite packed matrices, diff --git a/TESTING/LIN/zchkhe_rk.f b/TESTING/LIN/zchkhe_rk.f new file mode 100644 index 00000000..6c05245f --- /dev/null +++ b/TESTING/LIN/zchkhe_rk.f @@ -0,0 +1,859 @@ +*> \brief \b ZCHKHE_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKHE_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, AINV, B, X, +* XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKHE_RK tests ZHETRF_RK, -TRI_3, -TRS_3, +*> and -CON_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is CCOMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is CCOMPLEX*16 array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZCHKHE_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ONEHALF + PARAMETER ( ONEHALF = 0.5D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) + INTEGER NTYPES + PARAMETER ( NTYPES = 10 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA, + $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, + $ NRUN, NT + DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, SING_MAX, + $ SING_MIN, RCOND, RCONDC, DTEMP +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ), IDUMMY( 1 ) + DOUBLE PRECISION RESULT( NTESTS ) + COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DGET06, ZLANGE, ZLANHE + EXTERNAL DGET06, ZLANGE, ZLANHE +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, ZERRHE, ZGESVD, ZGET04, + $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZPOT02, ZPOT03, + $ ZHECON_3, ZHET01_3, ZHETRF_RK, ZHETRI_3, + $ ZHETRS_3, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC DCONJG, MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'HK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'HE' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRHE( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with ZLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with ZLATMS. +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from ZLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'ZHETRF_RK' + CALL ZHETRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from ZHETRF_RK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'ZHETRF_RK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL ZHET01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'ZHETRI_3' +* +* Another reason that we need to compute the invesrse +* is that ZPOT03 produces RCONDC which is used later +* in TEST6 and TEST7. +* + LWORK = (N+NB+1)*(NB+3) + CALL ZHETRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Check error code from ZHETRI_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZHETRI_3', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a Hermitian matrix times +* its inverse. +* + CALL ZPOT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + DTEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) / + $ ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in U +* + DTEMP = ZLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + DTEMP = ZLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in L +* + DTEMP = ZLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + DTEMP = ZLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +* +*+ TEST 4 +* Compute largest 2-Norm (condition number) +* of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + DTEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )* + $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) ) + CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 ) + BLOCK( 1, 2 ) = E( K ) + BLOCK( 2, 1 ) = DCONJG( BLOCK( 1, 2 ) ) + BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K ) +* + CALL ZGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ ZDUMMY, 1, ZDUMMY, 1, + $ WORK, 6, RWORK( 3 ), INFO ) +* +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + DTEMP = SING_MAX / SING_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K ) + BLOCK( 2, 1 ) = E( K ) + BLOCK( 1, 2 ) = DCONJG( BLOCK( 2, 1 ) ) + BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 ) +* + CALL ZGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ ZDUMMY, 1, ZDUMMY, 1, + $ WORK, 6, RWORK(3), INFO ) +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + DTEMP = SING_MAX / SING_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +* Begin loop over NRHS values +* +* +*+ TEST 5 ( Using TRS_3) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'ZHETRS_3' + CALL ZHETRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, INFO ) +* +* Check error code from ZHETRS_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZHETRS_3', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'ZHECON_3' + CALL ZHECON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM, + $ RCOND, WORK, INFO ) +* +* Check error code from ZHECON_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZHECON_3', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare values of RCOND +* + RESULT( 7 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of ZCHKHE_RK +* + END diff --git a/TESTING/LIN/zchksy_rk.f b/TESTING/LIN/zchksy_rk.f new file mode 100644 index 00000000..b8c62e57 --- /dev/null +++ b/TESTING/LIN/zchksy_rk.f @@ -0,0 +1,867 @@ +*> \brief \b ZCHKSY_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, +* THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, +* X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NNB, NNS, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKSY_RK tests ZSYTRF_RK, -TRI_3, -TRS_3, +*> and -CON_3. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB contained in the vector NBVAL. +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NBVAL) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NNS +*> \verbatim +*> NNS is INTEGER +*> The number of values of NRHS contained in the vector NSVAL. +*> \endverbatim +*> +*> \param[in] NSVAL +*> \verbatim +*> NSVAL is INTEGER array, dimension (NNS) +*> The values of the number of right hand sides NRHS. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim + +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> where NSMAX is the largest entry in NSVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NSMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (NMAX*max(3,NSMAX)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (max(NMAX,2*NSMAX)) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZCHKSY_RK( DOTYPE, NN, NVAL, NNB, NBVAL, NNS, NSVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, E, AINV, B, + $ X, XACT, WORK, RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NNB, NNS, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), NSVAL( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION ONEHALF + PARAMETER ( ONEHALF = 0.5D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) + INTEGER NTYPES + PARAMETER ( NTYPES = 11 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) +* .. +* .. Local Scalars .. + LOGICAL TRFCON, ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH, MATPATH + INTEGER I, I1, I2, IMAT, IN, INB, INFO, IOFF, IRHS, + $ ITEMP, ITEMP2, IUPLO, IZERO, J, K, KL, KU, LDA, + $ LWORK, MODE, N, NB, NERRS, NFAIL, NIMAT, NRHS, + $ NRUN, NT + DOUBLE PRECISION ALPHA, ANORM, CNDNUM, CONST, DTEMP, SING_MAX, + $ SING_MIN, RCOND, RCONDC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) + COMPLEX*16 BLOCK( 2, 2 ), ZDUMMY( 1 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DGET06, ZLANGE, ZLANSY + EXTERNAL DGET06, ZLANGE, ZLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, ZERRSY, ZGESVD, ZGET04, + $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZLATSY, ZSYT02, + $ ZSYT03, ZSYCON_3, ZSYT01_3, ZSYTRF_RK, + $ ZSYTRI_3, ZSYTRS_3, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'SK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRSY( PATH, NOUT ) + INFOT = 0 +* +* Set the minimum block size for which the block routine should +* be used, which will be later returned by ILAENV +* + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 270 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 +* +* Do for each value of matrix type IMAT +* + DO 260 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 260 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 260 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 250 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate test matrix A. +* + IF( IMAT.NE.NTYPES ) THEN +* +* Set up parameters with ZLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with ZLATMS. +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from ZLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) +* +* Skip all tests for this generated matrix +* + GO TO 250 + END IF +* +* For matrix types 3-6, zero one or more rows and +* columns of the matrix to test that INFO is returned +* correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = CZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = CZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = CZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = CZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the last IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = CZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* + ELSE +* +* For matrix kind IMAT = 11, generate special block +* diagonal matrix to test alternate code +* for the 2 x 2 blocks. +* + CALL ZLATSY( UPLO, N, A, LDA, ISEED ) +* + END IF +* +* End generate test matrix A. +* +* +* Do for each value of NB in NBVAL +* + DO 240 INB = 1, NNB +* +* Set the optimal blocksize, which will be later +* returned by ILAENV. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Copy the test matrix A into matrix AFAC which +* will be factorized in place. This is needed to +* preserve the test matrix A for subsequent tests. +* + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) +* +* Compute the L*D*L**T or U*D*U**T factorization of the +* matrix. IWORK stores details of the interchanges and +* the block structure of D. AINV is a work array for +* block factorization, LWORK is the length of AINV. +* + LWORK = MAX( 2, NB )*LDA + SRNAMT = 'ZSYTRF_RK' + CALL ZSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV, + $ LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from ZSYTRF_RK and handle error. +* + IF( INFO.NE.K) + $ CALL ALAERH( PATH, 'ZSYTRF_RK', INFO, K, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Set the condition estimate flag if the INFO is not 0. +* + IF( INFO.NE.0 ) THEN + TRFCON = .TRUE. + ELSE + TRFCON = .FALSE. + END IF +* +*+ TEST 1 +* Reconstruct matrix from factors and compute residual. +* + CALL ZSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, IWORK, + $ AINV, LDA, RWORK, RESULT( 1 ) ) + NT = 1 +* +*+ TEST 2 +* Form the inverse and compute the residual, +* if the factorization was competed without INFO > 0 +* (i.e. there is no zero rows and columns). +* Do it only for the first block size. +* + IF( INB.EQ.1 .AND. .NOT.TRFCON ) THEN + CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + SRNAMT = 'ZSYTRI_3' +* +* Another reason that we need to compute the invesrse +* is that ZSYT03 produces RCONDC which is used later +* in TEST6 and TEST7. +* + LWORK = (N+NB+1)*(NB+3) + CALL ZSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Check error code from ZSYTRI_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZSYTRI_3', INFO, -1, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the residual for a symmetric matrix times +* its inverse. +* + CALL ZSYT03( UPLO, N, A, LDA, AINV, LDA, WORK, LDA, + $ RWORK, RCONDC, RESULT( 2 ) ) + NT = 2 + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT +* +*+ TEST 3 +* Compute largest element in U or L +* + RESULT( 3 ) = ZERO + DTEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) ) / + $ ( ONE-ALPHA ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Compute largest element in U +* + K = N + 120 CONTINUE + IF( K.LE.1 ) + $ GO TO 130 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in U +* + DTEMP = ZLANGE( 'M', K-1, 1, + $ AFAC( ( K-1 )*LDA+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k-1 in U +* + DTEMP = ZLANGE( 'M', K-2, 2, + $ AFAC( ( K-2 )*LDA+1 ), LDA, RWORK ) + K = K - 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K - 1 +* + GO TO 120 + 130 CONTINUE +* + ELSE +* +* Compute largest element in L +* + K = 1 + 140 CONTINUE + IF( K.GE.N ) + $ GO TO 150 +* + IF( IWORK( K ).GT.ZERO ) THEN +* +* Get max absolute value from elements +* in column k in in L +* + DTEMP = ZLANGE( 'M', N-K, 1, + $ AFAC( ( K-1 )*LDA+K+1 ), LDA, RWORK ) + ELSE +* +* Get max absolute value from elements +* in columns k and k+1 in L +* + DTEMP = ZLANGE( 'M', N-K-1, 2, + $ AFAC( ( K-1 )*LDA+K+2 ), LDA, RWORK ) + K = K + 1 +* + END IF +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 3 ) ) + $ RESULT( 3 ) = DTEMP +* + K = K + 1 +* + GO TO 140 + 150 CONTINUE + END IF +* +* +*+ TEST 4 +* Compute largest 2-Norm (condition number) +* of 2-by-2 diag blocks +* + RESULT( 4 ) = ZERO + DTEMP = ZERO +* + CONST = ( ( ALPHA**2-ONE ) / ( ALPHA**2-ONEHALF ) )* + $ ( ( ONE + ALPHA ) / ( ONE - ALPHA ) ) +* + IF( IUPLO.EQ.1 ) THEN +* +* Loop backward for UPLO = 'U' +* + K = N + 160 CONTINUE + IF( K.LE.1 ) + $ GO TO 170 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-2 )*LDA+K-1 ) + BLOCK( 1, 2 ) = E( K ) + BLOCK( 2, 1 ) = BLOCK( 1, 2 ) + BLOCK( 2, 2 ) = AFAC( (K-1)*LDA+K ) +* + CALL ZGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ ZDUMMY, 1, ZDUMMY, 1, + $ WORK, 6, RWORK( 3 ), INFO ) +* +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + DTEMP = SING_MAX / SING_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K - 1 +* + END IF +* + K = K - 1 +* + GO TO 160 + 170 CONTINUE +* + ELSE +* +* Loop forward for UPLO = 'L' +* + K = 1 + 180 CONTINUE + IF( K.GE.N ) + $ GO TO 190 +* + IF( IWORK( K ).LT.ZERO ) THEN +* +* Get the two singular values +* (real and non-negative) of a 2-by-2 block, +* store them in RWORK array +* + BLOCK( 1, 1 ) = AFAC( ( K-1 )*LDA+K ) + BLOCK( 2, 1 ) = E( K ) + BLOCK( 1, 2 ) = BLOCK( 2, 1 ) + BLOCK( 2, 2 ) = AFAC( K*LDA+K+1 ) +* + CALL ZGESVD( 'N', 'N', 2, 2, BLOCK, 2, RWORK, + $ ZDUMMY, 1, ZDUMMY, 1, + $ WORK, 6, RWORK(3), INFO ) +* + SING_MAX = RWORK( 1 ) + SING_MIN = RWORK( 2 ) +* + DTEMP = SING_MAX / SING_MIN +* +* DTEMP should be bounded by CONST +* + DTEMP = DTEMP - CONST + THRESH + IF( DTEMP.GT.RESULT( 4 ) ) + $ RESULT( 4 ) = DTEMP + K = K + 1 +* + END IF +* + K = K + 1 +* + GO TO 180 + 190 CONTINUE + END IF +* +* Print information about the tests that did not pass +* the threshold. +* + DO 200 K = 3, 4 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, NB, IMAT, K, + $ RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 200 CONTINUE + NRUN = NRUN + 2 +* +* Skip the other tests if this is not the first block +* size. +* + IF( INB.GT.1 ) + $ GO TO 240 +* +* Do only the condition estimate if INFO is not 0. +* + IF( TRFCON ) THEN + RCONDC = ZERO + GO TO 230 + END IF +* +* Do for each value of NRHS in NSVAL. +* + DO 220 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) +* +*+ TEST 5 ( Using TRS_3) +* Solve and compute residual for A * X = B. +* +* Choose a set of NRHS random solution vectors +* stored in XACT and set up the right hand side B +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, + $ KL, KU, NRHS, A, LDA, XACT, LDA, + $ B, LDA, ISEED, INFO ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'ZSYTRS_3' + CALL ZSYTRS_3( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, INFO ) +* +* Check error code from ZSYTRS_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZSYTRS_3', INFO, 0, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) +* +* Compute the residual for the solution +* + CALL ZSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 5 ) ) +* +*+ TEST 6 +* Check solution from generated exact solution. +* + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 6 ) ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 210 K = 5, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 210 CONTINUE + NRUN = NRUN + 2 +* +* End do for each value of NRHS in NSVAL. +* + 220 CONTINUE +* +*+ TEST 7 +* Get an estimate of RCOND = 1/CNDNUM. +* + 230 CONTINUE + ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK ) + SRNAMT = 'ZSYCON_3' + CALL ZSYCON_3( UPLO, N, AFAC, LDA, E, IWORK, ANORM, + $ RCOND, WORK, INFO ) +* +* Check error code from ZSYCON_3 and handle error. +* + IF( INFO.NE.0 ) + $ CALL ALAERH( PATH, 'ZSYCON_3', INFO, 0, + $ UPLO, N, N, -1, -1, -1, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute the test ratio to compare values of RCOND +* + RESULT( 7 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )UPLO, N, IMAT, 7, + $ RESULT( 7 ) + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 240 CONTINUE +* + 250 CONTINUE + 260 CONTINUE + 270 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NB =', I4, ', type ', + $ I2, ', test ', I2, ', ratio =', G12.5 ) + 9998 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9997 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ',', 10X, ' type ', I2, + $ ', test(', I2, ') =', G12.5 ) + RETURN +* +* End of ZCHKSY_RK +* + END diff --git a/TESTING/LIN/zdrvhe_rk.f b/TESTING/LIN/zdrvhe_rk.f new file mode 100644 index 00000000..e18a3706 --- /dev/null +++ b/TESTING/LIN/zdrvhe_rk.f @@ -0,0 +1,534 @@ +*> \brief \b ZDRVHE_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, +* RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDRVHE_RK tests the driver routines ZHESV_RK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (NMAX) +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZDRVHE_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 10, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) + +* .. +* .. External Functions .. + DOUBLE PRECISION ZLANHE + EXTERNAL ZLANHE +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, + $ ZGET04, ZLACPY, ZLARHS, ZLATB4, ZLATMS, + $ ZHESV_RK, ZHET01_3, ZPOT02, ZHETRF_RK, ZHETRI_3 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'HK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'HE' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Begin generate the test matrix A. +* +* Set up parameters with ZLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with ZLATMS. +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from ZLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of +* the matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF +* +* End generate the test matrix A. +* +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL ZHETRF_RK( UPLO, N, AFAC, LDA, E, IWORK, WORK, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) +* +* We need to copute the invesrse to compute +* RCONDC that is used later in TEST3. +* + CALL ZHETRI_3( UPLO, N, AINV, LDA, E, IWORK, + $ WORK, LWORK, INFO ) + AINVNM = ZLANHE( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test ZHESV_RK --- +* + IF( IFACT.EQ.2 ) THEN + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* ZHESV_RK. +* + SRNAMT = 'ZHESV_RK' + CALL ZHESV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from ZHESV_RK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'ZHESV_RK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL ZHET01_3( UPLO, N, A, LDA, AFAC, LDA, E, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'ZHESV_RK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of ZDRVHE_RK +* + END diff --git a/TESTING/LIN/zdrvsy_rk.f b/TESTING/LIN/zdrvsy_rk.f new file mode 100644 index 00000000..81bbc7ef --- /dev/null +++ b/TESTING/LIN/zdrvsy_rk.f @@ -0,0 +1,542 @@ +*> \brief \b ZDRVSY_RK +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, +* NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, +* RWORK, IWORK, NOUT ) +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NMAX, NN, NOUT, NRHS +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NVAL( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( *), +* $ WORK( * ), X( * ), XACT( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZDRVSY_RK tests the driver routines ZSYSV_RK. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> 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. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix dimension N. +*> \endverbatim +*> +*> \param[in] NRHS +*> \verbatim +*> NRHS is INTEGER +*> The number of right hand side vectors to be generated for +*> each linear system. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[in] NMAX +*> \verbatim +*> NMAX is INTEGER +*> The maximum value permitted for N, used in dimensioning the +*> work arrays. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] AINV +*> \verbatim +*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX) +*> \endverbatim +*> +*> \param[out] B +*> \verbatim +*> B is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] XACT +*> \verbatim +*> XACT is COMPLEX*16 array, dimension (NMAX*NRHS) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS)) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2013 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZDRVSY_RK( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, + $ NMAX, A, AFAC, E, AINV, B, X, XACT, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2013 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ), E( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES, NTESTS + PARAMETER ( NTYPES = 11, NTESTS = 3 ) + INTEGER NFACT + PARAMETER ( NFACT = 2 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 MATPATH, PATH + INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, J, K, KL, KU, LDA, LWORK, MODE, N, + $ NB, NBMIN, NERRS, NFAIL, NIMAT, NRUN, NT + DOUBLE PRECISION AINVNM, ANORM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER FACTS( NFACT ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) + +* .. +* .. External Functions .. + DOUBLE PRECISION ZLANSY + EXTERNAL ZLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, ZGET04, + $ ZLACPY, ZLARHS, ZLATB4, ZLATMS, ZLATSY, + $ ZSYSV_RK, ZSYT01_3, ZSYT02, ZSYTRF_RK, ZSYTRI_3 +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / , FACTS / 'F', 'N' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* +* Test path +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'SK' +* +* Path to generate matrices +* + MATPATH( 1: 1 ) = 'Zomplex precision' + MATPATH( 2: 3 ) = 'SY' +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + LWORK = MAX( 2*NMAX, NMAX*NRHS ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for which the block +* routine should be used, which will be later returned by ILAENV. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 180 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 170 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 170 +* +* Skip types 3, 4, 5, or 6 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.6 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 170 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 160 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* + IF( IMAT.NE.NTYPES ) THEN +* +* Begin generate the test matrix A. +* +* Set up parameters with ZLATB4 for the matrix generator +* based on the type of matrix to be generated. +* + CALL ZLATB4( MATPATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* +* Generate a matrix with ZLATMS. +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, + $ WORK, INFO ) +* +* Check error code from DLATMS and handle error. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 160 + END IF +* +* For types 3-6, zero one or more rows and columns of +* the matrix to test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF +* + IF( IMAT.LT.6 ) THEN +* +* Set row and column IZERO to zero. +* + IF( IUPLO.EQ.1 ) THEN + IOFF = ( IZERO-1 )*LDA + DO 20 I = 1, IZERO - 1 + A( IOFF+I ) = ZERO + 20 CONTINUE + IOFF = IOFF + IZERO + DO 30 I = IZERO, N + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 30 CONTINUE + ELSE + IOFF = IZERO + DO 40 I = 1, IZERO - 1 + A( IOFF ) = ZERO + IOFF = IOFF + LDA + 40 CONTINUE + IOFF = IOFF - IZERO + DO 50 I = IZERO, N + A( IOFF+I ) = ZERO + 50 CONTINUE + END IF + ELSE + IF( IUPLO.EQ.1 ) THEN +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 70 J = 1, N + I2 = MIN( J, IZERO ) + DO 60 I = 1, I2 + A( IOFF+I ) = ZERO + 60 CONTINUE + IOFF = IOFF + LDA + 70 CONTINUE + ELSE +* +* Set the first IZERO rows and columns to zero. +* + IOFF = 0 + DO 90 J = 1, N + I1 = MAX( J, IZERO ) + DO 80 I = I1, N + A( IOFF+I ) = ZERO + 80 CONTINUE + IOFF = IOFF + LDA + 90 CONTINUE + END IF + END IF + ELSE + IZERO = 0 + END IF + ELSE +* +* IMAT = NTYPES: Use a special block diagonal matrix to +* test alternate code for the 2-by-2 blocks. +* + CALL ZLATSY( UPLO, N, A, LDA, ISEED ) + END IF +* + DO 150 IFACT = 1, NFACT +* +* Do first for FACT = 'F', then for other values. +* + FACT = FACTS( IFACT ) +* +* Compute the condition number for comparison with +* the value returned by ZSYSVX_ROOK. +* + IF( ZEROT ) THEN + IF( IFACT.EQ.1 ) + $ GO TO 150 + RCONDC = ZERO +* + ELSE IF( IFACT.EQ.1 ) THEN +* +* Compute the 1-norm of A. +* + ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* Factor the matrix A. +* + + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL ZSYTRF_RK( UPLO, N, AFAC, LDA, E, IWORK, AINV, + $ LWORK, INFO ) +* +* Compute inv(A) and take its norm. +* + CALL ZLACPY( UPLO, N, N, AFAC, LDA, AINV, LDA ) + LWORK = (N+NB+1)*(NB+3) +* +* We need to copute the invesrse to compute +* RCONDC that is used later in TEST3. +* + CALL ZSYTRI_3( UPLO, N, AINV, LDA, E, IWORK, + $ WORK, LWORK, INFO ) + AINVNM = ZLANSY( '1', UPLO, N, AINV, LDA, RWORK ) +* +* Compute the 1-norm condition number of A. +* + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( MATPATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, ISEED, + $ INFO ) + XTYPE = 'C' +* +* --- Test ZSYSV_RK --- +* + IF( IFACT.EQ.2 ) THEN + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* +* Factor the matrix and solve the system using +* ZSYSV_RK. +* + SRNAMT = 'ZSYSV_RK' + CALL ZSYSV_RK( UPLO, N, NRHS, AFAC, LDA, E, IWORK, + $ X, LDA, WORK, LWORK, INFO ) +* +* Adjust the expected value of INFO to account for +* pivoting. +* + K = IZERO + IF( K.GT.0 ) THEN + 100 CONTINUE + IF( IWORK( K ).LT.0 ) THEN + IF( IWORK( K ).NE.-K ) THEN + K = -IWORK( K ) + GO TO 100 + END IF + ELSE IF( IWORK( K ).NE.K ) THEN + K = IWORK( K ) + GO TO 100 + END IF + END IF +* +* Check error code from ZSYSV_RK and handle error. +* + IF( INFO.NE.K ) THEN + CALL ALAERH( PATH, 'ZSYSV_RK', INFO, K, UPLO, + $ N, N, -1, -1, NRHS, IMAT, NFAIL, + $ NERRS, NOUT ) + GO TO 120 + ELSE IF( INFO.NE.0 ) THEN + GO TO 120 + END IF +* +*+ TEST 1 Reconstruct matrix from factors and compute +* residual. +* + CALL ZSYT01_3( UPLO, N, A, LDA, AFAC, LDA, E, + $ IWORK, AINV, LDA, RWORK, + $ RESULT( 1 ) ) +* +*+ TEST 2 Compute residual of the computed solution. +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, LDA ) + CALL ZSYT02( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 2 ) ) +* +*+ TEST 3 +* Check solution from generated exact solution. +* + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + $ RESULT( 3 ) ) + NT = 3 +* +* Print information about the tests that did not pass +* the threshold. +* + DO 110 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )'ZSYSV_RK', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 110 CONTINUE + NRUN = NRUN + NT + 120 CONTINUE + END IF +* + 150 CONTINUE +* + 160 CONTINUE + 170 CONTINUE + 180 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I2, + $ ', test ', I2, ', ratio =', G12.5 ) + RETURN +* +* End of ZDRVSY_RK +* + END diff --git a/TESTING/LIN/zerrhe.f b/TESTING/LIN/zerrhe.f index 47b64ae0..b6304b1c 100644 --- a/TESTING/LIN/zerrhe.f +++ b/TESTING/LIN/zerrhe.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date November 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRHE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2013 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -81,18 +81,19 @@ INTEGER IP( NMAX ) DOUBLE PRECISION R( NMAX ), R1( NMAX ), R2( NMAX ) COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, ZHECON, ZHECON_ROOK, ZHERFS, - $ ZHETF2, ZHETF2_ROOK, ZHETRF, ZHETRF_ROOK, - $ ZHETRF_AA, ZHETRI, ZHETRI_ROOK, ZHETRI2, - $ ZHETRS, ZHETRS_ROOK, ZHETRS_AA, ZHPCON, ZHPRFS, - $ ZHPTRF, ZHPTRI, ZHPTRS + EXTERNAL ALAESM, CHKXER, ZHECON, ZHECON_3, ZHECON_ROOK, + $ ZHERFS, ZHETF2, ZHETF2_RK, ZHETF2_ROOK, ZHETRF, + $ ZHETRF_RK, ZHETRF_ROOK, ZHETRF_AA, ZHETRI, + $ ZHETRI_3, ZHETRI_3X, ZHETRI_ROOK, ZHETRI2, + $ ZHETRI2X, ZHETRS, ZHETRS_3, ZHETRS_ROOK, + $ ZHETRS_AA, ZHPCON, ZHPRFS, ZHPTRF, ZHPTRI, ZHPTRS * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -122,6 +123,7 @@ $ -1.D0 / DBLE( I+J ) ) 10 CONTINUE B( J ) = 0.D0 + E( J ) = 0.D0 R1( J ) = 0.D0 R2( J ) = 0.D0 W( J ) = 0.D0 @@ -131,12 +133,12 @@ ANRM = 1.0D0 OK = .TRUE. * -* Test error exits of the routines that use factorization -* of a Hermitian indefinite matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. -* IF( LSAMEN( 2, C2, 'HE' ) ) THEN * +* Test error exits of the routines that use factorization +* of a Hermitian indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * ZHETRF * SRNAMT = 'ZHETRF' @@ -149,6 +151,12 @@ INFOT = 4 CALL ZHETRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK ) * * ZHETF2 * @@ -189,6 +197,19 @@ CALL ZHETRI2( 'U', 2, A, 1, IP, W, 1, INFO ) CALL CHKXER( 'ZHETRI2', INFOT, NOUT, LERR, OK ) * +* ZHETRI2X +* + SRNAMT = 'ZHETRI2X' + INFOT = 1 + CALL ZHETRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK ) +* * ZHETRS * SRNAMT = 'ZHETRS' @@ -256,12 +277,12 @@ CALL ZHECON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZHECON', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN +* * Test error exits of the routines that use factorization -* of a Hermitian indefinite matrix with "rook" +* of a Hermitian indefinite matrix with rook * (bounded Bunch-Kaufman) diagonal pivoting method. * - ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN -* * ZHETRF_ROOK * SRNAMT = 'ZHETRF_ROOK' @@ -274,6 +295,12 @@ INFOT = 4 CALL ZHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) * * ZHETF2_ROOK * @@ -336,6 +363,115 @@ CALL ZHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN +* +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* ZHETRF_RK +* + SRNAMT = 'ZHETRF_RK' + INFOT = 1 + CALL ZHETRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) +* +* ZHETF2_RK +* + SRNAMT = 'ZHETF2_RK' + INFOT = 1 + CALL ZHETF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK ) +* +* ZHETRI_3 +* + SRNAMT = 'ZHETRI_3' + INFOT = 1 + CALL ZHETRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) +* +* ZHETRI_3X +* + SRNAMT = 'ZHETRI_3X' + INFOT = 1 + CALL ZHETRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK ) +* +* ZHETRS_3 +* + SRNAMT = 'ZHETRS_3' + INFOT = 1 + CALL ZHETRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHETRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHETRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZHETRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) +* +* ZHECON_3 +* + SRNAMT = 'ZHECON_3' + INFOT = 1 + CALL ZHECON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHECON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHECON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHECON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, INFO) + CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK ) +* * Test error exits of the routines that use factorization * of a Hermitian indefinite matrix with Aasen's algorithm. * @@ -373,12 +509,12 @@ CALL ZHETRS_AA( 'U', 2, 1, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'ZHETRS_AA', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN +* * Test error exits of the routines that use factorization * of a Hermitian indefinite packed matrix with patrial * (Bunch-Kaufman) diagonal pivoting method. * - ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN -* * ZHPTRF * SRNAMT = 'ZHPTRF' diff --git a/TESTING/LIN/zerrhex.f b/TESTING/LIN/zerrhex.f index 81d61a3c..ec0741a6 100644 --- a/TESTING/LIN/zerrhex.f +++ b/TESTING/LIN/zerrhex.f @@ -51,17 +51,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date November 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRHE( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -87,18 +87,19 @@ $ S( NMAX ), ERR_BNDS_N( NMAX, 3 ), $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN EXTERNAL LSAMEN * .. * .. External Subroutines .. - EXTERNAL ALAESM, CHKXER, ZHECON, ZHECON_ROOK, ZHERFS, - $ ZHETF2, ZHETF2_ROOK, ZHETRF, ZHETRF_ROOK, - $ ZHETRI, ZHETRI_ROOK, ZHETRI2, ZHETRS, - $ ZHETRS_ROOK, ZHPCON, ZHPRFS, ZHPTRF, ZHPTRI, - $ ZHPTRS, ZHERFSX + EXTERNAL ALAESM, CHKXER, ZHECON, ZHECON_3, ZHECON_ROOK, + $ ZHERFS, ZHETF2, ZHETF2_RK, ZHETF2_ROOK, ZHETRF, + $ ZHETRF_RK, ZHETRF_ROOK, ZHETRI, ZHETRI_3, + $ ZHETRI_3X, ZHETRI_ROOK, ZHETRI2, ZHETRI2X, + $ ZHETRS, ZHETRS_3, ZHETRS_ROOK, ZHPCON, + $ ZHPRFS, ZHPTRF, ZHPTRI, ZHPTRS, ZHERFSX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -128,6 +129,7 @@ $ -1.D0 / DBLE( I+J ) ) 10 CONTINUE B( J ) = 0.D0 + E( J ) = 0.D0 R1( J ) = 0.D0 R2( J ) = 0.D0 W( J ) = 0.D0 @@ -156,6 +158,12 @@ INFOT = 4 CALL ZHETRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZHETRF', INFOT, NOUT, LERR, OK ) * * ZHETF2 * @@ -196,6 +204,19 @@ CALL ZHETRI2( 'U', 2, A, 1, IP, W, 1, INFO ) CALL CHKXER( 'ZHETRI2', INFOT, NOUT, LERR, OK ) * +* ZHETRI2X +* + SRNAMT = 'ZHETRI2X' + INFOT = 1 + CALL ZHETRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI2X', INFOT, NOUT, LERR, OK ) +* * ZHETRS * SRNAMT = 'ZHETRS' @@ -310,12 +331,12 @@ CALL ZHECON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZHECON', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN +* * Test error exits of the routines that use factorization -* of a Hermitian indefinite matrix with "rook" +* of a Hermitian indefinite matrix with rook * (bounded Bunch-Kaufman) diagonal pivoting method. * - ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN -* * ZHETRF_ROOK * SRNAMT = 'ZHETRF_ROOK' @@ -328,6 +349,12 @@ INFOT = 4 CALL ZHETRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHETRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZHETRF_ROOK', INFOT, NOUT, LERR, OK ) * * ZHETF2_ROOK * @@ -390,12 +417,121 @@ CALL ZHECON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZHECON_ROOK', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN +* * Test error exits of the routines that use factorization -* of a Hermitian indefinite packed matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* ZHETRF_RK +* + SRNAMT = 'ZHETRF_RK' + INFOT = 1 + CALL ZHETRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'ZHETRF_RK', INFOT, NOUT, LERR, OK ) +* +* ZHETF2_RK +* + SRNAMT = 'ZHETF2_RK' + INFOT = 1 + CALL ZHETF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZHETF2_RK', INFOT, NOUT, LERR, OK ) +* +* ZHETRI_3 +* + SRNAMT = 'ZHETRI_3' + INFOT = 1 + CALL ZHETRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHETRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'ZHETRI_3', INFOT, NOUT, LERR, OK ) +* +* ZHETRI_3X +* + SRNAMT = 'ZHETRI_3X' + INFOT = 1 + CALL ZHETRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHETRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZHETRI_3X', INFOT, NOUT, LERR, OK ) +* +* ZHETRS_3 +* + SRNAMT = 'ZHETRS_3' + INFOT = 1 + CALL ZHETRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHETRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHETRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHETRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZHETRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZHETRS_3', INFOT, NOUT, LERR, OK ) +* +* ZHECON_3 +* + SRNAMT = 'ZHECON_3' + INFOT = 1 + CALL ZHECON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHECON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHECON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZHECON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, INFO) + CALL CHKXER( 'ZHECON_3', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * +* Test error exits of the routines that use factorization +* of a Hermitian indefinite packed matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * ZHPTRF * SRNAMT = 'ZHPTRF' diff --git a/TESTING/LIN/zerrsy.f b/TESTING/LIN/zerrsy.f index 35361e60..45e5f0c0 100644 --- a/TESTING/LIN/zerrsy.f +++ b/TESTING/LIN/zerrsy.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date November 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2013 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -80,7 +80,7 @@ INTEGER IP( NMAX ) DOUBLE PRECISION R( NMAX ), R1( NMAX ), R2( NMAX ) COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -88,9 +88,11 @@ * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, ZSPCON, ZSPRFS, ZSPTRF, ZSPTRI, - $ ZSPTRS, ZSYCON, ZSYCON_ROOK, ZSYRFS, ZSYTF2, - $ ZSYTF2_ROOK, ZSYTRF, ZSYTRF_ROOK, ZSYTRI, - $ ZSYTRI_ROOK, ZSYTRI2, ZSYTRS, ZSYTRS_ROOK + $ ZSPTRS, ZSYCON, ZSYCON_3, ZSYCON_ROOK, ZSYRFS, + $ ZSYTF2, ZSYTF2_RK, ZSYTF2_ROOK, ZSYTRF, + $ ZSYTRF_RK, ZSYTRF_ROOK, ZSYTRI, ZSYTRI_3, + $ ZSYTRI_3X, ZSYTRI_ROOK, ZSYTRI2, ZSYTRI2Z, + $ ZSYTRS, ZSYTRS_3, ZSYTRS_ROOK * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -120,6 +122,7 @@ $ -1.D0 / DBLE( I+J ) ) 10 CONTINUE B( J ) = 0.D0 + E( J ) = 0.D0 R1( J ) = 0.D0 R2( J ) = 0.D0 W( J ) = 0.D0 @@ -129,12 +132,12 @@ ANRM = 1.0D0 OK = .TRUE. * -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. -* IF( LSAMEN( 2, C2, 'SY' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * ZSYTRF * SRNAMT = 'ZSYTRF' @@ -147,6 +150,12 @@ INFOT = 4 CALL ZSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK ) * * ZSYTF2 * @@ -187,6 +196,19 @@ CALL ZSYTRI2( 'U', 2, A, 1, IP, W, 1, INFO ) CALL CHKXER( 'ZSYTRI2', INFOT, NOUT, LERR, OK ) * +* ZSYTRI2X +* + SRNAMT = 'ZSYTRI2X' + INFOT = 1 + CALL ZSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK ) +* * ZSYTRS * SRNAMT = 'ZSYTRS' @@ -254,12 +276,12 @@ CALL ZSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZSYCON', INFOT, NOUT, LERR, OK ) * -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with "rook" -* (bounded Bunch-Kaufman) diagonal pivoting method. -* ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) diagonal pivoting method. +* * ZSYTRF_ROOK * SRNAMT = 'ZSYTRF_ROOK' @@ -272,6 +294,12 @@ INFOT = 4 CALL ZSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) * * ZSYTF2_ROOK * @@ -334,12 +362,121 @@ CALL ZSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* * Test error exits of the routines that use factorization -* of a symmetric indefinite packed matrix with patrial -* (Bunch-Kaufman) pivoting. +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* ZSYTRF_RK +* + SRNAMT = 'ZSYTRF_RK' + INFOT = 1 + CALL ZSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) +* +* ZSYTF2_RK +* + SRNAMT = 'ZSYTF2_RK' + INFOT = 1 + CALL ZSYTF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK ) +* +* ZSYTRI_3 +* + SRNAMT = 'ZSYTRI_3' + INFOT = 1 + CALL ZSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) +* +* ZSYTRI_3X +* + SRNAMT = 'ZSYTRI_3X' + INFOT = 1 + CALL ZSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK ) +* +* ZSYTRS_3 +* + SRNAMT = 'ZSYTRS_3' + INFOT = 1 + CALL ZSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) +* +* ZSYCON_3 +* + SRNAMT = 'ZSYCON_3' + INFOT = 1 + CALL ZSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYCON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, INFO) + CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite packed matrix with patrial +* (Bunch-Kaufman) pivoting. +* * ZSPTRF * SRNAMT = 'ZSPTRF' diff --git a/TESTING/LIN/zerrsyx.f b/TESTING/LIN/zerrsyx.f index f78ce009..df4f9902 100644 --- a/TESTING/LIN/zerrsyx.f +++ b/TESTING/LIN/zerrsyx.f @@ -51,17 +51,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date November 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRSY( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -86,7 +86,7 @@ $ S( NMAX ), ERR_BNDS_N( NMAX, 3 ), $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -94,10 +94,11 @@ * .. * .. External Subroutines .. EXTERNAL ALAESM, CHKXER, ZSPCON, ZSPRFS, ZSPTRF, ZSPTRI, - $ ZSPTRS, ZSYCON, ZSYCON_ROOK, ZSYRFS, ZSYTF2, - $ ZSYTF2_ROOK, ZSYTRF, ZSYTRF_ROOK, ZSYTRI, - $ ZSYTRI_ROOK, ZSYTRI2, ZSYTRS, ZSYTRS_ROOK, - $ ZSYRFSX + $ ZSPTRS, ZSYCON, ZSYCON_3, ZSYCON_ROOK, ZSYRFS, + $ ZSYTF2, ZSYTF2_RK, ZSYTF2_ROOK, ZSYTRF, + $ ZSYTRF_RK, ZSYTRF_ROOK, ZSYTRI, ZSYTRI_3, + $ ZSYTRI_3X, ZSYTRI_ROOK, ZSYTRI2, ZSYTRI2X, + $ ZSYTRS, ZSYTRS_3, ZSYTRS_ROOK, ZSYRFSX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -127,6 +128,7 @@ $ -1.D0 / DBLE( I+J ) ) 10 CONTINUE B( J ) = 0.D0 + E( J ) = 0.D0 R1( J ) = 0.D0 R2( J ) = 0.D0 W( J ) = 0.D0 @@ -137,12 +139,12 @@ ANRM = 1.0D0 OK = .TRUE. * -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with patrial -* (Bunch-Kaufman) diagonal pivoting method. -* IF( LSAMEN( 2, C2, 'SY' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with patrial +* (Bunch-Kaufman) diagonal pivoting method. +* * ZSYTRF * SRNAMT = 'ZSYTRF' @@ -155,6 +157,12 @@ INFOT = 4 CALL ZSYTRF( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZSYTRF', INFOT, NOUT, LERR, OK ) * * ZSYTF2 * @@ -195,6 +203,19 @@ CALL ZSYTRI2( 'U', 2, A, 1, IP, W, 1, INFO ) CALL CHKXER( 'ZSYTRI2', INFOT, NOUT, LERR, OK ) * +* ZSYTRI2X +* + SRNAMT = 'ZSYTRI2X' + INFOT = 1 + CALL ZSYTRI2X( '/', 0, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRI2X( 'U', -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRI2X( 'U', 2, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI2X', INFOT, NOUT, LERR, OK ) +* * ZSYTRS * SRNAMT = 'ZSYTRS' @@ -309,12 +330,12 @@ CALL ZSYCON( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZSYCON', INFOT, NOUT, LERR, OK ) * -* Test error exits of the routines that use factorization -* of a symmetric indefinite matrix with "rook" -* (bounded Bunch-Kaufman) diagonal pivoting method. -* ELSE IF( LSAMEN( 2, C2, 'SR' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) diagonal pivoting method. +* * ZSYTRF_ROOK * SRNAMT = 'ZSYTRF_ROOK' @@ -327,6 +348,12 @@ INFOT = 4 CALL ZSYTRF_ROOK( 'U', 2, A, 1, IP, W, 4, INFO ) CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF_ROOK( 'U', 0, A, 1, IP, W, 0, INFO ) + CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYTRF_ROOK( 'U', 0, A, 1, IP, W, -2, INFO ) + CALL CHKXER( 'ZSYTRF_ROOK', INFOT, NOUT, LERR, OK ) * * ZSYTF2_ROOK * @@ -389,12 +416,121 @@ CALL ZSYCON_ROOK( 'U', 1, A, 1, IP, -ANRM, RCOND, W, INFO ) CALL CHKXER( 'ZSYCON_ROOK', INFOT, NOUT, LERR, OK ) * + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* * Test error exits of the routines that use factorization -* of a symmetric indefinite packed matrix with patrial -* (Bunch-Kaufman) pivoting. +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* +* ZSYTRF_RK +* + SRNAMT = 'ZSYTRF_RK' + INFOT = 1 + CALL ZSYTRF_RK( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRF_RK( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRF_RK( 'U', 2, A, 1, E, IP, W, 4, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRF_RK( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRF_RK( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'ZSYTRF_RK', INFOT, NOUT, LERR, OK ) +* +* ZSYTF2_RK +* + SRNAMT = 'ZSYTF2_RK' + INFOT = 1 + CALL ZSYTF2_RK( '/', 0, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTF2_RK( 'U', -1, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTF2_RK( 'U', 2, A, 1, E, IP, INFO ) + CALL CHKXER( 'ZSYTF2_RK', INFOT, NOUT, LERR, OK ) +* +* ZSYTRI_3 +* + SRNAMT = 'ZSYTRI_3' + INFOT = 1 + CALL ZSYTRI_3( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRI_3( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRI_3( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRI_3( 'U', 0, A, 1, E, IP, W, 0, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZSYTRI_3( 'U', 0, A, 1, E, IP, W, -2, INFO ) + CALL CHKXER( 'ZSYTRI_3', INFOT, NOUT, LERR, OK ) +* +* ZSYTRI_3X +* + SRNAMT = 'ZSYTRI_3X' + INFOT = 1 + CALL ZSYTRI_3X( '/', 0, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRI_3X( 'U', -1, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYTRI_3X( 'U', 2, A, 1, E, IP, W, 1, INFO ) + CALL CHKXER( 'ZSYTRI_3X', INFOT, NOUT, LERR, OK ) +* +* ZSYTRS_3 +* + SRNAMT = 'ZSYTRS_3' + INFOT = 1 + CALL ZSYTRS_3( '/', 0, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYTRS_3( 'U', -1, 0, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZSYTRS_3( 'U', 0, -1, A, 1, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZSYTRS_3( 'U', 2, 1, A, 1, E, IP, B, 2, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZSYTRS_3( 'U', 2, 1, A, 2, E, IP, B, 1, INFO ) + CALL CHKXER( 'ZSYTRS_3', INFOT, NOUT, LERR, OK ) +* +* ZSYCON_3 +* + SRNAMT = 'ZSYCON_3' + INFOT = 1 + CALL ZSYCON_3( '/', 0, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYCON_3( 'U', -1, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZSYCON_3( 'U', 2, A, 1, E, IP, ANRM, RCOND, W, INFO ) + CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZSYCON_3( 'U', 1, A, 1, E, IP, -1.0D0, RCOND, W, INFO) + CALL CHKXER( 'ZSYCON_3', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * +* Test error exits of the routines that use factorization +* of a symmetric indefinite packed matrix with patrial +* (Bunch-Kaufman) pivoting. +* * ZSPTRF * SRNAMT = 'ZSPTRF' diff --git a/TESTING/LIN/zerrvx.f b/TESTING/LIN/zerrvx.f index ca0618b2..0eed4a51 100644 --- a/TESTING/LIN/zerrvx.f +++ b/TESTING/LIN/zerrvx.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2013 +*> \date November 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.5.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2013 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -82,7 +82,7 @@ DOUBLE PRECISION C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ), $ RF( NMAX ), RW( NMAX ) COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -90,10 +90,11 @@ * .. * .. External Subroutines .. EXTERNAL CHKXER, ZGBSV, ZGBSVX, ZGESV, ZGESVX, ZGTSV, - $ ZGTSVX, ZHESV, ZHESV_ROOK, ZHESVX, ZHPSV, - $ ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX, ZPPSV, - $ ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX, ZSYSV, - $ ZSYSV_AA, ZSYSV_ROOK, ZSYSVX + $ ZGTSVX, ZHESV, ZHESV_RK, ZHESV_ROOK, ZHESVX, + $ ZHPSV, ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX, + $ ZPPSV, ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX, + $ ZSYSV, ZSYSV_AA, ZSYSV_RK, ZSYSV_ROOK, + $ ZSYSVX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -123,6 +124,7 @@ $ -1.D0 / DBLE( I+J ) ) 10 CONTINUE B( J ) = 0.D0 + E( J ) = 0.D0 R1( J ) = 0.D0 R2( J ) = 0.D0 W( J ) = 0.D0 @@ -593,6 +595,12 @@ INFOT = 8 CALL ZHESV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHESV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHESV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK ) * * ZHESVX * @@ -634,25 +642,6 @@ $ RCOND, R1, R2, W, 3, RW, INFO ) CALL CHKXER( 'ZHESVX', INFOT, NOUT, LERR, OK ) * - ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN -* -* ZHESV_AA -* - SRNAMT = 'ZHESV_AA' - INFOT = 1 - CALL ZHESV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK ) - INFOT = 2 - CALL ZHESV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK ) - INFOT = 3 - CALL ZHESV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK ) - INFOT = 8 - CALL ZHESV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) - CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK ) -* - ELSE IF( LSAMEN( 2, C2, 'HR' ) ) THEN * * ZHESV_ROOK @@ -670,6 +659,65 @@ INFOT = 8 CALL ZHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN +* +* ZSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a Hermitian indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'ZHESV_RK' + INFOT = 1 + CALL ZHESV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHESV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHESV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHESV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZHESV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HA' ) ) THEN +* +* ZHESV_AA +* + SRNAMT = 'ZHESV_AA' + INFOT = 1 + CALL ZHESV_AA( '/', 0, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHESV_AA( 'U', -1, 0, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHESV_AA( 'U', 0, -1, A, 1, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHESV_AA( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_AA', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * @@ -734,6 +782,12 @@ INFOT = 8 CALL ZSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK ) * * ZSYSVX * @@ -792,6 +846,46 @@ INFOT = 8 CALL ZSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* ZSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'ZSYSV_RK' + INFOT = 1 + CALL ZSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/TESTING/LIN/zerrvxx.f b/TESTING/LIN/zerrvxx.f index 747d84ad..d2006667 100644 --- a/TESTING/LIN/zerrvxx.f +++ b/TESTING/LIN/zerrvxx.f @@ -48,17 +48,17 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \date November 2015 +*> \date November 2016 * *> \ingroup complex16_lin * * ===================================================================== SUBROUTINE ZERRVX( PATH, NUNIT ) * -* -- LAPACK test routine (version 3.6.0) -- +* -- LAPACK test routine (version 3.7.0) -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2015 +* November 2016 * * .. Scalar Arguments .. CHARACTER*3 PATH @@ -85,7 +85,7 @@ $ RF( NMAX ), RW( NMAX ), ERR_BNDS_N( NMAX, 3 ), $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), - $ W( 2*NMAX ), X( NMAX ) + $ E( NMAX ), W( 2*NMAX ), X( NMAX ) * .. * .. External Functions .. LOGICAL LSAMEN @@ -93,11 +93,11 @@ * .. * .. External Subroutines .. EXTERNAL CHKXER, ZGBSV, ZGBSVX, ZGESV, ZGESVX, ZGTSV, - $ ZGTSVX, ZHESV, ZHESV_ROOK, ZHESVX, ZHPSV, - $ ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX, ZPPSV, - $ ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX, ZSYSV, - $ ZSYSV_ROOK, ZSYSVX, ZGESVXX, ZSYSVXX, ZPOSVXX, - $ ZHESVXX, ZGBSVXX + $ ZGTSVX, ZHESV, ZHESV_RK, ZHESV_ROOK, ZHESVX, + $ ZHPSV, ZHPSVX, ZPBSV, ZPBSVX, ZPOSV, ZPOSVX, + $ ZPPSV, ZPPSVX, ZPTSV, ZPTSVX, ZSPSV, ZSPSVX, + $ ZSYSV, ZSYSV_RK, ZSYSV_ROOK, ZSYSVX, ZGESVXX, + $ ZSYSVXX, ZPOSVXX, ZHESVXX, ZGBSVXX * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -127,6 +127,7 @@ $ -1.D0 / DBLE( I+J ) ) 10 CONTINUE B( J ) = 0.D0 + E( J ) = 0.D0 R1( J ) = 0.D0 R2( J ) = 0.D0 W( J ) = 0.D0 @@ -835,6 +836,12 @@ INFOT = 8 CALL ZHESV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHESV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHESV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZHESV ', INFOT, NOUT, LERR, OK ) * * ZHESVX * @@ -951,6 +958,47 @@ INFOT = 8 CALL ZHESV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZHESV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZHESV_ROOK', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'HK' ) ) THEN +* +* ZSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a Hermitian indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'ZHESV_RK' + INFOT = 1 + CALL ZHESV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHESV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHESV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHESV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZHESV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZHESV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZHESV_RK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'HP' ) ) THEN * @@ -1015,6 +1063,12 @@ INFOT = 8 CALL ZSYSV( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZSYSV( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZSYSV ', INFOT, NOUT, LERR, OK ) * * ZSYSVX * @@ -1141,6 +1195,46 @@ INFOT = 8 CALL ZSYSV_ROOK( 'U', 2, 0, A, 2, IP, B, 1, W, 1, INFO ) CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZSYSV_ROOK', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZSYSV_ROOK( 'U', 0, 0, A, 1, IP, B, 1, W, -2, INFO ) +* + ELSE IF( LSAMEN( 2, C2, 'SK' ) ) THEN +* +* ZSYSV_RK +* +* Test error exits of the driver that uses factorization +* of a symmetric indefinite matrix with rook +* (bounded Bunch-Kaufman) pivoting with the new storage +* format for factors L ( or U) and D. +* +* L (or U) is stored in A, diagonal of D is stored on the +* diagonal of A, subdiagonal of D is stored in a separate array E. +* + SRNAMT = 'ZSYSV_RK' + INFOT = 1 + CALL ZSYSV_RK( '/', 0, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZSYSV_RK( 'U', -1, 0, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZSYSV_RK( 'U', 0, -1, A, 1, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZSYSV_RK( 'U', 2, 0, A, 1, E, IP, B, 2, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZSYSV_RK( 'U', 2, 0, A, 2, E, IP, B, 1, W, 1, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, 0, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZSYSV_RK( 'U', 0, 0, A, 1, E, IP, B, 1, W, -2, INFO ) + CALL CHKXER( 'ZSYSV_RK', INFOT, NOUT, LERR, OK ) * ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN * diff --git a/TESTING/LIN/zhet01_3.f b/TESTING/LIN/zhet01_3.f new file mode 100644 index 00000000..cfe22585 --- /dev/null +++ b/TESTING/LIN/zhet01_3.f @@ -0,0 +1,264 @@ +*> \brief \b ZHET01_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZHET01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, +* LDC, RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZHET01_3 reconstructs a Hermitian indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization computed by ZHETRF_RK +*> (or ZHETRF_BK) and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> UPLO is CHARACTER*1 +*> Specifies whether the upper or lower triangular part of the +*> Hermitian matrix A is stored: +*> = 'U': Upper triangular +*> = 'L': Lower triangular +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The original Hermitian matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (LDAFAC,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by ZHETRF_RK and ZHETRF_BK: +*> a) ONLY diagonal elements of the Hermitian block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. +*> LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the Hermitian block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from ZHETRF_RK (or ZHETRF_BK). +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> 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 ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2016 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZHET01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + DOUBLE PRECISION ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION ZLANHE, DLAMCH + EXTERNAL LSAME, ZLANHE, DLAMCH +* .. +* .. External Subroutines .. + EXTERNAL ZLASET, ZLAVHE_ROOK, ZSYCONVF_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC DIMAG, DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* a) Revert to multiplyers of L +* + CALL ZSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO ) +* +* 1) Determine EPS and the norm of A. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK ) +* +* Check the imaginary parts of the diagonal elements and return with +* an error code if any are nonzero. +* + DO J = 1, N + IF( DIMAG( AFAC( J, J ) ).NE.ZERO ) THEN + RESID = ONE / EPS + RETURN + END IF + END DO +* +* 2) Initialize C to the identity matrix. +* + CALL ZLASET( 'Full', N, N, CZERO, CONE, C, LDC ) +* +* 3) Call ZLAVHE_ROOK to form the product D * U' (or D * L' ). +* + CALL ZLAVHE_ROOK( UPLO, 'Conjugate', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 4) Call ZLAVHE_RK again to multiply by U (or L ). +* + CALL ZLAVHE_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 5) Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J - 1 + C( I, J ) = C( I, J ) - A( I, J ) + END DO + C( J, J ) = C( J, J ) - DBLE( A( J, J ) ) + END DO + ELSE + DO J = 1, N + C( J, J ) = C( J, J ) - DBLE( A( J, J ) ) + DO I = J + 1, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* 6) Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = ZLANHE( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID/DBLE( N ) )/ANORM ) / EPS + END IF +* +* b) Convert to factor of L (or U) +* + CALL ZSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO ) +* + RETURN +* +* End of ZHET01_3 +* + END diff --git a/TESTING/LIN/zsyt01_3.f b/TESTING/LIN/zsyt01_3.f new file mode 100644 index 00000000..d20c4174 --- /dev/null +++ b/TESTING/LIN/zsyt01_3.f @@ -0,0 +1,253 @@ +*> \brief \b ZSYT01_3 +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, +* LDC, RWORK, RESID ) +* +* .. Scalar Arguments .. +* CHARACTER UPLO +* INTEGER LDA, LDAFAC, LDC, N +* DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. +* INTEGER IPIV( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), +* E( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZSYT01_3 reconstructs a symmetric indefinite matrix A from its +*> block L*D*L' or U*D*U' factorization computed by ZSYTRF_RK +*> (or ZSYTRF_BK) and computes the residual +*> norm( C - A ) / ( N * norm(A) * EPS ), +*> where C is the reconstructed matrix and EPS is the machine epsilon. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] UPLO +*> \verbatim +*> 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 +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of rows and columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> The original symmetric matrix A. +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,N) +*> \endverbatim +*> +*> \param[in] AFAC +*> \verbatim +*> AFAC is COMPLEX*16 array, dimension (LDAFAC,N) +*> Diagonal of the block diagonal matrix D and factors U or L +*> as computed by ZSYTRF_RK and ZSYTRF_BK: +*> a) ONLY diagonal elements of the symmetric block diagonal +*> matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); +*> (superdiagonal (or subdiagonal) elements of D +*> should be provided on entry in array E), and +*> b) If UPLO = 'U': factor U in the superdiagonal part of A. +*> If UPLO = 'L': factor L in the subdiagonal part of A. +*> \endverbatim +*> +*> \param[in] LDAFAC +*> \verbatim +*> LDAFAC is INTEGER +*> The leading dimension of the array AFAC. +*> LDAFAC >= max(1,N). +*> \endverbatim +*> +*> \param[in] E +*> \verbatim +*> E is COMPLEX*16 array, dimension (N) +*> On entry, contains the superdiagonal (or subdiagonal) +*> elements of the symmetric block diagonal matrix D +*> with 1-by-1 or 2-by-2 diagonal blocks, where +*> If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not refernced; +*> If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. +*> \endverbatim +*> +*> \param[in] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (N) +*> The pivot indices from ZSYTRF_RK (or ZSYTRF_BK). +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (LDC,N) +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. LDC >= max(1,N). +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (N) +*> \endverbatim +*> +*> \param[out] RESID +*> \verbatim +*> 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 ) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \date November 2016 +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZSYT01_3( UPLO, N, A, LDA, AFAC, LDAFAC, E, IPIV, C, + $ LDC, RWORK, RESID ) +* +* -- LAPACK test routine (version 3.7.0) -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* November 2016 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDAFAC, LDC, N + DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. + INTEGER IPIV( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ), + $ E( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CZERO, CONE + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ), + $ CONE = ( 1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J + DOUBLE PRECISION ANORM, EPS +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, ZLANSY + EXTERNAL LSAME, DLAMCH, ZLANSY +* .. +* .. External Subroutines .. + EXTERNAL ZLASET, ZLAVSY_ROOK, ZSYCONVF_ROOK +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* a) Revert to multiplyers of L +* + CALL ZSYCONVF_ROOK( UPLO, 'R', N, AFAC, LDAFAC, E, IPIV, INFO ) +* +* 1) Determine EPS and the norm of A. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = ZLANSY( '1', UPLO, N, A, LDA, RWORK ) +* +* 2) Initialize C to the identity matrix. +* + CALL ZLASET( 'Full', N, N, CZERO, CONE, C, LDC ) +* +* 3) Call ZLAVSY_ROOK to form the product D * U' (or D * L' ). +* + CALL ZLAVSY_ROOK( UPLO, 'Transpose', 'Non-unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 4) Call ZLAVSY_ROOK again to multiply by U (or L ). +* + CALL ZLAVSY_ROOK( UPLO, 'No transpose', 'Unit', N, N, AFAC, + $ LDAFAC, IPIV, C, LDC, INFO ) +* +* 5) Compute the difference C - A . +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO J = 1, N + DO I = 1, J + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + ELSE + DO J = 1, N + DO I = J, N + C( I, J ) = C( I, J ) - A( I, J ) + END DO + END DO + END IF +* +* 6) Compute norm( C - A ) / ( N * norm(A) * EPS ) +* + RESID = ZLANSY( '1', UPLO, N, C, LDC, RWORK ) +* + IF( ANORM.LE.ZERO ) THEN + IF( RESID.NE.ZERO ) + $ RESID = ONE / EPS + ELSE + RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS + END IF + +* +* b) Convert to factor of L (or U) +* + CALL ZSYCONVF_ROOK( UPLO, 'C', N, AFAC, LDAFAC, E, IPIV, INFO ) +* + RETURN +* +* End of ZSYT01_3 +* + END diff --git a/TESTING/ctest.in b/TESTING/ctest.in index b8a197a9..c5ed21fd 100755 --- a/TESTING/ctest.in +++ b/TESTING/ctest.in @@ -24,10 +24,12 @@ CPB 8 List types on next line if 0 < NTYPES < 8 CPT 12 List types on next line if 0 < NTYPES < 12 CHE 10 List types on next line if 0 < NTYPES < 10 CHR 10 List types on next line if 0 < NTYPES < 10 +CHK 10 List types on next line if 0 < NTYPES < 10 CHA 10 List types on next line if 0 < NTYPES < 10 CHP 10 List types on next line if 0 < NTYPES < 10 CSY 11 List types on next line if 0 < NTYPES < 11 CSR 11 List types on next line if 0 < NTYPES < 11 +CSK 11 List types on next line if 0 < NTYPES < 11 CSP 11 List types on next line if 0 < NTYPES < 11 CTR 18 List types on next line if 0 < NTYPES < 18 CTP 18 List types on next line if 0 < NTYPES < 18 diff --git a/TESTING/dtest.in b/TESTING/dtest.in index 3742b060..d05a27ca 100755 --- a/TESTING/dtest.in +++ b/TESTING/dtest.in @@ -22,9 +22,10 @@ DPS 9 List types on next line if 0 < NTYPES < 9 DPP 9 List types on next line if 0 < NTYPES < 9 DPB 8 List types on next line if 0 < NTYPES < 8 DPT 12 List types on next line if 0 < NTYPES < 12 -DSA 10 List types on next line if 0 < NTYPES < 10 DSY 10 List types on next line if 0 < NTYPES < 10 DSR 10 List types on next line if 0 < NTYPES < 10 +DSK 10 List types on next line if 0 < NTYPES < 10 +DSA 10 List types on next line if 0 < NTYPES < 10 DSP 10 List types on next line if 0 < NTYPES < 10 DTR 18 List types on next line if 0 < NTYPES < 18 DTP 18 List types on next line if 0 < NTYPES < 18 diff --git a/TESTING/stest.in b/TESTING/stest.in index 16529646..30f1c470 100755 --- a/TESTING/stest.in +++ b/TESTING/stest.in @@ -22,9 +22,10 @@ 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 -SSA 10 List types on next line if 0 < NTYPES < 10 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 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 diff --git a/TESTING/ztest.in b/TESTING/ztest.in index f3eabb5e..aba4a3d5 100755 --- a/TESTING/ztest.in +++ b/TESTING/ztest.in @@ -22,12 +22,14 @@ ZPS 9 List types on next line if 0 < NTYPES < 9 ZPP 9 List types on next line if 0 < NTYPES < 9 ZPB 8 List types on next line if 0 < NTYPES < 8 ZPT 12 List types on next line if 0 < NTYPES < 12 -ZHA 10 List types on next line if 0 < NTYPES < 10 ZHE 10 List types on next line if 0 < NTYPES < 10 ZHR 10 List types on next line if 0 < NTYPES < 10 +ZHK 10 List types on next line if 0 < NTYPES < 10 +ZHA 10 List types on next line if 0 < NTYPES < 10 ZHP 10 List types on next line if 0 < NTYPES < 10 ZSY 11 List types on next line if 0 < NTYPES < 11 ZSR 11 List types on next line if 0 < NTYPES < 11 +ZSK 11 List types on next line if 0 < NTYPES < 11 ZSP 11 List types on next line if 0 < NTYPES < 11 ZTR 18 List types on next line if 0 < NTYPES < 18 ZTP 18 List types on next line if 0 < NTYPES < 18 |