diff options
Diffstat (limited to 'TESTING/LIN')
323 files changed, 29529 insertions, 581 deletions
diff --git a/TESTING/LIN/Makefile b/TESTING/LIN/Makefile index 3d63c79e..8ea1f858 100644 --- a/TESTING/LIN/Makefile +++ b/TESTING/LIN/Makefile @@ -44,22 +44,22 @@ DZLNTST= dlaord.o SLINTST = schkaa.o \ schkeq.o schkgb.o schkge.o schkgt.o \ - schklq.o schkpb.o schkpo.o schkpp.o \ + schklq.o schkpb.o schkpo.o schkps.o schkpp.o \ schkpt.o schkq3.o schkql.o schkqp.o schkqr.o schkrq.o \ schksp.o schksy.o schktb.o schktp.o schktr.o \ schktz.o \ - sdrvgb.o sdrvge.o sdrvgt.o sdrvls.o sdrvpb.o \ - sdrvpo.o sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy.o \ - serrge.o serrgt.o serrlq.o serrls.o \ - serrpo.o serrql.o serrqp.o serrqr.o \ + sdrvgt.o sdrvls.o sdrvpb.o \ + sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy.o \ + serrgt.o serrlq.o serrls.o \ + serrpo.o serrps.o serrql.o serrqp.o serrqr.o \ serrrq.o serrsy.o serrtr.o serrtz.o serrvx.o \ sgbt01.o sgbt02.o sgbt05.o sgelqs.o sgeqls.o sgeqrs.o \ sgerqs.o sget01.o sget02.o \ sget03.o sget04.o sget06.o sget07.o sgtt01.o sgtt02.o \ - sgtt05.o slaptm.o slarhs.o slatb4.o slattb.o slattp.o \ + sgtt05.o slaptm.o slarhs.o slatb4.o slatb5.o slattb.o slattp.o \ slattr.o slavsp.o slavsy.o slqt01.o slqt02.o \ slqt03.o spbt01.o spbt02.o spbt05.o spot01.o \ - spot02.o spot03.o spot05.o sppt01.o \ + spot02.o spot03.o spot05.o spst01.o sppt01.o \ sppt02.o sppt03.o sppt05.o sptt01.o sptt02.o \ sptt05.o sqlt01.o sqlt02.o sqlt03.o sqpt01.o \ sqrt01.o sqrt02.o sqrt03.o sqrt11.o sqrt12.o \ @@ -71,27 +71,33 @@ SLINTST = schkaa.o \ strt02.o strt03.o strt05.o strt06.o \ stzt01.o stzt02.o sgennd.o +ifdef USEXBLAS +SLINTST += sdrvgex.o serrgex.o sdrvgbx.o sdrvpox.o sebchvxx.o +else +SLINTST += sdrvge.o serrge.o sdrvgb.o sdrvpo.o +endif + CLINTST = cchkaa.o \ cchkeq.o cchkgb.o cchkge.o cchkgt.o \ cchkhe.o cchkhp.o cchklq.o cchkpb.o \ - cchkpo.o cchkpp.o cchkpt.o cchkq3.o cchkql.o cchkqp.o \ + cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkql.o cchkqp.o \ cchkqr.o cchkrq.o cchksp.o cchksy.o cchktb.o \ cchktp.o cchktr.o cchktz.o \ - cdrvgb.o cdrvge.o cdrvgt.o cdrvhe.o cdrvhp.o \ - cdrvls.o cdrvpb.o cdrvpo.o cdrvpp.o cdrvpt.o \ + cdrvgt.o cdrvhe.o cdrvhp.o \ + cdrvls.o cdrvpb.o cdrvpp.o cdrvpt.o \ cdrvsp.o cdrvsy.o \ - cerrge.o cerrgt.o cerrhe.o cerrlq.o \ - cerrls.o cerrpo.o cerrql.o cerrqp.o \ + cerrgt.o cerrhe.o cerrlq.o \ + cerrls.o cerrps.o cerrql.o cerrqp.o \ cerrqr.o cerrrq.o cerrsy.o cerrtr.o cerrtz.o \ cerrvx.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 chpt01.o claipd.o claptm.o clarhs.o clatb4.o \ + cgtt05.o chet01.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 clavhp.o clavsp.o clavsy.o clqt01.o \ clqt02.o clqt03.o cpbt01.o cpbt02.o cpbt05.o \ - cpot01.o cpot02.o cpot03.o cpot05.o \ + cpot01.o cpot02.o cpot03.o cpot05.o cpst01.o \ cppt01.o cppt02.o cppt03.o cppt05.o cptt01.o \ cptt02.o cptt05.o cqlt01.o cqlt02.o cqlt03.o \ cqpt01.o cqrt01.o cqrt02.o cqrt03.o cqrt11.o \ @@ -104,24 +110,30 @@ CLINTST = cchkaa.o \ ctrt02.o ctrt03.o ctrt05.o ctrt06.o \ ctzt01.o ctzt02.o sget06.o cgennd.o +ifdef USEXBLAS +CLINTST += cdrvgex.o cdrvgbx.o cerrgex.o cdrvpox.o cerrpox.o cebchvxx.o +else +CLINTST += cdrvge.o cdrvgb.o cerrge.o cdrvpo.o cerrpo.o +endif + DLINTST = dchkaa.o \ dchkeq.o dchkgb.o dchkge.o dchkgt.o \ - dchklq.o dchkpb.o dchkpo.o dchkpp.o \ + dchklq.o dchkpb.o dchkpo.o dchkps.o dchkpp.o \ dchkpt.o dchkq3.o dchkql.o dchkqp.o dchkqr.o dchkrq.o \ dchksp.o dchksy.o dchktb.o dchktp.o dchktr.o \ dchktz.o \ - ddrvgb.o ddrvge.o ddrvgt.o ddrvls.o ddrvpb.o \ - ddrvpo.o ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy.o \ - derrge.o derrgt.o derrlq.o derrls.o \ - derrpo.o derrql.o derrqp.o derrqr.o \ + ddrvgt.o ddrvls.o ddrvpb.o \ + ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy.o \ + derrgt.o derrlq.o derrls.o \ + derrps.o derrql.o derrqp.o derrqr.o \ derrrq.o derrsy.o derrtr.o derrtz.o derrvx.o \ dgbt01.o dgbt02.o dgbt05.o dgelqs.o dgeqls.o dgeqrs.o \ dgerqs.o dget01.o dget02.o \ dget03.o dget04.o dget06.o dget07.o dgtt01.o dgtt02.o \ - dgtt05.o dlaptm.o dlarhs.o dlatb4.o dlattb.o dlattp.o \ + dgtt05.o dlaptm.o dlarhs.o dlatb4.o dlatb5.o dlattb.o dlattp.o \ dlattr.o dlavsp.o dlavsy.o dlqt01.o dlqt02.o \ dlqt03.o dpbt01.o dpbt02.o dpbt05.o dpot01.o \ - dpot02.o dpot03.o dpot05.o dppt01.o \ + dpot02.o dpot03.o dpot05.o dpst01.o dppt01.o \ dppt02.o dppt03.o dppt05.o dptt01.o dptt02.o \ dptt05.o dqlt01.o dqlt02.o dqlt03.o dqpt01.o \ dqrt01.o dqrt02.o dqrt03.o dqrt11.o dqrt12.o \ @@ -133,27 +145,33 @@ DLINTST = dchkaa.o \ dtrt02.o dtrt03.o dtrt05.o dtrt06.o \ dtzt01.o dtzt02.o dgennd.o +ifdef USEXBLAS +DLINTST += ddrvgex.o ddrvgbx.o derrgex.o ddrvpox.o derrpox.o debchvxx.o +else +DLINTST += ddrvge.o ddrvgb.o derrge.o ddrvpo.o derrpo.o +endif + ZLINTST = zchkaa.o \ zchkeq.o zchkgb.o zchkge.o zchkgt.o \ zchkhe.o zchkhp.o zchklq.o zchkpb.o \ - zchkpo.o zchkpp.o zchkpt.o zchkq3.o zchkql.o zchkqp.o \ + zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkql.o zchkqp.o \ zchkqr.o zchkrq.o zchksp.o zchksy.o zchktb.o \ zchktp.o zchktr.o zchktz.o \ - zdrvgb.o zdrvge.o zdrvgt.o zdrvhe.o zdrvhp.o \ - zdrvls.o zdrvpb.o zdrvpo.o zdrvpp.o zdrvpt.o \ + zdrvgt.o zdrvhe.o zdrvhp.o \ + zdrvls.o zdrvpb.o zdrvpp.o zdrvpt.o \ zdrvsp.o zdrvsy.o \ - zerrge.o zerrgt.o zerrhe.o zerrlq.o \ - zerrls.o zerrpo.o zerrql.o zerrqp.o \ + zerrgt.o zerrhe.o zerrlq.o \ + zerrls.o zerrps.o zerrql.o zerrqp.o \ zerrqr.o zerrrq.o zerrsy.o zerrtr.o zerrtz.o \ zerrvx.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 zhpt01.o zlaipd.o zlaptm.o zlarhs.o zlatb4.o \ + zgtt05.o zhet01.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 zlavhp.o zlavsp.o zlavsy.o zlqt01.o \ zlqt02.o zlqt03.o zpbt01.o zpbt02.o zpbt05.o \ - zpot01.o zpot02.o zpot03.o zpot05.o \ + zpot01.o zpot02.o zpot03.o zpot05.o zpst01.o \ zppt01.o zppt02.o zppt03.o zppt05.o zptt01.o \ zptt02.o zptt05.o zqlt01.o zqlt02.o zqlt03.o \ zqpt01.o zqrt01.o zqrt02.o zqrt03.o zqrt11.o \ @@ -166,51 +184,91 @@ ZLINTST = zchkaa.o \ ztrt02.o ztrt03.o ztrt05.o ztrt06.o \ ztzt01.o ztzt02.o dget06.o zgennd.o +ifdef USEXBLAS +ZLINTST += zdrvgex.o zdrvgbx.o zerrgex.o zdrvpox.o zerrpox.o zebchvxx.o +else +ZLINTST += zdrvge.o zdrvgb.o zerrge.o zdrvpo.o zerrpo.o +endif + DSLINTST = dchkab.o \ - ddrvab.o derrab.o dget08.o \ + ddrvab.o ddrvac.o derrab.o derrac.o dget08.o \ alaerh.o alahd.o aladhd.o alareq.o \ chkxer.o dlarhs.o dlatb4.o xerbla.o \ - dget02.o + dget02.o dpot06.o ZCLINTST = zchkab.o \ - zdrvab.o zerrab.o zget08.o \ + zdrvab.o zdrvac.o zerrab.o zerrac.o zget08.o \ alaerh.o alahd.o aladhd.o alareq.o \ chkxer.o zget02.o zlarhs.o zlatb4.o \ - zsbmv.o xerbla.o + zsbmv.o xerbla.o zpot06.o zlaipd.o + +SLINTSTRFP = schkrfp.o sdrvrfp.o sdrvrf1.o sdrvrf2.o sdrvrf3.o sdrvrf4.o serrrfp.o \ + slatb4.o slarhs.o sget04.o spot01.o spot03.o spot02.o \ + chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o + +DLINTSTRFP = dchkrfp.o ddrvrfp.o ddrvrf1.o ddrvrf2.o ddrvrf3.o ddrvrf4.o derrrfp.o \ + dlatb4.o dlarhs.o dget04.o dpot01.o dpot03.o dpot02.o \ + chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o + +CLINTSTRFP = cchkrfp.o cdrvrfp.o cdrvrf1.o cdrvrf2.o cdrvrf3.o cdrvrf4.o cerrrfp.o \ + claipd.o clatb4.o clarhs.o csbmv.o cget04.o cpot01.o cpot03.o cpot02.o \ + chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o -all: single double complex complex16 proto-double proto-complex16 +ZLINTSTRFP = zchkrfp.o zdrvrfp.o zdrvrf1.o zdrvrf2.o zdrvrf3.o zdrvrf4.o zerrrfp.o \ + zlatb4.o zlaipd.o zlarhs.o zsbmv.o zget04.o zpot01.o zpot03.o zpot02.o \ + chkxer.o xerbla.o alaerh.o aladhd.o alahd.o alasvm.o + +all: single double complex complex16 proto-single proto-double proto-complex proto-complex16 single: ../xlintsts double: ../xlintstd complex: ../xlintstc complex16: ../xlintstz -proto-double: ../xlintstds -proto-complex16: ../xlintstzc +proto-single: ../xlintstrfs +proto-double: ../xlintstds ../xlintstrfd +proto-complex: ../xlintstrfc +proto-complex16: ../xlintstzc ../xlintstrfz ../xlintsts : $(ALINTST) $(SLINTST) $(SCLNTST) $(LOADER) $(LOADOPTS) $(ALINTST) $(SCLNTST) $(SLINTST) \ - ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o xlintsts && mv xlintsts $@ ../xlintstc : $(ALINTST) $(CLINTST) $(SCLNTST) $(LOADER) $(LOADOPTS) $(ALINTST) $(SCLNTST) $(CLINTST) \ - ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o xlintstc && mv xlintstc $@ ../xlintstd : $(ALINTST) $(DLINTST) $(DZLNTST) - $(LOADER) $(LOADOPTS) $(ALINTST) $(DZLNTST) $(DLINTST) \ - ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ + $(LOADER) $(LOADOPTS) $^ \ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o xlintstd && mv xlintstd $@ ../xlintstz : $(ALINTST) $(ZLINTST) $(DZLNTST) $(LOADER) $(LOADOPTS) $(ALINTST) $(DZLNTST) $(ZLINTST) \ - ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) -o xlintstz && mv xlintstz $@ ../xlintstds : $(DSLINTST) $(LOADER) $(LOADOPTS) $(DSLINTST) \ - ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o xlintstds && mv xlintstds $@ ../xlintstzc : $(ZCLINTST) $(LOADER) $(LOADOPTS) $(ZCLINTST) \ - ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o $@ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o xlintstzc && mv xlintstzc $@ + +../xlintstrfs : $(SLINTSTRFP) + $(LOADER) $(LOADOPTS) $(SLINTSTRFP) \ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o xlintstrfs && mv xlintstrfs $@ + +../xlintstrfd : $(DLINTSTRFP) + $(LOADER) $(LOADOPTS) $(DLINTSTRFP) \ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o xlintstrfd && mv xlintstrfd $@ + +../xlintstrfc : $(CLINTSTRFP) + $(LOADER) $(LOADOPTS) $(CLINTSTRFP) \ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o xlintstrfc && mv xlintstrfc $@ + +../xlintstrfz : $(ZLINTSTRFP) + $(LOADER) $(LOADOPTS) $(ZLINTSTRFP) \ + ../../$(TMGLIB) ../../$(LAPACKLIB) $(BLASLIB) -o xlintstrfz && mv xlintstrfz $@ $(ALINTST): $(FRC) $(SCLNTST): $(FRC) @@ -219,7 +277,7 @@ $(SLINTST): $(FRC) $(CLINTST): $(FRC) $(DLINTST): $(FRC) $(ZLINTST): $(FRC) - + FRC: @FRC=$(FRC) diff --git a/TESTING/LIN/aladhd.f b/TESTING/LIN/aladhd.f index faa37dcd..44365935 100644 --- a/TESTING/LIN/aladhd.f +++ b/TESTING/LIN/aladhd.f @@ -28,6 +28,7 @@ * _GB: General band * _GT: General Tridiagonal * _PO: Symmetric or Hermitian positive definite +* _PS: Symmetric or Hermitian positive semi-definite * _PP: Symmetric or Hermitian positive definite packed * _PB: Symmetric or Hermitian positive definite band * _PT: Symmetric or Hermitian positive definite tridiagonal @@ -109,9 +110,11 @@ WRITE( IOUNIT, FMT = 9976 )6 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * - ELSE IF( LSAMEN( 2, P2, 'PO' ) .OR. LSAMEN( 2, P2, 'PP' ) ) THEN + ELSE IF( LSAMEN( 2, P2, 'PO' ) .OR. LSAMEN( 2, P2, 'PP' ) + $ .OR. LSAMEN( 2, P2, 'PS' ) ) THEN * * PO: Positive definite full +* PS: Positive definite full * PP: Positive definite packed * IF( SORD ) THEN diff --git a/TESTING/LIN/alaerh.f b/TESTING/LIN/alaerh.f index 8db21b8d..1edb12c2 100644 --- a/TESTING/LIN/alaerh.f +++ b/TESTING/LIN/alaerh.f @@ -7,7 +7,7 @@ * * .. Scalar Arguments .. CHARACTER*3 PATH - CHARACTER*(*) SUBNAM + CHARACTER*( * ) SUBNAM CHARACTER*( * ) OPTS INTEGER IMAT, INFO, INFOE, KL, KU, M, N, N5, NERRS, $ NFAIL, NOUT @@ -87,11 +87,12 @@ CHARACTER*3 C3 * .. * .. External Functions .. - INTEGER ILA_LEN_TRIM - EXTERNAL ILA_LEN_TRIM LOGICAL LSAME, LSAMEN EXTERNAL LSAME, LSAMEN * .. +* .. Intrinsic Functions .. + INTRINSIC LEN_TRIM +* .. * .. External Subroutines .. EXTERNAL ALADHD, ALAHD * .. @@ -123,11 +124,11 @@ IF( LSAMEN( 3, C3, 'TRF' ) ) THEN IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9988 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, M, N, N5, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, M, N, N5, $ IMAT ELSE WRITE( NOUT, FMT = 9975 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, M, N, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, N5, IMAT END IF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9949 ) @@ -136,57 +137,57 @@ * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9984 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, N, N5, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, N, N5, $ IMAT ELSE WRITE( NOUT, FMT = 9970 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, N, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9992 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT ELSE WRITE( NOUT, FMT = 9997 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN * WRITE( NOUT, FMT = 9971 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, N, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, N, N5, IMAT * ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN * WRITE( NOUT, FMT = 9978 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, M, N, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT * ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN * WRITE( NOUT, FMT = 9969 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, $ IMAT * ELSE IF( LSAMEN( 3, C3, 'LS ' ) ) THEN * WRITE( NOUT, FMT = 9965 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, N, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, N, $ KL, N5, IMAT * ELSE IF( LSAMEN( 3, C3, 'LSX' ) .OR. LSAMEN( 3, C3, 'LSS' ) ) $ THEN * WRITE( NOUT, FMT = 9974 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT * ELSE * WRITE( NOUT, FMT = 9963 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, N5, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, N5, $ IMAT END IF * @@ -197,11 +198,11 @@ IF( LSAMEN( 3, C3, 'TRF' ) ) THEN IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9989 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, M, N, KL, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, M, N, KL, $ KU, N5, IMAT ELSE WRITE( NOUT, FMT = 9976 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, M, N, KL, KU, N5, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, KL, KU, N5, $ IMAT END IF IF( INFO.NE.0 ) @@ -211,11 +212,11 @@ * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9986 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, N, KL, KU, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, N, KL, KU, $ N5, IMAT ELSE WRITE( NOUT, FMT = 9972 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, N, KL, KU, N5, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, N, KL, KU, N5, $ IMAT END IF * @@ -223,29 +224,29 @@ * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9993 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, KL, KU, N5, IMAT ELSE WRITE( NOUT, FMT = 9998 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), N, KL, KU, N5, IMAT END IF * ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN * WRITE( NOUT, FMT = 9977 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, M, N, KL, KU, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, KL, KU, IMAT * ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN * WRITE( NOUT, FMT = 9968 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, KL, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, KL, $ KU, IMAT * ELSE * WRITE( NOUT, FMT = 9964 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, KL, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, KL, $ KU, N5, IMAT END IF * @@ -256,10 +257,10 @@ IF( LSAMEN( 3, C3, 'TRF' ) ) THEN IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9987 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, N, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, N, IMAT ELSE WRITE( NOUT, FMT = 9973 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, N, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, N, IMAT END IF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9949 ) @@ -268,35 +269,35 @@ * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9984 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, N, N5, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, N, N5, $ IMAT ELSE WRITE( NOUT, FMT = 9970 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, N, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9992 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT ELSE WRITE( NOUT, FMT = 9997 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN * WRITE( NOUT, FMT = 9969 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, $ IMAT * ELSE * WRITE( NOUT, FMT = 9963 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, N5, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, N5, $ IMAT END IF * @@ -308,11 +309,11 @@ IF( LSAMEN( 3, C3, 'TRF' ) ) THEN IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9980 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, M, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, M, $ N5, IMAT ELSE WRITE( NOUT, FMT = 9956 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT END IF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9949 ) @@ -321,40 +322,88 @@ * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9979 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, N, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, N, $ N5, IMAT ELSE WRITE( NOUT, FMT = 9955 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, UPLO, N, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9990 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT ELSE WRITE( NOUT, FMT = 9995 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN * WRITE( NOUT, FMT = 9956 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT * ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR. $ LSAMEN( 3, C3, 'CON' ) ) THEN * WRITE( NOUT, FMT = 9960 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, UPLO, M, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, IMAT * ELSE * WRITE( NOUT, FMT = 9955 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT + END IF +* + ELSE IF( LSAMEN( 2, P2, 'PS' ) ) THEN +* +* xPS: Symmetric or Hermitian positive semi-definite matrices +* + UPLO = OPTS( 1: 1 ) + IF( LSAMEN( 3, C3, 'TRF' ) ) THEN + IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN + WRITE( NOUT, FMT = 9980 )SUBNAM, INFO, INFOE, UPLO, M, + $ N5, IMAT + ELSE + WRITE( NOUT, FMT = 9956 )SUBNAM, INFO, UPLO, M, N5, IMAT + END IF + IF( INFO.NE.0 ) + $ WRITE( NOUT, FMT = 9949 ) +* + ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN +* + IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN + WRITE( NOUT, FMT = 9979 )SUBNAM, INFO, INFOE, UPLO, N, + $ N5, IMAT + ELSE + WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, N, N5, IMAT + END IF +* + ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN +* + IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN + WRITE( NOUT, FMT = 9990 )SUBNAM, INFO, INFOE, + $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT + ELSE + WRITE( NOUT, FMT = 9995 )SUBNAM, INFO, OPTS( 1: 1 ), + $ OPTS( 2: 2 ), N, N5, IMAT + END IF +* + ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN +* + WRITE( NOUT, FMT = 9956 )SUBNAM, INFO, UPLO, M, N5, IMAT +* + ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMT' ) .OR. + $ LSAMEN( 3, C3, 'CON' ) ) THEN +* + WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT +* + ELSE +* + WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, M, N5, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'SY' ) .OR. LSAMEN( 2, P2, 'HE' ) ) THEN @@ -365,11 +414,11 @@ IF( LSAMEN( 3, C3, 'TRF' ) ) THEN IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9980 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, M, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, M, $ N5, IMAT ELSE WRITE( NOUT, FMT = 9956 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT END IF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9949 ) @@ -378,22 +427,22 @@ * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9979 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, N, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, N, $ N5, IMAT ELSE WRITE( NOUT, FMT = 9955 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, UPLO, N, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9990 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT ELSE WRITE( NOUT, FMT = 9995 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), N, N5, IMAT END IF * @@ -402,12 +451,12 @@ $ THEN * WRITE( NOUT, FMT = 9960 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, UPLO, M, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, IMAT * ELSE * WRITE( NOUT, FMT = 9955 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'PP' ) .OR. LSAMEN( 2, P2, 'SP' ) .OR. @@ -419,11 +468,11 @@ IF( LSAMEN( 3, C3, 'TRF' ) ) THEN IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9983 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, M, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, M, $ IMAT ELSE WRITE( NOUT, FMT = 9960 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, UPLO, M, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, IMAT END IF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9949 ) @@ -432,22 +481,22 @@ * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9979 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, N, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, N, $ N5, IMAT ELSE WRITE( NOUT, FMT = 9955 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, UPLO, N, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9990 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT ELSE WRITE( NOUT, FMT = 9995 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), N, N5, IMAT END IF * @@ -456,12 +505,12 @@ $ THEN * WRITE( NOUT, FMT = 9960 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, UPLO, M, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, IMAT * ELSE * WRITE( NOUT, FMT = 9955 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, N5, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'PB' ) ) THEN @@ -472,11 +521,11 @@ IF( LSAMEN( 3, C3, 'TRF' ) ) THEN IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9982 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, M, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, M, $ KL, N5, IMAT ELSE WRITE( NOUT, FMT = 9958 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, UPLO, M, KL, N5, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, KL, N5, $ IMAT END IF IF( INFO.NE.0 ) @@ -486,11 +535,11 @@ * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9981 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, N, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, UPLO, N, $ KL, N5, IMAT ELSE WRITE( NOUT, FMT = 9957 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, UPLO, N, KL, N5, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, N, KL, N5, $ IMAT END IF * @@ -498,11 +547,11 @@ * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9991 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, KL, N5, IMAT ELSE WRITE( NOUT, FMT = 9996 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), N, KL, N5, IMAT END IF * @@ -510,12 +559,12 @@ $ LSAMEN( 3, C3, 'CON' ) ) THEN * WRITE( NOUT, FMT = 9959 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, UPLO, M, KL, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, KL, IMAT * ELSE * WRITE( NOUT, FMT = 9957 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, UPLO, M, KL, N5, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, UPLO, M, KL, N5, $ IMAT END IF * @@ -526,10 +575,10 @@ IF( LSAMEN( 3, C3, 'TRF' ) ) THEN IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9987 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, N, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, N, IMAT ELSE WRITE( NOUT, FMT = 9973 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, N, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, N, IMAT END IF IF( INFO.NE.0 ) $ WRITE( NOUT, FMT = 9949 ) @@ -538,22 +587,22 @@ * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9984 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, N, N5, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, N, N5, $ IMAT ELSE WRITE( NOUT, FMT = 9970 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, N, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, N, N5, IMAT END IF * ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9994 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, $ OPTS( 1: 1 ), N, N5, IMAT ELSE WRITE( NOUT, FMT = 9999 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), N, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), N, $ N5, IMAT END IF * @@ -562,17 +611,17 @@ IF( LSAME( SUBNAM( 1: 1 ), 'S' ) .OR. $ LSAME( SUBNAM( 1: 1 ), 'D' ) ) THEN WRITE( NOUT, FMT = 9973 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, M, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, IMAT ELSE WRITE( NOUT, FMT = 9969 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, $ IMAT END IF * ELSE * WRITE( NOUT, FMT = 9963 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, N5, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), M, N5, $ IMAT END IF * @@ -582,19 +631,19 @@ * IF( LSAMEN( 3, C3, 'TRI' ) ) THEN WRITE( NOUT, FMT = 9961 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), M, N5, IMAT ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN WRITE( NOUT, FMT = 9967 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, IMAT ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATRS' ) ) THEN WRITE( NOUT, FMT = 9952 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, IMAT ELSE WRITE( NOUT, FMT = 9953 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, N5, IMAT END IF * @@ -604,19 +653,19 @@ * IF( LSAMEN( 3, C3, 'TRI' ) ) THEN WRITE( NOUT, FMT = 9962 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), M, IMAT ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN WRITE( NOUT, FMT = 9967 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, IMAT ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATPS' ) ) THEN WRITE( NOUT, FMT = 9952 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, IMAT ELSE WRITE( NOUT, FMT = 9953 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, N5, IMAT END IF * @@ -626,15 +675,15 @@ * IF( LSAMEN( 3, C3, 'CON' ) ) THEN WRITE( NOUT, FMT = 9966 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, KL, IMAT ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATBS' ) ) THEN WRITE( NOUT, FMT = 9951 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, KL, IMAT ELSE WRITE( NOUT, FMT = 9954 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, OPTS( 1: 1 ), $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, KL, N5, IMAT END IF * @@ -644,10 +693,10 @@ * IF( LSAMEN( 3, C3, 'QRS' ) ) THEN WRITE( NOUT, FMT = 9974 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN WRITE( NOUT, FMT = 9978 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, M, N, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'LQ' ) ) THEN @@ -656,10 +705,10 @@ * IF( LSAMEN( 3, C3, 'LQS' ) ) THEN WRITE( NOUT, FMT = 9974 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN WRITE( NOUT, FMT = 9978 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, M, N, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'QL' ) ) THEN @@ -668,10 +717,10 @@ * IF( LSAMEN( 3, C3, 'QLS' ) ) THEN WRITE( NOUT, FMT = 9974 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN WRITE( NOUT, FMT = 9978 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, M, N, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'RQ' ) ) THEN @@ -680,31 +729,31 @@ * IF( LSAMEN( 3, C3, 'RQS' ) ) THEN WRITE( NOUT, FMT = 9974 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, KL, N5, IMAT ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN WRITE( NOUT, FMT = 9978 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, M, N, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'LU' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9988 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, M, N, N5, + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, M, N, N5, $ IMAT ELSE WRITE( NOUT, FMT = 9975 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, M, N, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, N5, IMAT END IF * ELSE IF( LSAMEN( 2, P2, 'CH' ) ) THEN * IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN WRITE( NOUT, FMT = 9985 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, INFOE, M, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, INFOE, M, N5, IMAT ELSE WRITE( NOUT, FMT = 9971 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO, M, N5, IMAT + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N5, IMAT END IF * ELSE @@ -712,7 +761,7 @@ * Print a generic message if the path is unknown. * WRITE( NOUT, FMT = 9950 ) - $ SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), INFO + $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO END IF * * Description of error message (alphabetical, left to right) diff --git a/TESTING/LIN/alahd.f b/TESTING/LIN/alahd.f index 35005aec..db2ad217 100644 --- a/TESTING/LIN/alahd.f +++ b/TESTING/LIN/alahd.f @@ -28,6 +28,7 @@ * _GB: General band * _GT: General Tridiagonal * _PO: Symmetric or Hermitian positive definite +* _PS: Symmetric or Hermitian positive semi-definite * _PP: Symmetric or Hermitian positive definite packed * _PB: Symmetric or Hermitian positive definite band * _PT: Symmetric or Hermitian positive definite tridiagonal @@ -57,15 +58,17 @@ LOGICAL CORZ, SORD CHARACTER C1, C3 CHARACTER*2 P2 - CHARACTER(32) SUBNAM + CHARACTER*4 EIGCNM + CHARACTER*32 SUBNAM CHARACTER*9 SYM * .. * .. External Functions .. - INTEGER ILA_LEN_TRIM - EXTERNAL ILA_LEN_TRIM LOGICAL LSAME, LSAMEN EXTERNAL LSAME, LSAMEN * .. +* .. Intrinsic Functions .. + INTRINSIC LEN_TRIM +* .. * .. Executable Statements .. * IF( IOUNIT.LE.0 ) @@ -157,6 +160,28 @@ WRITE( IOUNIT, FMT = 9955 )8 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * + ELSE IF( LSAMEN( 2, P2, 'PS' ) ) THEN +* +* PS: Positive semi-definite full +* + IF( SORD ) THEN + SYM = 'Symmetric' + ELSE + SYM = 'Hermitian' + END IF + IF( LSAME( C1, 'S' ) .OR. LSAME( C1, 'C' ) ) THEN + EIGCNM = '1E04' + ELSE + EIGCNM = '1D12' + END IF + WRITE( IOUNIT, FMT = 9995 )PATH, SYM + WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' ) + WRITE( IOUNIT, FMT = 8973 )EIGCNM, EIGCNM, EIGCNM + WRITE( IOUNIT, FMT = '( '' Difference:'' )' ) + WRITE( IOUNIT, FMT = 8972 )C1 + WRITE( IOUNIT, FMT = '( '' Test ratio:'' )' ) + WRITE( IOUNIT, FMT = 8950 ) + WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) ELSE IF( LSAMEN( 2, P2, 'PB' ) ) THEN * * PB: Positive definite band @@ -261,7 +286,7 @@ SUBNAM = PATH( 1: 1 ) // 'LATPS' END IF WRITE( IOUNIT, FMT = 9966 )PATH - WRITE( IOUNIT, FMT = 9965 )SUBNAM(1:ILA_LEN_TRIM( SUBNAM )) + WRITE( IOUNIT, FMT = 9965 )SUBNAM(1:LEN_TRIM( SUBNAM )) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9961 )1 WRITE( IOUNIT, FMT = 9960 )2 @@ -270,7 +295,7 @@ WRITE( IOUNIT, FMT = 9957 )5 WRITE( IOUNIT, FMT = 9956 )6 WRITE( IOUNIT, FMT = 9955 )7 - WRITE( IOUNIT, FMT = 9951 )SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), 8 + WRITE( IOUNIT, FMT = 9951 )SUBNAM(1:LEN_TRIM( SUBNAM )), 8 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'TB' ) ) THEN @@ -280,7 +305,7 @@ WRITE( IOUNIT, FMT = 9988 )PATH SUBNAM = PATH( 1: 1 ) // 'LATBS' WRITE( IOUNIT, FMT = 9964 )PATH - WRITE( IOUNIT, FMT = 9963 )SUBNAM(1:ILA_LEN_TRIM( SUBNAM )) + WRITE( IOUNIT, FMT = 9963 )SUBNAM(1:LEN_TRIM( SUBNAM )) WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) WRITE( IOUNIT, FMT = 9960 )1 WRITE( IOUNIT, FMT = 9959 )2 @@ -288,7 +313,7 @@ WRITE( IOUNIT, FMT = 9957 )4 WRITE( IOUNIT, FMT = 9956 )5 WRITE( IOUNIT, FMT = 9955 )6 - WRITE( IOUNIT, FMT = 9951 )SUBNAM(1:ILA_LEN_TRIM( SUBNAM )), 7 + WRITE( IOUNIT, FMT = 9951 )SUBNAM(1:LEN_TRIM( SUBNAM )), 7 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'QR' ) ) THEN @@ -539,6 +564,21 @@ $ '*5. Middle row and column zero', / 3X, $ '(* - tests error exits, no test ratios are computed)' ) * +* PS matrix types +* + 8973 FORMAT( 4X, '1. Diagonal', / 4X, '2. Random, CNDNUM = 2', 14X, + $ / 3X, '*3. Nonzero eigenvalues of: D(1:RANK-1)=1 and ', + $ 'D(RANK) = 1.0/', A4, / 3X, + $ '*4. Nonzero eigenvalues of: D(1)=1 and ', + $ ' D(2:RANK) = 1.0/', A4, / 3X, + $ '*5. Nonzero eigenvalues of: D(I) = ', A4, + $ '**(-(I-1)/(RANK-1)) ', ' I=1:RANK', / 4X, + $ '6. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, + $ '7. Random, CNDNUM = 0.1/EPS', / 4X, + $ '8. Scaled near underflow', / 4X, '9. Scaled near overflow', + $ / 3X, '(* - Semi-definite tests )' ) + 8972 FORMAT( 3X, 'RANK minus computed rank, returned by ', A, 'PSTRF' ) +* * PB matrix types * 9973 FORMAT( 4X, '1. Random, CNDNUM = 2', 14X, @@ -673,6 +713,10 @@ 9954 FORMAT( 3X, I2, ': norm( U'' * U - A ) / ( N * norm(A) * EPS )', $ ', or', / 7X, 'norm( L * L'' - A ) / ( N * norm(A) * EPS )' $ ) + 8950 FORMAT( 3X, + $ 'norm( P * U'' * U * P'' - A ) / ( N * norm(A) * EPS )', + $ ', or', / 3X, + $ 'norm( P * L * L'' * P'' - A ) / ( N * norm(A) * EPS )' ) 9953 FORMAT( 3X, I2, ': norm( U*D*U'' - A ) / ( N * norm(A) * EPS )', $ ', or', / 7X, 'norm( L*D*L'' - A ) / ( N * norm(A) * EPS )' $ ) diff --git a/TESTING/LIN/cchkaa.f b/TESTING/LIN/cchkaa.f index acc026af..1680df59 100644 --- a/TESTING/LIN/cchkaa.f +++ b/TESTING/LIN/cchkaa.f @@ -26,6 +26,8 @@ * 5 Number of values of NB * 1 3 3 3 20 Values of NB (the blocksize) * 1 0 5 9 1 Values of NX (crossover point) +* 3 Number of values of RANK +* 30 50 90 Values of rank (as a % of N) * 30.0 Threshold value of test ratio * T Put T to test the LAPACK routines * T Put T to test the driver routines @@ -34,6 +36,7 @@ * CGB 8 List types on next line if 0 < NTYPES < 8 * CGT 12 List types on next line if 0 < NTYPES < 12 * CPO 9 List types on next line if 0 < NTYPES < 9 +* CPO 9 List types on next line if 0 < NTYPES < 9 * CPP 9 List types on next line if 0 < NTYPES < 9 * CPB 8 List types on next line if 0 < NTYPES < 8 * CPT 12 List types on next line if 0 < NTYPES < 12 @@ -96,15 +99,16 @@ CHARACTER*10 INTSTR CHARACTER*72 ALINE INTEGER I, IC, J, K, LA, LAFAC, LDA, NB, NM, NMATS, NN, - $ NNB, NNB2, NNS, NRHS, NTYPES,VERS_MAJOR, - $ VERS_MINOR, VERS_PATCH + $ NNB, NNB2, NNS, NRHS, NTYPES, NRANK, + $ VERS_MAJOR, VERS_MINOR, VERS_PATCH REAL EPS, S1, S2, THREQ, THRESH * .. * .. Local Arrays .. LOGICAL DOTYPE( MATMAX ) INTEGER IWORK( 25*NMAX ), MVAL( MAXIN ), $ NBVAL( MAXIN ), NBVAL2( MAXIN ), - $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ) + $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), + $ 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 ) @@ -116,15 +120,16 @@ * .. * .. External Subroutines .. EXTERNAL ALAREQ, CCHKEQ, CCHKGB, CCHKGE, CCHKGT, CCHKHE, - $ CCHKHP, CCHKLQ, CCHKPB, CCHKPO, CCHKPP, CCHKPT, - $ CCHKQ3, CCHKQL, CCHKQP, CCHKQR, CCHKRQ, CCHKSP, - $ CCHKSY, CCHKTB, CCHKTP, CCHKTR, CCHKTZ, CDRVGB, - $ CDRVGE, CDRVGT, CDRVHE, CDRVHP, CDRVLS, CDRVPB, - $ CDRVPO, CDRVPP, CDRVPT, CDRVSP, CDRVSY, ILAVER + $ CCHKHP, CCHKLQ, CCHKPB, CCHKPO, CCHKPS, CCHKPP, + $ CCHKPT, CCHKQ3, CCHKQL, CCHKQP, CCHKQR, CCHKRQ, + $ CCHKSP, CCHKSY, CCHKTB, CCHKTP, CCHKTR, CCHKTZ, + $ CDRVGB, CDRVGE, CDRVGT, CDRVHE, CDRVHP, CDRVLS, + $ CDRVPB, CDRVPO, CDRVPP, CDRVPT, CDRVSP, CDRVSY, + $ ILAVER * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Arrays in Common .. @@ -275,6 +280,32 @@ IF( NNB.GT.0 ) $ WRITE( NOUT, FMT = 9993 )'NX ', ( NXVAL( I ), I = 1, NNB ) * +* Read the values of RANKVAL +* + READ( NIN, FMT = * )NRANK + IF( NN.LT.1 ) THEN + WRITE( NOUT, FMT = 9996 )' NRANK ', NRANK, 1 + NRANK = 0 + FATAL = .TRUE. + ELSE IF( NN.GT.MAXIN ) THEN + WRITE( NOUT, FMT = 9995 )' NRANK ', NRANK, MAXIN + NRANK = 0 + FATAL = .TRUE. + END IF + READ( NIN, FMT = * )( RANKVAL( I ), I = 1, NRANK ) + DO I = 1, NRANK + IF( RANKVAL( I ).LT.0 ) THEN + WRITE( NOUT, FMT = 9996 )' RANK ', RANKVAL( I ), 0 + FATAL = .TRUE. + ELSE IF( RANKVAL( I ).GT.100 ) THEN + WRITE( NOUT, FMT = 9995 )' RANK ', RANKVAL( I ), 100 + FATAL = .TRUE. + END IF + END DO + IF( NRANK.GT.0 ) + $ WRITE( NOUT, FMT = 9993 )'RANK % OF N', + $ ( RANKVAL( I ), I = 1, NRANK ) +* * Read the threshold value for the test ratios. * READ( NIN, FMT = * )THRESH @@ -453,6 +484,23 @@ WRITE( NOUT, FMT = 9988 )PATH END IF * + ELSE IF( LSAMEN( 2, C2, 'PS' ) ) THEN +* +* PS: positive semi-definite matrices +* + NTYPES = 9 +* + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL CCHKPS( DOTYPE, NN, NVAL, NNB2, NBVAL2, NRANK, + $ RANKVAL, THRESH, TSTERR, LDA, A( 1, 1 ), + $ A( 1, 2 ), A( 1, 3 ), PIV, WORK, RWORK, + $ NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN * * PP: positive definite packed matrices diff --git a/TESTING/LIN/cchkgb.f b/TESTING/LIN/cchkgb.f index 21559135..a0c69247 100644 --- a/TESTING/LIN/cchkgb.f +++ b/TESTING/LIN/cchkgb.f @@ -140,7 +140,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchkge.f b/TESTING/LIN/cchkge.f index 42fd9562..53ca139f 100644 --- a/TESTING/LIN/cchkge.f +++ b/TESTING/LIN/cchkge.f @@ -139,7 +139,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. @@ -411,7 +411,7 @@ CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, $ RESULT( 5 ) ) CALL CGET07( TRANS, N, NRHS, A, LDA, B, LDA, X, - $ LDA, XACT, LDA, RWORK, + $ LDA, XACT, LDA, RWORK, .TRUE., $ RWORK( NRHS+1 ), RESULT( 6 ) ) * * Print information about the tests that did not diff --git a/TESTING/LIN/cchkgt.f b/TESTING/LIN/cchkgt.f index 554ae195..4a9dc39b 100644 --- a/TESTING/LIN/cchkgt.f +++ b/TESTING/LIN/cchkgt.f @@ -114,7 +114,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchkhe.f b/TESTING/LIN/cchkhe.f index 882332ce..99ad04e1 100644 --- a/TESTING/LIN/cchkhe.f +++ b/TESTING/LIN/cchkhe.f @@ -125,7 +125,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchkhp.f b/TESTING/LIN/cchkhp.f index d22be2dc..bdb00328 100644 --- a/TESTING/LIN/cchkhp.f +++ b/TESTING/LIN/cchkhp.f @@ -123,7 +123,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchklq.f b/TESTING/LIN/cchklq.f index be035976..7f8cba18 100644 --- a/TESTING/LIN/cchklq.f +++ b/TESTING/LIN/cchklq.f @@ -135,7 +135,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchkpb.f b/TESTING/LIN/cchkpb.f index e536b5e0..45590a47 100644 --- a/TESTING/LIN/cchkpb.f +++ b/TESTING/LIN/cchkpb.f @@ -123,7 +123,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchkpo.f b/TESTING/LIN/cchkpo.f index 5b2c24e4..cf758f29 100644 --- a/TESTING/LIN/cchkpo.f +++ b/TESTING/LIN/cchkpo.f @@ -120,7 +120,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchkpp.f b/TESTING/LIN/cchkpp.f index ec8311be..9c93fe53 100644 --- a/TESTING/LIN/cchkpp.f +++ b/TESTING/LIN/cchkpp.f @@ -117,7 +117,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchkps.f b/TESTING/LIN/cchkps.f new file mode 100644 index 00000000..3e54fbd1 --- /dev/null +++ b/TESTING/LIN/cchkps.f @@ -0,0 +1,267 @@ + SUBROUTINE CCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK, + $ RWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + REAL THRESH + INTEGER NMAX, NN, NNB, NOUT, NRANK + LOGICAL TSTERR +* .. +* .. Array Arguments .. + COMPLEX A( * ), AFAC( * ), PERM( * ), WORK( * ) + REAL RWORK( * ) + INTEGER NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * ) + LOGICAL DOTYPE( * ) +* .. +* +* Purpose +* ======= +* +* CCHKPS tests CPSTRF. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* NNB (input) INTEGER +* The number of values of NB contained in the vector NBVAL. +* +* NBVAL (input) INTEGER array, dimension (NBVAL) +* The values of the block size NB. +* +* NRANK (input) INTEGER +* The number of values of RANK contained in the vector RANKVAL. +* +* RANKVAL (input) INTEGER array, dimension (NBVAL) +* The values of the block size NB. +* +* THRESH (input) 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. +* +* TSTERR (input) LOGICAL +* Flag that indicates whether error exits are to be tested. +* +* NMAX (input) INTEGER +* The maximum value permitted for N, used in dimensioning the +* work arrays. +* +* A (workspace) COMPLEX array, dimension (NMAX*NMAX) +* +* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) +* +* PERM (workspace) COMPLEX array, dimension (NMAX*NMAX) +* +* PIV (workspace) INTEGER array, dimension (NMAX) +* +* WORK (workspace) COMPLEX array, dimension (NMAX*3) +* +* RWORK (workspace) REAL array, dimension (NMAX) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 9 ) +* .. +* .. Local Scalars .. + REAL ANORM, CNDNUM, RESULT, TOL + INTEGER COMPRANK, I, IMAT, IN, INB, INFO, IRANK, IUPLO, + $ IZERO, KL, KU, LDA, MODE, N, NB, NERRS, NFAIL, + $ NIMAT, NRUN, RANK, RANKDIFF + CHARACTER DIST, TYPE, UPLO + CHARACTER*3 PATH +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ), ISEEDY( 4 ) + CHARACTER UPLOS( 2 ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, CERRPS, CLACPY + $ CLATB5, CLATMT, CPST01, CPSTRF, XLAENV +* .. +* .. Scalars in Common .. + INTEGER INFOT, NUNIT + LOGICAL LERR, OK + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, REAL, CEILING +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Complex Precision' + PATH( 2: 3 ) = 'PS' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 100 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 100 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRPS( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of N in NVAL +* + DO 150 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 + DO 140 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 140 +* +* Do for each value of RANK in RANKVAL +* + DO 130 IRANK = 1, NRANK +* +* Only repeat test 3 to 5 for different ranks +* Other tests use full rank +* + IF( ( IMAT.LT.3 .OR. IMAT.GT.5 ) .AND. IRANK.GT.1 ) + $ GO TO 130 +* + RANK = CEILING( ( N * REAL( RANKVAL( IRANK ) ) ) + $ / 100.E+0 ) +* +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 120 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with CLATB5 and generate a test matrix +* with CLATMT. +* + CALL CLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'CLATMT' + CALL CLATMT( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, RANK, KL, KU, UPLO, A, + $ LDA, WORK, INFO ) +* +* Check error code from CLATMT. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMT', INFO, 0, UPLO, N, + $ N, -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + GO TO 120 + END IF +* +* Do for each value of NB in NBVAL +* + DO 110 INB = 1, NNB + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Compute the pivoted L*L' or U'*U factorization +* of the matrix. +* + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + SRNAMT = 'CPSTRF' +* +* Use default tolerance +* + TOL = -ONE + CALL CPSTRF( UPLO, N, AFAC, LDA, PIV, COMPRANK, + $ TOL, RWORK, INFO ) +* +* Check error code from CPSTRF. +* + IF( (INFO.LT.IZERO) + $ .OR.(INFO.NE.IZERO.AND.RANK.EQ.N) + $ .OR.(INFO.LE.IZERO.AND.RANK.LT.N) ) THEN + CALL ALAERH( PATH, 'CPSTRF', INFO, IZERO, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) + GO TO 110 + END IF +* +* Skip the test if INFO is not 0. +* + IF( INFO.NE.0 ) + $ GO TO 110 +* +* Reconstruct matrix from factors and compute residual. +* +* PERM holds permuted L*L^T or U^T*U +* + CALL CPST01( UPLO, N, A, LDA, AFAC, LDA, PERM, LDA, + $ PIV, RWORK, RESULT, COMPRANK ) +* +* Print information about the tests that did not pass +* the threshold or where computed rank was not RANK. +* + IF( N.EQ.0 ) + $ COMPRANK = 0 + RANKDIFF = RANK - COMPRANK + IF( RESULT.GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, RANK, + $ RANKDIFF, NB, IMAT, RESULT + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 110 CONTINUE +* + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', RANK =', I3, + $ ', Diff =', I5, ', NB =', I4, ', type ', I2, ', Ratio =', + $ G12.5 ) + RETURN +* +* End of CCHKPS +* + END diff --git a/TESTING/LIN/cchkpt.f b/TESTING/LIN/cchkpt.f index 31a40d6b..d940d51f 100644 --- a/TESTING/LIN/cchkpt.f +++ b/TESTING/LIN/cchkpt.f @@ -114,7 +114,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchkq3.f b/TESTING/LIN/cchkq3.f index bcdd5710..d9b5f766 100644 --- a/TESTING/LIN/cchkq3.f +++ b/TESTING/LIN/cchkq3.f @@ -119,7 +119,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchkql.f b/TESTING/LIN/cchkql.f index ec0ee163..fccb8792 100644 --- a/TESTING/LIN/cchkql.f +++ b/TESTING/LIN/cchkql.f @@ -135,7 +135,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchkqp.f b/TESTING/LIN/cchkqp.f index 5f89dc5a..cf25cf64 100644 --- a/TESTING/LIN/cchkqp.f +++ b/TESTING/LIN/cchkqp.f @@ -109,7 +109,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchkqr.f b/TESTING/LIN/cchkqr.f index 93279ce7..f1bdeba5 100644 --- a/TESTING/LIN/cchkqr.f +++ b/TESTING/LIN/cchkqr.f @@ -135,7 +135,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchkrfp.f b/TESTING/LIN/cchkrfp.f new file mode 100644 index 00000000..8d85e6dc --- /dev/null +++ b/TESTING/LIN/cchkrfp.f @@ -0,0 +1,265 @@ + PROGRAM CCHKRFP + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* Purpose +* ======= +* +* CCHKRFP is the main test program for the COMPLEX linear equation +* routines with RFP storage format +* +* +* Internal Parameters +* =================== +* +* MAXIN INTEGER +* The number of different values that can be used for each of +* M, N, or NB +* +* MAXRHS INTEGER +* The maximum number of right hand sides +* +* NTYPES INTEGER +* +* NMAX INTEGER +* The maximum allowable value for N. +* +* NIN INTEGER +* The unit number for input +* +* NOUT INTEGER +* The unit number for output +* +* ===================================================================== +* +* .. Parameters .. + INTEGER MAXIN + PARAMETER ( MAXIN = 12 ) + INTEGER NMAX + PARAMETER ( NMAX = 50 ) + INTEGER MAXRHS + PARAMETER ( MAXRHS = 16 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 9 ) + INTEGER NIN, NOUT + PARAMETER ( NIN = 5, NOUT = 6 ) +* .. +* .. Local Scalars .. + LOGICAL FATAL, TSTERR + INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH + INTEGER I, NN, NNS, NNT + REAL EPS, S1, S2, THRESH + +* .. +* .. Local Arrays .. + INTEGER NVAL( MAXIN ), NSVAL( MAXIN ), NTVAL( NTYPES ) + COMPLEX WORKA( NMAX, NMAX ) + COMPLEX WORKASAV( NMAX, NMAX ) + COMPLEX WORKB( NMAX, MAXRHS ) + COMPLEX WORKXACT( NMAX, MAXRHS ) + COMPLEX WORKBSAV( NMAX, MAXRHS ) + COMPLEX WORKX( NMAX, MAXRHS ) + COMPLEX WORKAFAC( NMAX, NMAX ) + COMPLEX WORKAINV( NMAX, NMAX ) + COMPLEX WORKARF( (NMAX*(NMAX+1))/2 ) + COMPLEX WORKAP( (NMAX*(NMAX+1))/2 ) + COMPLEX WORKARFINV( (NMAX*(NMAX+1))/2 ) + COMPLEX C_WORK_CLATMS( 3 * NMAX ) + COMPLEX C_WORK_CPOT01( NMAX ) + COMPLEX C_WORK_CPOT02( NMAX, MAXRHS ) + COMPLEX C_WORK_CPOT03( NMAX, NMAX ) + REAL S_WORK_CLATMS( NMAX ) + REAL S_WORK_CLANHE( NMAX ) + REAL S_WORK_CPOT02( NMAX ) + REAL S_WORK_CPOT03( NMAX ) +* .. +* .. External Functions .. + REAL SLAMCH, SECOND + EXTERNAL SLAMCH, SECOND +* .. +* .. External Subroutines .. + EXTERNAL ILAVER, CDRVRFP, CDRVRF1, CDRVRF2, CDRVRF3, + + CDRVRF4 +* .. +* .. Executable Statements .. +* + S1 = SECOND( ) + FATAL = .FALSE. +* +* Read a dummy line. +* + READ( NIN, FMT = * ) +* +* Report LAPACK version tag (e.g. LAPACK-3.2.0) +* + CALL ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) + WRITE( NOUT, FMT = 9994 ) VERS_MAJOR, VERS_MINOR, VERS_PATCH +* +* Read the values of N +* + READ( NIN, FMT = * )NN + IF( NN.LT.1 ) THEN + WRITE( NOUT, FMT = 9996 )' NN ', NN, 1 + NN = 0 + FATAL = .TRUE. + ELSE IF( NN.GT.MAXIN ) THEN + WRITE( NOUT, FMT = 9995 )' NN ', NN, MAXIN + NN = 0 + FATAL = .TRUE. + END IF + READ( NIN, FMT = * )( NVAL( I ), I = 1, NN ) + DO 10 I = 1, NN + IF( NVAL( I ).LT.0 ) THEN + WRITE( NOUT, FMT = 9996 )' M ', NVAL( I ), 0 + FATAL = .TRUE. + ELSE IF( NVAL( I ).GT.NMAX ) THEN + WRITE( NOUT, FMT = 9995 )' M ', NVAL( I ), NMAX + FATAL = .TRUE. + END IF + 10 CONTINUE + IF( NN.GT.0 ) + $ WRITE( NOUT, FMT = 9993 )'N ', ( NVAL( I ), I = 1, NN ) +* +* Read the values of NRHS +* + READ( NIN, FMT = * )NNS + IF( NNS.LT.1 ) THEN + WRITE( NOUT, FMT = 9996 )' NNS', NNS, 1 + NNS = 0 + FATAL = .TRUE. + ELSE IF( NNS.GT.MAXIN ) THEN + WRITE( NOUT, FMT = 9995 )' NNS', NNS, MAXIN + NNS = 0 + FATAL = .TRUE. + END IF + READ( NIN, FMT = * )( NSVAL( I ), I = 1, NNS ) + DO 30 I = 1, NNS + IF( NSVAL( I ).LT.0 ) THEN + WRITE( NOUT, FMT = 9996 )'NRHS', NSVAL( I ), 0 + FATAL = .TRUE. + ELSE IF( NSVAL( I ).GT.MAXRHS ) THEN + WRITE( NOUT, FMT = 9995 )'NRHS', NSVAL( I ), MAXRHS + FATAL = .TRUE. + END IF + 30 CONTINUE + IF( NNS.GT.0 ) + $ WRITE( NOUT, FMT = 9993 )'NRHS', ( NSVAL( I ), I = 1, NNS ) +* +* Read the matrix types +* + READ( NIN, FMT = * )NNT + IF( NNT.LT.1 ) THEN + WRITE( NOUT, FMT = 9996 )' NMA', NNT, 1 + NNT = 0 + FATAL = .TRUE. + ELSE IF( NNT.GT.NTYPES ) THEN + WRITE( NOUT, FMT = 9995 )' NMA', NNT, NTYPES + NNT = 0 + FATAL = .TRUE. + END IF + READ( NIN, FMT = * )( NTVAL( I ), I = 1, NNT ) + DO 320 I = 1, NNT + IF( NTVAL( I ).LT.0 ) THEN + WRITE( NOUT, FMT = 9996 )'TYPE', NTVAL( I ), 0 + FATAL = .TRUE. + ELSE IF( NTVAL( I ).GT.NTYPES ) THEN + WRITE( NOUT, FMT = 9995 )'TYPE', NTVAL( I ), NTYPES + FATAL = .TRUE. + END IF + 320 CONTINUE + IF( NNT.GT.0 ) + $ WRITE( NOUT, FMT = 9993 )'TYPE', ( NTVAL( I ), I = 1, NNT ) +* +* Read the threshold value for the test ratios. +* + READ( NIN, FMT = * )THRESH + WRITE( NOUT, FMT = 9992 )THRESH +* +* Read the flag that indicates whether to test the error exits. +* + READ( NIN, FMT = * )TSTERR +* + IF( FATAL ) THEN + WRITE( NOUT, FMT = 9999 ) + STOP + END IF +* + IF( FATAL ) THEN + WRITE( NOUT, FMT = 9999 ) + STOP + END IF +* +* Calculate and print the machine dependent constants. +* + EPS = SLAMCH( 'Underflow threshold' ) + WRITE( NOUT, FMT = 9991 )'underflow', EPS + EPS = SLAMCH( 'Overflow threshold' ) + WRITE( NOUT, FMT = 9991 )'overflow ', EPS + EPS = SLAMCH( 'Epsilon' ) + WRITE( NOUT, FMT = 9991 )'precision', EPS + WRITE( NOUT, FMT = * ) +* +* Test the error exit of: +* + IF( TSTERR ) + $ CALL CERRRFP( NOUT ) +* +* Test the routines: cpftrf, cpftri, cpftrs (as in CDRVPO). +* This also tests the routines: ctfsm, ctftri, ctfttr, ctrttf. +* + CALL CDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, THRESH, + $ WORKA, WORKASAV, WORKAFAC, WORKAINV, WORKB, + $ WORKBSAV, WORKXACT, WORKX, WORKARF, WORKARFINV, + $ C_WORK_CLATMS, C_WORK_CPOT01, C_WORK_CPOT02, + $ C_WORK_CPOT03, S_WORK_CLATMS, S_WORK_CLANHE, + $ S_WORK_CPOT02, S_WORK_CPOT03 ) +* +* Test the routine: clanhf +* + CALL CDRVRF1( NOUT, NN, NVAL, THRESH, WORKA, NMAX, WORKARF, + + S_WORK_CLANHE ) +* +* Test the convertion routines: +* chfttp, ctpthf, ctfttr, ctrttf, ctrttp and ctpttr. +* + CALL CDRVRF2( NOUT, NN, NVAL, WORKA, NMAX, WORKARF, + + WORKAP, WORKASAV ) +* +* Test the routine: ctfsm +* + CALL CDRVRF3( NOUT, NN, NVAL, THRESH, WORKA, NMAX, WORKARF, + + WORKAINV, WORKAFAC, S_WORK_CLANHE, + + C_WORK_CPOT03, C_WORK_CPOT01 ) +* +* +* Test the routine: chfrk +* + CALL CDRVRF4( NOUT, NN, NVAL, THRESH, WORKA, WORKAFAC, NMAX, + + WORKARF, WORKAINV, NMAX, S_WORK_CLANHE) +* + CLOSE ( NIN ) + S2 = SECOND( ) + WRITE( NOUT, FMT = 9998 ) + WRITE( NOUT, FMT = 9997 )S2 - S1 +* + 9999 FORMAT( / ' Execution not attempted due to input errors' ) + 9998 FORMAT( / ' End of tests' ) + 9997 FORMAT( ' Total time used = ', F12.2, ' seconds', / ) + 9996 FORMAT( ' !! Invalid input value: ', A4, '=', I6, '; must be >=', + $ I6 ) + 9995 FORMAT( ' !! Invalid input value: ', A4, '=', I6, '; must be <=', + $ I6 ) + 9994 FORMAT( / ' Tests of the COMPLEX LAPACK RFP routines ', + $ / ' LAPACK VERSION ', I1, '.', I1, '.', I1, + $ / / ' The following parameter values will be used:' ) + 9993 FORMAT( 4X, A4, ': ', 10I6, / 11X, 10I6 ) + 9992 FORMAT( / ' Routines pass computational tests if test ratio is ', + $ 'less than', F8.2, / ) + 9991 FORMAT( ' Relative machine ', A, ' is taken to be', D16.6 ) +* +* End of CCHKRFP +* + END diff --git a/TESTING/LIN/cchkrq.f b/TESTING/LIN/cchkrq.f index 2e5d1cd5..b672d351 100644 --- a/TESTING/LIN/cchkrq.f +++ b/TESTING/LIN/cchkrq.f @@ -135,7 +135,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchksp.f b/TESTING/LIN/cchksp.f index d41a6cdb..ae11e49e 100644 --- a/TESTING/LIN/cchksp.f +++ b/TESTING/LIN/cchksp.f @@ -123,7 +123,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchksy.f b/TESTING/LIN/cchksy.f index f100dfc8..f0f90506 100644 --- a/TESTING/LIN/cchksy.f +++ b/TESTING/LIN/cchksy.f @@ -125,7 +125,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchktb.f b/TESTING/LIN/cchktb.f index 0f8d1cd0..d12fdcae 100644 --- a/TESTING/LIN/cchktb.f +++ b/TESTING/LIN/cchktb.f @@ -114,7 +114,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchktp.f b/TESTING/LIN/cchktp.f index 0de93004..a21f7755 100644 --- a/TESTING/LIN/cchktp.f +++ b/TESTING/LIN/cchktp.f @@ -114,7 +114,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchktr.f b/TESTING/LIN/cchktr.f index c51e4892..3f1a6068 100644 --- a/TESTING/LIN/cchktr.f +++ b/TESTING/LIN/cchktr.f @@ -120,7 +120,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cchktz.f b/TESTING/LIN/cchktz.f index 29aff151..85507041 100644 --- a/TESTING/LIN/cchktz.f +++ b/TESTING/LIN/cchktz.f @@ -105,7 +105,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cdrvgb.f b/TESTING/LIN/cdrvgb.f index f6da8efb..49f75151 100644 --- a/TESTING/LIN/cdrvgb.f +++ b/TESTING/LIN/cdrvgb.f @@ -130,7 +130,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cdrvgbx.f b/TESTING/LIN/cdrvgbx.f new file mode 100644 index 00000000..c0e16773 --- /dev/null +++ b/TESTING/LIN/cdrvgbx.f @@ -0,0 +1,930 @@ + SUBROUTINE CDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, + $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER LA, LAFB, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL RWORK( * ), S( * ) + COMPLEX A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* Purpose +* ======= +* +* CDRVGB tests the driver routines CGBSV and -SVX. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix column dimension N. +* +* NRHS (input) INTEGER +* The number of right hand side vectors to be generated for +* each linear system. +* +* THRESH (input) 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. +* +* TSTERR (input) LOGICAL +* Flag that indicates whether error exits are to be tested. +* +* A (workspace) COMPLEX array, dimension (LA) +* +* LA (input) INTEGER +* The length of the array A. LA >= (2*NMAX-1)*NMAX +* where NMAX is the largest entry in NVAL. +* +* AFB (workspace) COMPLEX array, dimension (LAFB) +* +* LAFB (input) INTEGER +* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX +* where NMAX is the largest entry in NVAL. +* +* ASAV (workspace) COMPLEX array, dimension (LA) +* +* B (workspace) COMPLEX array, dimension (NMAX*NRHS) +* +* BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) +* +* X (workspace) COMPLEX array, dimension (NMAX*NRHS) +* +* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) +* +* S (workspace) REAL array, dimension (2*NMAX) +* +* WORK (workspace) COMPLEX array, dimension +* (NMAX*max(3,NRHS,NMAX)) +* +* RWORK (workspace) REAL array, dimension +* (max(NMAX,2*NRHS)) +* +* IWORK (workspace) INTEGER array, dimension (NMAX) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 8 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) + INTEGER NTRAN + PARAMETER ( NTRAN = 3 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT + CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE + CHARACTER*3 PATH + INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN, + $ INFO, IOFF, ITRAN, IZERO, J, K, K1, KL, KU, + $ LDA, LDAFB, LDB, MODE, N, NB, NBMIN, NERRS, + $ NFACT, NFAIL, NIMAT, NKL, NKU, NRUN, NT, + $ N_ERR_BNDS + REAL AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV, + $ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO, + $ ROLDC, ROLDI, ROLDO, ROWCND, RPVGRW, + $ RPVGRW_SVXX +* .. +* .. Local Arrays .. + CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RDUM( 1 ), RESULT( NTESTS ), BERR( NRHS ), + $ ERRBNDS_N( NRHS,3 ), ERRBNDS_C( NRHS, 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + REAL CLANGB, CLANGE, CLANTB, SGET06, SLAMCH, + $ CLA_GBRPVGRW + EXTERNAL LSAME, CLANGB, CLANGE, CLANTB, SGET06, SLAMCH, + $ CLA_GBRPVGRW +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, CERRVX, CGBEQU, CGBSV, + $ CGBSVX, CGBT01, CGBT02, CGBT05, CGBTRF, CGBTRS, + $ CGET04, CLACPY, CLAQGB, CLARHS, CLASET, CLATB4, + $ CLATMS, XLAENV, CGBSVXX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, CMPLX, MAX, MIN +* .. +* .. 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 TRANSS / 'N', 'T', 'C' / + DATA FACTS / 'F', 'N', 'E' / + DATA EQUEDS / 'N', 'R', 'C', 'B' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'GB' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 150 IN = 1, NN + N = NVAL( IN ) + LDB = MAX( N, 1 ) + XTYPE = 'N' +* +* Set limits on the number of loop iterations. +* + NKL = MAX( 1, MIN( N, 4 ) ) + IF( N.EQ.0 ) + $ NKL = 1 + NKU = NKL + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 140 IKL = 1, NKL +* +* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes +* it easier to skip redundant values for small values of N. +* + IF( IKL.EQ.1 ) THEN + KL = 0 + ELSE IF( IKL.EQ.2 ) THEN + KL = MAX( N-1, 0 ) + ELSE IF( IKL.EQ.3 ) THEN + KL = ( 3*N-1 ) / 4 + ELSE IF( IKL.EQ.4 ) THEN + KL = ( N+1 ) / 4 + END IF + DO 130 IKU = 1, NKU +* +* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order +* makes it easier to skip redundant values for small +* values of N. +* + IF( IKU.EQ.1 ) THEN + KU = 0 + ELSE IF( IKU.EQ.2 ) THEN + KU = MAX( N-1, 0 ) + ELSE IF( IKU.EQ.3 ) THEN + KU = ( 3*N-1 ) / 4 + ELSE IF( IKU.EQ.4 ) THEN + KU = ( N+1 ) / 4 + END IF +* +* Check that A and AFB are big enough to generate this +* matrix. +* + LDA = KL + KU + 1 + LDAFB = 2*KL + KU + 1 + IF( LDA*N.GT.LA .OR. LDAFB*N.GT.LAFB ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( LDA*N.GT.LA ) THEN + WRITE( NOUT, FMT = 9999 )LA, N, KL, KU, + $ N*( KL+KU+1 ) + NERRS = NERRS + 1 + END IF + IF( LDAFB*N.GT.LAFB ) THEN + WRITE( NOUT, FMT = 9998 )LAFB, N, KL, KU, + $ N*( 2*KL+KU+1 ) + NERRS = NERRS + 1 + END IF + GO TO 130 + END IF +* + DO 120 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 120 +* +* Skip types 2, 3, or 4 if the matrix is too small. +* + ZEROT = IMAT.GE.2 .AND. IMAT.LE.4 + IF( ZEROT .AND. N.LT.IMAT-1 ) + $ GO TO 120 +* +* Set up parameters with CLATB4 and generate a +* test matrix with CLATMS. +* + CALL CLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) + RCONDC = ONE / CNDNUM +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, 'Z', A, LDA, WORK, + $ INFO ) +* +* Check the error code from CLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', N, N, + $ KL, KU, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 120 + END IF +* +* For types 2, 3, and 4, zero one or more columns of +* the matrix to test that INFO is returned correctly. +* + IZERO = 0 + IF( ZEROT ) THEN + IF( IMAT.EQ.2 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.3 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF + IOFF = ( IZERO-1 )*LDA + IF( IMAT.LT.4 ) THEN + I1 = MAX( 1, KU+2-IZERO ) + I2 = MIN( KL+KU+1, KU+1+( N-IZERO ) ) + DO 20 I = I1, I2 + A( IOFF+I ) = ZERO + 20 CONTINUE + ELSE + DO 40 J = IZERO, N + DO 30 I = MAX( 1, KU+2-J ), + $ MIN( KL+KU+1, KU+1+( N-J ) ) + A( IOFF+I ) = ZERO + 30 CONTINUE + IOFF = IOFF + LDA + 40 CONTINUE + END IF + END IF +* +* Save a copy of the matrix A in ASAV. +* + CALL CLACPY( 'Full', KL+KU+1, N, A, LDA, ASAV, LDA ) +* + DO 110 IEQUED = 1, 4 + EQUED = EQUEDS( IEQUED ) + IF( IEQUED.EQ.1 ) THEN + NFACT = 3 + ELSE + NFACT = 1 + END IF +* + DO 100 IFACT = 1, NFACT + FACT = FACTS( IFACT ) + PREFAC = LSAME( FACT, 'F' ) + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) +* + IF( ZEROT ) THEN + IF( PREFAC ) + $ GO TO 100 + RCONDO = ZERO + RCONDI = ZERO +* + ELSE IF( .NOT.NOFACT ) THEN +* +* Compute the condition number for comparison +* with the value returned by SGESVX (FACT = +* 'N' reuses the condition number from the +* previous iteration with FACT = 'F'). +* + CALL CLACPY( 'Full', KL+KU+1, N, ASAV, LDA, + $ AFB( KL+1 ), LDAFB ) + IF( EQUIL .OR. IEQUED.GT.1 ) THEN +* +* Compute row and column scale factors to +* equilibrate the matrix A. +* + CALL CGBEQU( N, N, KL, KU, AFB( KL+1 ), + $ LDAFB, S, S( N+1 ), ROWCND, + $ COLCND, AMAX, INFO ) + IF( INFO.EQ.0 .AND. N.GT.0 ) THEN + IF( LSAME( EQUED, 'R' ) ) THEN + ROWCND = ZERO + COLCND = ONE + ELSE IF( LSAME( EQUED, 'C' ) ) THEN + ROWCND = ONE + COLCND = ZERO + ELSE IF( LSAME( EQUED, 'B' ) ) THEN + ROWCND = ZERO + COLCND = ZERO + END IF +* +* Equilibrate the matrix. +* + CALL CLAQGB( N, N, KL, KU, AFB( KL+1 ), + $ LDAFB, S, S( N+1 ), + $ ROWCND, COLCND, AMAX, + $ EQUED ) + END IF + END IF +* +* Save the condition number of the +* non-equilibrated system for use in CGET04. +* + IF( EQUIL ) THEN + ROLDO = RCONDO + ROLDI = RCONDI + END IF +* +* Compute the 1-norm and infinity-norm of A. +* + ANORMO = CLANGB( '1', N, KL, KU, AFB( KL+1 ), + $ LDAFB, RWORK ) + ANORMI = CLANGB( 'I', N, KL, KU, AFB( KL+1 ), + $ LDAFB, RWORK ) +* +* Factor the matrix A. +* + CALL CGBTRF( N, N, KL, KU, AFB, LDAFB, IWORK, + $ INFO ) +* +* Form the inverse of A. +* + CALL CLASET( 'Full', N, N, CMPLX( ZERO ), + $ CMPLX( ONE ), WORK, LDB ) + SRNAMT = 'CGBTRS' + CALL CGBTRS( 'No transpose', N, KL, KU, N, + $ AFB, LDAFB, IWORK, WORK, LDB, + $ INFO ) +* +* Compute the 1-norm condition number of A. +* + AINVNM = CLANGE( '1', N, N, WORK, LDB, + $ RWORK ) + IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDO = ONE + ELSE + RCONDO = ( ONE / ANORMO ) / AINVNM + END IF +* +* Compute the infinity-norm condition number +* of A. +* + AINVNM = CLANGE( 'I', N, N, WORK, LDB, + $ RWORK ) + IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDI = ONE + ELSE + RCONDI = ( ONE / ANORMI ) / AINVNM + END IF + END IF +* + DO 90 ITRAN = 1, NTRAN +* +* Do for each value of TRANS. +* + TRANS = TRANSS( ITRAN ) + IF( ITRAN.EQ.1 ) THEN + RCONDC = RCONDO + ELSE + RCONDC = RCONDI + END IF +* +* Restore the matrix A. +* + CALL CLACPY( 'Full', KL+KU+1, N, ASAV, LDA, + $ A, LDA ) +* +* Form an exact solution and set the right hand +* side. +* + SRNAMT = 'CLARHS' + CALL CLARHS( PATH, XTYPE, 'Full', TRANS, N, + $ N, KL, KU, NRHS, A, LDA, XACT, + $ LDB, B, LDB, ISEED, INFO ) + XTYPE = 'C' + CALL CLACPY( 'Full', N, NRHS, B, LDB, BSAV, + $ LDB ) +* + IF( NOFACT .AND. ITRAN.EQ.1 ) THEN +* +* --- Test CGBSV --- +* +* Compute the LU factorization of the matrix +* and solve the system. +* + CALL CLACPY( 'Full', KL+KU+1, N, A, LDA, + $ AFB( KL+1 ), LDAFB ) + CALL CLACPY( 'Full', N, NRHS, B, LDB, X, + $ LDB ) +* + SRNAMT = 'CGBSV ' + CALL CGBSV( N, KL, KU, NRHS, AFB, LDAFB, + $ IWORK, X, LDB, INFO ) +* +* Check error code from CGBSV . +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'CGBSV ', INFO, + $ IZERO, ' ', N, N, KL, KU, + $ NRHS, IMAT, NFAIL, NERRS, + $ NOUT ) + GOTO 90 + END IF +* +* Reconstruct matrix from factors and +* compute residual. +* + CALL CGBT01( N, N, KL, KU, A, LDA, AFB, + $ LDAFB, IWORK, WORK, + $ RESULT( 1 ) ) + NT = 1 + IF( IZERO.EQ.0 ) THEN +* +* Compute residual of the computed +* solution. +* + CALL CLACPY( 'Full', N, NRHS, B, LDB, + $ WORK, LDB ) + CALL CGBT02( 'No transpose', N, N, KL, + $ KU, NRHS, A, LDA, X, LDB, + $ WORK, LDB, RESULT( 2 ) ) +* +* Check solution from generated exact +* solution. +* + CALL CGET04( N, NRHS, X, LDB, XACT, + $ LDB, RCONDC, RESULT( 3 ) ) + NT = 3 + END IF +* +* Print information about the tests that did +* not pass the threshold. +* + DO 50 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )'CGBSV ', + $ N, KL, KU, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 50 CONTINUE + NRUN = NRUN + NT + END IF +* +* --- Test CGBSVX --- +* + IF( .NOT.PREFAC ) + $ CALL CLASET( 'Full', 2*KL+KU+1, N, + $ CMPLX( ZERO ), CMPLX( ZERO ), + $ AFB, LDAFB ) + CALL CLASET( 'Full', N, NRHS, CMPLX( ZERO ), + $ CMPLX( ZERO ), X, LDB ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT = 'F' and +* EQUED = 'R', 'C', or 'B'. +* + CALL CLAQGB( N, N, KL, KU, A, LDA, S, + $ S( N+1 ), ROWCND, COLCND, + $ AMAX, EQUED ) + END IF +* +* Solve the system and compute the condition +* number and error bounds using CGBSVX. +* + SRNAMT = 'CGBSVX' + CALL CGBSVX( FACT, TRANS, N, KL, KU, NRHS, A, + $ LDA, AFB, LDAFB, IWORK, EQUED, + $ S, S( LDB+1 ), B, LDB, X, LDB, + $ RCOND, RWORK, RWORK( NRHS+1 ), + $ WORK, RWORK( 2*NRHS+1 ), INFO ) +* +* Check the error code from CGBSVX. +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'CGBSVX', INFO, IZERO, + $ FACT // TRANS, N, N, KL, KU, + $ NRHS, IMAT, NFAIL, NERRS, + $ NOUT ) + GOTO 90 + END IF +* Compare RWORK(2*NRHS+1) from CGBSVX with the +* computed reciprocal pivot growth RPVGRW +* + IF( INFO.NE.0 ) THEN + ANRMPV = ZERO + DO 70 J = 1, INFO + DO 60 I = MAX( KU+2-J, 1 ), + $ MIN( N+KU+1-J, KL+KU+1 ) + ANRMPV = MAX( ANRMPV, + $ ABS( A( I+( J-1 )*LDA ) ) ) + 60 CONTINUE + 70 CONTINUE + RPVGRW = CLANTB( 'M', 'U', 'N', INFO, + $ MIN( INFO-1, KL+KU ), + $ AFB( MAX( 1, KL+KU+2-INFO ) ), + $ LDAFB, RDUM ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = ANRMPV / RPVGRW + END IF + ELSE + RPVGRW = CLANTB( 'M', 'U', 'N', N, KL+KU, + $ AFB, LDAFB, RDUM ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = CLANGB( 'M', N, KL, KU, A, + $ LDA, RDUM ) / RPVGRW + END IF + END IF + RESULT( 7 ) = ABS( RPVGRW-RWORK( 2*NRHS+1 ) ) + $ / MAX( RWORK( 2*NRHS+1 ), + $ RPVGRW ) / SLAMCH( 'E' ) +* + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and +* compute residual. +* + CALL CGBT01( N, N, KL, KU, A, LDA, AFB, + $ LDAFB, IWORK, WORK, + $ RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* + IF( INFO.EQ.0 ) THEN + TRFCON = .FALSE. +* +* Compute residual of the computed solution. +* + CALL CLACPY( 'Full', N, NRHS, BSAV, LDB, + $ WORK, LDB ) + CALL CGBT02( TRANS, N, N, KL, KU, NRHS, + $ ASAV, LDA, X, LDB, WORK, LDB, + $ RESULT( 2 ) ) +* +* Check solution from generated exact +* solution. +* + IF( NOFACT .OR. ( PREFAC .AND. + $ LSAME( EQUED, 'N' ) ) ) THEN + CALL CGET04( N, NRHS, X, LDB, XACT, + $ LDB, RCONDC, RESULT( 3 ) ) + ELSE + IF( ITRAN.EQ.1 ) THEN + ROLDC = ROLDO + ELSE + ROLDC = ROLDI + END IF + CALL CGET04( N, NRHS, X, LDB, XACT, + $ LDB, ROLDC, RESULT( 3 ) ) + END IF +* +* Check the error bounds from iterative +* refinement. +* + CALL CGBT05( TRANS, N, KL, KU, NRHS, ASAV, + $ LDA, BSAV, LDB, X, LDB, XACT, + $ LDB, RWORK, RWORK( NRHS+1 ), + $ RESULT( 4 ) ) + ELSE + TRFCON = .TRUE. + END IF +* +* Compare RCOND from CGBSVX with the computed +* value in RCONDC. +* + RESULT( 6 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did +* not pass the threshold. +* + IF( .NOT.TRFCON ) THEN + DO 80 K = K1, NTESTS + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9995 ) + $ 'CGBSVX', FACT, TRANS, N, KL, + $ KU, EQUED, IMAT, K, + $ RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9996 ) + $ 'CGBSVX', FACT, TRANS, N, KL, + $ KU, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 80 CONTINUE + NRUN = NRUN + 7 - K1 + ELSE + IF( RESULT( 1 ).GE.THRESH .AND. .NOT. + $ PREFAC ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9995 )'CGBSVX', + $ FACT, TRANS, N, KL, KU, EQUED, + $ IMAT, 1, RESULT( 1 ) + ELSE + WRITE( NOUT, FMT = 9996 )'CGBSVX', + $ FACT, TRANS, N, KL, KU, IMAT, 1, + $ RESULT( 1 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 6 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9995 )'CGBSVX', + $ FACT, TRANS, N, KL, KU, EQUED, + $ IMAT, 6, RESULT( 6 ) + ELSE + WRITE( NOUT, FMT = 9996 )'CGBSVX', + $ FACT, TRANS, N, KL, KU, IMAT, 6, + $ RESULT( 6 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9995 )'CGBSVX', + $ FACT, TRANS, N, KL, KU, EQUED, + $ IMAT, 7, RESULT( 7 ) + ELSE + WRITE( NOUT, FMT = 9996 )'CGBSVX', + $ FACT, TRANS, N, KL, KU, IMAT, 7, + $ RESULT( 7 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + END IF + +* --- Test CGBSVXX --- + +* Restore the matrices A and B. + +c write(*,*) 'begin cgbsvxx testing' + + CALL CLACPY( 'Full', KL+KU+1, N, ASAV, LDA, A, + $ LDA ) + CALL CLACPY( 'Full', N, NRHS, BSAV, LDB, B, LDB ) + + IF( .NOT.PREFAC ) + $ CALL CLASET( 'Full', 2*KL+KU+1, N, ZERO, ZERO, + $ AFB, LDAFB ) + CALL CLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDB ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT = 'F' and +* EQUED = 'R', 'C', or 'B'. +* + CALL CLAQGB( N, N, KL, KU, A, LDA, S, + $ S( N+1 ), ROWCND, COLCND, AMAX, EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using CGBSVXX. +* + SRNAMT = 'CGBSVXX' + n_err_bnds = 3 + CALL CGBSVXX( FACT, TRANS, N, KL, KU, NRHS, A, LDA, + $ AFB, LDAFB, IWORK, EQUED, S, S( N+1 ), B, LDB, + $ X, LDB, rcond, rpvgrw_svxx, berr, n_err_bnds, + $ errbnds_n, errbnds_c, 0, ZERO, WORK, + $ RWORK, INFO ) +* +* Check the error code from CGBSVXX. +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'CGBSVXX', INFO, IZERO, + $ FACT // TRANS, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GOTO 90 + END IF +* +* Compare rpvgrw_svxx from CGESVXX with the computed +* reciprocal pivot growth factor RPVGRW +* + + IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN + RPVGRW = CLA_GBRPVGRW(N, KL, KU, INFO, A, LDA, + $ AFB, LDAFB) + ELSE + RPVGRW = CLA_GBRPVGRW(N, KL, KU, N, A, LDA, + $ AFB, LDAFB) + ENDIF + + RESULT( 7 ) = ABS( RPVGRW-rpvgrw_svxx ) / + $ MAX( rpvgrw_svxx, RPVGRW ) / + $ SLAMCH( 'E' ) +* + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL CGBT01( N, N, KL, KU, A, LDA, AFB, LDAFB, + $ IWORK, RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* + IF( INFO.EQ.0 ) THEN + TRFCON = .FALSE. +* +* Compute residual of the computed solution. +* + CALL CLACPY( 'Full', N, NRHS, BSAV, LDB, WORK, + $ LDB ) + CALL CGBT02( TRANS, N, N, KL, KU, NRHS, ASAV, + $ LDA, X, LDB, WORK, LDB, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL CGET04( N, NRHS, X, LDB, XACT, LDB, + $ RCONDC, RESULT( 3 ) ) + ELSE + IF( ITRAN.EQ.1 ) THEN + ROLDC = ROLDO + ELSE + ROLDC = ROLDI + END IF + CALL CGET04( N, NRHS, X, LDB, XACT, LDB, + $ ROLDC, RESULT( 3 ) ) + END IF + ELSE + TRFCON = .TRUE. + END IF +* +* Compare RCOND from CGBSVXX with the computed value +* in RCONDC. +* + RESULT( 6 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( .NOT.TRFCON ) THEN + DO 45 K = K1, NTESTS + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'CGBSVXX', + $ FACT, TRANS, N, KL, KU, EQUED, + $ IMAT, K, RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'CGBSVXX', + $ FACT, TRANS, N, KL, KU, IMAT, K, + $ RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 45 CONTINUE + NRUN = NRUN + 7 - K1 + ELSE + IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) + $ THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'CGBSVXX', FACT, + $ TRANS, N, KL, KU, EQUED, IMAT, 1, + $ RESULT( 1 ) + ELSE + WRITE( NOUT, FMT = 9998 )'CGBSVXX', FACT, + $ TRANS, N, KL, KU, IMAT, 1, + $ RESULT( 1 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 6 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'CGBSVXX', FACT, + $ TRANS, N, KL, KU, EQUED, IMAT, 6, + $ RESULT( 6 ) + ELSE + WRITE( NOUT, FMT = 9998 )'CGBSVXX', FACT, + $ TRANS, N, KL, KU, IMAT, 6, + $ RESULT( 6 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'CGBSVXX', FACT, + $ TRANS, N, KL, KU, EQUED, IMAT, 7, + $ RESULT( 7 ) + ELSE + WRITE( NOUT, FMT = 9998 )'CGBSVXX', FACT, + $ TRANS, N, KL, KU, IMAT, 7, + $ RESULT( 7 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF +* + END IF +* + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + +* Test Error Bounds from CGBSVXX + + CALL CEBCHVXX(THRESH, PATH) + + 9999 FORMAT( ' *** In CDRVGB, LA=', I5, ' is too small for N=', I5, + $ ', KU=', I5, ', KL=', I5, / ' ==> Increase LA to at least ', + $ I5 ) + 9998 FORMAT( ' *** In CDRVGB, LAFB=', I5, ' is too small for N=', I5, + $ ', KU=', I5, ', KL=', I5, / + $ ' ==> Increase LAFB to at least ', I5 ) + 9997 FORMAT( 1X, A, ', N=', I5, ', KL=', I5, ', KU=', I5, ', type ', + $ I1, ', test(', I1, ')=', G12.5 ) + 9996 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', + $ I5, ',...), type ', I1, ', test(', I1, ')=', G12.5 ) + 9995 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', + $ I5, ',...), EQUED=''', A1, ''', type ', I1, ', test(', I1, + $ ')=', G12.5 ) +* + RETURN +* +* End of CDRVGB +* + END diff --git a/TESTING/LIN/cdrvge.f b/TESTING/LIN/cdrvge.f index 84b98a10..e6397524 100644 --- a/TESTING/LIN/cdrvge.f +++ b/TESTING/LIN/cdrvge.f @@ -124,7 +124,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. @@ -515,7 +515,7 @@ * refinement. * CALL CGET07( TRANS, N, NRHS, ASAV, LDA, B, LDA, - $ X, LDA, XACT, LDA, RWORK, + $ X, LDA, XACT, LDA, RWORK, .TRUE., $ RWORK( NRHS+1 ), RESULT( 4 ) ) ELSE TRFCON = .TRUE. diff --git a/TESTING/LIN/cdrvgex.f b/TESTING/LIN/cdrvgex.f new file mode 100644 index 00000000..aa175a3e --- /dev/null +++ b/TESTING/LIN/cdrvgex.f @@ -0,0 +1,800 @@ + SUBROUTINE CDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, + $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL RWORK( * ), S( * ) + COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ), + $ BSAV( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* Purpose +* ======= +* +* CDRVGE tests the driver routines CGESV, -SVX, and -SVXX. +* +* Note that this file is used only when the XBLAS are available, +* otherwise cdrvge.f defines this subroutine. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix column dimension N. +* +* NRHS (input) INTEGER +* The number of right hand side vectors to be generated for +* each linear system. +* +* THRESH (input) 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. +* +* TSTERR (input) LOGICAL +* Flag that indicates whether error exits are to be tested. +* +* NMAX (input) INTEGER +* The maximum value permitted for N, used in dimensioning the +* work arrays. +* +* A (workspace) COMPLEX array, dimension (NMAX*NMAX) +* +* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) +* +* ASAV (workspace) COMPLEX array, dimension (NMAX*NMAX) +* +* B (workspace) COMPLEX array, dimension (NMAX*NRHS) +* +* BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) +* +* X (workspace) COMPLEX array, dimension (NMAX*NRHS) +* +* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) +* +* S (workspace) REAL array, dimension (2*NMAX) +* +* WORK (workspace) COMPLEX array, dimension +* (NMAX*max(3,NRHS)) +* +* RWORK (workspace) REAL array, dimension (2*NRHS+NMAX) +* +* IWORK (workspace) INTEGER array, dimension (NMAX) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 11 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) + INTEGER NTRAN + PARAMETER ( NTRAN = 3 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT + CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE + CHARACTER*3 PATH + INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, ITRAN, + $ IZERO, K, K1, KL, KU, LDA, LWORK, MODE, N, NB, + $ NBMIN, NERRS, NFACT, NFAIL, NIMAT, NRUN, NT, + $ N_ERR_BNDS + REAL AINVNM, AMAX, ANORM, ANORMI, ANORMO, CNDNUM, + $ COLCND, RCOND, RCONDC, RCONDI, RCONDO, ROLDC, + $ ROLDI, ROLDO, ROWCND, RPVGRW, RPVGRW_SVXX +* .. +* .. Local Arrays .. + CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RDUM( 1 ), RESULT( NTESTS ), BERR( NRHS ), + $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + REAL CLANGE, CLANTR, SGET06, SLAMCH, CLA_RPVGRW + EXTERNAL LSAME, CLANGE, CLANTR, SGET06, SLAMCH, + $ CLA_RPVGRW +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, CERRVX, CGEEQU, CGESV, + $ CGESVX, CGET01, CGET02, CGET04, CGET07, CGETRF, + $ CGETRI, CLACPY, CLAQGE, CLARHS, CLASET, CLATB4, + $ CLATMS, XLAENV, CGESVXX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, CMPLX, MAX +* .. +* .. 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 TRANSS / 'N', 'T', 'C' / + DATA FACTS / 'F', 'N', 'E' / + DATA EQUEDS / 'N', 'R', 'C', 'B' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'GE' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 90 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 80 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 80 +* +* Skip types 5, 6, or 7 if the matrix size is too small. +* + ZEROT = IMAT.GE.5 .AND. IMAT.LE.7 + IF( ZEROT .AND. N.LT.IMAT-4 ) + $ GO TO 80 +* +* Set up parameters with CLATB4 and generate a test matrix +* with CLATMS. +* + CALL CLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) + RCONDC = ONE / CNDNUM +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, CNDNUM, + $ ANORM, KL, KU, 'No packing', A, LDA, WORK, + $ INFO ) +* +* Check error code from CLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', N, N, -1, -1, + $ -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 80 + END IF +* +* For types 5-7, zero one or more columns of the matrix to +* test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.5 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.6 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF + IOFF = ( IZERO-1 )*LDA + IF( IMAT.LT.7 ) THEN + DO 20 I = 1, N + A( IOFF+I ) = ZERO + 20 CONTINUE + ELSE + CALL CLASET( 'Full', N, N-IZERO+1, CMPLX( ZERO ), + $ CMPLX( ZERO ), A( IOFF+1 ), LDA ) + END IF + ELSE + IZERO = 0 + END IF +* +* Save a copy of the matrix A in ASAV. +* + CALL CLACPY( 'Full', N, N, A, LDA, ASAV, LDA ) +* + DO 70 IEQUED = 1, 4 + EQUED = EQUEDS( IEQUED ) + IF( IEQUED.EQ.1 ) THEN + NFACT = 3 + ELSE + NFACT = 1 + END IF +* + DO 60 IFACT = 1, NFACT + FACT = FACTS( IFACT ) + PREFAC = LSAME( FACT, 'F' ) + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) +* + IF( ZEROT ) THEN + IF( PREFAC ) + $ GO TO 60 + RCONDO = ZERO + RCONDI = ZERO +* + ELSE IF( .NOT.NOFACT ) THEN +* +* Compute the condition number for comparison with +* the value returned by CGESVX (FACT = 'N' reuses +* the condition number from the previous iteration +* with FACT = 'F'). +* + CALL CLACPY( 'Full', N, N, ASAV, LDA, AFAC, LDA ) + IF( EQUIL .OR. IEQUED.GT.1 ) THEN +* +* Compute row and column scale factors to +* equilibrate the matrix A. +* + CALL CGEEQU( N, N, AFAC, LDA, S, S( N+1 ), + $ ROWCND, COLCND, AMAX, INFO ) + IF( INFO.EQ.0 .AND. N.GT.0 ) THEN + IF( LSAME( EQUED, 'R' ) ) THEN + ROWCND = ZERO + COLCND = ONE + ELSE IF( LSAME( EQUED, 'C' ) ) THEN + ROWCND = ONE + COLCND = ZERO + ELSE IF( LSAME( EQUED, 'B' ) ) THEN + ROWCND = ZERO + COLCND = ZERO + END IF +* +* Equilibrate the matrix. +* + CALL CLAQGE( N, N, AFAC, LDA, S, S( N+1 ), + $ ROWCND, COLCND, AMAX, EQUED ) + END IF + END IF +* +* Save the condition number of the non-equilibrated +* system for use in CGET04. +* + IF( EQUIL ) THEN + ROLDO = RCONDO + ROLDI = RCONDI + END IF +* +* Compute the 1-norm and infinity-norm of A. +* + ANORMO = CLANGE( '1', N, N, AFAC, LDA, RWORK ) + ANORMI = CLANGE( 'I', N, N, AFAC, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL CGETRF( N, N, AFAC, LDA, IWORK, INFO ) +* +* Form the inverse of A. +* + CALL CLACPY( 'Full', N, N, AFAC, LDA, A, LDA ) + LWORK = NMAX*MAX( 3, NRHS ) + CALL CGETRI( N, A, LDA, IWORK, WORK, LWORK, INFO ) +* +* Compute the 1-norm condition number of A. +* + AINVNM = CLANGE( '1', N, N, A, LDA, RWORK ) + IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDO = ONE + ELSE + RCONDO = ( ONE / ANORMO ) / AINVNM + END IF +* +* Compute the infinity-norm condition number of A. +* + AINVNM = CLANGE( 'I', N, N, A, LDA, RWORK ) + IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDI = ONE + ELSE + RCONDI = ( ONE / ANORMI ) / AINVNM + END IF + END IF +* + DO 50 ITRAN = 1, NTRAN + DO I = 1, NTESTS + RESULT (I) = ZERO + END DO +* +* Do for each value of TRANS. +* + TRANS = TRANSS( ITRAN ) + IF( ITRAN.EQ.1 ) THEN + RCONDC = RCONDO + ELSE + RCONDC = RCONDI + END IF +* +* Restore the matrix A. +* + CALL CLACPY( 'Full', N, N, ASAV, LDA, A, LDA ) +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'CLARHS' + CALL CLARHS( PATH, XTYPE, 'Full', TRANS, N, N, KL, + $ KU, NRHS, A, LDA, XACT, LDA, B, LDA, + $ ISEED, INFO ) + XTYPE = 'C' + CALL CLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA ) +* + IF( NOFACT .AND. ITRAN.EQ.1 ) THEN +* +* --- Test CGESV --- +* +* Compute the LU factorization of the matrix and +* solve the system. +* + CALL CLACPY( 'Full', N, N, A, LDA, AFAC, LDA ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'CGESV ' + CALL CGESV( N, NRHS, AFAC, LDA, IWORK, X, LDA, + $ INFO ) +* +* Check error code from CGESV . +* + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'CGESV ', INFO, IZERO, + $ ' ', N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) + GOTO 50 + END IF +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL CGET01( N, N, A, LDA, AFAC, LDA, IWORK, + $ RWORK, RESULT( 1 ) ) + NT = 1 + IF( IZERO.EQ.0 ) THEN +* +* Compute residual of the computed solution. +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, WORK, + $ LDA ) + CALL CGET02( 'No transpose', N, N, NRHS, A, + $ LDA, X, LDA, WORK, LDA, RWORK, + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + NT = 3 + END IF +* +* Print information about the tests that did not +* pass the threshold. +* + DO 30 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 )'CGESV ', N, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 30 CONTINUE + NRUN = NRUN + NT + END IF +* +* --- Test CGESVX --- +* + IF( .NOT.PREFAC ) + $ CALL CLASET( 'Full', N, N, CMPLX( ZERO ), + $ CMPLX( ZERO ), AFAC, LDA ) + CALL CLASET( 'Full', N, NRHS, CMPLX( ZERO ), + $ CMPLX( ZERO ), X, LDA ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT = 'F' and +* EQUED = 'R', 'C', or 'B'. +* + CALL CLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND, + $ COLCND, AMAX, EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using CGESVX. +* + SRNAMT = 'CGESVX' + CALL CGESVX( FACT, TRANS, N, NRHS, A, LDA, AFAC, + $ LDA, IWORK, EQUED, S, S( N+1 ), B, + $ LDA, X, LDA, RCOND, RWORK, + $ RWORK( NRHS+1 ), WORK, + $ RWORK( 2*NRHS+1 ), INFO ) +* +* Check the error code from CGESVX. +* + IF( INFO.EQ.N+1 ) GOTO 50 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'CGESVX', INFO, IZERO, + $ FACT // TRANS, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GOTO 50 + END IF +* +* Compare RWORK(2*NRHS+1) from CGESVX with the +* computed reciprocal pivot growth factor RPVGRW +* + IF( INFO.NE.0 ) THEN + RPVGRW = CLANTR( 'M', 'U', 'N', INFO, INFO, + $ AFAC, LDA, RDUM ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = CLANGE( 'M', N, INFO, A, LDA, + $ RDUM ) / RPVGRW + END IF + ELSE + RPVGRW = CLANTR( 'M', 'U', 'N', N, N, AFAC, LDA, + $ RDUM ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = CLANGE( 'M', N, N, A, LDA, RDUM ) / + $ RPVGRW + END IF + END IF + RESULT( 7 ) = ABS( RPVGRW-RWORK( 2*NRHS+1 ) ) / + $ MAX( RWORK( 2*NRHS+1 ), RPVGRW ) / + $ SLAMCH( 'E' ) +* + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL CGET01( N, N, A, LDA, AFAC, LDA, IWORK, + $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* + IF( INFO.EQ.0 ) THEN + TRFCON = .FALSE. +* +* Compute residual of the computed solution. +* + CALL CLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, + $ LDA ) + CALL CGET02( TRANS, N, N, NRHS, ASAV, LDA, X, + $ LDA, WORK, LDA, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + ELSE + IF( ITRAN.EQ.1 ) THEN + ROLDC = ROLDO + ELSE + ROLDC = ROLDI + END IF + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, + $ ROLDC, RESULT( 3 ) ) + END IF +* +* Check the error bounds from iterative +* refinement. +* + CALL CGET07( TRANS, N, NRHS, ASAV, LDA, B, LDA, + $ X, LDA, XACT, LDA, RWORK, .TRUE., + $ RWORK( NRHS+1 ), RESULT( 4 ) ) + ELSE + TRFCON = .TRUE. + END IF +* +* Compare RCOND from CGESVX with the computed value +* in RCONDC. +* + RESULT( 6 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( .NOT.TRFCON ) THEN + DO 40 K = K1, NTESTS + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'CGESVX', + $ FACT, TRANS, N, EQUED, IMAT, K, + $ RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'CGESVX', + $ FACT, TRANS, N, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 40 CONTINUE + NRUN = NRUN + 7 - K1 + ELSE + IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) + $ THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'CGESVX', FACT, + $ TRANS, N, EQUED, IMAT, 1, RESULT( 1 ) + ELSE + WRITE( NOUT, FMT = 9998 )'CGESVX', FACT, + $ TRANS, N, IMAT, 1, RESULT( 1 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 6 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'CGESVX', FACT, + $ TRANS, N, EQUED, IMAT, 6, RESULT( 6 ) + ELSE + WRITE( NOUT, FMT = 9998 )'CGESVX', FACT, + $ TRANS, N, IMAT, 6, RESULT( 6 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'CGESVX', FACT, + $ TRANS, N, EQUED, IMAT, 7, RESULT( 7 ) + ELSE + WRITE( NOUT, FMT = 9998 )'CGESVX', FACT, + $ TRANS, N, IMAT, 7, RESULT( 7 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF +* + END IF +* +* --- Test CGESVXX --- +* +* Restore the matrices A and B. +* + + CALL CLACPY( 'Full', N, N, ASAV, LDA, A, LDA ) + CALL CLACPY( 'Full', N, NRHS, BSAV, LDA, B, LDA ) + + IF( .NOT.PREFAC ) + $ CALL CLASET( 'Full', N, N, ZERO, ZERO, AFAC, + $ LDA ) + CALL CLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT = 'F' and +* EQUED = 'R', 'C', or 'B'. +* + CALL CLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND, + $ COLCND, AMAX, EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using CGESVXX. +* + SRNAMT = 'CGESVXX' + N_ERR_BNDS = 3 + CALL CGESVXX( FACT, TRANS, N, NRHS, A, LDA, AFAC, + $ LDA, IWORK, EQUED, S, S( N+1 ), B, LDA, X, + $ LDA, RCOND, RPVGRW_SVXX, BERR, N_ERR_BNDS, + $ ERRBNDS_N, ERRBNDS_C, 0, ZERO, WORK, + $ RWORK, INFO ) +* +* Check the error code from CGESVXX. +* + IF( INFO.EQ.N+1 ) GOTO 50 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'CGESVXX', INFO, IZERO, + $ FACT // TRANS, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GOTO 50 + END IF +* +* Compare rpvgrw_svxx from CGESVXX with the computed +* reciprocal pivot growth factor RPVGRW +* + + IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN + RPVGRW = CLA_RPVGRW(N, INFO, A, LDA, AFAC, LDA) + ELSE + RPVGRW = CLA_RPVGRW(N, N, A, LDA, AFAC, LDA) + ENDIF + + RESULT( 7 ) = ABS( RPVGRW-rpvgrw_svxx ) / + $ MAX( rpvgrw_svxx, RPVGRW ) / + $ SLAMCH( 'E' ) +* + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL CGET01( N, N, A, LDA, AFAC, LDA, IWORK, + $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* + IF( INFO.EQ.0 ) THEN + TRFCON = .FALSE. +* +* Compute residual of the computed solution. +* + CALL CLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, + $ LDA ) + CALL CGET02( TRANS, N, N, NRHS, ASAV, LDA, X, + $ LDA, WORK, LDA, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + ELSE + IF( ITRAN.EQ.1 ) THEN + ROLDC = ROLDO + ELSE + ROLDC = ROLDI + END IF + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, + $ ROLDC, RESULT( 3 ) ) + END IF + ELSE + TRFCON = .TRUE. + END IF +* +* Compare RCOND from CGESVXX with the computed value +* in RCONDC. +* + RESULT( 6 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( .NOT.TRFCON ) THEN + DO 45 K = K1, NTESTS + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'CGESVXX', + $ FACT, TRANS, N, EQUED, IMAT, K, + $ RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'CGESVXX', + $ FACT, TRANS, N, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 45 CONTINUE + NRUN = NRUN + 7 - K1 + ELSE + IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) + $ THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'CGESVXX', FACT, + $ TRANS, N, EQUED, IMAT, 1, RESULT( 1 ) + ELSE + WRITE( NOUT, FMT = 9998 )'CGESVXX', FACT, + $ TRANS, N, IMAT, 1, RESULT( 1 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 6 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'CGESVXX', FACT, + $ TRANS, N, EQUED, IMAT, 6, RESULT( 6 ) + ELSE + WRITE( NOUT, FMT = 9998 )'CGESVXX', FACT, + $ TRANS, N, IMAT, 6, RESULT( 6 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'CGESVXX', FACT, + $ TRANS, N, EQUED, IMAT, 7, RESULT( 7 ) + ELSE + WRITE( NOUT, FMT = 9998 )'CGESVXX', FACT, + $ TRANS, N, IMAT, 7, RESULT( 7 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF +* + END IF +* + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + +* Test Error Bounds for CGESVXX + + CALL CEBCHVXX(THRESH, PATH) + + 9999 FORMAT( 1X, A, ', N =', I5, ', type ', I2, ', test(', I2, ') =', + $ G12.5 ) + 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5, + $ ', type ', I2, ', test(', I1, ')=', G12.5 ) + 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5, + $ ', EQUED=''', A1, ''', type ', I2, ', test(', I1, ')=', + $ G12.5 ) + RETURN +* +* End of CDRVGE +* + END diff --git a/TESTING/LIN/cdrvgt.f b/TESTING/LIN/cdrvgt.f index 84af7d9d..ace19204 100644 --- a/TESTING/LIN/cdrvgt.f +++ b/TESTING/LIN/cdrvgt.f @@ -105,7 +105,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cdrvhe.f b/TESTING/LIN/cdrvhe.f index 39737bea..cba64094 100644 --- a/TESTING/LIN/cdrvhe.f +++ b/TESTING/LIN/cdrvhe.f @@ -112,7 +112,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cdrvhp.f b/TESTING/LIN/cdrvhp.f index caeb3a70..2e449591 100644 --- a/TESTING/LIN/cdrvhp.f +++ b/TESTING/LIN/cdrvhp.f @@ -115,7 +115,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cdrvls.f b/TESTING/LIN/cdrvls.f index 2fec75d7..7b7b93c0 100644 --- a/TESTING/LIN/cdrvls.f +++ b/TESTING/LIN/cdrvls.f @@ -155,7 +155,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cdrvpb.f b/TESTING/LIN/cdrvpb.f index 647ff8cb..819dbca0 100644 --- a/TESTING/LIN/cdrvpb.f +++ b/TESTING/LIN/cdrvpb.f @@ -120,7 +120,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cdrvpo.f b/TESTING/LIN/cdrvpo.f index 9a6ac717..26e55af7 100644 --- a/TESTING/LIN/cdrvpo.f +++ b/TESTING/LIN/cdrvpo.f @@ -116,7 +116,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cdrvpox.f b/TESTING/LIN/cdrvpox.f new file mode 100644 index 00000000..08e8636f --- /dev/null +++ b/TESTING/LIN/cdrvpox.f @@ -0,0 +1,640 @@ + SUBROUTINE CDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, + $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, + $ RWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER NVAL( * ) + REAL RWORK( * ), S( * ) + COMPLEX A( * ), AFAC( * ), ASAV( * ), B( * ), + $ BSAV( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* Purpose +* ======= +* +* CDRVPO tests the driver routines CPOSV, -SVX, and -SVXX. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* NRHS (input) INTEGER +* The number of right hand side vectors to be generated for +* each linear system. +* +* THRESH (input) 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. +* +* TSTERR (input) LOGICAL +* Flag that indicates whether error exits are to be tested. +* +* NMAX (input) INTEGER +* The maximum value permitted for N, used in dimensioning the +* work arrays. +* +* A (workspace) COMPLEX array, dimension (NMAX*NMAX) +* +* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) +* +* ASAV (workspace) COMPLEX array, dimension (NMAX*NMAX) +* +* B (workspace) COMPLEX array, dimension (NMAX*NRHS) +* +* BSAV (workspace) COMPLEX array, dimension (NMAX*NRHS) +* +* X (workspace) COMPLEX array, dimension (NMAX*NRHS) +* +* XACT (workspace) COMPLEX array, dimension (NMAX*NRHS) +* +* S (workspace) REAL array, dimension (NMAX) +* +* WORK (workspace) COMPLEX array, dimension +* (NMAX*max(3,NRHS)) +* +* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 9 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 6 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, PREFAC, ZEROT + CHARACTER DIST, EQUED, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 PATH + INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, K, K1, KL, KU, LDA, MODE, N, NB, NBMIN, + $ NERRS, NFACT, NFAIL, NIMAT, NRUN, NT, + $ N_ERR_BNDS + REAL AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC, + $ ROLDC, SCOND, RPVGRW_SVXX +* .. +* .. Local Arrays .. + CHARACTER EQUEDS( 2 ), FACTS( 3 ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ), BERR( NRHS ), + $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + REAL CLANHE, SGET06 + EXTERNAL LSAME, CLANHE, SGET06 +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, CERRVX, CGET04, CLACPY, + $ CLAIPD, CLAQHE, CLARHS, CLASET, CLATB4, CLATMS, + $ CPOEQU, CPOSV, CPOSVX, CPOT01, CPOT02, CPOT05, + $ CPOTRF, CPOTRI, XLAENV, CPOSVXX +* .. +* .. 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 CMPLX, MAX +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FACTS / 'F', 'N', 'E' / + DATA EQUEDS / 'N', 'Y' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'PO' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 130 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 120 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 120 +* +* Skip types 3, 4, or 5 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 120 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 110 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with CLATB4 and generate a test matrix +* with CLATMS. +* + CALL CLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) +* + 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. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 110 + END IF +* +* For types 3-5, zero one row and column 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 + IOFF = ( IZERO-1 )*LDA +* +* Set row and column IZERO of A to 0. +* + IF( IUPLO.EQ.1 ) THEN + 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 + IZERO = 0 + END IF +* +* Set the imaginary part of the diagonals. +* + CALL CLAIPD( N, A, LDA+1, 0 ) +* +* Save a copy of the matrix A in ASAV. +* + CALL CLACPY( UPLO, N, N, A, LDA, ASAV, LDA ) +* + DO 100 IEQUED = 1, 2 + EQUED = EQUEDS( IEQUED ) + IF( IEQUED.EQ.1 ) THEN + NFACT = 3 + ELSE + NFACT = 1 + END IF +* + DO 90 IFACT = 1, NFACT + DO I = 1, NTESTS + RESULT (I) = ZERO + END DO + FACT = FACTS( IFACT ) + PREFAC = LSAME( FACT, 'F' ) + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) +* + IF( ZEROT ) THEN + IF( PREFAC ) + $ GO TO 90 + RCONDC = ZERO +* + ELSE IF( .NOT.LSAME( FACT, 'N' ) ) THEN +* +* Compute the condition number for comparison with +* the value returned by CPOSVX (FACT = 'N' reuses +* the condition number from the previous iteration +* with FACT = 'F'). +* + CALL CLACPY( UPLO, N, N, ASAV, LDA, AFAC, LDA ) + IF( EQUIL .OR. IEQUED.GT.1 ) THEN +* +* Compute row and column scale factors to +* equilibrate the matrix A. +* + CALL CPOEQU( N, AFAC, LDA, S, SCOND, AMAX, + $ INFO ) + IF( INFO.EQ.0 .AND. N.GT.0 ) THEN + IF( IEQUED.GT.1 ) + $ SCOND = ZERO +* +* Equilibrate the matrix. +* + CALL CLAQHE( UPLO, N, AFAC, LDA, S, SCOND, + $ AMAX, EQUED ) + END IF + END IF +* +* Save the condition number of the +* non-equilibrated system for use in CGET04. +* + IF( EQUIL ) + $ ROLDC = RCONDC +* +* Compute the 1-norm of A. +* + ANORM = CLANHE( '1', UPLO, N, AFAC, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL CPOTRF( UPLO, N, AFAC, LDA, INFO ) +* +* Form the inverse of A. +* + CALL CLACPY( UPLO, N, N, AFAC, LDA, A, LDA ) + CALL CPOTRI( UPLO, N, A, LDA, INFO ) +* +* Compute the 1-norm condition number of A. +* + AINVNM = CLANHE( '1', UPLO, N, A, LDA, RWORK ) + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Restore the matrix A. +* + CALL CLACPY( UPLO, N, N, ASAV, LDA, A, LDA ) +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'CLARHS' + CALL CLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, + $ ISEED, INFO ) + XTYPE = 'C' + CALL CLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA ) +* + IF( NOFACT ) THEN +* +* --- Test CPOSV --- +* +* Compute the L*L' or U'*U factorization of the +* matrix and solve the system. +* + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'CPOSV ' + CALL CPOSV( UPLO, N, NRHS, AFAC, LDA, X, LDA, + $ INFO ) +* +* Check error code from CPOSV . +* + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'CPOSV ', INFO, IZERO, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) + GO TO 70 + ELSE IF( INFO.NE.0 ) THEN + GO TO 70 + END IF +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL CPOT01( UPLO, N, A, LDA, AFAC, LDA, RWORK, + $ RESULT( 1 ) ) +* +* 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 ) ) +* +* 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 60 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 )'CPOSV ', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 60 CONTINUE + NRUN = NRUN + NT + 70 CONTINUE + END IF +* +* --- Test CPOSVX --- +* + IF( .NOT.PREFAC ) + $ CALL CLASET( UPLO, N, N, CMPLX( ZERO ), + $ CMPLX( ZERO ), AFAC, LDA ) + CALL CLASET( 'Full', N, NRHS, CMPLX( ZERO ), + $ CMPLX( ZERO ), X, LDA ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT='F' and +* EQUED='Y'. +* + CALL CLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, + $ EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using CPOSVX. +* + SRNAMT = 'CPOSVX' + CALL CPOSVX( FACT, UPLO, N, NRHS, A, LDA, AFAC, + $ LDA, EQUED, S, B, LDA, X, LDA, RCOND, + $ RWORK, RWORK( NRHS+1 ), WORK, + $ RWORK( 2*NRHS+1 ), INFO ) +* +* Check the error code from CPOSVX. +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'CPOSVX', INFO, IZERO, + $ FACT // UPLO, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GO TO 90 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL CPOT01( UPLO, N, A, LDA, AFAC, LDA, + $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* +* Compute residual of the computed solution. +* + CALL CLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, + $ LDA ) + CALL CPOT02( UPLO, N, NRHS, ASAV, LDA, X, LDA, + $ WORK, LDA, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + ELSE + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, + $ ROLDC, RESULT( 3 ) ) + END IF +* +* Check the error bounds from iterative +* refinement. +* + CALL CPOT05( UPLO, N, NRHS, ASAV, LDA, B, LDA, + $ X, LDA, XACT, LDA, RWORK, + $ RWORK( NRHS+1 ), RESULT( 4 ) ) + ELSE + K1 = 6 + END IF +* +* Compare RCOND from CPOSVX with the computed value +* in RCONDC. +* + RESULT( 6 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 80 K = K1, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'CPOSVX', FACT, + $ UPLO, N, EQUED, IMAT, K, RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'CPOSVX', FACT, + $ UPLO, N, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 80 CONTINUE + NRUN = NRUN + 7 - K1 +* +* --- Test CPOSVXX --- +* +* Restore the matrices A and B. +* + CALL CLACPY( 'Full', N, N, ASAV, LDA, A, LDA ) + CALL CLACPY( 'Full', N, NRHS, BSAV, LDA, B, LDA ) + + IF( .NOT.PREFAC ) + $ CALL CLASET( UPLO, N, N, CMPLX( ZERO ), + $ CMPLX( ZERO ), AFAC, LDA ) + CALL CLASET( 'Full', N, NRHS, CMPLX( ZERO ), + $ CMPLX( ZERO ), X, LDA ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT='F' and +* EQUED='Y'. +* + CALL CLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, + $ EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using CPOSVXX. +* + SRNAMT = 'CPOSVXX' + CALL CPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AFAC, + $ LDA, EQUED, S, B, LDA, X, + $ LDA, rcond, rpvgrw_svxx, berr, n_err_bnds, + $ errbnds_n, errbnds_c, 0, ZERO, WORK, + $ RWORK( 2*NRHS+1 ), INFO ) +* +* Check the error code from CPOSVXX. +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'CPOSVXX', INFO, IZERO, + $ FACT // UPLO, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GO TO 90 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL CPOT01( UPLO, N, A, LDA, AFAC, LDA, + $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* +* Compute residual of the computed solution. +* + CALL CLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, + $ LDA ) + CALL CPOT02( UPLO, N, NRHS, ASAV, LDA, X, LDA, + $ WORK, LDA, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + ELSE + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, + $ ROLDC, RESULT( 3 ) ) + END IF +* +* Check the error bounds from iterative +* refinement. +* + CALL CPOT05( UPLO, N, NRHS, ASAV, LDA, B, LDA, + $ X, LDA, XACT, LDA, RWORK, + $ RWORK( NRHS+1 ), RESULT( 4 ) ) + ELSE + K1 = 6 + END IF +* +* Compare RCOND from CPOSVXX with the computed value +* in RCONDC. +* + RESULT( 6 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 85 K = K1, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'CPOSVXX', FACT, + $ UPLO, N, EQUED, IMAT, K, RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'CPOSVXX', FACT, + $ UPLO, N, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 85 CONTINUE + NRUN = NRUN + 7 - K1 + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + +* Test Error Bounds for CGESVXX + + CALL CEBCHVXX(THRESH, PATH) + + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I1, + $ ', test(', I1, ')=', G12.5 ) + 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5, + $ ', type ', I1, ', test(', I1, ')=', G12.5 ) + 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5, + $ ', EQUED=''', A1, ''', type ', I1, ', test(', I1, ') =', + $ G12.5 ) + RETURN +* +* End of CDRVPO +* + END diff --git a/TESTING/LIN/cdrvpp.f b/TESTING/LIN/cdrvpp.f index f14f1722..957570de 100644 --- a/TESTING/LIN/cdrvpp.f +++ b/TESTING/LIN/cdrvpp.f @@ -116,7 +116,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cdrvpt.f b/TESTING/LIN/cdrvpt.f index 0a5dc7eb..d6972bfa 100644 --- a/TESTING/LIN/cdrvpt.f +++ b/TESTING/LIN/cdrvpt.f @@ -108,7 +108,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cdrvrf1.f b/TESTING/LIN/cdrvrf1.f new file mode 100644 index 00000000..03f1b01b --- /dev/null +++ b/TESTING/LIN/cdrvrf1.f @@ -0,0 +1,218 @@ + SUBROUTINE CDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER LDA, NN, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ) + REAL WORK( * ) + COMPLEX A( LDA, * ), ARF( * ) +* .. +* +* Purpose +* ======= +* +* CDRVRF1 tests the LAPACK RFP routines: +* CLANHF.F +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* THRESH (input) 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. +* +* A (workspace) COMPLEX array, dimension (LDA,NMAX) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* ARF (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2). +* +* WORK (workspace) COMPLEX array, dimension ( NMAX ) +* +* ===================================================================== +* .. +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 1 ) +* .. +* .. Local Scalars .. + CHARACTER UPLO, CFORM, NORM + INTEGER I, IFORM, IIN, IIT, INFO, INORM, IUPLO, J, N, + + NERRS, NFAIL, NRUN + REAL EPS, LARGE, NORMA, NORMARF, SMALL +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ), NORMS( 4 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + COMPLEX CLARND + REAL SLAMCH, CLANHE, CLANHF + EXTERNAL SLAMCH, CLARND, CLANHE, CLANHF +* .. +* .. External Subroutines .. + EXTERNAL CTRTTF +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'C' / + DATA NORMS / 'M', '1', 'I', 'F' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + INFO = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* + EPS = SLAMCH( 'Precision' ) + SMALL = SLAMCH( 'Safe minimum' ) + LARGE = ONE / SMALL + SMALL = SMALL * LDA * LDA + LARGE = LARGE / LDA / LDA +* + DO 130 IIN = 1, NN +* + N = NVAL( IIN ) +* + DO 120 IIT = 1, 3 +* +* IIT = 1 : random matrix +* IIT = 2 : random matrix scaled near underflow +* IIT = 3 : random matrix scaled near overflow +* + DO J = 1, N + DO I = 1, N + A( I, J) = CLARND( 4, ISEED ) + END DO + END DO +* + IF ( IIT.EQ.2 ) THEN + DO J = 1, N + DO I = 1, N + A( I, J) = A( I, J ) * LARGE + END DO + END DO + END IF +* + IF ( IIT.EQ.3 ) THEN + DO J = 1, N + DO I = 1, N + A( I, J) = A( I, J) * SMALL + END DO + END DO + END IF +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 110 IUPLO = 1, 2 +* + UPLO = UPLOS( IUPLO ) +* +* Do first for CFORM = 'N', then for CFORM = 'C' +* + DO 100 IFORM = 1, 2 +* + CFORM = FORMS( IFORM ) +* + SRNAMT = 'CTRTTF' + CALL CTRTTF( CFORM, UPLO, N, A, LDA, ARF, INFO ) +* +* Check error code from CTRTTF +* + IF( INFO.NE.0 ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9998 ) SRNAMT, UPLO, CFORM, N + NERRS = NERRS + 1 + GO TO 100 + END IF +* + DO 90 INORM = 1, 4 +* +* Check all four norms: 'M', '1', 'I', 'F' +* + NORM = NORMS( INORM ) + NORMARF = CLANHF( NORM, CFORM, UPLO, N, ARF, WORK ) + NORMA = CLANHE( NORM, UPLO, N, A, LDA, WORK ) +* + RESULT(1) = ( NORMA - NORMARF ) / NORMA / EPS + NRUN = NRUN + 1 +* + IF( RESULT(1).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9997 ) 'CLANHF', + + N, IIT, UPLO, CFORM, NORM, RESULT(1) + NFAIL = NFAIL + 1 + END IF + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE +* +* Print a summary of the results. +* + IF ( NFAIL.EQ.0 ) THEN + WRITE( NOUT, FMT = 9996 )'CLANHF', NRUN + ELSE + WRITE( NOUT, FMT = 9995 ) 'CLANHF', NFAIL, NRUN + END IF + IF ( NERRS.NE.0 ) THEN + WRITE( NOUT, FMT = 9994 ) NERRS, 'CLANHF' + END IF +* + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing CLANHF + + ***') + 9998 FORMAT( 1X, ' Error in ',A6,' with UPLO=''',A1,''', FORM=''', + + A1,''', N=',I5) + 9997 FORMAT( 1X, ' Failure in ',A6,' N=',I5,' TYPE=',I5,' UPLO=''', + + A1, ''', FORM =''',A1,''', NORM=''',A1,''', test=',G12.5) + 9996 FORMAT( 1X, 'All tests for ',A6,' auxiliary routine passed the ', + + 'threshold (',I5,' tests run)') + 9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5, + + ' tests failed to pass the threshold') + 9994 FORMAT( 26X, I5,' error message recorded (',A6,')') +* + RETURN +* +* End of CDRVRF1 +* + END diff --git a/TESTING/LIN/cdrvrf2.f b/TESTING/LIN/cdrvrf2.f new file mode 100644 index 00000000..c1c18ce1 --- /dev/null +++ b/TESTING/LIN/cdrvrf2.f @@ -0,0 +1,202 @@ + SUBROUTINE CDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER LDA, NN, NOUT +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ) + COMPLEX A( LDA, * ), ARF( * ), AP(*), ASAV( LDA, * ) +* .. +* +* Purpose +* ======= +* +* CDRVRF2 tests the LAPACK RFP convertion routines. +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* A (workspace) COMPLEX array, dimension (LDA,NMAX) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* ARF (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2). +* +* AP (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2). +* +* A2 (workspace) COMPLEX6 array, dimension (LDA,NMAX) +* +* ===================================================================== +* .. +* .. Local Scalars .. + LOGICAL LOWER, OK1, OK2 + CHARACTER UPLO, CFORM + INTEGER I, IFORM, IIN, INFO, IUPLO, J, N, + + NERRS, NRUN +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) +* .. +* .. External Functions .. + COMPLEX CLARND + EXTERNAL CLARND +* .. +* .. External Subroutines .. + EXTERNAL CTFTTR, CTFTTP, CTRTTF, CTRTTP, CTPTTR, CTPTTF +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'C' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NERRS = 0 + INFO = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* + DO 120 IIN = 1, NN +* + N = NVAL( IIN ) +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 110 IUPLO = 1, 2 +* + UPLO = UPLOS( IUPLO ) + LOWER = .TRUE. + IF ( IUPLO.EQ.1 ) LOWER = .FALSE. +* +* Do first for CFORM = 'N', then for CFORM = 'C' +* + DO 100 IFORM = 1, 2 +* + CFORM = FORMS( IFORM ) +* + NRUN = NRUN + 1 +* + DO J = 1, N + DO I = 1, N + A( I, J) = CLARND( 4, ISEED ) + END DO + END DO +* + SRNAMT = 'CTRTTF' + CALL CTRTTF( CFORM, UPLO, N, A, LDA, ARF, INFO ) +* + SRNAMT = 'CTFTTP' + CALL CTFTTP( CFORM, UPLO, N, ARF, AP, INFO ) +* + SRNAMT = 'CTPTTR' + CALL CTPTTR( UPLO, N, AP, ASAV, LDA, INFO ) +* + OK1 = .TRUE. + IF ( LOWER ) THEN + DO J = 1, N + DO I = J, N + IF ( A(I,J).NE.ASAV(I,J) ) THEN + OK1 = .FALSE. + END IF + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, J + IF ( A(I,J).NE.ASAV(I,J) ) THEN + OK1 = .FALSE. + END IF + END DO + END DO + END IF +* + NRUN = NRUN + 1 +* + SRNAMT = 'CTRTTP' + CALL CTRTTP( UPLO, N, A, LDA, AP, INFO ) +* + SRNAMT = 'CTPTTF' + CALL CTPTTF( CFORM, UPLO, N, AP, ARF, INFO ) +* + SRNAMT = 'CTFTTR' + CALL CTFTTR( CFORM, UPLO, N, ARF, ASAV, LDA, INFO ) +* + OK2 = .TRUE. + IF ( LOWER ) THEN + DO J = 1, N + DO I = J, N + IF ( A(I,J).NE.ASAV(I,J) ) THEN + OK2 = .FALSE. + END IF + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, J + IF ( A(I,J).NE.ASAV(I,J) ) THEN + OK2 = .FALSE. + END IF + END DO + END DO + END IF +* + IF (( .NOT.OK1 ).OR.( .NOT.OK2 )) THEN + IF( NERRS.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9998 ) N, UPLO, CFORM + NERRS = NERRS + 1 + END IF +* + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE +* +* Print a summary of the results. +* + IF ( NERRS.EQ.0 ) THEN + WRITE( NOUT, FMT = 9997 ) NRUN + ELSE + WRITE( NOUT, FMT = 9996 ) NERRS, NRUN + END IF +* + 9999 FORMAT( 1X, ' *** Error(s) while testing the RFP convertion', + + ' routines ***') + 9998 FORMAT( 1X, ' Error in RFP,convertion routines N=',I5, + + ' UPLO=''', A1, ''', FORM =''',A1,'''') + 9997 FORMAT( 1X, 'All tests for the RFP convertion routines passed (', + + I5,' tests run)') + 9996 FORMAT( 1X, 'RFP convertion routines:',I5,' out of ',I5, + + ' error message recorded') +* + RETURN +* +* End of CDRVRF2 +* + END diff --git a/TESTING/LIN/cdrvrf3.f b/TESTING/LIN/cdrvrf3.f new file mode 100644 index 00000000..55bad286 --- /dev/null +++ b/TESTING/LIN/cdrvrf3.f @@ -0,0 +1,310 @@ + SUBROUTINE CDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, + + S_WORK_CLANGE, C_WORK_CGEQRF, TAU ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER LDA, NN, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ) + REAL S_WORK_CLANGE( * ) + COMPLEX A( LDA, * ), ARF( * ), B1( LDA, * ), + + B2( LDA, * ) + COMPLEX C_WORK_CGEQRF( * ), TAU( * ) +* .. +* +* Purpose +* ======= +* +* CDRVRF3 tests the LAPACK RFP routines: +* CTFSM +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* THRESH (input) 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. +* +* A (workspace) COMPLEX*16 array, dimension (LDA,NMAX) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* ARF (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2). +* +* B1 (workspace) COMPLEX array, dimension (LDA,NMAX) +* +* B2 (workspace) COMPLEX array, dimension (LDA,NMAX) +* +* S_WORK_CLANGE (workspace) REAL array, dimension (NMAX) +* +* C_WORK_CGEQRF (workspace) COMPLEX array, dimension (NMAX) +* +* TAU (workspace) COMPLEX array, dimension (NMAX) +* +* ===================================================================== +* .. +* .. Parameters .. + COMPLEX ZERO, ONE + PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) , + + ONE = ( 1.0E+0, 0.0E+0 ) ) + INTEGER NTESTS + PARAMETER ( NTESTS = 1 ) +* .. +* .. Local Scalars .. + CHARACTER UPLO, CFORM, DIAG, TRANS, SIDE + INTEGER I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA, + + NFAIL, NRUN, ISIDE, IDIAG, IALPHA, ITRANS + COMPLEX ALPHA + REAL EPS +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ), + + DIAGS( 2 ), SIDES( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL SLAMCH, CLANGE + COMPLEX CLARND + EXTERNAL SLAMCH, CLARND, CLANGE +* .. +* .. External Subroutines .. + EXTERNAL CTRTTF, CGEQRF, CGEQLF, CTFSM, CTRSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'C' / + DATA SIDES / 'L', 'R' / + DATA TRANSS / 'N', 'C' / + DATA DIAGS / 'N', 'U' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NFAIL = 0 + INFO = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + EPS = SLAMCH( 'Precision' ) +* + DO 170 IIM = 1, NN +* + M = NVAL( IIM ) +* + DO 160 IIN = 1, NN +* + N = NVAL( IIN ) +* + DO 150 IFORM = 1, 2 +* + CFORM = FORMS( IFORM ) +* + DO 140 IUPLO = 1, 2 +* + UPLO = UPLOS( IUPLO ) +* + DO 130 ISIDE = 1, 2 +* + SIDE = SIDES( ISIDE ) +* + DO 120 ITRANS = 1, 2 +* + TRANS = TRANSS( ITRANS ) +* + DO 110 IDIAG = 1, 2 +* + DIAG = DIAGS( IDIAG ) +* + DO 100 IALPHA = 1, 3 +* + IF ( IALPHA.EQ. 1) THEN + ALPHA = ZERO + ELSE IF ( IALPHA.EQ. 1) THEN + ALPHA = ONE + ELSE + ALPHA = CLARND( 4, ISEED ) + END IF +* +* All the parameters are set: +* CFORM, SIDE, UPLO, TRANS, DIAG, M, N, +* and ALPHA +* READY TO TEST! +* + NRUN = NRUN + 1 +* + IF ( ISIDE.EQ.1 ) THEN +* +* The case ISIDE.EQ.1 is when SIDE.EQ.'L' +* -> A is M-by-M ( B is M-by-N ) +* + NA = M +* + ELSE +* +* The case ISIDE.EQ.2 is when SIDE.EQ.'R' +* -> A is N-by-N ( B is M-by-N ) +* + NA = N +* + END IF +* +* Generate A our NA--by--NA triangular +* matrix. +* Our test is based on forward error so we +* do want A to be well conditionned! To get +* a well-conditionned triangular matrix, we +* take the R factor of the QR/LQ factorization +* of a random matrix. +* + DO J = 1, NA + DO I = 1, NA + A( I, J) = CLARND( 4, ISEED ) + END DO + END DO +* + IF ( IUPLO.EQ.1 ) THEN +* +* The case IUPLO.EQ.1 is when SIDE.EQ.'U' +* -> QR factorization. +* + SRNAMT = 'CGEQRF' + CALL CGEQRF( NA, NA, A, LDA, TAU, + + C_WORK_CGEQRF, LDA, + + INFO ) + ELSE +* +* The case IUPLO.EQ.2 is when SIDE.EQ.'L' +* -> QL factorization. +* + SRNAMT = 'CGELQF' + CALL CGELQF( NA, NA, A, LDA, TAU, + + C_WORK_CGEQRF, LDA, + + INFO ) + END IF +* +* After the QR factorization, the diagonal +* of A is made of real numbers, we multiply +* by a random complex number of absolute +* value 1.0E+00. +* + DO J = 1, NA + A( J, J) = A(J,J) * CLARND( 5, ISEED ) + END DO +* +* Store a copy of A in RFP format (in ARF). +* + SRNAMT = 'CTRTTF' + CALL CTRTTF( CFORM, UPLO, NA, A, LDA, ARF, + + INFO ) +* +* Generate B1 our M--by--N right-hand side +* and store a copy in B2. +* + DO J = 1, N + DO I = 1, M + B1( I, J) = CLARND( 4, ISEED ) + B2( I, J) = B1( I, J) + END DO + END DO +* +* Solve op( A ) X = B or X op( A ) = B +* with CTRSM +* + SRNAMT = 'CTRSM' + CALL CTRSM( SIDE, UPLO, TRANS, DIAG, M, N, + + ALPHA, A, LDA, B1, LDA ) +* +* Solve op( A ) X = B or X op( A ) = B +* with CTFSM +* + SRNAMT = 'CTFSM' + CALL CTFSM( CFORM, SIDE, UPLO, TRANS, + + DIAG, M, N, ALPHA, ARF, B2, + + LDA ) +* +* Check that the result agrees. +* + DO J = 1, N + DO I = 1, M + B1( I, J) = B2( I, J ) - B1( I, J ) + END DO + END DO +* + RESULT(1) = CLANGE( 'I', M, N, B1, LDA, + + S_WORK_CLANGE ) +* + RESULT(1) = RESULT(1) / SQRT( EPS ) + + / MAX ( MAX( M, N), 1 ) +* + IF( RESULT(1).GE.THRESH ) THEN + IF( NFAIL.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9997 ) 'CTFSM', + + CFORM, SIDE, UPLO, TRANS, DIAG, M, + + N, RESULT(1) + NFAIL = NFAIL + 1 + END IF +* + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE +* +* Print a summary of the results. +* + IF ( NFAIL.EQ.0 ) THEN + WRITE( NOUT, FMT = 9996 ) 'CTFSM', NRUN + ELSE + WRITE( NOUT, FMT = 9995 ) 'CTFSM', NFAIL, NRUN + END IF +* + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing CTFSM + + ***') + 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', + + ' SIDE=''',A1,''',',' UPLO=''',A1,''',',' TRANS=''',A1,''',', + + ' DIAG=''',A1,''',',' M=',I3,', N =', I3,', test=',G12.5) + 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ', + + 'threshold (',I5,' tests run)') + 9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5, + + ' tests failed to pass the threshold') +* + RETURN +* +* End of CDRVRF3 +* + END diff --git a/TESTING/LIN/cdrvrf4.f b/TESTING/LIN/cdrvrf4.f new file mode 100644 index 00000000..5ee83a98 --- /dev/null +++ b/TESTING/LIN/cdrvrf4.f @@ -0,0 +1,283 @@ + SUBROUTINE CDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, + + LDA, S_WORK_CLANGE ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER LDA, LDC, NN, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ) + REAL S_WORK_CLANGE( * ) + COMPLEX A( LDA, * ), C1( LDC, * ), C2( LDC, *), + + CRF( * ) +* .. +* +* Purpose +* ======= +* +* CDRVRF4 tests the LAPACK RFP routines: +* CHFRK +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* THRESH (input) 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. +* +* C1 (workspace) COMPLEX array, dimension (LDC,NMAX) +* +* C2 (workspace) COMPLEX array, dimension (LDC,NMAX) +* +* LDC (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* CRF (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2). +* +* A (workspace) COMPLEX array, dimension (LDA,NMAX) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* S_WORK_CLANGE (workspace) REAL array, dimension (NMAX) +* +* ===================================================================== +* .. +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 1 ) +* .. +* .. Local Scalars .. + CHARACTER UPLO, CFORM, TRANS + INTEGER I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N, + + NFAIL, NRUN, IALPHA, ITRANS + REAL ALPHA, BETA, EPS, NORMA, NORMC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL SLAMCH, SLARND, CLANGE + COMPLEX CLARND + EXTERNAL SLAMCH, SLARND, CLANGE, CLARND +* .. +* .. External Subroutines .. + EXTERNAL CHERK, CHFRK, CTFTTR, CTRTTF +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'C' / + DATA TRANSS / 'N', 'C' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NFAIL = 0 + INFO = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + EPS = SLAMCH( 'Precision' ) +* + DO 150 IIN = 1, NN +* + N = NVAL( IIN ) +* + DO 140 IIK = 1, NN +* + K = NVAL( IIN ) +* + DO 130 IFORM = 1, 2 +* + CFORM = FORMS( IFORM ) +* + DO 120 IUPLO = 1, 2 +* + UPLO = UPLOS( IUPLO ) +* + DO 110 ITRANS = 1, 2 +* + TRANS = TRANSS( ITRANS ) +* + DO 100 IALPHA = 1, 4 +* + IF ( IALPHA.EQ. 1) THEN + ALPHA = ZERO + BETA = ZERO + ELSE IF ( IALPHA.EQ. 1) THEN + ALPHA = ONE + BETA = ZERO + ELSE IF ( IALPHA.EQ. 1) THEN + ALPHA = ZERO + BETA = ONE + ELSE + ALPHA = SLARND( 2, ISEED ) + BETA = SLARND( 2, ISEED ) + END IF +* +* All the parameters are set: +* CFORM, UPLO, TRANS, M, N, +* ALPHA, and BETA +* READY TO TEST! +* + NRUN = NRUN + 1 +* + IF ( ITRANS.EQ.1 ) THEN +* +* In this case we are NOTRANS, so A is N-by-K +* + DO J = 1, K + DO I = 1, N + A( I, J) = CLARND( 4, ISEED ) + END DO + END DO +* + NORMA = CLANGE( 'I', N, K, A, LDA, + + S_WORK_CLANGE ) +* + ELSE +* +* In this case we are TRANS, so A is K-by-N +* + DO J = 1,N + DO I = 1, K + A( I, J) = CLARND( 4, ISEED ) + END DO + END DO +* + NORMA = CLANGE( 'I', K, N, A, LDA, + + S_WORK_CLANGE ) +* + END IF +* +* +* Generate C1 our N--by--N Hermitian matrix. +* Make sure C2 has the same upper/lower part, +* (the one that we do not touch), so +* copy the initial C1 in C2 in it. +* + DO J = 1, N + DO I = 1, N + C1( I, J) = CLARND( 4, ISEED ) + C2(I,J) = C1(I,J) + END DO + END DO +* +* (See comment later on for why we use CLANGE and +* not CLANHE for C1.) +* + NORMC = CLANGE( 'I', N, N, C1, LDC, + + S_WORK_CLANGE ) +* + SRNAMT = 'CTRTTF' + CALL CTRTTF( CFORM, UPLO, N, C1, LDC, CRF, + + INFO ) +* +* call zherk the BLAS routine -> gives C1 +* + SRNAMT = 'CHERK ' + CALL CHERK( UPLO, TRANS, N, K, ALPHA, A, LDA, + + BETA, C1, LDC ) +* +* call zhfrk the RFP routine -> gives CRF +* + SRNAMT = 'CHFRK ' + CALL CHFRK( CFORM, UPLO, TRANS, N, K, ALPHA, A, + + LDA, BETA, CRF ) +* +* convert CRF in full format -> gives C2 +* + SRNAMT = 'CTFTTR' + CALL CTFTTR( CFORM, UPLO, N, CRF, C2, LDC, + + INFO ) +* +* compare C1 and C2 +* + DO J = 1, N + DO I = 1, N + C1(I,J) = C1(I,J)-C2(I,J) + END DO + END DO +* +* Yes, C1 is Hermitian so we could call CLANHE, +* but we want to check the upper part that is +* supposed to be unchanged and the diagonal that +* is supposed to be real -> CLANGE +* + RESULT(1) = CLANGE( 'I', N, N, C1, LDC, + + S_WORK_CLANGE ) + RESULT(1) = RESULT(1) + + / MAX( ABS( ALPHA ) * NORMA * NORMA + + + ABS( BETA ) * NORMC, ONE ) + + / MAX( N , 1 ) / EPS +* + IF( RESULT(1).GE.THRESH ) THEN + IF( NFAIL.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9997 ) 'CHFRK', + + CFORM, UPLO, TRANS, N, K, RESULT(1) + NFAIL = NFAIL + 1 + END IF +* + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE +* +* Print a summary of the results. +* + IF ( NFAIL.EQ.0 ) THEN + WRITE( NOUT, FMT = 9996 ) 'CHFRK', NRUN + ELSE + WRITE( NOUT, FMT = 9995 ) 'CHFRK', NFAIL, NRUN + END IF +* + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing CHFRK + + ***') + 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', + + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3, + + ', test=',G12.5) + 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ', + + 'threshold (',I5,' tests run)') + 9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5, + + ' tests failed to pass the threshold') +* + RETURN +* +* End of CDRVRF4 +* + END diff --git a/TESTING/LIN/cdrvrfp.f b/TESTING/LIN/cdrvrfp.f new file mode 100644 index 00000000..3dd75d3a --- /dev/null +++ b/TESTING/LIN/cdrvrfp.f @@ -0,0 +1,452 @@ + SUBROUTINE CDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, + + THRESH, A, ASAV, AFAC, AINV, B, + + BSAV, XACT, X, ARF, ARFINV, + + C_WORK_CLATMS, C_WORK_CPOT01, C_WORK_CPOT02, + + C_WORK_CPOT03, S_WORK_CLATMS, S_WORK_CLANHE, + + S_WORK_CPOT02, S_WORK_CPOT03 ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER NN, NNS, NNT, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ), NSVAL( NNS ), NTVAL( NNT ) + COMPLEX A( * ) + COMPLEX AINV( * ) + COMPLEX ASAV( * ) + COMPLEX B( * ) + COMPLEX BSAV( * ) + COMPLEX AFAC( * ) + COMPLEX ARF( * ) + COMPLEX ARFINV( * ) + COMPLEX XACT( * ) + COMPLEX X( * ) + COMPLEX C_WORK_CLATMS( * ) + COMPLEX C_WORK_CPOT01( * ) + COMPLEX C_WORK_CPOT02( * ) + COMPLEX C_WORK_CPOT03( * ) + REAL S_WORK_CLATMS( * ) + REAL S_WORK_CLANHE( * ) + REAL S_WORK_CPOT02( * ) + REAL S_WORK_CPOT03( * ) +* .. +* +* Purpose +* ======= +* +* CDRVRFP tests the LAPACK RFP routines: +* CPFTRF, CPFTRS, and CPFTRI. +* +* This testing routine follow the same tests as CDRVPO (test for the full +* format Symmetric Positive Definite solver). +* +* The tests are performed in Full Format, convertion back and forth from +* full format to RFP format are performed using the routines CTRTTF and +* CTFTTR. +* +* First, a specific matrix A of size N is created. There is nine types of +* different matrixes possible. +* 1. Diagonal 6. Random, CNDNUM = sqrt(0.1/EPS) +* 2. Random, CNDNUM = 2 7. Random, CNDNUM = 0.1/EPS +* *3. First row and column zero 8. Scaled near underflow +* *4. Last row and column zero 9. Scaled near overflow +* *5. Middle row and column zero +* (* - tests error exits from CPFTRF, no test ratios are computed) +* A solution XACT of size N-by-NRHS is created and the associated right +* hand side B as well. Then CPFTRF is called to compute L (or U), the +* Cholesky factor of A. Then L (or U) is used to solve the linear system +* of equations AX = B. This gives X. Then L (or U) is used to compute the +* inverse of A, AINV. The following four tests are then performed: +* (1) norm( L*L' - A ) / ( N * norm(A) * EPS ) or +* norm( U'*U - A ) / ( N * norm(A) * EPS ), +* (2) norm(B - A*X) / ( norm(A) * norm(X) * EPS ), +* (3) norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), +* (4) ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ), +* where EPS is the machine precision, RCOND the condition number of A, and +* norm( . ) the 1-norm for (1,2,3) and the inf-norm for (4). +* Errors occur when INFO parameter is not as expected. Failures occur when +* a test ratios is greater than THRES. +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* NNS (input) INTEGER +* The number of values of NRHS contained in the vector NSVAL. +* +* NSVAL (input) INTEGER array, dimension (NNS) +* The values of the number of right-hand sides NRHS. +* +* NNT (input) INTEGER +* The number of values of MATRIX TYPE contained in the vector NTVAL. +* +* NTVAL (input) INTEGER array, dimension (NNT) +* The values of matrix type (between 0 and 9 for PO/PP/PF matrices). +* +* THRESH (input) 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. +* +* A (workspace) COMPLEX array, dimension (NMAX*NMAX) +* +* ASAV (workspace) COMPLEX array, dimension (NMAX*NMAX) +* +* AFAC (workspace) COMPLEX array, dimension (NMAX*NMAX) +* +* AINV (workspace) COMPLEX array, dimension (NMAX*NMAX) +* +* B (workspace) COMPLEX array, dimension (NMAX*MAXRHS) +* +* BSAV (workspace) COMPLEX array, dimension (NMAX*MAXRHS) +* +* XACT (workspace) COMPLEX array, dimension (NMAX*MAXRHS) +* +* X (workspace) COMPLEX array, dimension (NMAX*MAXRHS) +* +* ARF (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2) +* +* ARFINV (workspace) COMPLEX array, dimension ((NMAX*(NMAX+1))/2) +* +* C_WORK_CLATMS (workspace) COMPLEX array, dimension ( 3*NMAX ) +* +* C_WORK_CPOT01 (workspace) COMPLEX array, dimension ( NMAX ) +* +* C_WORK_CPOT02 (workspace) COMPLEX array, dimension ( NMAX*MAXRHS ) +* +* C_WORK_CPOT03 (workspace) COMPLEX array, dimension ( NMAX*NMAX ) +* +* S_WORK_CLATMS (workspace) REAL array, dimension ( NMAX ) +* +* S_WORK_CLANHE (workspace) REAL array, dimension ( NMAX ) +* +* S_WORK_CPOT02 (workspace) REAL array, dimension ( NMAX ) +* +* S_WORK_CPOT03 (workspace) REAL array, dimension ( NMAX ) +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 4 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + INTEGER I, INFO, IUPLO, LDA, LDB, IMAT, NERRS, NFAIL, + + NRHS, NRUN, IZERO, IOFF, K, NT, N, IFORM, IIN, + + IIT, IIS + CHARACTER DIST, CTYPE, UPLO, CFORM + INTEGER KL, KU, MODE + REAL ANORM, AINVNM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL CLANHE + EXTERNAL CLANHE +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, CGET04, CTFTTR, CLACPY, + + CLAIPD, CLARHS, CLATB4, CLATMS, CPFTRI, CPFTRF, + + CPFTRS, CPOT01, CPOT02, CPOT03, CPOTRI, CPOTRF, + + CTRTTF +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'C' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* + DO 130 IIN = 1, NN +* + N = NVAL( IIN ) + LDA = MAX( N, 1 ) + LDB = MAX( N, 1 ) +* + DO 980 IIS = 1, NNS +* + NRHS = NSVAL( IIS ) +* + DO 120 IIT = 1, NNT +* + IMAT = NTVAL( IIT ) +* +* If N.EQ.0, only consider the first type +* + IF( N.EQ.0 .AND. IIT.GT.1 ) GO TO 120 +* +* Skip types 3, 4, or 5 if the matrix size is too small. +* + IF( IMAT.EQ.4 .AND. N.LE.1 ) GO TO 120 + IF( IMAT.EQ.5 .AND. N.LE.2 ) GO TO 120 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 110 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Do first for CFORM = 'N', then for CFORM = 'C' +* + DO 100 IFORM = 1, 2 + CFORM = FORMS( IFORM ) +* +* Set up parameters with CLATB4 and generate a test +* matrix with CLATMS. +* + CALL CLATB4( 'CPO', IMAT, N, N, CTYPE, KL, KU, + + ANORM, MODE, CNDNUM, DIST ) +* + SRNAMT = 'CLATMS' + CALL CLATMS( N, N, DIST, ISEED, CTYPE, + + S_WORK_CLATMS, + + MODE, CNDNUM, ANORM, KL, KU, UPLO, A, + + LDA, C_WORK_CLATMS, INFO ) +* +* Check error code from CLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( 'CPF', 'CLATMS', INFO, 0, UPLO, N, + + N, -1, -1, -1, IIT, NFAIL, NERRS, + + NOUT ) + GO TO 100 + END IF +* +* For types 3-5, zero one row and column of the matrix to +* test that INFO is returned correctly. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 + IF( ZEROT ) THEN + IF( IIT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IIT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF + IOFF = ( IZERO-1 )*LDA +* +* Set row and column IZERO of A to 0. +* + IF( IUPLO.EQ.1 ) THEN + 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 + IZERO = 0 + END IF +* +* Set the imaginary part of the diagonals. +* + CALL CLAIPD( N, A, LDA+1, 0 ) +* +* Save a copy of the matrix A in ASAV. +* + CALL CLACPY( UPLO, N, N, A, LDA, ASAV, LDA ) +* +* Compute the condition number of A (RCONDC). +* + IF( ZEROT ) THEN + RCONDC = ZERO + ELSE +* +* Compute the 1-norm of A. +* + ANORM = CLANHE( '1', UPLO, N, A, LDA, + + S_WORK_CLANHE ) +* +* Factor the matrix A. +* + CALL CPOTRF( UPLO, N, A, LDA, INFO ) +* +* Form the inverse of A. +* + CALL CPOTRI( UPLO, N, A, LDA, INFO ) +* +* Compute the 1-norm condition number of A. +* + AINVNM = CLANHE( '1', UPLO, N, A, LDA, + + S_WORK_CLANHE ) + RCONDC = ( ONE / ANORM ) / AINVNM +* +* Restore the matrix A. +* + CALL CLACPY( UPLO, N, N, ASAV, LDA, A, LDA ) +* + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'CLARHS' + CALL CLARHS( 'CPO', 'N', UPLO, ' ', N, N, KL, KU, + + NRHS, A, LDA, XACT, LDA, B, LDA, + + ISEED, INFO ) + CALL CLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA ) +* +* Compute the L*L' or U'*U factorization of the +* matrix and solve the system. +* + CALL CLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL CLACPY( 'Full', N, NRHS, B, LDB, X, LDB ) +* + SRNAMT = 'CTRTTF' + CALL CTRTTF( CFORM, UPLO, N, AFAC, LDA, ARF, INFO ) + SRNAMT = 'CPFTRF' + CALL CPFTRF( CFORM, UPLO, N, ARF, INFO ) +* +* Check error code from CPFTRF. +* + IF( INFO.NE.IZERO ) THEN +* +* LANGOU: there is a small hick here: IZERO should +* always be INFO however if INFO is ZERO, ALAERH does not +* complain. +* + CALL ALAERH( 'CPF', 'CPFSV ', INFO, IZERO, + + UPLO, N, N, -1, -1, NRHS, IIT, + + NFAIL, NERRS, NOUT ) + GO TO 100 + END IF +* +* Skip the tests if INFO is not 0. +* + IF( INFO.NE.0 ) THEN + GO TO 100 + END IF +* + SRNAMT = 'CPFTRS' + CALL CPFTRS( CFORM, UPLO, N, NRHS, ARF, X, LDB, + + INFO ) +* + SRNAMT = 'CTFTTR' + CALL CTFTTR( CFORM, UPLO, N, ARF, AFAC, LDA, INFO ) +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL CLACPY( UPLO, N, N, AFAC, LDA, ASAV, LDA ) + CALL CPOT01( UPLO, N, A, LDA, AFAC, LDA, + + C_WORK_CPOT01, RESULT( 1 ) ) + CALL CLACPY( UPLO, N, N, ASAV, LDA, AFAC, LDA ) +* +* Form the inverse and compute the residual. +* + IF(MOD(N,2).EQ.0)THEN + CALL CLACPY( 'A', N+1, N/2, ARF, N+1, ARFINV, + + N+1 ) + ELSE + CALL CLACPY( 'A', N, (N+1)/2, ARF, N, ARFINV, + + N ) + END IF +* + SRNAMT = 'CPFTRI' + CALL CPFTRI( CFORM, UPLO, N, ARFINV , INFO ) +* + SRNAMT = 'CTFTTR' + CALL CTFTTR( CFORM, UPLO, N, ARFINV, AINV, LDA, + + INFO ) +* +* Check error code from CPFTRI. +* + IF( INFO.NE.0 ) + + CALL ALAERH( 'CPO', 'CPFTRI', INFO, 0, UPLO, N, + + N, -1, -1, -1, IMAT, NFAIL, NERRS, + + NOUT ) +* + CALL CPOT03( UPLO, N, A, LDA, AINV, LDA, + + C_WORK_CPOT03, LDA, S_WORK_CPOT03, + + RCONDC, RESULT( 2 ) ) +* +* Compute residual of the computed solution. +* + CALL CLACPY( 'Full', N, NRHS, B, LDA, + + C_WORK_CPOT02, LDA ) + CALL CPOT02( UPLO, N, NRHS, A, LDA, X, LDA, + + C_WORK_CPOT02, LDA, S_WORK_CPOT02, + + RESULT( 3 ) ) +* +* Check solution from generated exact solution. +* + CALL CGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + + RESULT( 4 ) ) + NT = 4 +* +* Print information about the tests that did not +* pass the threshold. +* + DO 60 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + + CALL ALADHD( NOUT, 'CPF' ) + WRITE( NOUT, FMT = 9999 )'CPFSV ', UPLO, + + N, IIT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 60 CONTINUE + NRUN = NRUN + NT + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 980 CONTINUE + 130 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( 'CPF', NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A6, ', UPLO=''', A1, ''', N =', I5, ', type ', I1, + + ', test(', I1, ')=', G12.5 ) +* + RETURN +* +* End of CDRVRFP +* + END diff --git a/TESTING/LIN/cdrvsp.f b/TESTING/LIN/cdrvsp.f index 7c55929b..1c43f494 100644 --- a/TESTING/LIN/cdrvsp.f +++ b/TESTING/LIN/cdrvsp.f @@ -115,7 +115,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cdrvsy.f b/TESTING/LIN/cdrvsy.f index 91cb592a..e6c07d1e 100644 --- a/TESTING/LIN/cdrvsy.f +++ b/TESTING/LIN/cdrvsy.f @@ -112,7 +112,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cebchvxx.f b/TESTING/LIN/cebchvxx.f new file mode 100644 index 00000000..5fb0d364 --- /dev/null +++ b/TESTING/LIN/cebchvxx.f @@ -0,0 +1,474 @@ + SUBROUTINE CEBCHVXX( THRESH, PATH ) + IMPLICIT NONE +* .. Scalar Arguments .. + REAL THRESH + CHARACTER*3 PATH +* +* Purpose +* ====== +* +* CEBCHVXX will run CGESVXX on a series of Hilbert matrices and then +* compare the error bounds returned by CGESVXX to see if the returned +* answer indeed falls within those bounds. +* +* Eight test ratios will be computed. The tests will pass if they are .LT. +* THRESH. There are two cases that are determined by 1 / (SQRT( N ) * EPS). +* If that value is .LE. to the component wise reciprocal condition number, +* it uses the guaranteed case, other wise it uses the unguaranteed case. +* +* Test ratios: +* Let Xc be X_computed and Xt be X_truth. +* The norm used is the infinity norm. + +* Let A be the guaranteed case and B be the unguaranteed case. +* +* 1. Normwise guaranteed forward error bound. +* A: norm ( abs( Xc - Xt ) / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ) and +* ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N),10) * EPS. +* If these conditions are met, the test ratio is set to be +* ERRBND( *, nwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. +* B: For this case, CGESVXX should just return 1. If it is less than +* one, treat it the same as in 1A. Otherwise it fails. (Set test +* ratio to ERRBND( *, nwise_i, bnd_i ) * THRESH?) +* +* 2. Componentwise guaranteed forward error bound. +* A: norm ( abs( Xc(j) - Xt(j) ) ) / norm (Xt(j)) .LE. ERRBND( *, cwise_i, bnd_i ) +* for all j .AND. ERRBND( *, cwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS. +* If these conditions are met, the test ratio is set to be +* ERRBND( *, cwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. +* B: Same as normwise test ratio. +* +* 3. Backwards error. +* A: The test ratio is set to BERR/EPS. +* B: Same test ratio. +* +* 4. Reciprocal condition number. +* A: A condition number is computed with Xt and compared with the one +* returned from CGESVXX. Let RCONDc be the RCOND returned by CGESVXX +* and RCONDt be the RCOND from the truth value. Test ratio is set to +* MAX(RCONDc/RCONDt, RCONDt/RCONDc). +* B: Test ratio is set to 1 / (EPS * RCONDc). +* +* 5. Reciprocal normwise condition number. +* A: The test ratio is set to +* MAX(ERRBND( *, nwise_i, cond_i ) / NCOND, NCOND / ERRBND( *, nwise_i, cond_i )). +* B: Test ratio is set to 1 / (EPS * ERRBND( *, nwise_i, cond_i )). +* +* 6. Reciprocal componentwise condition number. +* A: Test ratio is set to +* MAX(ERRBND( *, cwise_i, cond_i ) / CCOND, CCOND / ERRBND( *, cwise_i, cond_i )). +* B: Test ratio is set to 1 / (EPS * ERRBND( *, cwise_i, cond_i )). +* +* .. Parameters .. +* NMAX is determined by the largest number in the inverse of the hilbert +* matrix. Precision is exhausted when the largest entry in it is greater +* than 2 to the power of the number of bits in the fraction of the data +* type used plus one, which is 24 for single precision. +* NMAX should be 6 for single and 11 for double. + + INTEGER NMAX, NPARAMS, NERRBND, NTESTS, KL, KU + PARAMETER (NMAX = 6, NPARAMS = 2, NERRBND = 3, + $ NTESTS = 6) + +* .. Local Scalars .. + INTEGER N, NRHS, INFO, I ,J, k, NFAIL, LDA, + $ N_AUX_TESTS, LDAB, LDAFB + CHARACTER FACT, TRANS, UPLO, EQUED + CHARACTER*2 C2 + CHARACTER(3) NGUAR, CGUAR + LOGICAL printed_guide + REAL NCOND, CCOND, M, NORMDIF, NORMT, RCOND, + $ RNORM, RINORM, SUMR, SUMRI, EPS, + $ BERR(NMAX), RPVGRW, ORCOND, + $ CWISE_ERR, NWISE_ERR, CWISE_BND, NWISE_BND, + $ CWISE_RCOND, NWISE_RCOND, + $ CONDTHRESH, ERRTHRESH + COMPLEX ZDUM + +* .. Local Arrays .. + REAL TSTRAT(NTESTS), RINV(NMAX), PARAMS(NPARAMS), + $ S(NMAX), R(NMAX),C(NMAX),RWORK(3*NMAX), + $ DIFF(NMAX, NMAX), + $ ERRBND_N(NMAX*3), ERRBND_C(NMAX*3) + INTEGER IPIV(NMAX) + COMPLEX A(NMAX,NMAX),INVHILB(NMAX,NMAX),X(NMAX,NMAX), + $ WORK(NMAX*3*5), AF(NMAX, NMAX),B(NMAX, NMAX), + $ ACOPY(NMAX, NMAX), + $ AB( (NMAX-1)+(NMAX-1)+1, NMAX ), + $ ABCOPY( (NMAX-1)+(NMAX-1)+1, NMAX ), + $ AFB( 2*(NMAX-1)+(NMAX-1)+1, NMAX ) + +* .. External Functions .. + REAL SLAMCH + +* .. External Subroutines .. + EXTERNAL CLAHILB, CGESVXX, CSYSVXX, CPOSVXX, + $ CGBSVXX, SLACPY, LSAMEN + LOGICAL LSAMEN + +* .. Intrinsic Functions .. + INTRINSIC SQRT, MAX, ABS, REAL, AIMAG + +* .. Statement Functions .. + REAL CABS1 +* .. +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( REAL( ZDUM ) ) + ABS( AIMAG( ZDUM ) ) + +* .. Parameters .. + INTEGER NWISE_I, CWISE_I + PARAMETER (NWISE_I = 1, CWISE_I = 1) + INTEGER BND_I, COND_I + PARAMETER (BND_I = 2, COND_I = 3) + +* Create the loop to test out the Hilbert matrices + + FACT = 'E' + UPLO = 'U' + TRANS = 'N' + EQUED = 'N' + EPS = SLAMCH('Epsilon') + NFAIL = 0 + N_AUX_TESTS = 0 + LDA = NMAX + LDAB = (NMAX-1)+(NMAX-1)+1 + LDAFB = 2*(NMAX-1)+(NMAX-1)+1 + C2 = PATH( 2: 3 ) + +* Main loop to test the different Hilbert Matrices. + + printed_guide = .false. + + DO N = 1 , NMAX + PARAMS(1) = -1 + PARAMS(2) = -1 + + KL = N-1 + KU = N-1 + NRHS = n + M = MAX(SQRT(REAL(N)), 10.0) + +* Generate the Hilbert matrix, its inverse, and the +* right hand side, all scaled by the LCM(1,..,2N-1). + CALL CLAHILB(N, N, A, LDA, INVHILB, LDA, B, + $ LDA, WORK, INFO, PATH) + +* Copy A into ACOPY. + CALL CLACPY('ALL', N, N, A, NMAX, ACOPY, NMAX) + +* Store A in band format for GB tests + DO J = 1, N + DO I = 1, KL+KU+1 + AB( I, J ) = (0.0E+0,0.0E+0) + END DO + END DO + DO J = 1, N + DO I = MAX( 1, J-KU ), MIN( N, J+KL ) + AB( KU+1+I-J, J ) = A( I, J ) + END DO + END DO + +* Copy AB into ABCOPY. + DO J = 1, N + DO I = 1, KL+KU+1 + ABCOPY( I, J ) = (0.0E+0,0.0E+0) + END DO + END DO + CALL DLACPY('ALL', KL+KU+1, N, AB, LDAB, ABCOPY, LDAB) + +* Call C**SVXX with default PARAMS and N_ERR_BND = 3. + IF ( LSAMEN( 2, C2, 'SY' ) ) THEN + CALL CSYSVXX(FACT, UPLO, N, NRHS, ACOPY, LDA, AF, LDA, + $ IPIV, EQUED, S, B, LDA, X, LDA, ORCOND, + $ RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS, + $ PARAMS, WORK, RWORK, INFO) + ELSE IF ( LSAMEN( 2, C2, 'PO' ) ) THEN + CALL CPOSVXX(FACT, UPLO, N, NRHS, ACOPY, LDA, AF, LDA, + $ EQUED, S, B, LDA, X, LDA, ORCOND, + $ RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS, + $ PARAMS, WORK, RWORK, INFO) + ELSE IF ( LSAMEN( 2, C2, 'HE' ) ) THEN + CALL CHESVXX(FACT, UPLO, N, NRHS, ACOPY, LDA, AF, LDA, + $ IPIV, EQUED, S, B, LDA, X, LDA, ORCOND, + $ RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS, + $ PARAMS, WORK, RWORK, INFO) + ELSE IF ( LSAMEN( 2, C2, 'GB' ) ) THEN + CALL CGBSVXX(FACT, TRANS, N, KL, KU, NRHS, ABCOPY, + $ LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, + $ LDA, X, LDA, ORCOND, RPVGRW, BERR, NERRBND, + $ ERRBND_N, ERRBND_C, NPARAMS, PARAMS, WORK, RWORK, + $ INFO) + ELSE + CALL CGESVXX(FACT, TRANS, N, NRHS, ACOPY, LDA, AF, LDA, + $ IPIV, EQUED, R, C, B, LDA, X, LDA, ORCOND, + $ RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS, + $ PARAMS, WORK, RWORK, INFO) + END IF + + N_AUX_TESTS = N_AUX_TESTS + 1 + IF (ORCOND .LT. EPS) THEN +! Either factorization failed or the matrix is flagged, and 1 <= +! INFO <= N+1. We don't decide based on rcond anymore. +! IF (INFO .EQ. 0 .OR. INFO .GT. N+1) THEN +! NFAIL = NFAIL + 1 +! WRITE (*, FMT=8000) N, INFO, ORCOND, RCOND +! END IF + ELSE +! Either everything succeeded (INFO == 0) or some solution failed +! to converge (INFO > N+1). + IF (INFO .GT. 0 .AND. INFO .LE. N+1) THEN + NFAIL = NFAIL + 1 + WRITE (*, FMT=8000) C2, N, INFO, ORCOND, RCOND + END IF + END IF + +* Calculating the difference between C**SVXX's X and the true X. + DO I = 1,N + DO J =1,NRHS + DIFF(I,J) = X(I,J) - INVHILB(I,J) + END DO + END DO + +* Calculating the RCOND + RNORM = 0 + RINORM = 0 + IF ( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'SY' ) .OR. + $ LSAMEN( 2, C2, 'HE' ) ) THEN + DO I = 1, N + SUMR = 0 + SUMRI = 0 + DO J = 1, N + SUMR = SUMR + S(I) * CABS1(A(I,J)) * S(J) + SUMRI = SUMRI + CABS1(INVHILB(I, J)) / (S(J) * S(I)) + END DO + RNORM = MAX(RNORM,SUMR) + RINORM = MAX(RINORM,SUMRI) + END DO + ELSE IF ( LSAMEN( 2, C2, 'GE' ) .OR. LSAMEN( 2, C2, 'GB' ) ) + $ THEN + DO I = 1, N + SUMR = 0 + SUMRI = 0 + DO J = 1, N + SUMR = SUMR + R(I) * CABS1(A(I,J)) * C(J) + SUMRI = SUMRI + CABS1(INVHILB(I, J)) / (R(J) * C(I)) + END DO + RNORM = MAX(RNORM,SUMR) + RINORM = MAX(RINORM,SUMRI) + END DO + END IF + + RNORM = RNORM / CABS1(A(1, 1)) + RCOND = 1.0/(RNORM * RINORM) + +* Calculating the R for normwise rcond. + DO I = 1, N + RINV(I) = 0.0 + END DO + DO J = 1, N + DO I = 1, N + RINV(I) = RINV(I) + CABS1(A(I,J)) + END DO + END DO + +* Calculating the Normwise rcond. + RINORM = 0.0 + DO I = 1, N + SUMRI = 0.0 + DO J = 1, N + SUMRI = SUMRI + CABS1(INVHILB(I,J) * RINV(J)) + END DO + RINORM = MAX(RINORM, SUMRI) + END DO + +! invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm +! by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) + NCOND = CABS1(A(1,1)) / RINORM + + CONDTHRESH = M * EPS + ERRTHRESH = M * EPS + + DO K = 1, NRHS + NORMT = 0.0 + NORMDIF = 0.0 + CWISE_ERR = 0.0 + DO I = 1, N + NORMT = MAX(CABS1(INVHILB(I, K)), NORMT) + NORMDIF = MAX(CABS1(X(I,K) - INVHILB(I,K)), NORMDIF) + IF (INVHILB(I,K) .NE. 0.0) THEN + CWISE_ERR = MAX(CABS1(X(I,K) - INVHILB(I,K)) + $ /CABS1(INVHILB(I,K)), CWISE_ERR) + ELSE IF (X(I, K) .NE. 0.0) THEN + CWISE_ERR = SLAMCH('OVERFLOW') + END IF + END DO + IF (NORMT .NE. 0.0) THEN + NWISE_ERR = NORMDIF / NORMT + ELSE IF (NORMDIF .NE. 0.0) THEN + NWISE_ERR = SLAMCH('OVERFLOW') + ELSE + NWISE_ERR = 0.0 + ENDIF + + DO I = 1, N + RINV(I) = 0.0 + END DO + DO J = 1, N + DO I = 1, N + RINV(I) = RINV(I) + CABS1(A(I, J) * INVHILB(J, K)) + END DO + END DO + RINORM = 0.0 + DO I = 1, N + SUMRI = 0.0 + DO J = 1, N + SUMRI = SUMRI + $ + CABS1(INVHILB(I, J) * RINV(J) / INVHILB(I, K)) + END DO + RINORM = MAX(RINORM, SUMRI) + END DO +! invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm +! by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) + CCOND = CABS1(A(1,1))/RINORM + +! Forward error bound tests + NWISE_BND = ERRBND_N(K + (BND_I-1)*NRHS) + CWISE_BND = ERRBND_C(K + (BND_I-1)*NRHS) + NWISE_RCOND = ERRBND_N(K + (COND_I-1)*NRHS) + CWISE_RCOND = ERRBND_C(K + (COND_I-1)*NRHS) +! write (*,*) 'nwise : ', n, k, ncond, nwise_rcond, +! $ condthresh, ncond.ge.condthresh +! write (*,*) 'nwise2: ', k, nwise_bnd, nwise_err, errthresh + IF (NCOND .GE. CONDTHRESH) THEN + NGUAR = 'YES' + IF (NWISE_BND .GT. ERRTHRESH) THEN + TSTRAT(1) = 1/(2.0*EPS) + ELSE + IF (NWISE_BND .NE. 0.0) THEN + TSTRAT(1) = NWISE_ERR / NWISE_BND + ELSE IF (NWISE_ERR .NE. 0.0) THEN + TSTRAT(1) = 1/(16.0*EPS) + ELSE + TSTRAT(1) = 0.0 + END IF + IF (TSTRAT(1) .GT. 1.0) THEN + TSTRAT(1) = 1/(4.0*EPS) + END IF + END IF + ELSE + NGUAR = 'NO' + IF (NWISE_BND .LT. 1.0) THEN + TSTRAT(1) = 1/(8.0*EPS) + ELSE + TSTRAT(1) = 1.0 + END IF + END IF +! write (*,*) 'cwise : ', n, k, ccond, cwise_rcond, +! $ condthresh, ccond.ge.condthresh +! write (*,*) 'cwise2: ', k, cwise_bnd, cwise_err, errthresh + IF (CCOND .GE. CONDTHRESH) THEN + CGUAR = 'YES' + IF (CWISE_BND .GT. ERRTHRESH) THEN + TSTRAT(2) = 1/(2.0*EPS) + ELSE + IF (CWISE_BND .NE. 0.0) THEN + TSTRAT(2) = CWISE_ERR / CWISE_BND + ELSE IF (CWISE_ERR .NE. 0.0) THEN + TSTRAT(2) = 1/(16.0*EPS) + ELSE + TSTRAT(2) = 0.0 + END IF + IF (TSTRAT(2) .GT. 1.0) TSTRAT(2) = 1/(4.0*EPS) + END IF + ELSE + CGUAR = 'NO' + IF (CWISE_BND .LT. 1.0) THEN + TSTRAT(2) = 1/(8.0*EPS) + ELSE + TSTRAT(2) = 1.0 + END IF + END IF + +! Backwards error test + TSTRAT(3) = BERR(K)/EPS + +! Condition number tests + TSTRAT(4) = RCOND / ORCOND + IF (RCOND .GE. CONDTHRESH .AND. TSTRAT(4) .LT. 1.0) + $ TSTRAT(4) = 1.0 / TSTRAT(4) + + TSTRAT(5) = NCOND / NWISE_RCOND + IF (NCOND .GE. CONDTHRESH .AND. TSTRAT(5) .LT. 1.0) + $ TSTRAT(5) = 1.0 / TSTRAT(5) + + TSTRAT(6) = CCOND / NWISE_RCOND + IF (CCOND .GE. CONDTHRESH .AND. TSTRAT(6) .LT. 1.0) + $ TSTRAT(6) = 1.0 / TSTRAT(6) + + DO I = 1, NTESTS + IF (TSTRAT(I) .GT. THRESH) THEN + IF (.NOT.PRINTED_GUIDE) THEN + WRITE(*,*) + WRITE( *, 9996) 1 + WRITE( *, 9995) 2 + WRITE( *, 9994) 3 + WRITE( *, 9993) 4 + WRITE( *, 9992) 5 + WRITE( *, 9991) 6 + WRITE( *, 9990) 7 + WRITE( *, 9989) 8 + WRITE(*,*) + PRINTED_GUIDE = .TRUE. + END IF + WRITE( *, 9999) C2, N, K, NGUAR, CGUAR, I, TSTRAT(I) + NFAIL = NFAIL + 1 + END IF + END DO + END DO + +c$$$ WRITE(*,*) +c$$$ WRITE(*,*) 'Normwise Error Bounds' +c$$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,nwise_i,bnd_i) +c$$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,nwise_i,cond_i) +c$$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,nwise_i,rawbnd_i) +c$$$ WRITE(*,*) +c$$$ WRITE(*,*) 'Componentwise Error Bounds' +c$$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,cwise_i,bnd_i) +c$$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,cwise_i,cond_i) +c$$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,cwise_i,rawbnd_i) +c$$$ print *, 'Info: ', info +c$$$ WRITE(*,*) +* WRITE(*,*) 'TSTRAT: ',TSTRAT + + END DO + + WRITE(*,*) + IF( NFAIL .GT. 0 ) THEN + WRITE(*,9998) C2, NFAIL, NTESTS*N+N_AUX_TESTS + ELSE + WRITE(*,9997) C2 + END IF + 9999 FORMAT( ' C', A2, 'SVXX: N =', I2, ', RHS = ', I2, + $ ', NWISE GUAR. = ', A, ', CWISE GUAR. = ', A, + $ ' test(',I1,') =', G12.5 ) + 9998 FORMAT( ' C', A2, 'SVXX: ', I6, ' out of ', I6, + $ ' tests failed to pass the threshold' ) + 9997 FORMAT( ' C', A2, 'SVXX passed the tests of error bounds' ) +* Test ratios. + 9996 FORMAT( 3X, I2, ': Normwise guaranteed forward error', / 5X, + $ 'Guaranteed case: if norm ( abs( Xc - Xt )', + $ ' / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ), then', + $ / 5X, + $ 'ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS') + 9995 FORMAT( 3X, I2, ': Componentwise guaranteed forward error' ) + 9994 FORMAT( 3X, I2, ': Backwards error' ) + 9993 FORMAT( 3X, I2, ': Reciprocal condition number' ) + 9992 FORMAT( 3X, I2, ': Reciprocal normwise condition number' ) + 9991 FORMAT( 3X, I2, ': Raw normwise error estimate' ) + 9990 FORMAT( 3X, I2, ': Reciprocal componentwise condition number' ) + 9989 FORMAT( 3X, I2, ': Raw componentwise error estimate' ) + + 8000 FORMAT( ' C', A2, 'SVXX: N =', I2, ', INFO = ', I3, + $ ', ORCOND = ', G12.5, ', real RCOND = ', G12.5 ) + + END diff --git a/TESTING/LIN/cerrge.f b/TESTING/LIN/cerrge.f index 530f89e4..d27d61c5 100644 --- a/TESTING/LIN/cerrge.f +++ b/TESTING/LIN/cerrge.f @@ -52,7 +52,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cerrgex.f b/TESTING/LIN/cerrgex.f new file mode 100644 index 00000000..13ffcdd9 --- /dev/null +++ b/TESTING/LIN/cerrgex.f @@ -0,0 +1,524 @@ + SUBROUTINE CERRGE( PATH, NUNIT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* Purpose +* ======= +* +* CERRGE tests the error exits for the COMPLEX routines +* for general matrices. +* +* Note that this file is used only when the XBLAS are available, +* otherwise cerrge.f defines this subroutine. +* +* Arguments +* ========= +* +* PATH (input) CHARACTER*3 +* The LAPACK path name for the routines to be tested. +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 4 ) +* .. +* .. Local Scalars .. + CHARACTER EQ + CHARACTER*2 C2 + INTEGER I, INFO, J, N_ERR_BNDS, NPARAMS + REAL ANRM, CCOND, RCOND, BERR +* .. +* .. LOCAL ARRAYS .. + INTEGER IP( NMAX ) + REAL R( NMAX ), R1( NMAX ), R2( NMAX ), CS( NMAX ), + $ RS( NMAX ) + COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), + $ W( 2*NMAX ), X( NMAX ), ERR_BNDS_N( NMAX, 3 ), + $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAMEN + EXTERNAL LSAMEN +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CGBCON, CGBEQU, CGBRFS, CGBTF2, CGBTRF, + $ CGBTRS, CGECON, CGEEQU, CGERFS, CGETF2, CGETRF, + $ CGETRI, CGETRS, CHKXER, CGEEQUB, CGERFSX, + $ CGBEQUB, CGBRFSX +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC CMPLX, REAL +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) + C2 = PATH( 2: 3 ) +* +* Set the variables to innocuous values. +* + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + 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. + CS( J ) = 0. + RS( J ) = 0. + IP( J ) = J + 20 CONTINUE + OK = .TRUE. +* +* Test error exits of the routines that use the LU decomposition +* of a general matrix. +* + IF( LSAMEN( 2, C2, 'GE' ) ) THEN +* +* CGETRF +* + SRNAMT = 'CGETRF' + INFOT = 1 + CALL CGETRF( -1, 0, A, 1, IP, INFO ) + CALL CHKXER( 'CGETRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGETRF( 0, -1, A, 1, IP, INFO ) + CALL CHKXER( 'CGETRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGETRF( 2, 1, A, 1, IP, INFO ) + CALL CHKXER( 'CGETRF', INFOT, NOUT, LERR, OK ) +* +* CGETF2 +* + SRNAMT = 'CGETF2' + INFOT = 1 + CALL CGETF2( -1, 0, A, 1, IP, INFO ) + CALL CHKXER( 'CGETF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGETF2( 0, -1, A, 1, IP, INFO ) + CALL CHKXER( 'CGETF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGETF2( 2, 1, A, 1, IP, INFO ) + CALL CHKXER( 'CGETF2', INFOT, NOUT, LERR, OK ) +* +* CGETRI +* + SRNAMT = 'CGETRI' + INFOT = 1 + CALL CGETRI( -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'CGETRI', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGETRI( 2, A, 1, IP, W, 2, INFO ) + CALL CHKXER( 'CGETRI', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CGETRI( 2, A, 2, IP, W, 1, INFO ) + CALL CHKXER( 'CGETRI', INFOT, NOUT, LERR, OK ) +* +* CGETRS +* + SRNAMT = 'CGETRS' + INFOT = 1 + CALL CGETRS( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CGETRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGETRS( 'N', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CGETRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGETRS( 'N', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CGETRS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGETRS( 'N', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'CGETRS', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGETRS( 'N', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'CGETRS', INFOT, NOUT, LERR, OK ) +* +* CGERFS +* + SRNAMT = 'CGERFS' + INFOT = 1 + CALL CGERFS( '/', 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'CGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGERFS( 'N', -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, + $ W, R, INFO ) + CALL CHKXER( 'CGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGERFS( 'N', 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, + $ W, R, INFO ) + CALL CHKXER( 'CGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGERFS( 'N', 2, 1, A, 1, AF, 2, IP, B, 2, X, 2, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'CGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CGERFS( 'N', 2, 1, A, 2, AF, 1, IP, B, 2, X, 2, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'CGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CGERFS( 'N', 2, 1, A, 2, AF, 2, IP, B, 1, X, 2, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'CGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL CGERFS( 'N', 2, 1, A, 2, AF, 2, IP, B, 2, X, 1, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'CGERFS', INFOT, NOUT, LERR, OK ) +* +* CGERFSX +* + N_ERR_BNDS = 3 + NPARAMS = 0 + SRNAMT = 'CGERFSX' + INFOT = 1 + CALL CGERFSX( '/', EQ, 0, 0, A, 1, AF, 1, IP, RS, CS, B, 1, X, + $ 1, RCOND, berr, n_err_bnds, err_bnds_n, + $ err_bnds_c, nparams, params, W, R, INFO ) + CALL CHKXER( 'CGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 2 + EQ = '/' + CALL CGERFSX( 'N', EQ, 2, 1, A, 1, AF, 2, IP, RS, CS, B, 2, X, + $ 2, RCOND, berr, n_err_bnds, err_bnds_n, + $ err_bnds_c, nparams, params, W, R, INFO ) + CALL CHKXER( 'CGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 3 + EQ = 'R' + CALL CGERFSX( 'N', EQ, -1, 0, A, 1, AF, 1, IP, RS, CS, B, 1, X, + $ 1, RCOND, berr, n_err_bnds, err_bnds_n, + $ err_bnds_c, nparams, params, W, R, INFO ) + CALL CHKXER( 'CGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGERFSX( 'N', EQ, 0, -1, A, 1, AF, 1, IP, RS, CS, B, 1, X, + $ 1, RCOND, berr, n_err_bnds, err_bnds_n, + $ err_bnds_c, nparams, params, W, R, INFO ) + CALL CHKXER( 'CGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CGERFSX( 'N', EQ, 2, 1, A, 1, AF, 2, IP, RS, CS, B, 2, X, + $ 2, RCOND, berr, n_err_bnds, err_bnds_n, + $ err_bnds_c, nparams, params, W, R, INFO ) + CALL CHKXER( 'CGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGERFSX( 'N', EQ, 2, 1, A, 2, AF, 1, IP, RS, CS, B, 2, X, + $ 2, RCOND, berr, n_err_bnds, err_bnds_n, + $ err_bnds_c, nparams, params, W, R, INFO ) + CALL CHKXER( 'CGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 13 + EQ = 'C' + CALL CGERFSX( 'N', EQ, 2, 1, A, 2, AF, 2, IP, RS, CS, B, 1, X, + $ 2, RCOND, berr, n_err_bnds, err_bnds_n, + $ err_bnds_c, nparams, params, W, R, INFO ) + CALL CHKXER( 'CGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL CGERFSX( 'N', EQ, 2, 1, A, 2, AF, 2, IP, RS, CS, B, 2, X, + $ 1, RCOND, berr, n_err_bnds, err_bnds_n, + $ err_bnds_c, nparams, params, W, R, INFO ) + CALL CHKXER( 'CGERFSX', INFOT, NOUT, LERR, OK ) +* +* CGECON +* + SRNAMT = 'CGECON' + INFOT = 1 + CALL CGECON( '/', 0, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CGECON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGECON( '1', -1, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CGECON', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGECON( '1', 2, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CGECON', INFOT, NOUT, LERR, OK ) +* +* CGEEQU +* + SRNAMT = 'CGEEQU' + INFOT = 1 + CALL CGEEQU( -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'CGEEQU', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGEEQU( 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'CGEEQU', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEEQU( 2, 2, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'CGEEQU', INFOT, NOUT, LERR, OK ) +* +* CGEEQUB +* + SRNAMT = 'CGEEQUB' + INFOT = 1 + CALL CGEEQUB( -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'CGEEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGEEQUB( 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'CGEEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGEEQUB( 2, 2, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'CGEEQUB', INFOT, NOUT, LERR, OK ) +* +* Test error exits of the routines that use the LU decomposition +* of a general band matrix. +* + ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN +* +* CGBTRF +* + SRNAMT = 'CGBTRF' + INFOT = 1 + CALL CGBTRF( -1, 0, 0, 0, A, 1, IP, INFO ) + CALL CHKXER( 'CGBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGBTRF( 0, -1, 0, 0, A, 1, IP, INFO ) + CALL CHKXER( 'CGBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGBTRF( 1, 1, -1, 0, A, 1, IP, INFO ) + CALL CHKXER( 'CGBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGBTRF( 1, 1, 0, -1, A, 1, IP, INFO ) + CALL CHKXER( 'CGBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CGBTRF( 2, 2, 1, 1, A, 3, IP, INFO ) + CALL CHKXER( 'CGBTRF', INFOT, NOUT, LERR, OK ) +* +* CGBTF2 +* + SRNAMT = 'CGBTF2' + INFOT = 1 + CALL CGBTF2( -1, 0, 0, 0, A, 1, IP, INFO ) + CALL CHKXER( 'CGBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGBTF2( 0, -1, 0, 0, A, 1, IP, INFO ) + CALL CHKXER( 'CGBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGBTF2( 1, 1, -1, 0, A, 1, IP, INFO ) + CALL CHKXER( 'CGBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGBTF2( 1, 1, 0, -1, A, 1, IP, INFO ) + CALL CHKXER( 'CGBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CGBTF2( 2, 2, 1, 1, A, 3, IP, INFO ) + CALL CHKXER( 'CGBTF2', INFOT, NOUT, LERR, OK ) +* +* CGBTRS +* + SRNAMT = 'CGBTRS' + INFOT = 1 + CALL CGBTRS( '/', 0, 0, 0, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGBTRS( 'N', -1, 0, 0, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGBTRS( 'N', 1, -1, 0, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGBTRS( 'N', 1, 0, -1, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGBTRS( 'N', 1, 0, 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CGBTRS( 'N', 2, 1, 1, 1, A, 3, IP, B, 2, INFO ) + CALL CHKXER( 'CGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CGBTRS( 'N', 2, 0, 0, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'CGBTRS', INFOT, NOUT, LERR, OK ) +* +* CGBRFS +* + SRNAMT = 'CGBRFS' + INFOT = 1 + CALL CGBRFS( '/', 0, 0, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'CGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGBRFS( 'N', -1, 0, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'CGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGBRFS( 'N', 1, -1, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'CGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGBRFS( 'N', 1, 0, -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'CGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CGBRFS( 'N', 1, 0, 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'CGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CGBRFS( 'N', 2, 1, 1, 1, A, 2, AF, 4, IP, B, 2, X, 2, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'CGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CGBRFS( 'N', 2, 1, 1, 1, A, 3, AF, 3, IP, B, 2, X, 2, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'CGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL CGBRFS( 'N', 2, 0, 0, 1, A, 1, AF, 1, IP, B, 1, X, 2, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'CGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 14 + CALL CGBRFS( 'N', 2, 0, 0, 1, A, 1, AF, 1, IP, B, 2, X, 1, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'CGBRFS', INFOT, NOUT, LERR, OK ) +* +* CGBRFSX +* + N_ERR_BNDS = 3 + NPARAMS = 0 + SRNAMT = 'CGBRFSX' + INFOT = 1 + CALL CGBRFSX( '/', EQ, 0, 0, 0, 0, A, 1, AF, 1, IP, RS, CS, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'CGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 2 + EQ = '/' + CALL CGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 1, AF, 2, IP, RS, CS, B, + $ 2, X, 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'CGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 3 + EQ = 'R' + CALL CGBRFSX( 'N', EQ, -1, 1, 1, 0, A, 1, AF, 1, IP, RS, CS, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'CGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 4 + EQ = 'R' + CALL CGBRFSX( 'N', EQ, 2, -1, 1, 1, A, 3, AF, 4, IP, RS, CS, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'CGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 5 + EQ = 'R' + CALL CGBRFSX( 'N', EQ, 2, 1, -1, 1, A, 3, AF, 4, IP, RS, CS, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'CGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CGBRFSX( 'N', EQ, 0, 0, 0, -1, A, 1, AF, 1, IP, RS, CS, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'CGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 1, AF, 2, IP, RS, CS, B, + $ 2, X, 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'CGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 3, AF, 3, IP, RS, CS, B, + $ 2, X, 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'CGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 13 + EQ = 'C' + CALL CGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 3, AF, 5, IP, RS, CS, B, + $ 1, X, 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'CGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL CGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 3, AF, 5, IP, RS, CS, B, + $ 2, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'CGBRFSX', INFOT, NOUT, LERR, OK ) +* +* CGBCON +* + SRNAMT = 'CGBCON' + INFOT = 1 + CALL CGBCON( '/', 0, 0, 0, A, 1, IP, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CGBCON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGBCON( '1', -1, 0, 0, A, 1, IP, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CGBCON', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGBCON( '1', 1, -1, 0, A, 1, IP, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CGBCON', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGBCON( '1', 1, 0, -1, A, 1, IP, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CGBCON', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CGBCON( '1', 2, 1, 1, A, 3, IP, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CGBCON', INFOT, NOUT, LERR, OK ) +* +* CGBEQU +* + SRNAMT = 'CGBEQU' + INFOT = 1 + CALL CGBEQU( -1, 0, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'CGBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGBEQU( 0, -1, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'CGBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGBEQU( 1, 1, -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'CGBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGBEQU( 1, 1, 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'CGBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CGBEQU( 2, 2, 1, 1, A, 2, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'CGBEQU', INFOT, NOUT, LERR, OK ) +* +* CGBEQUB +* + SRNAMT = 'CGBEQUB' + INFOT = 1 + CALL CGBEQUB( -1, 0, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'CGBEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CGBEQUB( 0, -1, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'CGBEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CGBEQUB( 1, 1, -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'CGBEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CGBEQUB( 1, 1, 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'CGBEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CGBEQUB( 2, 2, 1, 1, A, 2, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'CGBEQUB', INFOT, NOUT, LERR, OK ) + END IF +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of CERRGE +* + END diff --git a/TESTING/LIN/cerrgt.f b/TESTING/LIN/cerrgt.f index cee3068b..7c8ecc17 100644 --- a/TESTING/LIN/cerrgt.f +++ b/TESTING/LIN/cerrgt.f @@ -53,7 +53,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cerrhe.f b/TESTING/LIN/cerrhe.f index 120fd28a..c58cd36e 100644 --- a/TESTING/LIN/cerrhe.f +++ b/TESTING/LIN/cerrhe.f @@ -53,7 +53,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cerrlq.f b/TESTING/LIN/cerrlq.f index 0db34119..1b0d4f4b 100644 --- a/TESTING/LIN/cerrlq.f +++ b/TESTING/LIN/cerrlq.f @@ -43,7 +43,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cerrls.f b/TESTING/LIN/cerrls.f index c38a019e..fca399d6 100644 --- a/TESTING/LIN/cerrls.f +++ b/TESTING/LIN/cerrls.f @@ -50,7 +50,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cerrpo.f b/TESTING/LIN/cerrpo.f index 78b0eafc..81b9c13c 100644 --- a/TESTING/LIN/cerrpo.f +++ b/TESTING/LIN/cerrpo.f @@ -52,7 +52,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cerrpox.f b/TESTING/LIN/cerrpox.f new file mode 100644 index 00000000..61fff132 --- /dev/null +++ b/TESTING/LIN/cerrpox.f @@ -0,0 +1,493 @@ + SUBROUTINE CERRPO( PATH, NUNIT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* Purpose +* ======= +* +* CERRPO tests the error exits for the COMPLEX routines +* for Hermitian positive definite matrices. +* +* Arguments +* ========= +* +* PATH (input) CHARACTER*3 +* The LAPACK path name for the routines to be tested. +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 4 ) +* .. +* .. Local Scalars .. + CHARACTER EQ + CHARACTER*2 C2 + INTEGER I, INFO, J, N_ERR_BNDS, NPARAMS + REAL ANRM, RCOND, BERR +* .. +* .. Local Arrays .. + REAL S( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ), + $ ERR_BNDS_N( NMAX, 3 ), ERR_BNDS_C( NMAX, 3 ), + $ PARAMS + COMPLEX A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), + $ W( 2*NMAX ), X( NMAX ) +* .. +* .. External Functions .. + LOGICAL LSAMEN + EXTERNAL LSAMEN +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, CPBCON, CPBEQU, CPBRFS, CPBTF2, + $ CPBTRF, CPBTRS, CPOCON, CPOEQU, CPORFS, CPOTF2, + $ CPOTRF, CPOTRI, CPOTRS, CPPCON, CPPEQU, CPPRFS, + $ CPPTRF, CPPTRI, CPPTRS, CPOEQUB, CPORFSX +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC CMPLX, REAL +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) + C2 = PATH( 2: 3 ) +* +* Set the variables to innocuous values. +* + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + 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. + 20 CONTINUE + ANRM = 1. + OK = .TRUE. +* +* Test error exits of the routines that use the Cholesky +* decomposition of a Hermitian positive definite matrix. +* + IF( LSAMEN( 2, C2, 'PO' ) ) THEN +* +* CPOTRF +* + SRNAMT = 'CPOTRF' + INFOT = 1 + CALL CPOTRF( '/', 0, A, 1, INFO ) + CALL CHKXER( 'CPOTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPOTRF( 'U', -1, A, 1, INFO ) + CALL CHKXER( 'CPOTRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CPOTRF( 'U', 2, A, 1, INFO ) + CALL CHKXER( 'CPOTRF', INFOT, NOUT, LERR, OK ) +* +* CPOTF2 +* + SRNAMT = 'CPOTF2' + INFOT = 1 + CALL CPOTF2( '/', 0, A, 1, INFO ) + CALL CHKXER( 'CPOTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPOTF2( 'U', -1, A, 1, INFO ) + CALL CHKXER( 'CPOTF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CPOTF2( 'U', 2, A, 1, INFO ) + CALL CHKXER( 'CPOTF2', INFOT, NOUT, LERR, OK ) +* +* CPOTRI +* + SRNAMT = 'CPOTRI' + INFOT = 1 + CALL CPOTRI( '/', 0, A, 1, INFO ) + CALL CHKXER( 'CPOTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPOTRI( 'U', -1, A, 1, INFO ) + CALL CHKXER( 'CPOTRI', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CPOTRI( 'U', 2, A, 1, INFO ) + CALL CHKXER( 'CPOTRI', INFOT, NOUT, LERR, OK ) +* +* CPOTRS +* + SRNAMT = 'CPOTRS' + INFOT = 1 + CALL CPOTRS( '/', 0, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'CPOTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPOTRS( 'U', -1, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'CPOTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CPOTRS( 'U', 0, -1, A, 1, B, 1, INFO ) + CALL CHKXER( 'CPOTRS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CPOTRS( 'U', 2, 1, A, 1, B, 2, INFO ) + CALL CHKXER( 'CPOTRS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CPOTRS( 'U', 2, 1, A, 2, B, 1, INFO ) + CALL CHKXER( 'CPOTRS', INFOT, NOUT, LERR, OK ) +* +* CPORFS +* + SRNAMT = 'CPORFS' + INFOT = 1 + CALL CPORFS( '/', 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'CPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPORFS( 'U', -1, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'CPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CPORFS( 'U', 0, -1, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'CPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CPORFS( 'U', 2, 1, A, 1, AF, 2, B, 2, X, 2, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'CPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CPORFS( 'U', 2, 1, A, 2, AF, 1, B, 2, X, 2, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'CPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CPORFS( 'U', 2, 1, A, 2, AF, 2, B, 1, X, 2, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'CPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CPORFS( 'U', 2, 1, A, 2, AF, 2, B, 2, X, 1, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'CPORFS', INFOT, NOUT, LERR, OK ) +* +* CPORFSX +* + N_ERR_BNDS = 3 + NPARAMS = 0 + SRNAMT = 'CPORFSX' + INFOT = 1 + CALL CPORFSX( '/', EQ, 0, 0, A, 1, AF, 1, S, B, 1, X, 1, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, R, INFO ) + CALL CHKXER( 'CPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPORFSX( 'U', EQ, -1, 0, A, 1, AF, 1, S, B, 1, X, 1, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, R, INFO ) + CALL CHKXER( 'CPORFSX', INFOT, NOUT, LERR, OK ) + EQ = 'N' + INFOT = 3 + CALL CPORFSX( 'U', EQ, -1, 0, A, 1, AF, 1, S, B, 1, X, 1, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, R, INFO ) + CALL CHKXER( 'CPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CPORFSX( 'U', EQ, 0, -1, A, 1, AF, 1, S, B, 1, X, 1, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, R, INFO ) + CALL CHKXER( 'CPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CPORFSX( 'U', EQ, 2, 1, A, 1, AF, 2, S, B, 2, X, 2, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, R, INFO ) + CALL CHKXER( 'CPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CPORFSX( 'U', EQ, 2, 1, A, 2, AF, 1, S, B, 2, X, 2, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, R, INFO ) + CALL CHKXER( 'CPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CPORFSX( 'U', EQ, 2, 1, A, 2, AF, 2, S, B, 1, X, 2, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, R, INFO ) + CALL CHKXER( 'CPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL CPORFSX( 'U', EQ, 2, 1, A, 2, AF, 2, S, B, 2, X, 1, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, R, INFO ) + CALL CHKXER( 'CPORFSX', INFOT, NOUT, LERR, OK ) +* +* CPOCON +* + SRNAMT = 'CPOCON' + INFOT = 1 + CALL CPOCON( '/', 0, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CPOCON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPOCON( 'U', -1, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CPOCON', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CPOCON( 'U', 2, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CPOCON', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CPOCON( 'U', 1, A, 1, -ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CPOCON', INFOT, NOUT, LERR, OK ) +* +* CPOEQU +* + SRNAMT = 'CPOEQU' + INFOT = 1 + CALL CPOEQU( -1, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'CPOEQU', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CPOEQU( 2, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'CPOEQU', INFOT, NOUT, LERR, OK ) +* +* CPOEQUB +* + SRNAMT = 'CPOEQUB' + INFOT = 1 + CALL CPOEQUB( -1, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'CPOEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CPOEQUB( 2, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'CPOEQUB', INFOT, NOUT, LERR, OK ) +* +* Test error exits of the routines that use the Cholesky +* decomposition of a Hermitian positive definite packed matrix. +* + ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN +* +* CPPTRF +* + SRNAMT = 'CPPTRF' + INFOT = 1 + CALL CPPTRF( '/', 0, A, INFO ) + CALL CHKXER( 'CPPTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPPTRF( 'U', -1, A, INFO ) + CALL CHKXER( 'CPPTRF', INFOT, NOUT, LERR, OK ) +* +* CPPTRI +* + SRNAMT = 'CPPTRI' + INFOT = 1 + CALL CPPTRI( '/', 0, A, INFO ) + CALL CHKXER( 'CPPTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPPTRI( 'U', -1, A, INFO ) + CALL CHKXER( 'CPPTRI', INFOT, NOUT, LERR, OK ) +* +* CPPTRS +* + SRNAMT = 'CPPTRS' + INFOT = 1 + CALL CPPTRS( '/', 0, 0, A, B, 1, INFO ) + CALL CHKXER( 'CPPTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPPTRS( 'U', -1, 0, A, B, 1, INFO ) + CALL CHKXER( 'CPPTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CPPTRS( 'U', 0, -1, A, B, 1, INFO ) + CALL CHKXER( 'CPPTRS', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CPPTRS( 'U', 2, 1, A, B, 1, INFO ) + CALL CHKXER( 'CPPTRS', INFOT, NOUT, LERR, OK ) +* +* CPPRFS +* + SRNAMT = 'CPPRFS' + INFOT = 1 + CALL CPPRFS( '/', 0, 0, A, AF, B, 1, X, 1, R1, R2, W, R, INFO ) + CALL CHKXER( 'CPPRFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPPRFS( 'U', -1, 0, A, AF, B, 1, X, 1, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'CPPRFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CPPRFS( 'U', 0, -1, A, AF, B, 1, X, 1, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'CPPRFS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CPPRFS( 'U', 2, 1, A, AF, B, 1, X, 2, R1, R2, W, R, INFO ) + CALL CHKXER( 'CPPRFS', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL CPPRFS( 'U', 2, 1, A, AF, B, 2, X, 1, R1, R2, W, R, INFO ) + CALL CHKXER( 'CPPRFS', INFOT, NOUT, LERR, OK ) +* +* CPPCON +* + SRNAMT = 'CPPCON' + INFOT = 1 + CALL CPPCON( '/', 0, A, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CPPCON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPPCON( 'U', -1, A, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CPPCON', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CPPCON( 'U', 1, A, -ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CPPCON', INFOT, NOUT, LERR, OK ) +* +* CPPEQU +* + SRNAMT = 'CPPEQU' + INFOT = 1 + CALL CPPEQU( '/', 0, A, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'CPPEQU', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPPEQU( 'U', -1, A, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'CPPEQU', INFOT, NOUT, LERR, OK ) +* +* Test error exits of the routines that use the Cholesky +* decomposition of a Hermitian positive definite band matrix. +* + ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN +* +* CPBTRF +* + SRNAMT = 'CPBTRF' + INFOT = 1 + CALL CPBTRF( '/', 0, 0, A, 1, INFO ) + CALL CHKXER( 'CPBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPBTRF( 'U', -1, 0, A, 1, INFO ) + CALL CHKXER( 'CPBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CPBTRF( 'U', 1, -1, A, 1, INFO ) + CALL CHKXER( 'CPBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CPBTRF( 'U', 2, 1, A, 1, INFO ) + CALL CHKXER( 'CPBTRF', INFOT, NOUT, LERR, OK ) +* +* CPBTF2 +* + SRNAMT = 'CPBTF2' + INFOT = 1 + CALL CPBTF2( '/', 0, 0, A, 1, INFO ) + CALL CHKXER( 'CPBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPBTF2( 'U', -1, 0, A, 1, INFO ) + CALL CHKXER( 'CPBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CPBTF2( 'U', 1, -1, A, 1, INFO ) + CALL CHKXER( 'CPBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CPBTF2( 'U', 2, 1, A, 1, INFO ) + CALL CHKXER( 'CPBTF2', INFOT, NOUT, LERR, OK ) +* +* CPBTRS +* + SRNAMT = 'CPBTRS' + INFOT = 1 + CALL CPBTRS( '/', 0, 0, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'CPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPBTRS( 'U', -1, 0, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'CPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CPBTRS( 'U', 1, -1, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'CPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CPBTRS( 'U', 0, 0, -1, A, 1, B, 1, INFO ) + CALL CHKXER( 'CPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CPBTRS( 'U', 2, 1, 1, A, 1, B, 1, INFO ) + CALL CHKXER( 'CPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CPBTRS( 'U', 2, 0, 1, A, 1, B, 1, INFO ) + CALL CHKXER( 'CPBTRS', INFOT, NOUT, LERR, OK ) +* +* CPBRFS +* + SRNAMT = 'CPBRFS' + INFOT = 1 + CALL CPBRFS( '/', 0, 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'CPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPBRFS( 'U', -1, 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'CPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CPBRFS( 'U', 1, -1, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'CPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CPBRFS( 'U', 0, 0, -1, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'CPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CPBRFS( 'U', 2, 1, 1, A, 1, AF, 2, B, 2, X, 2, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'CPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CPBRFS( 'U', 2, 1, 1, A, 2, AF, 1, B, 2, X, 2, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'CPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL CPBRFS( 'U', 2, 0, 1, A, 1, AF, 1, B, 1, X, 2, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'CPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL CPBRFS( 'U', 2, 0, 1, A, 1, AF, 1, B, 2, X, 1, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'CPBRFS', INFOT, NOUT, LERR, OK ) +* +* CPBCON +* + SRNAMT = 'CPBCON' + INFOT = 1 + CALL CPBCON( '/', 0, 0, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CPBCON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPBCON( 'U', -1, 0, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CPBCON', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CPBCON( 'U', 1, -1, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CPBCON', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CPBCON( 'U', 2, 1, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CPBCON', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CPBCON( 'U', 1, 0, A, 1, -ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'CPBCON', INFOT, NOUT, LERR, OK ) +* +* CPBEQU +* + SRNAMT = 'CPBEQU' + INFOT = 1 + CALL CPBEQU( '/', 0, 0, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'CPBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPBEQU( 'U', -1, 0, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'CPBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CPBEQU( 'U', 1, -1, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'CPBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CPBEQU( 'U', 2, 1, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'CPBEQU', INFOT, NOUT, LERR, OK ) + END IF +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of CERRPO +* + END diff --git a/TESTING/LIN/cerrps.f b/TESTING/LIN/cerrps.f new file mode 100644 index 00000000..5d4e8f1d --- /dev/null +++ b/TESTING/LIN/cerrps.f @@ -0,0 +1,114 @@ + SUBROUTINE CERRPS( PATH, NUNIT ) +* +* -- LAPACK test routine (version 3.1) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + INTEGER NUNIT + CHARACTER*3 PATH +* .. +* +* Purpose +* ======= +* +* CERRPS tests the error exits for the COMPLEX routines +* for CPSTRF.. +* +* Arguments +* ========= +* +* PATH (input) CHARACTER*3 +* The LAPACK path name for the routines to be tested. +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 4 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J +* .. +* .. Local Arrays .. + COMPLEX A( NMAX, NMAX ) + REAL RWORK( 2*NMAX ) + INTEGER PIV( NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, CPSTF2, CPSTRF +* .. +* .. Scalars in Common .. + INTEGER INFOT, NOUT + LOGICAL LERR, OK + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO 110 J = 1, NMAX + DO 100 I = 1, NMAX + A( I, J ) = 1.0 / REAL( I+J ) +* + 100 CONTINUE + PIV( J ) = J + RWORK( J ) = 0. + RWORK( NMAX+J ) = 0. +* + 110 CONTINUE + OK = .TRUE. +* +* +* Test error exits of the routines that use the Cholesky +* decomposition of an Hermitian positive semidefinite matrix. +* +* CPSTRF +* + SRNAMT = 'CPSTRF' + INFOT = 1 + CALL CPSTRF( '/', 0, A, 1, PIV, 1, -1.0, RWORK, INFO ) + CALL CHKXER( 'CPSTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPSTRF( 'U', -1, A, 1, PIV, 1, -1.0, RWORK, INFO ) + CALL CHKXER( 'CPSTRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CPSTRF( 'U', 2, A, 1, PIV, 1, -1.0, RWORK, INFO ) + CALL CHKXER( 'CPSTRF', INFOT, NOUT, LERR, OK ) +* +* CPSTF2 +* + SRNAMT = 'CPSTF2' + INFOT = 1 + CALL CPSTF2( '/', 0, A, 1, PIV, 1, -1.0, RWORK, INFO ) + CALL CHKXER( 'CPSTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPSTF2( 'U', -1, A, 1, PIV, 1, -1.0, RWORK, INFO ) + CALL CHKXER( 'CPSTF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CPSTF2( 'U', 2, A, 1, PIV, 1, -1.0, RWORK, INFO ) + CALL CHKXER( 'CPSTF2', INFOT, NOUT, LERR, OK ) +* +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of CERRPS +* + END diff --git a/TESTING/LIN/cerrql.f b/TESTING/LIN/cerrql.f index c6b8177d..72eb34fb 100644 --- a/TESTING/LIN/cerrql.f +++ b/TESTING/LIN/cerrql.f @@ -43,7 +43,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cerrqp.f b/TESTING/LIN/cerrqp.f index 12e2345f..452ad22a 100644 --- a/TESTING/LIN/cerrqp.f +++ b/TESTING/LIN/cerrqp.f @@ -48,7 +48,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cerrqr.f b/TESTING/LIN/cerrqr.f index 40c2e5fb..d2dbcae9 100644 --- a/TESTING/LIN/cerrqr.f +++ b/TESTING/LIN/cerrqr.f @@ -43,7 +43,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cerrrfp.f b/TESTING/LIN/cerrrfp.f new file mode 100644 index 00000000..2c965458 --- /dev/null +++ b/TESTING/LIN/cerrrfp.f @@ -0,0 +1,250 @@ + SUBROUTINE CERRRFP( NUNIT ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER NUNIT +* .. +* +* Purpose +* ======= +* +* CERRRFP tests the error exits for the COMPLEX driver routines +* for solving linear systems of equations. +* +* CDRVRFP tests the COMPLEX LAPACK RFP routines: +* CTFSM, CTFTRI, CHFRK, CTFTTP, CTFTTR, CPFTRF, CPFTRS, CTPTTF, +* CTPTTR, CTRTTF, and CTRTTP +* +* Arguments +* ========= +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER INFO + COMPLEX ALPHA, BETA +* .. +* .. Local Arrays .. + COMPLEX A( 1, 1), B( 1, 1) +* .. +* .. External Subroutines .. + EXTERNAL CHKXER, CTFSM, CTFTRI, CHFRK, CTFTTP, CTFTTR, + + CPFTRI, CPFTRF, CPFTRS, CTPTTF, CTPTTR, CTRTTF, + + CTRTTP +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Intrinsic Functions .. + INTRINSIC CMPLX +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + OK = .TRUE. + A( 1, 1 ) = CMPLX( 1.D0 , 1.D0 ) + B( 1, 1 ) = CMPLX( 1.D0 , 1.D0 ) + ALPHA = CMPLX( 1.D0 , 1.D0 ) + BETA = CMPLX( 1.D0 , 1.D0 ) +* + SRNAMT = 'CPFTRF' + INFOT = 1 + CALL CPFTRF( '/', 'U', 0, A, INFO ) + CALL CHKXER( 'CPFTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPFTRF( 'N', '/', 0, A, INFO ) + CALL CHKXER( 'CPFTRF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CPFTRF( 'N', 'U', -1, A, INFO ) + CALL CHKXER( 'CPFTRF', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'CPFTRS' + INFOT = 1 + CALL CPFTRS( '/', 'U', 0, 0, A, B, 1, INFO ) + CALL CHKXER( 'CPFTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPFTRS( 'N', '/', 0, 0, A, B, 1, INFO ) + CALL CHKXER( 'CPFTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CPFTRS( 'N', 'U', -1, 0, A, B, 1, INFO ) + CALL CHKXER( 'CPFTRS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CPFTRS( 'N', 'U', 0, -1, A, B, 1, INFO ) + CALL CHKXER( 'CPFTRS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CPFTRS( 'N', 'U', 0, 0, A, B, 0, INFO ) + CALL CHKXER( 'CPFTRS', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'CPFTRI' + INFOT = 1 + CALL CPFTRI( '/', 'U', 0, A, INFO ) + CALL CHKXER( 'CPFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CPFTRI( 'N', '/', 0, A, INFO ) + CALL CHKXER( 'CPFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CPFTRI( 'N', 'U', -1, A, INFO ) + CALL CHKXER( 'CPFTRI', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'CTFSM ' + INFOT = 1 + CALL CTFSM( '/', 'L', 'U', 'C', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'CTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CTFSM( 'N', '/', 'U', 'C', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'CTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CTFSM( 'N', 'L', '/', 'C', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'CTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CTFSM( 'N', 'L', 'U', '/', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'CTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CTFSM( 'N', 'L', 'U', 'C', '/', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'CTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CTFSM( 'N', 'L', 'U', 'C', 'U', -1, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'CTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL CTFSM( 'N', 'L', 'U', 'C', 'U', 0, -1, ALPHA, A, B, 1 ) + CALL CHKXER( 'CTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL CTFSM( 'N', 'L', 'U', 'C', 'U', 0, 0, ALPHA, A, B, 0 ) + CALL CHKXER( 'CTFSM ', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'CTFTRI' + INFOT = 1 + CALL CTFTRI( '/', 'L', 'N', 0, A, INFO ) + CALL CHKXER( 'CTFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CTFTRI( 'N', '/', 'N', 0, A, INFO ) + CALL CHKXER( 'CTFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CTFTRI( 'N', 'L', '/', 0, A, INFO ) + CALL CHKXER( 'CTFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CTFTRI( 'N', 'L', 'N', -1, A, INFO ) + CALL CHKXER( 'CTFTRI', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'CTFTTR' + INFOT = 1 + CALL CTFTTR( '/', 'U', 0, A, B, 1, INFO ) + CALL CHKXER( 'CTFTTR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CTFTTR( 'N', '/', 0, A, B, 1, INFO ) + CALL CHKXER( 'CTFTTR', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CTFTTR( 'N', 'U', -1, A, B, 1, INFO ) + CALL CHKXER( 'CTFTTR', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL CTFTTR( 'N', 'U', 0, A, B, 0, INFO ) + CALL CHKXER( 'CTFTTR', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'CTRTTF' + INFOT = 1 + CALL CTRTTF( '/', 'U', 0, A, 1, B, INFO ) + CALL CHKXER( 'CTRTTF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CTRTTF( 'N', '/', 0, A, 1, B, INFO ) + CALL CHKXER( 'CTRTTF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CTRTTF( 'N', 'U', -1, A, 1, B, INFO ) + CALL CHKXER( 'CTRTTF', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CTRTTF( 'N', 'U', 0, A, 0, B, INFO ) + CALL CHKXER( 'CTRTTF', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'CTFTTP' + INFOT = 1 + CALL CTFTTP( '/', 'U', 0, A, B, INFO ) + CALL CHKXER( 'CTFTTP', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CTFTTP( 'N', '/', 0, A, B, INFO ) + CALL CHKXER( 'CTFTTP', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CTFTTP( 'N', 'U', -1, A, B, INFO ) + CALL CHKXER( 'CTFTTP', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'CTPTTF' + INFOT = 1 + CALL CTPTTF( '/', 'U', 0, A, B, INFO ) + CALL CHKXER( 'CTPTTF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CTPTTF( 'N', '/', 0, A, B, INFO ) + CALL CHKXER( 'CTPTTF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CTPTTF( 'N', 'U', -1, A, B, INFO ) + CALL CHKXER( 'CTPTTF', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'CTRTTP' + INFOT = 1 + CALL CTRTTP( '/', 0, A, 1, B, INFO ) + CALL CHKXER( 'CTRTTP', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CTRTTP( 'U', -1, A, 1, B, INFO ) + CALL CHKXER( 'CTRTTP', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CTRTTP( 'U', 0, A, 0, B, INFO ) + CALL CHKXER( 'CTRTTP', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'CTPTTR' + INFOT = 1 + CALL CTPTTR( '/', 0, A, B, 1, INFO ) + CALL CHKXER( 'CTPTTR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CTPTTR( 'U', -1, A, B, 1, INFO ) + CALL CHKXER( 'CTPTTR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CTPTTR( 'U', 0, A, B, 0, INFO ) + CALL CHKXER( 'CTPTTR', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'CHFRK ' + INFOT = 1 + CALL CHFRK( '/', 'U', 'N', 0, 0, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'CHFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL CHFRK( 'N', '/', 'N', 0, 0, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'CHFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL CHFRK( 'N', 'U', '/', 0, 0, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'CHFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL CHFRK( 'N', 'U', 'N', -1, 0, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'CHFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL CHFRK( 'N', 'U', 'N', 0, -1, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'CHFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL CHFRK( 'N', 'U', 'N', 0, 0, ALPHA, A, 0, BETA, B ) + CALL CHKXER( 'CHFRK ', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + IF( OK ) THEN + WRITE( NOUT, FMT = 9999 ) + ELSE + WRITE( NOUT, FMT = 9998 ) + END IF +* + 9999 FORMAT( 1X, 'COMPLEX RFP routines passed the tests of the ', + $ 'error exits' ) + 9998 FORMAT( ' *** RFP routines failed the tests of the error ', + $ 'exits ***' ) + RETURN +* +* End of CERRRFP +* + END diff --git a/TESTING/LIN/cerrrq.f b/TESTING/LIN/cerrrq.f index 7f552e68..2e920f95 100644 --- a/TESTING/LIN/cerrrq.f +++ b/TESTING/LIN/cerrrq.f @@ -43,7 +43,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cerrsy.f b/TESTING/LIN/cerrsy.f index a47b0e88..943925e1 100644 --- a/TESTING/LIN/cerrsy.f +++ b/TESTING/LIN/cerrsy.f @@ -52,7 +52,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cerrtr.f b/TESTING/LIN/cerrtr.f index 49d9e537..d84d75ac 100644 --- a/TESTING/LIN/cerrtr.f +++ b/TESTING/LIN/cerrtr.f @@ -50,7 +50,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cerrtz.f b/TESTING/LIN/cerrtz.f index 4e043c35..300a86dd 100644 --- a/TESTING/LIN/cerrtz.f +++ b/TESTING/LIN/cerrtz.f @@ -45,7 +45,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cerrvx.f b/TESTING/LIN/cerrvx.f index e9a213c0..5f7aa464 100644 --- a/TESTING/LIN/cerrvx.f +++ b/TESTING/LIN/cerrvx.f @@ -55,7 +55,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/cget07.f b/TESTING/LIN/cget07.f index 1219ebdb..e65038fc 100644 --- a/TESTING/LIN/cget07.f +++ b/TESTING/LIN/cget07.f @@ -1,5 +1,5 @@ SUBROUTINE CGET07( TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, - $ LDXACT, FERR, BERR, RESLTS ) + $ LDXACT, FERR, CHKFERR, BERR, RESLTS ) * * -- LAPACK test routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. @@ -7,6 +7,7 @@ * * .. Scalar Arguments .. CHARACTER TRANS + LOGICAL CHKFERR INTEGER LDA, LDB, LDX, LDXACT, N, NRHS * .. * .. Array Arguments .. @@ -79,6 +80,11 @@ * of the largest entry in (X - XTRUE) divided by the magnitude * of the largest entry in X. * +* CHKFERR (input) LOGICAL +* Set to .TRUE. to check FERR, .FALSE. not to check FERR. +* When the test system is ill-conditioned, the "true" +* solution in XACT may be incorrect. +* * BERR (input) REAL array, dimension (NRHS) * The componentwise relative backward error of each solution * vector (i.e., the smallest relative change in any entry of A @@ -136,30 +142,32 @@ * over all the vectors X and XACT using the infinity-norm. * ERRBND = ZERO - DO 30 J = 1, NRHS - IMAX = ICAMAX( N, X( 1, J ), 1 ) - XNORM = MAX( CABS1( X( IMAX, J ) ), UNFL ) - DIFF = ZERO - DO 10 I = 1, N - DIFF = MAX( DIFF, CABS1( X( I, J )-XACT( I, J ) ) ) - 10 CONTINUE -* - IF( XNORM.GT.ONE ) THEN - GO TO 20 - ELSE IF( DIFF.LE.OVFL*XNORM ) THEN - GO TO 20 - ELSE - ERRBND = ONE / EPS - GO TO 30 - END IF + IF( CHKFERR ) THEN + DO 30 J = 1, NRHS + IMAX = ICAMAX( N, X( 1, J ), 1 ) + XNORM = MAX( CABS1( X( IMAX, J ) ), UNFL ) + DIFF = ZERO + DO 10 I = 1, N + DIFF = MAX( DIFF, CABS1( X( I, J )-XACT( I, J ) ) ) + 10 CONTINUE +* + IF( XNORM.GT.ONE ) THEN + GO TO 20 + ELSE IF( DIFF.LE.OVFL*XNORM ) THEN + GO TO 20 + ELSE + ERRBND = ONE / EPS + GO TO 30 + END IF * - 20 CONTINUE - IF( DIFF / XNORM.LE.FERR( J ) ) THEN - ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) ) - ELSE - ERRBND = ONE / EPS - END IF - 30 CONTINUE + 20 CONTINUE + IF( DIFF / XNORM.LE.FERR( J ) ) THEN + ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) ) + ELSE + ERRBND = ONE / EPS + END IF + 30 CONTINUE + END IF RESLTS( 1 ) = ERRBND * * Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where diff --git a/TESTING/LIN/chkxer.f b/TESTING/LIN/chkxer.f index c3c4d8bb..9a7082b0 100644 --- a/TESTING/LIN/chkxer.f +++ b/TESTING/LIN/chkxer.f @@ -12,16 +12,16 @@ * * .. Scalar Arguments .. LOGICAL LERR, OK - CHARACTER*(*) SRNAMT + CHARACTER*(*) SRNAMT INTEGER INFOT, NOUT * .. -* .. External Functions .. - INTEGER ILA_LEN_TRIM - EXTERNAL ILA_LEN_TRIM +* .. Intrinsic Functions .. + INTRINSIC LEN_TRIM * .. * .. Executable Statements .. IF( .NOT.LERR ) THEN - WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT(1:ILA_LEN_TRIM(SRNAMT)) + WRITE( NOUT, FMT = 9999 )INFOT, + $ SRNAMT( 1:LEN_TRIM( SRNAMT ) ) OK = .FALSE. END IF LERR = .FALSE. diff --git a/TESTING/LIN/clahilb.f b/TESTING/LIN/clahilb.f new file mode 100644 index 00000000..8c495df1 --- /dev/null +++ b/TESTING/LIN/clahilb.f @@ -0,0 +1,210 @@ + SUBROUTINE CLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, + $ INFO, PATH) +! +! -- LAPACK auxiliary test routine (version 3.0) -- +! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +! Courant Institute, Argonne National Lab, and Rice University +! 28 August, 2006 +! +! David Vu <dtv@cs.berkeley.edu> +! Yozo Hida <yozo@cs.berkeley.edu> +! Jason Riedy <ejr@cs.berkeley.edu> +! D. Halligan <dhalligan@berkeley.edu> +! + IMPLICIT NONE +! .. Scalar Arguments .. + INTEGER T, N, NRHS, LDA, LDX, LDB, INFO +! .. Array Arguments .. + REAL WORK(N) + COMPLEX A(LDA,N), X(LDX, NRHS), B(LDB, NRHS) + CHARACTER*3 PATH +! .. +! +! Purpose +! ======= +! +! CLAHILB generates an N by N scaled Hilbert matrix in A along with +! NRHS right-hand sides in B and solutions in X such that A*X=B. +! +! The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all +! entries are integers. The right-hand sides are the first NRHS +! columns of M * the identity matrix, and the solutions are the +! first NRHS columns of the inverse Hilbert matrix. +! +! The condition number of the Hilbert matrix grows exponentially with +! its size, roughly as O(e ** (3.5*N)). Additionally, the inverse +! Hilbert matrices beyond a relatively small dimension cannot be +! generated exactly without extra precision. Precision is exhausted +! when the largest entry in the inverse Hilbert matrix is greater than +! 2 to the power of the number of bits in the fraction of the data type +! used plus one, which is 24 for single precision. +! +! In single, the generated solution is exact for N <= 6 and has +! small componentwise error for 7 <= N <= 11. +! +! Arguments +! ========= +! +! N (input) INTEGER +! The dimension of the matrix A. +! +! NRHS (input) NRHS +! The requested number of right-hand sides. +! +! A (output) COMPLEX array, dimension (LDA, N) +! The generated scaled Hilbert matrix. +! +! LDA (input) INTEGER +! The leading dimension of the array A. LDA >= N. +! +! X (output) COMPLEX array, dimension (LDX, NRHS) +! The generated exact solutions. Currently, the first NRHS +! columns of the inverse Hilbert matrix. +! +! LDX (input) INTEGER +! The leading dimension of the array X. LDX >= N. +! +! B (output) REAL array, dimension (LDB, NRHS) +! The generated right-hand sides. Currently, the first NRHS +! columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. +! +! LDB (input) INTEGER +! The leading dimension of the array B. LDB >= N. +! +! WORK (workspace) REAL array, dimension (N) +! +! +! INFO (output) INTEGER +! = 0: successful exit +! = 1: N is too large; the data is still generated but may not +! be not exact. +! < 0: if INFO = -i, the i-th argument had an illegal value +! +! ===================================================================== + +! .. Local Scalars .. + INTEGER TM, TI, R + INTEGER M + INTEGER I, J + COMPLEX TMP + CHARACTER*2 C2 + +! .. Parameters .. +! NMAX_EXACT the largest dimension where the generated data is +! exact. +! NMAX_APPROX the largest dimension where the generated data has +! a small componentwise relative error. +! ??? complex uses how many bits ??? + INTEGER NMAX_EXACT, NMAX_APPROX, SIZE_D + PARAMETER (NMAX_EXACT = 6, NMAX_APPROX = 11, SIZE_D = 8) + +! d's are generated from random permuation of those eight elements. + COMPLEX D1(8), D2(8), INVD1(8), INVD2(8) + DATA D1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/ + DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/ + + DATA INVD1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0), + $ (-.5,-.5),(.5,-.5),(.5,.5)/ + DATA INVD2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0), + $ (-.5,.5),(.5,.5),(.5,-.5)/ + +! .. +! .. External Functions + EXTERNAL CLASET, LSAMEN + INTRINSIC REAL + LOGICAL LSAMEN +! .. +! .. Executable Statements .. + C2 = PATH( 2: 3 ) +! +! Test the input arguments +! + INFO = 0 + IF (N .LT. 0 .OR. N .GT. NMAX_APPROX) THEN + INFO = -1 + ELSE IF (NRHS .LT. 0) THEN + INFO = -2 + ELSE IF (LDA .LT. N) THEN + INFO = -4 + ELSE IF (LDX .LT. N) THEN + INFO = -6 + ELSE IF (LDB .LT. N) THEN + INFO = -8 + END IF + IF (INFO .LT. 0) THEN + CALL XERBLA('CLAHILB', -INFO) + RETURN + END IF + IF (N .GT. NMAX_EXACT) THEN + INFO = 1 + END IF + +! Compute M = the LCM of the integers [1, 2*N-1]. The largest +! reasonable N is small enough that integers suffice (up to N = 11). + M = 1 + DO I = 2, (2*N-1) + TM = M + TI = I + R = MOD(TM, TI) + DO WHILE (R .NE. 0) + TM = TI + TI = R + R = MOD(TM, TI) + END DO + M = (M / TI) * I + END DO + +! Generate the scaled Hilbert matrix in A +! If we are testing SY routines, take D1_i = D2_i, else, D1_i = D2_i* + IF ( LSAMEN( 2, C2, 'SY' ) ) THEN + DO J = 1, N + DO I = 1, N + A(I, J) = D1(MOD(J,SIZE_D)+1) * (REAL(M) / (I + J - 1)) + $ * D1(MOD(I,SIZE_D)+1) + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, N + A(I, J) = D1(MOD(J,SIZE_D)+1) * (REAL(M) / (I + J - 1)) + $ * D2(MOD(I,SIZE_D)+1) + END DO + END DO + END IF + +! Generate matrix B as simply the first NRHS columns of M * the +! identity. + TMP = REAL(M) + CALL CLASET('Full', N, NRHS, (0.0,0.0), TMP, B, LDB) + +! Generate the true solutions in X. Because B = the first NRHS +! columns of M*I, the true solutions are just the first NRHS columns +! of the inverse Hilbert matrix. + WORK(1) = N + DO J = 2, N + WORK(J) = ( ( (WORK(J-1)/(J-1)) * (J-1 - N) ) /(J-1) ) + $ * (N +J -1) + END DO + +! If we are testing SY routines, take D1_i = D2_i, else, D1_i = D2_i* + IF ( LSAMEN( 2, C2, 'SY' ) ) THEN + DO J = 1, NRHS + DO I = 1, N + X(I, J) = + $ INVD1(MOD(J,SIZE_D)+1) * + $ ((WORK(I)*WORK(J)) / (I + J - 1)) + $ * INVD1(MOD(I,SIZE_D)+1) + END DO + END DO + ELSE + DO J = 1, NRHS + DO I = 1, N + X(I, J) = + $ INVD2(MOD(J,SIZE_D)+1) * + $ ((WORK(I)*WORK(J)) / (I + J - 1)) + $ * INVD1(MOD(I,SIZE_D)+1) + END DO + END DO + END IF + END + diff --git a/TESTING/LIN/clatb5.f b/TESTING/LIN/clatb5.f new file mode 100644 index 00000000..7ac3a8db --- /dev/null +++ b/TESTING/LIN/clatb5.f @@ -0,0 +1,166 @@ + SUBROUTINE CLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) +* +* -- LAPACK test routine (version 3.1) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + REAL ANORM, CNDNUM + INTEGER IMAT, KL, KU, MODE, N + CHARACTER DIST, TYPE + CHARACTER*3 PATH +* .. +* +* Purpose +* ======= +* +* CLATB5 sets parameters for the matrix generator based on the type +* of matrix to be generated. +* +* Arguments +* ========= +* +* PATH (input) CHARACTER*3 +* The LAPACK path name. +* +* IMAT (input) INTEGER +* An integer key describing which matrix to generate for this +* path. +* +* N (input) INTEGER +* The number of rows and columns in the matrix to be generated. +* +* TYPE (output) CHARACTER*1 +* The type of the matrix to be generated: +* = 'S': symmetric matrix +* = 'P': symmetric positive (semi)definite matrix +* = 'N': nonsymmetric matrix +* +* KL (output) INTEGER +* The lower band width of the matrix to be generated. +* +* KU (output) INTEGER +* The upper band width of the matrix to be generated. +* +* ANORM (output) REAL +* The desired norm of the matrix to be generated. The diagonal +* matrix of singular values or eigenvalues is scaled by this +* value. +* +* MODE (output) INTEGER +* A key indicating how to choose the vector of eigenvalues. +* +* CNDNUM (output) REAL +* The desired condition number. +* +* DIST (output) CHARACTER*1 +* The type of distribution to be used by the random number +* generator. +* +* ===================================================================== +* +* .. Parameters .. + REAL SHRINK, TENTH + PARAMETER ( SHRINK = 0.25E0, TENTH = 0.1E+0 ) + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) + REAL TWO + PARAMETER ( TWO = 2.0E+0 ) +* .. +* .. Local Scalars .. + REAL BADC1, BADC2, EPS, LARGE, SMALL + LOGICAL FIRST + CHARACTER*2 C2 +* .. +* .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Subroutines .. + EXTERNAL SLABAD +* .. +* .. Save statement .. + SAVE EPS, SMALL, LARGE, BADC1, BADC2, FIRST +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* +* Set some constants for use in the subroutine. +* + IF( FIRST ) THEN + FIRST = .FALSE. + EPS = SLAMCH( 'Precision' ) + BADC2 = TENTH / EPS + BADC1 = SQRT( BADC2 ) + SMALL = SLAMCH( 'Safe minimum' ) + LARGE = ONE / SMALL +* +* If it looks like we're on a Cray, take the square root of +* SMALL and LARGE to avoid overflow and underflow problems. +* + CALL SLABAD( SMALL, LARGE ) + SMALL = SHRINK*( SMALL / EPS ) + LARGE = ONE / SMALL + END IF +* + C2 = PATH( 2: 3 ) +* +* Set some parameters +* + DIST = 'S' + MODE = 3 +* +* Set TYPE, the type of matrix to be generated. +* + TYPE = C2( 1: 1 ) +* +* Set the lower and upper bandwidths. +* + IF( IMAT.EQ.1 ) THEN + KL = 0 + ELSE + KL = MAX( N-1, 0 ) + END IF + KU = KL +* +* Set the condition number and norm.etc +* + IF( IMAT.EQ.3 ) THEN + CNDNUM = 1.0E4 + MODE = 2 + ELSE IF( IMAT.EQ.4 ) THEN + CNDNUM = 1.0E4 + MODE = 1 + ELSE IF( IMAT.EQ.5 ) THEN + CNDNUM = 1.0E4 + MODE = 3 + ELSE IF( IMAT.EQ.6 ) THEN + CNDNUM = BADC1 + ELSE IF( IMAT.EQ.7 ) THEN + CNDNUM = BADC2 + ELSE + CNDNUM = TWO + END IF +* + IF( IMAT.EQ.8 ) THEN + ANORM = SMALL + ELSE IF( IMAT.EQ.9 ) THEN + ANORM = LARGE + ELSE + ANORM = ONE + END IF +* + IF( N.LE.1 ) + $ CNDNUM = ONE +* + RETURN +* +* End of SLATB5 +* + END diff --git a/TESTING/LIN/clqt01.f b/TESTING/LIN/clqt01.f index ca4a5478..6997a24a 100644 --- a/TESTING/LIN/clqt01.f +++ b/TESTING/LIN/clqt01.f @@ -87,7 +87,7 @@ INTRINSIC CMPLX, MAX, MIN, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/clqt02.f b/TESTING/LIN/clqt02.f index caa0d97b..57000311 100644 --- a/TESTING/LIN/clqt02.f +++ b/TESTING/LIN/clqt02.f @@ -93,7 +93,7 @@ INTRINSIC CMPLX, MAX, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/clqt03.f b/TESTING/LIN/clqt03.f index 25c2cd79..e8f811b2 100644 --- a/TESTING/LIN/clqt03.f +++ b/TESTING/LIN/clqt03.f @@ -99,7 +99,7 @@ INTRINSIC CMPLX, MAX, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/cpst01.f b/TESTING/LIN/cpst01.f new file mode 100644 index 00000000..70891d92 --- /dev/null +++ b/TESTING/LIN/cpst01.f @@ -0,0 +1,243 @@ + SUBROUTINE CPST01( UPLO, N, A, LDA, AFAC, LDAFAC, PERM, LDPERM, + $ PIV, RWORK, RESID, RANK ) +* +* -- LAPACK test routine (version 3.1) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + REAL RESID + INTEGER LDA, LDAFAC, LDPERM, N, RANK + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX A( LDA, * ), AFAC( LDAFAC, * ), + $ PERM( LDPERM, * ) + REAL RWORK( * ) + INTEGER PIV( * ) +* .. +* +* Purpose +* ======= +* +* CPST01 reconstructs an Hermitian positive semidefinite matrix A +* from its L or U factors and the permutation matrix P and computes +* the residual +* norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or +* norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ), +* where EPS is the machine epsilon, L' is the conjugate transpose of L, +* and U' is the conjugate transpose of U. +* +* Arguments +* ========== +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* Hermitian matrix A is stored: +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The number of rows and columns of the matrix A. N >= 0. +* +* A (input) COMPLEX array, dimension (LDA,N) +* The original Hermitian matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N) +* +* AFAC (input) COMPLEX array, dimension (LDAFAC,N) +* The factor L or U from the L*L' or U'*U +* factorization of A. +* +* LDAFAC (input) INTEGER +* The leading dimension of the array AFAC. LDAFAC >= max(1,N). +* +* PERM (output) COMPLEX array, dimension (LDPERM,N) +* Overwritten with the reconstructed matrix, and then with the +* difference P*L*L'*P' - A (or P*U'*U*P' - A) +* +* LDPERM (input) INTEGER +* The leading dimension of the array PERM. +* LDAPERM >= max(1,N). +* +* PIV (input) INTEGER array, dimension (N) +* PIV is such that the nonzero entries are +* P( PIV( K ), K ) = 1. +* +* RWORK (workspace) REAL array, dimension (N) +* +* RESID (output) REAL +* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) +* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + COMPLEX CZERO + PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) ) +* .. +* .. Local Scalars .. + COMPLEX TC + REAL ANORM, EPS, TR + INTEGER I, J, K +* .. +* .. External Functions .. + COMPLEX CDOTC + REAL CLANHE, SLAMCH + LOGICAL LSAME + EXTERNAL CDOTC, CLANHE, SLAMCH, LSAME +* .. +* .. External Subroutines .. + EXTERNAL CHER, CSCAL, CTRMV +* .. +* .. Intrinsic Functions .. + INTRINSIC AIMAG, CONJG, REAL +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Exit with RESID = 1/EPS if ANORM = 0. +* + EPS = SLAMCH( 'Epsilon' ) + ANORM = CLANHE( '1', UPLO, N, A, LDA, RWORK ) + IF( ANORM.LE.ZERO ) THEN + RESID = ONE / EPS + RETURN + END IF +* +* Check the imaginary parts of the diagonal elements and return with +* an error code if any are nonzero. +* + DO 100 J = 1, N + IF( AIMAG( AFAC( J, J ) ).NE.ZERO ) THEN + RESID = ONE / EPS + RETURN + END IF + 100 CONTINUE +* +* Compute the product U'*U, overwriting U. +* + IF( LSAME( UPLO, 'U' ) ) THEN +* + IF( RANK.LT.N ) THEN + DO 120 J = RANK + 1, N + DO 110 I = RANK + 1, J + AFAC( I, J ) = CZERO + 110 CONTINUE + 120 CONTINUE + END IF +* + DO 130 K = N, 1, -1 +* +* Compute the (K,K) element of the result. +* + TR = CDOTC( K, AFAC( 1, K ), 1, AFAC( 1, K ), 1 ) + AFAC( K, K ) = TR +* +* Compute the rest of column K. +* + CALL CTRMV( 'Upper', 'Conjugate', 'Non-unit', K-1, AFAC, + $ LDAFAC, AFAC( 1, K ), 1 ) +* + 130 CONTINUE +* +* Compute the product L*L', overwriting L. +* + ELSE +* + IF( RANK.LT.N ) THEN + DO 150 J = RANK + 1, N + DO 140 I = J, N + AFAC( I, J ) = CZERO + 140 CONTINUE + 150 CONTINUE + END IF +* + DO 160 K = N, 1, -1 +* Add a multiple of column K of the factor L to each of +* columns K+1 through N. +* + IF( K+1.LE.N ) + $ CALL CHER( 'Lower', N-K, ONE, AFAC( K+1, K ), 1, + $ AFAC( K+1, K+1 ), LDAFAC ) +* +* Scale column K by the diagonal element. +* + TC = AFAC( K, K ) + CALL CSCAL( N-K+1, TC, AFAC( K, K ), 1 ) + 160 CONTINUE +* + END IF +* +* Form P*L*L'*P' or P*U'*U*P' +* + IF( LSAME( UPLO, 'U' ) ) THEN +* + DO 180 J = 1, N + DO 170 I = 1, N + IF( PIV( I ).LE.PIV( J ) ) THEN + IF( I.LE.J ) THEN + PERM( PIV( I ), PIV( J ) ) = AFAC( I, J ) + ELSE + PERM( PIV( I ), PIV( J ) ) = CONJG( AFAC( J, I ) ) + END IF + END IF + 170 CONTINUE + 180 CONTINUE +* +* + ELSE +* + DO 200 J = 1, N + DO 190 I = 1, N + IF( PIV( I ).GE.PIV( J ) ) THEN + IF( I.GE.J ) THEN + PERM( PIV( I ), PIV( J ) ) = AFAC( I, J ) + ELSE + PERM( PIV( I ), PIV( J ) ) = CONJG( AFAC( J, I ) ) + END IF + END IF + 190 CONTINUE + 200 CONTINUE +* + END IF +* +* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A). +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 220 J = 1, N + DO 210 I = 1, J - 1 + PERM( I, J ) = PERM( I, J ) - A( I, J ) + 210 CONTINUE + PERM( J, J ) = PERM( J, J ) - REAL( A( J, J ) ) + 220 CONTINUE + ELSE + DO 240 J = 1, N + PERM( J, J ) = PERM( J, J ) - REAL( A( J, J ) ) + DO 230 I = J + 1, N + PERM( I, J ) = PERM( I, J ) - A( I, J ) + 230 CONTINUE + 240 CONTINUE + END IF +* +* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or +* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). +* + RESID = CLANHE( '1', UPLO, N, PERM, LDAFAC, RWORK ) +* + RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS +* + RETURN +* +* End of CPST01 +* + END diff --git a/TESTING/LIN/cqlt01.f b/TESTING/LIN/cqlt01.f index e257ade6..6bfc60fb 100644 --- a/TESTING/LIN/cqlt01.f +++ b/TESTING/LIN/cqlt01.f @@ -87,7 +87,7 @@ INTRINSIC CMPLX, MAX, MIN, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/cqlt02.f b/TESTING/LIN/cqlt02.f index 54b6ca9d..7fb03aaa 100644 --- a/TESTING/LIN/cqlt02.f +++ b/TESTING/LIN/cqlt02.f @@ -94,7 +94,7 @@ INTRINSIC CMPLX, MAX, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/cqlt03.f b/TESTING/LIN/cqlt03.f index 9db1ba12..01e7a69d 100644 --- a/TESTING/LIN/cqlt03.f +++ b/TESTING/LIN/cqlt03.f @@ -99,7 +99,7 @@ INTRINSIC CMPLX, MAX, MIN, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/cqrt01.f b/TESTING/LIN/cqrt01.f index 62322c78..e940a7db 100644 --- a/TESTING/LIN/cqrt01.f +++ b/TESTING/LIN/cqrt01.f @@ -87,7 +87,7 @@ INTRINSIC CMPLX, MAX, MIN, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/cqrt02.f b/TESTING/LIN/cqrt02.f index 975edced..0c53df9f 100644 --- a/TESTING/LIN/cqrt02.f +++ b/TESTING/LIN/cqrt02.f @@ -93,7 +93,7 @@ INTRINSIC CMPLX, MAX, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/cqrt03.f b/TESTING/LIN/cqrt03.f index 161813d2..01f29aed 100644 --- a/TESTING/LIN/cqrt03.f +++ b/TESTING/LIN/cqrt03.f @@ -99,7 +99,7 @@ INTRINSIC CMPLX, MAX, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/crqt01.f b/TESTING/LIN/crqt01.f index ad1fd789..94bf4f1b 100644 --- a/TESTING/LIN/crqt01.f +++ b/TESTING/LIN/crqt01.f @@ -87,7 +87,7 @@ INTRINSIC CMPLX, MAX, MIN, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/crqt02.f b/TESTING/LIN/crqt02.f index 3c939803..ab54f3ff 100644 --- a/TESTING/LIN/crqt02.f +++ b/TESTING/LIN/crqt02.f @@ -94,7 +94,7 @@ INTRINSIC CMPLX, MAX, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/crqt03.f b/TESTING/LIN/crqt03.f index caa28acd..002ca8fd 100644 --- a/TESTING/LIN/crqt03.f +++ b/TESTING/LIN/crqt03.f @@ -99,7 +99,7 @@ INTRINSIC CMPLX, MAX, MIN, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/dchkaa.f b/TESTING/LIN/dchkaa.f index 61c01241..9ac2c288 100644 --- a/TESTING/LIN/dchkaa.f +++ b/TESTING/LIN/dchkaa.f @@ -26,6 +26,8 @@ * 5 Number of values of NB * 1 3 3 3 20 Values of NB (the blocksize) * 1 0 5 9 1 Values of NX (crossover point) +* 3 Number of values of RANK +* 30 50 90 Values of rank (as a % of N) * 20.0 Threshold value of test ratio * T Put T to test the LAPACK routines * T Put T to test the driver routines @@ -34,6 +36,7 @@ * DGB 8 List types on next line if 0 < NTYPES < 8 * DGT 12 List types on next line if 0 < NTYPES < 12 * DPO 9 List types on next line if 0 < NTYPES < 9 +* DPS 9 List types on next line if 0 < NTYPES < 9 * DPP 9 List types on next line if 0 < NTYPES < 9 * DPB 8 List types on next line if 0 < NTYPES < 8 * DPT 12 List types on next line if 0 < NTYPES < 12 @@ -94,7 +97,7 @@ CHARACTER*10 INTSTR CHARACTER*72 ALINE INTEGER I, IC, J, K, LA, LAFAC, LDA, NB, NM, NMATS, NN, - $ NNB, NNB2, NNS, NRHS, NTYPES, + $ NNB, NNB2, NNS, NRHS, NTYPES, NRANK, $ VERS_MAJOR, VERS_MINOR, VERS_PATCH DOUBLE PRECISION EPS, S1, S2, THREQ, THRESH * .. @@ -102,7 +105,8 @@ LOGICAL DOTYPE( MATMAX ) INTEGER IWORK( 25*NMAX ), MVAL( MAXIN ), $ NBVAL( MAXIN ), NBVAL2( MAXIN ), - $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ) + $ 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 ) @@ -114,15 +118,15 @@ * .. * .. External Subroutines .. EXTERNAL ALAREQ, DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ, - $ DCHKPB, DCHKPO, DCHKPP, DCHKPT, DCHKQ3, DCHKQL, - $ DCHKQP, DCHKQR, DCHKRQ, DCHKSP, DCHKSY, DCHKTB, - $ DCHKTP, DCHKTR, DCHKTZ, DDRVGB, DDRVGE, DDRVGT, - $ DDRVLS, DDRVPB, DDRVPO, DDRVPP, DDRVPT, DDRVSP, - $ DDRVSY, ILAVER + $ DCHKPB, DCHKPO, DCHKPS, DCHKPP, DCHKPT, DCHKQ3, + $ DCHKQL, DCHKQP, DCHKQR, DCHKRQ, DCHKSP, DCHKSY, + $ DCHKTB, DCHKTP, DCHKTR, DCHKTZ, DDRVGB, DDRVGE, + $ DDRVGT, DDRVLS, DDRVPB, DDRVPO, DDRVPP, DDRVPT, + $ DDRVSP, DDRVSY, ILAVER * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Arrays in Common .. @@ -273,6 +277,32 @@ IF( NNB.GT.0 ) $ WRITE( NOUT, FMT = 9993 )'NX ', ( NXVAL( I ), I = 1, NNB ) * +* Read the values of RANKVAL +* + READ( NIN, FMT = * )NRANK + IF( NN.LT.1 ) THEN + WRITE( NOUT, FMT = 9996 )' NRANK ', NRANK, 1 + NRANK = 0 + FATAL = .TRUE. + ELSE IF( NN.GT.MAXIN ) THEN + WRITE( NOUT, FMT = 9995 )' NRANK ', NRANK, MAXIN + NRANK = 0 + FATAL = .TRUE. + END IF + READ( NIN, FMT = * )( RANKVAL( I ), I = 1, NRANK ) + DO I = 1, NRANK + IF( RANKVAL( I ).LT.0 ) THEN + WRITE( NOUT, FMT = 9996 )' RANK ', RANKVAL( I ), 0 + FATAL = .TRUE. + ELSE IF( RANKVAL( I ).GT.100 ) THEN + WRITE( NOUT, FMT = 9995 )' RANK ', RANKVAL( I ), 100 + FATAL = .TRUE. + END IF + END DO + IF( NRANK.GT.0 ) + $ WRITE( NOUT, FMT = 9993 )'RANK % OF N', + $ ( RANKVAL( I ), I = 1, NRANK ) +* * Read the threshold value for the test ratios. * READ( NIN, FMT = * )THRESH @@ -453,6 +483,23 @@ WRITE( NOUT, FMT = 9988 )PATH END IF * + ELSE IF( LSAMEN( 2, C2, 'PS' ) ) THEN +* +* PS: positive semi-definite matrices +* + NTYPES = 9 +* + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL DCHKPS( DOTYPE, NN, NVAL, NNB2, NBVAL2, NRANK, + $ RANKVAL, THRESH, TSTERR, LDA, A( 1, 1 ), + $ A( 1, 2 ), A( 1, 3 ), PIV, WORK, RWORK, + $ NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN * * PP: positive definite packed matrices diff --git a/TESTING/LIN/dchkab.f b/TESTING/LIN/dchkab.f index 44054817..6f140057 100644 --- a/TESTING/LIN/dchkab.f +++ b/TESTING/LIN/dchkab.f @@ -9,23 +9,24 @@ * ======= * * DCHKAB is the test program for the DOUBLE PRECISION LAPACK -* DSGESV routine +* DSGESV/DSPOSV routine * * The program must be driven by a short data file. The first 5 records * specify problem dimensions and program options using list-directed * input. The remaining lines specify the LAPACK test paths and the * number of matrix types to use in testing. An annotated example of a * data file can be obtained by deleting the first 3 characters from the -* following 9 lines: +* following 10 lines: * Data file for testing DOUBLE PRECISION LAPACK DSGESV * 7 Number of values of M * 0 1 2 3 5 10 16 Values of M (row dimension) * 1 Number of values of NRHS * 2 Values of NRHS (number of right hand sides) * 20.0 Threshold value of test ratio -* T Put T to test the DSGESV routine -* T Put T to test the error exits for DSGESV -* 11 List types on next line if 0 < NTYPES < 11 +* T Put T to test the LAPACK routines +* T Put T to test the error exits +* DGE 11 List types on next line if 0 < NTYPES < 11 +* DPO 9 List types on next line if 0 < NTYPES < 9 * * Internal Parameters * =================== @@ -64,7 +65,12 @@ * .. * .. Local Scalars .. LOGICAL FATAL, TSTDRV, TSTERR - INTEGER I, LDA, NM, NMATS, + CHARACTER C1 + CHARACTER*2 C2 + CHARACTER*3 PATH + CHARACTER*10 INTSTR + CHARACTER*72 ALINE + INTEGER I, IC, K, LDA, NM, NMATS, $ NNS, NRHS, NTYPES, $ VERS_MAJOR, VERS_MINOR, VERS_PATCH DOUBLE PRECISION EPS, S1, S2, THRESH @@ -79,21 +85,25 @@ * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DSECND + LOGICAL LSAME, LSAMEN REAL SLAMCH - EXTERNAL DLAMCH, DSECND, SLAMCH + EXTERNAL LSAME, LSAMEN, DLAMCH, DSECND, SLAMCH * .. * .. External Subroutines .. - EXTERNAL ALAREQ, DERRAB, ILAVER + EXTERNAL ALAREQ, DERRGX, DERRPX, ILAVER * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. COMMON / INFOC / INFOT, NUNIT, OK, LERR COMMON / SRNAMC / SRNAMT * .. +* .. Data statements .. + DATA INTSTR / '0123456789' / +* .. * .. Executable Statements .. * S1 = DSECND( ) @@ -195,35 +205,107 @@ WRITE( NOUT, FMT = 9991 )'(double precision) precision', EPS WRITE( NOUT, FMT = * ) * + 80 CONTINUE +* +* Read a test path and the number of matrix types to use. +* + READ( NIN, FMT = '(A72)', END = 140 )ALINE + PATH = ALINE( 1: 3 ) + NMATS = MATMAX + I = 3 + 90 CONTINUE + I = I + 1 + IF( I.GT.72 ) THEN + NMATS = MATMAX + GO TO 130 + END IF + IF( ALINE( I: I ).EQ.' ' ) + $ GO TO 90 + NMATS = 0 + 100 CONTINUE + C1 = ALINE( I: I ) + DO 110 K = 1, 10 + IF( C1.EQ.INTSTR( K: K ) ) THEN + IC = K - 1 + GO TO 120 + END IF + 110 CONTINUE + GO TO 130 + 120 CONTINUE + NMATS = NMATS*10 + IC + I = I + 1 + IF( I.GT.72 ) + $ GO TO 130 + GO TO 100 + 130 CONTINUE + C1 = PATH( 1: 1 ) + C2 = PATH( 2: 3 ) NRHS = NSVAL( 1 ) - READ( NIN, FMT = * ) NMATS * - IF( NMATS.LE.0 ) THEN +* Check first character for correct precision. +* + IF( .NOT.LSAME( C1, 'Double precision' ) ) THEN + WRITE( NOUT, FMT = 9990 )PATH + +* + ELSE IF( NMATS.LE.0 ) THEN * * Check for a positive number of tests requested. * - WRITE( NOUT, FMT = 9990 )'DSGESV' + WRITE( NOUT, FMT = 9989 )PATH GO TO 140 * - END IF + ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN +* +* GE: general matrices +* + NTYPES = 11 + CALL ALAREQ( 'DGE', NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* +* Test the error exits * - NTYPES = 11 - CALL ALAREQ( 'DGE', NMATS, DOTYPE, NTYPES, NIN, NOUT ) + IF( TSTERR ) + $ CALL DERRAB( NOUT ) * -* Test the error exits + IF( TSTDRV ) THEN + CALL DDRVAB( DOTYPE, NM, MVAL, NNS, + $ NSVAL, THRESH, LDA, A( 1, 1 ), + $ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), + $ WORK, RWORK, SWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )'DSGESV' + END IF +* + ELSE IF( LSAMEN( 2, C2, 'PO' ) ) THEN +* +* PO: positive definite matrices +* + NTYPES = 9 + CALL ALAREQ( 'DPO', NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* +* + IF( TSTERR ) + $ CALL DERRAC( NOUT ) * - IF( TSTERR ) - $ CALL DERRAB( NOUT ) * - IF( TSTDRV ) THEN - CALL DDRVAB( DOTYPE, NM, MVAL, NNS, - $ NSVAL, THRESH, LDA, A( 1, 1 ), - $ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), - $ WORK, RWORK, SWORK, IWORK, NOUT ) + IF( TSTDRV ) THEN + CALL DDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, + $ THRESH, LDA, A( 1, 1 ), A( 1, 2 ), + $ B( 1, 1 ), B( 1, 2 ), + $ WORK, RWORK, SWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF ELSE - WRITE( NOUT, FMT = 9989 )'DSGESV' +* END IF * +* Go back to get another input line. +* + GO TO 80 +* +* Branch to this line when the last record is read. +* 140 CONTINUE CLOSE ( NIN ) S2 = DSECND( ) @@ -237,7 +319,8 @@ $ I6 ) 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', $ I6 ) - 9994 FORMAT( ' Tests of the DOUBLE PRECISION LAPACK DSGESV routines ', + 9994 FORMAT( ' Tests of the DOUBLE PRECISION LAPACK DSGESV/DSPOSV', + $ ' routines ', $ / ' LAPACK VERSION ', I1, '.', I1, '.', I1, $ / / ' The following parameter values will be used:' ) 9993 FORMAT( 4X, A4, ': ', 10I6, / 11X, 10I6 ) @@ -246,6 +329,7 @@ 9991 FORMAT( ' Relative machine ', A, ' is taken to be', D16.6 ) 9990 FORMAT( / 1X, A6, ' routines were not tested' ) 9989 FORMAT( / 1X, A6, ' driver routines were not tested' ) + 9988 FORMAT( / 1X, A3, ': Unrecognized path name' ) * * End of DCHKAB * diff --git a/TESTING/LIN/dchkgb.f b/TESTING/LIN/dchkgb.f index f9698843..6d23ae91 100644 --- a/TESTING/LIN/dchkgb.f +++ b/TESTING/LIN/dchkgb.f @@ -140,7 +140,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dchkge.f b/TESTING/LIN/dchkge.f index 8ec0e5e1..b3628af6 100644 --- a/TESTING/LIN/dchkge.f +++ b/TESTING/LIN/dchkge.f @@ -127,14 +127,14 @@ EXTERNAL ALAERH, ALAHD, ALASUM, DERRGE, DGECON, DGERFS, $ DGET01, DGET02, DGET03, DGET04, DGET07, DGETRF, $ DGETRI, DGETRS, DLACPY, DLARHS, DLASET, DLATB4, - $ DLATMS, XLAENV + $ DLATMS, DERRGEX, XLAENV * .. * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. @@ -406,7 +406,7 @@ CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, $ RESULT( 5 ) ) CALL DGET07( TRANS, N, NRHS, A, LDA, B, LDA, X, - $ LDA, XACT, LDA, RWORK, + $ LDA, XACT, LDA, RWORK, .TRUE., $ RWORK( NRHS+1 ), RESULT( 6 ) ) * * Print information about the tests that did not diff --git a/TESTING/LIN/dchkgt.f b/TESTING/LIN/dchkgt.f index 53c20e84..250875b8 100644 --- a/TESTING/LIN/dchkgt.f +++ b/TESTING/LIN/dchkgt.f @@ -112,7 +112,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dchklq.f b/TESTING/LIN/dchklq.f index 5df09e98..350c7ceb 100644 --- a/TESTING/LIN/dchklq.f +++ b/TESTING/LIN/dchklq.f @@ -135,7 +135,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dchkpb.f b/TESTING/LIN/dchkpb.f index 14c98353..b762be21 100644 --- a/TESTING/LIN/dchkpb.f +++ b/TESTING/LIN/dchkpb.f @@ -124,7 +124,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dchkpo.f b/TESTING/LIN/dchkpo.f index 89575bcf..9535b1aa 100644 --- a/TESTING/LIN/dchkpo.f +++ b/TESTING/LIN/dchkpo.f @@ -121,7 +121,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dchkpp.f b/TESTING/LIN/dchkpp.f index 6158a1f6..4f07f855 100644 --- a/TESTING/LIN/dchkpp.f +++ b/TESTING/LIN/dchkpp.f @@ -118,7 +118,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dchkps.f b/TESTING/LIN/dchkps.f new file mode 100644 index 00000000..6d7a884d --- /dev/null +++ b/TESTING/LIN/dchkps.f @@ -0,0 +1,268 @@ + SUBROUTINE DCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK, + $ RWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + DOUBLE PRECISION THRESH + INTEGER NMAX, NN, NNB, NOUT, NRANK + LOGICAL TSTERR +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( * ), AFAC( * ), PERM( * ), RWORK( * ), + $ WORK( * ) + INTEGER NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * ) + LOGICAL DOTYPE( * ) +* .. +* +* Purpose +* ======= +* +* DCHKPS tests DPSTRF. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* NNB (input) INTEGER +* The number of values of NB contained in the vector NBVAL. +* +* NBVAL (input) INTEGER array, dimension (NBVAL) +* The values of the block size NB. +* +* NRANK (input) INTEGER +* The number of values of RANK contained in the vector RANKVAL. +* +* RANKVAL (input) INTEGER array, dimension (NBVAL) +* The values of the block size NB. +* +* THRESH (input) 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. +* +* TSTERR (input) LOGICAL +* Flag that indicates whether error exits are to be tested. +* +* NMAX (input) INTEGER +* The maximum value permitted for N, used in dimensioning the +* work arrays. +* +* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) +* +* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) +* +* PERM (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) +* +* PIV (workspace) INTEGER array, dimension (NMAX) +* +* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*3) +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 9 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION ANORM, CNDNUM, RESULT, TOL + INTEGER COMPRANK, I, IMAT, IN, INB, INFO, IRANK, IUPLO, + $ IZERO, KL, KU, LDA, MODE, N, NB, NERRS, NFAIL, + $ NIMAT, NRUN, RANK, RANKDIFF + CHARACTER DIST, TYPE, UPLO + CHARACTER*3 PATH +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ), ISEEDY( 4 ) + CHARACTER UPLOS( 2 ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRPS, DLACPY, DLATB5, + $ DLATMT, DPST01, DPSTRF, XLAENV +* .. +* .. Scalars in Common .. + INTEGER INFOT, NUNIT + LOGICAL LERR, OK + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, CEILING +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'PS' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 100 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 100 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL DERRPS( PATH, NOUT ) + INFOT = 0 + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 150 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 + DO 140 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 140 +* +* Do for each value of RANK in RANKVAL +* + DO 130 IRANK = 1, NRANK +* +* Only repeat test 3 to 5 for different ranks +* Other tests use full rank +* + IF( ( IMAT.LT.3 .OR. IMAT.GT.5 ) .AND. IRANK.GT.1 ) + $ GO TO 130 +* + RANK = CEILING( ( N * DBLE( RANKVAL( IRANK ) ) ) + $ / 100.D+0 ) +* +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 120 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with DLATB5 and generate a test matrix +* with DLATMT. +* + CALL DLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'DLATMT' + CALL DLATMT( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, RANK, KL, KU, UPLO, A, + $ LDA, WORK, INFO ) +* +* Check error code from DLATMT. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMT', INFO, 0, UPLO, N, + $ N, -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + GO TO 120 + END IF +* +* Do for each value of NB in NBVAL +* + DO 110 INB = 1, NNB + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Compute the pivoted L*L' or U'*U factorization +* of the matrix. +* + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + SRNAMT = 'DPSTRF' +* +* Use default tolerance +* + TOL = -ONE + CALL DPSTRF( UPLO, N, AFAC, LDA, PIV, COMPRANK, + $ TOL, WORK, INFO ) +* +* Check error code from DPSTRF. +* + IF( (INFO.LT.IZERO) + $ .OR.(INFO.NE.IZERO.AND.RANK.EQ.N) + $ .OR.(INFO.LE.IZERO.AND.RANK.LT.N) ) THEN + CALL ALAERH( PATH, 'DPSTRF', INFO, IZERO, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) + GO TO 110 + END IF +* +* Skip the test if INFO is not 0. +* + IF( INFO.NE.0 ) + $ GO TO 110 +* +* Reconstruct matrix from factors and compute residual. +* +* PERM holds permuted L*L^T or U^T*U +* + CALL DPST01( UPLO, N, A, LDA, AFAC, LDA, PERM, LDA, + $ PIV, RWORK, RESULT, COMPRANK ) +* +* Print information about the tests that did not pass +* the threshold or where computed rank was not RANK. +* + IF( N.EQ.0 ) + $ COMPRANK = 0 + RANKDIFF = RANK - COMPRANK + IF( RESULT.GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, RANK, + $ RANKDIFF, NB, IMAT, RESULT + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 110 CONTINUE +* + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', RANK =', I3, + $ ', Diff =', I5, ', NB =', I4, ', type ', I2, ', Ratio =', + $ G12.5 ) + RETURN +* +* End of DCHKPS +* + END diff --git a/TESTING/LIN/dchkpt.f b/TESTING/LIN/dchkpt.f index f88d7111..297c04ea 100644 --- a/TESTING/LIN/dchkpt.f +++ b/TESTING/LIN/dchkpt.f @@ -111,7 +111,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dchkq3.f b/TESTING/LIN/dchkq3.f index 2d63281e..797e42a4 100644 --- a/TESTING/LIN/dchkq3.f +++ b/TESTING/LIN/dchkq3.f @@ -115,7 +115,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dchkql.f b/TESTING/LIN/dchkql.f index 470ed770..857bc2e2 100644 --- a/TESTING/LIN/dchkql.f +++ b/TESTING/LIN/dchkql.f @@ -135,7 +135,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dchkqp.f b/TESTING/LIN/dchkqp.f index 2989a232..ce04030d 100644 --- a/TESTING/LIN/dchkqp.f +++ b/TESTING/LIN/dchkqp.f @@ -106,7 +106,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dchkqr.f b/TESTING/LIN/dchkqr.f index 5ac74e6a..d9a9b40d 100644 --- a/TESTING/LIN/dchkqr.f +++ b/TESTING/LIN/dchkqr.f @@ -135,7 +135,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dchkrfp.f b/TESTING/LIN/dchkrfp.f new file mode 100644 index 00000000..3e8a4e4b --- /dev/null +++ b/TESTING/LIN/dchkrfp.f @@ -0,0 +1,264 @@ + PROGRAM DCHKRFP + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* Purpose +* ======= +* +* DCHKRFP is the main test program for the DOUBLE PRECISION linear +* equation routines with RFP storage format +* +* +* Internal Parameters +* =================== +* +* MAXIN INTEGER +* The number of different values that can be used for each of +* M, N, or NB +* +* MAXRHS INTEGER +* The maximum number of right hand sides +* +* NTYPES INTEGER +* +* NMAX INTEGER +* The maximum allowable value for N. +* +* NIN INTEGER +* The unit number for input +* +* NOUT INTEGER +* The unit number for output +* +* ===================================================================== +* +* .. Parameters .. + INTEGER MAXIN + PARAMETER ( MAXIN = 12 ) + INTEGER NMAX + PARAMETER ( NMAX = 50 ) + INTEGER MAXRHS + PARAMETER ( MAXRHS = 16 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 9 ) + INTEGER NIN, NOUT + PARAMETER ( NIN = 5, NOUT = 6 ) +* .. +* .. Local Scalars .. + LOGICAL FATAL, TSTERR + INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH + INTEGER I, NN, NNS, NNT + DOUBLE PRECISION EPS, S1, S2, THRESH + +* .. +* .. Local Arrays .. + INTEGER NVAL( MAXIN ), NSVAL( MAXIN ), NTVAL( NTYPES ) + DOUBLE PRECISION WORKA( NMAX, NMAX ) + DOUBLE PRECISION WORKASAV( NMAX, NMAX ) + DOUBLE PRECISION WORKB( NMAX, MAXRHS ) + DOUBLE PRECISION WORKXACT( NMAX, MAXRHS ) + DOUBLE PRECISION WORKBSAV( NMAX, MAXRHS ) + DOUBLE PRECISION WORKX( NMAX, MAXRHS ) + DOUBLE PRECISION WORKAFAC( NMAX, NMAX ) + DOUBLE PRECISION WORKAINV( NMAX, NMAX ) + DOUBLE PRECISION WORKARF( (NMAX*(NMAX+1))/2 ) + DOUBLE PRECISION WORKAP( (NMAX*(NMAX+1))/2 ) + DOUBLE PRECISION WORKARFINV( (NMAX*(NMAX+1))/2 ) + DOUBLE PRECISION D_WORK_DLATMS( 3 * NMAX ) + DOUBLE PRECISION D_WORK_DPOT01( NMAX ) + DOUBLE PRECISION D_TEMP_DPOT02( NMAX, MAXRHS ) + DOUBLE PRECISION D_TEMP_DPOT03( NMAX, NMAX ) + DOUBLE PRECISION D_WORK_DLANSY( NMAX ) + DOUBLE PRECISION D_WORK_DPOT02( NMAX ) + DOUBLE PRECISION D_WORK_DPOT03( NMAX ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DSECND + EXTERNAL DLAMCH, DSECND +* .. +* .. External Subroutines .. + EXTERNAL ILAVER, DDRVRFP, DDRVRF1, DDRVRF2, DDRVRF3, + + DDRVRF4 +* .. +* .. Executable Statements .. +* + S1 = DSECND( ) + FATAL = .FALSE. +* +* Read a dummy line. +* + READ( NIN, FMT = * ) +* +* Report LAPACK version tag (e.g. LAPACK-3.2.0) +* + CALL ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) + WRITE( NOUT, FMT = 9994 ) VERS_MAJOR, VERS_MINOR, VERS_PATCH +* +* Read the values of N +* + READ( NIN, FMT = * )NN + IF( NN.LT.1 ) THEN + WRITE( NOUT, FMT = 9996 )' NN ', NN, 1 + NN = 0 + FATAL = .TRUE. + ELSE IF( NN.GT.MAXIN ) THEN + WRITE( NOUT, FMT = 9995 )' NN ', NN, MAXIN + NN = 0 + FATAL = .TRUE. + END IF + READ( NIN, FMT = * )( NVAL( I ), I = 1, NN ) + DO 10 I = 1, NN + IF( NVAL( I ).LT.0 ) THEN + WRITE( NOUT, FMT = 9996 )' M ', NVAL( I ), 0 + FATAL = .TRUE. + ELSE IF( NVAL( I ).GT.NMAX ) THEN + WRITE( NOUT, FMT = 9995 )' M ', NVAL( I ), NMAX + FATAL = .TRUE. + END IF + 10 CONTINUE + IF( NN.GT.0 ) + $ WRITE( NOUT, FMT = 9993 )'N ', ( NVAL( I ), I = 1, NN ) +* +* Read the values of NRHS +* + READ( NIN, FMT = * )NNS + IF( NNS.LT.1 ) THEN + WRITE( NOUT, FMT = 9996 )' NNS', NNS, 1 + NNS = 0 + FATAL = .TRUE. + ELSE IF( NNS.GT.MAXIN ) THEN + WRITE( NOUT, FMT = 9995 )' NNS', NNS, MAXIN + NNS = 0 + FATAL = .TRUE. + END IF + READ( NIN, FMT = * )( NSVAL( I ), I = 1, NNS ) + DO 30 I = 1, NNS + IF( NSVAL( I ).LT.0 ) THEN + WRITE( NOUT, FMT = 9996 )'NRHS', NSVAL( I ), 0 + FATAL = .TRUE. + ELSE IF( NSVAL( I ).GT.MAXRHS ) THEN + WRITE( NOUT, FMT = 9995 )'NRHS', NSVAL( I ), MAXRHS + FATAL = .TRUE. + END IF + 30 CONTINUE + IF( NNS.GT.0 ) + $ WRITE( NOUT, FMT = 9993 )'NRHS', ( NSVAL( I ), I = 1, NNS ) +* +* Read the matrix types +* + READ( NIN, FMT = * )NNT + IF( NNT.LT.1 ) THEN + WRITE( NOUT, FMT = 9996 )' NMA', NNT, 1 + NNT = 0 + FATAL = .TRUE. + ELSE IF( NNT.GT.NTYPES ) THEN + WRITE( NOUT, FMT = 9995 )' NMA', NNT, NTYPES + NNT = 0 + FATAL = .TRUE. + END IF + READ( NIN, FMT = * )( NTVAL( I ), I = 1, NNT ) + DO 320 I = 1, NNT + IF( NTVAL( I ).LT.0 ) THEN + WRITE( NOUT, FMT = 9996 )'TYPE', NTVAL( I ), 0 + FATAL = .TRUE. + ELSE IF( NTVAL( I ).GT.NTYPES ) THEN + WRITE( NOUT, FMT = 9995 )'TYPE', NTVAL( I ), NTYPES + FATAL = .TRUE. + END IF + 320 CONTINUE + IF( NNT.GT.0 ) + $ WRITE( NOUT, FMT = 9993 )'TYPE', ( NTVAL( I ), I = 1, NNT ) +* +* Read the threshold value for the test ratios. +* + READ( NIN, FMT = * )THRESH + WRITE( NOUT, FMT = 9992 )THRESH +* +* Read the flag that indicates whether to test the error exits. +* + READ( NIN, FMT = * )TSTERR +* + IF( FATAL ) THEN + WRITE( NOUT, FMT = 9999 ) + STOP + END IF +* + IF( FATAL ) THEN + WRITE( NOUT, FMT = 9999 ) + STOP + END IF +* +* Calculate and print the machine dependent constants. +* + EPS = DLAMCH( 'Underflow threshold' ) + WRITE( NOUT, FMT = 9991 )'underflow', EPS + EPS = DLAMCH( 'Overflow threshold' ) + WRITE( NOUT, FMT = 9991 )'overflow ', EPS + EPS = DLAMCH( 'Epsilon' ) + WRITE( NOUT, FMT = 9991 )'precision', EPS + WRITE( NOUT, FMT = * ) +* +* Test the error exit of: +* + IF( TSTERR ) + $ CALL DERRRFP( NOUT ) +* +* Test the routines: dpftrf, dpftri, dpftrs (as in DDRVPO). +* This also tests the routines: dtfsm, dtftri, dtfttr, dtrttf. +* + CALL DDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, THRESH, + $ WORKA, WORKASAV, WORKAFAC, WORKAINV, WORKB, + $ WORKBSAV, WORKXACT, WORKX, WORKARF, WORKARFINV, + $ D_WORK_DLATMS, D_WORK_DPOT01, D_TEMP_DPOT02, + $ D_TEMP_DPOT03, D_WORK_DLANSY, D_WORK_DPOT02, + $ D_WORK_DPOT03 ) +* +* Test the routine: dlansf +* + CALL DDRVRF1( NOUT, NN, NVAL, THRESH, WORKA, NMAX, WORKARF, + + D_WORK_DLANSY ) +* +* Test the convertion routines: +* dtfttp, dtpttf, dtfttr, dtrttf, dtrttp and dtpttr. +* + CALL DDRVRF2( NOUT, NN, NVAL, WORKA, NMAX, WORKARF, + + WORKAP, WORKASAV ) +* +* Test the routine: dtfsm +* + CALL DDRVRF3( NOUT, NN, NVAL, THRESH, WORKA, NMAX, WORKARF, + + WORKAINV, WORKAFAC, D_WORK_DLANSY, + + D_WORK_DPOT03, D_WORK_DPOT01 ) +* +* +* Test the routine: dsfrk +* + CALL DDRVRF4( NOUT, NN, NVAL, THRESH, WORKA, WORKAFAC, NMAX, + + WORKARF, WORKAINV, NMAX, D_WORK_DLANSY) +* + CLOSE ( NIN ) + S2 = DSECND( ) + WRITE( NOUT, FMT = 9998 ) + WRITE( NOUT, FMT = 9997 )S2 - S1 +* + 9999 FORMAT( / ' Execution not attempted due to input errors' ) + 9998 FORMAT( / ' End of tests' ) + 9997 FORMAT( ' Total time used = ', F12.2, ' seconds', / ) + 9996 FORMAT( ' !! Invalid input value: ', A4, '=', I6, '; must be >=', + $ I6 ) + 9995 FORMAT( ' !! Invalid input value: ', A4, '=', I6, '; must be <=', + $ I6 ) + 9994 FORMAT( / ' Tests of the DOUBLE PRECISION LAPACK RFP routines ', + $ / ' LAPACK VERSION ', I1, '.', I1, '.', I1, + $ / / ' The following parameter values will be used:' ) + 9993 FORMAT( 4X, A4, ': ', 10I6, / 11X, 10I6 ) + 9992 FORMAT( / ' Routines pass computational tests if test ratio is ', + $ 'less than', F8.2, / ) + 9991 FORMAT( ' Relative machine ', A, ' is taken to be', D16.6 ) +* +* End of DCHKRFP +* + END diff --git a/TESTING/LIN/dchkrq.f b/TESTING/LIN/dchkrq.f index afbe86ac..6f23b41f 100644 --- a/TESTING/LIN/dchkrq.f +++ b/TESTING/LIN/dchkrq.f @@ -135,7 +135,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dchksp.f b/TESTING/LIN/dchksp.f index b3f17e10..bda506f8 100644 --- a/TESTING/LIN/dchksp.f +++ b/TESTING/LIN/dchksp.f @@ -122,7 +122,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dchksy.f b/TESTING/LIN/dchksy.f index ee4814ae..97e040e7 100644 --- a/TESTING/LIN/dchksy.f +++ b/TESTING/LIN/dchksy.f @@ -124,7 +124,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dchktb.f b/TESTING/LIN/dchktb.f index 8fac48d1..f0d4b8aa 100644 --- a/TESTING/LIN/dchktb.f +++ b/TESTING/LIN/dchktb.f @@ -116,7 +116,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dchktp.f b/TESTING/LIN/dchktp.f index 03c60f47..0e378654 100644 --- a/TESTING/LIN/dchktp.f +++ b/TESTING/LIN/dchktp.f @@ -117,7 +117,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dchktr.f b/TESTING/LIN/dchktr.f index 60add26c..0503c703 100644 --- a/TESTING/LIN/dchktr.f +++ b/TESTING/LIN/dchktr.f @@ -121,7 +121,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dchktz.f b/TESTING/LIN/dchktz.f index 55c94c88..9d7699c1 100644 --- a/TESTING/LIN/dchktz.f +++ b/TESTING/LIN/dchktz.f @@ -103,7 +103,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/ddrvab.f b/TESTING/LIN/ddrvab.f index 5bdb9feb..e33b2143 100644 --- a/TESTING/LIN/ddrvab.f +++ b/TESTING/LIN/ddrvab.f @@ -112,7 +112,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/ddrvac.f b/TESTING/LIN/ddrvac.f new file mode 100644 index 00000000..417f9427 --- /dev/null +++ b/TESTING/LIN/ddrvac.f @@ -0,0 +1,371 @@ + SUBROUTINE DDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, + $ A, AFAC, B, X, WORK, + $ RWORK, SWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1.2) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* April 2007 +* +* .. Scalar Arguments .. + INTEGER NMAX, NM, NNS, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER MVAL( * ), NSVAL( * ) + REAL SWORK(*) + DOUBLE PRECISION A( * ), AFAC( * ), B( * ), + $ RWORK( * ), WORK( * ), X( * ) +* .. +* +* Purpose +* ======= +* +* DDRVAC tests DSPOSV. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NM (input) INTEGER +* The number of values of N contained in the vector MVAL. +* +* MVAL (input) INTEGER array, dimension (NM) +* The values of the matrix dimension N. +* +* NNS (input) INTEGER +* The number of values of NRHS contained in the vector NSVAL. +* +* NSVAL (input) INTEGER array, dimension (NNS) +* The values of the number of right hand sides NRHS. +* +* THRESH (input) 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. +* +* NMAX (input) INTEGER +* The maximum value permitted for N, used in dimensioning the +* work arrays. +* +* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) +* +* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) +* +* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) +* +* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX) +* +* WORK (workspace) DOUBLE PRECISION array, dimension +* (NMAX*max(3,NSMAX)) +* +* RWORK (workspace) DOUBLE PRECISION array, dimension +* (max(2*NMAX,2*NSMAX+NWORK)) +* +* SWORK (workspace) REAL array, dimension +* (NMAX*(NSMAX+NMAX)) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 9 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 1 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH + INTEGER I, IM, IMAT, INFO, IOFF, IRHS, IUPLO, + $ IZERO, KL, KU, LDA, MODE, N, + $ NERRS, NFAIL, NIMAT, NRHS, NRUN + DOUBLE PRECISION ANORM, CNDNUM +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. Local Variables .. + INTEGER ITER, KASE +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, DLACPY, + $ DLARHS, DLASET, DLATB4, DLATMS, + $ DPOT06, DSPOSV +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, 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. +* + KASE = 0 + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'PO' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* + INFOT = 0 +* +* Do for each value of N in MVAL +* + DO 120 IM = 1, NM + N = MVAL( IM ) + LDA = MAX( N, 1 ) + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 110 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 110 +* +* Skip types 3, 4, or 5 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 110 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 100 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with DLATB4 and generate a test matrix +* with DLATMS. +* + CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) +* + 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. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 100 + END IF +* +* For types 3-5, zero one row and column 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 + IOFF = ( IZERO-1 )*LDA +* +* Set row and column IZERO of A to 0. +* + IF( IUPLO.EQ.1 ) THEN + 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 + IZERO = 0 + END IF +* + DO 60 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) + XTYPE = 'N' +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'DLARHS' + CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, X, LDA, B, LDA, + $ ISEED, INFO ) +* +* Compute the L*L' or U'*U factorization of the +* matrix and solve the system. +* + SRNAMT = 'DSPOSV ' + KASE = KASE + 1 +* + CALL DLACPY( 'All', N, N, A, LDA, AFAC, LDA) +* + CALL DSPOSV( UPLO, N, NRHS, AFAC, LDA, B, LDA, X, LDA, + $ WORK, SWORK, ITER, INFO ) + + IF (ITER.LT.0) THEN + CALL DLACPY( 'All', N, N, A, LDA, AFAC, LDA ) + ENDIF +* +* Check error code from DSPOSV . +* + IF( INFO.NE.IZERO ) THEN +* + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + NERRS = NERRS + 1 +* + IF( INFO.NE.IZERO .AND. IZERO.NE.0 ) THEN + WRITE( NOUT, FMT = 9988 )'DSPOSV',INFO,IZERO,N, + $ IMAT + ELSE + WRITE( NOUT, FMT = 9975 )'DSPOSV',INFO,N,IMAT + END IF + END IF +* +* Skip the remaining test if the matrix is singular. +* + IF( INFO.NE.0 ) + $ GO TO 110 +* +* Check the quality of the solution +* + CALL DLACPY( 'All', N, NRHS, B, LDA, WORK, LDA ) +* + CALL DPOT06( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 1 ) ) +* +* Check if the test passes the tesing. +* Print information about the tests that did not +* pass the testing. +* +* If iterative refinement has been used and claimed to +* be successful (ITER>0), we want +* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS*SRQT(N)) < 1 +* +* If double precision has been used (ITER<0), we want +* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS) < THRES +* (Cf. the linear solver testing routines) +* + IF ((THRESH.LE.0.0E+00) + $ .OR.((ITER.GE.0).AND.(N.GT.0) + $ .AND.(RESULT(1).GE.SQRT(DBLE(N)))) + $ .OR.((ITER.LT.0).AND.(RESULT(1).GE.THRESH))) THEN +* + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN + WRITE( NOUT, FMT = 8999 )'DPO' + WRITE( NOUT, FMT = '( '' Matrix types:'' )' ) + WRITE( NOUT, FMT = 8979 ) + WRITE( NOUT, FMT = '( '' Test ratios:'' )' ) + WRITE( NOUT, FMT = 8960 )1 + WRITE( NOUT, FMT = '( '' Messages:'' )' ) + END IF +* + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, IMAT, 1, + $ RESULT( 1 ) +* + NFAIL = NFAIL + 1 +* + END IF +* + NRUN = NRUN + 1 +* + 60 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE +* + 130 CONTINUE +* +* Print a summary of the results. +* + IF( NFAIL.GT.0 ) THEN + WRITE( NOUT, FMT = 9996 )'DSPOSV', NFAIL, NRUN + ELSE + WRITE( NOUT, FMT = 9995 )'DSPOSV', NRUN + END IF + IF( NERRS.GT.0 ) THEN + WRITE( NOUT, FMT = 9994 )NERRS + END IF +* + 9998 FORMAT( ' UPLO=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9996 FORMAT( 1X, A6, ': ', I6, ' out of ', I6, + $ ' tests failed to pass the threshold' ) + 9995 FORMAT( /1X, 'All tests for ', A6, + $ ' routines passed the threshold (', I6, ' tests run)' ) + 9994 FORMAT( 6X, I6, ' error messages recorded' ) +* +* SUBNAM, INFO, INFOE, N, IMAT +* + 9988 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', + $ I5, / ' ==> N =', I5, ', type ', + $ I2 ) +* +* SUBNAM, INFO, N, IMAT +* + 9975 FORMAT( ' *** Error code from ', A6, '=', I5, ' for M=', I5, + $ ', type ', I2 ) + 8999 FORMAT( / 1X, A3, ': positive definite dense matrices' ) + 8979 FORMAT( 4X, '1. Diagonal', 24X, '7. Last n/2 columns zero', / 4X, + $ '2. Upper triangular', 16X, + $ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, + $ '3. Lower triangular', 16X, '9. Random, CNDNUM = 0.1/EPS', + $ / 4X, '4. Random, CNDNUM = 2', 13X, + $ '10. Scaled near underflow', / 4X, '5. First column zero', + $ 14X, '11. Scaled near overflow', / 4X, + $ '6. Last column zero' ) + 8960 FORMAT( 3X, I2, ': norm_1( B - A * X ) / ', + $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF', + $ / 4x, 'or norm_1( B - A * X ) / ', + $ '( norm_1(A) * norm_1(X) * EPS ) > THRES if DPOTRF' ) + + RETURN +* +* End of DDRVAC +* + END diff --git a/TESTING/LIN/ddrvgb.f b/TESTING/LIN/ddrvgb.f index 37a19fd9..298f8fbc 100644 --- a/TESTING/LIN/ddrvgb.f +++ b/TESTING/LIN/ddrvgb.f @@ -130,7 +130,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/ddrvgbx.f b/TESTING/LIN/ddrvgbx.f new file mode 100644 index 00000000..53b3bcd6 --- /dev/null +++ b/TESTING/LIN/ddrvgbx.f @@ -0,0 +1,928 @@ + SUBROUTINE DDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, + $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER LA, LAFB, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ), + $ RWORK( * ), S( * ), WORK( * ), X( * ), + $ XACT( * ) +* .. +* +* Purpose +* ======= +* +* DDRVGB tests the driver routines DGBSV and -SVX. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix column dimension N. +* +* NRHS (input) INTEGER +* The number of right hand side vectors to be generated for +* each linear system. +* +* THRESH (input) 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. +* +* TSTERR (input) LOGICAL +* Flag that indicates whether error exits are to be tested. +* +* A (workspace) DOUBLE PRECISION array, dimension (LA) +* +* LA (input) INTEGER +* The length of the array A. LA >= (2*NMAX-1)*NMAX +* where NMAX is the largest entry in NVAL. +* +* AFB (workspace) DOUBLE PRECISION array, dimension (LAFB) +* +* LAFB (input) INTEGER +* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX +* where NMAX is the largest entry in NVAL. +* +* ASAV (workspace) DOUBLE PRECISION array, dimension (LA) +* +* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) +* +* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) +* +* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) +* +* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) +* +* S (workspace) DOUBLE PRECISION array, dimension (2*NMAX) +* +* WORK (workspace) DOUBLE PRECISION array, dimension +* (NMAX*max(3,NRHS,NMAX)) +* +* RWORK (workspace) DOUBLE PRECISION array, dimension +* (max(NMAX,2*NRHS)) +* +* IWORK (workspace) INTEGER array, dimension (2*NMAX) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 8 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) + INTEGER NTRAN + PARAMETER ( NTRAN = 3 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT + CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE + CHARACTER*3 PATH + INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN, + $ INFO, IOFF, ITRAN, IZERO, J, K, K1, KL, KU, + $ LDA, LDAFB, LDB, MODE, N, NB, NBMIN, NERRS, + $ NFACT, NFAIL, NIMAT, NKL, NKU, NRUN, NT, + $ N_ERR_BNDS + DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV, + $ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO, + $ ROLDC, ROLDI, ROLDO, ROWCND, RPVGRW, + $ RPVGRW_SVXX +* .. +* .. Local Arrays .. + CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ), BERR( NRHS ), + $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DGET06, DLAMCH, DLANGB, DLANGE, DLANTB, + $ DLA_GBRPVGRW + EXTERNAL LSAME, DGET06, DLAMCH, DLANGB, DLANGE, DLANTB, + $ DLA_GBRPVGRW +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGBEQU, DGBSV, + $ DGBSVX, DGBT01, DGBT02, DGBT05, DGBTRF, DGBTRS, + $ DGET04, DLACPY, DLAQGB, DLARHS, DLASET, DLATB4, + $ DLATMS, XLAENV, DGBSVXX, DGBEQUB +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. 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 TRANSS / 'N', 'T', 'C' / + DATA FACTS / 'F', 'N', 'E' / + DATA EQUEDS / 'N', 'R', 'C', 'B' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'GB' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL DERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 150 IN = 1, NN + N = NVAL( IN ) + LDB = MAX( N, 1 ) + XTYPE = 'N' +* +* Set limits on the number of loop iterations. +* + NKL = MAX( 1, MIN( N, 4 ) ) + IF( N.EQ.0 ) + $ NKL = 1 + NKU = NKL + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 140 IKL = 1, NKL +* +* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes +* it easier to skip redundant values for small values of N. +* + IF( IKL.EQ.1 ) THEN + KL = 0 + ELSE IF( IKL.EQ.2 ) THEN + KL = MAX( N-1, 0 ) + ELSE IF( IKL.EQ.3 ) THEN + KL = ( 3*N-1 ) / 4 + ELSE IF( IKL.EQ.4 ) THEN + KL = ( N+1 ) / 4 + END IF + DO 130 IKU = 1, NKU +* +* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order +* makes it easier to skip redundant values for small +* values of N. +* + IF( IKU.EQ.1 ) THEN + KU = 0 + ELSE IF( IKU.EQ.2 ) THEN + KU = MAX( N-1, 0 ) + ELSE IF( IKU.EQ.3 ) THEN + KU = ( 3*N-1 ) / 4 + ELSE IF( IKU.EQ.4 ) THEN + KU = ( N+1 ) / 4 + END IF +* +* Check that A and AFB are big enough to generate this +* matrix. +* + LDA = KL + KU + 1 + LDAFB = 2*KL + KU + 1 + IF( LDA*N.GT.LA .OR. LDAFB*N.GT.LAFB ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( LDA*N.GT.LA ) THEN + WRITE( NOUT, FMT = 9999 )LA, N, KL, KU, + $ N*( KL+KU+1 ) + NERRS = NERRS + 1 + END IF + IF( LDAFB*N.GT.LAFB ) THEN + WRITE( NOUT, FMT = 9998 )LAFB, N, KL, KU, + $ N*( 2*KL+KU+1 ) + NERRS = NERRS + 1 + END IF + GO TO 130 + END IF +* + DO 120 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 120 +* +* Skip types 2, 3, or 4 if the matrix is too small. +* + ZEROT = IMAT.GE.2 .AND. IMAT.LE.4 + IF( ZEROT .AND. N.LT.IMAT-1 ) + $ GO TO 120 +* +* Set up parameters with DLATB4 and generate a +* test matrix with DLATMS. +* + CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) + RCONDC = ONE / CNDNUM +* + SRNAMT = 'DLATMS' + CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, 'Z', A, LDA, WORK, + $ INFO ) +* +* Check the error code from DLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', N, N, + $ KL, KU, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 120 + END IF +* +* For types 2, 3, and 4, zero one or more columns of +* the matrix to test that INFO is returned correctly. +* + IZERO = 0 + IF( ZEROT ) THEN + IF( IMAT.EQ.2 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.3 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF + IOFF = ( IZERO-1 )*LDA + IF( IMAT.LT.4 ) THEN + I1 = MAX( 1, KU+2-IZERO ) + I2 = MIN( KL+KU+1, KU+1+( N-IZERO ) ) + DO 20 I = I1, I2 + A( IOFF+I ) = ZERO + 20 CONTINUE + ELSE + DO 40 J = IZERO, N + DO 30 I = MAX( 1, KU+2-J ), + $ MIN( KL+KU+1, KU+1+( N-J ) ) + A( IOFF+I ) = ZERO + 30 CONTINUE + IOFF = IOFF + LDA + 40 CONTINUE + END IF + END IF +* +* Save a copy of the matrix A in ASAV. +* + CALL DLACPY( 'Full', KL+KU+1, N, A, LDA, ASAV, LDA ) +* + DO 110 IEQUED = 1, 4 + EQUED = EQUEDS( IEQUED ) + IF( IEQUED.EQ.1 ) THEN + NFACT = 3 + ELSE + NFACT = 1 + END IF +* + DO 100 IFACT = 1, NFACT + FACT = FACTS( IFACT ) + PREFAC = LSAME( FACT, 'F' ) + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) +* + IF( ZEROT ) THEN + IF( PREFAC ) + $ GO TO 100 + RCONDO = ZERO + RCONDI = ZERO +* + ELSE IF( .NOT.NOFACT ) THEN +* +* Compute the condition number for comparison +* with the value returned by DGESVX (FACT = +* 'N' reuses the condition number from the +* previous iteration with FACT = 'F'). +* + CALL DLACPY( 'Full', KL+KU+1, N, ASAV, LDA, + $ AFB( KL+1 ), LDAFB ) + IF( EQUIL .OR. IEQUED.GT.1 ) THEN +* +* Compute row and column scale factors to +* equilibrate the matrix A. +* + CALL DGBEQU( N, N, KL, KU, AFB( KL+1 ), + $ LDAFB, S, S( N+1 ), ROWCND, + $ COLCND, AMAX, INFO ) + IF( INFO.EQ.0 .AND. N.GT.0 ) THEN + IF( LSAME( EQUED, 'R' ) ) THEN + ROWCND = ZERO + COLCND = ONE + ELSE IF( LSAME( EQUED, 'C' ) ) THEN + ROWCND = ONE + COLCND = ZERO + ELSE IF( LSAME( EQUED, 'B' ) ) THEN + ROWCND = ZERO + COLCND = ZERO + END IF +* +* Equilibrate the matrix. +* + CALL DLAQGB( N, N, KL, KU, AFB( KL+1 ), + $ LDAFB, S, S( N+1 ), + $ ROWCND, COLCND, AMAX, + $ EQUED ) + END IF + END IF +* +* Save the condition number of the +* non-equilibrated system for use in DGET04. +* + IF( EQUIL ) THEN + ROLDO = RCONDO + ROLDI = RCONDI + END IF +* +* Compute the 1-norm and infinity-norm of A. +* + ANORMO = DLANGB( '1', N, KL, KU, AFB( KL+1 ), + $ LDAFB, RWORK ) + ANORMI = DLANGB( 'I', N, KL, KU, AFB( KL+1 ), + $ LDAFB, RWORK ) +* +* Factor the matrix A. +* + CALL DGBTRF( N, N, KL, KU, AFB, LDAFB, IWORK, + $ INFO ) +* +* Form the inverse of A. +* + CALL DLASET( 'Full', N, N, ZERO, ONE, WORK, + $ LDB ) + SRNAMT = 'DGBTRS' + CALL DGBTRS( 'No transpose', N, KL, KU, N, + $ AFB, LDAFB, IWORK, WORK, LDB, + $ INFO ) +* +* Compute the 1-norm condition number of A. +* + AINVNM = DLANGE( '1', N, N, WORK, LDB, + $ RWORK ) + IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDO = ONE + ELSE + RCONDO = ( ONE / ANORMO ) / AINVNM + END IF +* +* Compute the infinity-norm condition number +* of A. +* + AINVNM = DLANGE( 'I', N, N, WORK, LDB, + $ RWORK ) + IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDI = ONE + ELSE + RCONDI = ( ONE / ANORMI ) / AINVNM + END IF + END IF +* + DO 90 ITRAN = 1, NTRAN +* +* Do for each value of TRANS. +* + TRANS = TRANSS( ITRAN ) + IF( ITRAN.EQ.1 ) THEN + RCONDC = RCONDO + ELSE + RCONDC = RCONDI + END IF +* +* Restore the matrix A. +* + CALL DLACPY( 'Full', KL+KU+1, N, ASAV, LDA, + $ A, LDA ) +* +* Form an exact solution and set the right hand +* side. +* + SRNAMT = 'DLARHS' + CALL DLARHS( PATH, XTYPE, 'Full', TRANS, N, + $ N, KL, KU, NRHS, A, LDA, XACT, + $ LDB, B, LDB, ISEED, INFO ) + XTYPE = 'C' + CALL DLACPY( 'Full', N, NRHS, B, LDB, BSAV, + $ LDB ) +* + IF( NOFACT .AND. ITRAN.EQ.1 ) THEN +* +* --- Test DGBSV --- +* +* Compute the LU factorization of the matrix +* and solve the system. +* + CALL DLACPY( 'Full', KL+KU+1, N, A, LDA, + $ AFB( KL+1 ), LDAFB ) + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, + $ LDB ) +* + SRNAMT = 'DGBSV ' + CALL DGBSV( N, KL, KU, NRHS, AFB, LDAFB, + $ IWORK, X, LDB, INFO ) +* +* Check error code from DGBSV . +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'DGBSV ', INFO, + $ IZERO, ' ', N, N, KL, KU, + $ NRHS, IMAT, NFAIL, NERRS, + $ NOUT ) + GOTO 90 + END IF +* +* Reconstruct matrix from factors and +* compute residual. +* + CALL DGBT01( N, N, KL, KU, A, LDA, AFB, + $ LDAFB, IWORK, WORK, + $ RESULT( 1 ) ) + NT = 1 + IF( IZERO.EQ.0 ) THEN +* +* Compute residual of the computed +* solution. +* + CALL DLACPY( 'Full', N, NRHS, B, LDB, + $ WORK, LDB ) + CALL DGBT02( 'No transpose', N, N, KL, + $ KU, NRHS, A, LDA, X, LDB, + $ WORK, LDB, RESULT( 2 ) ) +* +* Check solution from generated exact +* solution. +* + CALL DGET04( N, NRHS, X, LDB, XACT, + $ LDB, RCONDC, RESULT( 3 ) ) + NT = 3 + END IF +* +* Print information about the tests that did +* not pass the threshold. +* + DO 50 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )'DGBSV ', + $ N, KL, KU, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 50 CONTINUE + NRUN = NRUN + NT + END IF +* +* --- Test DGBSVX --- +* + IF( .NOT.PREFAC ) + $ CALL DLASET( 'Full', 2*KL+KU+1, N, ZERO, + $ ZERO, AFB, LDAFB ) + CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, + $ LDB ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT = 'F' and +* EQUED = 'R', 'C', or 'B'. +* + CALL DLAQGB( N, N, KL, KU, A, LDA, S, + $ S( N+1 ), ROWCND, COLCND, + $ AMAX, EQUED ) + END IF +* +* Solve the system and compute the condition +* number and error bounds using DGBSVX. +* + SRNAMT = 'DGBSVX' + CALL DGBSVX( FACT, TRANS, N, KL, KU, NRHS, A, + $ LDA, AFB, LDAFB, IWORK, EQUED, + $ S, S( N+1 ), B, LDB, X, LDB, + $ RCOND, RWORK, RWORK( NRHS+1 ), + $ WORK, IWORK( N+1 ), INFO ) +* +* Check the error code from DGBSVX. +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'DGBSVX', INFO, IZERO, + $ FACT // TRANS, N, N, KL, KU, + $ NRHS, IMAT, NFAIL, NERRS, + $ NOUT ) + GOTO 90 + END IF + +* +* Compare WORK(1) from DGBSVX with the computed +* reciprocal pivot growth factor RPVGRW +* + IF( INFO.NE.0 ) THEN + ANRMPV = ZERO + DO 70 J = 1, INFO + DO 60 I = MAX( KU+2-J, 1 ), + $ MIN( N+KU+1-J, KL+KU+1 ) + ANRMPV = MAX( ANRMPV, + $ ABS( A( I+( J-1 )*LDA ) ) ) + 60 CONTINUE + 70 CONTINUE + RPVGRW = DLANTB( 'M', 'U', 'N', INFO, + $ MIN( INFO-1, KL+KU ), + $ AFB( MAX( 1, KL+KU+2-INFO ) ), + $ LDAFB, WORK ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = ANRMPV / RPVGRW + END IF + ELSE + RPVGRW = DLANTB( 'M', 'U', 'N', N, KL+KU, + $ AFB, LDAFB, WORK ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = DLANGB( 'M', N, KL, KU, A, + $ LDA, WORK ) / RPVGRW + END IF + END IF + RESULT( 7 ) = ABS( RPVGRW-WORK( 1 ) ) / + $ MAX( WORK( 1 ), RPVGRW ) / + $ DLAMCH( 'E' ) +* + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and +* compute residual. +* + CALL DGBT01( N, N, KL, KU, A, LDA, AFB, + $ LDAFB, IWORK, WORK, + $ RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* + IF( INFO.EQ.0 ) THEN + TRFCON = .FALSE. +* +* Compute residual of the computed solution. +* + CALL DLACPY( 'Full', N, NRHS, BSAV, LDB, + $ WORK, LDB ) + CALL DGBT02( TRANS, N, N, KL, KU, NRHS, + $ ASAV, LDA, X, LDB, WORK, LDB, + $ RESULT( 2 ) ) +* +* Check solution from generated exact +* solution. +* + IF( NOFACT .OR. ( PREFAC .AND. + $ LSAME( EQUED, 'N' ) ) ) THEN + CALL DGET04( N, NRHS, X, LDB, XACT, + $ LDB, RCONDC, RESULT( 3 ) ) + ELSE + IF( ITRAN.EQ.1 ) THEN + ROLDC = ROLDO + ELSE + ROLDC = ROLDI + END IF + CALL DGET04( N, NRHS, X, LDB, XACT, + $ LDB, ROLDC, RESULT( 3 ) ) + END IF +* +* Check the error bounds from iterative +* refinement. +* + CALL DGBT05( TRANS, N, KL, KU, NRHS, ASAV, + $ LDA, B, LDB, X, LDB, XACT, + $ LDB, RWORK, RWORK( NRHS+1 ), + $ RESULT( 4 ) ) + ELSE + TRFCON = .TRUE. + END IF +* +* Compare RCOND from DGBSVX with the computed +* value in RCONDC. +* + RESULT( 6 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did +* not pass the threshold. +* + IF( .NOT.TRFCON ) THEN + DO 80 K = K1, NTESTS + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9995 ) + $ 'DGBSVX', FACT, TRANS, N, KL, + $ KU, EQUED, IMAT, K, + $ RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9996 ) + $ 'DGBSVX', FACT, TRANS, N, KL, + $ KU, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 80 CONTINUE + NRUN = NRUN + 7 - K1 + ELSE + IF( RESULT( 1 ).GE.THRESH .AND. .NOT. + $ PREFAC ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9995 )'DGBSVX', + $ FACT, TRANS, N, KL, KU, EQUED, + $ IMAT, 1, RESULT( 1 ) + ELSE + WRITE( NOUT, FMT = 9996 )'DGBSVX', + $ FACT, TRANS, N, KL, KU, IMAT, 1, + $ RESULT( 1 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 6 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9995 )'DGBSVX', + $ FACT, TRANS, N, KL, KU, EQUED, + $ IMAT, 6, RESULT( 6 ) + ELSE + WRITE( NOUT, FMT = 9996 )'DGBSVX', + $ FACT, TRANS, N, KL, KU, IMAT, 6, + $ RESULT( 6 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9995 )'DGBSVX', + $ FACT, TRANS, N, KL, KU, EQUED, + $ IMAT, 7, RESULT( 7 ) + ELSE + WRITE( NOUT, FMT = 9996 )'DGBSVX', + $ FACT, TRANS, N, KL, KU, IMAT, 7, + $ RESULT( 7 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF +* + END IF +* +* --- Test DGBSVXX --- +* +* Restore the matrices A and B. +* + CALL DLACPY( 'Full', KL+KU+1, N, ASAV, LDA, A, + $ LDA ) + CALL DLACPY( 'Full', N, NRHS, BSAV, LDB, B, LDB ) + + IF( .NOT.PREFAC ) + $ CALL DLASET( 'Full', 2*KL+KU+1, N, ZERO, ZERO, + $ AFB, LDAFB ) + CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDB ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT = 'F' and +* EQUED = 'R', 'C', or 'B'. +* + CALL DLAQGB( N, N, KL, KU, A, LDA, S, S( N+1 ), + $ ROWCND, COLCND, AMAX, EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using DGBSVXX. +* + SRNAMT = 'DGBSVXX' + N_ERR_BNDS = 3 + CALL DGBSVXX( FACT, TRANS, N, KL, KU, NRHS, A, LDA, + $ AFB, LDAFB, IWORK, EQUED, S, S( N+1 ), B, LDB, + $ X, LDB, RCOND, RPVGRW_SVXX, BERR, N_ERR_BNDS, + $ ERRBNDS_N, ERRBNDS_C, 0, ZERO, WORK, + $ IWORK( N+1 ), INFO ) +* +* Check the error code from DGBSVXX. +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'DGBSVXX', INFO, IZERO, + $ FACT // TRANS, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GOTO 90 + END IF +* +* Compare rpvgrw_svxx from DGBSVXX with the computed +* reciprocal pivot growth factor RPVGRW +* + + IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN + RPVGRW = DLA_GBRPVGRW(N, KL, KU, INFO, A, LDA, + $ AFB, LDAFB) + ELSE + RPVGRW = DLA_GBRPVGRW(N, KL, KU, N, A, LDA, + $ AFB, LDAFB) + ENDIF + + RESULT( 7 ) = ABS( RPVGRW-rpvgrw_svxx ) / + $ MAX( rpvgrw_svxx, RPVGRW ) / + $ DLAMCH( 'E' ) +* + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL DGBT01( N, N, KL, KU, A, LDA, AFB, LDAFB, + $ IWORK, WORK, RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* + IF( INFO.EQ.0 ) THEN + TRFCON = .FALSE. +* +* Compute residual of the computed solution. +* + CALL DLACPY( 'Full', N, NRHS, BSAV, LDB, WORK, + $ LDB ) + CALL DGBT02( TRANS, N, N, KL, KU, NRHS, ASAV, + $ LDA, X, LDB, WORK, LDB, + $ WORK, RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL DGET04( N, NRHS, X, LDB, XACT, LDB, + $ RCONDC, RESULT( 3 ) ) + ELSE + IF( ITRAN.EQ.1 ) THEN + ROLDC = ROLDO + ELSE + ROLDC = ROLDI + END IF + CALL DGET04( N, NRHS, X, LDB, XACT, LDB, + $ ROLDC, RESULT( 3 ) ) + END IF + ELSE + TRFCON = .TRUE. + END IF +* +* Compare RCOND from DGBSVXX with the computed value +* in RCONDC. +* + RESULT( 6 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( .NOT.TRFCON ) THEN + DO 45 K = K1, NTESTS + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'DGBSVXX', + $ FACT, TRANS, N, KL, KU, EQUED, + $ IMAT, K, RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'DGBSVXX', + $ FACT, TRANS, N, KL, KU, IMAT, K, + $ RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 45 CONTINUE + NRUN = NRUN + 7 - K1 + ELSE + IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) + $ THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'DGBSVXX', FACT, + $ TRANS, N, KL, KU, EQUED, IMAT, 1, + $ RESULT( 1 ) + ELSE + WRITE( NOUT, FMT = 9998 )'DGBSVXX', FACT, + $ TRANS, N, KL, KU, IMAT, 1, + $ RESULT( 1 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 6 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'DGBSVXX', FACT, + $ TRANS, N, KL, KU, EQUED, IMAT, 6, + $ RESULT( 6 ) + ELSE + WRITE( NOUT, FMT = 9998 )'DGBSVXX', FACT, + $ TRANS, N, KL, KU, IMAT, 6, + $ RESULT( 6 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'DGBSVXX', FACT, + $ TRANS, N, KL, KU, EQUED, IMAT, 7, + $ RESULT( 7 ) + ELSE + WRITE( NOUT, FMT = 9998 )'DGBSVXX', FACT, + $ TRANS, N, KL, KU, IMAT, 7, + $ RESULT( 7 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF +* + END IF + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) + +* Test Error Bounds from DGBSVXX + + CALL DEBCHVXX(THRESH, PATH) + + 9999 FORMAT( ' *** In DDRVGB, LA=', I5, ' is too small for N=', I5, + $ ', KU=', I5, ', KL=', I5, / ' ==> Increase LA to at least ', + $ I5 ) + 9998 FORMAT( ' *** In DDRVGB, LAFB=', I5, ' is too small for N=', I5, + $ ', KU=', I5, ', KL=', I5, / + $ ' ==> Increase LAFB to at least ', I5 ) + 9997 FORMAT( 1X, A, ', N=', I5, ', KL=', I5, ', KU=', I5, ', type ', + $ I1, ', test(', I1, ')=', G12.5 ) + 9996 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', + $ I5, ',...), type ', I1, ', test(', I1, ')=', G12.5 ) + 9995 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', + $ I5, ',...), EQUED=''', A1, ''', type ', I1, ', test(', I1, + $ ')=', G12.5 ) +* + RETURN +* +* End of DDRVGB +* + END diff --git a/TESTING/LIN/ddrvge.f b/TESTING/LIN/ddrvge.f index d8d3c1d3..8bfb78c7 100644 --- a/TESTING/LIN/ddrvge.f +++ b/TESTING/LIN/ddrvge.f @@ -124,7 +124,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. @@ -514,7 +514,7 @@ * refinement. * CALL DGET07( TRANS, N, NRHS, ASAV, LDA, B, LDA, - $ X, LDA, XACT, LDA, RWORK, + $ X, LDA, XACT, LDA, RWORK, .TRUE., $ RWORK( NRHS+1 ), RESULT( 4 ) ) ELSE TRFCON = .TRUE. diff --git a/TESTING/LIN/ddrvgex.f b/TESTING/LIN/ddrvgex.f new file mode 100644 index 00000000..c9f36448 --- /dev/null +++ b/TESTING/LIN/ddrvgex.f @@ -0,0 +1,798 @@ + SUBROUTINE DDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, + $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION A( * ), AFAC( * ), ASAV( * ), B( * ), + $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), + $ X( * ), XACT( * ) +* .. +* +* Purpose +* ======= +* +* DDRVGE tests the driver routines DGESV, -SVX, and -SVXX. +* +* Note that this file is used only when the XBLAS are available, +* otherwise ddrvge.f defines this subroutine. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix column dimension N. +* +* NRHS (input) INTEGER +* The number of right hand side vectors to be generated for +* each linear system. +* +* THRESH (input) 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. +* +* TSTERR (input) LOGICAL +* Flag that indicates whether error exits are to be tested. +* +* NMAX (input) INTEGER +* The maximum value permitted for N, used in dimensioning the +* work arrays. +* +* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) +* +* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) +* +* ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) +* +* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) +* +* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) +* +* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) +* +* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) +* +* S (workspace) DOUBLE PRECISION array, dimension (2*NMAX) +* +* WORK (workspace) DOUBLE PRECISION array, dimension +* (NMAX*max(3,NRHS)) +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (2*NRHS+NMAX) +* +* IWORK (workspace) INTEGER array, dimension (2*NMAX) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 11 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) + INTEGER NTRAN + PARAMETER ( NTRAN = 3 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT + CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE + CHARACTER*3 PATH + INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, ITRAN, + $ IZERO, K, K1, KL, KU, LDA, LWORK, MODE, N, NB, + $ NBMIN, NERRS, NFACT, NFAIL, NIMAT, NRUN, NT, + $ N_ERR_BNDS + DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, CNDNUM, + $ COLCND, RCOND, RCONDC, RCONDI, RCONDO, ROLDC, + $ ROLDI, ROLDO, ROWCND, RPVGRW, RPVGRW_SVXX +* .. +* .. Local Arrays .. + CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ), BERR( NRHS ), + $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DGET06, DLAMCH, DLANGE, DLANTR, DLA_RPVGRW + EXTERNAL LSAME, DGET06, DLAMCH, DLANGE, DLANTR, + $ DLA_RPVGRW +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGEEQU, DGESV, + $ DGESVX, DGET01, DGET02, DGET04, DGET07, DGETRF, + $ DGETRI, DLACPY, DLAQGE, DLARHS, DLASET, DLATB4, + $ DLATMS, XLAENV, DGESVXX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. 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 TRANSS / 'N', 'T', 'C' / + DATA FACTS / 'F', 'N', 'E' / + DATA EQUEDS / 'N', 'R', 'C', 'B' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'GE' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL DERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 90 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 80 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 80 +* +* Skip types 5, 6, or 7 if the matrix size is too small. +* + ZEROT = IMAT.GE.5 .AND. IMAT.LE.7 + IF( ZEROT .AND. N.LT.IMAT-4 ) + $ GO TO 80 +* +* Set up parameters with DLATB4 and generate a test matrix +* with DLATMS. +* + CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) + RCONDC = ONE / CNDNUM +* + SRNAMT = 'DLATMS' + CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, CNDNUM, + $ ANORM, KL, KU, 'No packing', A, LDA, WORK, + $ INFO ) +* +* Check error code from DLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', N, N, -1, -1, + $ -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 80 + END IF +* +* For types 5-7, zero one or more columns of the matrix to +* test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.5 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.6 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF + IOFF = ( IZERO-1 )*LDA + IF( IMAT.LT.7 ) THEN + DO 20 I = 1, N + A( IOFF+I ) = ZERO + 20 CONTINUE + ELSE + CALL DLASET( 'Full', N, N-IZERO+1, ZERO, ZERO, + $ A( IOFF+1 ), LDA ) + END IF + ELSE + IZERO = 0 + END IF +* +* Save a copy of the matrix A in ASAV. +* + CALL DLACPY( 'Full', N, N, A, LDA, ASAV, LDA ) +* + DO 70 IEQUED = 1, 4 + EQUED = EQUEDS( IEQUED ) + IF( IEQUED.EQ.1 ) THEN + NFACT = 3 + ELSE + NFACT = 1 + END IF +* + DO 60 IFACT = 1, NFACT + FACT = FACTS( IFACT ) + PREFAC = LSAME( FACT, 'F' ) + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) +* + IF( ZEROT ) THEN + IF( PREFAC ) + $ GO TO 60 + RCONDO = ZERO + RCONDI = ZERO +* + ELSE IF( .NOT.NOFACT ) THEN +* +* Compute the condition number for comparison with +* the value returned by DGESVX (FACT = 'N' reuses +* the condition number from the previous iteration +* with FACT = 'F'). +* + CALL DLACPY( 'Full', N, N, ASAV, LDA, AFAC, LDA ) + IF( EQUIL .OR. IEQUED.GT.1 ) THEN +* +* Compute row and column scale factors to +* equilibrate the matrix A. +* + CALL DGEEQU( N, N, AFAC, LDA, S, S( N+1 ), + $ ROWCND, COLCND, AMAX, INFO ) + IF( INFO.EQ.0 .AND. N.GT.0 ) THEN + IF( LSAME( EQUED, 'R' ) ) THEN + ROWCND = ZERO + COLCND = ONE + ELSE IF( LSAME( EQUED, 'C' ) ) THEN + ROWCND = ONE + COLCND = ZERO + ELSE IF( LSAME( EQUED, 'B' ) ) THEN + ROWCND = ZERO + COLCND = ZERO + END IF +* +* Equilibrate the matrix. +* + CALL DLAQGE( N, N, AFAC, LDA, S, S( N+1 ), + $ ROWCND, COLCND, AMAX, EQUED ) + END IF + END IF +* +* Save the condition number of the non-equilibrated +* system for use in DGET04. +* + IF( EQUIL ) THEN + ROLDO = RCONDO + ROLDI = RCONDI + END IF +* +* Compute the 1-norm and infinity-norm of A. +* + ANORMO = DLANGE( '1', N, N, AFAC, LDA, RWORK ) + ANORMI = DLANGE( 'I', N, N, AFAC, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL DGETRF( N, N, AFAC, LDA, IWORK, INFO ) +* +* Form the inverse of A. +* + CALL DLACPY( 'Full', N, N, AFAC, LDA, A, LDA ) + LWORK = NMAX*MAX( 3, NRHS ) + CALL DGETRI( N, A, LDA, IWORK, WORK, LWORK, INFO ) +* +* Compute the 1-norm condition number of A. +* + AINVNM = DLANGE( '1', N, N, A, LDA, RWORK ) + IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDO = ONE + ELSE + RCONDO = ( ONE / ANORMO ) / AINVNM + END IF +* +* Compute the infinity-norm condition number of A. +* + AINVNM = DLANGE( 'I', N, N, A, LDA, RWORK ) + IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDI = ONE + ELSE + RCONDI = ( ONE / ANORMI ) / AINVNM + END IF + END IF +* + DO 50 ITRAN = 1, NTRAN + DO I = 1, NTESTS + RESULT (I) = ZERO + END DO +* +* Do for each value of TRANS. +* + TRANS = TRANSS( ITRAN ) + IF( ITRAN.EQ.1 ) THEN + RCONDC = RCONDO + ELSE + RCONDC = RCONDI + END IF +* +* Restore the matrix A. +* + CALL DLACPY( 'Full', N, N, ASAV, LDA, A, LDA ) +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'DLARHS' + CALL DLARHS( PATH, XTYPE, 'Full', TRANS, N, N, KL, + $ KU, NRHS, A, LDA, XACT, LDA, B, LDA, + $ ISEED, INFO ) + XTYPE = 'C' + CALL DLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA ) +* + IF( NOFACT .AND. ITRAN.EQ.1 ) THEN +* +* --- Test DGESV --- +* +* Compute the LU factorization of the matrix and +* solve the system. +* + CALL DLACPY( 'Full', N, N, A, LDA, AFAC, LDA ) + CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'DGESV ' + CALL DGESV( N, NRHS, AFAC, LDA, IWORK, X, LDA, + $ INFO ) +* +* Check error code from DGESV . +* + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'DGESV ', INFO, IZERO, + $ ' ', N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) + GOTO 50 + END IF +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL DGET01( N, N, A, LDA, AFAC, LDA, IWORK, + $ RWORK, RESULT( 1 ) ) + NT = 1 + IF( IZERO.EQ.0 ) THEN +* +* Compute residual of the computed solution. +* + CALL DLACPY( 'Full', N, NRHS, B, LDA, WORK, + $ LDA ) + CALL DGET02( 'No transpose', N, N, NRHS, A, + $ LDA, X, LDA, WORK, LDA, RWORK, + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + NT = 3 + END IF +* +* Print information about the tests that did not +* pass the threshold. +* + DO 30 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 )'DGESV ', N, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 30 CONTINUE + NRUN = NRUN + NT + END IF +* +* --- Test DGESVX --- +* + IF( .NOT.PREFAC ) + $ CALL DLASET( 'Full', N, N, ZERO, ZERO, AFAC, + $ LDA ) + CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT = 'F' and +* EQUED = 'R', 'C', or 'B'. +* + CALL DLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND, + $ COLCND, AMAX, EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using DGESVX. +* + SRNAMT = 'DGESVX' + CALL DGESVX( FACT, TRANS, N, NRHS, A, LDA, AFAC, + $ LDA, IWORK, EQUED, S, S( N+1 ), B, + $ LDA, X, LDA, RCOND, RWORK, + $ RWORK( NRHS+1 ), WORK, IWORK( N+1 ), + $ INFO ) +* +* Check the error code from DGESVX. +* + IF( INFO.EQ.N+1 ) GOTO 50 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'DGESVX', INFO, IZERO, + $ FACT // TRANS, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GOTO 50 + END IF +* +* Compare WORK(1) from DGESVX with the computed +* reciprocal pivot growth factor RPVGRW +* + IF( INFO.NE.0 ) THEN + RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO, + $ AFAC, LDA, WORK ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = DLANGE( 'M', N, INFO, A, LDA, + $ WORK ) / RPVGRW + END IF + ELSE + RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AFAC, LDA, + $ WORK ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = DLANGE( 'M', N, N, A, LDA, WORK ) / + $ RPVGRW + END IF + END IF + RESULT( 7 ) = ABS( RPVGRW-WORK( 1 ) ) / + $ MAX( WORK( 1 ), RPVGRW ) / + $ DLAMCH( 'E' ) +* + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL DGET01( N, N, A, LDA, AFAC, LDA, IWORK, + $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* + IF( INFO.EQ.0 ) THEN + TRFCON = .FALSE. +* +* Compute residual of the computed solution. +* + CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, + $ LDA ) + CALL DGET02( TRANS, N, N, NRHS, ASAV, LDA, X, + $ LDA, WORK, LDA, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + ELSE + IF( ITRAN.EQ.1 ) THEN + ROLDC = ROLDO + ELSE + ROLDC = ROLDI + END IF + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, + $ ROLDC, RESULT( 3 ) ) + END IF +* +* Check the error bounds from iterative +* refinement. +* + CALL DGET07( TRANS, N, NRHS, ASAV, LDA, B, LDA, + $ X, LDA, XACT, LDA, RWORK, .TRUE., + $ RWORK( NRHS+1 ), RESULT( 4 ) ) + ELSE + TRFCON = .TRUE. + END IF +* +* Compare RCOND from DGESVX with the computed value +* in RCONDC. +* + RESULT( 6 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( .NOT.TRFCON ) THEN + DO 40 K = K1, NTESTS + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'DGESVX', + $ FACT, TRANS, N, EQUED, IMAT, K, + $ RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'DGESVX', + $ FACT, TRANS, N, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 40 CONTINUE + NRUN = NRUN + 7 - K1 + ELSE + IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) + $ THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'DGESVX', FACT, + $ TRANS, N, EQUED, IMAT, 1, RESULT( 1 ) + ELSE + WRITE( NOUT, FMT = 9998 )'DGESVX', FACT, + $ TRANS, N, IMAT, 1, RESULT( 1 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 6 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'DGESVX', FACT, + $ TRANS, N, EQUED, IMAT, 6, RESULT( 6 ) + ELSE + WRITE( NOUT, FMT = 9998 )'DGESVX', FACT, + $ TRANS, N, IMAT, 6, RESULT( 6 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'DGESVX', FACT, + $ TRANS, N, EQUED, IMAT, 7, RESULT( 7 ) + ELSE + WRITE( NOUT, FMT = 9998 )'DGESVX', FACT, + $ TRANS, N, IMAT, 7, RESULT( 7 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF +* + END IF +* +* --- Test DGESVXX --- +* +* Restore the matrices A and B. +* + CALL DLACPY( 'Full', N, N, ASAV, LDA, A, LDA ) + CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, B, LDA ) + + IF( .NOT.PREFAC ) + $ CALL DLASET( 'Full', N, N, ZERO, ZERO, AFAC, + $ LDA ) + CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT = 'F' and +* EQUED = 'R', 'C', or 'B'. +* + CALL DLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND, + $ COLCND, AMAX, EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using DGESVXX. +* + SRNAMT = 'DGESVXX' + N_ERR_BNDS = 3 + CALL DGESVXX( FACT, TRANS, N, NRHS, A, LDA, AFAC, + $ LDA, IWORK, EQUED, S, S( N+1 ), B, LDA, X, + $ LDA, RCOND, RPVGRW_SVXX, BERR, N_ERR_BNDS, + $ ERRBNDS_N, ERRBNDS_C, 0, ZERO, WORK, + $ IWORK( N+1 ), INFO ) +* +* Check the error code from DGESVXX. +* + IF( INFO.EQ.N+1 ) GOTO 50 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'DGESVXX', INFO, IZERO, + $ FACT // TRANS, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GOTO 50 + END IF +* +* Compare rpvgrw_svxx from DGESVXX with the computed +* reciprocal pivot growth factor RPVGRW +* + + IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN + RPVGRW = DLA_RPVGRW(N, INFO, A, LDA, AFAC, LDA) + ELSE + RPVGRW = DLA_RPVGRW(N, N, A, LDA, AFAC, LDA) + ENDIF + + RESULT( 7 ) = ABS( RPVGRW-RPVGRW_SVXX ) / + $ MAX( RPVGRW_SVXX, RPVGRW ) / + $ DLAMCH( 'E' ) +* + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL DGET01( N, N, A, LDA, AFAC, LDA, IWORK, + $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* + IF( INFO.EQ.0 ) THEN + TRFCON = .FALSE. +* +* Compute residual of the computed solution. +* + CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, + $ LDA ) + CALL DGET02( TRANS, N, N, NRHS, ASAV, LDA, X, + $ LDA, WORK, LDA, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + ELSE + IF( ITRAN.EQ.1 ) THEN + ROLDC = ROLDO + ELSE + ROLDC = ROLDI + END IF + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, + $ ROLDC, RESULT( 3 ) ) + END IF + ELSE + TRFCON = .TRUE. + END IF +* +* Compare RCOND from DGESVXX with the computed value +* in RCONDC. +* + RESULT( 6 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( .NOT.TRFCON ) THEN + DO 45 K = K1, NTESTS + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'DGESVXX', + $ FACT, TRANS, N, EQUED, IMAT, K, + $ RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'DGESVXX', + $ FACT, TRANS, N, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 45 CONTINUE + NRUN = NRUN + 7 - K1 + ELSE + IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) + $ THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'DGESVXX', FACT, + $ TRANS, N, EQUED, IMAT, 1, RESULT( 1 ) + ELSE + WRITE( NOUT, FMT = 9998 )'DGESVXX', FACT, + $ TRANS, N, IMAT, 1, RESULT( 1 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 6 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'DGESVXX', FACT, + $ TRANS, N, EQUED, IMAT, 6, RESULT( 6 ) + ELSE + WRITE( NOUT, FMT = 9998 )'DGESVXX', FACT, + $ TRANS, N, IMAT, 6, RESULT( 6 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'DGESVXX', FACT, + $ TRANS, N, EQUED, IMAT, 7, RESULT( 7 ) + ELSE + WRITE( NOUT, FMT = 9998 )'DGESVXX', FACT, + $ TRANS, N, IMAT, 7, RESULT( 7 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF +* + END IF +* + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + +* Test Error Bounds from DGESVXX + + CALL DEBCHVXX( THRESH, PATH ) + + 9999 FORMAT( 1X, A, ', N =', I5, ', type ', I2, ', test(', I2, ') =', + $ G12.5 ) + 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5, + $ ', type ', I2, ', test(', I1, ')=', G12.5 ) + 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5, + $ ', EQUED=''', A1, ''', type ', I2, ', test(', I1, ')=', + $ G12.5 ) + RETURN +* +* End of DDRVGE +* + END diff --git a/TESTING/LIN/ddrvgt.f b/TESTING/LIN/ddrvgt.f index a3aa53e1..4f7c4111 100644 --- a/TESTING/LIN/ddrvgt.f +++ b/TESTING/LIN/ddrvgt.f @@ -105,7 +105,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/ddrvls.f b/TESTING/LIN/ddrvls.f index 30e01618..5bc1e93d 100644 --- a/TESTING/LIN/ddrvls.f +++ b/TESTING/LIN/ddrvls.f @@ -148,7 +148,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/ddrvpb.f b/TESTING/LIN/ddrvpb.f index 8c5d1a83..7752c3f9 100644 --- a/TESTING/LIN/ddrvpb.f +++ b/TESTING/LIN/ddrvpb.f @@ -122,7 +122,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/ddrvpo.f b/TESTING/LIN/ddrvpo.f index 0ee27449..e9f94a57 100644 --- a/TESTING/LIN/ddrvpo.f +++ b/TESTING/LIN/ddrvpo.f @@ -121,7 +121,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/ddrvpox.f b/TESTING/LIN/ddrvpox.f new file mode 100644 index 00000000..11a796aa --- /dev/null +++ b/TESTING/LIN/ddrvpox.f @@ -0,0 +1,634 @@ + SUBROUTINE DDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, + $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION A( * ), AFAC( * ), ASAV( * ), B( * ), + $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), + $ X( * ), XACT( * ) +* .. +* +* Purpose +* ======= +* +* DDRVPO tests the driver routines DPOSV, -SVX, and -SVXX. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* NRHS (input) INTEGER +* The number of right hand side vectors to be generated for +* each linear system. +* +* THRESH (input) 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. +* +* TSTERR (input) LOGICAL +* Flag that indicates whether error exits are to be tested. +* +* NMAX (input) INTEGER +* The maximum value permitted for N, used in dimensioning the +* work arrays. +* +* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) +* +* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) +* +* ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) +* +* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) +* +* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) +* +* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) +* +* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NRHS) +* +* S (workspace) DOUBLE PRECISION array, dimension (NMAX) +* +* WORK (workspace) DOUBLE PRECISION array, dimension +* (NMAX*max(3,NRHS)) +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) +* +* IWORK (workspace) INTEGER array, dimension (NMAX) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 9 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 6 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, PREFAC, ZEROT + CHARACTER DIST, EQUED, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 PATH + INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, K, K1, KL, KU, LDA, MODE, N, NB, NBMIN, + $ NERRS, NFACT, NFAIL, NIMAT, NRUN, NT, + $ N_ERR_BNDS + DOUBLE PRECISION AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC, + $ ROLDC, SCOND, RPVGRW_SVXX +* .. +* .. Local Arrays .. + CHARACTER EQUEDS( 2 ), FACTS( 3 ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ), BERR( NRHS ), + $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DGET06, DLANSY + EXTERNAL LSAME, DGET06, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, DERRVX, DGET04, DLACPY, + $ DLAQSY, DLARHS, DLASET, DLATB4, DLATMS, DPOEQU, + $ DPOSV, DPOSVX, DPOT01, DPOT02, DPOT05, DPOTRF, + $ DPOTRI, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. 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' / + DATA FACTS / 'F', 'N', 'E' / + DATA EQUEDS / 'N', 'Y' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'PO' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL DERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 130 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 120 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 120 +* +* Skip types 3, 4, or 5 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 120 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 110 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with DLATB4 and generate a test matrix +* with DLATMS. +* + CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) +* + 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. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 110 + END IF +* +* For types 3-5, zero one row and column 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 + IOFF = ( IZERO-1 )*LDA +* +* Set row and column IZERO of A to 0. +* + IF( IUPLO.EQ.1 ) THEN + 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 + IZERO = 0 + END IF +* +* Save a copy of the matrix A in ASAV. +* + CALL DLACPY( UPLO, N, N, A, LDA, ASAV, LDA ) +* + DO 100 IEQUED = 1, 2 + EQUED = EQUEDS( IEQUED ) + IF( IEQUED.EQ.1 ) THEN + NFACT = 3 + ELSE + NFACT = 1 + END IF +* + DO 90 IFACT = 1, NFACT + DO I = 1, NTESTS + RESULT (I) = ZERO + END DO + FACT = FACTS( IFACT ) + PREFAC = LSAME( FACT, 'F' ) + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) +* + IF( ZEROT ) THEN + IF( PREFAC ) + $ GO TO 90 + RCONDC = ZERO +* + ELSE IF( .NOT.LSAME( FACT, 'N' ) ) THEN +* +* Compute the condition number for comparison with +* the value returned by DPOSVX (FACT = 'N' reuses +* the condition number from the previous iteration +* with FACT = 'F'). +* + CALL DLACPY( UPLO, N, N, ASAV, LDA, AFAC, LDA ) + IF( EQUIL .OR. IEQUED.GT.1 ) THEN +* +* Compute row and column scale factors to +* equilibrate the matrix A. +* + CALL DPOEQU( N, AFAC, LDA, S, SCOND, AMAX, + $ INFO ) + IF( INFO.EQ.0 .AND. N.GT.0 ) THEN + IF( IEQUED.GT.1 ) + $ SCOND = ZERO +* +* Equilibrate the matrix. +* + CALL DLAQSY( UPLO, N, AFAC, LDA, S, SCOND, + $ AMAX, EQUED ) + END IF + END IF +* +* Save the condition number of the +* non-equilibrated system for use in DGET04. +* + IF( EQUIL ) + $ ROLDC = RCONDC +* +* Compute the 1-norm of A. +* + ANORM = DLANSY( '1', UPLO, N, AFAC, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL DPOTRF( UPLO, N, AFAC, LDA, INFO ) +* +* Form the inverse of A. +* + CALL DLACPY( UPLO, N, N, AFAC, LDA, A, LDA ) + CALL DPOTRI( UPLO, N, A, LDA, INFO ) +* +* Compute the 1-norm condition number of A. +* + AINVNM = DLANSY( '1', UPLO, N, A, LDA, RWORK ) + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Restore the matrix A. +* + CALL DLACPY( UPLO, N, N, ASAV, LDA, A, LDA ) +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'DLARHS' + CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, + $ ISEED, INFO ) + XTYPE = 'C' + CALL DLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA ) +* + IF( NOFACT ) THEN +* +* --- Test DPOSV --- +* +* Compute the L*L' or U'*U factorization of the +* matrix and solve the system. +* + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL DLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'DPOSV ' + CALL DPOSV( UPLO, N, NRHS, AFAC, LDA, X, LDA, + $ INFO ) +* +* Check error code from DPOSV . +* + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'DPOSV ', INFO, IZERO, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) + GO TO 70 + ELSE IF( INFO.NE.0 ) THEN + GO TO 70 + END IF +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL DPOT01( UPLO, N, A, LDA, AFAC, LDA, RWORK, + $ RESULT( 1 ) ) +* +* 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 ) ) +* +* 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 60 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 )'DPOSV ', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 60 CONTINUE + NRUN = NRUN + NT + 70 CONTINUE + END IF +* +* --- Test DPOSVX --- +* + IF( .NOT.PREFAC ) + $ CALL DLASET( UPLO, N, N, ZERO, ZERO, AFAC, LDA ) + CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT='F' and +* EQUED='Y'. +* + CALL DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, + $ EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using DPOSVX. +* + SRNAMT = 'DPOSVX' + CALL DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AFAC, + $ LDA, EQUED, S, B, LDA, X, LDA, RCOND, + $ RWORK, RWORK( NRHS+1 ), WORK, IWORK, + $ INFO ) +* +* Check the error code from DPOSVX. +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'DPOSVX', INFO, IZERO, + $ FACT // UPLO, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GO TO 90 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL DPOT01( UPLO, N, A, LDA, AFAC, LDA, + $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* +* Compute residual of the computed solution. +* + CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, + $ LDA ) + CALL DPOT02( UPLO, N, NRHS, ASAV, LDA, X, LDA, + $ WORK, LDA, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + ELSE + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, + $ ROLDC, RESULT( 3 ) ) + END IF +* +* Check the error bounds from iterative +* refinement. +* + CALL DPOT05( UPLO, N, NRHS, ASAV, LDA, B, LDA, + $ X, LDA, XACT, LDA, RWORK, + $ RWORK( NRHS+1 ), RESULT( 4 ) ) + ELSE + K1 = 6 + END IF +* +* Compare RCOND from DPOSVX with the computed value +* in RCONDC. +* + RESULT( 6 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 80 K = K1, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'DPOSVX', FACT, + $ UPLO, N, EQUED, IMAT, K, RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'DPOSVX', FACT, + $ UPLO, N, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 80 CONTINUE + NRUN = NRUN + 7 - K1 +* +* --- Test DPOSVXX --- +* +* Restore the matrices A and B. +* + CALL DLACPY( 'Full', N, N, ASAV, LDA, A, LDA ) + CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, B, LDA ) + + IF( .NOT.PREFAC ) + $ CALL DLASET( UPLO, N, N, ZERO, ZERO, AFAC, LDA ) + CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT='F' and +* EQUED='Y'. +* + CALL DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, + $ EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using DPOSVXX. +* + SRNAMT = 'DPOSVXX' + CALL DPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AFAC, + $ LDA, EQUED, S, B, LDA, X, + $ LDA, rcond, rpvgrw_svxx, berr, n_err_bnds, + $ errbnds_n, errbnds_c, 0, ZERO, WORK, + $ IWORK, INFO ) +* +* Check the error code from DPOSVXX. +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'DPOSVXX', INFO, IZERO, + $ FACT // UPLO, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GO TO 90 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL DPOT01( UPLO, N, A, LDA, AFAC, LDA, + $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* +* Compute residual of the computed solution. +* + CALL DLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, + $ LDA ) + CALL DPOT02( UPLO, N, NRHS, ASAV, LDA, X, LDA, + $ WORK, LDA, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + ELSE + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, + $ ROLDC, RESULT( 3 ) ) + END IF +* +* Check the error bounds from iterative +* refinement. +* + CALL DPOT05( UPLO, N, NRHS, ASAV, LDA, B, LDA, + $ X, LDA, XACT, LDA, RWORK, + $ RWORK( NRHS+1 ), RESULT( 4 ) ) + ELSE + K1 = 6 + END IF +* +* Compare RCOND from DPOSVXX with the computed value +* in RCONDC. +* + RESULT( 6 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 85 K = K1, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'DPOSVXX', FACT, + $ UPLO, N, EQUED, IMAT, K, RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'DPOSVXX', FACT, + $ UPLO, N, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 85 CONTINUE + NRUN = NRUN + 7 - K1 + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + +* Test Error Bounds from DPOSVXX + + CALL DEBCHVXX( THRESH, PATH ) + + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I1, + $ ', test(', I1, ')=', G12.5 ) + 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5, + $ ', type ', I1, ', test(', I1, ')=', G12.5 ) + 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5, + $ ', EQUED=''', A1, ''', type ', I1, ', test(', I1, ') =', + $ G12.5 ) + RETURN +* +* End of DDRVPO +* + END diff --git a/TESTING/LIN/ddrvpp.f b/TESTING/LIN/ddrvpp.f index edbb83ee..c8ee4f81 100644 --- a/TESTING/LIN/ddrvpp.f +++ b/TESTING/LIN/ddrvpp.f @@ -121,7 +121,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/ddrvpt.f b/TESTING/LIN/ddrvpt.f index 78a313e0..0203b24e 100644 --- a/TESTING/LIN/ddrvpt.f +++ b/TESTING/LIN/ddrvpt.f @@ -108,7 +108,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/ddrvrf1.f b/TESTING/LIN/ddrvrf1.f new file mode 100644 index 00000000..0b9413e6 --- /dev/null +++ b/TESTING/LIN/ddrvrf1.f @@ -0,0 +1,216 @@ + SUBROUTINE DDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER LDA, NN, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ) + DOUBLE PRECISION A( LDA, * ), ARF( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* DDRVRF1 tests the LAPACK RFP routines: +* DLANSF +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* THRESH (input) 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. +* +* A (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* ARF (workspace) DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2). +* +* WORK (workspace) DOUBLE PRECISION array, dimension ( NMAX ) +* +* ===================================================================== +* .. +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 1 ) +* .. +* .. Local Scalars .. + CHARACTER UPLO, CFORM, NORM + INTEGER I, IFORM, IIN, IIT, INFO, INORM, IUPLO, J, N, + + NERRS, NFAIL, NRUN + DOUBLE PRECISION EPS, LARGE, NORMA, NORMARF, SMALL +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ), NORMS( 4 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANSY, DLANSF, DLARND + EXTERNAL DLAMCH, DLANSY, DLANSF, DLARND +* .. +* .. External Subroutines .. + EXTERNAL DTRTTF +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'T' / + DATA NORMS / 'M', '1', 'I', 'F' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + INFO = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* + EPS = DLAMCH( 'Precision' ) + SMALL = DLAMCH( 'Safe minimum' ) + LARGE = ONE / SMALL + SMALL = SMALL * LDA * LDA + LARGE = LARGE / LDA / LDA +* + DO 130 IIN = 1, NN +* + N = NVAL( IIN ) +* + DO 120 IIT = 1, 3 +* +* IIT = 1 : random matrix +* IIT = 2 : random matrix scaled near underflow +* IIT = 3 : random matrix scaled near overflow +* + DO J = 1, N + DO I = 1, N + A( I, J) = DLARND( 2, ISEED ) + END DO + END DO +* + IF ( IIT.EQ.2 ) THEN + DO J = 1, N + DO I = 1, N + A( I, J) = A( I, J ) * LARGE + END DO + END DO + END IF +* + IF ( IIT.EQ.3 ) THEN + DO J = 1, N + DO I = 1, N + A( I, J) = A( I, J) * SMALL + END DO + END DO + END IF +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 110 IUPLO = 1, 2 +* + UPLO = UPLOS( IUPLO ) +* +* Do first for CFORM = 'N', then for CFORM = 'C' +* + DO 100 IFORM = 1, 2 +* + CFORM = FORMS( IFORM ) +* + SRNAMT = 'DTRTTF' + CALL DTRTTF( CFORM, UPLO, N, A, LDA, ARF, INFO ) +* +* Check error code from DTRTTF +* + IF( INFO.NE.0 ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9998 ) SRNAMT, UPLO, CFORM, N + NERRS = NERRS + 1 + GO TO 100 + END IF +* + DO 90 INORM = 1, 4 +* +* Check all four norms: 'M', '1', 'I', 'F' +* + NORM = NORMS( INORM ) + NORMARF = DLANSF( NORM, CFORM, UPLO, N, ARF, WORK ) + NORMA = DLANSY( NORM, UPLO, N, A, LDA, WORK ) +* + RESULT(1) = ( NORMA - NORMARF ) / NORMA / EPS + NRUN = NRUN + 1 +* + IF( RESULT(1).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9997 ) 'DLANSF', + + N, IIT, UPLO, CFORM, NORM, RESULT(1) + NFAIL = NFAIL + 1 + END IF + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE +* +* Print a summary of the results. +* + IF ( NFAIL.EQ.0 ) THEN + WRITE( NOUT, FMT = 9996 ) 'DLANSF', NRUN + ELSE + WRITE( NOUT, FMT = 9995 ) 'DLANSF', NFAIL, NRUN + END IF + IF ( NERRS.NE.0 ) THEN + WRITE( NOUT, FMT = 9994 ) NERRS, 'DLANSF' + END IF +* + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing DLANSF + + ***') + 9998 FORMAT( 1X, ' Error in ',A6,' with UPLO=''',A1,''', FORM=''', + + A1,''', N=',I5) + 9997 FORMAT( 1X, ' Failure in ',A6,' N=',I5,' TYPE=',I5,' UPLO=''', + + A1, ''', FORM =''',A1,''', NORM=''',A1,''', test=',G12.5) + 9996 FORMAT( 1X, 'All tests for ',A6,' auxiliary routine passed the ', + + 'threshold (',I5,' tests run)') + 9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5, + + ' tests failed to pass the threshold') + 9994 FORMAT( 26X, I5,' error message recorded (',A6,')') +* + RETURN +* +* End of DDRVRF1 +* + END diff --git a/TESTING/LIN/ddrvrf2.f b/TESTING/LIN/ddrvrf2.f new file mode 100644 index 00000000..6ca6ad97 --- /dev/null +++ b/TESTING/LIN/ddrvrf2.f @@ -0,0 +1,202 @@ + SUBROUTINE DDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER LDA, NN, NOUT +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ) + DOUBLE PRECISION A( LDA, * ), ARF( * ), AP(*), ASAV( LDA, * ) +* .. +* +* Purpose +* ======= +* +* DDRVRF2 tests the LAPACK RFP convertion routines. +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* A (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* ARF (workspace) DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2). +* +* AP (workspace) DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2). +* +* A2 (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) +* +* ===================================================================== +* .. +* .. Local Scalars .. + LOGICAL LOWER, OK1, OK2 + CHARACTER UPLO, CFORM + INTEGER I, IFORM, IIN, INFO, IUPLO, J, N, + + NERRS, NRUN +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLARND + EXTERNAL DLARND +* .. +* .. External Subroutines .. + EXTERNAL DTFTTR, DTFTTP, DTRTTF, DTRTTP, DTPTTR, DTPTTF +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'T' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NERRS = 0 + INFO = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* + DO 120 IIN = 1, NN +* + N = NVAL( IIN ) +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 110 IUPLO = 1, 2 +* + UPLO = UPLOS( IUPLO ) + LOWER = .TRUE. + IF ( IUPLO.EQ.1 ) LOWER = .FALSE. +* +* Do first for CFORM = 'N', then for CFORM = 'T' +* + DO 100 IFORM = 1, 2 +* + CFORM = FORMS( IFORM ) +* + NRUN = NRUN + 1 +* + DO J = 1, N + DO I = 1, N + A( I, J) = DLARND( 2, ISEED ) + END DO + END DO +* + SRNAMT = 'DTRTTF' + CALL DTRTTF( CFORM, UPLO, N, A, LDA, ARF, INFO ) +* + SRNAMT = 'DTFTTP' + CALL DTFTTP( CFORM, UPLO, N, ARF, AP, INFO ) +* + SRNAMT = 'DTPTTR' + CALL DTPTTR( UPLO, N, AP, ASAV, LDA, INFO ) +* + OK1 = .TRUE. + IF ( LOWER ) THEN + DO J = 1, N + DO I = J, N + IF ( A(I,J).NE.ASAV(I,J) ) THEN + OK1 = .FALSE. + END IF + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, J + IF ( A(I,J).NE.ASAV(I,J) ) THEN + OK1 = .FALSE. + END IF + END DO + END DO + END IF +* + NRUN = NRUN + 1 +* + SRNAMT = 'DTRTTP' + CALL DTRTTP( UPLO, N, A, LDA, AP, INFO ) +* + SRNAMT = 'DTPTTF' + CALL DTPTTF( CFORM, UPLO, N, AP, ARF, INFO ) +* + SRNAMT = 'DTFTTR' + CALL DTFTTR( CFORM, UPLO, N, ARF, ASAV, LDA, INFO ) +* + OK2 = .TRUE. + IF ( LOWER ) THEN + DO J = 1, N + DO I = J, N + IF ( A(I,J).NE.ASAV(I,J) ) THEN + OK2 = .FALSE. + END IF + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, J + IF ( A(I,J).NE.ASAV(I,J) ) THEN + OK2 = .FALSE. + END IF + END DO + END DO + END IF +* + IF (( .NOT.OK1 ).OR.( .NOT.OK2 )) THEN + IF( NERRS.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9998 ) N, UPLO, CFORM + NERRS = NERRS + 1 + END IF +* + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE +* +* Print a summary of the results. +* + IF ( NERRS.EQ.0 ) THEN + WRITE( NOUT, FMT = 9997 ) NRUN + ELSE + WRITE( NOUT, FMT = 9996 ) NERRS, NRUN + END IF +* + 9999 FORMAT( 1X, ' *** Error(s) while testing the RFP convertion', + + ' routines ***') + 9998 FORMAT( 1X, ' Error in RFP,convertion routines N=',I5, + + ' UPLO=''', A1, ''', FORM =''',A1,'''') + 9997 FORMAT( 1X, 'All tests for the RFP convertion routines passed (', + + I5,' tests run)') + 9996 FORMAT( 1X, 'RFP convertion routines:',I5,' out of ',I5, + + ' error message recorded') +* + RETURN +* +* End of DDRVRF2 +* + END diff --git a/TESTING/LIN/ddrvrf3.f b/TESTING/LIN/ddrvrf3.f new file mode 100644 index 00000000..3bef2f73 --- /dev/null +++ b/TESTING/LIN/ddrvrf3.f @@ -0,0 +1,298 @@ + SUBROUTINE DDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, + + D_WORK_DLANGE, D_WORK_DGEQRF, TAU ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER LDA, NN, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ) + DOUBLE PRECISION A( LDA, * ), ARF( * ), B1( LDA, * ), + + B2( LDA, * ), D_WORK_DGEQRF( * ), + + D_WORK_DLANGE( * ), TAU( * ) +* .. +* +* Purpose +* ======= +* +* DDRVRF3 tests the LAPACK RFP routines: +* DTFSM +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* THRESH (input) 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. +* +* A (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* ARF (workspace) DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2). +* +* B1 (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) +* +* B2 (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX) +* +* D_WORK_DLANGE (workspace) DOUBLE PRECISION array, dimension (NMAX) +* +* D_WORK_DGEQRF (workspace) DOUBLE PRECISION array, dimension (NMAX) +* +* TAU (workspace) DOUBLE PRECISION array, dimension (NMAX) +* +* ===================================================================== +* .. +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) , + + ONE = ( 1.0D+0, 0.0D+0 ) ) + INTEGER NTESTS + PARAMETER ( NTESTS = 1 ) +* .. +* .. Local Scalars .. + CHARACTER UPLO, CFORM, DIAG, TRANS, SIDE + INTEGER I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA, + + NFAIL, NRUN, ISIDE, IDIAG, IALPHA, ITRANS + DOUBLE PRECISION EPS, ALPHA +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ), + + DIAGS( 2 ), SIDES( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLANGE, DLARND + EXTERNAL DLAMCH, DLANGE, DLARND +* .. +* .. External Subroutines .. + EXTERNAL DTRTTF, DGEQRF, DGEQLF, DTFSM, DTRSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'T' / + DATA SIDES / 'L', 'R' / + DATA TRANSS / 'N', 'T' / + DATA DIAGS / 'N', 'U' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NFAIL = 0 + INFO = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + EPS = DLAMCH( 'Precision' ) +* + DO 170 IIM = 1, NN +* + M = NVAL( IIM ) +* + DO 160 IIN = 1, NN +* + N = NVAL( IIN ) +* + DO 150 IFORM = 1, 2 +* + CFORM = FORMS( IFORM ) +* + DO 140 IUPLO = 1, 2 +* + UPLO = UPLOS( IUPLO ) +* + DO 130 ISIDE = 1, 2 +* + SIDE = SIDES( ISIDE ) +* + DO 120 ITRANS = 1, 2 +* + TRANS = TRANSS( ITRANS ) +* + DO 110 IDIAG = 1, 2 +* + DIAG = DIAGS( IDIAG ) +* + DO 100 IALPHA = 1, 3 +* + IF ( IALPHA.EQ. 1) THEN + ALPHA = ZERO + ELSE IF ( IALPHA.EQ. 1) THEN + ALPHA = ONE + ELSE + ALPHA = DLARND( 2, ISEED ) + END IF +* +* All the parameters are set: +* CFORM, SIDE, UPLO, TRANS, DIAG, M, N, +* and ALPHA +* READY TO TEST! +* + NRUN = NRUN + 1 +* + IF ( ISIDE.EQ.1 ) THEN +* +* The case ISIDE.EQ.1 is when SIDE.EQ.'L' +* -> A is M-by-M ( B is M-by-N ) +* + NA = M +* + ELSE +* +* The case ISIDE.EQ.2 is when SIDE.EQ.'R' +* -> A is N-by-N ( B is M-by-N ) +* + NA = N +* + END IF +* +* Generate A our NA--by--NA triangular +* matrix. +* Our test is based on forward error so we +* do want A to be well conditionned! To get +* a well-conditionned triangular matrix, we +* take the R factor of the QR/LQ factorization +* of a random matrix. +* + DO J = 1, NA + DO I = 1, NA + A( I, J) = DLARND( 2, ISEED ) + END DO + END DO +* + IF ( IUPLO.EQ.1 ) THEN +* +* The case IUPLO.EQ.1 is when SIDE.EQ.'U' +* -> QR factorization. +* + SRNAMT = 'DGEQRF' + CALL DGEQRF( NA, NA, A, LDA, TAU, + + D_WORK_DGEQRF, LDA, + + INFO ) + ELSE +* +* The case IUPLO.EQ.2 is when SIDE.EQ.'L' +* -> QL factorization. +* + SRNAMT = 'DGELQF' + CALL DGELQF( NA, NA, A, LDA, TAU, + + D_WORK_DGEQRF, LDA, + + INFO ) + END IF +* +* Store a copy of A in RFP format (in ARF). +* + SRNAMT = 'DTRTTF' + CALL DTRTTF( CFORM, UPLO, NA, A, LDA, ARF, + + INFO ) +* +* Generate B1 our M--by--N right-hand side +* and store a copy in B2. +* + DO J = 1, N + DO I = 1, M + B1( I, J) = DLARND( 2, ISEED ) + B2( I, J) = B1( I, J) + END DO + END DO +* +* Solve op( A ) X = B or X op( A ) = B +* with DTRSM +* + SRNAMT = 'DTRSM' + CALL DTRSM( SIDE, UPLO, TRANS, DIAG, M, N, + + ALPHA, A, LDA, B1, LDA ) +* +* Solve op( A ) X = B or X op( A ) = B +* with DTFSM +* + SRNAMT = 'DTFSM' + CALL DTFSM( CFORM, SIDE, UPLO, TRANS, + + DIAG, M, N, ALPHA, ARF, B2, + + LDA ) +* +* Check that the result agrees. +* + DO J = 1, N + DO I = 1, M + B1( I, J) = B2( I, J ) - B1( I, J ) + END DO + END DO +* + RESULT(1) = DLANGE( 'I', M, N, B1, LDA, + + D_WORK_DLANGE ) +* + RESULT(1) = RESULT(1) / SQRT( EPS ) + + / MAX ( MAX( M, N), 1 ) +* + IF( RESULT(1).GE.THRESH ) THEN + IF( NFAIL.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9997 ) 'DTFSM', + + CFORM, SIDE, UPLO, TRANS, DIAG, M, + + N, RESULT(1) + NFAIL = NFAIL + 1 + END IF +* + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE +* +* Print a summary of the results. +* + IF ( NFAIL.EQ.0 ) THEN + WRITE( NOUT, FMT = 9996 ) 'DTFSM', NRUN + ELSE + WRITE( NOUT, FMT = 9995 ) 'DTFSM', NFAIL, NRUN + END IF +* + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing DTFSM + + ***') + 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', + + ' SIDE=''',A1,''',',' UPLO=''',A1,''',',' TRANS=''',A1,''',', + + ' DIAG=''',A1,''',',' M=',I3,', N =', I3,', test=',G12.5) + 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ', + + 'threshold (',I5,' tests run)') + 9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5, + + ' tests failed to pass the threshold') +* + RETURN +* +* End of DDRVRF3 +* + END diff --git a/TESTING/LIN/ddrvrf4.f b/TESTING/LIN/ddrvrf4.f new file mode 100644 index 00000000..d0c81314 --- /dev/null +++ b/TESTING/LIN/ddrvrf4.f @@ -0,0 +1,286 @@ + SUBROUTINE DDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, + + LDA, D_WORK_DLANGE ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER LDA, LDC, NN, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ) + DOUBLE PRECISION A( LDA, * ), C1( LDC, * ), C2( LDC, *), + + CRF( * ), D_WORK_DLANGE( * ) +* .. +* +* Purpose +* ======= +* +* DDRVRF4 tests the LAPACK RFP routines: +* DSFRK +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* THRESH (input) 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. +* +* C1 (workspace) DOUBLE PRECISION array, +* dimension (LDC,NMAX) +* +* C2 (workspace) DOUBLE PRECISION array, +* dimension (LDC,NMAX) +* +* LDC (input) INTEGER +* The leading dimension of the array A. +* LDA >= max(1,NMAX). +* +* CRF (workspace) DOUBLE PRECISION array, +* dimension ((NMAX*(NMAX+1))/2). +* +* A (workspace) DOUBLE PRECISION array, +* dimension (LDA,NMAX) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* D_WORK_DLANGE (workspace) DOUBLE PRECISION array, dimension (NMAX) +* +* ===================================================================== +* .. +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 1 ) +* .. +* .. Local Scalars .. + CHARACTER UPLO, CFORM, TRANS + INTEGER I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N, + + NFAIL, NRUN, IALPHA, ITRANS + DOUBLE PRECISION ALPHA, BETA, EPS, NORMA, NORMC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLARND, DLANGE + EXTERNAL DLAMCH, DLARND, DLANGE +* .. +* .. External Subroutines .. + EXTERNAL DSYRK, DSFRK, DTFTTR, DTRTTF +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'T' / + DATA TRANSS / 'N', 'T' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NFAIL = 0 + INFO = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + EPS = DLAMCH( 'Precision' ) +* + DO 150 IIN = 1, NN +* + N = NVAL( IIN ) +* + DO 140 IIK = 1, NN +* + K = NVAL( IIN ) +* + DO 130 IFORM = 1, 2 +* + CFORM = FORMS( IFORM ) +* + DO 120 IUPLO = 1, 2 +* + UPLO = UPLOS( IUPLO ) +* + DO 110 ITRANS = 1, 2 +* + TRANS = TRANSS( ITRANS ) +* + DO 100 IALPHA = 1, 4 +* + IF ( IALPHA.EQ. 1) THEN + ALPHA = ZERO + BETA = ZERO + ELSE IF ( IALPHA.EQ. 2) THEN + ALPHA = ONE + BETA = ZERO + ELSE IF ( IALPHA.EQ. 3) THEN + ALPHA = ZERO + BETA = ONE + ELSE + ALPHA = DLARND( 2, ISEED ) + BETA = DLARND( 2, ISEED ) + END IF +* +* All the parameters are set: +* CFORM, UPLO, TRANS, M, N, +* ALPHA, and BETA +* READY TO TEST! +* + NRUN = NRUN + 1 +* + IF ( ITRANS.EQ.1 ) THEN +* +* In this case we are NOTRANS, so A is N-by-K +* + DO J = 1, K + DO I = 1, N + A( I, J) = DLARND( 2, ISEED ) + END DO + END DO +* + NORMA = DLANGE( 'I', N, K, A, LDA, + + D_WORK_DLANGE ) +* + + ELSE +* +* In this case we are TRANS, so A is K-by-N +* + DO J = 1,N + DO I = 1, K + A( I, J) = DLARND( 2, ISEED ) + END DO + END DO +* + NORMA = DLANGE( 'I', K, N, A, LDA, + + D_WORK_DLANGE ) +* + END IF +* +* Generate C1 our N--by--N symmetric matrix. +* Make sure C2 has the same upper/lower part, +* (the one that we do not touch), so +* copy the initial C1 in C2 in it. +* + DO J = 1, N + DO I = 1, N + C1( I, J) = DLARND( 2, ISEED ) + C2(I,J) = C1(I,J) + END DO + END DO +* +* (See comment later on for why we use DLANGE and +* not DLANSY for C1.) +* + NORMC = DLANGE( 'I', N, N, C1, LDC, + + D_WORK_DLANGE ) +* + SRNAMT = 'DTRTTF' + CALL DTRTTF( CFORM, UPLO, N, C1, LDC, CRF, + + INFO ) +* +* call dsyrk the BLAS routine -> gives C1 +* + SRNAMT = 'DSYRK ' + CALL DSYRK( UPLO, TRANS, N, K, ALPHA, A, LDA, + + BETA, C1, LDC ) +* +* call dsfrk the RFP routine -> gives CRF +* + SRNAMT = 'DSFRK ' + CALL DSFRK( CFORM, UPLO, TRANS, N, K, ALPHA, A, + + LDA, BETA, CRF ) +* +* convert CRF in full format -> gives C2 +* + SRNAMT = 'DTFTTR' + CALL DTFTTR( CFORM, UPLO, N, CRF, C2, LDC, + + INFO ) +* +* compare C1 and C2 +* + DO J = 1, N + DO I = 1, N + C1(I,J) = C1(I,J)-C2(I,J) + END DO + END DO +* +* Yes, C1 is symmetric so we could call DLANSY, +* but we want to check the upper part that is +* supposed to be unchanged and the diagonal that +* is supposed to be real -> DLANGE +* + RESULT(1) = DLANGE( 'I', N, N, C1, LDC, + + D_WORK_DLANGE ) + RESULT(1) = RESULT(1) + + / MAX( ABS( ALPHA ) * NORMA + + + ABS( BETA ) , ONE ) + + / MAX( N , 1 ) / EPS +* + IF( RESULT(1).GE.THRESH ) THEN + IF( NFAIL.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9997 ) 'DSFRK', + + CFORM, UPLO, TRANS, N, K, RESULT(1) + NFAIL = NFAIL + 1 + END IF +* + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE +* +* Print a summary of the results. +* + IF ( NFAIL.EQ.0 ) THEN + WRITE( NOUT, FMT = 9996 ) 'DSFRK', NRUN + ELSE + WRITE( NOUT, FMT = 9995 ) 'DSFRK', NFAIL, NRUN + END IF +* + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing DSFRK + + ***') + 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', + + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3, + + ', test=',G12.5) + 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ', + + 'threshold (',I5,' tests run)') + 9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5, + + ' tests failed to pass the threshold') +* + RETURN +* +* End of DDRVRF4 +* + END diff --git a/TESTING/LIN/ddrvrfp.f b/TESTING/LIN/ddrvrfp.f new file mode 100644 index 00000000..90e57d01 --- /dev/null +++ b/TESTING/LIN/ddrvrfp.f @@ -0,0 +1,446 @@ + SUBROUTINE DDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, + + THRESH, A, ASAV, AFAC, AINV, B, + + BSAV, XACT, X, ARF, ARFINV, + + D_WORK_DLATMS, D_WORK_DPOT01, D_TEMP_DPOT02, + + D_TEMP_DPOT03, D_WORK_DLANSY, + + D_WORK_DPOT02, D_WORK_DPOT03 ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER NN, NNS, NNT, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ), NSVAL( NNS ), NTVAL( NNT ) + DOUBLE PRECISION A( * ) + DOUBLE PRECISION AINV( * ) + DOUBLE PRECISION ASAV( * ) + DOUBLE PRECISION B( * ) + DOUBLE PRECISION BSAV( * ) + DOUBLE PRECISION AFAC( * ) + DOUBLE PRECISION ARF( * ) + DOUBLE PRECISION ARFINV( * ) + DOUBLE PRECISION XACT( * ) + DOUBLE PRECISION X( * ) + DOUBLE PRECISION D_WORK_DLATMS( * ) + DOUBLE PRECISION D_WORK_DPOT01( * ) + DOUBLE PRECISION D_TEMP_DPOT02( * ) + DOUBLE PRECISION D_TEMP_DPOT03( * ) + DOUBLE PRECISION D_WORK_DLANSY( * ) + DOUBLE PRECISION D_WORK_DPOT02( * ) + DOUBLE PRECISION D_WORK_DPOT03( * ) +* .. +* +* Purpose +* ======= +* +* DDRVRFP tests the LAPACK RFP routines: +* DPFTRF, DPFTRS, and DPFTRI. +* +* This testing routine follow the same tests as DDRVPO (test for the full +* format Symmetric Positive Definite solver). +* +* The tests are performed in Full Format, convertion back and forth from +* full format to RFP format are performed using the routines DTRTTF and +* DTFTTR. +* +* First, a specific matrix A of size N is created. There is nine types of +* different matrixes possible. +* 1. Diagonal 6. Random, CNDNUM = sqrt(0.1/EPS) +* 2. Random, CNDNUM = 2 7. Random, CNDNUM = 0.1/EPS +* *3. First row and column zero 8. Scaled near underflow +* *4. Last row and column zero 9. Scaled near overflow +* *5. Middle row and column zero +* (* - tests error exits from DPFTRF, no test ratios are computed) +* A solution XACT of size N-by-NRHS is created and the associated right +* hand side B as well. Then DPFTRF is called to compute L (or U), the +* Cholesky factor of A. Then L (or U) is used to solve the linear system +* of equations AX = B. This gives X. Then L (or U) is used to compute the +* inverse of A, AINV. The following four tests are then performed: +* (1) norm( L*L' - A ) / ( N * norm(A) * EPS ) or +* norm( U'*U - A ) / ( N * norm(A) * EPS ), +* (2) norm(B - A*X) / ( norm(A) * norm(X) * EPS ), +* (3) norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), +* (4) ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ), +* where EPS is the machine precision, RCOND the condition number of A, and +* norm( . ) the 1-norm for (1,2,3) and the inf-norm for (4). +* Errors occur when INFO parameter is not as expected. Failures occur when +* a test ratios is greater than THRES. +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* NNS (input) INTEGER +* The number of values of NRHS contained in the vector NSVAL. +* +* NSVAL (input) INTEGER array, dimension (NNS) +* The values of the number of right-hand sides NRHS. +* +* NNT (input) INTEGER +* The number of values of MATRIX TYPE contained in the vector NTVAL. +* +* NTVAL (input) INTEGER array, dimension (NNT) +* The values of matrix type (between 0 and 9 for PO/PP/PF matrices). +* +* THRESH (input) 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. +* +* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) +* +* ASAV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) +* +* AFAC (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) +* +* AINV (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX) +* +* B (workspace) DOUBLE PRECISION array, dimension (NMAX*MAXRHS) +* +* BSAV (workspace) DOUBLE PRECISION array, dimension (NMAX*MAXRHS) +* +* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*MAXRHS) +* +* X (workspace) DOUBLE PRECISION array, dimension (NMAX*MAXRHS) +* +* ARF (workspace) DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2) +* +* ARFINV (workspace) DOUBLE PRECISION array, dimension ((NMAX*(NMAX+1))/2) +* +* D_WORK_DLATMS (workspace) DOUBLE PRECISION array, dimension ( 3*NMAX ) +* +* D_WORK_DPOT01 (workspace) DOUBLE PRECISION array, dimension ( NMAX ) +* +* D_TEMP_DPOT02 (workspace) DOUBLE PRECISION array, dimension ( NMAX*MAXRHS ) +* +* D_TEMP_DPOT03 (workspace) DOUBLE PRECISION array, dimension ( NMAX*NMAX ) +* +* D_WORK_DLATMS (workspace) DOUBLE PRECISION array, dimension ( NMAX ) +* +* D_WORK_DLANSY (workspace) DOUBLE PRECISION array, dimension ( NMAX ) +* +* D_WORK_DPOT02 (workspace) DOUBLE PRECISION array, dimension ( NMAX ) +* +* D_WORK_DPOT03 (workspace) DOUBLE PRECISION array, dimension ( NMAX ) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 4 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + INTEGER I, INFO, IUPLO, LDA, LDB, IMAT, NERRS, NFAIL, + + NRHS, NRUN, IZERO, IOFF, K, NT, N, IFORM, IIN, + + IIT, IIS + CHARACTER DIST, CTYPE, UPLO, CFORM + INTEGER KL, KU, MODE + DOUBLE PRECISION ANORM, AINVNM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLANSY + EXTERNAL DLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, DGET04, DTFTTR, DLACPY, + + DLARHS, DLATB4, DLATMS, DPFTRI, DPFTRF, DPFTRS, + + DPOT01, DPOT02, DPOT03, DPOTRI, DPOTRF, DTRTTF +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'T' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* + DO 130 IIN = 1, NN +* + N = NVAL( IIN ) + LDA = MAX( N, 1 ) + LDB = MAX( N, 1 ) +* + DO 980 IIS = 1, NNS +* + NRHS = NSVAL( IIS ) +* + DO 120 IIT = 1, NNT +* + IMAT = NTVAL( IIT ) +* +* If N.EQ.0, only consider the first type +* + IF( N.EQ.0 .AND. IIT.GT.1 ) GO TO 120 +* +* Skip types 3, 4, or 5 if the matrix size is too small. +* + IF( IMAT.EQ.4 .AND. N.LE.1 ) GO TO 120 + IF( IMAT.EQ.5 .AND. N.LE.2 ) GO TO 120 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 110 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Do first for CFORM = 'N', then for CFORM = 'C' +* + DO 100 IFORM = 1, 2 + CFORM = FORMS( IFORM ) +* +* Set up parameters with DLATB4 and generate a test +* matrix with DLATMS. +* + CALL DLATB4( 'DPO', IMAT, N, N, CTYPE, KL, KU, + + ANORM, MODE, CNDNUM, DIST ) +* + SRNAMT = 'DLATMS' + CALL DLATMS( N, N, DIST, ISEED, CTYPE, + + D_WORK_DLATMS, + + MODE, CNDNUM, ANORM, KL, KU, UPLO, A, + + LDA, D_WORK_DLATMS, INFO ) +* +* Check error code from DLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( 'DPF', 'DLATMS', INFO, 0, UPLO, N, + + N, -1, -1, -1, IIT, NFAIL, NERRS, + + NOUT ) + GO TO 100 + END IF +* +* For types 3-5, zero one row and column of the matrix to +* test that INFO is returned correctly. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 + IF( ZEROT ) THEN + IF( IIT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IIT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF + IOFF = ( IZERO-1 )*LDA +* +* Set row and column IZERO of A to 0. +* + IF( IUPLO.EQ.1 ) THEN + 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 + IZERO = 0 + END IF +* +* Save a copy of the matrix A in ASAV. +* + CALL DLACPY( UPLO, N, N, A, LDA, ASAV, LDA ) +* +* Compute the condition number of A (RCONDC). +* + IF( ZEROT ) THEN + RCONDC = ZERO + ELSE +* +* Compute the 1-norm of A. +* + ANORM = DLANSY( '1', UPLO, N, A, LDA, + + D_WORK_DLANSY ) +* +* Factor the matrix A. +* + CALL DPOTRF( UPLO, N, A, LDA, INFO ) +* +* Form the inverse of A. +* + CALL DPOTRI( UPLO, N, A, LDA, INFO ) +* +* Compute the 1-norm condition number of A. +* + AINVNM = DLANSY( '1', UPLO, N, A, LDA, + + D_WORK_DLANSY ) + RCONDC = ( ONE / ANORM ) / AINVNM +* +* Restore the matrix A. +* + CALL DLACPY( UPLO, N, N, ASAV, LDA, A, LDA ) +* + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'DLARHS' + CALL DLARHS( 'DPO', 'N', UPLO, ' ', N, N, KL, KU, + + NRHS, A, LDA, XACT, LDA, B, LDA, + + ISEED, INFO ) + CALL DLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA ) +* +* Compute the L*L' or U'*U factorization of the +* matrix and solve the system. +* + CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDB ) +* + SRNAMT = 'DTRTTF' + CALL DTRTTF( CFORM, UPLO, N, AFAC, LDA, ARF, INFO ) + SRNAMT = 'DPFTRF' + CALL DPFTRF( CFORM, UPLO, N, ARF, INFO ) +* +* Check error code from DPFTRF. +* + IF( INFO.NE.IZERO ) THEN +* +* LANGOU: there is a small hick here: IZERO should +* always be INFO however if INFO is ZERO, ALAERH does not +* complain. +* + CALL ALAERH( 'DPF', 'DPFSV ', INFO, IZERO, + + UPLO, N, N, -1, -1, NRHS, IIT, + + NFAIL, NERRS, NOUT ) + GO TO 100 + END IF +* +* Skip the tests if INFO is not 0. +* + IF( INFO.NE.0 ) THEN + GO TO 100 + END IF +* + SRNAMT = 'DPFTRS' + CALL DPFTRS( CFORM, UPLO, N, NRHS, ARF, X, LDB, + + INFO ) +* + SRNAMT = 'DTFTTR' + CALL DTFTTR( CFORM, UPLO, N, ARF, AFAC, LDA, INFO ) +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL DLACPY( UPLO, N, N, AFAC, LDA, ASAV, LDA ) + CALL DPOT01( UPLO, N, A, LDA, AFAC, LDA, + + D_WORK_DPOT01, RESULT( 1 ) ) + CALL DLACPY( UPLO, N, N, ASAV, LDA, AFAC, LDA ) +* +* Form the inverse and compute the residual. +* + IF(MOD(N,2).EQ.0)THEN + CALL DLACPY( 'A', N+1, N/2, ARF, N+1, ARFINV, + + N+1 ) + ELSE + CALL DLACPY( 'A', N, (N+1)/2, ARF, N, ARFINV, + + N ) + END IF +* + SRNAMT = 'DPFTRI' + CALL DPFTRI( CFORM, UPLO, N, ARFINV , INFO ) +* + SRNAMT = 'DTFTTR' + CALL DTFTTR( CFORM, UPLO, N, ARFINV, AINV, LDA, + + INFO ) +* +* Check error code from DPFTRI. +* + IF( INFO.NE.0 ) + + CALL ALAERH( 'DPO', 'DPFTRI', INFO, 0, UPLO, N, + + N, -1, -1, -1, IMAT, NFAIL, NERRS, + + NOUT ) +* + CALL DPOT03( UPLO, N, A, LDA, AINV, LDA, + + D_TEMP_DPOT03, LDA, D_WORK_DPOT03, + + RCONDC, RESULT( 2 ) ) +* +* Compute residual of the computed solution. +* + CALL DLACPY( 'Full', N, NRHS, B, LDA, + + D_TEMP_DPOT02, LDA ) + CALL DPOT02( UPLO, N, NRHS, A, LDA, X, LDA, + + D_TEMP_DPOT02, LDA, D_WORK_DPOT02, + + RESULT( 3 ) ) +* +* Check solution from generated exact solution. + + CALL DGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + + RESULT( 4 ) ) + NT = 4 +* +* Print information about the tests that did not +* pass the threshold. +* + DO 60 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + + CALL ALADHD( NOUT, 'DPF' ) + WRITE( NOUT, FMT = 9999 )'DPFSV ', UPLO, + + N, IIT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 60 CONTINUE + NRUN = NRUN + NT + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 980 CONTINUE + 130 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( 'DPF', NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A6, ', UPLO=''', A1, ''', N =', I5, ', type ', I1, + + ', test(', I1, ')=', G12.5 ) +* + RETURN +* +* End of DDRVRFP +* + END diff --git a/TESTING/LIN/ddrvsp.f b/TESTING/LIN/ddrvsp.f index 6a509786..11414a18 100644 --- a/TESTING/LIN/ddrvsp.f +++ b/TESTING/LIN/ddrvsp.f @@ -113,7 +113,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/ddrvsy.f b/TESTING/LIN/ddrvsy.f index a4196ae3..33bf412a 100644 --- a/TESTING/LIN/ddrvsy.f +++ b/TESTING/LIN/ddrvsy.f @@ -110,7 +110,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/debchvxx.f b/TESTING/LIN/debchvxx.f new file mode 100644 index 00000000..c988dd7e --- /dev/null +++ b/TESTING/LIN/debchvxx.f @@ -0,0 +1,460 @@ + SUBROUTINE DEBCHVXX( THRESH, PATH ) + IMPLICIT NONE +* .. Scalar Arguments .. + DOUBLE PRECISION THRESH + CHARACTER*3 PATH +* +* Purpose +* ====== +* +* DEBCHVXX will run D**SVXX on a series of Hilbert matrices and then +* compare the error bounds returned by D**SVXX to see if the returned +* answer indeed falls within those bounds. +* +* Eight test ratios will be computed. The tests will pass if they are .LT. +* THRESH. There are two cases that are determined by 1 / (SQRT( N ) * EPS). +* If that value is .LE. to the component wise reciprocal condition number, +* it uses the guaranteed case, other wise it uses the unguaranteed case. +* +* Test ratios: +* Let Xc be X_computed and Xt be X_truth. +* The norm used is the infinity norm. + +* Let A be the guaranteed case and B be the unguaranteed case. +* +* 1. Normwise guaranteed forward error bound. +* A: norm ( abs( Xc - Xt ) / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ) and +* ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N),10) * EPS. +* If these conditions are met, the test ratio is set to be +* ERRBND( *, nwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. +* B: For this case, CGESVXX should just return 1. If it is less than +* one, treat it the same as in 1A. Otherwise it fails. (Set test +* ratio to ERRBND( *, nwise_i, bnd_i ) * THRESH?) +* +* 2. Componentwise guaranteed forward error bound. +* A: norm ( abs( Xc(j) - Xt(j) ) ) / norm (Xt(j)) .LE. ERRBND( *, cwise_i, bnd_i ) +* for all j .AND. ERRBND( *, cwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS. +* If these conditions are met, the test ratio is set to be +* ERRBND( *, cwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. +* B: Same as normwise test ratio. +* +* 3. Backwards error. +* A: The test ratio is set to BERR/EPS. +* B: Same test ratio. +* +* 4. Reciprocal condition number. +* A: A condition number is computed with Xt and compared with the one +* returned from CGESVXX. Let RCONDc be the RCOND returned by D**SVXX +* and RCONDt be the RCOND from the truth value. Test ratio is set to +* MAX(RCONDc/RCONDt, RCONDt/RCONDc). +* B: Test ratio is set to 1 / (EPS * RCONDc). +* +* 5. Reciprocal normwise condition number. +* A: The test ratio is set to +* MAX(ERRBND( *, nwise_i, cond_i ) / NCOND, NCOND / ERRBND( *, nwise_i, cond_i )). +* B: Test ratio is set to 1 / (EPS * ERRBND( *, nwise_i, cond_i )). +* +* 6. Reciprocal componentwise condition number. +* A: Test ratio is set to +* MAX(ERRBND( *, cwise_i, cond_i ) / CCOND, CCOND / ERRBND( *, cwise_i, cond_i )). +* B: Test ratio is set to 1 / (EPS * ERRBND( *, cwise_i, cond_i )). +* +* .. Parameters .. +* NMAX is determined by the largest number in the inverse of the hilbert +* matrix. Precision is exhausted when the largest entry in it is greater +* than 2 to the power of the number of bits in the fraction of the data +* type used plus one, which is 24 for single precision. +* NMAX should be 6 for single and 11 for double. + + INTEGER NMAX, NPARAMS, NERRBND, NTESTS, KL, KU + PARAMETER (NMAX = 10, NPARAMS = 2, NERRBND = 3, + $ NTESTS = 6) + +* .. Local Scalars .. + INTEGER N, NRHS, INFO, I ,J, k, NFAIL, LDA, + $ N_AUX_TESTS, LDAB, LDAFB + CHARACTER FACT, TRANS, UPLO, EQUED + CHARACTER*2 C2 + CHARACTER(3) NGUAR, CGUAR + LOGICAL printed_guide + DOUBLE PRECISION NCOND, CCOND, M, NORMDIF, NORMT, RCOND, + $ RNORM, RINORM, SUMR, SUMRI, EPS, + $ BERR(NMAX), RPVGRW, ORCOND, + $ CWISE_ERR, NWISE_ERR, CWISE_BND, NWISE_BND, + $ CWISE_RCOND, NWISE_RCOND, + $ CONDTHRESH, ERRTHRESH + +* .. Local Arrays .. + DOUBLE PRECISION TSTRAT(NTESTS), RINV(NMAX), PARAMS(NPARAMS), + $ S(NMAX),R(NMAX),C(NMAX), DIFF(NMAX, NMAX), + $ ERRBND_N(NMAX*3), ERRBND_C(NMAX*3), + $ A(NMAX,NMAX),INVHILB(NMAX,NMAX),X(NMAX,NMAX), + $ AB( (NMAX-1)+(NMAX-1)+1, NMAX ), + $ ABCOPY( (NMAX-1)+(NMAX-1)+1, NMAX ), + $ AFB( 2*(NMAX-1)+(NMAX-1)+1, NMAX ), + $ WORK(NMAX*3*5), AF(NMAX, NMAX),B(NMAX, NMAX), + $ ACOPY(NMAX, NMAX) + INTEGER IPIV(NMAX), IWORK(3*NMAX) + +* .. External Functions .. + DOUBLE PRECISION DLAMCH + +* .. External Subroutines .. + EXTERNAL DLAHILB, DGESVXX, DPOSVXX, DSYSVXX, + $ DGBSVXX, DLACPY, LSAMEN + LOGICAL LSAMEN + +* .. Intrinsic Functions .. + INTRINSIC SQRT, MAX, ABS, DBLE + +* .. Parameters .. + INTEGER NWISE_I, CWISE_I + PARAMETER (NWISE_I = 1, CWISE_I = 1) + INTEGER BND_I, COND_I + PARAMETER (BND_I = 2, COND_I = 3) + +* Create the loop to test out the Hilbert matrices + + FACT = 'E' + UPLO = 'U' + TRANS = 'N' + EQUED = 'N' + EPS = DLAMCH('Epsilon') + NFAIL = 0 + N_AUX_TESTS = 0 + LDA = NMAX + LDAB = (NMAX-1)+(NMAX-1)+1 + LDAFB = 2*(NMAX-1)+(NMAX-1)+1 + C2 = PATH( 2: 3 ) + +* Main loop to test the different Hilbert Matrices. + + printed_guide = .false. + + DO N = 1 , NMAX + PARAMS(1) = -1 + PARAMS(2) = -1 + + KL = N-1 + KU = N-1 + NRHS = n + M = MAX(SQRT(DBLE(N)), 10.0D+0) + +* Generate the Hilbert matrix, its inverse, and the +* right hand side, all scaled by the LCM(1,..,2N-1). + CALL DLAHILB(N, N, A, LDA, INVHILB, LDA, B, LDA, WORK, INFO) + +* Copy A into ACOPY. + CALL DLACPY('ALL', N, N, A, NMAX, ACOPY, NMAX) + +* Store A in band format for GB tests + DO J = 1, N + DO I = 1, KL+KU+1 + AB( I, J ) = 0.0D+0 + END DO + END DO + DO J = 1, N + DO I = MAX( 1, J-KU ), MIN( N, J+KL ) + AB( KU+1+I-J, J ) = A( I, J ) + END DO + END DO + +* Copy AB into ABCOPY. + DO J = 1, N + DO I = 1, KL+KU+1 + ABCOPY( I, J ) = 0.0D+0 + END DO + END DO + CALL DLACPY('ALL', KL+KU+1, N, AB, LDAB, ABCOPY, LDAB) + +* Call D**SVXX with default PARAMS and N_ERR_BND = 3. + IF ( LSAMEN( 2, C2, 'SY' ) ) THEN + CALL DSYSVXX(FACT, UPLO, N, NRHS, ACOPY, LDA, AF, LDA, + $ IPIV, EQUED, S, B, LDA, X, LDA, ORCOND, + $ RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS, + $ PARAMS, WORK, IWORK, INFO) + ELSE IF ( LSAMEN( 2, C2, 'PO' ) ) THEN + CALL DPOSVXX(FACT, UPLO, N, NRHS, ACOPY, LDA, AF, LDA, + $ EQUED, S, B, LDA, X, LDA, ORCOND, + $ RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS, + $ PARAMS, WORK, IWORK, INFO) + ELSE IF ( LSAMEN( 2, C2, 'GB' ) ) THEN + CALL DGBSVXX(FACT, TRANS, N, KL, KU, NRHS, ABCOPY, + $ LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, + $ LDA, X, LDA, ORCOND, RPVGRW, BERR, NERRBND, + $ ERRBND_N, ERRBND_C, NPARAMS, PARAMS, WORK, IWORK, + $ INFO) + ELSE + CALL DGESVXX(FACT, TRANS, N, NRHS, ACOPY, LDA, AF, LDA, + $ IPIV, EQUED, R, C, B, LDA, X, LDA, ORCOND, + $ RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS, + $ PARAMS, WORK, IWORK, INFO) + END IF + + N_AUX_TESTS = N_AUX_TESTS + 1 + IF (ORCOND .LT. EPS) THEN +! Either factorization failed or the matrix is flagged, and 1 <= +! INFO <= N+1. We don't decide based on rcond anymore. +! IF (INFO .EQ. 0 .OR. INFO .GT. N+1) THEN +! NFAIL = NFAIL + 1 +! WRITE (*, FMT=8000) N, INFO, ORCOND, RCOND +! END IF + ELSE +! Either everything succeeded (INFO == 0) or some solution failed +! to converge (INFO > N+1). + IF (INFO .GT. 0 .AND. INFO .LE. N+1) THEN + NFAIL = NFAIL + 1 + WRITE (*, FMT=8000) C2, N, INFO, ORCOND, RCOND + END IF + END IF + +* Calculating the difference between D**SVXX's X and the true X. + DO I = 1,N + DO J =1,NRHS + DIFF(I,J) = X(I,J) - INVHILB(I,J) + END DO + END DO + +* Calculating the RCOND + RNORM = 0.0D+0 + RINORM = 0.0D+0 + IF ( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'SY' ) ) THEN + DO I = 1, N + SUMR = 0.0D+0 + SUMRI = 0.0D+0 + DO J = 1, N + SUMR = SUMR + S(I) * ABS(A(I,J)) * S(J) + SUMRI = SUMRI + ABS(INVHILB(I, J)) / (S(J) * S(I)) + + END DO + RNORM = MAX(RNORM,SUMR) + RINORM = MAX(RINORM,SUMRI) + END DO + ELSE IF ( LSAMEN( 2, C2, 'GE' ) .OR. LSAMEN( 2, C2, 'GB' ) ) + $ THEN + DO I = 1, N + SUMR = 0.0D+0 + SUMRI = 0.0D+0 + DO J = 1, N + SUMR = SUMR + R(I) * ABS(A(I,J)) * C(J) + SUMRI = SUMRI + ABS(INVHILB(I, J)) / (R(J) * C(I)) + END DO + RNORM = MAX(RNORM,SUMR) + RINORM = MAX(RINORM,SUMRI) + END DO + END IF + + RNORM = RNORM / ABS(A(1, 1)) + RCOND = 1.0D+0/(RNORM * RINORM) + +* Calculating the R for normwise rcond. + DO I = 1, N + RINV(I) = 0.0D+0 + END DO + DO J = 1, N + DO I = 1, N + RINV(I) = RINV(I) + ABS(A(I,J)) + END DO + END DO + +* Calculating the Normwise rcond. + RINORM = 0.0D+0 + DO I = 1, N + SUMRI = 0.0D+0 + DO J = 1, N + SUMRI = SUMRI + ABS(INVHILB(I,J) * RINV(J)) + END DO + RINORM = MAX(RINORM, SUMRI) + END DO + +! invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm +! by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) + NCOND = ABS(A(1,1)) / RINORM + + CONDTHRESH = M * EPS + ERRTHRESH = M * EPS + + DO K = 1, NRHS + NORMT = 0.0D+0 + NORMDIF = 0.0D+0 + CWISE_ERR = 0.0D+0 + DO I = 1, N + NORMT = MAX(ABS(INVHILB(I, K)), NORMT) + NORMDIF = MAX(ABS(X(I,K) - INVHILB(I,K)), NORMDIF) + IF (INVHILB(I,K) .NE. 0.0D+0) THEN + CWISE_ERR = MAX(ABS(X(I,K) - INVHILB(I,K)) + $ /ABS(INVHILB(I,K)), CWISE_ERR) + ELSE IF (X(I, K) .NE. 0.0D+0) THEN + CWISE_ERR = DLAMCH('OVERFLOW') + END IF + END DO + IF (NORMT .NE. 0.0D+0) THEN + NWISE_ERR = NORMDIF / NORMT + ELSE IF (NORMDIF .NE. 0.0D+0) THEN + NWISE_ERR = DLAMCH('OVERFLOW') + ELSE + NWISE_ERR = 0.0D+0 + ENDIF + + DO I = 1, N + RINV(I) = 0.0D+0 + END DO + DO J = 1, N + DO I = 1, N + RINV(I) = RINV(I) + ABS(A(I, J) * INVHILB(J, K)) + END DO + END DO + RINORM = 0.0D+0 + DO I = 1, N + SUMRI = 0.0D+0 + DO J = 1, N + SUMRI = SUMRI + $ + ABS(INVHILB(I, J) * RINV(J) / INVHILB(I, K)) + END DO + RINORM = MAX(RINORM, SUMRI) + END DO +! invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm +! by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) + CCOND = ABS(A(1,1))/RINORM + +! Forward error bound tests + NWISE_BND = ERRBND_N(K + (BND_I-1)*NRHS) + CWISE_BND = ERRBND_C(K + (BND_I-1)*NRHS) + NWISE_RCOND = ERRBND_N(K + (COND_I-1)*NRHS) + CWISE_RCOND = ERRBND_C(K + (COND_I-1)*NRHS) +! write (*,*) 'nwise : ', n, k, ncond, nwise_rcond, +! $ condthresh, ncond.ge.condthresh +! write (*,*) 'nwise2: ', k, nwise_bnd, nwise_err, errthresh + IF (NCOND .GE. CONDTHRESH) THEN + NGUAR = 'YES' + IF (NWISE_BND .GT. ERRTHRESH) THEN + TSTRAT(1) = 1/(2.0D+0*EPS) + ELSE + IF (NWISE_BND .NE. 0.0D+0) THEN + TSTRAT(1) = NWISE_ERR / NWISE_BND + ELSE IF (NWISE_ERR .NE. 0.0D+0) THEN + TSTRAT(1) = 1/(16.0*EPS) + ELSE + TSTRAT(1) = 0.0D+0 + END IF + IF (TSTRAT(1) .GT. 1.0D+0) THEN + TSTRAT(1) = 1/(4.0D+0*EPS) + END IF + END IF + ELSE + NGUAR = 'NO' + IF (NWISE_BND .LT. 1.0D+0) THEN + TSTRAT(1) = 1/(8.0D+0*EPS) + ELSE + TSTRAT(1) = 1.0D+0 + END IF + END IF +! write (*,*) 'cwise : ', n, k, ccond, cwise_rcond, +! $ condthresh, ccond.ge.condthresh +! write (*,*) 'cwise2: ', k, cwise_bnd, cwise_err, errthresh + IF (CCOND .GE. CONDTHRESH) THEN + CGUAR = 'YES' + IF (CWISE_BND .GT. ERRTHRESH) THEN + TSTRAT(2) = 1/(2.0D+0*EPS) + ELSE + IF (CWISE_BND .NE. 0.0D+0) THEN + TSTRAT(2) = CWISE_ERR / CWISE_BND + ELSE IF (CWISE_ERR .NE. 0.0D+0) THEN + TSTRAT(2) = 1/(16.0D+0*EPS) + ELSE + TSTRAT(2) = 0.0D+0 + END IF + IF (TSTRAT(2) .GT. 1.0D+0) TSTRAT(2) = 1/(4.0D+0*EPS) + END IF + ELSE + CGUAR = 'NO' + IF (CWISE_BND .LT. 1.0D+0) THEN + TSTRAT(2) = 1/(8.0D+0*EPS) + ELSE + TSTRAT(2) = 1.0D+0 + END IF + END IF + +! Backwards error test + TSTRAT(3) = BERR(K)/EPS + +! Condition number tests + TSTRAT(4) = RCOND / ORCOND + IF (RCOND .GE. CONDTHRESH .AND. TSTRAT(4) .LT. 1.0D+0) + $ TSTRAT(4) = 1.0D+0 / TSTRAT(4) + + TSTRAT(5) = NCOND / NWISE_RCOND + IF (NCOND .GE. CONDTHRESH .AND. TSTRAT(5) .LT. 1.0D+0) + $ TSTRAT(5) = 1.0D+0 / TSTRAT(5) + + TSTRAT(6) = CCOND / NWISE_RCOND + IF (CCOND .GE. CONDTHRESH .AND. TSTRAT(6) .LT. 1.0D+0) + $ TSTRAT(6) = 1.0D+0 / TSTRAT(6) + + DO I = 1, NTESTS + IF (TSTRAT(I) .GT. THRESH) THEN + IF (.NOT.PRINTED_GUIDE) THEN + WRITE(*,*) + WRITE( *, 9996) 1 + WRITE( *, 9995) 2 + WRITE( *, 9994) 3 + WRITE( *, 9993) 4 + WRITE( *, 9992) 5 + WRITE( *, 9991) 6 + WRITE( *, 9990) 7 + WRITE( *, 9989) 8 + WRITE(*,*) + PRINTED_GUIDE = .TRUE. + END IF + WRITE( *, 9999) C2, N, K, NGUAR, CGUAR, I, TSTRAT(I) + NFAIL = NFAIL + 1 + END IF + END DO + END DO + +c$$$ WRITE(*,*) +c$$$ WRITE(*,*) 'Normwise Error Bounds' +c$$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,nwise_i,bnd_i) +c$$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,nwise_i,cond_i) +c$$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,nwise_i,rawbnd_i) +c$$$ WRITE(*,*) +c$$$ WRITE(*,*) 'Componentwise Error Bounds' +c$$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,cwise_i,bnd_i) +c$$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,cwise_i,cond_i) +c$$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,cwise_i,rawbnd_i) +c$$$ print *, 'Info: ', info +c$$$ WRITE(*,*) +* WRITE(*,*) 'TSTRAT: ',TSTRAT + + END DO + + WRITE(*,*) + IF( NFAIL .GT. 0 ) THEN + WRITE(*,9998) C2, NFAIL, NTESTS*N+N_AUX_TESTS + ELSE + WRITE(*,9997) C2 + END IF + 9999 FORMAT( ' D', A2, 'SVXX: N =', I2, ', RHS = ', I2, + $ ', NWISE GUAR. = ', A, ', CWISE GUAR. = ', A, + $ ' test(',I1,') =', G12.5 ) + 9998 FORMAT( ' D', A2, 'SVXX: ', I6, ' out of ', I6, + $ ' tests failed to pass the threshold' ) + 9997 FORMAT( ' D', A2, 'SVXX passed the tests of error bounds' ) +* Test ratios. + 9996 FORMAT( 3X, I2, ': Normwise guaranteed forward error', / 5X, + $ 'Guaranteed case: if norm ( abs( Xc - Xt )', + $ ' / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ), then', + $ / 5X, + $ 'ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS') + 9995 FORMAT( 3X, I2, ': Componentwise guaranteed forward error' ) + 9994 FORMAT( 3X, I2, ': Backwards error' ) + 9993 FORMAT( 3X, I2, ': Reciprocal condition number' ) + 9992 FORMAT( 3X, I2, ': Reciprocal normwise condition number' ) + 9991 FORMAT( 3X, I2, ': Raw normwise error estimate' ) + 9990 FORMAT( 3X, I2, ': Reciprocal componentwise condition number' ) + 9989 FORMAT( 3X, I2, ': Raw componentwise error estimate' ) + + 8000 FORMAT( ' D', A2, 'SVXX: N =', I2, ', INFO = ', I3, + $ ', ORCOND = ', G12.5, ', real RCOND = ', G12.5 ) + + END diff --git a/TESTING/LIN/derrac.f b/TESTING/LIN/derrac.f new file mode 100644 index 00000000..d7598d43 --- /dev/null +++ b/TESTING/LIN/derrac.f @@ -0,0 +1,112 @@ + SUBROUTINE DERRAC( NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.1.2) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* May 2007 +* +* .. Scalar Arguments .. + INTEGER NUNIT +* .. +* +* Purpose +* ======= +* +* DERRAC tests the error exits for DSPOSV. +* +* Arguments +* ========= +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 4 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, ITER, J +* .. +* .. Local Arrays .. + DOUBLE PRECISION A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), + $ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ), + $ W( 2*NMAX ), X( NMAX ) + DOUBLE PRECISION WORK(NMAX*NMAX) + REAL SWORK(NMAX*NMAX) +* .. +* .. External Subroutines .. + EXTERNAL CHKXER, DSPOSV +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + 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 + 20 CONTINUE + OK = .TRUE. +* + SRNAMT = 'DSPOSV' + INFOT = 1 + CALL DSPOSV('/',0,0,A,1,B,1,X,1,WORK,SWORK,ITER,INFO) + CALL CHKXER( 'DSPOSV', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSPOSV('U',-1,0,A,1,B,1,X,1,WORK,SWORK,ITER,INFO) + CALL CHKXER( 'DSPOSV', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSPOSV('U',0,-1,A,1,B,1,X,1,WORK,SWORK,ITER,INFO) + CALL CHKXER( 'DSPOSV', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSPOSV('U',2,1,A,1,B,2,X,2,WORK,SWORK,ITER,INFO) + CALL CHKXER( 'DSPOSV', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DSPOSV('U',2,1,A,2,B,1,X,2,WORK,SWORK,ITER,INFO) + CALL CHKXER( 'DSPOSV', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DSPOSV('U',2,1,A,2,B,2,X,1,WORK,SWORK,ITER,INFO) + CALL CHKXER( 'DSPOSV', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + IF( OK ) THEN + WRITE( NOUT, FMT = 9999 )'DSPOSV' + ELSE + WRITE( NOUT, FMT = 9998 )'DSPOSV' + END IF +* + 9999 FORMAT( 1X, A6, ' drivers passed the tests of the error exits' ) + 9998 FORMAT( ' *** ', A6, ' drivers failed the tests of the error ', + $ 'exits ***' ) +* + RETURN +* +* End of DERRAC +* + END diff --git a/TESTING/LIN/derrge.f b/TESTING/LIN/derrge.f index 16fdad85..25be9d2b 100644 --- a/TESTING/LIN/derrge.f +++ b/TESTING/LIN/derrge.f @@ -51,7 +51,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/derrgex.f b/TESTING/LIN/derrgex.f new file mode 100644 index 00000000..b21b25f2 --- /dev/null +++ b/TESTING/LIN/derrgex.f @@ -0,0 +1,524 @@ + SUBROUTINE DERRGE( PATH, NUNIT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* Purpose +* ======= +* +* DERRGE tests the error exits for the DOUBLE PRECISION routines +* for general matrices. +* +* Note that this file is used only when the XBLAS are available, +* otherwise derrge.f defines this subroutine. +* +* Arguments +* ========= +* +* PATH (input) CHARACTER*3 +* The LAPACK path name for the routines to be tested. +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX, LW + PARAMETER ( NMAX = 4, LW = 3*NMAX ) +* .. +* .. Local Scalars .. + CHARACTER EQ + CHARACTER*2 C2 + INTEGER I, INFO, J, N_ERR_BNDS, NPARAMS + DOUBLE PRECISION ANRM, CCOND, RCOND, BERR +* .. +* .. 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( LW ), X( NMAX ), ERR_BNDS_N( NMAX, 3 ), + $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAMEN + EXTERNAL LSAMEN +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, DGBCON, DGBEQU, DGBRFS, DGBTF2, + $ DGBTRF, DGBTRS, DGECON, DGEEQU, DGERFS, DGETF2, + $ DGETRF, DGETRI, DGETRS, DGEEQUB, DGERFSX, + $ DGBEQUB, DGBRFSX +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) + C2 = PATH( 2: 3 ) +* +* Set the variables to innocuous values. +* + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + 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 + IP( J ) = J + IW( J ) = J + 20 CONTINUE + OK = .TRUE. +* + IF( LSAMEN( 2, C2, 'GE' ) ) THEN +* +* Test error exits of the routines that use the LU decomposition +* of a general matrix. +* +* DGETRF +* + SRNAMT = 'DGETRF' + INFOT = 1 + CALL DGETRF( -1, 0, A, 1, IP, INFO ) + CALL CHKXER( 'DGETRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGETRF( 0, -1, A, 1, IP, INFO ) + CALL CHKXER( 'DGETRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGETRF( 2, 1, A, 1, IP, INFO ) + CALL CHKXER( 'DGETRF', INFOT, NOUT, LERR, OK ) +* +* DGETF2 +* + SRNAMT = 'DGETF2' + INFOT = 1 + CALL DGETF2( -1, 0, A, 1, IP, INFO ) + CALL CHKXER( 'DGETF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGETF2( 0, -1, A, 1, IP, INFO ) + CALL CHKXER( 'DGETF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGETF2( 2, 1, A, 1, IP, INFO ) + CALL CHKXER( 'DGETF2', INFOT, NOUT, LERR, OK ) +* +* DGETRI +* + SRNAMT = 'DGETRI' + INFOT = 1 + CALL DGETRI( -1, A, 1, IP, W, LW, INFO ) + CALL CHKXER( 'DGETRI', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGETRI( 2, A, 1, IP, W, LW, INFO ) + CALL CHKXER( 'DGETRI', INFOT, NOUT, LERR, OK ) +* +* DGETRS +* + SRNAMT = 'DGETRS' + INFOT = 1 + CALL DGETRS( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DGETRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGETRS( 'N', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DGETRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGETRS( 'N', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DGETRS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGETRS( 'N', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'DGETRS', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DGETRS( 'N', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'DGETRS', INFOT, NOUT, LERR, OK ) +* +* DGERFS +* + SRNAMT = 'DGERFS' + INFOT = 1 + CALL DGERFS( '/', 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGERFS( 'N', -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, + $ W, IW, INFO ) + CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGERFS( 'N', 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, + $ W, IW, INFO ) + CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGERFS( 'N', 2, 1, A, 1, AF, 2, IP, B, 2, X, 2, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DGERFS( 'N', 2, 1, A, 2, AF, 1, IP, B, 2, X, 2, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DGERFS( 'N', 2, 1, A, 2, AF, 2, IP, B, 1, X, 2, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DGERFS( 'N', 2, 1, A, 2, AF, 2, IP, B, 2, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'DGERFS', INFOT, NOUT, LERR, OK ) +* +* DGERFSX +* + N_ERR_BNDS = 3 + NPARAMS = 0 + SRNAMT = 'DGERFSX' + INFOT = 1 + CALL DGERFSX( '/', EQ, 0, 0, A, 1, AF, 1, IP, R, C, B, 1, X, + $ 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 2 + EQ = '/' + CALL DGERFSX( 'N', EQ, 2, 1, A, 1, AF, 2, IP, R, C, B, 2, X, + $ 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 3 + EQ = 'R' + CALL DGERFSX( 'N', EQ, -1, 0, A, 1, AF, 1, IP, R, C, B, 1, X, + $ 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGERFSX( 'N', EQ, 0, -1, A, 1, AF, 1, IP, R, C, B, 1, X, + $ 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DGERFSX( 'N', EQ, 2, 1, A, 1, AF, 2, IP, R, C, B, 2, X, + $ 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DGERFSX( 'N', EQ, 2, 1, A, 2, AF, 1, IP, R, C, B, 2, X, + $ 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 13 + EQ = 'C' + CALL DGERFSX( 'N', EQ, 2, 1, A, 2, AF, 2, IP, R, C, B, 1, X, + $ 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL DGERFSX( 'N', EQ, 2, 1, A, 2, AF, 2, IP, R, C, B, 2, X, + $ 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGERFSX', INFOT, NOUT, LERR, OK ) +* +* DGECON +* + SRNAMT = 'DGECON' + INFOT = 1 + CALL DGECON( '/', 0, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DGECON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGECON( '1', -1, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DGECON', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGECON( '1', 2, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DGECON', INFOT, NOUT, LERR, OK ) +* +* DGEEQU +* + SRNAMT = 'DGEEQU' + INFOT = 1 + CALL DGEEQU( -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'DGEEQU', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGEEQU( 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'DGEEQU', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGEEQU( 2, 2, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'DGEEQU', INFOT, NOUT, LERR, OK ) +* +* DGEEQUB +* + SRNAMT = 'DGEEQUB' + INFOT = 1 + CALL DGEEQUB( -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'DGEEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGEEQUB( 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'DGEEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGEEQUB( 2, 2, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'DGEEQUB', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN +* +* Test error exits of the routines that use the LU decomposition +* of a general band matrix. +* +* DGBTRF +* + SRNAMT = 'DGBTRF' + INFOT = 1 + CALL DGBTRF( -1, 0, 0, 0, A, 1, IP, INFO ) + CALL CHKXER( 'DGBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGBTRF( 0, -1, 0, 0, A, 1, IP, INFO ) + CALL CHKXER( 'DGBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGBTRF( 1, 1, -1, 0, A, 1, IP, INFO ) + CALL CHKXER( 'DGBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGBTRF( 1, 1, 0, -1, A, 1, IP, INFO ) + CALL CHKXER( 'DGBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DGBTRF( 2, 2, 1, 1, A, 3, IP, INFO ) + CALL CHKXER( 'DGBTRF', INFOT, NOUT, LERR, OK ) +* +* DGBTF2 +* + SRNAMT = 'DGBTF2' + INFOT = 1 + CALL DGBTF2( -1, 0, 0, 0, A, 1, IP, INFO ) + CALL CHKXER( 'DGBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGBTF2( 0, -1, 0, 0, A, 1, IP, INFO ) + CALL CHKXER( 'DGBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGBTF2( 1, 1, -1, 0, A, 1, IP, INFO ) + CALL CHKXER( 'DGBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGBTF2( 1, 1, 0, -1, A, 1, IP, INFO ) + CALL CHKXER( 'DGBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DGBTF2( 2, 2, 1, 1, A, 3, IP, INFO ) + CALL CHKXER( 'DGBTF2', INFOT, NOUT, LERR, OK ) +* +* DGBTRS +* + SRNAMT = 'DGBTRS' + INFOT = 1 + CALL DGBTRS( '/', 0, 0, 0, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGBTRS( 'N', -1, 0, 0, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGBTRS( 'N', 1, -1, 0, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGBTRS( 'N', 1, 0, -1, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGBTRS( 'N', 1, 0, 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DGBTRS( 'N', 2, 1, 1, 1, A, 3, IP, B, 2, INFO ) + CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DGBTRS( 'N', 2, 0, 0, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'DGBTRS', INFOT, NOUT, LERR, OK ) +* +* DGBRFS +* + SRNAMT = 'DGBRFS' + INFOT = 1 + CALL DGBRFS( '/', 0, 0, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGBRFS( 'N', -1, 0, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGBRFS( 'N', 1, -1, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGBRFS( 'N', 1, 0, -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DGBRFS( 'N', 1, 0, 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DGBRFS( 'N', 2, 1, 1, 1, A, 2, AF, 4, IP, B, 2, X, 2, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DGBRFS( 'N', 2, 1, 1, 1, A, 3, AF, 3, IP, B, 2, X, 2, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DGBRFS( 'N', 2, 0, 0, 1, A, 1, AF, 1, IP, B, 1, X, 2, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 14 + CALL DGBRFS( 'N', 2, 0, 0, 1, A, 1, AF, 1, IP, B, 2, X, 1, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'DGBRFS', INFOT, NOUT, LERR, OK ) +* +* DGBRFSX +* + N_ERR_BNDS = 3 + NPARAMS = 0 + SRNAMT = 'DGBRFSX' + INFOT = 1 + CALL DGBRFSX( '/', EQ, 0, 0, 0, 0, A, 1, AF, 1, IP, R, C, B, 1, + $ X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 2 + EQ = '/' + CALL DGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 1, AF, 2, IP, R, C, B, 2, + $ X, 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 3 + EQ = 'R' + CALL DGBRFSX( 'N', EQ, -1, 1, 1, 0, A, 1, AF, 1, IP, R, C, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 4 + EQ = 'R' + CALL DGBRFSX( 'N', EQ, 2, -1, 1, 1, A, 3, AF, 4, IP, R, C, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 5 + EQ = 'R' + CALL DGBRFSX( 'N', EQ, 2, 1, -1, 1, A, 3, AF, 4, IP, R, C, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DGBRFSX( 'N', EQ, 0, 0, 0, -1, A, 1, AF, 1, IP, R, C, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 1, AF, 2, IP, R, C, B, + $ 2, X, 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 3, AF, 3, IP, R, C, B, 2, + $ X, 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 13 + EQ = 'C' + CALL DGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 3, AF, 5, IP, R, C, B, + $ 1, X, 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL DGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 3, AF, 5, IP, R, C, B, 2, + $ X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'DGBRFSX', INFOT, NOUT, LERR, OK ) +* +* DGBCON +* + SRNAMT = 'DGBCON' + INFOT = 1 + CALL DGBCON( '/', 0, 0, 0, A, 1, IP, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DGBCON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGBCON( '1', -1, 0, 0, A, 1, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'DGBCON', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGBCON( '1', 1, -1, 0, A, 1, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'DGBCON', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGBCON( '1', 1, 0, -1, A, 1, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'DGBCON', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DGBCON( '1', 2, 1, 1, A, 3, IP, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DGBCON', INFOT, NOUT, LERR, OK ) +* +* DGBEQU +* + SRNAMT = 'DGBEQU' + INFOT = 1 + CALL DGBEQU( -1, 0, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'DGBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGBEQU( 0, -1, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'DGBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGBEQU( 1, 1, -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'DGBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGBEQU( 1, 1, 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'DGBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DGBEQU( 2, 2, 1, 1, A, 2, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'DGBEQU', INFOT, NOUT, LERR, OK ) +* +* DGBEQUB +* + SRNAMT = 'DGBEQUB' + INFOT = 1 + CALL DGBEQUB( -1, 0, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'DGBEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DGBEQUB( 0, -1, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'DGBEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DGBEQUB( 1, 1, -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'DGBEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DGBEQUB( 1, 1, 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'DGBEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DGBEQUB( 2, 2, 1, 1, A, 2, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'DGBEQUB', INFOT, NOUT, LERR, OK ) + END IF +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of DERRGE +* + END diff --git a/TESTING/LIN/derrgt.f b/TESTING/LIN/derrgt.f index d1a4ff0e..af1844f6 100644 --- a/TESTING/LIN/derrgt.f +++ b/TESTING/LIN/derrgt.f @@ -51,7 +51,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/derrlq.f b/TESTING/LIN/derrlq.f index 63f4491a..f6f6e1c4 100644 --- a/TESTING/LIN/derrlq.f +++ b/TESTING/LIN/derrlq.f @@ -43,7 +43,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/derrls.f b/TESTING/LIN/derrls.f index d7c0fd90..1ff652ab 100644 --- a/TESTING/LIN/derrls.f +++ b/TESTING/LIN/derrls.f @@ -50,7 +50,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/derrpo.f b/TESTING/LIN/derrpo.f index aeaf0096..f8456b9b 100644 --- a/TESTING/LIN/derrpo.f +++ b/TESTING/LIN/derrpo.f @@ -52,7 +52,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/derrpox.f b/TESTING/LIN/derrpox.f new file mode 100644 index 00000000..f6ab31fb --- /dev/null +++ b/TESTING/LIN/derrpox.f @@ -0,0 +1,487 @@ + SUBROUTINE DERRPO( PATH, NUNIT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* Purpose +* ======= +* +* DERRPO tests the error exits for the DOUBLE PRECISION routines +* for symmetric positive definite matrices. +* +* Arguments +* ========= +* +* PATH (input) CHARACTER*3 +* The LAPACK path name for the routines to be tested. +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 4 ) +* .. +* .. Local Scalars .. + CHARACTER EQ + CHARACTER*2 C2 + INTEGER I, INFO, J, N_ERR_BNDS, NPARAMS + DOUBLE PRECISION ANRM, RCOND, BERR +* .. +* .. Local Arrays .. + INTEGER 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 ), + $ ERR_BNDS_C( NMAX, 3 ), PARAMS +* .. +* .. External Functions .. + LOGICAL LSAMEN + EXTERNAL LSAMEN +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, DPBCON, DPBEQU, DPBRFS, DPBTF2, + $ DPBTRF, DPBTRS, DPOCON, DPOEQU, DPORFS, DPOTF2, + $ DPOTRF, DPOTRI, DPOTRS, DPPCON, DPPEQU, DPPRFS, + $ DPPTRF, DPPTRI, DPPTRS, DPOEQUB, DPORFSX +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) + C2 = PATH( 2: 3 ) +* +* Set the variables to innocuous values. +* + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + 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 + S( J ) = 0.D0 + IW( J ) = J + 20 CONTINUE + OK = .TRUE. +* + IF( LSAMEN( 2, C2, 'PO' ) ) THEN +* +* Test error exits of the routines that use the Cholesky +* decomposition of a symmetric positive definite matrix. +* +* DPOTRF +* + SRNAMT = 'DPOTRF' + INFOT = 1 + CALL DPOTRF( '/', 0, A, 1, INFO ) + CALL CHKXER( 'DPOTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPOTRF( 'U', -1, A, 1, INFO ) + CALL CHKXER( 'DPOTRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DPOTRF( 'U', 2, A, 1, INFO ) + CALL CHKXER( 'DPOTRF', INFOT, NOUT, LERR, OK ) +* +* DPOTF2 +* + SRNAMT = 'DPOTF2' + INFOT = 1 + CALL DPOTF2( '/', 0, A, 1, INFO ) + CALL CHKXER( 'DPOTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPOTF2( 'U', -1, A, 1, INFO ) + CALL CHKXER( 'DPOTF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DPOTF2( 'U', 2, A, 1, INFO ) + CALL CHKXER( 'DPOTF2', INFOT, NOUT, LERR, OK ) +* +* DPOTRI +* + SRNAMT = 'DPOTRI' + INFOT = 1 + CALL DPOTRI( '/', 0, A, 1, INFO ) + CALL CHKXER( 'DPOTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPOTRI( 'U', -1, A, 1, INFO ) + CALL CHKXER( 'DPOTRI', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DPOTRI( 'U', 2, A, 1, INFO ) + CALL CHKXER( 'DPOTRI', INFOT, NOUT, LERR, OK ) +* +* DPOTRS +* + SRNAMT = 'DPOTRS' + INFOT = 1 + CALL DPOTRS( '/', 0, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'DPOTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPOTRS( 'U', -1, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'DPOTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DPOTRS( 'U', 0, -1, A, 1, B, 1, INFO ) + CALL CHKXER( 'DPOTRS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DPOTRS( 'U', 2, 1, A, 1, B, 2, INFO ) + CALL CHKXER( 'DPOTRS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DPOTRS( 'U', 2, 1, A, 2, B, 1, INFO ) + CALL CHKXER( 'DPOTRS', INFOT, NOUT, LERR, OK ) +* +* DPORFS +* + SRNAMT = 'DPORFS' + INFOT = 1 + CALL DPORFS( '/', 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'DPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPORFS( 'U', -1, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'DPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DPORFS( 'U', 0, -1, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'DPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DPORFS( 'U', 2, 1, A, 1, AF, 2, B, 2, X, 2, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'DPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DPORFS( 'U', 2, 1, A, 2, AF, 1, B, 2, X, 2, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'DPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DPORFS( 'U', 2, 1, A, 2, AF, 2, B, 1, X, 2, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'DPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DPORFS( 'U', 2, 1, A, 2, AF, 2, B, 2, X, 1, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'DPORFS', INFOT, NOUT, LERR, OK ) +* +* DPORFSX +* + N_ERR_BNDS = 3 + NPARAMS = 0 + SRNAMT = 'DPORFSX' + INFOT = 1 + CALL DPORFSX( '/', EQ, 0, 0, A, 1, AF, 1, S, B, 1, X, 1, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, IW, INFO ) + CALL CHKXER( 'DPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPORFSX( 'U', EQ, -1, 0, A, 1, AF, 1, S, B, 1, X, 1, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, IW, INFO ) + CALL CHKXER( 'DPORFSX', INFOT, NOUT, LERR, OK ) + EQ = 'N' + INFOT = 3 + CALL DPORFSX( 'U', EQ, -1, 0, A, 1, AF, 1, S, B, 1, X, 1, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, IW, INFO ) + CALL CHKXER( 'DPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DPORFSX( 'U', EQ, 0, -1, A, 1, AF, 1, S, B, 1, X, 1, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, IW, INFO ) + CALL CHKXER( 'DPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DPORFSX( 'U', EQ, 2, 1, A, 1, AF, 2, S, B, 2, X, 2, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, IW, INFO ) + CALL CHKXER( 'DPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DPORFSX( 'U', EQ, 2, 1, A, 2, AF, 1, S, B, 2, X, 2, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, IW, INFO ) + CALL CHKXER( 'DPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DPORFSX( 'U', EQ, 2, 1, A, 2, AF, 2, S, B, 1, X, 2, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, IW, INFO ) + CALL CHKXER( 'DPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL DPORFSX( 'U', EQ, 2, 1, A, 2, AF, 2, S, B, 2, X, 1, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, IW, INFO ) + CALL CHKXER( 'DPORFSX', INFOT, NOUT, LERR, OK ) +* +* DPOCON +* + SRNAMT = 'DPOCON' + INFOT = 1 + CALL DPOCON( '/', 0, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DPOCON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPOCON( 'U', -1, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DPOCON', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DPOCON( 'U', 2, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DPOCON', INFOT, NOUT, LERR, OK ) +* +* DPOEQU +* + SRNAMT = 'DPOEQU' + INFOT = 1 + CALL DPOEQU( -1, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'DPOEQU', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DPOEQU( 2, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'DPOEQU', INFOT, NOUT, LERR, OK ) +* +* DPOEQUB +* + SRNAMT = 'DPOEQUB' + INFOT = 1 + CALL DPOEQUB( -1, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'DPOEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DPOEQUB( 2, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'DPOEQUB', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN +* +* Test error exits of the routines that use the Cholesky +* decomposition of a symmetric positive definite packed matrix. +* +* DPPTRF +* + SRNAMT = 'DPPTRF' + INFOT = 1 + CALL DPPTRF( '/', 0, A, INFO ) + CALL CHKXER( 'DPPTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPPTRF( 'U', -1, A, INFO ) + CALL CHKXER( 'DPPTRF', INFOT, NOUT, LERR, OK ) +* +* DPPTRI +* + SRNAMT = 'DPPTRI' + INFOT = 1 + CALL DPPTRI( '/', 0, A, INFO ) + CALL CHKXER( 'DPPTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPPTRI( 'U', -1, A, INFO ) + CALL CHKXER( 'DPPTRI', INFOT, NOUT, LERR, OK ) +* +* DPPTRS +* + SRNAMT = 'DPPTRS' + INFOT = 1 + CALL DPPTRS( '/', 0, 0, A, B, 1, INFO ) + CALL CHKXER( 'DPPTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPPTRS( 'U', -1, 0, A, B, 1, INFO ) + CALL CHKXER( 'DPPTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DPPTRS( 'U', 0, -1, A, B, 1, INFO ) + CALL CHKXER( 'DPPTRS', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DPPTRS( 'U', 2, 1, A, B, 1, INFO ) + CALL CHKXER( 'DPPTRS', INFOT, NOUT, LERR, OK ) +* +* DPPRFS +* + SRNAMT = 'DPPRFS' + INFOT = 1 + CALL DPPRFS( '/', 0, 0, A, AF, B, 1, X, 1, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'DPPRFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPPRFS( 'U', -1, 0, A, AF, B, 1, X, 1, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'DPPRFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DPPRFS( 'U', 0, -1, A, AF, B, 1, X, 1, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'DPPRFS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DPPRFS( 'U', 2, 1, A, AF, B, 1, X, 2, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'DPPRFS', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL DPPRFS( 'U', 2, 1, A, AF, B, 2, X, 1, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'DPPRFS', INFOT, NOUT, LERR, OK ) +* +* DPPCON +* + SRNAMT = 'DPPCON' + INFOT = 1 + CALL DPPCON( '/', 0, A, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DPPCON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPPCON( 'U', -1, A, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DPPCON', INFOT, NOUT, LERR, OK ) +* +* DPPEQU +* + SRNAMT = 'DPPEQU' + INFOT = 1 + CALL DPPEQU( '/', 0, A, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'DPPEQU', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPPEQU( 'U', -1, A, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'DPPEQU', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN +* +* Test error exits of the routines that use the Cholesky +* decomposition of a symmetric positive definite band matrix. +* +* DPBTRF +* + SRNAMT = 'DPBTRF' + INFOT = 1 + CALL DPBTRF( '/', 0, 0, A, 1, INFO ) + CALL CHKXER( 'DPBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPBTRF( 'U', -1, 0, A, 1, INFO ) + CALL CHKXER( 'DPBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DPBTRF( 'U', 1, -1, A, 1, INFO ) + CALL CHKXER( 'DPBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DPBTRF( 'U', 2, 1, A, 1, INFO ) + CALL CHKXER( 'DPBTRF', INFOT, NOUT, LERR, OK ) +* +* DPBTF2 +* + SRNAMT = 'DPBTF2' + INFOT = 1 + CALL DPBTF2( '/', 0, 0, A, 1, INFO ) + CALL CHKXER( 'DPBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPBTF2( 'U', -1, 0, A, 1, INFO ) + CALL CHKXER( 'DPBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DPBTF2( 'U', 1, -1, A, 1, INFO ) + CALL CHKXER( 'DPBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DPBTF2( 'U', 2, 1, A, 1, INFO ) + CALL CHKXER( 'DPBTF2', INFOT, NOUT, LERR, OK ) +* +* DPBTRS +* + SRNAMT = 'DPBTRS' + INFOT = 1 + CALL DPBTRS( '/', 0, 0, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'DPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPBTRS( 'U', -1, 0, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'DPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DPBTRS( 'U', 1, -1, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'DPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DPBTRS( 'U', 0, 0, -1, A, 1, B, 1, INFO ) + CALL CHKXER( 'DPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DPBTRS( 'U', 2, 1, 1, A, 1, B, 1, INFO ) + CALL CHKXER( 'DPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DPBTRS( 'U', 2, 0, 1, A, 1, B, 1, INFO ) + CALL CHKXER( 'DPBTRS', INFOT, NOUT, LERR, OK ) +* +* DPBRFS +* + SRNAMT = 'DPBRFS' + INFOT = 1 + CALL DPBRFS( '/', 0, 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'DPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPBRFS( 'U', -1, 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'DPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DPBRFS( 'U', 1, -1, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'DPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DPBRFS( 'U', 0, 0, -1, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'DPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DPBRFS( 'U', 2, 1, 1, A, 1, AF, 2, B, 2, X, 2, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'DPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DPBRFS( 'U', 2, 1, 1, A, 2, AF, 1, B, 2, X, 2, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'DPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL DPBRFS( 'U', 2, 0, 1, A, 1, AF, 1, B, 1, X, 2, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'DPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL DPBRFS( 'U', 2, 0, 1, A, 1, AF, 1, B, 2, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'DPBRFS', INFOT, NOUT, LERR, OK ) +* +* DPBCON +* + SRNAMT = 'DPBCON' + INFOT = 1 + CALL DPBCON( '/', 0, 0, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DPBCON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPBCON( 'U', -1, 0, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DPBCON', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DPBCON( 'U', 1, -1, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DPBCON', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DPBCON( 'U', 2, 1, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'DPBCON', INFOT, NOUT, LERR, OK ) +* +* DPBEQU +* + SRNAMT = 'DPBEQU' + INFOT = 1 + CALL DPBEQU( '/', 0, 0, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'DPBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPBEQU( 'U', -1, 0, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'DPBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DPBEQU( 'U', 1, -1, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'DPBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DPBEQU( 'U', 2, 1, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'DPBEQU', INFOT, NOUT, LERR, OK ) + END IF +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of DERRPO +* + END diff --git a/TESTING/LIN/derrps.f b/TESTING/LIN/derrps.f new file mode 100644 index 00000000..79bbee6b --- /dev/null +++ b/TESTING/LIN/derrps.f @@ -0,0 +1,113 @@ + SUBROUTINE DERRPS( PATH, NUNIT ) +* +* -- LAPACK test routine (version 3.1) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + INTEGER NUNIT + CHARACTER*3 PATH +* .. +* +* Purpose +* ======= +* +* DERRPS tests the error exits for the DOUBLE PRECISION routines +* for DPSTRF. +* +* Arguments +* ========= +* +* PATH (input) CHARACTER*3 +* The LAPACK path name for the routines to be tested. +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 4 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J +* .. +* .. Local Arrays .. + DOUBLE PRECISION A( NMAX, NMAX ), WORK( 2*NMAX ) + INTEGER PIV( NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, DPSTF2, DPSTRF +* .. +* .. Scalars in Common .. + INTEGER INFOT, NOUT + LOGICAL LERR, OK + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO 110 J = 1, NMAX + DO 100 I = 1, NMAX + A( I, J ) = 1.D0 / DBLE( I+J ) +* + 100 CONTINUE + PIV( J ) = J + WORK( J ) = 0.D0 + WORK( NMAX+J ) = 0.D0 +* + 110 CONTINUE + OK = .TRUE. +* +* +* Test error exits of the routines that use the Cholesky +* decomposition of a symmetric positive semidefinite matrix. +* +* DPSTRF +* + SRNAMT = 'DPSTRF' + INFOT = 1 + CALL DPSTRF( '/', 0, A, 1, PIV, 1, -1.D0, WORK, INFO ) + CALL CHKXER( 'DPSTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPSTRF( 'U', -1, A, 1, PIV, 1, -1.D0, WORK, INFO ) + CALL CHKXER( 'DPSTRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DPSTRF( 'U', 2, A, 1, PIV, 1, -1.D0, WORK, INFO ) + CALL CHKXER( 'DPSTRF', INFOT, NOUT, LERR, OK ) +* +* DPSTF2 +* + SRNAMT = 'DPSTF2' + INFOT = 1 + CALL DPSTF2( '/', 0, A, 1, PIV, 1, -1.D0, WORK, INFO ) + CALL CHKXER( 'DPSTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPSTF2( 'U', -1, A, 1, PIV, 1, -1.D0, WORK, INFO ) + CALL CHKXER( 'DPSTF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DPSTF2( 'U', 2, A, 1, PIV, 1, -1.D0, WORK, INFO ) + CALL CHKXER( 'DPSTF2', INFOT, NOUT, LERR, OK ) +* +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of DERRPS +* + END diff --git a/TESTING/LIN/derrql.f b/TESTING/LIN/derrql.f index aa781ec2..dd68d0a4 100644 --- a/TESTING/LIN/derrql.f +++ b/TESTING/LIN/derrql.f @@ -43,7 +43,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/derrqp.f b/TESTING/LIN/derrqp.f index 3989cbc1..71e18f6d 100644 --- a/TESTING/LIN/derrqp.f +++ b/TESTING/LIN/derrqp.f @@ -46,7 +46,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/derrqr.f b/TESTING/LIN/derrqr.f index 7d44314f..9503f992 100644 --- a/TESTING/LIN/derrqr.f +++ b/TESTING/LIN/derrqr.f @@ -43,7 +43,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/derrrfp.f b/TESTING/LIN/derrrfp.f new file mode 100644 index 00000000..ba72752f --- /dev/null +++ b/TESTING/LIN/derrrfp.f @@ -0,0 +1,247 @@ + SUBROUTINE DERRRFP( NUNIT ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER NUNIT +* .. +* +* Purpose +* ======= +* +* DERRRFP tests the error exits for the DOUBLE PRECISION driver routines +* for solving linear systems of equations. +* +* DDRVRFP tests the DOUBLE PRECISION LAPACK RFP routines: +* DTFSM, DTFTRI, DSFRK, DTFTTP, DTFTTR, DPFTRF, DPFTRS, DTPTTF, +* DTPTTR, DTRTTF, and DTRTTP +* +* Arguments +* ========= +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER INFO + DOUBLE PRECISION ALPHA, BETA +* .. +* .. Local Arrays .. + DOUBLE PRECISION A( 1, 1), B( 1, 1) +* .. +* .. External Subroutines .. + EXTERNAL CHKXER, DTFSM, DTFTRI, DSFRK, DTFTTP, DTFTTR, + + DPFTRI, DPFTRF, DPFTRS, DTPTTF, DTPTTR, DTRTTF, + + DTRTTP +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + OK = .TRUE. + A( 1, 1 ) = 1.0D+0 + B( 1, 1 ) = 1.0D+0 + ALPHA = 1.0D+0 + BETA = 1.0D+0 +* + SRNAMT = 'DPFTRF' + INFOT = 1 + CALL DPFTRF( '/', 'U', 0, A, INFO ) + CALL CHKXER( 'DPFTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPFTRF( 'N', '/', 0, A, INFO ) + CALL CHKXER( 'DPFTRF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DPFTRF( 'N', 'U', -1, A, INFO ) + CALL CHKXER( 'DPFTRF', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'DPFTRS' + INFOT = 1 + CALL DPFTRS( '/', 'U', 0, 0, A, B, 1, INFO ) + CALL CHKXER( 'DPFTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPFTRS( 'N', '/', 0, 0, A, B, 1, INFO ) + CALL CHKXER( 'DPFTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DPFTRS( 'N', 'U', -1, 0, A, B, 1, INFO ) + CALL CHKXER( 'DPFTRS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DPFTRS( 'N', 'U', 0, -1, A, B, 1, INFO ) + CALL CHKXER( 'DPFTRS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DPFTRS( 'N', 'U', 0, 0, A, B, 0, INFO ) + CALL CHKXER( 'DPFTRS', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'DPFTRI' + INFOT = 1 + CALL DPFTRI( '/', 'U', 0, A, INFO ) + CALL CHKXER( 'DPFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DPFTRI( 'N', '/', 0, A, INFO ) + CALL CHKXER( 'DPFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DPFTRI( 'N', 'U', -1, A, INFO ) + CALL CHKXER( 'DPFTRI', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'DTFSM ' + INFOT = 1 + CALL DTFSM( '/', 'L', 'U', 'T', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'DTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DTFSM( 'N', '/', 'U', 'T', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'DTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DTFSM( 'N', 'L', '/', 'T', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'DTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DTFSM( 'N', 'L', 'U', '/', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'DTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DTFSM( 'N', 'L', 'U', 'T', '/', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'DTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DTFSM( 'N', 'L', 'U', 'T', 'U', -1, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'DTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL DTFSM( 'N', 'L', 'U', 'T', 'U', 0, -1, ALPHA, A, B, 1 ) + CALL CHKXER( 'DTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL DTFSM( 'N', 'L', 'U', 'T', 'U', 0, 0, ALPHA, A, B, 0 ) + CALL CHKXER( 'DTFSM ', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'DTFTRI' + INFOT = 1 + CALL DTFTRI( '/', 'L', 'N', 0, A, INFO ) + CALL CHKXER( 'DTFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DTFTRI( 'N', '/', 'N', 0, A, INFO ) + CALL CHKXER( 'DTFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DTFTRI( 'N', 'L', '/', 0, A, INFO ) + CALL CHKXER( 'DTFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DTFTRI( 'N', 'L', 'N', -1, A, INFO ) + CALL CHKXER( 'DTFTRI', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'DTFTTR' + INFOT = 1 + CALL DTFTTR( '/', 'U', 0, A, B, 1, INFO ) + CALL CHKXER( 'DTFTTR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DTFTTR( 'N', '/', 0, A, B, 1, INFO ) + CALL CHKXER( 'DTFTTR', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DTFTTR( 'N', 'U', -1, A, B, 1, INFO ) + CALL CHKXER( 'DTFTTR', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL DTFTTR( 'N', 'U', 0, A, B, 0, INFO ) + CALL CHKXER( 'DTFTTR', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'DTRTTF' + INFOT = 1 + CALL DTRTTF( '/', 'U', 0, A, 1, B, INFO ) + CALL CHKXER( 'DTRTTF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DTRTTF( 'N', '/', 0, A, 1, B, INFO ) + CALL CHKXER( 'DTRTTF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DTRTTF( 'N', 'U', -1, A, 1, B, INFO ) + CALL CHKXER( 'DTRTTF', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DTRTTF( 'N', 'U', 0, A, 0, B, INFO ) + CALL CHKXER( 'DTRTTF', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'DTFTTP' + INFOT = 1 + CALL DTFTTP( '/', 'U', 0, A, B, INFO ) + CALL CHKXER( 'DTFTTP', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DTFTTP( 'N', '/', 0, A, B, INFO ) + CALL CHKXER( 'DTFTTP', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DTFTTP( 'N', 'U', -1, A, B, INFO ) + CALL CHKXER( 'DTFTTP', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'DTPTTF' + INFOT = 1 + CALL DTPTTF( '/', 'U', 0, A, B, INFO ) + CALL CHKXER( 'DTPTTF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DTPTTF( 'N', '/', 0, A, B, INFO ) + CALL CHKXER( 'DTPTTF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DTPTTF( 'N', 'U', -1, A, B, INFO ) + CALL CHKXER( 'DTPTTF', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'DTRTTP' + INFOT = 1 + CALL DTRTTP( '/', 0, A, 1, B, INFO ) + CALL CHKXER( 'DTRTTP', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DTRTTP( 'U', -1, A, 1, B, INFO ) + CALL CHKXER( 'DTRTTP', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DTRTTP( 'U', 0, A, 0, B, INFO ) + CALL CHKXER( 'DTRTTP', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'DTPTTR' + INFOT = 1 + CALL DTPTTR( '/', 0, A, B, 1, INFO ) + CALL CHKXER( 'DTPTTR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DTPTTR( 'U', -1, A, B, 1, INFO ) + CALL CHKXER( 'DTPTTR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DTPTTR( 'U', 0, A, B, 0, INFO ) + CALL CHKXER( 'DTPTTR', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'DSFRK ' + INFOT = 1 + CALL DSFRK( '/', 'U', 'N', 0, 0, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'DSFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL DSFRK( 'N', '/', 'N', 0, 0, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'DSFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL DSFRK( 'N', 'U', '/', 0, 0, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'DSFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL DSFRK( 'N', 'U', 'N', -1, 0, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'DSFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL DSFRK( 'N', 'U', 'N', 0, -1, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'DSFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL DSFRK( 'N', 'U', 'N', 0, 0, ALPHA, A, 0, BETA, B ) + CALL CHKXER( 'DSFRK ', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + IF( OK ) THEN + WRITE( NOUT, FMT = 9999 ) + ELSE + WRITE( NOUT, FMT = 9998 ) + END IF +* + 9999 FORMAT( 1X, 'DOUBLE PRECISION RFP routines passed the tests of ', + $ 'the error exits' ) + 9998 FORMAT( ' *** RFP routines failed the tests of the error ', + $ 'exits ***' ) + RETURN +* +* End of DERRRFP +* + END diff --git a/TESTING/LIN/derrrq.f b/TESTING/LIN/derrrq.f index b0e29cb2..d2ac6af7 100644 --- a/TESTING/LIN/derrrq.f +++ b/TESTING/LIN/derrrq.f @@ -43,7 +43,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/derrsy.f b/TESTING/LIN/derrsy.f index 0a1d07f9..27098be8 100644 --- a/TESTING/LIN/derrsy.f +++ b/TESTING/LIN/derrsy.f @@ -51,7 +51,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/derrtr.f b/TESTING/LIN/derrtr.f index 01662015..52f926b2 100644 --- a/TESTING/LIN/derrtr.f +++ b/TESTING/LIN/derrtr.f @@ -51,7 +51,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/derrtz.f b/TESTING/LIN/derrtz.f index f710c71b..f3c6eb89 100644 --- a/TESTING/LIN/derrtz.f +++ b/TESTING/LIN/derrtz.f @@ -45,7 +45,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/derrvx.f b/TESTING/LIN/derrvx.f index 502ba315..df3aac12 100644 --- a/TESTING/LIN/derrvx.f +++ b/TESTING/LIN/derrvx.f @@ -54,7 +54,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/dget07.f b/TESTING/LIN/dget07.f index 202ba3e0..e996926e 100644 --- a/TESTING/LIN/dget07.f +++ b/TESTING/LIN/dget07.f @@ -1,5 +1,5 @@ SUBROUTINE DGET07( TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, - $ LDXACT, FERR, BERR, RESLTS ) + $ LDXACT, FERR, CHKFERR, BERR, RESLTS ) * * -- LAPACK test routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. @@ -7,6 +7,7 @@ * * .. Scalar Arguments .. CHARACTER TRANS + LOGICAL CHKFERR INTEGER LDA, LDB, LDX, LDXACT, N, NRHS * .. * .. Array Arguments .. @@ -78,6 +79,11 @@ * of the largest entry in (X - XTRUE) divided by the magnitude * of the largest entry in X. * +* CHKFERR (input) LOGICAL +* Set to .TRUE. to check FERR, .FALSE. not to check FERR. +* When the test system is ill-conditioned, the "true" +* solution in XACT may be incorrect. +* * BERR (input) DOUBLE PRECISION array, dimension (NRHS) * The componentwise relative backward error of each solution * vector (i.e., the smallest relative change in any entry of A @@ -128,30 +134,32 @@ * over all the vectors X and XACT using the infinity-norm. * ERRBND = ZERO - DO 30 J = 1, NRHS - IMAX = IDAMAX( N, X( 1, J ), 1 ) - XNORM = MAX( ABS( X( IMAX, J ) ), UNFL ) - DIFF = ZERO - DO 10 I = 1, N - DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) ) - 10 CONTINUE -* - IF( XNORM.GT.ONE ) THEN - GO TO 20 - ELSE IF( DIFF.LE.OVFL*XNORM ) THEN - GO TO 20 - ELSE - ERRBND = ONE / EPS - GO TO 30 - END IF + IF( CHKFERR ) THEN + DO 30 J = 1, NRHS + IMAX = IDAMAX( N, X( 1, J ), 1 ) + XNORM = MAX( ABS( X( IMAX, J ) ), UNFL ) + DIFF = ZERO + DO 10 I = 1, N + DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) ) + 10 CONTINUE +* + IF( XNORM.GT.ONE ) THEN + GO TO 20 + ELSE IF( DIFF.LE.OVFL*XNORM ) THEN + GO TO 20 + ELSE + ERRBND = ONE / EPS + GO TO 30 + END IF * - 20 CONTINUE - IF( DIFF / XNORM.LE.FERR( J ) ) THEN - ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) ) - ELSE - ERRBND = ONE / EPS - END IF - 30 CONTINUE + 20 CONTINUE + IF( DIFF / XNORM.LE.FERR( J ) ) THEN + ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) ) + ELSE + ERRBND = ONE / EPS + END IF + 30 CONTINUE + END IF RESLTS( 1 ) = ERRBND * * Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where diff --git a/TESTING/LIN/dlahilb.f b/TESTING/LIN/dlahilb.f new file mode 100644 index 00000000..ebc4d55b --- /dev/null +++ b/TESTING/LIN/dlahilb.f @@ -0,0 +1,168 @@ + SUBROUTINE DLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO) +! +! -- LAPACK auxiliary test routine (version 3.0) -- +! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +! Courant Institute, Argonne National Lab, and Rice University +! 28 August, 2006 +! +! David Vu <dtv@cs.berkeley.edu> +! Yozo Hida <yozo@cs.berkeley.edu> +! Jason Riedy <ejr@cs.berkeley.edu> +! D. Halligan <dhalligan@berkeley.edu> +! + IMPLICIT NONE +! .. Scalar Arguments .. + INTEGER N, NRHS, LDA, LDX, LDB, INFO +! .. Array Arguments .. + DOUBLE PRECISION A(LDA, N), X(LDX, NRHS), B(LDB, NRHS), WORK(N) +! .. +! +! Purpose +! ======= +! +! DLAHILB generates an N by N scaled Hilbert matrix in A along with +! NRHS right-hand sides in B and solutions in X such that A*X=B. +! +! The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all +! entries are integers. The right-hand sides are the first NRHS +! columns of M * the identity matrix, and the solutions are the +! first NRHS columns of the inverse Hilbert matrix. +! +! The condition number of the Hilbert matrix grows exponentially with +! its size, roughly as O(e ** (3.5*N)). Additionally, the inverse +! Hilbert matrices beyond a relatively small dimension cannot be +! generated exactly without extra precision. Precision is exhausted +! when the largest entry in the inverse Hilbert matrix is greater than +! 2 to the power of the number of bits in the fraction of the data type +! used plus one, which is 24 for single precision. +! +! In single, the generated solution is exact for N <= 6 and has +! small componentwise error for 7 <= N <= 11. +! +! Arguments +! ========= +! +! N (input) INTEGER +! The dimension of the matrix A. +! +! NRHS (input) NRHS +! The requested number of right-hand sides. +! +! A (output) DOUBLE PRECISION array, dimension (LDA, N) +! The generated scaled Hilbert matrix. +! +! LDA (input) INTEGER +! The leading dimension of the array A. LDA >= N. +! +! X (output) DOUBLE PRECISION array, dimension (LDX, NRHS) +! The generated exact solutions. Currently, the first NRHS +! columns of the inverse Hilbert matrix. +! +! LDX (input) INTEGER +! The leading dimension of the array X. LDX >= N. +! +! B (output) DOUBLE PRECISION array, dimension (LDB, NRHS) +! The generated right-hand sides. Currently, the first NRHS +! columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. +! +! LDB (input) INTEGER +! The leading dimension of the array B. LDB >= N. +! +! WORK (workspace) DOUBLE PRECISION array, dimension (N) +! +! +! INFO (output) INTEGER +! = 0: successful exit +! = 1: N is too large; the data is still generated but may not +! be not exact. +! < 0: if INFO = -i, the i-th argument had an illegal value +! +! ===================================================================== + +! .. Local Scalars .. + INTEGER TM, TI, R + INTEGER M + INTEGER I, J + COMPLEX*16 TMP + +! .. Parameters .. +! NMAX_EXACT the largest dimension where the generated data is +! exact. +! NMAX_APPROX the largest dimension where the generated data has +! a small componentwise relative error. + INTEGER NMAX_EXACT, NMAX_APPROX + PARAMETER (NMAX_EXACT = 6, NMAX_APPROX = 11) + +! .. +! .. External Functions + EXTERNAL DLASET + INTRINSIC DBLE +! .. +! .. Executable Statements .. +! +! Test the input arguments +! + INFO = 0 + IF (N .LT. 0 .OR. N .GT. NMAX_APPROX) THEN + INFO = -1 + ELSE IF (NRHS .LT. 0) THEN + INFO = -2 + ELSE IF (LDA .LT. N) THEN + INFO = -4 + ELSE IF (LDX .LT. N) THEN + INFO = -6 + ELSE IF (LDB .LT. N) THEN + INFO = -8 + END IF + IF (INFO .LT. 0) THEN + CALL XERBLA('DLAHILB', -INFO) + RETURN + END IF + IF (N .GT. NMAX_EXACT) THEN + INFO = 1 + END IF + +! Compute M = the LCM of the integers [1, 2*N-1]. The largest +! reasonable N is small enough that integers suffice (up to N = 11). + M = 1 + DO I = 2, (2*N-1) + TM = M + TI = I + R = MOD(TM, TI) + DO WHILE (R .NE. 0) + TM = TI + TI = R + R = MOD(TM, TI) + END DO + M = (M / TI) * I + END DO + +! Generate the scaled Hilbert matrix in A + DO J = 1, N + DO I = 1, N + A(I, J) = DBLE(M) / (I + J - 1) + END DO + END DO + +! Generate matrix B as simply the first NRHS columns of M * the +! identity. + TMP = DBLE(M) + CALL DLASET('Full', N, NRHS, 0.0D+0, TMP, B, LDB) + +! Generate the true solutions in X. Because B = the first NRHS +! columns of M*I, the true solutions are just the first NRHS columns +! of the inverse Hilbert matrix. + WORK(1) = N + DO J = 2, N + WORK(J) = ( ( (WORK(J-1)/(J-1)) * (J-1 - N) ) /(J-1) ) + $ * (N +J -1) + END DO + + DO J = 1, NRHS + DO I = 1, N + X(I, J) = (WORK(I)*WORK(J)) / (I + J - 1) + END DO + END DO + + END + diff --git a/TESTING/LIN/dlatb5.f b/TESTING/LIN/dlatb5.f new file mode 100644 index 00000000..43d1d56e --- /dev/null +++ b/TESTING/LIN/dlatb5.f @@ -0,0 +1,166 @@ + SUBROUTINE DLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) +* +* -- LAPACK test routine (version 3.1) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ANORM, CNDNUM + INTEGER IMAT, KL, KU, MODE, N + CHARACTER DIST, TYPE + CHARACTER*3 PATH +* .. +* +* Purpose +* ======= +* +* DLATB5 sets parameters for the matrix generator based on the type +* of matrix to be generated. +* +* Arguments +* ========= +* +* PATH (input) CHARACTER*3 +* The LAPACK path name. +* +* IMAT (input) INTEGER +* An integer key describing which matrix to generate for this +* path. +* +* N (input) INTEGER +* The number of rows and columns in the matrix to be generated. +* +* TYPE (output) CHARACTER*1 +* The type of the matrix to be generated: +* = 'S': symmetric matrix +* = 'P': symmetric positive (semi)definite matrix +* = 'N': nonsymmetric matrix +* +* KL (output) INTEGER +* The lower band width of the matrix to be generated. +* +* KU (output) INTEGER +* The upper band width of the matrix to be generated. +* +* ANORM (output) DOUBLE PRECISION +* The desired norm of the matrix to be generated. The diagonal +* matrix of singular values or eigenvalues is scaled by this +* value. +* +* MODE (output) INTEGER +* A key indicating how to choose the vector of eigenvalues. +* +* CNDNUM (output) DOUBLE PRECISION +* The desired condition number. +* +* DIST (output) CHARACTER*1 +* The type of distribution to be used by the random number +* generator. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION SHRINK, TENTH + PARAMETER ( SHRINK = 0.25D0, TENTH = 0.1D+0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION BADC1, BADC2, EPS, LARGE, SMALL + LOGICAL FIRST + CHARACTER*2 C2 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Subroutines .. + EXTERNAL DLABAD +* .. +* .. Save statement .. + SAVE EPS, SMALL, LARGE, BADC1, BADC2, FIRST +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* +* Set some constants for use in the subroutine. +* + IF( FIRST ) THEN + FIRST = .FALSE. + EPS = DLAMCH( 'Precision' ) + BADC2 = TENTH / EPS + BADC1 = SQRT( BADC2 ) + SMALL = DLAMCH( 'Safe minimum' ) + LARGE = ONE / SMALL +* +* If it looks like we're on a Cray, take the square root of +* SMALL and LARGE to avoid overflow and underflow problems. +* + CALL DLABAD( SMALL, LARGE ) + SMALL = SHRINK*( SMALL / EPS ) + LARGE = ONE / SMALL + END IF +* + C2 = PATH( 2: 3 ) +* +* Set some parameters +* + DIST = 'S' + MODE = 3 +* +* Set TYPE, the type of matrix to be generated. +* + TYPE = C2( 1: 1 ) +* +* Set the lower and upper bandwidths. +* + IF( IMAT.EQ.1 ) THEN + KL = 0 + ELSE + KL = MAX( N-1, 0 ) + END IF + KU = KL +* +* Set the condition number and norm.etc +* + IF( IMAT.EQ.3 ) THEN + CNDNUM = 1.0D12 + MODE = 2 + ELSE IF( IMAT.EQ.4 ) THEN + CNDNUM = 1.0D12 + MODE = 1 + ELSE IF( IMAT.EQ.5 ) THEN + CNDNUM = 1.0D12 + MODE = 3 + ELSE IF( IMAT.EQ.6 ) THEN + CNDNUM = BADC1 + ELSE IF( IMAT.EQ.7 ) THEN + CNDNUM = BADC2 + ELSE + CNDNUM = TWO + END IF +* + IF( IMAT.EQ.8 ) THEN + ANORM = SMALL + ELSE IF( IMAT.EQ.9 ) THEN + ANORM = LARGE + ELSE + ANORM = ONE + END IF +* + IF( N.LE.1 ) + $ CNDNUM = ONE +* + RETURN +* +* End of DLATB5 +* + END diff --git a/TESTING/LIN/dlqt01.f b/TESTING/LIN/dlqt01.f index b921eb6e..aa13ff86 100644 --- a/TESTING/LIN/dlqt01.f +++ b/TESTING/LIN/dlqt01.f @@ -87,7 +87,7 @@ INTRINSIC DBLE, MAX, MIN * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/dlqt02.f b/TESTING/LIN/dlqt02.f index 07f2ebfc..a77548a2 100644 --- a/TESTING/LIN/dlqt02.f +++ b/TESTING/LIN/dlqt02.f @@ -93,7 +93,7 @@ INTRINSIC DBLE, MAX * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/dlqt03.f b/TESTING/LIN/dlqt03.f index 6f87356a..6773cde8 100644 --- a/TESTING/LIN/dlqt03.f +++ b/TESTING/LIN/dlqt03.f @@ -99,7 +99,7 @@ INTRINSIC DBLE, MAX * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/dpot06.f b/TESTING/LIN/dpot06.f new file mode 100644 index 00000000..d1c2df51 --- /dev/null +++ b/TESTING/LIN/dpot06.f @@ -0,0 +1,136 @@ + SUBROUTINE DPOT06( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, + $ RWORK, RESID ) +* +* -- LAPACK test routine (version 3.1.2) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* April 2007 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, LDX, N, NRHS + DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ), + $ X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* DPOT06 computes the residual for a solution of a system of linear +* equations A*x = b : +* RESID = norm(B - A*X,inf) / ( norm(A,inf) * norm(X,inf) * EPS ), +* where EPS is the machine epsilon. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is stored: +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The number of rows and columns of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of columns of B, the matrix of right hand sides. +* NRHS >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The original M x N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS) +* The computed solution vectors for the system of linear +* equations. +* +* LDX (input) INTEGER +* The leading dimension of the array X. If TRANS = 'N', +* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,N). +* +* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) +* On entry, the right hand side vectors for the system of +* linear equations. +* On exit, B is overwritten with the difference B - A*X. +* +* LDB (input) INTEGER +* The leading dimension of the array B. IF TRANS = 'N', +* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (N) +* +* RESID (output) DOUBLE PRECISION +* The maximum over the number of right hand sides of +* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, NEGONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + PARAMETER ( NEGONE = -1.0D+0 ) +* .. +* .. Local Scalars .. + INTEGER IFAIL, J + DOUBLE PRECISION ANORM, BNORM, EPS, XNORM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, IDAMAX, DLAMCH, DLANSY +* .. +* .. External Subroutines .. + EXTERNAL DSYMM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, ABS +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0 or NRHS = 0 +* + IF( N.LE.0 .OR. NRHS.EQ.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Exit with RESID = 1/EPS if ANORM = 0. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = DLANSY( 'I', UPLO, N, A, LDA, RWORK ) + IF( ANORM.LE.ZERO ) THEN + RESID = ONE / EPS + RETURN + END IF +* +* Compute B - A*X and store in B. + IFAIL=0 +* + CALL DSYMM( 'Left', UPLO, N, NRHS, NEGONE, A, LDA, X, + $ LDX, ONE, B, LDB ) +* +* Compute the maximum over the number of right hand sides of +* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) . +* + RESID = ZERO + DO 10 J = 1, NRHS + BNORM = ABS(B(IDAMAX( N, B( 1, J ), 1 ),J)) + XNORM = ABS(X(IDAMAX( N, X( 1, J ), 1 ),J)) + IF( XNORM.LE.ZERO ) THEN + RESID = ONE / EPS + ELSE + RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS ) + END IF + 10 CONTINUE +* + RETURN +* +* End of DPOT06 +* + END diff --git a/TESTING/LIN/dpst01.f b/TESTING/LIN/dpst01.f new file mode 100644 index 00000000..395890ea --- /dev/null +++ b/TESTING/LIN/dpst01.f @@ -0,0 +1,225 @@ + SUBROUTINE DPST01( UPLO, N, A, LDA, AFAC, LDAFAC, PERM, LDPERM, + $ PIV, RWORK, RESID, RANK ) +* +* -- LAPACK test routine (version 3.1) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + DOUBLE PRECISION RESID + INTEGER LDA, LDAFAC, LDPERM, N, RANK + CHARACTER UPLO +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), AFAC( LDAFAC, * ), + $ PERM( LDPERM, * ), RWORK( * ) + INTEGER PIV( * ) +* .. +* +* Purpose +* ======= +* +* DPST01 reconstructs a symmetric positive semidefinite matrix A +* from its L or U factors and the permutation matrix P and computes +* the residual +* norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or +* norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ), +* where EPS is the machine epsilon. +* +* Arguments +* ========== +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is stored: +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The number of rows and columns of the matrix A. N >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The original symmetric matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N) +* +* AFAC (input) DOUBLE PRECISION array, dimension (LDAFAC,N) +* The factor L or U from the L*L' or U'*U +* factorization of A. +* +* LDAFAC (input) INTEGER +* The leading dimension of the array AFAC. LDAFAC >= max(1,N). +* +* PERM (output) DOUBLE PRECISION array, dimension (LDPERM,N) +* Overwritten with the reconstructed matrix, and then with the +* difference P*L*L'*P' - A (or P*U'*U*P' - A) +* +* LDPERM (input) INTEGER +* The leading dimension of the array PERM. +* LDAPERM >= max(1,N). +* +* PIV (input) INTEGER array, dimension (N) +* PIV is such that the nonzero entries are +* P( PIV( K ), K ) = 1. +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (N) +* +* RESID (output) DOUBLE PRECISION +* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) +* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION ANORM, EPS, T + INTEGER I, J, K +* .. +* .. External Functions .. + DOUBLE PRECISION DDOT, DLAMCH, DLANSY + LOGICAL LSAME + EXTERNAL DDOT, DLAMCH, DLANSY, LSAME +* .. +* .. External Subroutines .. + EXTERNAL DSCAL, DSYR, DTRMV +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Exit with RESID = 1/EPS if ANORM = 0. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK ) + IF( ANORM.LE.ZERO ) THEN + RESID = ONE / EPS + RETURN + END IF +* +* Compute the product U'*U, overwriting U. +* + IF( LSAME( UPLO, 'U' ) ) THEN +* + IF( RANK.LT.N ) THEN + DO 110 J = RANK + 1, N + DO 100 I = RANK + 1, J + AFAC( I, J ) = ZERO + 100 CONTINUE + 110 CONTINUE + END IF +* + DO 120 K = N, 1, -1 +* +* Compute the (K,K) element of the result. +* + T = DDOT( K, AFAC( 1, K ), 1, AFAC( 1, K ), 1 ) + AFAC( K, K ) = T +* +* Compute the rest of column K. +* + CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', K-1, AFAC, + $ LDAFAC, AFAC( 1, K ), 1 ) +* + 120 CONTINUE +* +* Compute the product L*L', overwriting L. +* + ELSE +* + IF( RANK.LT.N ) THEN + DO 140 J = RANK + 1, N + DO 130 I = J, N + AFAC( I, J ) = ZERO + 130 CONTINUE + 140 CONTINUE + END IF +* + DO 150 K = N, 1, -1 +* Add a multiple of column K of the factor L to each of +* columns K+1 through N. +* + IF( K+1.LE.N ) + $ CALL DSYR( 'Lower', N-K, ONE, AFAC( K+1, K ), 1, + $ AFAC( K+1, K+1 ), LDAFAC ) +* +* Scale column K by the diagonal element. +* + T = AFAC( K, K ) + CALL DSCAL( N-K+1, T, AFAC( K, K ), 1 ) + 150 CONTINUE +* + END IF +* +* Form P*L*L'*P' or P*U'*U*P' +* + IF( LSAME( UPLO, 'U' ) ) THEN +* + DO 170 J = 1, N + DO 160 I = 1, N + IF( PIV( I ).LE.PIV( J ) ) THEN + IF( I.LE.J ) THEN + PERM( PIV( I ), PIV( J ) ) = AFAC( I, J ) + ELSE + PERM( PIV( I ), PIV( J ) ) = AFAC( J, I ) + END IF + END IF + 160 CONTINUE + 170 CONTINUE +* +* + ELSE +* + DO 190 J = 1, N + DO 180 I = 1, N + IF( PIV( I ).GE.PIV( J ) ) THEN + IF( I.GE.J ) THEN + PERM( PIV( I ), PIV( J ) ) = AFAC( I, J ) + ELSE + PERM( PIV( I ), PIV( J ) ) = AFAC( J, I ) + END IF + END IF + 180 CONTINUE + 190 CONTINUE +* + END IF +* +* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A). +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 210 J = 1, N + DO 200 I = 1, J + PERM( I, J ) = PERM( I, J ) - A( I, J ) + 200 CONTINUE + 210 CONTINUE + ELSE + DO 230 J = 1, N + DO 220 I = J, N + PERM( I, J ) = PERM( I, J ) - A( I, J ) + 220 CONTINUE + 230 CONTINUE + END IF +* +* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or +* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). +* + RESID = DLANSY( '1', UPLO, N, PERM, LDAFAC, RWORK ) +* + RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS +* + RETURN +* +* End of DPST01 +* + END diff --git a/TESTING/LIN/dqlt01.f b/TESTING/LIN/dqlt01.f index 253d70ef..de4fdb71 100644 --- a/TESTING/LIN/dqlt01.f +++ b/TESTING/LIN/dqlt01.f @@ -87,7 +87,7 @@ INTRINSIC DBLE, MAX, MIN * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/dqlt02.f b/TESTING/LIN/dqlt02.f index d76054de..af37dd7b 100644 --- a/TESTING/LIN/dqlt02.f +++ b/TESTING/LIN/dqlt02.f @@ -94,7 +94,7 @@ INTRINSIC DBLE, MAX * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/dqlt03.f b/TESTING/LIN/dqlt03.f index 8c8dd2d1..3c31ab46 100644 --- a/TESTING/LIN/dqlt03.f +++ b/TESTING/LIN/dqlt03.f @@ -99,7 +99,7 @@ INTRINSIC DBLE, MAX, MIN * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/dqrt01.f b/TESTING/LIN/dqrt01.f index 88f86f07..6c2b112f 100644 --- a/TESTING/LIN/dqrt01.f +++ b/TESTING/LIN/dqrt01.f @@ -87,7 +87,7 @@ INTRINSIC DBLE, MAX, MIN * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/dqrt02.f b/TESTING/LIN/dqrt02.f index 4253796f..e8ba4e20 100644 --- a/TESTING/LIN/dqrt02.f +++ b/TESTING/LIN/dqrt02.f @@ -93,7 +93,7 @@ INTRINSIC DBLE, MAX * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/dqrt03.f b/TESTING/LIN/dqrt03.f index 1ee186de..631a55d7 100644 --- a/TESTING/LIN/dqrt03.f +++ b/TESTING/LIN/dqrt03.f @@ -99,7 +99,7 @@ INTRINSIC DBLE, MAX * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/drqt01.f b/TESTING/LIN/drqt01.f index bb47e91e..5fef3e6e 100644 --- a/TESTING/LIN/drqt01.f +++ b/TESTING/LIN/drqt01.f @@ -87,7 +87,7 @@ INTRINSIC DBLE, MAX, MIN * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/drqt02.f b/TESTING/LIN/drqt02.f index 4074f39a..30d6f702 100644 --- a/TESTING/LIN/drqt02.f +++ b/TESTING/LIN/drqt02.f @@ -94,7 +94,7 @@ INTRINSIC DBLE, MAX * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/drqt03.f b/TESTING/LIN/drqt03.f index 4c611f5d..5effdc8a 100644 --- a/TESTING/LIN/drqt03.f +++ b/TESTING/LIN/drqt03.f @@ -99,7 +99,7 @@ INTRINSIC DBLE, MAX, MIN * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/schkaa.f b/TESTING/LIN/schkaa.f index b25439c9..1251afd7 100644 --- a/TESTING/LIN/schkaa.f +++ b/TESTING/LIN/schkaa.f @@ -26,6 +26,8 @@ * 5 Number of values of NB * 1 3 3 3 20 Values of NB (the blocksize) * 1 0 5 9 1 Values of NX (crossover point) +* 3 Number of values of RANK +* 30 50 90 Values of rank (as a % of N) * 20.0 Threshold value of test ratio * T Put T to test the LAPACK routines * T Put T to test the driver routines @@ -34,6 +36,7 @@ * SGB 8 List types on next line if 0 < NTYPES < 8 * SGT 12 List types on next line if 0 < NTYPES < 12 * SPO 9 List types on next line if 0 < NTYPES < 9 +* SPS 9 List types on next line if 0 < NTYPES < 9 * SPP 9 List types on next line if 0 < NTYPES < 9 * SPB 8 List types on next line if 0 < NTYPES < 8 * SPT 12 List types on next line if 0 < NTYPES < 12 @@ -94,7 +97,7 @@ CHARACTER*10 INTSTR CHARACTER*72 ALINE INTEGER I, IC, J, K, LA, LAFAC, LDA, NB, NM, NMATS, NN, - $ NNB, NNB2, NNS, NRHS, NTYPES, + $ NNB, NNB2, NNS, NRHS, NTYPES, NRANK, $ VERS_MAJOR, VERS_MINOR, VERS_PATCH REAL EPS, S1, S2, THREQ, THRESH * .. @@ -102,7 +105,8 @@ LOGICAL DOTYPE( MATMAX ) INTEGER IWORK( 25*NMAX ), MVAL( MAXIN ), $ NBVAL( MAXIN ), NBVAL2( MAXIN ), - $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ) + $ 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 ) @@ -114,15 +118,15 @@ * .. * .. External Subroutines .. EXTERNAL ALAREQ, SCHKEQ, SCHKGB, SCHKGE, SCHKGT, SCHKLQ, - $ SCHKPB, SCHKPO, SCHKPP, SCHKPT, SCHKQ3, SCHKQL, - $ SCHKQP, SCHKQR, SCHKRQ, SCHKSP, SCHKSY, SCHKTB, - $ SCHKTP, SCHKTR, SCHKTZ, SDRVGB, SDRVGE, SDRVGT, - $ SDRVLS, SDRVPB, SDRVPO, SDRVPP, SDRVPT, SDRVSP, - $ SDRVSY, ILAVER + $ SCHKPB, SCHKPO, SCHKPS, SCHKPP, SCHKPT, SCHKQ3, + $ SCHKQL, SCHKQP, SCHKQR, SCHKRQ, SCHKSP, SCHKSY, + $ SCHKTB, SCHKTP, SCHKTR, SCHKTZ, SDRVGB, SDRVGE, + $ SDRVGT, SDRVLS, SDRVPB, SDRVPO, SDRVPP, SDRVPT, + $ SDRVSP, SDRVSY, ILAVER * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Arrays in Common .. @@ -273,6 +277,32 @@ IF( NNB.GT.0 ) $ WRITE( NOUT, FMT = 9993 )'NX ', ( NXVAL( I ), I = 1, NNB ) * +* Read the values of RANKVAL +* + READ( NIN, FMT = * )NRANK + IF( NN.LT.1 ) THEN + WRITE( NOUT, FMT = 9996 )' NRANK ', NRANK, 1 + NRANK = 0 + FATAL = .TRUE. + ELSE IF( NN.GT.MAXIN ) THEN + WRITE( NOUT, FMT = 9995 )' NRANK ', NRANK, MAXIN + NRANK = 0 + FATAL = .TRUE. + END IF + READ( NIN, FMT = * )( RANKVAL( I ), I = 1, NRANK ) + DO I = 1, NRANK + IF( RANKVAL( I ).LT.0 ) THEN + WRITE( NOUT, FMT = 9996 )' RANK ', RANKVAL( I ), 0 + FATAL = .TRUE. + ELSE IF( RANKVAL( I ).GT.100 ) THEN + WRITE( NOUT, FMT = 9995 )' RANK ', RANKVAL( I ), 100 + FATAL = .TRUE. + END IF + END DO + IF( NRANK.GT.0 ) + $ WRITE( NOUT, FMT = 9993 )'RANK % OF N', + $ ( RANKVAL( I ), I = 1, NRANK ) +* * Read the threshold value for the test ratios. * READ( NIN, FMT = * )THRESH @@ -453,6 +483,23 @@ WRITE( NOUT, FMT = 9988 )PATH END IF * + ELSE IF( LSAMEN( 2, C2, 'PS' ) ) THEN +* +* PS: positive semi-definite matrices +* + NTYPES = 9 +* + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL SCHKPS( DOTYPE, NN, NVAL, NNB2, NBVAL2, NRANK, + $ RANKVAL, THRESH, TSTERR, LDA, A( 1, 1 ), + $ A( 1, 2 ), A( 1, 3 ), PIV, WORK, RWORK, + $ NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN * * PP: positive definite packed matrices diff --git a/TESTING/LIN/schkgb.f b/TESTING/LIN/schkgb.f index 6dba19e2..0a569927 100644 --- a/TESTING/LIN/schkgb.f +++ b/TESTING/LIN/schkgb.f @@ -140,7 +140,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/schkge.f b/TESTING/LIN/schkge.f index a7843001..1bcc218a 100644 --- a/TESTING/LIN/schkge.f +++ b/TESTING/LIN/schkge.f @@ -134,7 +134,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. @@ -406,7 +406,7 @@ CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, $ RESULT( 5 ) ) CALL SGET07( TRANS, N, NRHS, A, LDA, B, LDA, X, - $ LDA, XACT, LDA, RWORK, + $ LDA, XACT, LDA, RWORK, .TRUE., $ RWORK( NRHS+1 ), RESULT( 6 ) ) * * Print information about the tests that did not diff --git a/TESTING/LIN/schkgt.f b/TESTING/LIN/schkgt.f index 228f9286..8e7a2f7d 100644 --- a/TESTING/LIN/schkgt.f +++ b/TESTING/LIN/schkgt.f @@ -112,7 +112,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/schklq.f b/TESTING/LIN/schklq.f index 86b77895..183a1560 100644 --- a/TESTING/LIN/schklq.f +++ b/TESTING/LIN/schklq.f @@ -135,7 +135,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/schkpb.f b/TESTING/LIN/schkpb.f index 189db4fb..9d821690 100644 --- a/TESTING/LIN/schkpb.f +++ b/TESTING/LIN/schkpb.f @@ -124,7 +124,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/schkpo.f b/TESTING/LIN/schkpo.f index df247cb4..f085933b 100644 --- a/TESTING/LIN/schkpo.f +++ b/TESTING/LIN/schkpo.f @@ -121,7 +121,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/schkpp.f b/TESTING/LIN/schkpp.f index 2e29a35e..703b9993 100644 --- a/TESTING/LIN/schkpp.f +++ b/TESTING/LIN/schkpp.f @@ -118,7 +118,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/schkps.f b/TESTING/LIN/schkps.f new file mode 100644 index 00000000..d2def63d --- /dev/null +++ b/TESTING/LIN/schkps.f @@ -0,0 +1,268 @@ + SUBROUTINE SCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK, + $ RWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + REAL THRESH + INTEGER NMAX, NN, NNB, NOUT, NRANK + LOGICAL TSTERR +* .. +* .. Array Arguments .. + REAL A( * ), AFAC( * ), PERM( * ), RWORK( * ), + $ WORK( * ) + INTEGER NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * ) + LOGICAL DOTYPE( * ) +* .. +* +* Purpose +* ======= +* +* SCHKPS tests SPSTRF. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* NNB (input) INTEGER +* The number of values of NB contained in the vector NBVAL. +* +* NBVAL (input) INTEGER array, dimension (NBVAL) +* The values of the block size NB. +* +* NRANK (input) INTEGER +* The number of values of RANK contained in the vector RANKVAL. +* +* RANKVAL (input) INTEGER array, dimension (NBVAL) +* The values of the block size NB. +* +* THRESH (input) 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. +* +* TSTERR (input) LOGICAL +* Flag that indicates whether error exits are to be tested. +* +* NMAX (input) INTEGER +* The maximum value permitted for N, used in dimensioning the +* work arrays. +* +* A (workspace) REAL array, dimension (NMAX*NMAX) +* +* AFAC (workspace) REAL array, dimension (NMAX*NMAX) +* +* PERM (workspace) REAL array, dimension (NMAX*NMAX) +* +* PIV (workspace) INTEGER array, dimension (NMAX) +* +* WORK (workspace) REAL array, dimension (NMAX*3) +* +* RWORK (workspace) REAL array, dimension (NMAX) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 9 ) +* .. +* .. Local Scalars .. + REAL ANORM, CNDNUM, RESULT, TOL + INTEGER COMPRANK, I, IMAT, IN, INB, INFO, IRANK, IUPLO, + $ IZERO, KL, KU, LDA, MODE, N, NB, NERRS, NFAIL, + $ NIMAT, NRUN, RANK, RANKDIFF + CHARACTER DIST, TYPE, UPLO + CHARACTER*3 PATH +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ), ISEEDY( 4 ) + CHARACTER UPLOS( 2 ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, SERRPS, SLACPY, SLATB5, + $ SLATMT, SPST01, SPSTRF, XLAENV +* .. +* .. Scalars in Common .. + INTEGER INFOT, NUNIT + LOGICAL LERR, OK + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, REAL, CEILING +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Single Precision' + PATH( 2: 3 ) = 'PS' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 100 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 100 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL SERRPS( PATH, NOUT ) + INFOT = 0 + CALL XLAENV( 2, 2 ) +* +* Do for each value of N in NVAL +* + DO 150 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 + DO 140 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 140 +* +* Do for each value of RANK in RANKVAL +* + DO 130 IRANK = 1, NRANK +* +* Only repeat test 3 to 5 for different ranks +* Other tests use full rank +* + IF( ( IMAT.LT.3 .OR. IMAT.GT.5 ) .AND. IRANK.GT.1 ) + $ GO TO 130 +* + RANK = CEILING( ( N * REAL( RANKVAL( IRANK ) ) ) + $ / 100.E+0 ) +* +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 120 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with SLATB5 and generate a test matrix +* with SLATMT. +* + CALL SLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'SLATMT' + CALL SLATMT( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, RANK, KL, KU, UPLO, A, + $ LDA, WORK, INFO ) +* +* Check error code from SLATMT. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMT', INFO, 0, UPLO, N, + $ N, -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + GO TO 120 + END IF +* +* Do for each value of NB in NBVAL +* + DO 110 INB = 1, NNB + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Compute the pivoted L*L' or U'*U factorization +* of the matrix. +* + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + SRNAMT = 'SPSTRF' +* +* Use default tolerance +* + TOL = -ONE + CALL SPSTRF( UPLO, N, AFAC, LDA, PIV, COMPRANK, + $ TOL, WORK, INFO ) +* +* Check error code from SPSTRF. +* + IF( (INFO.LT.IZERO) + $ .OR.(INFO.NE.IZERO.AND.RANK.EQ.N) + $ .OR.(INFO.LE.IZERO.AND.RANK.LT.N) ) THEN + CALL ALAERH( PATH, 'SPSTRF', INFO, IZERO, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) + GO TO 110 + END IF +* +* Skip the test if INFO is not 0. +* + IF( INFO.NE.0 ) + $ GO TO 110 +* +* Reconstruct matrix from factors and compute residual. +* +* PERM holds permuted L*L^T or U^T*U +* + CALL SPST01( UPLO, N, A, LDA, AFAC, LDA, PERM, LDA, + $ PIV, RWORK, RESULT, COMPRANK ) +* +* Print information about the tests that did not pass +* the threshold or where computed rank was not RANK. +* + IF( N.EQ.0 ) + $ COMPRANK = 0 + RANKDIFF = RANK - COMPRANK + IF( RESULT.GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, RANK, + $ RANKDIFF, NB, IMAT, RESULT + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 110 CONTINUE +* + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', RANK =', I3, + $ ', Diff =', I5, ', NB =', I4, ', type ', I2, ', Ratio =', + $ G12.5 ) + RETURN +* +* End of SCHKPS +* + END diff --git a/TESTING/LIN/schkpt.f b/TESTING/LIN/schkpt.f index 9c7c647d..952c65ba 100644 --- a/TESTING/LIN/schkpt.f +++ b/TESTING/LIN/schkpt.f @@ -111,7 +111,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/schkq3.f b/TESTING/LIN/schkq3.f index cd094749..e32861d7 100644 --- a/TESTING/LIN/schkq3.f +++ b/TESTING/LIN/schkq3.f @@ -115,7 +115,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/schkql.f b/TESTING/LIN/schkql.f index 43dc12ee..9683eef3 100644 --- a/TESTING/LIN/schkql.f +++ b/TESTING/LIN/schkql.f @@ -135,7 +135,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/schkqp.f b/TESTING/LIN/schkqp.f index ae479b6c..4c27e013 100644 --- a/TESTING/LIN/schkqp.f +++ b/TESTING/LIN/schkqp.f @@ -106,7 +106,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/schkqr.f b/TESTING/LIN/schkqr.f index 0753dbad..cb40a134 100644 --- a/TESTING/LIN/schkqr.f +++ b/TESTING/LIN/schkqr.f @@ -135,7 +135,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/schkrfp.f b/TESTING/LIN/schkrfp.f new file mode 100644 index 00000000..6998d2b9 --- /dev/null +++ b/TESTING/LIN/schkrfp.f @@ -0,0 +1,262 @@ + PROGRAM SCHKRFP +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* Purpose +* ======= +* +* SCHKRFP is the main test program for the REAL linear +* equation routines with RFP storage format +* +* +* Internal Parameters +* =================== +* +* MAXIN INTEGER +* The number of different values that can be used for each of +* M, N, or NB +* +* MAXRHS INTEGER +* The maximum number of right hand sides +* +* NTYPES INTEGER +* +* NMAX INTEGER +* The maximum allowable value for N. +* +* NIN INTEGER +* The unit number for input +* +* NOUT INTEGER +* The unit number for output +* +* ===================================================================== +* +* .. Parameters .. + INTEGER MAXIN + PARAMETER ( MAXIN = 12 ) + INTEGER NMAX + PARAMETER ( NMAX = 50 ) + INTEGER MAXRHS + PARAMETER ( MAXRHS = 16 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 9 ) + INTEGER NIN, NOUT + PARAMETER ( NIN = 5, NOUT = 6 ) +* .. +* .. Local Scalars .. + LOGICAL FATAL, TSTERR + INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH + INTEGER I, NN, NNS, NNT + REAL EPS, S1, S2, THRESH +* .. +* .. Local Arrays .. + INTEGER NVAL( MAXIN ), NSVAL( MAXIN ), NTVAL( NTYPES ) + REAL WORKA( NMAX, NMAX ) + REAL WORKASAV( NMAX, NMAX ) + REAL WORKB( NMAX, MAXRHS ) + REAL WORKXACT( NMAX, MAXRHS ) + REAL WORKBSAV( NMAX, MAXRHS ) + REAL WORKX( NMAX, MAXRHS ) + REAL WORKAFAC( NMAX, NMAX ) + REAL WORKAINV( NMAX, NMAX ) + REAL WORKARF( (NMAX*(NMAX+1))/2 ) + REAL WORKAP( (NMAX*(NMAX+1))/2 ) + REAL WORKARFINV( (NMAX*(NMAX+1))/2 ) + REAL S_WORK_SLATMS( 3 * NMAX ) + REAL S_WORK_SPOT01( NMAX ) + REAL S_TEMP_SPOT02( NMAX, MAXRHS ) + REAL S_TEMP_SPOT03( NMAX, NMAX ) + REAL S_WORK_SLANSY( NMAX ) + REAL S_WORK_SPOT02( NMAX ) + REAL S_WORK_SPOT03( NMAX ) +* .. +* .. External Functions .. + REAL SLAMCH, SECOND + EXTERNAL SLAMCH, SECOND +* .. +* .. External Subroutines .. + EXTERNAL ILAVER, SDRVRFP, SDRVRF1, SDRVRF2, SDRVRF3, + + SDRVRF4 +* .. +* .. Executable Statements .. +* + S1 = SECOND( ) + FATAL = .FALSE. +* +* Read a dummy line. +* + READ( NIN, FMT = * ) +* +* Report LAPACK version tag (e.g. LAPACK-3.2.0) +* + CALL ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) + WRITE( NOUT, FMT = 9994 ) VERS_MAJOR, VERS_MINOR, VERS_PATCH +* +* Read the values of N +* + READ( NIN, FMT = * )NN + IF( NN.LT.1 ) THEN + WRITE( NOUT, FMT = 9996 )' NN ', NN, 1 + NN = 0 + FATAL = .TRUE. + ELSE IF( NN.GT.MAXIN ) THEN + WRITE( NOUT, FMT = 9995 )' NN ', NN, MAXIN + NN = 0 + FATAL = .TRUE. + END IF + READ( NIN, FMT = * )( NVAL( I ), I = 1, NN ) + DO 10 I = 1, NN + IF( NVAL( I ).LT.0 ) THEN + WRITE( NOUT, FMT = 9996 )' M ', NVAL( I ), 0 + FATAL = .TRUE. + ELSE IF( NVAL( I ).GT.NMAX ) THEN + WRITE( NOUT, FMT = 9995 )' M ', NVAL( I ), NMAX + FATAL = .TRUE. + END IF + 10 CONTINUE + IF( NN.GT.0 ) + $ WRITE( NOUT, FMT = 9993 )'N ', ( NVAL( I ), I = 1, NN ) +* +* Read the values of NRHS +* + READ( NIN, FMT = * )NNS + IF( NNS.LT.1 ) THEN + WRITE( NOUT, FMT = 9996 )' NNS', NNS, 1 + NNS = 0 + FATAL = .TRUE. + ELSE IF( NNS.GT.MAXIN ) THEN + WRITE( NOUT, FMT = 9995 )' NNS', NNS, MAXIN + NNS = 0 + FATAL = .TRUE. + END IF + READ( NIN, FMT = * )( NSVAL( I ), I = 1, NNS ) + DO 30 I = 1, NNS + IF( NSVAL( I ).LT.0 ) THEN + WRITE( NOUT, FMT = 9996 )'NRHS', NSVAL( I ), 0 + FATAL = .TRUE. + ELSE IF( NSVAL( I ).GT.MAXRHS ) THEN + WRITE( NOUT, FMT = 9995 )'NRHS', NSVAL( I ), MAXRHS + FATAL = .TRUE. + END IF + 30 CONTINUE + IF( NNS.GT.0 ) + $ WRITE( NOUT, FMT = 9993 )'NRHS', ( NSVAL( I ), I = 1, NNS ) +* +* Read the matrix types +* + READ( NIN, FMT = * )NNT + IF( NNT.LT.1 ) THEN + WRITE( NOUT, FMT = 9996 )' NMA', NNT, 1 + NNT = 0 + FATAL = .TRUE. + ELSE IF( NNT.GT.NTYPES ) THEN + WRITE( NOUT, FMT = 9995 )' NMA', NNT, NTYPES + NNT = 0 + FATAL = .TRUE. + END IF + READ( NIN, FMT = * )( NTVAL( I ), I = 1, NNT ) + DO 320 I = 1, NNT + IF( NTVAL( I ).LT.0 ) THEN + WRITE( NOUT, FMT = 9996 )'TYPE', NTVAL( I ), 0 + FATAL = .TRUE. + ELSE IF( NTVAL( I ).GT.NTYPES ) THEN + WRITE( NOUT, FMT = 9995 )'TYPE', NTVAL( I ), NTYPES + FATAL = .TRUE. + END IF + 320 CONTINUE + IF( NNT.GT.0 ) + $ WRITE( NOUT, FMT = 9993 )'TYPE', ( NTVAL( I ), I = 1, NNT ) +* +* Read the threshold value for the test ratios. +* + READ( NIN, FMT = * )THRESH + WRITE( NOUT, FMT = 9992 )THRESH +* +* Read the flag that indicates whether to test the error exits. +* + READ( NIN, FMT = * )TSTERR +* + IF( FATAL ) THEN + WRITE( NOUT, FMT = 9999 ) + STOP + END IF +* + IF( FATAL ) THEN + WRITE( NOUT, FMT = 9999 ) + STOP + END IF +* +* Calculate and print the machine dependent constants. +* + EPS = SLAMCH( 'Underflow threshold' ) + WRITE( NOUT, FMT = 9991 )'underflow', EPS + EPS = SLAMCH( 'Overflow threshold' ) + WRITE( NOUT, FMT = 9991 )'overflow ', EPS + EPS = SLAMCH( 'Epsilon' ) + WRITE( NOUT, FMT = 9991 )'precision', EPS + WRITE( NOUT, FMT = * ) +* +* Test the error exit of: +* + IF( TSTERR ) + $ CALL SERRRFP( NOUT ) +* +* Test the routines: spftrf, spftri, spftrs (as in SDRVPO). +* This also tests the routines: stfsm, stftri, stfttr, strttf. +* + CALL SDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, THRESH, + $ WORKA, WORKASAV, WORKAFAC, WORKAINV, WORKB, + $ WORKBSAV, WORKXACT, WORKX, WORKARF, WORKARFINV, + $ S_WORK_SLATMS, S_WORK_SPOT01, S_TEMP_SPOT02, + $ S_TEMP_SPOT03, S_WORK_SLANSY, S_WORK_SPOT02, + $ S_WORK_SPOT03 ) +* +* Test the routine: slansf +* + CALL SDRVRF1( NOUT, NN, NVAL, THRESH, WORKA, NMAX, WORKARF, + + S_WORK_SLANSY ) +* +* Test the convertion routines: +* stfttp, stpttf, stfttr, strttf, strttp and stpttr. +* + CALL SDRVRF2( NOUT, NN, NVAL, WORKA, NMAX, WORKARF, + + WORKAP, WORKASAV ) +* +* Test the routine: stfsm +* + CALL SDRVRF3( NOUT, NN, NVAL, THRESH, WORKA, NMAX, WORKARF, + + WORKAINV, WORKAFAC, S_WORK_SLANSY, + + S_WORK_SPOT03, S_WORK_SPOT01 ) +* +* +* Test the routine: ssfrk +* + CALL SDRVRF4( NOUT, NN, NVAL, THRESH, WORKA, WORKAFAC, NMAX, + + WORKARF, WORKAINV, NMAX, S_WORK_SLANSY) +* + CLOSE ( NIN ) + S2 = SECOND( ) + WRITE( NOUT, FMT = 9998 ) + WRITE( NOUT, FMT = 9997 )S2 - S1 +* + 9999 FORMAT( / ' Execution not attempted due to input errors' ) + 9998 FORMAT( / ' End of tests' ) + 9997 FORMAT( ' Total time used = ', F12.2, ' seconds', / ) + 9996 FORMAT( ' !! Invalid input value: ', A4, '=', I6, '; must be >=', + $ I6 ) + 9995 FORMAT( ' !! Invalid input value: ', A4, '=', I6, '; must be <=', + $ I6 ) + 9994 FORMAT( / ' Tests of the REAL LAPACK RFP routines ', + $ / ' LAPACK VERSION ', I1, '.', I1, '.', I1, + $ / / ' The following parameter values will be used:' ) + 9993 FORMAT( 4X, A4, ': ', 10I6, / 11X, 10I6 ) + 9992 FORMAT( / ' Routines pass computational tests if test ratio is ', + $ 'less than', F8.2, / ) + 9991 FORMAT( ' Relative machine ', A, ' is taken to be', D16.6 ) +* +* End of SCHKRFP +* + END diff --git a/TESTING/LIN/schkrq.f b/TESTING/LIN/schkrq.f index 42a6407e..c9963402 100644 --- a/TESTING/LIN/schkrq.f +++ b/TESTING/LIN/schkrq.f @@ -135,7 +135,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/schksp.f b/TESTING/LIN/schksp.f index bc9b9251..47874f34 100644 --- a/TESTING/LIN/schksp.f +++ b/TESTING/LIN/schksp.f @@ -122,7 +122,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/schksy.f b/TESTING/LIN/schksy.f index dcc5480c..2065292a 100644 --- a/TESTING/LIN/schksy.f +++ b/TESTING/LIN/schksy.f @@ -124,7 +124,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/schktb.f b/TESTING/LIN/schktb.f index 93bc3a8d..fe0c83c7 100644 --- a/TESTING/LIN/schktb.f +++ b/TESTING/LIN/schktb.f @@ -116,7 +116,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/schktp.f b/TESTING/LIN/schktp.f index cfc54f5a..3bd4597b 100644 --- a/TESTING/LIN/schktp.f +++ b/TESTING/LIN/schktp.f @@ -117,7 +117,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/schktr.f b/TESTING/LIN/schktr.f index 62ca2123..5154a8c8 100644 --- a/TESTING/LIN/schktr.f +++ b/TESTING/LIN/schktr.f @@ -121,7 +121,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/schktz.f b/TESTING/LIN/schktz.f index 08783116..12837154 100644 --- a/TESTING/LIN/schktz.f +++ b/TESTING/LIN/schktz.f @@ -103,7 +103,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/sdrvgb.f b/TESTING/LIN/sdrvgb.f index df8d1394..785df694 100644 --- a/TESTING/LIN/sdrvgb.f +++ b/TESTING/LIN/sdrvgb.f @@ -130,7 +130,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/sdrvgbx.f b/TESTING/LIN/sdrvgbx.f new file mode 100644 index 00000000..43c0d2fd --- /dev/null +++ b/TESTING/LIN/sdrvgbx.f @@ -0,0 +1,930 @@ + SUBROUTINE SDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, + $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER LA, LAFB, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ), + $ RWORK( * ), S( * ), WORK( * ), X( * ), + $ XACT( * ) +* .. +* +* Purpose +* ======= +* +* SDRVGB tests the driver routines SGBSV and -SVX. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix column dimension N. +* +* NRHS (input) INTEGER +* The number of right hand side vectors to be generated for +* each linear system. +* +* THRESH (input) 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. +* +* TSTERR (input) LOGICAL +* Flag that indicates whether error exits are to be tested. +* +* A (workspace) REAL array, dimension (LA) +* +* LA (input) INTEGER +* The length of the array A. LA >= (2*NMAX-1)*NMAX +* where NMAX is the largest entry in NVAL. +* +* AFB (workspace) REAL array, dimension (LAFB) +* +* LAFB (input) INTEGER +* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX +* where NMAX is the largest entry in NVAL. +* +* ASAV (workspace) REAL array, dimension (LA) +* +* B (workspace) REAL array, dimension (NMAX*NRHS) +* +* BSAV (workspace) REAL array, dimension (NMAX*NRHS) +* +* X (workspace) REAL array, dimension (NMAX*NRHS) +* +* XACT (workspace) REAL array, dimension (NMAX*NRHS) +* +* S (workspace) REAL array, dimension (2*NMAX) +* +* WORK (workspace) REAL array, dimension +* (NMAX*max(3,NRHS,NMAX)) +* +* RWORK (workspace) REAL array, dimension +* (max(NMAX,2*NRHS)) +* +* IWORK (workspace) INTEGER array, dimension (2*NMAX) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 8 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) + INTEGER NTRAN + PARAMETER ( NTRAN = 3 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT + CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE + CHARACTER*3 PATH + INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN, + $ INFO, IOFF, ITRAN, IZERO, J, K, K1, KL, KU, + $ LDA, LDAFB, LDB, MODE, N, NB, NBMIN, NERRS, + $ NFACT, NFAIL, NIMAT, NKL, NKU, NRUN, NT, + $ N_ERR_BNDS + REAL AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV, + $ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO, + $ ROLDC, ROLDI, ROLDO, ROWCND, RPVGRW, + $ RPVGRW_SVXX +* .. +* .. Local Arrays .. + CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ), BERR( NRHS ), + $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SGET06, SLAMCH, SLANGB, SLANGE, SLANTB, + $ SLA_GBRPVGRW + EXTERNAL LSAME, SGET06, SLAMCH, SLANGB, SLANGE, SLANTB, + $ SLA_GBRPVGRW +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGBEQU, SGBSV, + $ SGBSVX, SGBT01, SGBT02, SGBT05, SGBTRF, SGBTRS, + $ SGET04, SLACPY, SLAQGB, SLARHS, SLASET, SLATB4, + $ SLATMS, XLAENV, SGBSVXX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN +* .. +* .. 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 TRANSS / 'N', 'T', 'C' / + DATA FACTS / 'F', 'N', 'E' / + DATA EQUEDS / 'N', 'R', 'C', 'B' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'GB' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL SERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 150 IN = 1, NN + N = NVAL( IN ) + LDB = MAX( N, 1 ) + XTYPE = 'N' +* +* Set limits on the number of loop iterations. +* + NKL = MAX( 1, MIN( N, 4 ) ) + IF( N.EQ.0 ) + $ NKL = 1 + NKU = NKL + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 140 IKL = 1, NKL +* +* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes +* it easier to skip redundant values for small values of N. +* + IF( IKL.EQ.1 ) THEN + KL = 0 + ELSE IF( IKL.EQ.2 ) THEN + KL = MAX( N-1, 0 ) + ELSE IF( IKL.EQ.3 ) THEN + KL = ( 3*N-1 ) / 4 + ELSE IF( IKL.EQ.4 ) THEN + KL = ( N+1 ) / 4 + END IF + DO 130 IKU = 1, NKU +* +* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order +* makes it easier to skip redundant values for small +* values of N. +* + IF( IKU.EQ.1 ) THEN + KU = 0 + ELSE IF( IKU.EQ.2 ) THEN + KU = MAX( N-1, 0 ) + ELSE IF( IKU.EQ.3 ) THEN + KU = ( 3*N-1 ) / 4 + ELSE IF( IKU.EQ.4 ) THEN + KU = ( N+1 ) / 4 + END IF +* +* Check that A and AFB are big enough to generate this +* matrix. +* + LDA = KL + KU + 1 + LDAFB = 2*KL + KU + 1 + IF( LDA*N.GT.LA .OR. LDAFB*N.GT.LAFB ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( LDA*N.GT.LA ) THEN + WRITE( NOUT, FMT = 9999 )LA, N, KL, KU, + $ N*( KL+KU+1 ) + NERRS = NERRS + 1 + END IF + IF( LDAFB*N.GT.LAFB ) THEN + WRITE( NOUT, FMT = 9998 )LAFB, N, KL, KU, + $ N*( 2*KL+KU+1 ) + NERRS = NERRS + 1 + END IF + GO TO 130 + END IF +* + DO 120 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 120 +* +* Skip types 2, 3, or 4 if the matrix is too small. +* + ZEROT = IMAT.GE.2 .AND. IMAT.LE.4 + IF( ZEROT .AND. N.LT.IMAT-1 ) + $ GO TO 120 +* +* Set up parameters with SLATB4 and generate a +* test matrix with SLATMS. +* + CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) + RCONDC = ONE / CNDNUM +* + SRNAMT = 'SLATMS' + CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, 'Z', A, LDA, WORK, + $ INFO ) +* +* Check the error code from SLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', N, N, + $ KL, KU, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 120 + END IF +* +* For types 2, 3, and 4, zero one or more columns of +* the matrix to test that INFO is returned correctly. +* + IZERO = 0 + IF( ZEROT ) THEN + IF( IMAT.EQ.2 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.3 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF + IOFF = ( IZERO-1 )*LDA + IF( IMAT.LT.4 ) THEN + I1 = MAX( 1, KU+2-IZERO ) + I2 = MIN( KL+KU+1, KU+1+( N-IZERO ) ) + DO 20 I = I1, I2 + A( IOFF+I ) = ZERO + 20 CONTINUE + ELSE + DO 40 J = IZERO, N + DO 30 I = MAX( 1, KU+2-J ), + $ MIN( KL+KU+1, KU+1+( N-J ) ) + A( IOFF+I ) = ZERO + 30 CONTINUE + IOFF = IOFF + LDA + 40 CONTINUE + END IF + END IF +* +* Save a copy of the matrix A in ASAV. +* + CALL SLACPY( 'Full', KL+KU+1, N, A, LDA, ASAV, LDA ) +* + DO 110 IEQUED = 1, 4 + EQUED = EQUEDS( IEQUED ) + IF( IEQUED.EQ.1 ) THEN + NFACT = 3 + ELSE + NFACT = 1 + END IF +* + DO 100 IFACT = 1, NFACT + FACT = FACTS( IFACT ) + PREFAC = LSAME( FACT, 'F' ) + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) +* + IF( ZEROT ) THEN + IF( PREFAC ) + $ GO TO 100 + RCONDO = ZERO + RCONDI = ZERO +* + ELSE IF( .NOT.NOFACT ) THEN +* +* Compute the condition number for comparison +* with the value returned by SGESVX (FACT = +* 'N' reuses the condition number from the +* previous iteration with FACT = 'F'). +* + CALL SLACPY( 'Full', KL+KU+1, N, ASAV, LDA, + $ AFB( KL+1 ), LDAFB ) + IF( EQUIL .OR. IEQUED.GT.1 ) THEN +* +* Compute row and column scale factors to +* equilibrate the matrix A. +* + CALL SGBEQU( N, N, KL, KU, AFB( KL+1 ), + $ LDAFB, S, S( N+1 ), ROWCND, + $ COLCND, AMAX, INFO ) + IF( INFO.EQ.0 .AND. N.GT.0 ) THEN + IF( LSAME( EQUED, 'R' ) ) THEN + ROWCND = ZERO + COLCND = ONE + ELSE IF( LSAME( EQUED, 'C' ) ) THEN + ROWCND = ONE + COLCND = ZERO + ELSE IF( LSAME( EQUED, 'B' ) ) THEN + ROWCND = ZERO + COLCND = ZERO + END IF +* +* Equilibrate the matrix. +* + CALL SLAQGB( N, N, KL, KU, AFB( KL+1 ), + $ LDAFB, S, S( N+1 ), + $ ROWCND, COLCND, AMAX, + $ EQUED ) + END IF + END IF +* +* Save the condition number of the +* non-equilibrated system for use in SGET04. +* + IF( EQUIL ) THEN + ROLDO = RCONDO + ROLDI = RCONDI + END IF +* +* Compute the 1-norm and infinity-norm of A. +* + ANORMO = SLANGB( '1', N, KL, KU, AFB( KL+1 ), + $ LDAFB, RWORK ) + ANORMI = SLANGB( 'I', N, KL, KU, AFB( KL+1 ), + $ LDAFB, RWORK ) +* +* Factor the matrix A. +* + CALL SGBTRF( N, N, KL, KU, AFB, LDAFB, IWORK, + $ INFO ) +* +* Form the inverse of A. +* + CALL SLASET( 'Full', N, N, ZERO, ONE, WORK, + $ LDB ) + SRNAMT = 'SGBTRS' + CALL SGBTRS( 'No transpose', N, KL, KU, N, + $ AFB, LDAFB, IWORK, WORK, LDB, + $ INFO ) +* +* Compute the 1-norm condition number of A. +* + AINVNM = SLANGE( '1', N, N, WORK, LDB, + $ RWORK ) + IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDO = ONE + ELSE + RCONDO = ( ONE / ANORMO ) / AINVNM + END IF +* +* Compute the infinity-norm condition number +* of A. +* + AINVNM = SLANGE( 'I', N, N, WORK, LDB, + $ RWORK ) + IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDI = ONE + ELSE + RCONDI = ( ONE / ANORMI ) / AINVNM + END IF + END IF +* + DO 90 ITRAN = 1, NTRAN +* +* Do for each value of TRANS. +* + TRANS = TRANSS( ITRAN ) + IF( ITRAN.EQ.1 ) THEN + RCONDC = RCONDO + ELSE + RCONDC = RCONDI + END IF +* +* Restore the matrix A. +* + CALL SLACPY( 'Full', KL+KU+1, N, ASAV, LDA, + $ A, LDA ) +* +* Form an exact solution and set the right hand +* side. +* + SRNAMT = 'SLARHS' + CALL SLARHS( PATH, XTYPE, 'Full', TRANS, N, + $ N, KL, KU, NRHS, A, LDA, XACT, + $ LDB, B, LDB, ISEED, INFO ) + XTYPE = 'C' + CALL SLACPY( 'Full', N, NRHS, B, LDB, BSAV, + $ LDB ) +* + IF( NOFACT .AND. ITRAN.EQ.1 ) THEN +* +* --- Test SGBSV --- +* +* Compute the LU factorization of the matrix +* and solve the system. +* + CALL SLACPY( 'Full', KL+KU+1, N, A, LDA, + $ AFB( KL+1 ), LDAFB ) + CALL SLACPY( 'Full', N, NRHS, B, LDB, X, + $ LDB ) +* + SRNAMT = 'SGBSV ' + CALL SGBSV( N, KL, KU, NRHS, AFB, LDAFB, + $ IWORK, X, LDB, INFO ) +* +* Check error code from SGBSV . +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'SGBSV ', INFO, + $ IZERO, ' ', N, N, KL, KU, + $ NRHS, IMAT, NFAIL, NERRS, + $ NOUT ) + GOTO 90 + END IF +* +* Reconstruct matrix from factors and +* compute residual. +* + CALL SGBT01( N, N, KL, KU, A, LDA, AFB, + $ LDAFB, IWORK, WORK, + $ RESULT( 1 ) ) + NT = 1 + IF( IZERO.EQ.0 ) THEN +* +* Compute residual of the computed +* solution. +* + CALL SLACPY( 'Full', N, NRHS, B, LDB, + $ WORK, LDB ) + CALL SGBT02( 'No transpose', N, N, KL, + $ KU, NRHS, A, LDA, X, LDB, + $ WORK, LDB, RESULT( 2 ) ) +* +* Check solution from generated exact +* solution. +* + CALL SGET04( N, NRHS, X, LDB, XACT, + $ LDB, RCONDC, RESULT( 3 ) ) + NT = 3 + END IF +* +* Print information about the tests that did +* not pass the threshold. +* + DO 50 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )'SGBSV ', + $ N, KL, KU, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 50 CONTINUE + NRUN = NRUN + NT + END IF +* +* --- Test SGBSVX --- +* + IF( .NOT.PREFAC ) + $ CALL SLASET( 'Full', 2*KL+KU+1, N, ZERO, + $ ZERO, AFB, LDAFB ) + CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, + $ LDB ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT = 'F' and +* EQUED = 'R', 'C', or 'B'. +* + CALL SLAQGB( N, N, KL, KU, A, LDA, S, + $ S( N+1 ), ROWCND, COLCND, + $ AMAX, EQUED ) + END IF +* +* Solve the system and compute the condition +* number and error bounds using SGBSVX. +* + SRNAMT = 'SGBSVX' + CALL SGBSVX( FACT, TRANS, N, KL, KU, NRHS, A, + $ LDA, AFB, LDAFB, IWORK, EQUED, + $ S, S( N+1 ), B, LDB, X, LDB, + $ RCOND, RWORK, RWORK( NRHS+1 ), + $ WORK, IWORK( N+1 ), INFO ) +* +* Check the error code from SGBSVX. +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'SGBSVX', INFO, IZERO, + $ FACT // TRANS, N, N, KL, KU, + $ NRHS, IMAT, NFAIL, NERRS, + $ NOUT ) + GOTO 90 + END IF +* +* Compare WORK(1) from SGBSVX with the computed +* reciprocal pivot growth factor RPVGRW +* + IF( INFO.NE.0 ) THEN + ANRMPV = ZERO + DO 70 J = 1, INFO + DO 60 I = MAX( KU+2-J, 1 ), + $ MIN( N+KU+1-J, KL+KU+1 ) + ANRMPV = MAX( ANRMPV, + $ ABS( A( I+( J-1 )*LDA ) ) ) + 60 CONTINUE + 70 CONTINUE + RPVGRW = SLANTB( 'M', 'U', 'N', INFO, + $ MIN( INFO-1, KL+KU ), + $ AFB( MAX( 1, KL+KU+2-INFO ) ), + $ LDAFB, WORK ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = ANRMPV / RPVGRW + END IF + ELSE + RPVGRW = SLANTB( 'M', 'U', 'N', N, KL+KU, + $ AFB, LDAFB, WORK ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = SLANGB( 'M', N, KL, KU, A, + $ LDA, WORK ) / RPVGRW + END IF + END IF + RESULT( 7 ) = ABS( RPVGRW-WORK( 1 ) ) / + $ MAX( WORK( 1 ), RPVGRW ) / + $ SLAMCH( 'E' ) +* + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and +* compute residual. +* + CALL SGBT01( N, N, KL, KU, A, LDA, AFB, + $ LDAFB, IWORK, WORK, + $ RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* + IF( INFO.EQ.0 ) THEN + TRFCON = .FALSE. +* +* Compute residual of the computed solution. +* + CALL SLACPY( 'Full', N, NRHS, BSAV, LDB, + $ WORK, LDB ) + CALL SGBT02( TRANS, N, N, KL, KU, NRHS, + $ ASAV, LDA, X, LDB, WORK, LDB, + $ RESULT( 2 ) ) +* +* Check solution from generated exact +* solution. +* + IF( NOFACT .OR. ( PREFAC .AND. + $ LSAME( EQUED, 'N' ) ) ) THEN + CALL SGET04( N, NRHS, X, LDB, XACT, + $ LDB, RCONDC, RESULT( 3 ) ) + ELSE + IF( ITRAN.EQ.1 ) THEN + ROLDC = ROLDO + ELSE + ROLDC = ROLDI + END IF + CALL SGET04( N, NRHS, X, LDB, XACT, + $ LDB, ROLDC, RESULT( 3 ) ) + END IF +* +* Check the error bounds from iterative +* refinement. +* + CALL SGBT05( TRANS, N, KL, KU, NRHS, ASAV, + $ LDA, B, LDB, X, LDB, XACT, + $ LDB, RWORK, RWORK( NRHS+1 ), + $ RESULT( 4 ) ) + ELSE + TRFCON = .TRUE. + END IF +* +* Compare RCOND from SGBSVX with the computed +* value in RCONDC. +* + RESULT( 6 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did +* not pass the threshold. +* + IF( .NOT.TRFCON ) THEN + DO 80 K = K1, NTESTS + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9995 ) + $ 'SGBSVX', FACT, TRANS, N, KL, + $ KU, EQUED, IMAT, K, + $ RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9996 ) + $ 'SGBSVX', FACT, TRANS, N, KL, + $ KU, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 80 CONTINUE + NRUN = NRUN + 7 - K1 + ELSE + IF( RESULT( 1 ).GE.THRESH .AND. .NOT. + $ PREFAC ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9995 )'SGBSVX', + $ FACT, TRANS, N, KL, KU, EQUED, + $ IMAT, 1, RESULT( 1 ) + ELSE + WRITE( NOUT, FMT = 9996 )'SGBSVX', + $ FACT, TRANS, N, KL, KU, IMAT, 1, + $ RESULT( 1 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 6 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9995 )'SGBSVX', + $ FACT, TRANS, N, KL, KU, EQUED, + $ IMAT, 6, RESULT( 6 ) + ELSE + WRITE( NOUT, FMT = 9996 )'SGBSVX', + $ FACT, TRANS, N, KL, KU, IMAT, 6, + $ RESULT( 6 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9995 )'SGBSVX', + $ FACT, TRANS, N, KL, KU, EQUED, + $ IMAT, 7, RESULT( 7 ) + ELSE + WRITE( NOUT, FMT = 9996 )'SGBSVX', + $ FACT, TRANS, N, KL, KU, IMAT, 7, + $ RESULT( 7 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF +* + END IF +* +* --- Test SGBSVXX --- +* +* Restore the matrices A and B. +* + CALL SLACPY( 'Full', KL+KU+1, N, ASAV, LDA, A, + $ LDA ) + CALL SLACPY( 'Full', N, NRHS, BSAV, LDB, B, LDB ) + + IF( .NOT.PREFAC ) + $ CALL SLASET( 'Full', 2*KL+KU+1, N, ZERO, ZERO, + $ AFB, LDAFB ) + CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDB ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT = 'F' and +* EQUED = 'R', 'C', or 'B'. +* + CALL SLAQGB( N, N, KL, KU, A, LDA, S, + $ S( N+1 ), ROWCND, COLCND, AMAX, EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using SGBSVXX. +* + SRNAMT = 'SGBSVXX' + n_err_bnds = 3 + CALL SGBSVXX( FACT, TRANS, N, KL, KU, NRHS, A, LDA, + $ AFB, LDAFB, IWORK, EQUED, S, S( N+1 ), B, LDB, + $ X, LDB, rcond, rpvgrw_svxx, berr, n_err_bnds, + $ errbnds_n, errbnds_c, 0, ZERO, WORK, + $ IWORK( N+1 ), INFO ) + +* Check the error code from SGBSVXX. +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'SGBSVXX', INFO, IZERO, + $ FACT // TRANS, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GOTO 90 + END IF +* +* Compare rpvgrw_svxx from SGBSVXX with the computed +* reciprocal pivot growth factor RPVGRW +* + + IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN + RPVGRW = SLA_GBRPVGRW(N, KL, KU, INFO, A, LDA, + $ AFB, LDAFB ) + ELSE + RPVGRW = SLA_GBRPVGRW(N, KL, KU, N, A, LDA, + $ AFB, LDAFB ) + ENDIF + + RESULT( 7 ) = ABS( RPVGRW-rpvgrw_svxx ) / + $ MAX( rpvgrw_svxx, RPVGRW ) / + $ SLAMCH( 'E' ) +* + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL SGBT01( N, N, KL, KU, A, LDA, AFB, LDAFB, + $ IWORK, WORK, + $ RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* + IF( INFO.EQ.0 ) THEN + TRFCON = .FALSE. +* +* Compute residual of the computed solution. +* + CALL SLACPY( 'Full', N, NRHS, BSAV, LDB, WORK, + $ LDB ) + CALL SGBT02( TRANS, N, N, KL, KU, NRHS, ASAV, + $ LDA, X, LDB, WORK, LDB, + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL SGET04( N, NRHS, X, LDB, XACT, LDB, + $ RCONDC, RESULT( 3 ) ) + ELSE + IF( ITRAN.EQ.1 ) THEN + ROLDC = ROLDO + ELSE + ROLDC = ROLDI + END IF + CALL SGET04( N, NRHS, X, LDB, XACT, LDB, + $ ROLDC, RESULT( 3 ) ) + END IF + ELSE + TRFCON = .TRUE. + END IF +* +* Compare RCOND from SGBSVXX with the computed value +* in RCONDC. +* + RESULT( 6 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( .NOT.TRFCON ) THEN + DO 45 K = K1, NTESTS + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'SGBSVXX', + $ FACT, TRANS, N, KL, KU, EQUED, + $ IMAT, K, RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'SGBSVXX', + $ FACT, TRANS, N, KL, KU, IMAT, K, + $ RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 45 CONTINUE + NRUN = NRUN + 7 - K1 + ELSE + IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) + $ THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'SGBSVXX', FACT, + $ TRANS, N, KL, KU, EQUED, IMAT, 1, + $ RESULT( 1 ) + ELSE + WRITE( NOUT, FMT = 9998 )'SGBSVXX', FACT, + $ TRANS, N, KL, KU, IMAT, 1, + $ RESULT( 1 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 6 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'SGBSVXX', FACT, + $ TRANS, N, KL, KU, EQUED, IMAT, 6, + $ RESULT( 6 ) + ELSE + WRITE( NOUT, FMT = 9998 )'SGBSVXX', FACT, + $ TRANS, N, KL, KU, IMAT, 6, + $ RESULT( 6 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'SGBSVXX', FACT, + $ TRANS, N, KL, KU, EQUED, IMAT, 7, + $ RESULT( 7 ) + ELSE + WRITE( NOUT, FMT = 9998 )'SGBSVXX', FACT, + $ TRANS, N, KL, KU, IMAT, 7, + $ RESULT( 7 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + + END IF +* + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + +* Test Error Bounds from SGBSVXX + + CALL SEBCHVXX(THRESH, PATH) + + 9999 FORMAT( ' *** In SDRVGB, LA=', I5, ' is too small for N=', I5, + $ ', KU=', I5, ', KL=', I5, / ' ==> Increase LA to at least ', + $ I5 ) + 9998 FORMAT( ' *** In SDRVGB, LAFB=', I5, ' is too small for N=', I5, + $ ', KU=', I5, ', KL=', I5, / + $ ' ==> Increase LAFB to at least ', I5 ) + 9997 FORMAT( 1X, A, ', N=', I5, ', KL=', I5, ', KU=', I5, ', type ', + $ I1, ', test(', I1, ')=', G12.5 ) + 9996 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', + $ I5, ',...), type ', I1, ', test(', I1, ')=', G12.5 ) + 9995 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', + $ I5, ',...), EQUED=''', A1, ''', type ', I1, ', test(', I1, + $ ')=', G12.5 ) +* + RETURN +* +* End of SDRVGB +* + END diff --git a/TESTING/LIN/sdrvge.f b/TESTING/LIN/sdrvge.f index a22b2128..7f944621 100644 --- a/TESTING/LIN/sdrvge.f +++ b/TESTING/LIN/sdrvge.f @@ -124,7 +124,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. @@ -514,7 +514,7 @@ * refinement. * CALL SGET07( TRANS, N, NRHS, ASAV, LDA, B, LDA, - $ X, LDA, XACT, LDA, RWORK, + $ X, LDA, XACT, LDA, RWORK, .TRUE., $ RWORK( NRHS+1 ), RESULT( 4 ) ) ELSE TRFCON = .TRUE. diff --git a/TESTING/LIN/sdrvgex.f b/TESTING/LIN/sdrvgex.f new file mode 100644 index 00000000..a73387bf --- /dev/null +++ b/TESTING/LIN/sdrvgex.f @@ -0,0 +1,798 @@ + SUBROUTINE SDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, + $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL A( * ), AFAC( * ), ASAV( * ), B( * ), + $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), + $ X( * ), XACT( * ) +* .. +* +* Purpose +* ======= +* +* SDRVGE tests the driver routines SGESV, -SVX, and -SVXX. +* +* Note that this file is used only when the XBLAS are available, +* otherwise sdrvge.f defines this subroutine. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix column dimension N. +* +* NRHS (input) INTEGER +* The number of right hand side vectors to be generated for +* each linear system. +* +* THRESH (input) 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. +* +* TSTERR (input) LOGICAL +* Flag that indicates whether error exits are to be tested. +* +* NMAX (input) INTEGER +* The maximum value permitted for N, used in dimensioning the +* work arrays. +* +* A (workspace) REAL array, dimension (NMAX*NMAX) +* +* AFAC (workspace) REAL array, dimension (NMAX*NMAX) +* +* ASAV (workspace) REAL array, dimension (NMAX*NMAX) +* +* B (workspace) REAL array, dimension (NMAX*NRHS) +* +* BSAV (workspace) REAL array, dimension (NMAX*NRHS) +* +* X (workspace) REAL array, dimension (NMAX*NRHS) +* +* XACT (workspace) REAL array, dimension (NMAX*NRHS) +* +* S (workspace) REAL array, dimension (2*NMAX) +* +* WORK (workspace) REAL array, dimension +* (NMAX*max(3,NRHS)) +* +* RWORK (workspace) REAL array, dimension (2*NRHS+NMAX) +* +* IWORK (workspace) INTEGER array, dimension (2*NMAX) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 11 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) + INTEGER NTRAN + PARAMETER ( NTRAN = 3 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT + CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE + CHARACTER*3 PATH + INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, ITRAN, + $ IZERO, K, K1, KL, KU, LDA, LWORK, MODE, N, NB, + $ NBMIN, NERRS, NFACT, NFAIL, NIMAT, NRUN, NT, + $ N_ERR_BNDS + REAL AINVNM, AMAX, ANORM, ANORMI, ANORMO, CNDNUM, + $ COLCND, RCOND, RCONDC, RCONDI, RCONDO, ROLDC, + $ ROLDI, ROLDO, ROWCND, RPVGRW, RPVGRW_SVXX +* .. +* .. Local Arrays .. + CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ), BERR( NRHS ), + $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SGET06, SLAMCH, SLANGE, SLANTR, SLA_RPVGRW + EXTERNAL LSAME, SGET06, SLAMCH, SLANGE, SLANTR, + $ SLA_RPVGRW +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGEEQU, SGESV, + $ SGESVX, SGET01, SGET02, SGET04, SGET07, SGETRF, + $ SGETRI, SLACPY, SLAQGE, SLARHS, SLASET, SLATB4, + $ SLATMS, XLAENV, SGESVXX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. 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 TRANSS / 'N', 'T', 'C' / + DATA FACTS / 'F', 'N', 'E' / + DATA EQUEDS / 'N', 'R', 'C', 'B' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'GE' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL SERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 90 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 80 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 80 +* +* Skip types 5, 6, or 7 if the matrix size is too small. +* + ZEROT = IMAT.GE.5 .AND. IMAT.LE.7 + IF( ZEROT .AND. N.LT.IMAT-4 ) + $ GO TO 80 +* +* Set up parameters with SLATB4 and generate a test matrix +* with SLATMS. +* + CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) + RCONDC = ONE / CNDNUM +* + SRNAMT = 'SLATMS' + CALL SLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, CNDNUM, + $ ANORM, KL, KU, 'No packing', A, LDA, WORK, + $ INFO ) +* +* Check error code from SLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', N, N, -1, -1, + $ -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 80 + END IF +* +* For types 5-7, zero one or more columns of the matrix to +* test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.5 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.6 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF + IOFF = ( IZERO-1 )*LDA + IF( IMAT.LT.7 ) THEN + DO 20 I = 1, N + A( IOFF+I ) = ZERO + 20 CONTINUE + ELSE + CALL SLASET( 'Full', N, N-IZERO+1, ZERO, ZERO, + $ A( IOFF+1 ), LDA ) + END IF + ELSE + IZERO = 0 + END IF +* +* Save a copy of the matrix A in ASAV. +* + CALL SLACPY( 'Full', N, N, A, LDA, ASAV, LDA ) +* + DO 70 IEQUED = 1, 4 + EQUED = EQUEDS( IEQUED ) + IF( IEQUED.EQ.1 ) THEN + NFACT = 3 + ELSE + NFACT = 1 + END IF +* + DO 60 IFACT = 1, NFACT + FACT = FACTS( IFACT ) + PREFAC = LSAME( FACT, 'F' ) + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) +* + IF( ZEROT ) THEN + IF( PREFAC ) + $ GO TO 60 + RCONDO = ZERO + RCONDI = ZERO +* + ELSE IF( .NOT.NOFACT ) THEN +* +* Compute the condition number for comparison with +* the value returned by SGESVX (FACT = 'N' reuses +* the condition number from the previous iteration +* with FACT = 'F'). +* + CALL SLACPY( 'Full', N, N, ASAV, LDA, AFAC, LDA ) + IF( EQUIL .OR. IEQUED.GT.1 ) THEN +* +* Compute row and column scale factors to +* equilibrate the matrix A. +* + CALL SGEEQU( N, N, AFAC, LDA, S, S( N+1 ), + $ ROWCND, COLCND, AMAX, INFO ) + IF( INFO.EQ.0 .AND. N.GT.0 ) THEN + IF( LSAME( EQUED, 'R' ) ) THEN + ROWCND = ZERO + COLCND = ONE + ELSE IF( LSAME( EQUED, 'C' ) ) THEN + ROWCND = ONE + COLCND = ZERO + ELSE IF( LSAME( EQUED, 'B' ) ) THEN + ROWCND = ZERO + COLCND = ZERO + END IF +* +* Equilibrate the matrix. +* + CALL SLAQGE( N, N, AFAC, LDA, S, S( N+1 ), + $ ROWCND, COLCND, AMAX, EQUED ) + END IF + END IF +* +* Save the condition number of the non-equilibrated +* system for use in SGET04. +* + IF( EQUIL ) THEN + ROLDO = RCONDO + ROLDI = RCONDI + END IF +* +* Compute the 1-norm and infinity-norm of A. +* + ANORMO = SLANGE( '1', N, N, AFAC, LDA, RWORK ) + ANORMI = SLANGE( 'I', N, N, AFAC, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL SGETRF( N, N, AFAC, LDA, IWORK, INFO ) +* +* Form the inverse of A. +* + CALL SLACPY( 'Full', N, N, AFAC, LDA, A, LDA ) + LWORK = NMAX*MAX( 3, NRHS ) + CALL SGETRI( N, A, LDA, IWORK, WORK, LWORK, INFO ) +* +* Compute the 1-norm condition number of A. +* + AINVNM = SLANGE( '1', N, N, A, LDA, RWORK ) + IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDO = ONE + ELSE + RCONDO = ( ONE / ANORMO ) / AINVNM + END IF +* +* Compute the infinity-norm condition number of A. +* + AINVNM = SLANGE( 'I', N, N, A, LDA, RWORK ) + IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDI = ONE + ELSE + RCONDI = ( ONE / ANORMI ) / AINVNM + END IF + END IF +* + DO 50 ITRAN = 1, NTRAN + DO I = 1, NTESTS + RESULT (I) = ZERO + END DO +* +* Do for each value of TRANS. +* + TRANS = TRANSS( ITRAN ) + IF( ITRAN.EQ.1 ) THEN + RCONDC = RCONDO + ELSE + RCONDC = RCONDI + END IF +* +* Restore the matrix A. +* + CALL SLACPY( 'Full', N, N, ASAV, LDA, A, LDA ) +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'SLARHS' + CALL SLARHS( PATH, XTYPE, 'Full', TRANS, N, N, KL, + $ KU, NRHS, A, LDA, XACT, LDA, B, LDA, + $ ISEED, INFO ) + XTYPE = 'C' + CALL SLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA ) +* + IF( NOFACT .AND. ITRAN.EQ.1 ) THEN +* +* --- Test SGESV --- +* +* Compute the LU factorization of the matrix and +* solve the system. +* + CALL SLACPY( 'Full', N, N, A, LDA, AFAC, LDA ) + CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'SGESV ' + CALL SGESV( N, NRHS, AFAC, LDA, IWORK, X, LDA, + $ INFO ) +* +* Check error code from SGESV . +* + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'SGESV ', INFO, IZERO, + $ ' ', N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) + GOTO 50 + END IF +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL SGET01( N, N, A, LDA, AFAC, LDA, IWORK, + $ RWORK, RESULT( 1 ) ) + NT = 1 + IF( IZERO.EQ.0 ) THEN +* +* Compute residual of the computed solution. +* + CALL SLACPY( 'Full', N, NRHS, B, LDA, WORK, + $ LDA ) + CALL SGET02( 'No transpose', N, N, NRHS, A, + $ LDA, X, LDA, WORK, LDA, RWORK, + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + NT = 3 + END IF +* +* Print information about the tests that did not +* pass the threshold. +* + DO 30 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 )'SGESV ', N, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 30 CONTINUE + NRUN = NRUN + NT + END IF +* +* --- Test SGESVX --- +* + IF( .NOT.PREFAC ) + $ CALL SLASET( 'Full', N, N, ZERO, ZERO, AFAC, + $ LDA ) + CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT = 'F' and +* EQUED = 'R', 'C', or 'B'. +* + CALL SLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND, + $ COLCND, AMAX, EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using SGESVX. +* + SRNAMT = 'SGESVX' + CALL SGESVX( FACT, TRANS, N, NRHS, A, LDA, AFAC, + $ LDA, IWORK, EQUED, S, S( N+1 ), B, + $ LDA, X, LDA, RCOND, RWORK, + $ RWORK( NRHS+1 ), WORK, IWORK( N+1 ), + $ INFO ) +* +* Check the error code from SGESVX. +* + IF( INFO.EQ.N+1 ) GOTO 50 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'SGESVX', INFO, IZERO, + $ FACT // TRANS, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GOTO 50 + END IF +* +* Compare WORK(1) from SGESVX with the computed +* reciprocal pivot growth factor RPVGRW +* + IF( INFO.NE.0 ) THEN + RPVGRW = SLANTR( 'M', 'U', 'N', INFO, INFO, + $ AFAC, LDA, WORK ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = SLANGE( 'M', N, INFO, A, LDA, + $ WORK ) / RPVGRW + END IF + ELSE + RPVGRW = SLANTR( 'M', 'U', 'N', N, N, AFAC, LDA, + $ WORK ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = SLANGE( 'M', N, N, A, LDA, WORK ) / + $ RPVGRW + END IF + END IF + RESULT( 7 ) = ABS( RPVGRW-WORK( 1 ) ) / + $ MAX( WORK( 1 ), RPVGRW ) / + $ SLAMCH( 'E' ) +* + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL SGET01( N, N, A, LDA, AFAC, LDA, IWORK, + $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* + IF( INFO.EQ.0 ) THEN + TRFCON = .FALSE. +* +* Compute residual of the computed solution. +* + CALL SLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, + $ LDA ) + CALL SGET02( TRANS, N, N, NRHS, ASAV, LDA, X, + $ LDA, WORK, LDA, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + ELSE + IF( ITRAN.EQ.1 ) THEN + ROLDC = ROLDO + ELSE + ROLDC = ROLDI + END IF + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, + $ ROLDC, RESULT( 3 ) ) + END IF +* +* Check the error bounds from iterative +* refinement. +* + CALL SGET07( TRANS, N, NRHS, ASAV, LDA, B, LDA, + $ X, LDA, XACT, LDA, RWORK, .TRUE., + $ RWORK( NRHS+1 ), RESULT( 4 ) ) + ELSE + TRFCON = .TRUE. + END IF +* +* Compare RCOND from SGESVX with the computed value +* in RCONDC. +* + RESULT( 6 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( .NOT.TRFCON ) THEN + DO 40 K = K1, NTESTS + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'SGESVX', + $ FACT, TRANS, N, EQUED, IMAT, K, + $ RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'SGESVX', + $ FACT, TRANS, N, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 40 CONTINUE + NRUN = NRUN + 7 - K1 + ELSE + IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) + $ THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'SGESVX', FACT, + $ TRANS, N, EQUED, IMAT, 1, RESULT( 1 ) + ELSE + WRITE( NOUT, FMT = 9998 )'SGESVX', FACT, + $ TRANS, N, IMAT, 1, RESULT( 1 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 6 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'SGESVX', FACT, + $ TRANS, N, EQUED, IMAT, 6, RESULT( 6 ) + ELSE + WRITE( NOUT, FMT = 9998 )'SGESVX', FACT, + $ TRANS, N, IMAT, 6, RESULT( 6 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'SGESVX', FACT, + $ TRANS, N, EQUED, IMAT, 7, RESULT( 7 ) + ELSE + WRITE( NOUT, FMT = 9998 )'SGESVX', FACT, + $ TRANS, N, IMAT, 7, RESULT( 7 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF +* + END IF +* +* --- Test SGESVXX --- +* +* Restore the matrices A and B. +* + CALL SLACPY( 'Full', N, N, ASAV, LDA, A, LDA ) + CALL SLACPY( 'Full', N, NRHS, BSAV, LDA, B, LDA ) + + IF( .NOT.PREFAC ) + $ CALL SLASET( 'Full', N, N, ZERO, ZERO, AFAC, + $ LDA ) + CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT = 'F' and +* EQUED = 'R', 'C', or 'B'. +* + CALL SLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND, + $ COLCND, AMAX, EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using SGESVXX. +* + SRNAMT = 'SGESVXX' + N_ERR_BNDS = 3 + CALL SGESVXX( FACT, TRANS, N, NRHS, A, LDA, AFAC, + $ LDA, IWORK, EQUED, S, S( N+1 ), B, LDA, X, + $ LDA, RCOND, RPVGRW_SVXX, BERR, N_ERR_BNDS, + $ ERRBNDS_N, ERRBNDS_C, 0, ZERO, WORK, + $ IWORK( N+1 ), INFO ) +* +* Check the error code from SGESVXX. +* + IF( INFO.EQ.N+1 ) GOTO 50 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'SGESVXX', INFO, IZERO, + $ FACT // TRANS, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GOTO 50 + END IF +* +* Compare rpvgrw_svxx from SGESVXX with the computed +* reciprocal pivot growth factor RPVGRW +* + + IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN + RPVGRW = SLA_RPVGRW(N, INFO, A, LDA, AFAC, LDA) + ELSE + RPVGRW = SLA_RPVGRW(N, N, A, LDA, AFAC, LDA) + ENDIF + + RESULT( 7 ) = ABS( RPVGRW-RPVGRW_SVXX ) / + $ MAX( RPVGRW_SVXX, RPVGRW ) / + $ SLAMCH( 'E' ) +* + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL SGET01( N, N, A, LDA, AFAC, LDA, IWORK, + $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* + IF( INFO.EQ.0 ) THEN + TRFCON = .FALSE. +* +* Compute residual of the computed solution. +* + CALL SLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, + $ LDA ) + CALL SGET02( TRANS, N, N, NRHS, ASAV, LDA, X, + $ LDA, WORK, LDA, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + ELSE + IF( ITRAN.EQ.1 ) THEN + ROLDC = ROLDO + ELSE + ROLDC = ROLDI + END IF + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, + $ ROLDC, RESULT( 3 ) ) + END IF + ELSE + TRFCON = .TRUE. + END IF +* +* Compare RCOND from SGESVXX with the computed value +* in RCONDC. +* + RESULT( 6 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( .NOT.TRFCON ) THEN + DO 45 K = K1, NTESTS + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'SGESVXX', + $ FACT, TRANS, N, EQUED, IMAT, K, + $ RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'SGESVXX', + $ FACT, TRANS, N, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 45 CONTINUE + NRUN = NRUN + 7 - K1 + ELSE + IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) + $ THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'SGESVXX', FACT, + $ TRANS, N, EQUED, IMAT, 1, RESULT( 1 ) + ELSE + WRITE( NOUT, FMT = 9998 )'SGESVXX', FACT, + $ TRANS, N, IMAT, 1, RESULT( 1 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 6 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'SGESVXX', FACT, + $ TRANS, N, EQUED, IMAT, 6, RESULT( 6 ) + ELSE + WRITE( NOUT, FMT = 9998 )'SGESVXX', FACT, + $ TRANS, N, IMAT, 6, RESULT( 6 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'SGESVXX', FACT, + $ TRANS, N, EQUED, IMAT, 7, RESULT( 7 ) + ELSE + WRITE( NOUT, FMT = 9998 )'SGESVXX', FACT, + $ TRANS, N, IMAT, 7, RESULT( 7 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF +* + END IF +* + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + +* Test Error Bounds from SGESVXX + + CALL SEBCHVXX(THRESH, PATH) + + 9999 FORMAT( 1X, A, ', N =', I5, ', type ', I2, ', test(', I2, ') =', + $ G12.5 ) + 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5, + $ ', type ', I2, ', test(', I1, ')=', G12.5 ) + 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5, + $ ', EQUED=''', A1, ''', type ', I2, ', test(', I1, ')=', + $ G12.5 ) + RETURN +* +* End of SDRVGE +* + END diff --git a/TESTING/LIN/sdrvgt.f b/TESTING/LIN/sdrvgt.f index eb6889c9..908383dd 100644 --- a/TESTING/LIN/sdrvgt.f +++ b/TESTING/LIN/sdrvgt.f @@ -105,7 +105,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/sdrvls.f b/TESTING/LIN/sdrvls.f index 5b1d49d9..c00cf7ee 100644 --- a/TESTING/LIN/sdrvls.f +++ b/TESTING/LIN/sdrvls.f @@ -148,7 +148,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/sdrvpb.f b/TESTING/LIN/sdrvpb.f index c860f7e3..9f319fc1 100644 --- a/TESTING/LIN/sdrvpb.f +++ b/TESTING/LIN/sdrvpb.f @@ -122,7 +122,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/sdrvpo.f b/TESTING/LIN/sdrvpo.f index 8679521d..f0c92653 100644 --- a/TESTING/LIN/sdrvpo.f +++ b/TESTING/LIN/sdrvpo.f @@ -121,7 +121,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/sdrvpox.f b/TESTING/LIN/sdrvpox.f new file mode 100644 index 00000000..a0d6813c --- /dev/null +++ b/TESTING/LIN/sdrvpox.f @@ -0,0 +1,635 @@ + SUBROUTINE SDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, + $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + REAL A( * ), AFAC( * ), ASAV( * ), B( * ), + $ BSAV( * ), RWORK( * ), S( * ), WORK( * ), + $ X( * ), XACT( * ) +* .. +* +* Purpose +* ======= +* +* SDRVPO tests the driver routines SPOSV, -SVX, and -SVXX. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* NRHS (input) INTEGER +* The number of right hand side vectors to be generated for +* each linear system. +* +* THRESH (input) 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. +* +* TSTERR (input) LOGICAL +* Flag that indicates whether error exits are to be tested. +* +* NMAX (input) INTEGER +* The maximum value permitted for N, used in dimensioning the +* work arrays. +* +* A (workspace) REAL array, dimension (NMAX*NMAX) +* +* AFAC (workspace) REAL array, dimension (NMAX*NMAX) +* +* ASAV (workspace) REAL array, dimension (NMAX*NMAX) +* +* B (workspace) REAL array, dimension (NMAX*NRHS) +* +* BSAV (workspace) REAL array, dimension (NMAX*NRHS) +* +* X (workspace) REAL array, dimension (NMAX*NRHS) +* +* XACT (workspace) REAL array, dimension (NMAX*NRHS) +* +* S (workspace) REAL array, dimension (NMAX) +* +* WORK (workspace) REAL array, dimension +* (NMAX*max(3,NRHS)) +* +* RWORK (workspace) REAL array, dimension (NMAX+2*NRHS) +* +* IWORK (workspace) INTEGER array, dimension (NMAX) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 9 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 6 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, PREFAC, ZEROT + CHARACTER DIST, EQUED, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 PATH + INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, K, K1, KL, KU, LDA, MODE, N, NB, NBMIN, + $ NERRS, NFACT, NFAIL, NIMAT, NRUN, NT, + $ N_ERR_BNDS + REAL AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC, + $ ROLDC, SCOND, RPVGRW_SVXX +* .. +* .. Local Arrays .. + CHARACTER EQUEDS( 2 ), FACTS( 3 ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ), BERR( NRHS ), + $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + REAL SGET06, SLANSY + EXTERNAL LSAME, SGET06, SLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, SERRVX, SGET04, SLACPY, + $ SLAQSY, SLARHS, SLASET, SLATB4, SLATMS, SPOEQU, + $ SPOSV, SPOSVX, SPOT01, SPOT02, SPOT05, SPOTRF, + $ SPOTRI, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. 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' / + DATA FACTS / 'F', 'N', 'E' / + DATA EQUEDS / 'N', 'Y' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'PO' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL SERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 130 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 120 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 120 +* +* Skip types 3, 4, or 5 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 120 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 110 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with SLATB4 and generate a test matrix +* with SLATMS. +* + CALL SLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) +* + 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. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 110 + END IF +* +* For types 3-5, zero one row and column 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 + IOFF = ( IZERO-1 )*LDA +* +* Set row and column IZERO of A to 0. +* + IF( IUPLO.EQ.1 ) THEN + 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 + IZERO = 0 + END IF +* +* Save a copy of the matrix A in ASAV. +* + CALL SLACPY( UPLO, N, N, A, LDA, ASAV, LDA ) +* + DO 100 IEQUED = 1, 2 + EQUED = EQUEDS( IEQUED ) + IF( IEQUED.EQ.1 ) THEN + NFACT = 3 + ELSE + NFACT = 1 + END IF +* + DO 90 IFACT = 1, NFACT + DO I = 1, NTESTS + RESULT (I) = ZERO + END DO + FACT = FACTS( IFACT ) + PREFAC = LSAME( FACT, 'F' ) + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) +* + IF( ZEROT ) THEN + IF( PREFAC ) + $ GO TO 90 + RCONDC = ZERO +* + ELSE IF( .NOT.LSAME( FACT, 'N' ) ) THEN +* +* Compute the condition number for comparison with +* the value returned by SPOSVX (FACT = 'N' reuses +* the condition number from the previous iteration +* with FACT = 'F'). +* + CALL SLACPY( UPLO, N, N, ASAV, LDA, AFAC, LDA ) + IF( EQUIL .OR. IEQUED.GT.1 ) THEN +* +* Compute row and column scale factors to +* equilibrate the matrix A. +* + CALL SPOEQU( N, AFAC, LDA, S, SCOND, AMAX, + $ INFO ) + IF( INFO.EQ.0 .AND. N.GT.0 ) THEN + IF( IEQUED.GT.1 ) + $ SCOND = ZERO +* +* Equilibrate the matrix. +* + CALL SLAQSY( UPLO, N, AFAC, LDA, S, SCOND, + $ AMAX, EQUED ) + END IF + END IF +* +* Save the condition number of the +* non-equilibrated system for use in SGET04. +* + IF( EQUIL ) + $ ROLDC = RCONDC +* +* Compute the 1-norm of A. +* + ANORM = SLANSY( '1', UPLO, N, AFAC, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL SPOTRF( UPLO, N, AFAC, LDA, INFO ) +* +* Form the inverse of A. +* + CALL SLACPY( UPLO, N, N, AFAC, LDA, A, LDA ) + CALL SPOTRI( UPLO, N, A, LDA, INFO ) +* +* Compute the 1-norm condition number of A. +* + AINVNM = SLANSY( '1', UPLO, N, A, LDA, RWORK ) + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Restore the matrix A. +* + CALL SLACPY( UPLO, N, N, ASAV, LDA, A, LDA ) +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'SLARHS' + CALL SLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, + $ ISEED, INFO ) + XTYPE = 'C' + CALL SLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA ) +* + IF( NOFACT ) THEN +* +* --- Test SPOSV --- +* +* Compute the L*L' or U'*U factorization of the +* matrix and solve the system. +* + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'SPOSV ' + CALL SPOSV( UPLO, N, NRHS, AFAC, LDA, X, LDA, + $ INFO ) +* +* Check error code from SPOSV . +* + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'SPOSV ', INFO, IZERO, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) + GO TO 70 + ELSE IF( INFO.NE.0 ) THEN + GO TO 70 + END IF +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL SPOT01( UPLO, N, A, LDA, AFAC, LDA, RWORK, + $ RESULT( 1 ) ) +* +* 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 ) ) +* +* 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 60 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 )'SPOSV ', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 60 CONTINUE + NRUN = NRUN + NT + 70 CONTINUE + END IF +* +* --- Test SPOSVX --- +* + IF( .NOT.PREFAC ) + $ CALL SLASET( UPLO, N, N, ZERO, ZERO, AFAC, LDA ) + CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT='F' and +* EQUED='Y'. +* + CALL SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, + $ EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using SPOSVX. +* + SRNAMT = 'SPOSVX' + CALL SPOSVX( FACT, UPLO, N, NRHS, A, LDA, AFAC, + $ LDA, EQUED, S, B, LDA, X, LDA, RCOND, + $ RWORK, RWORK( NRHS+1 ), WORK, IWORK, + $ INFO ) +* +* Check the error code from SPOSVX. +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'SPOSVX', INFO, IZERO, + $ FACT // UPLO, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GO TO 90 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL SPOT01( UPLO, N, A, LDA, AFAC, LDA, + $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* +* Compute residual of the computed solution. +* + CALL SLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, + $ LDA ) + CALL SPOT02( UPLO, N, NRHS, ASAV, LDA, X, LDA, + $ WORK, LDA, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + ELSE + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, + $ ROLDC, RESULT( 3 ) ) + END IF +* +* Check the error bounds from iterative +* refinement. +* + CALL SPOT05( UPLO, N, NRHS, ASAV, LDA, B, LDA, + $ X, LDA, XACT, LDA, RWORK, + $ RWORK( NRHS+1 ), RESULT( 4 ) ) + ELSE + K1 = 6 + END IF +* +* Compare RCOND from SPOSVX with the computed value +* in RCONDC. +* + RESULT( 6 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 80 K = K1, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'SPOSVX', FACT, + $ UPLO, N, EQUED, IMAT, K, RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'SPOSVX', FACT, + $ UPLO, N, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 80 CONTINUE + NRUN = NRUN + 7 - K1 +* +* --- Test SPOSVXX --- +* +* Restore the matrices A and B. +* + CALL SLACPY( 'Full', N, N, ASAV, LDA, A, LDA ) + CALL SLACPY( 'Full', N, NRHS, BSAV, LDA, B, LDA ) + + IF( .NOT.PREFAC ) + $ CALL SLASET( UPLO, N, N, ZERO, ZERO, AFAC, LDA ) + CALL SLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT='F' and +* EQUED='Y'. +* + CALL SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, + $ EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using SPOSVXX. +* + SRNAMT = 'SPOSVXX' + n_err_bnds = 3 + CALL SPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AFAC, + $ LDA, EQUED, S, B, LDA, X, + $ LDA, rcond, rpvgrw_svxx, berr, n_err_bnds, + $ errbnds_n, errbnds_c, 0, ZERO, WORK, + $ IWORK, INFO ) +* +* Check the error code from SPOSVXX. +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'SPOSVXX', INFO, IZERO, + $ FACT // UPLO, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GO TO 90 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL SPOT01( UPLO, N, A, LDA, AFAC, LDA, + $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* +* Compute residual of the computed solution. +* + CALL SLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, + $ LDA ) + CALL SPOT02( UPLO, N, NRHS, ASAV, LDA, X, LDA, + $ WORK, LDA, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + ELSE + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, + $ ROLDC, RESULT( 3 ) ) + END IF +* +* Check the error bounds from iterative +* refinement. +* + CALL SPOT05( UPLO, N, NRHS, ASAV, LDA, B, LDA, + $ X, LDA, XACT, LDA, RWORK, + $ RWORK( NRHS+1 ), RESULT( 4 ) ) + ELSE + K1 = 6 + END IF +* +* Compare RCOND from SPOSVXX with the computed value +* in RCONDC. +* + RESULT( 6 ) = SGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 85 K = K1, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'SPOSVXX', FACT, + $ UPLO, N, EQUED, IMAT, K, RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'SPOSVXX', FACT, + $ UPLO, N, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 85 CONTINUE + NRUN = NRUN + 7 - K1 + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + +* Test Error Bounds from SPOSVXX + + CALL SEBCHVXX(THRESH, PATH) + + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I1, + $ ', test(', I1, ')=', G12.5 ) + 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5, + $ ', type ', I1, ', test(', I1, ')=', G12.5 ) + 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5, + $ ', EQUED=''', A1, ''', type ', I1, ', test(', I1, ') =', + $ G12.5 ) + RETURN +* +* End of SDRVPO +* + END diff --git a/TESTING/LIN/sdrvpp.f b/TESTING/LIN/sdrvpp.f index 7100b0e8..422b24af 100644 --- a/TESTING/LIN/sdrvpp.f +++ b/TESTING/LIN/sdrvpp.f @@ -121,7 +121,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/sdrvpt.f b/TESTING/LIN/sdrvpt.f index 2c7e86cb..309b3369 100644 --- a/TESTING/LIN/sdrvpt.f +++ b/TESTING/LIN/sdrvpt.f @@ -108,7 +108,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/sdrvrf1.f b/TESTING/LIN/sdrvrf1.f new file mode 100644 index 00000000..9c1bd40e --- /dev/null +++ b/TESTING/LIN/sdrvrf1.f @@ -0,0 +1,216 @@ + SUBROUTINE SDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER LDA, NN, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ) + REAL A( LDA, * ), ARF( * ), WORK( * ) +* .. +* +* Purpose +* ======= +* +* SDRVRF1 tests the LAPACK RFP routines: +* SLANSF +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* THRESH (input) 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. +* +* A (workspace) REAL array, dimension (LDA,NMAX) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* ARF (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2). +* +* WORK (workspace) REAL array, dimension ( NMAX ) +* +* ===================================================================== +* .. +* .. Parameters .. + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 1 ) +* .. +* .. Local Scalars .. + CHARACTER UPLO, CFORM, NORM + INTEGER I, IFORM, IIN, IIT, INFO, INORM, IUPLO, J, N, + + NERRS, NFAIL, NRUN + REAL EPS, LARGE, NORMA, NORMARF, SMALL +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ), NORMS( 4 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL SLAMCH, SLANSY, SLANSF, SLARND + EXTERNAL SLAMCH, SLANSY, SLANSF, SLARND +* .. +* .. External Subroutines .. + EXTERNAL STRTTF +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'T' / + DATA NORMS / 'M', '1', 'I', 'F' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + INFO = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* + EPS = SLAMCH( 'Precision' ) + SMALL = SLAMCH( 'Safe minimum' ) + LARGE = ONE / SMALL + SMALL = SMALL * LDA * LDA + LARGE = LARGE / LDA / LDA +* + DO 130 IIN = 1, NN +* + N = NVAL( IIN ) +* + DO 120 IIT = 1, 3 +* +* IIT = 1 : random matrix +* IIT = 2 : random matrix scaled near underflow +* IIT = 3 : random matrix scaled near overflow +* + DO J = 1, N + DO I = 1, N + A( I, J) = SLARND( 2, ISEED ) + END DO + END DO +* + IF ( IIT.EQ.2 ) THEN + DO J = 1, N + DO I = 1, N + A( I, J) = A( I, J ) * LARGE + END DO + END DO + END IF +* + IF ( IIT.EQ.3 ) THEN + DO J = 1, N + DO I = 1, N + A( I, J) = A( I, J) * SMALL + END DO + END DO + END IF +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 110 IUPLO = 1, 2 +* + UPLO = UPLOS( IUPLO ) +* +* Do first for CFORM = 'N', then for CFORM = 'C' +* + DO 100 IFORM = 1, 2 +* + CFORM = FORMS( IFORM ) +* + SRNAMT = 'STRTTF' + CALL STRTTF( CFORM, UPLO, N, A, LDA, ARF, INFO ) +* +* Check error code from STRTTF +* + IF( INFO.NE.0 ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9998 ) SRNAMT, UPLO, CFORM, N + NERRS = NERRS + 1 + GO TO 100 + END IF +* + DO 90 INORM = 1, 4 +* +* Check all four norms: 'M', '1', 'I', 'F' +* + NORM = NORMS( INORM ) + NORMARF = SLANSF( NORM, CFORM, UPLO, N, ARF, WORK ) + NORMA = SLANSY( NORM, UPLO, N, A, LDA, WORK ) +* + RESULT(1) = ( NORMA - NORMARF ) / NORMA / EPS + NRUN = NRUN + 1 +* + IF( RESULT(1).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9997 ) 'SLANSF', + + N, IIT, UPLO, CFORM, NORM, RESULT(1) + NFAIL = NFAIL + 1 + END IF + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE +* +* Print a summary of the results. +* + IF ( NFAIL.EQ.0 ) THEN + WRITE( NOUT, FMT = 9996 ) 'SLANSF', NRUN + ELSE + WRITE( NOUT, FMT = 9995 ) 'SLANSF', NFAIL, NRUN + END IF + IF ( NERRS.NE.0 ) THEN + WRITE( NOUT, FMT = 9994 ) NERRS, 'SLANSF' + END IF +* + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing SLANSF + + ***') + 9998 FORMAT( 1X, ' Error in ',A6,' with UPLO=''',A1,''', FORM=''', + + A1,''', N=',I5) + 9997 FORMAT( 1X, ' Failure in ',A6,' N=',I5,' TYPE=',I5,' UPLO=''', + + A1, ''', FORM =''',A1,''', NORM=''',A1,''', test=',G12.5) + 9996 FORMAT( 1X, 'All tests for ',A6,' auxiliary routine passed the ', + + 'threshold (',I5,' tests run)') + 9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5, + + ' tests failed to pass the threshold') + 9994 FORMAT( 26X, I5,' error message recorded (',A6,')') +* + RETURN +* +* End of SDRVRF1 +* + END diff --git a/TESTING/LIN/sdrvrf2.f b/TESTING/LIN/sdrvrf2.f new file mode 100644 index 00000000..1a2abf2d --- /dev/null +++ b/TESTING/LIN/sdrvrf2.f @@ -0,0 +1,202 @@ + SUBROUTINE SDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER LDA, NN, NOUT +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ) + REAL A( LDA, * ), ARF( * ), AP(*), ASAV( LDA, * ) +* .. +* +* Purpose +* ======= +* +* SDRVRF2 tests the LAPACK RFP convertion routines. +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* A (workspace) REAL array, dimension (LDA,NMAX) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* ARF (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2). +* +* AP (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2). +* +* A2 (workspace) REAL array, dimension (LDA,NMAX) +* +* ===================================================================== +* .. +* .. Local Scalars .. + LOGICAL LOWER, OK1, OK2 + CHARACTER UPLO, CFORM + INTEGER I, IFORM, IIN, INFO, IUPLO, J, N, + + NERRS, NRUN +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) +* .. +* .. External Functions .. + REAL SLARND + EXTERNAL SLARND +* .. +* .. External Subroutines .. + EXTERNAL STFTTR, STFTTP, STRTTF, STRTTP, STPTTR, STPTTF +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'T' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NERRS = 0 + INFO = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* + DO 120 IIN = 1, NN +* + N = NVAL( IIN ) +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 110 IUPLO = 1, 2 +* + UPLO = UPLOS( IUPLO ) + LOWER = .TRUE. + IF ( IUPLO.EQ.1 ) LOWER = .FALSE. +* +* Do first for CFORM = 'N', then for CFORM = 'T' +* + DO 100 IFORM = 1, 2 +* + CFORM = FORMS( IFORM ) +* + NRUN = NRUN + 1 +* + DO J = 1, N + DO I = 1, N + A( I, J) = SLARND( 2, ISEED ) + END DO + END DO +* + SRNAMT = 'DTRTTF' + CALL STRTTF( CFORM, UPLO, N, A, LDA, ARF, INFO ) +* + SRNAMT = 'DTFTTP' + CALL STFTTP( CFORM, UPLO, N, ARF, AP, INFO ) +* + SRNAMT = 'DTPTTR' + CALL STPTTR( UPLO, N, AP, ASAV, LDA, INFO ) +* + OK1 = .TRUE. + IF ( LOWER ) THEN + DO J = 1, N + DO I = J, N + IF ( A(I,J).NE.ASAV(I,J) ) THEN + OK1 = .FALSE. + END IF + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, J + IF ( A(I,J).NE.ASAV(I,J) ) THEN + OK1 = .FALSE. + END IF + END DO + END DO + END IF +* + NRUN = NRUN + 1 +* + SRNAMT = 'DTRTTP' + CALL STRTTP( UPLO, N, A, LDA, AP, INFO ) +* + SRNAMT = 'DTPTTF' + CALL STPTTF( CFORM, UPLO, N, AP, ARF, INFO ) +* + SRNAMT = 'DTFTTR' + CALL STFTTR( CFORM, UPLO, N, ARF, ASAV, LDA, INFO ) +* + OK2 = .TRUE. + IF ( LOWER ) THEN + DO J = 1, N + DO I = J, N + IF ( A(I,J).NE.ASAV(I,J) ) THEN + OK2 = .FALSE. + END IF + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, J + IF ( A(I,J).NE.ASAV(I,J) ) THEN + OK2 = .FALSE. + END IF + END DO + END DO + END IF +* + IF (( .NOT.OK1 ).OR.( .NOT.OK2 )) THEN + IF( NERRS.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9998 ) N, UPLO, CFORM + NERRS = NERRS + 1 + END IF +* + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE +* +* Print a summary of the results. +* + IF ( NERRS.EQ.0 ) THEN + WRITE( NOUT, FMT = 9997 ) NRUN + ELSE + WRITE( NOUT, FMT = 9996 ) NERRS, NRUN + END IF +* + 9999 FORMAT( 1X, ' *** Error(s) while testing the RFP convertion', + + ' routines ***') + 9998 FORMAT( 1X, ' Error in RFP,convertion routines N=',I5, + + ' UPLO=''', A1, ''', FORM =''',A1,'''') + 9997 FORMAT( 1X, 'All tests for the RFP convertion routines passed (', + + I5,' tests run)') + 9996 FORMAT( 1X, 'RFP convertion routines:',I5,' out of ',I5, + + ' error message recorded') +* + RETURN +* +* End of SDRVRF2 +* + END diff --git a/TESTING/LIN/sdrvrf3.f b/TESTING/LIN/sdrvrf3.f new file mode 100644 index 00000000..e4efafaa --- /dev/null +++ b/TESTING/LIN/sdrvrf3.f @@ -0,0 +1,298 @@ + SUBROUTINE SDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, + + S_WORK_SLANGE, S_WORK_SGEQRF, TAU ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER LDA, NN, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ) + REAL A( LDA, * ), ARF( * ), B1( LDA, * ), + + B2( LDA, * ), S_WORK_SGEQRF( * ), + + S_WORK_SLANGE( * ), TAU( * ) +* .. +* +* Purpose +* ======= +* +* SDRVRF3 tests the LAPACK RFP routines: +* STFSM +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* THRESH (input) 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. +* +* A (workspace) REAL array, dimension (LDA,NMAX) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* ARF (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2). +* +* B1 (workspace) REAL array, dimension (LDA,NMAX) +* +* B2 (workspace) REAL array, dimension (LDA,NMAX) +* +* S_WORK_SLANGE (workspace) REAL array, dimension (NMAX) +* +* S_WORK_SGEQRF (workspace) REAL array, dimension (NMAX) +* +* TAU (workspace) REAL array, dimension (NMAX) +* +* ===================================================================== +* .. +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) , + + ONE = ( 1.0E+0, 0.0E+0 ) ) + INTEGER NTESTS + PARAMETER ( NTESTS = 1 ) +* .. +* .. Local Scalars .. + CHARACTER UPLO, CFORM, DIAG, TRANS, SIDE + INTEGER I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA, + + NFAIL, NRUN, ISIDE, IDIAG, IALPHA, ITRANS + REAL EPS, ALPHA +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ), + + DIAGS( 2 ), SIDES( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL SLAMCH, SLANGE, SLARND + EXTERNAL SLAMCH, SLANGE, SLARND +* .. +* .. External Subroutines .. + EXTERNAL STRTTF, SGEQRF, SGEQLF, STFSM, STRSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'T' / + DATA SIDES / 'L', 'R' / + DATA TRANSS / 'N', 'T' / + DATA DIAGS / 'N', 'U' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NFAIL = 0 + INFO = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + EPS = SLAMCH( 'Precision' ) +* + DO 170 IIM = 1, NN +* + M = NVAL( IIM ) +* + DO 160 IIN = 1, NN +* + N = NVAL( IIN ) +* + DO 150 IFORM = 1, 2 +* + CFORM = FORMS( IFORM ) +* + DO 140 IUPLO = 1, 2 +* + UPLO = UPLOS( IUPLO ) +* + DO 130 ISIDE = 1, 2 +* + SIDE = SIDES( ISIDE ) +* + DO 120 ITRANS = 1, 2 +* + TRANS = TRANSS( ITRANS ) +* + DO 110 IDIAG = 1, 2 +* + DIAG = DIAGS( IDIAG ) +* + DO 100 IALPHA = 1, 3 +* + IF ( IALPHA.EQ. 1) THEN + ALPHA = ZERO + ELSE IF ( IALPHA.EQ. 1) THEN + ALPHA = ONE + ELSE + ALPHA = SLARND( 2, ISEED ) + END IF +* +* All the parameters are set: +* CFORM, SIDE, UPLO, TRANS, DIAG, M, N, +* and ALPHA +* READY TO TEST! +* + NRUN = NRUN + 1 +* + IF ( ISIDE.EQ.1 ) THEN +* +* The case ISIDE.EQ.1 is when SIDE.EQ.'L' +* -> A is M-by-M ( B is M-by-N ) +* + NA = M +* + ELSE +* +* The case ISIDE.EQ.2 is when SIDE.EQ.'R' +* -> A is N-by-N ( B is M-by-N ) +* + NA = N +* + END IF +* +* Generate A our NA--by--NA triangular +* matrix. +* Our test is based on forward error so we +* do want A to be well conditionned! To get +* a well-conditionned triangular matrix, we +* take the R factor of the QR/LQ factorization +* of a random matrix. +* + DO J = 1, NA + DO I = 1, NA + A( I, J) = SLARND( 2, ISEED ) + END DO + END DO +* + IF ( IUPLO.EQ.1 ) THEN +* +* The case IUPLO.EQ.1 is when SIDE.EQ.'U' +* -> QR factorization. +* + SRNAMT = 'SGEQRF' + CALL SGEQRF( NA, NA, A, LDA, TAU, + + S_WORK_SGEQRF, LDA, + + INFO ) + ELSE +* +* The case IUPLO.EQ.2 is when SIDE.EQ.'L' +* -> QL factorization. +* + SRNAMT = 'SGELQF' + CALL SGELQF( NA, NA, A, LDA, TAU, + + S_WORK_SGEQRF, LDA, + + INFO ) + END IF +* +* Store a copy of A in RFP format (in ARF). +* + SRNAMT = 'STRTTF' + CALL STRTTF( CFORM, UPLO, NA, A, LDA, ARF, + + INFO ) +* +* Generate B1 our M--by--N right-hand side +* and store a copy in B2. +* + DO J = 1, N + DO I = 1, M + B1( I, J) = SLARND( 2, ISEED ) + B2( I, J) = B1( I, J) + END DO + END DO +* +* Solve op( A ) X = B or X op( A ) = B +* with STRSM +* + SRNAMT = 'STRSM' + CALL STRSM( SIDE, UPLO, TRANS, DIAG, M, N, + + ALPHA, A, LDA, B1, LDA ) +* +* Solve op( A ) X = B or X op( A ) = B +* with STFSM +* + SRNAMT = 'STFSM' + CALL STFSM( CFORM, SIDE, UPLO, TRANS, + + DIAG, M, N, ALPHA, ARF, B2, + + LDA ) +* +* Check that the result agrees. +* + DO J = 1, N + DO I = 1, M + B1( I, J) = B2( I, J ) - B1( I, J ) + END DO + END DO +* + RESULT(1) = SLANGE( 'I', M, N, B1, LDA, + + S_WORK_SLANGE ) +* + RESULT(1) = RESULT(1) / SQRT( EPS ) + + / MAX ( MAX( M, N), 1 ) +* + IF( RESULT(1).GE.THRESH ) THEN + IF( NFAIL.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9997 ) 'STFSM', + + CFORM, SIDE, UPLO, TRANS, DIAG, M, + + N, RESULT(1) + NFAIL = NFAIL + 1 + END IF +* + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE +* +* Print a summary of the results. +* + IF ( NFAIL.EQ.0 ) THEN + WRITE( NOUT, FMT = 9996 ) 'STFSM', NRUN + ELSE + WRITE( NOUT, FMT = 9995 ) 'STFSM', NFAIL, NRUN + END IF +* + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing STFSM + + ***') + 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', + + ' SIDE=''',A1,''',',' UPLO=''',A1,''',',' TRANS=''',A1,''',', + + ' DIAG=''',A1,''',',' M=',I3,', N =', I3,', test=',G12.5) + 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ', + + 'threshold (',I5,' tests run)') + 9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5, + + ' tests failed to pass the threshold') +* + RETURN +* +* End of SDRVRF3 +* + END diff --git a/TESTING/LIN/sdrvrf4.f b/TESTING/LIN/sdrvrf4.f new file mode 100644 index 00000000..0eedbadf --- /dev/null +++ b/TESTING/LIN/sdrvrf4.f @@ -0,0 +1,286 @@ + SUBROUTINE SDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, + + LDA, S_WORK_SLANGE ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER LDA, LDC, NN, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ) + REAL A( LDA, * ), C1( LDC, * ), C2( LDC, *), + + CRF( * ), S_WORK_SLANGE( * ) +* .. +* +* Purpose +* ======= +* +* SDRVRF4 tests the LAPACK RFP routines: +* SSFRK +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* THRESH (input) 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. +* +* C1 (workspace) REAL array, +* dimension (LDC,NMAX) +* +* C2 (workspace) REAL array, +* dimension (LDC,NMAX) +* +* LDC (input) INTEGER +* The leading dimension of the array A. +* LDA >= max(1,NMAX). +* +* CRF (workspace) REAL array, +* dimension ((NMAX*(NMAX+1))/2). +* +* A (workspace) REAL array, +* dimension (LDA,NMAX) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* S_WORK_SLANGE (workspace) REAL array, dimension (NMAX) +* +* ===================================================================== +* .. +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 1 ) +* .. +* .. Local Scalars .. + CHARACTER UPLO, CFORM, TRANS + INTEGER I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N, + + NFAIL, NRUN, IALPHA, ITRANS + REAL ALPHA, BETA, EPS, NORMA, NORMC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL SLAMCH, SLARND, SLANGE + EXTERNAL SLAMCH, SLARND, SLANGE +* .. +* .. External Subroutines .. + EXTERNAL SSYRK, SSFRK, STFTTR, STRTTF +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'T' / + DATA TRANSS / 'N', 'T' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NFAIL = 0 + INFO = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + EPS = SLAMCH( 'Precision' ) +* + DO 150 IIN = 1, NN +* + N = NVAL( IIN ) +* + DO 140 IIK = 1, NN +* + K = NVAL( IIN ) +* + DO 130 IFORM = 1, 2 +* + CFORM = FORMS( IFORM ) +* + DO 120 IUPLO = 1, 2 +* + UPLO = UPLOS( IUPLO ) +* + DO 110 ITRANS = 1, 2 +* + TRANS = TRANSS( ITRANS ) +* + DO 100 IALPHA = 1, 4 +* + IF ( IALPHA.EQ. 1) THEN + ALPHA = ZERO + BETA = ZERO + ELSE IF ( IALPHA.EQ. 2) THEN + ALPHA = ONE + BETA = ZERO + ELSE IF ( IALPHA.EQ. 3) THEN + ALPHA = ZERO + BETA = ONE + ELSE + ALPHA = SLARND( 2, ISEED ) + BETA = SLARND( 2, ISEED ) + END IF +* +* All the parameters are set: +* CFORM, UPLO, TRANS, M, N, +* ALPHA, and BETA +* READY TO TEST! +* + NRUN = NRUN + 1 +* + IF ( ITRANS.EQ.1 ) THEN +* +* In this case we are NOTRANS, so A is N-by-K +* + DO J = 1, K + DO I = 1, N + A( I, J) = SLARND( 2, ISEED ) + END DO + END DO +* + NORMA = SLANGE( 'I', N, K, A, LDA, + + S_WORK_SLANGE ) +* + + ELSE +* +* In this case we are TRANS, so A is K-by-N +* + DO J = 1,N + DO I = 1, K + A( I, J) = SLARND( 2, ISEED ) + END DO + END DO +* + NORMA = SLANGE( 'I', K, N, A, LDA, + + S_WORK_SLANGE ) +* + END IF +* +* Generate C1 our N--by--N symmetric matrix. +* Make sure C2 has the same upper/lower part, +* (the one that we do not touch), so +* copy the initial C1 in C2 in it. +* + DO J = 1, N + DO I = 1, N + C1( I, J) = SLARND( 2, ISEED ) + C2(I,J) = C1(I,J) + END DO + END DO +* +* (See comment later on for why we use SLANGE and +* not SLANSY for C1.) +* + NORMC = SLANGE( 'I', N, N, C1, LDC, + + S_WORK_SLANGE ) +* + SRNAMT = 'STRTTF' + CALL STRTTF( CFORM, UPLO, N, C1, LDC, CRF, + + INFO ) +* +* call ssyrk the BLAS routine -> gives C1 +* + SRNAMT = 'SSYRK ' + CALL SSYRK( UPLO, TRANS, N, K, ALPHA, A, LDA, + + BETA, C1, LDC ) +* +* call ssfrk the RFP routine -> gives CRF +* + SRNAMT = 'SSFRK ' + CALL SSFRK( CFORM, UPLO, TRANS, N, K, ALPHA, A, + + LDA, BETA, CRF ) +* +* convert CRF in full format -> gives C2 +* + SRNAMT = 'STFTTR' + CALL STFTTR( CFORM, UPLO, N, CRF, C2, LDC, + + INFO ) +* +* compare C1 and C2 +* + DO J = 1, N + DO I = 1, N + C1(I,J) = C1(I,J)-C2(I,J) + END DO + END DO +* +* Yes, C1 is symmetric so we could call SLANSY, +* but we want to check the upper part that is +* supposed to be unchanged and the diagonal that +* is supposed to be real -> SLANGE +* + RESULT(1) = SLANGE( 'I', N, N, C1, LDC, + + S_WORK_SLANGE ) + RESULT(1) = RESULT(1) + + / MAX( ABS( ALPHA ) * NORMA + + + ABS( BETA ) , ONE ) + + / MAX( N , 1 ) / EPS +* + IF( RESULT(1).GE.THRESH ) THEN + IF( NFAIL.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9997 ) 'SSFRK', + + CFORM, UPLO, TRANS, N, K, RESULT(1) + NFAIL = NFAIL + 1 + END IF +* + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE +* +* Print a summary of the results. +* + IF ( NFAIL.EQ.0 ) THEN + WRITE( NOUT, FMT = 9996 ) 'SSFRK', NRUN + ELSE + WRITE( NOUT, FMT = 9995 ) 'SSFRK', NFAIL, NRUN + END IF +* + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing SSFRK + + ***') + 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', + + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3, + + ', test=',G12.5) + 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ', + + 'threshold (',I5,' tests run)') + 9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5, + + ' tests failed to pass the threshold') +* + RETURN +* +* End of SDRVRF4 +* + END diff --git a/TESTING/LIN/sdrvrfp.f b/TESTING/LIN/sdrvrfp.f new file mode 100644 index 00000000..abc9f16b --- /dev/null +++ b/TESTING/LIN/sdrvrfp.f @@ -0,0 +1,446 @@ + SUBROUTINE SDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, + + THRESH, A, ASAV, AFAC, AINV, B, + + BSAV, XACT, X, ARF, ARFINV, + + S_WORK_SLATMS, S_WORK_SPOT01, S_TEMP_SPOT02, + + S_TEMP_SPOT03, S_WORK_SLANSY, + + S_WORK_SPOT02, S_WORK_SPOT03 ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER NN, NNS, NNT, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ), NSVAL( NNS ), NTVAL( NNT ) + REAL A( * ) + REAL AINV( * ) + REAL ASAV( * ) + REAL B( * ) + REAL BSAV( * ) + REAL AFAC( * ) + REAL ARF( * ) + REAL ARFINV( * ) + REAL XACT( * ) + REAL X( * ) + REAL S_WORK_SLATMS( * ) + REAL S_WORK_SPOT01( * ) + REAL S_TEMP_SPOT02( * ) + REAL S_TEMP_SPOT03( * ) + REAL S_WORK_SLANSY( * ) + REAL S_WORK_SPOT02( * ) + REAL S_WORK_SPOT03( * ) +* .. +* +* Purpose +* ======= +* +* SDRVRFP tests the LAPACK RFP routines: +* SPFTRF, SPFTRS, and SPFTRI. +* +* This testing routine follow the same tests as DDRVPO (test for the full +* format Symmetric Positive Definite solver). +* +* The tests are performed in Full Format, convertion back and forth from +* full format to RFP format are performed using the routines STRTTF and +* STFTTR. +* +* First, a specific matrix A of size N is created. There is nine types of +* different matrixes possible. +* 1. Diagonal 6. Random, CNDNUM = sqrt(0.1/EPS) +* 2. Random, CNDNUM = 2 7. Random, CNDNUM = 0.1/EPS +* *3. First row and column zero 8. Scaled near underflow +* *4. Last row and column zero 9. Scaled near overflow +* *5. Middle row and column zero +* (* - tests error exits from SPFTRF, no test ratios are computed) +* A solution XACT of size N-by-NRHS is created and the associated right +* hand side B as well. Then SPFTRF is called to compute L (or U), the +* Cholesky factor of A. Then L (or U) is used to solve the linear system +* of equations AX = B. This gives X. Then L (or U) is used to compute the +* inverse of A, AINV. The following four tests are then performed: +* (1) norm( L*L' - A ) / ( N * norm(A) * EPS ) or +* norm( U'*U - A ) / ( N * norm(A) * EPS ), +* (2) norm(B - A*X) / ( norm(A) * norm(X) * EPS ), +* (3) norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), +* (4) ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ), +* where EPS is the machine precision, RCOND the condition number of A, and +* norm( . ) the 1-norm for (1,2,3) and the inf-norm for (4). +* Errors occur when INFO parameter is not as expected. Failures occur when +* a test ratios is greater than THRES. +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* NNS (input) INTEGER +* The number of values of NRHS contained in the vector NSVAL. +* +* NSVAL (input) INTEGER array, dimension (NNS) +* The values of the number of right-hand sides NRHS. +* +* NNT (input) INTEGER +* The number of values of MATRIX TYPE contained in the vector NTVAL. +* +* NTVAL (input) INTEGER array, dimension (NNT) +* The values of matrix type (between 0 and 9 for PO/PP/PF matrices). +* +* THRESH (input) 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. +* +* A (workspace) REAL array, dimension (NMAX*NMAX) +* +* ASAV (workspace) REAL array, dimension (NMAX*NMAX) +* +* AFAC (workspace) REAL array, dimension (NMAX*NMAX) +* +* AINV (workspace) REAL array, dimension (NMAX*NMAX) +* +* B (workspace) REAL array, dimension (NMAX*MAXRHS) +* +* BSAV (workspace) REAL array, dimension (NMAX*MAXRHS) +* +* XACT (workspace) REAL array, dimension (NMAX*MAXRHS) +* +* X (workspace) REAL array, dimension (NMAX*MAXRHS) +* +* ARF (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2) +* +* ARFINV (workspace) REAL array, dimension ((NMAX*(NMAX+1))/2) +* +* S_WORK_SLATMS (workspace) REAL array, dimension ( 3*NMAX ) +* +* S_WORK_SPOT01 (workspace) REAL array, dimension ( NMAX ) +* +* S_TEMP_SPOT02 (workspace) REAL array, dimension ( NMAX*MAXRHS ) +* +* S_TEMP_SPOT03 (workspace) REAL array, dimension ( NMAX*NMAX ) +* +* S_WORK_SLATMS (workspace) REAL array, dimension ( NMAX ) +* +* S_WORK_SLANSY (workspace) REAL array, dimension ( NMAX ) +* +* S_WORK_SPOT02 (workspace) REAL array, dimension ( NMAX ) +* +* S_WORK_SPOT03 (workspace) REAL array, dimension ( NMAX ) +* +* ===================================================================== +* +* .. Parameters .. + REAL ONE, ZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 4 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + INTEGER I, INFO, IUPLO, LDA, LDB, IMAT, NERRS, NFAIL, + + NRHS, NRUN, IZERO, IOFF, K, NT, N, IFORM, IIN, + + IIT, IIS + CHARACTER DIST, CTYPE, UPLO, CFORM + INTEGER KL, KU, MODE + REAL ANORM, AINVNM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL SLANSY + EXTERNAL SLANSY +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, SGET04, STFTTR, SLACPY, + + SLARHS, SLATB4, SLATMS, SPFTRI, SPFTRF, SPFTRS, + + SPOT01, SPOT02, SPOT03, SPOTRI, SPOTRF, STRTTF +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'T' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* + DO 130 IIN = 1, NN +* + N = NVAL( IIN ) + LDA = MAX( N, 1 ) + LDB = MAX( N, 1 ) +* + DO 980 IIS = 1, NNS +* + NRHS = NSVAL( IIS ) +* + DO 120 IIT = 1, NNT +* + IMAT = NTVAL( IIT ) +* +* If N.EQ.0, only consider the first type +* + IF( N.EQ.0 .AND. IIT.GT.1 ) GO TO 120 +* +* Skip types 3, 4, or 5 if the matrix size is too small. +* + IF( IMAT.EQ.4 .AND. N.LE.1 ) GO TO 120 + IF( IMAT.EQ.5 .AND. N.LE.2 ) GO TO 120 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 110 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Do first for CFORM = 'N', then for CFORM = 'C' +* + DO 100 IFORM = 1, 2 + CFORM = FORMS( IFORM ) +* +* Set up parameters with SLATB4 and generate a test +* matrix with SLATMS. +* + CALL SLATB4( 'SPO', IMAT, N, N, CTYPE, KL, KU, + + ANORM, MODE, CNDNUM, DIST ) +* + SRNAMT = 'SLATMS' + CALL SLATMS( N, N, DIST, ISEED, CTYPE, + + S_WORK_SLATMS, + + MODE, CNDNUM, ANORM, KL, KU, UPLO, A, + + LDA, S_WORK_SLATMS, INFO ) +* +* Check error code from SLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( 'SPF', 'SLATMS', INFO, 0, UPLO, N, + + N, -1, -1, -1, IIT, NFAIL, NERRS, + + NOUT ) + GO TO 100 + END IF +* +* For types 3-5, zero one row and column of the matrix to +* test that INFO is returned correctly. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 + IF( ZEROT ) THEN + IF( IIT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IIT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF + IOFF = ( IZERO-1 )*LDA +* +* Set row and column IZERO of A to 0. +* + IF( IUPLO.EQ.1 ) THEN + 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 + IZERO = 0 + END IF +* +* Save a copy of the matrix A in ASAV. +* + CALL SLACPY( UPLO, N, N, A, LDA, ASAV, LDA ) +* +* Compute the condition number of A (RCONDC). +* + IF( ZEROT ) THEN + RCONDC = ZERO + ELSE +* +* Compute the 1-norm of A. +* + ANORM = SLANSY( '1', UPLO, N, A, LDA, + + S_WORK_SLANSY ) +* +* Factor the matrix A. +* + CALL SPOTRF( UPLO, N, A, LDA, INFO ) +* +* Form the inverse of A. +* + CALL SPOTRI( UPLO, N, A, LDA, INFO ) +* +* Compute the 1-norm condition number of A. +* + AINVNM = SLANSY( '1', UPLO, N, A, LDA, + + S_WORK_SLANSY ) + RCONDC = ( ONE / ANORM ) / AINVNM +* +* Restore the matrix A. +* + CALL SLACPY( UPLO, N, N, ASAV, LDA, A, LDA ) +* + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'SLARHS' + CALL SLARHS( 'SPO', 'N', UPLO, ' ', N, N, KL, KU, + + NRHS, A, LDA, XACT, LDA, B, LDA, + + ISEED, INFO ) + CALL SLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA ) +* +* Compute the L*L' or U'*U factorization of the +* matrix and solve the system. +* + CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDB ) +* + SRNAMT = 'STRTTF' + CALL STRTTF( CFORM, UPLO, N, AFAC, LDA, ARF, INFO ) + SRNAMT = 'SPFTRF' + CALL SPFTRF( CFORM, UPLO, N, ARF, INFO ) +* +* Check error code from SPFTRF. +* + IF( INFO.NE.IZERO ) THEN +* +* LANGOU: there is a small hick here: IZERO should +* always be INFO however if INFO is ZERO, ALAERH does not +* complain. +* + CALL ALAERH( 'SPF', 'SPFSV ', INFO, IZERO, + + UPLO, N, N, -1, -1, NRHS, IIT, + + NFAIL, NERRS, NOUT ) + GO TO 100 + END IF +* +* Skip the tests if INFO is not 0. +* + IF( INFO.NE.0 ) THEN + GO TO 100 + END IF +* + SRNAMT = 'SPFTRS' + CALL SPFTRS( CFORM, UPLO, N, NRHS, ARF, X, LDB, + + INFO ) +* + SRNAMT = 'STFTTR' + CALL STFTTR( CFORM, UPLO, N, ARF, AFAC, LDA, INFO ) +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL SLACPY( UPLO, N, N, AFAC, LDA, ASAV, LDA ) + CALL SPOT01( UPLO, N, A, LDA, AFAC, LDA, + + S_WORK_SPOT01, RESULT( 1 ) ) + CALL SLACPY( UPLO, N, N, ASAV, LDA, AFAC, LDA ) +* +* Form the inverse and compute the residual. +* + IF(MOD(N,2).EQ.0)THEN + CALL SLACPY( 'A', N+1, N/2, ARF, N+1, ARFINV, + + N+1 ) + ELSE + CALL SLACPY( 'A', N, (N+1)/2, ARF, N, ARFINV, + + N ) + END IF +* + SRNAMT = 'SPFTRI' + CALL SPFTRI( CFORM, UPLO, N, ARFINV , INFO ) +* + SRNAMT = 'STFTTR' + CALL STFTTR( CFORM, UPLO, N, ARFINV, AINV, LDA, + + INFO ) +* +* Check error code from SPFTRI. +* + IF( INFO.NE.0 ) + + CALL ALAERH( 'SPO', 'SPFTRI', INFO, 0, UPLO, N, + + N, -1, -1, -1, IMAT, NFAIL, NERRS, + + NOUT ) +* + CALL SPOT03( UPLO, N, A, LDA, AINV, LDA, + + S_TEMP_SPOT03, LDA, S_WORK_SPOT03, + + RCONDC, RESULT( 2 ) ) +* +* Compute residual of the computed solution. +* + CALL SLACPY( 'Full', N, NRHS, B, LDA, + + S_TEMP_SPOT02, LDA ) + CALL SPOT02( UPLO, N, NRHS, A, LDA, X, LDA, + + S_TEMP_SPOT02, LDA, S_WORK_SPOT02, + + RESULT( 3 ) ) +* +* Check solution from generated exact solution. + + CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + + RESULT( 4 ) ) + NT = 4 +* +* Print information about the tests that did not +* pass the threshold. +* + DO 60 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + + CALL ALADHD( NOUT, 'SPF' ) + WRITE( NOUT, FMT = 9999 )'SPFSV ', UPLO, + + N, IIT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 60 CONTINUE + NRUN = NRUN + NT + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 980 CONTINUE + 130 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( 'SPF', NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A6, ', UPLO=''', A1, ''', N =', I5, ', type ', I1, + + ', test(', I1, ')=', G12.5 ) +* + RETURN +* +* End of SDRVRFP +* + END diff --git a/TESTING/LIN/sdrvsp.f b/TESTING/LIN/sdrvsp.f index 24319344..764d29f3 100644 --- a/TESTING/LIN/sdrvsp.f +++ b/TESTING/LIN/sdrvsp.f @@ -113,7 +113,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/sdrvsy.f b/TESTING/LIN/sdrvsy.f index 737eb929..8b4e5e04 100644 --- a/TESTING/LIN/sdrvsy.f +++ b/TESTING/LIN/sdrvsy.f @@ -110,7 +110,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/sebchvxx.f b/TESTING/LIN/sebchvxx.f new file mode 100644 index 00000000..19be0141 --- /dev/null +++ b/TESTING/LIN/sebchvxx.f @@ -0,0 +1,462 @@ + SUBROUTINE SEBCHVXX( THRESH, PATH ) + IMPLICIT NONE +* .. Scalar Arguments .. + REAL THRESH + CHARACTER*3 PATH +* +* Purpose +* ====== +* +* SEBCHVXX will run S**SVXX on a series of Hilbert matrices and then +* compare the error bounds returned by SGESVXX to see if the returned +* answer indeed falls within those bounds. +* +* Eight test ratios will be computed. The tests will pass if they are .LT. +* THRESH. There are two cases that are determined by 1 / (SQRT( N ) * EPS). +* If that value is .LE. to the component wise reciprocal condition number, +* it uses the guaranteed case, other wise it uses the unguaranteed case. +* +* Test ratios: +* Let Xc be X_computed and Xt be X_truth. +* The norm used is the infinity norm. + +* Let A be the guaranteed case and B be the unguaranteed case. +* +* 1. Normwise guaranteed forward error bound. +* A: norm ( abs( Xc - Xt ) / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ) and +* ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N),10) * EPS. +* If these conditions are met, the test ratio is set to be +* ERRBND( *, nwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. +* B: For this case, SGESVXX should just return 1. If it is less than +* one, treat it the same as in 1A. Otherwise it fails. (Set test +* ratio to ERRBND( *, nwise_i, bnd_i ) * THRESH?) +* +* 2. Componentwise guaranteed forward error bound. +* A: norm ( abs( Xc(j) - Xt(j) ) ) / norm (Xt(j)) .LE. ERRBND( *, cwise_i, bnd_i ) +* for all j .AND. ERRBND( *, cwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS. +* If these conditions are met, the test ratio is set to be +* ERRBND( *, cwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. +* B: Same as normwise test ratio. +* +* 3. Backwards error. +* A: The test ratio is set to BERR/EPS. +* B: Same test ratio. +* +* 4. Reciprocal condition number. +* A: A condition number is computed with Xt and compared with the one +* returned from SGESVXX. Let RCONDc be the RCOND returned by SGESVXX +* and RCONDt be the RCOND from the truth value. Test ratio is set to +* MAX(RCONDc/RCONDt, RCONDt/RCONDc). +* B: Test ratio is set to 1 / (EPS * RCONDc). +* +* 5. Reciprocal normwise condition number. +* A: The test ratio is set to +* MAX(ERRBND( *, nwise_i, cond_i ) / NCOND, NCOND / ERRBND( *, nwise_i, cond_i )). +* B: Test ratio is set to 1 / (EPS * ERRBND( *, nwise_i, cond_i )). +* +* 7. Reciprocal componentwise condition number. +* A: Test ratio is set to +* MAX(ERRBND( *, cwise_i, cond_i ) / CCOND, CCOND / ERRBND( *, cwise_i, cond_i )). +* B: Test ratio is set to 1 / (EPS * ERRBND( *, cwise_i, cond_i )). +* +* .. Parameters .. +* NMAX is determined by the largest number in the inverse of the Hilbert +* matrix. Precision is exhausted when the largest entry in it is greater +* than 2 to the power of the number of bits in the fraction of the data +* type used plus one, which is 24 for single precision. +* NMAX should be 6 for single and 11 for double. + + INTEGER NMAX, NPARAMS, NERRBND, NTESTS, KL, KU + PARAMETER (NMAX = 6, NPARAMS = 2, NERRBND = 3, + $ NTESTS = 6) + +* .. Local Scalars .. + INTEGER N, NRHS, INFO, I ,J, k, NFAIL, LDA, LDAB, + $ LDAFB, N_AUX_TESTS + CHARACTER FACT, TRANS, UPLO, EQUED + CHARACTER*2 C2 + CHARACTER(3) NGUAR, CGUAR + LOGICAL printed_guide + REAL NCOND, CCOND, M, NORMDIF, NORMT, RCOND, + $ RNORM, RINORM, SUMR, SUMRI, EPS, + $ BERR(NMAX), RPVGRW, ORCOND, + $ CWISE_ERR, NWISE_ERR, CWISE_BND, NWISE_BND, + $ CWISE_RCOND, NWISE_RCOND, + $ CONDTHRESH, ERRTHRESH + +* .. Local Arrays .. + REAL TSTRAT(NTESTS), RINV(NMAX), PARAMS(NPARAMS), + $ A(NMAX, NMAX), ACOPY(NMAX, NMAX), + $ INVHILB(NMAX, NMAX), R(NMAX), C(NMAX), S(NMAX), + $ WORK(NMAX * 5), B(NMAX, NMAX), X(NMAX, NMAX), + $ DIFF(NMAX, NMAX), AF(NMAX, NMAX), + $ AB( (NMAX-1)+(NMAX-1)+1, NMAX ), + $ ABCOPY( (NMAX-1)+(NMAX-1)+1, NMAX ), + $ AFB( 2*(NMAX-1)+(NMAX-1)+1, NMAX ), + $ ERRBND_N(NMAX*3), ERRBND_C(NMAX*3) + INTEGER IWORK(NMAX), IPIV(NMAX) + +* .. External Functions .. + REAL SLAMCH + +* .. External Subroutines .. + EXTERNAL SLAHILB, SGESVXX, SSYSVXX, SPOSVXX, SGBSVXX, + $ SLACPY, LSAMEN + LOGICAL LSAMEN + +* .. Intrinsic Functions .. + INTRINSIC SQRT, MAX, ABS + +* .. Parameters .. + INTEGER NWISE_I, CWISE_I + PARAMETER (NWISE_I = 1, CWISE_I = 1) + INTEGER BND_I, COND_I + PARAMETER (BND_I = 2, COND_I = 3) + +* Create the loop to test out the Hilbert matrices + + FACT = 'E' + UPLO = 'U' + TRANS = 'N' + EQUED = 'N' + EPS = SLAMCH('Epsilon') + NFAIL = 0 + N_AUX_TESTS = 0 + LDA = NMAX + LDAB = (NMAX-1)+(NMAX-1)+1 + LDAFB = 2*(NMAX-1)+(NMAX-1)+1 + C2 = PATH( 2: 3 ) + +* Main loop to test the different Hilbert Matrices. + + printed_guide = .false. + + DO N = 1 , NMAX + PARAMS(1) = -1 + PARAMS(2) = -1 + + KL = N-1 + KU = N-1 + NRHS = n + M = MAX(SQRT(REAL(N)), 10.0) + +* Generate the Hilbert matrix, its inverse, and the +* right hand side, all scaled by the LCM(1,..,2N-1). + CALL SLAHILB(N, N, A, LDA, INVHILB, LDA, B, LDA, WORK, INFO) + +* Copy A into ACOPY. + CALL SLACPY('ALL', N, N, A, NMAX, ACOPY, NMAX) + +* Store A in band format for GB tests + DO J = 1, N + DO I = 1, KL+KU+1 + AB( I, J ) = 0.0E+0 + END DO + END DO + DO J = 1, N + DO I = MAX( 1, J-KU ), MIN( N, J+KL ) + AB( KU+1+I-J, J ) = A( I, J ) + END DO + END DO + +* Copy AB into ABCOPY. + DO J = 1, N + DO I = 1, KL+KU+1 + ABCOPY( I, J ) = 0.0E+0 + END DO + END DO + CALL SLACPY('ALL', KL+KU+1, N, AB, LDAB, ABCOPY, LDAB) + +* Call S**SVXX with default PARAMS and N_ERR_BND = 3. + IF ( LSAMEN( 2, C2, 'SY' ) ) THEN + CALL SSYSVXX(FACT, UPLO, N, NRHS, ACOPY, LDA, AF, LDA, + $ IPIV, EQUED, S, B, LDA, X, LDA, ORCOND, + $ RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS, + $ PARAMS, WORK, IWORK, INFO) + ELSE IF ( LSAMEN( 2, C2, 'PO' ) ) THEN + CALL SPOSVXX(FACT, UPLO, N, NRHS, ACOPY, LDA, AF, LDA, + $ EQUED, S, B, LDA, X, LDA, ORCOND, + $ RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS, + $ PARAMS, WORK, IWORK, INFO) + ELSE IF ( LSAMEN( 2, C2, 'GB' ) ) THEN + CALL SGBSVXX(FACT, TRANS, N, KL, KU, NRHS, ABCOPY, + $ LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, + $ LDA, X, LDA, ORCOND, RPVGRW, BERR, NERRBND, + $ ERRBND_N, ERRBND_C, NPARAMS, PARAMS, WORK, IWORK, + $ INFO) + ELSE + CALL SGESVXX(FACT, TRANS, N, NRHS, ACOPY, LDA, AF, LDA, + $ IPIV, EQUED, R, C, B, LDA, X, LDA, ORCOND, + $ RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS, + $ PARAMS, WORK, IWORK, INFO) + END IF + + N_AUX_TESTS = N_AUX_TESTS + 1 + IF (ORCOND .LT. EPS) THEN +! Either factorization failed or the matrix is flagged, and 1 <= +! INFO <= N+1. We don't decide based on rcond anymore. +! IF (INFO .EQ. 0 .OR. INFO .GT. N+1) THEN +! NFAIL = NFAIL + 1 +! WRITE (*, FMT=8000) N, INFO, ORCOND, RCOND +! END IF + ELSE +! Either everything succeeded (INFO == 0) or some solution failed +! to converge (INFO > N+1). + IF (INFO .GT. 0 .AND. INFO .LE. N+1) THEN + NFAIL = NFAIL + 1 + WRITE (*, FMT=8000) C2, N, INFO, ORCOND, RCOND + END IF + END IF + +* Calculating the difference between S**SVXX's X and the true X. + DO I = 1, N + DO J = 1, NRHS + DIFF( I, J ) = X( I, J ) - INVHILB( I, J ) + END DO + END DO + +* Calculating the RCOND + RNORM = 0 + RINORM = 0 + IF ( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'SY' ) ) THEN + DO I = 1, N + SUMR = 0 + SUMRI = 0 + DO J = 1, N + SUMR = SUMR + ABS(S(I) * A(I,J) * S(J)) + SUMRI = SUMRI + ABS(INVHILB(I, J) / S(J) / S(I)) + END DO + RNORM = MAX(RNORM,SUMR) + RINORM = MAX(RINORM,SUMRI) + END DO + ELSE IF ( LSAMEN( 2, C2, 'GE' ) .OR. LSAMEN( 2, C2, 'GB' ) ) + $ THEN + DO I = 1, N + SUMR = 0 + SUMRI = 0 + DO J = 1, N + SUMR = SUMR + ABS(R(I) * A(I,J) * C(J)) + SUMRI = SUMRI + ABS(INVHILB(I, J) / R(J) / C(I)) + END DO + RNORM = MAX(RNORM,SUMR) + RINORM = MAX(RINORM,SUMRI) + END DO + END IF + + RNORM = RNORM / A(1, 1) + RCOND = 1.0/(RNORM * RINORM) + +* Calculating the R for normwise rcond. + DO I = 1, N + RINV(I) = 0.0 + END DO + DO J = 1, N + DO I = 1, N + RINV(I) = RINV(I) + ABS(A(I,J)) + END DO + END DO + +* Calculating the Normwise rcond. + RINORM = 0.0 + DO I = 1, N + SUMRI = 0.0 + DO J = 1, N + SUMRI = SUMRI + ABS(INVHILB(I,J) * RINV(J)) + END DO + RINORM = MAX(RINORM, SUMRI) + END DO + +! invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm +! by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) + NCOND = A(1,1) / RINORM + + CONDTHRESH = M * EPS + ERRTHRESH = M * EPS + + DO K = 1, NRHS + NORMT = 0.0 + NORMDIF = 0.0 + CWISE_ERR = 0.0 + DO I = 1, N + NORMT = MAX(ABS(INVHILB(I, K)), NORMT) + NORMDIF = MAX(ABS(X(I,K) - INVHILB(I,K)), NORMDIF) + IF (INVHILB(I,K) .NE. 0.0) THEN + CWISE_ERR = MAX(ABS(X(I,K) - INVHILB(I,K)) + $ /ABS(INVHILB(I,K)), CWISE_ERR) + ELSE IF (X(I, K) .NE. 0.0) THEN + CWISE_ERR = SLAMCH('OVERFLOW') + END IF + END DO + IF (NORMT .NE. 0.0) THEN + NWISE_ERR = NORMDIF / NORMT + ELSE IF (NORMDIF .NE. 0.0) THEN + NWISE_ERR = SLAMCH('OVERFLOW') + ELSE + NWISE_ERR = 0.0 + ENDIF + + DO I = 1, N + RINV(I) = 0.0 + END DO + DO J = 1, N + DO I = 1, N + RINV(I) = RINV(I) + ABS(A(I, J) * INVHILB(J, K)) + END DO + END DO + RINORM = 0.0 + DO I = 1, N + SUMRI = 0.0 + DO J = 1, N + SUMRI = SUMRI + $ + ABS(INVHILB(I, J) * RINV(J) / INVHILB(I, K)) + END DO + RINORM = MAX(RINORM, SUMRI) + END DO +! invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm +! by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) + CCOND = A(1,1)/RINORM + +! Forward error bound tests + NWISE_BND = ERRBND_N(K + (BND_I-1)*NRHS) + CWISE_BND = ERRBND_C(K + (BND_I-1)*NRHS) + NWISE_RCOND = ERRBND_N(K + (COND_I-1)*NRHS) + CWISE_RCOND = ERRBND_C(K + (COND_I-1)*NRHS) +! write (*,*) 'nwise : ', n, k, ncond, nwise_rcond, +! $ condthresh, ncond.ge.condthresh +! write (*,*) 'nwise2: ', k, nwise_bnd, nwise_err, errthresh + + IF (NCOND .GE. CONDTHRESH) THEN + NGUAR = 'YES' + IF (NWISE_BND .GT. ERRTHRESH) THEN + TSTRAT(1) = 1/(2.0*EPS) + ELSE + + IF (NWISE_BND .NE. 0.0) THEN + TSTRAT(1) = NWISE_ERR / NWISE_BND + ELSE IF (NWISE_ERR .NE. 0.0) THEN + TSTRAT(1) = 1/(16.0*EPS) + ELSE + TSTRAT(1) = 0.0 + END IF + IF (TSTRAT(1) .GT. 1.0) THEN + TSTRAT(1) = 1/(4.0*EPS) + END IF + END IF + ELSE + NGUAR = 'NO' + IF (NWISE_BND .LT. 1.0) THEN + TSTRAT(1) = 1/(8.0*EPS) + ELSE + TSTRAT(1) = 1.0 + END IF + END IF +! write (*,*) 'cwise : ', n, k, ccond, cwise_rcond, +! $ condthresh, ccond.ge.condthresh +! write (*,*) 'cwise2: ', k, cwise_bnd, cwise_err, errthresh + IF (CCOND .GE. CONDTHRESH) THEN + CGUAR = 'YES' + + IF (CWISE_BND .GT. ERRTHRESH) THEN + TSTRAT(2) = 1/(2.0*EPS) + ELSE + IF (CWISE_BND .NE. 0.0) THEN + TSTRAT(2) = CWISE_ERR / CWISE_BND + ELSE IF (CWISE_ERR .NE. 0.0) THEN + TSTRAT(2) = 1/(16.0*EPS) + ELSE + TSTRAT(2) = 0.0 + END IF + IF (TSTRAT(2) .GT. 1.0) TSTRAT(2) = 1/(4.0*EPS) + END IF + ELSE + CGUAR = 'NO' + IF (CWISE_BND .LT. 1.0) THEN + TSTRAT(2) = 1/(8.0*EPS) + ELSE + TSTRAT(2) = 1.0 + END IF + END IF + +! Backwards error test + TSTRAT(3) = BERR(K)/EPS + +! Condition number tests + TSTRAT(4) = RCOND / ORCOND + IF (RCOND .GE. CONDTHRESH .AND. TSTRAT(4) .LT. 1.0) + $ TSTRAT(4) = 1.0 / TSTRAT(4) + + TSTRAT(5) = NCOND / NWISE_RCOND + IF (NCOND .GE. CONDTHRESH .AND. TSTRAT(5) .LT. 1.0) + $ TSTRAT(5) = 1.0 / TSTRAT(5) + + TSTRAT(6) = CCOND / NWISE_RCOND + IF (CCOND .GE. CONDTHRESH .AND. TSTRAT(6) .LT. 1.0) + $ TSTRAT(6) = 1.0 / TSTRAT(6) + + DO I = 1, NTESTS + IF (TSTRAT(I) .GT. THRESH) THEN + IF (.NOT.PRINTED_GUIDE) THEN + WRITE(*,*) + WRITE( *, 9996) 1 + WRITE( *, 9995) 2 + WRITE( *, 9994) 3 + WRITE( *, 9993) 4 + WRITE( *, 9992) 5 + WRITE( *, 9991) 6 + WRITE( *, 9990) 7 + WRITE( *, 9989) 8 + WRITE(*,*) + PRINTED_GUIDE = .TRUE. + END IF + WRITE( *, 9999) C2, N, K, NGUAR, CGUAR, I, TSTRAT(I) + NFAIL = NFAIL + 1 + END IF + END DO + END DO + +c$$$ WRITE(*,*) +c$$$ WRITE(*,*) 'Normwise Error Bounds' +c$$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,nwise_i,bnd_i) +c$$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,nwise_i,cond_i) +c$$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,nwise_i,rawbnd_i) +c$$$ WRITE(*,*) +c$$$ WRITE(*,*) 'Componentwise Error Bounds' +c$$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,cwise_i,bnd_i) +c$$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,cwise_i,cond_i) +c$$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,cwise_i,rawbnd_i) +c$$$ print *, 'Info: ', info +c$$$ WRITE(*,*) +* WRITE(*,*) 'TSTRAT: ',TSTRAT + + END DO + + WRITE(*,*) + IF( NFAIL .GT. 0 ) THEN + WRITE(*,9998) C2, NFAIL, NTESTS*N+N_AUX_TESTS + ELSE + WRITE(*,9997) C2 + END IF + 9999 FORMAT( ' S', A2, 'SVXX: N =', I2, ', RHS = ', I2, + $ ', NWISE GUAR. = ', A, ', CWISE GUAR. = ', A, + $ ' test(',I1,') =', G12.5 ) + 9998 FORMAT( ' S', A2, 'SVXX: ', I6, ' out of ', I6, + $ ' tests failed to pass the threshold' ) + 9997 FORMAT( ' S', A2, 'SVXX passed the tests of error bounds' ) +* Test ratios. + 9996 FORMAT( 3X, I2, ': Normwise guaranteed forward error', / 5X, + $ 'Guaranteed case: if norm ( abs( Xc - Xt )', + $ ' / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ), then', + $ / 5X, + $ 'ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS') + 9995 FORMAT( 3X, I2, ': Componentwise guaranteed forward error' ) + 9994 FORMAT( 3X, I2, ': Backwards error' ) + 9993 FORMAT( 3X, I2, ': Reciprocal condition number' ) + 9992 FORMAT( 3X, I2, ': Reciprocal normwise condition number' ) + 9991 FORMAT( 3X, I2, ': Raw normwise error estimate' ) + 9990 FORMAT( 3X, I2, ': Reciprocal componentwise condition number' ) + 9989 FORMAT( 3X, I2, ': Raw componentwise error estimate' ) + + 8000 FORMAT( ' S', A2, 'SVXX: N =', I2, ', INFO = ', I3, + $ ', ORCOND = ', G12.5, ', real RCOND = ', G12.5 ) + + END diff --git a/TESTING/LIN/serrge.f b/TESTING/LIN/serrge.f index 7be69008..41476e8b 100644 --- a/TESTING/LIN/serrge.f +++ b/TESTING/LIN/serrge.f @@ -51,7 +51,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/serrgex.f b/TESTING/LIN/serrgex.f new file mode 100644 index 00000000..873292a0 --- /dev/null +++ b/TESTING/LIN/serrgex.f @@ -0,0 +1,524 @@ + SUBROUTINE SERRGE( PATH, NUNIT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* Purpose +* ======= +* +* SERRGE tests the error exits for the REAL routines +* for general matrices. +* +* Note that this file is used only when the XBLAS are available, +* otherwise serrge.f defines this subroutine. +* +* Arguments +* ========= +* +* PATH (input) CHARACTER*3 +* The LAPACK path name for the routines to be tested. +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX, LW + PARAMETER ( NMAX = 4, LW = 3*NMAX ) +* .. +* .. Local Scalars .. + CHARACTER EQ + CHARACTER*2 C2 + INTEGER I, INFO, J, N_ERR_BNDS, NPARAMS + REAL ANRM, CCOND, RCOND, BERR +* .. +* .. 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( LW ), X( NMAX ), ERR_BNDS_N( NMAX, 3 ), + $ ERR_BNDS_C( NMAX, 3 ), PARAMS( 1 ) +* .. +* .. External Functions .. + LOGICAL LSAMEN + EXTERNAL LSAMEN +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, SGBCON, SGBEQU, SGBRFS, SGBTF2, + $ SGBTRF, SGBTRS, SGECON, SGEEQU, SGERFS, SGETF2, + $ SGETRF, SGETRI, SGETRS, SGEEQUB, SGERFSX, + $ SGBEQUB, SGBRFSX +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) + C2 = PATH( 2: 3 ) +* +* Set the variables to innocuous values. +* + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + 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. + IP( J ) = J + IW( J ) = J + 20 CONTINUE + OK = .TRUE. +* + IF( LSAMEN( 2, C2, 'GE' ) ) THEN +* +* Test error exits of the routines that use the LU decomposition +* of a general matrix. +* +* SGETRF +* + SRNAMT = 'SGETRF' + INFOT = 1 + CALL SGETRF( -1, 0, A, 1, IP, INFO ) + CALL CHKXER( 'SGETRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGETRF( 0, -1, A, 1, IP, INFO ) + CALL CHKXER( 'SGETRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGETRF( 2, 1, A, 1, IP, INFO ) + CALL CHKXER( 'SGETRF', INFOT, NOUT, LERR, OK ) +* +* SGETF2 +* + SRNAMT = 'SGETF2' + INFOT = 1 + CALL SGETF2( -1, 0, A, 1, IP, INFO ) + CALL CHKXER( 'SGETF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGETF2( 0, -1, A, 1, IP, INFO ) + CALL CHKXER( 'SGETF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGETF2( 2, 1, A, 1, IP, INFO ) + CALL CHKXER( 'SGETF2', INFOT, NOUT, LERR, OK ) +* +* SGETRI +* + SRNAMT = 'SGETRI' + INFOT = 1 + CALL SGETRI( -1, A, 1, IP, W, LW, INFO ) + CALL CHKXER( 'SGETRI', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGETRI( 2, A, 1, IP, W, LW, INFO ) + CALL CHKXER( 'SGETRI', INFOT, NOUT, LERR, OK ) +* +* SGETRS +* + SRNAMT = 'SGETRS' + INFOT = 1 + CALL SGETRS( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SGETRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGETRS( 'N', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SGETRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGETRS( 'N', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SGETRS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGETRS( 'N', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'SGETRS', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SGETRS( 'N', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'SGETRS', INFOT, NOUT, LERR, OK ) +* +* SGERFS +* + SRNAMT = 'SGERFS' + INFOT = 1 + CALL SGERFS( '/', 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'SGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGERFS( 'N', -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, + $ W, IW, INFO ) + CALL CHKXER( 'SGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGERFS( 'N', 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, + $ W, IW, INFO ) + CALL CHKXER( 'SGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGERFS( 'N', 2, 1, A, 1, AF, 2, IP, B, 2, X, 2, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'SGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SGERFS( 'N', 2, 1, A, 2, AF, 1, IP, B, 2, X, 2, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'SGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SGERFS( 'N', 2, 1, A, 2, AF, 2, IP, B, 1, X, 2, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'SGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SGERFS( 'N', 2, 1, A, 2, AF, 2, IP, B, 2, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'SGERFS', INFOT, NOUT, LERR, OK ) +* +* SGERFSX +* + n_err_bnds = 3 + nparams = 0 + SRNAMT = 'SGERFSX' + INFOT = 1 + CALL SGERFSX( '/', EQ, 0, 0, A, 1, AF, 1, IP, R, C, B, 1, X, + $ 1, RCOND, berr, n_err_bnds, err_bnds_n, err_bnds_c, + $ nparams, params, W, IW, INFO ) + CALL CHKXER( 'SGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 2 + EQ = '/' + CALL SGERFSX( 'N', EQ, 2, 1, A, 1, AF, 2, IP, R, C, B, 2, X, + $ 2, RCOND, berr, n_err_bnds, err_bnds_n, err_bnds_c, + $ nparams, params, W, IW, INFO ) + CALL CHKXER( 'SGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 3 + EQ = 'R' + CALL SGERFSX( 'N', EQ, -1, 0, A, 1, AF, 1, IP, R, C, B, 1, X, + $ 1, RCOND, berr, n_err_bnds, err_bnds_n, err_bnds_c, + $ nparams, params, W, IW, INFO ) + CALL CHKXER( 'SGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGERFSX( 'N', EQ, 0, -1, A, 1, AF, 1, IP, R, C, B, 1, X, + $ 1, RCOND, berr, n_err_bnds, err_bnds_n, err_bnds_c, + $ nparams, params, W, IW, INFO ) + CALL CHKXER( 'SGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SGERFSX( 'N', EQ, 2, 1, A, 1, AF, 2, IP, R, C, B, 2, X, + $ 2, RCOND, berr, n_err_bnds, err_bnds_n, err_bnds_c, + $ nparams, params, W, IW, INFO ) + CALL CHKXER( 'SGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SGERFSX( 'N', EQ, 2, 1, A, 2, AF, 1, IP, R, C, B, 2, X, + $ 2, RCOND, berr, n_err_bnds, err_bnds_n, err_bnds_c, + $ nparams, params, W, IW, INFO ) + CALL CHKXER( 'SGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 13 + EQ = 'C' + CALL SGERFSX( 'N', EQ, 2, 1, A, 2, AF, 2, IP, R, C, B, 1, X, + $ 2, RCOND, berr, n_err_bnds, err_bnds_n, err_bnds_c, + $ nparams, params, W, IW, INFO ) + CALL CHKXER( 'SGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL SGERFSX( 'N', EQ, 2, 1, A, 2, AF, 2, IP, R, C, B, 2, X, + $ 1, RCOND, berr, n_err_bnds, err_bnds_n, err_bnds_c, + $ nparams, params, W, IW, INFO ) + CALL CHKXER( 'SGERFSX', INFOT, NOUT, LERR, OK ) +* +* SGECON +* + SRNAMT = 'SGECON' + INFOT = 1 + CALL SGECON( '/', 0, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SGECON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGECON( '1', -1, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SGECON', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGECON( '1', 2, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SGECON', INFOT, NOUT, LERR, OK ) +* +* SGEEQU +* + SRNAMT = 'SGEEQU' + INFOT = 1 + CALL SGEEQU( -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'SGEEQU', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGEEQU( 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'SGEEQU', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGEEQU( 2, 2, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'SGEEQU', INFOT, NOUT, LERR, OK ) +* +* SGEEQUB +* + SRNAMT = 'SGEEQUB' + INFOT = 1 + CALL SGEEQUB( -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'SGEEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGEEQUB( 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'SGEEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGEEQUB( 2, 2, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'SGEEQUB', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN +* +* Test error exits of the routines that use the LU decomposition +* of a general band matrix. +* +* SGBTRF +* + SRNAMT = 'SGBTRF' + INFOT = 1 + CALL SGBTRF( -1, 0, 0, 0, A, 1, IP, INFO ) + CALL CHKXER( 'SGBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGBTRF( 0, -1, 0, 0, A, 1, IP, INFO ) + CALL CHKXER( 'SGBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGBTRF( 1, 1, -1, 0, A, 1, IP, INFO ) + CALL CHKXER( 'SGBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGBTRF( 1, 1, 0, -1, A, 1, IP, INFO ) + CALL CHKXER( 'SGBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SGBTRF( 2, 2, 1, 1, A, 3, IP, INFO ) + CALL CHKXER( 'SGBTRF', INFOT, NOUT, LERR, OK ) +* +* SGBTF2 +* + SRNAMT = 'SGBTF2' + INFOT = 1 + CALL SGBTF2( -1, 0, 0, 0, A, 1, IP, INFO ) + CALL CHKXER( 'SGBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGBTF2( 0, -1, 0, 0, A, 1, IP, INFO ) + CALL CHKXER( 'SGBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGBTF2( 1, 1, -1, 0, A, 1, IP, INFO ) + CALL CHKXER( 'SGBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGBTF2( 1, 1, 0, -1, A, 1, IP, INFO ) + CALL CHKXER( 'SGBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SGBTF2( 2, 2, 1, 1, A, 3, IP, INFO ) + CALL CHKXER( 'SGBTF2', INFOT, NOUT, LERR, OK ) +* +* SGBTRS +* + SRNAMT = 'SGBTRS' + INFOT = 1 + CALL SGBTRS( '/', 0, 0, 0, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGBTRS( 'N', -1, 0, 0, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGBTRS( 'N', 1, -1, 0, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGBTRS( 'N', 1, 0, -1, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGBTRS( 'N', 1, 0, 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SGBTRS( 'N', 2, 1, 1, 1, A, 3, IP, B, 2, INFO ) + CALL CHKXER( 'SGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SGBTRS( 'N', 2, 0, 0, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'SGBTRS', INFOT, NOUT, LERR, OK ) +* +* SGBRFS +* + SRNAMT = 'SGBRFS' + INFOT = 1 + CALL SGBRFS( '/', 0, 0, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGBRFS( 'N', -1, 0, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGBRFS( 'N', 1, -1, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGBRFS( 'N', 1, 0, -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SGBRFS( 'N', 1, 0, 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SGBRFS( 'N', 2, 1, 1, 1, A, 2, AF, 4, IP, B, 2, X, 2, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SGBRFS( 'N', 2, 1, 1, 1, A, 3, AF, 3, IP, B, 2, X, 2, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SGBRFS( 'N', 2, 0, 0, 1, A, 1, AF, 1, IP, B, 1, X, 2, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 14 + CALL SGBRFS( 'N', 2, 0, 0, 1, A, 1, AF, 1, IP, B, 2, X, 1, R1, + $ R2, W, IW, INFO ) + CALL CHKXER( 'SGBRFS', INFOT, NOUT, LERR, OK ) +* +* SGBRFSX +* + N_ERR_BNDS = 3 + NPARAMS = 0 + SRNAMT = 'SGBRFSX' + INFOT = 1 + CALL SGBRFSX( '/', EQ, 0, 0, 0, 0, A, 1, AF, 1, IP, R, C, B, 1, + $ X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'SGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 2 + EQ = '/' + CALL SGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 1, AF, 2, IP, R, C, B, 2, + $ X, 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'SGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 3 + EQ = 'R' + CALL SGBRFSX( 'N', EQ, -1, 1, 1, 0, A, 1, AF, 1, IP, R, C, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'SGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 4 + EQ = 'R' + CALL SGBRFSX( 'N', EQ, 2, -1, 1, 1, A, 3, AF, 4, IP, R, C, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'SGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 5 + EQ = 'R' + CALL SGBRFSX( 'N', EQ, 2, 1, -1, 1, A, 3, AF, 4, IP, R, C, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'SGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SGBRFSX( 'N', EQ, 0, 0, 0, -1, A, 1, AF, 1, IP, R, C, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'SGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 1, AF, 2, IP, R, C, B, + $ 2, X, 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'SGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 3, AF, 3, IP, R, C, B, 2, + $ X, 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'SGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 13 + EQ = 'C' + CALL SGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 3, AF, 5, IP, R, C, B, + $ 1, X, 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'SGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL SGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 3, AF, 5, IP, R, C, B, 2, + $ X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, IW, INFO ) + CALL CHKXER( 'SGBRFSX', INFOT, NOUT, LERR, OK ) +* +* SGBCON +* + SRNAMT = 'SGBCON' + INFOT = 1 + CALL SGBCON( '/', 0, 0, 0, A, 1, IP, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SGBCON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGBCON( '1', -1, 0, 0, A, 1, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'SGBCON', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGBCON( '1', 1, -1, 0, A, 1, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'SGBCON', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGBCON( '1', 1, 0, -1, A, 1, IP, ANRM, RCOND, W, IW, + $ INFO ) + CALL CHKXER( 'SGBCON', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SGBCON( '1', 2, 1, 1, A, 3, IP, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SGBCON', INFOT, NOUT, LERR, OK ) +* +* SGBEQU +* + SRNAMT = 'SGBEQU' + INFOT = 1 + CALL SGBEQU( -1, 0, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'SGBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGBEQU( 0, -1, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'SGBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGBEQU( 1, 1, -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'SGBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGBEQU( 1, 1, 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'SGBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SGBEQU( 2, 2, 1, 1, A, 2, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'SGBEQU', INFOT, NOUT, LERR, OK ) +* +* SGBEQUB +* + SRNAMT = 'SGBEQUB' + INFOT = 1 + CALL SGBEQUB( -1, 0, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'SGBEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SGBEQUB( 0, -1, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'SGBEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SGBEQUB( 1, 1, -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'SGBEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SGBEQUB( 1, 1, 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'SGBEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SGBEQUB( 2, 2, 1, 1, A, 2, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'SGBEQUB', INFOT, NOUT, LERR, OK ) + END IF +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of SERRGE +* + END diff --git a/TESTING/LIN/serrgt.f b/TESTING/LIN/serrgt.f index 0b742430..894f6f26 100644 --- a/TESTING/LIN/serrgt.f +++ b/TESTING/LIN/serrgt.f @@ -51,7 +51,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/serrlq.f b/TESTING/LIN/serrlq.f index be56bc8b..94f1d3fa 100644 --- a/TESTING/LIN/serrlq.f +++ b/TESTING/LIN/serrlq.f @@ -43,7 +43,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/serrls.f b/TESTING/LIN/serrls.f index a21e9bac..314b1a34 100644 --- a/TESTING/LIN/serrls.f +++ b/TESTING/LIN/serrls.f @@ -50,7 +50,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/serrpo.f b/TESTING/LIN/serrpo.f index 2651251c..4319cb2c 100644 --- a/TESTING/LIN/serrpo.f +++ b/TESTING/LIN/serrpo.f @@ -52,7 +52,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/serrpox.f b/TESTING/LIN/serrpox.f new file mode 100644 index 00000000..03b56e33 --- /dev/null +++ b/TESTING/LIN/serrpox.f @@ -0,0 +1,487 @@ + SUBROUTINE SERRPO( PATH, NUNIT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* Purpose +* ======= +* +* SERRPO tests the error exits for the REAL routines +* for symmetric positive definite matrices. +* +* Arguments +* ========= +* +* PATH (input) CHARACTER*3 +* The LAPACK path name for the routines to be tested. +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 4 ) +* .. +* .. Local Scalars .. + CHARACTER EQ + CHARACTER*2 C2 + INTEGER I, INFO, J, N_ERR_BNDS, NPARAMS + REAL ANRM, RCOND, BERR +* .. +* .. Local Arrays .. + INTEGER 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 ), + $ ERR_BNDS_C( NMAX, 3 ), PARAMS +* .. +* .. External Functions .. + LOGICAL LSAMEN + EXTERNAL LSAMEN +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, SPBCON, SPBEQU, SPBRFS, SPBTF2, + $ SPBTRF, SPBTRS, SPOCON, SPOEQU, SPORFS, SPOTF2, + $ SPOTRF, SPOTRI, SPOTRS, SPPCON, SPPEQU, SPPRFS, + $ SPPTRF, SPPTRI, SPPTRS, SPOEQUB, SPORFSX +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) + C2 = PATH( 2: 3 ) +* +* Set the variables to innocuous values. +* + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + 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. + IW( J ) = J + 20 CONTINUE + OK = .TRUE. +* + IF( LSAMEN( 2, C2, 'PO' ) ) THEN +* +* Test error exits of the routines that use the Cholesky +* decomposition of a symmetric positive definite matrix. +* +* SPOTRF +* + SRNAMT = 'SPOTRF' + INFOT = 1 + CALL SPOTRF( '/', 0, A, 1, INFO ) + CALL CHKXER( 'SPOTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPOTRF( 'U', -1, A, 1, INFO ) + CALL CHKXER( 'SPOTRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SPOTRF( 'U', 2, A, 1, INFO ) + CALL CHKXER( 'SPOTRF', INFOT, NOUT, LERR, OK ) +* +* SPOTF2 +* + SRNAMT = 'SPOTF2' + INFOT = 1 + CALL SPOTF2( '/', 0, A, 1, INFO ) + CALL CHKXER( 'SPOTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPOTF2( 'U', -1, A, 1, INFO ) + CALL CHKXER( 'SPOTF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SPOTF2( 'U', 2, A, 1, INFO ) + CALL CHKXER( 'SPOTF2', INFOT, NOUT, LERR, OK ) +* +* SPOTRI +* + SRNAMT = 'SPOTRI' + INFOT = 1 + CALL SPOTRI( '/', 0, A, 1, INFO ) + CALL CHKXER( 'SPOTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPOTRI( 'U', -1, A, 1, INFO ) + CALL CHKXER( 'SPOTRI', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SPOTRI( 'U', 2, A, 1, INFO ) + CALL CHKXER( 'SPOTRI', INFOT, NOUT, LERR, OK ) +* +* SPOTRS +* + SRNAMT = 'SPOTRS' + INFOT = 1 + CALL SPOTRS( '/', 0, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'SPOTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPOTRS( 'U', -1, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'SPOTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SPOTRS( 'U', 0, -1, A, 1, B, 1, INFO ) + CALL CHKXER( 'SPOTRS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SPOTRS( 'U', 2, 1, A, 1, B, 2, INFO ) + CALL CHKXER( 'SPOTRS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SPOTRS( 'U', 2, 1, A, 2, B, 1, INFO ) + CALL CHKXER( 'SPOTRS', INFOT, NOUT, LERR, OK ) +* +* SPORFS +* + SRNAMT = 'SPORFS' + INFOT = 1 + CALL SPORFS( '/', 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'SPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPORFS( 'U', -1, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'SPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SPORFS( 'U', 0, -1, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'SPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SPORFS( 'U', 2, 1, A, 1, AF, 2, B, 2, X, 2, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'SPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SPORFS( 'U', 2, 1, A, 2, AF, 1, B, 2, X, 2, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'SPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SPORFS( 'U', 2, 1, A, 2, AF, 2, B, 1, X, 2, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'SPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SPORFS( 'U', 2, 1, A, 2, AF, 2, B, 2, X, 1, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'SPORFS', INFOT, NOUT, LERR, OK ) +* +* SPORFSX +* + N_ERR_BNDS = 3 + NPARAMS = 0 + SRNAMT = 'SPORFSX' + INFOT = 1 + CALL SPORFSX( '/', EQ, 0, 0, A, 1, AF, 1, S, B, 1, X, 1, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, IW, INFO ) + CALL CHKXER( 'SPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPORFSX( 'U', EQ, -1, 0, A, 1, AF, 1, S, B, 1, X, 1, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, IW, INFO ) + CALL CHKXER( 'SPORFSX', INFOT, NOUT, LERR, OK ) + EQ = 'N' + INFOT = 3 + CALL SPORFSX( 'U', EQ, -1, 0, A, 1, AF, 1, S, B, 1, X, 1, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, IW, INFO ) + CALL CHKXER( 'SPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SPORFSX( 'U', EQ, 0, -1, A, 1, AF, 1, S, B, 1, X, 1, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, IW, INFO ) + CALL CHKXER( 'SPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SPORFSX( 'U', EQ, 2, 1, A, 1, AF, 2, S, B, 2, X, 2, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, IW, INFO ) + CALL CHKXER( 'SPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SPORFSX( 'U', EQ, 2, 1, A, 2, AF, 1, S, B, 2, X, 2, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, IW, INFO ) + CALL CHKXER( 'SPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL SPORFSX( 'U', EQ, 2, 1, A, 2, AF, 2, S, B, 1, X, 2, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, IW, INFO ) + CALL CHKXER( 'SPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL SPORFSX( 'U', EQ, 2, 1, A, 2, AF, 2, S, B, 2, X, 1, + $ RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, NPARAMS, + $ PARAMS, W, IW, INFO ) + CALL CHKXER( 'SPORFSX', INFOT, NOUT, LERR, OK ) +* +* SPOCON +* + SRNAMT = 'SPOCON' + INFOT = 1 + CALL SPOCON( '/', 0, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SPOCON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPOCON( 'U', -1, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SPOCON', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SPOCON( 'U', 2, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SPOCON', INFOT, NOUT, LERR, OK ) +* +* SPOEQU +* + SRNAMT = 'SPOEQU' + INFOT = 1 + CALL SPOEQU( -1, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'SPOEQU', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SPOEQU( 2, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'SPOEQU', INFOT, NOUT, LERR, OK ) +* +* SPOEQUB +* + SRNAMT = 'SPOEQUB' + INFOT = 1 + CALL SPOEQUB( -1, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'SPOEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SPOEQUB( 2, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'SPOEQUB', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN +* +* Test error exits of the routines that use the Cholesky +* decomposition of a symmetric positive definite packed matrix. +* +* SPPTRF +* + SRNAMT = 'SPPTRF' + INFOT = 1 + CALL SPPTRF( '/', 0, A, INFO ) + CALL CHKXER( 'SPPTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPPTRF( 'U', -1, A, INFO ) + CALL CHKXER( 'SPPTRF', INFOT, NOUT, LERR, OK ) +* +* SPPTRI +* + SRNAMT = 'SPPTRI' + INFOT = 1 + CALL SPPTRI( '/', 0, A, INFO ) + CALL CHKXER( 'SPPTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPPTRI( 'U', -1, A, INFO ) + CALL CHKXER( 'SPPTRI', INFOT, NOUT, LERR, OK ) +* +* SPPTRS +* + SRNAMT = 'SPPTRS' + INFOT = 1 + CALL SPPTRS( '/', 0, 0, A, B, 1, INFO ) + CALL CHKXER( 'SPPTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPPTRS( 'U', -1, 0, A, B, 1, INFO ) + CALL CHKXER( 'SPPTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SPPTRS( 'U', 0, -1, A, B, 1, INFO ) + CALL CHKXER( 'SPPTRS', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SPPTRS( 'U', 2, 1, A, B, 1, INFO ) + CALL CHKXER( 'SPPTRS', INFOT, NOUT, LERR, OK ) +* +* SPPRFS +* + SRNAMT = 'SPPRFS' + INFOT = 1 + CALL SPPRFS( '/', 0, 0, A, AF, B, 1, X, 1, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'SPPRFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPPRFS( 'U', -1, 0, A, AF, B, 1, X, 1, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'SPPRFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SPPRFS( 'U', 0, -1, A, AF, B, 1, X, 1, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'SPPRFS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SPPRFS( 'U', 2, 1, A, AF, B, 1, X, 2, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'SPPRFS', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL SPPRFS( 'U', 2, 1, A, AF, B, 2, X, 1, R1, R2, W, IW, + $ INFO ) + CALL CHKXER( 'SPPRFS', INFOT, NOUT, LERR, OK ) +* +* SPPCON +* + SRNAMT = 'SPPCON' + INFOT = 1 + CALL SPPCON( '/', 0, A, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SPPCON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPPCON( 'U', -1, A, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SPPCON', INFOT, NOUT, LERR, OK ) +* +* SPPEQU +* + SRNAMT = 'SPPEQU' + INFOT = 1 + CALL SPPEQU( '/', 0, A, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'SPPEQU', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPPEQU( 'U', -1, A, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'SPPEQU', INFOT, NOUT, LERR, OK ) +* + ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN +* +* Test error exits of the routines that use the Cholesky +* decomposition of a symmetric positive definite band matrix. +* +* SPBTRF +* + SRNAMT = 'SPBTRF' + INFOT = 1 + CALL SPBTRF( '/', 0, 0, A, 1, INFO ) + CALL CHKXER( 'SPBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPBTRF( 'U', -1, 0, A, 1, INFO ) + CALL CHKXER( 'SPBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SPBTRF( 'U', 1, -1, A, 1, INFO ) + CALL CHKXER( 'SPBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SPBTRF( 'U', 2, 1, A, 1, INFO ) + CALL CHKXER( 'SPBTRF', INFOT, NOUT, LERR, OK ) +* +* SPBTF2 +* + SRNAMT = 'SPBTF2' + INFOT = 1 + CALL SPBTF2( '/', 0, 0, A, 1, INFO ) + CALL CHKXER( 'SPBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPBTF2( 'U', -1, 0, A, 1, INFO ) + CALL CHKXER( 'SPBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SPBTF2( 'U', 1, -1, A, 1, INFO ) + CALL CHKXER( 'SPBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SPBTF2( 'U', 2, 1, A, 1, INFO ) + CALL CHKXER( 'SPBTF2', INFOT, NOUT, LERR, OK ) +* +* SPBTRS +* + SRNAMT = 'SPBTRS' + INFOT = 1 + CALL SPBTRS( '/', 0, 0, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'SPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPBTRS( 'U', -1, 0, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'SPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SPBTRS( 'U', 1, -1, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'SPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SPBTRS( 'U', 0, 0, -1, A, 1, B, 1, INFO ) + CALL CHKXER( 'SPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SPBTRS( 'U', 2, 1, 1, A, 1, B, 1, INFO ) + CALL CHKXER( 'SPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SPBTRS( 'U', 2, 0, 1, A, 1, B, 1, INFO ) + CALL CHKXER( 'SPBTRS', INFOT, NOUT, LERR, OK ) +* +* SPBRFS +* + SRNAMT = 'SPBRFS' + INFOT = 1 + CALL SPBRFS( '/', 0, 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'SPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPBRFS( 'U', -1, 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'SPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SPBRFS( 'U', 1, -1, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'SPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SPBRFS( 'U', 0, 0, -1, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'SPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL SPBRFS( 'U', 2, 1, 1, A, 1, AF, 2, B, 2, X, 2, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'SPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SPBRFS( 'U', 2, 1, 1, A, 2, AF, 1, B, 2, X, 2, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'SPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL SPBRFS( 'U', 2, 0, 1, A, 1, AF, 1, B, 1, X, 2, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'SPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL SPBRFS( 'U', 2, 0, 1, A, 1, AF, 1, B, 2, X, 1, R1, R2, W, + $ IW, INFO ) + CALL CHKXER( 'SPBRFS', INFOT, NOUT, LERR, OK ) +* +* SPBCON +* + SRNAMT = 'SPBCON' + INFOT = 1 + CALL SPBCON( '/', 0, 0, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SPBCON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPBCON( 'U', -1, 0, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SPBCON', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SPBCON( 'U', 1, -1, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SPBCON', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SPBCON( 'U', 2, 1, A, 1, ANRM, RCOND, W, IW, INFO ) + CALL CHKXER( 'SPBCON', INFOT, NOUT, LERR, OK ) +* +* SPBEQU +* + SRNAMT = 'SPBEQU' + INFOT = 1 + CALL SPBEQU( '/', 0, 0, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'SPBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPBEQU( 'U', -1, 0, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'SPBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SPBEQU( 'U', 1, -1, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'SPBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SPBEQU( 'U', 2, 1, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'SPBEQU', INFOT, NOUT, LERR, OK ) + END IF +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of SERRPO +* + END diff --git a/TESTING/LIN/serrps.f b/TESTING/LIN/serrps.f new file mode 100644 index 00000000..d2e954d3 --- /dev/null +++ b/TESTING/LIN/serrps.f @@ -0,0 +1,113 @@ + SUBROUTINE SERRPS( PATH, NUNIT ) +* +* -- LAPACK test routine (version 3.1) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + INTEGER NUNIT + CHARACTER*3 PATH +* .. +* +* Purpose +* ======= +* +* SERRPS tests the error exits for the REAL routines +* for SPSTRF.. +* +* Arguments +* ========= +* +* PATH (input) CHARACTER*3 +* The LAPACK path name for the routines to be tested. +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 4 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J +* .. +* .. Local Arrays .. + REAL A( NMAX, NMAX ), WORK( 2*NMAX ) + INTEGER PIV( NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, SPSTF2, SPSTRF +* .. +* .. Scalars in Common .. + INTEGER INFOT, NOUT + LOGICAL LERR, OK + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO 110 J = 1, NMAX + DO 100 I = 1, NMAX + A( I, J ) = 1.0 / REAL( I+J ) +* + 100 CONTINUE + PIV( J ) = J + WORK( J ) = 0. + WORK( NMAX+J ) = 0. +* + 110 CONTINUE + OK = .TRUE. +* +* +* Test error exits of the routines that use the Cholesky +* decomposition of a symmetric positive semidefinite matrix. +* +* SPSTRF +* + SRNAMT = 'SPSTRF' + INFOT = 1 + CALL SPSTRF( '/', 0, A, 1, PIV, 1, -1.0, WORK, INFO ) + CALL CHKXER( 'SPSTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPSTRF( 'U', -1, A, 1, PIV, 1, -1.0, WORK, INFO ) + CALL CHKXER( 'SPSTRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SPSTRF( 'U', 2, A, 1, PIV, 1, -1.0, WORK, INFO ) + CALL CHKXER( 'SPSTRF', INFOT, NOUT, LERR, OK ) +* +* SPSTF2 +* + SRNAMT = 'SPSTF2' + INFOT = 1 + CALL SPSTF2( '/', 0, A, 1, PIV, 1, -1.0, WORK, INFO ) + CALL CHKXER( 'SPSTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPSTF2( 'U', -1, A, 1, PIV, 1, -1.0, WORK, INFO ) + CALL CHKXER( 'SPSTF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SPSTF2( 'U', 2, A, 1, PIV, 1, -1.0, WORK, INFO ) + CALL CHKXER( 'SPSTF2', INFOT, NOUT, LERR, OK ) +* +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of SERRPS +* + END diff --git a/TESTING/LIN/serrql.f b/TESTING/LIN/serrql.f index f3632ed0..96c2ffeb 100644 --- a/TESTING/LIN/serrql.f +++ b/TESTING/LIN/serrql.f @@ -43,7 +43,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/serrqp.f b/TESTING/LIN/serrqp.f index 25ee6aaa..cea578ac 100644 --- a/TESTING/LIN/serrqp.f +++ b/TESTING/LIN/serrqp.f @@ -46,7 +46,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/serrqr.f b/TESTING/LIN/serrqr.f index 27b4c31d..b1c7eaba 100644 --- a/TESTING/LIN/serrqr.f +++ b/TESTING/LIN/serrqr.f @@ -43,7 +43,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/serrrfp.f b/TESTING/LIN/serrrfp.f new file mode 100644 index 00000000..a54a7373 --- /dev/null +++ b/TESTING/LIN/serrrfp.f @@ -0,0 +1,247 @@ + SUBROUTINE SERRRFP( NUNIT ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER NUNIT +* .. +* +* Purpose +* ======= +* +* SERRRFP tests the error exits for the REAL driver routines +* for solving linear systems of equations. +* +* SDRVRFP tests the REAL LAPACK RFP routines: +* STFSM, STFTRI, SSFRK, STFTTP, STFTTR, SPFTRF, SPFTRS, STPTTF, +* STPTTR, STRTTF, and STRTTP +* +* Arguments +* ========= +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER INFO + REAL ALPHA, BETA +* .. +* .. Local Arrays .. + REAL A( 1, 1), B( 1, 1) +* .. +* .. External Subroutines .. + EXTERNAL CHKXER, STFSM, STFTRI, SSFRK, STFTTP, STFTTR, + + SPFTRI, SPFTRF, SPFTRS, STPTTF, STPTTR, STRTTF, + + STRTTP +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + OK = .TRUE. + A( 1, 1 ) = 1.0E+0 + B( 1, 1 ) = 1.0E+0 + ALPHA = 1.0E+0 + BETA = 1.0E+0 +* + SRNAMT = 'SPFTRF' + INFOT = 1 + CALL SPFTRF( '/', 'U', 0, A, INFO ) + CALL CHKXER( 'SPFTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPFTRF( 'N', '/', 0, A, INFO ) + CALL CHKXER( 'SPFTRF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SPFTRF( 'N', 'U', -1, A, INFO ) + CALL CHKXER( 'SPFTRF', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'SPFTRS' + INFOT = 1 + CALL SPFTRS( '/', 'U', 0, 0, A, B, 1, INFO ) + CALL CHKXER( 'SPFTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPFTRS( 'N', '/', 0, 0, A, B, 1, INFO ) + CALL CHKXER( 'SPFTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SPFTRS( 'N', 'U', -1, 0, A, B, 1, INFO ) + CALL CHKXER( 'SPFTRS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SPFTRS( 'N', 'U', 0, -1, A, B, 1, INFO ) + CALL CHKXER( 'SPFTRS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL SPFTRS( 'N', 'U', 0, 0, A, B, 0, INFO ) + CALL CHKXER( 'SPFTRS', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'SPFTRI' + INFOT = 1 + CALL SPFTRI( '/', 'U', 0, A, INFO ) + CALL CHKXER( 'SPFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SPFTRI( 'N', '/', 0, A, INFO ) + CALL CHKXER( 'SPFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SPFTRI( 'N', 'U', -1, A, INFO ) + CALL CHKXER( 'SPFTRI', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'STFSM ' + INFOT = 1 + CALL STFSM( '/', 'L', 'U', 'T', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'STFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL STFSM( 'N', '/', 'U', 'T', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'STFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL STFSM( 'N', 'L', '/', 'T', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'STFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL STFSM( 'N', 'L', 'U', '/', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'STFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL STFSM( 'N', 'L', 'U', 'T', '/', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'STFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL STFSM( 'N', 'L', 'U', 'T', 'U', -1, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'STFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL STFSM( 'N', 'L', 'U', 'T', 'U', 0, -1, ALPHA, A, B, 1 ) + CALL CHKXER( 'STFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL STFSM( 'N', 'L', 'U', 'T', 'U', 0, 0, ALPHA, A, B, 0 ) + CALL CHKXER( 'STFSM ', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'STFTRI' + INFOT = 1 + CALL STFTRI( '/', 'L', 'N', 0, A, INFO ) + CALL CHKXER( 'STFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL STFTRI( 'N', '/', 'N', 0, A, INFO ) + CALL CHKXER( 'STFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL STFTRI( 'N', 'L', '/', 0, A, INFO ) + CALL CHKXER( 'STFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL STFTRI( 'N', 'L', 'N', -1, A, INFO ) + CALL CHKXER( 'STFTRI', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'STFTTR' + INFOT = 1 + CALL STFTTR( '/', 'U', 0, A, B, 1, INFO ) + CALL CHKXER( 'STFTTR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL STFTTR( 'N', '/', 0, A, B, 1, INFO ) + CALL CHKXER( 'STFTTR', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL STFTTR( 'N', 'U', -1, A, B, 1, INFO ) + CALL CHKXER( 'STFTTR', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL STFTTR( 'N', 'U', 0, A, B, 0, INFO ) + CALL CHKXER( 'STFTTR', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'STRTTF' + INFOT = 1 + CALL STRTTF( '/', 'U', 0, A, 1, B, INFO ) + CALL CHKXER( 'STRTTF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL STRTTF( 'N', '/', 0, A, 1, B, INFO ) + CALL CHKXER( 'STRTTF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL STRTTF( 'N', 'U', -1, A, 1, B, INFO ) + CALL CHKXER( 'STRTTF', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL STRTTF( 'N', 'U', 0, A, 0, B, INFO ) + CALL CHKXER( 'STRTTF', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'STFTTP' + INFOT = 1 + CALL STFTTP( '/', 'U', 0, A, B, INFO ) + CALL CHKXER( 'STFTTP', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL STFTTP( 'N', '/', 0, A, B, INFO ) + CALL CHKXER( 'STFTTP', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL STFTTP( 'N', 'U', -1, A, B, INFO ) + CALL CHKXER( 'STFTTP', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'STPTTF' + INFOT = 1 + CALL STPTTF( '/', 'U', 0, A, B, INFO ) + CALL CHKXER( 'STPTTF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL STPTTF( 'N', '/', 0, A, B, INFO ) + CALL CHKXER( 'STPTTF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL STPTTF( 'N', 'U', -1, A, B, INFO ) + CALL CHKXER( 'STPTTF', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'STRTTP' + INFOT = 1 + CALL STRTTP( '/', 0, A, 1, B, INFO ) + CALL CHKXER( 'STRTTP', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL STRTTP( 'U', -1, A, 1, B, INFO ) + CALL CHKXER( 'STRTTP', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL STRTTP( 'U', 0, A, 0, B, INFO ) + CALL CHKXER( 'STRTTP', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'STPTTR' + INFOT = 1 + CALL STPTTR( '/', 0, A, B, 1, INFO ) + CALL CHKXER( 'STPTTR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL STPTTR( 'U', -1, A, B, 1, INFO ) + CALL CHKXER( 'STPTTR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL STPTTR( 'U', 0, A, B, 0, INFO ) + CALL CHKXER( 'STPTTR', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'SSFRK ' + INFOT = 1 + CALL SSFRK( '/', 'U', 'N', 0, 0, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'SSFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL SSFRK( 'N', '/', 'N', 0, 0, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'SSFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL SSFRK( 'N', 'U', '/', 0, 0, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'SSFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL SSFRK( 'N', 'U', 'N', -1, 0, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'SSFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL SSFRK( 'N', 'U', 'N', 0, -1, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'SSFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL SSFRK( 'N', 'U', 'N', 0, 0, ALPHA, A, 0, BETA, B ) + CALL CHKXER( 'SSFRK ', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + IF( OK ) THEN + WRITE( NOUT, FMT = 9999 ) + ELSE + WRITE( NOUT, FMT = 9998 ) + END IF +* + 9999 FORMAT( 1X, 'REAL RFP routines passed the tests of ', + $ 'the error exits' ) + 9998 FORMAT( ' *** RFP routines failed the tests of the error ', + $ 'exits ***' ) + RETURN +* +* End of SERRRFP +* + END diff --git a/TESTING/LIN/serrrq.f b/TESTING/LIN/serrrq.f index 82ee0408..5b363eb6 100644 --- a/TESTING/LIN/serrrq.f +++ b/TESTING/LIN/serrrq.f @@ -43,7 +43,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/serrsy.f b/TESTING/LIN/serrsy.f index 5ff72bca..00d36e44 100644 --- a/TESTING/LIN/serrsy.f +++ b/TESTING/LIN/serrsy.f @@ -51,7 +51,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/serrtr.f b/TESTING/LIN/serrtr.f index a96e7f92..97fcae44 100644 --- a/TESTING/LIN/serrtr.f +++ b/TESTING/LIN/serrtr.f @@ -51,7 +51,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/serrtz.f b/TESTING/LIN/serrtz.f index dd49e34c..9731931b 100644 --- a/TESTING/LIN/serrtz.f +++ b/TESTING/LIN/serrtz.f @@ -45,7 +45,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/serrvx.f b/TESTING/LIN/serrvx.f index 0a264f94..bf786410 100644 --- a/TESTING/LIN/serrvx.f +++ b/TESTING/LIN/serrvx.f @@ -54,7 +54,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/sget07.f b/TESTING/LIN/sget07.f index 2a547483..be12bb69 100644 --- a/TESTING/LIN/sget07.f +++ b/TESTING/LIN/sget07.f @@ -1,5 +1,5 @@ SUBROUTINE SGET07( TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, - $ LDXACT, FERR, BERR, RESLTS ) + $ LDXACT, FERR, CHKFERR, BERR, RESLTS ) * * -- LAPACK test routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. @@ -7,6 +7,7 @@ * * .. Scalar Arguments .. CHARACTER TRANS + LOGICAL CHKFERR INTEGER LDA, LDB, LDX, LDXACT, N, NRHS * .. * .. Array Arguments .. @@ -78,6 +79,11 @@ * of the largest entry in (X - XTRUE) divided by the magnitude * of the largest entry in X. * +* CHKFERR (input) LOGICAL +* Set to .TRUE. to check FERR, .FALSE. not to check FERR. +* When the test system is ill-conditioned, the "true" +* solution in XACT may be incorrect. +* * BERR (input) REAL array, dimension (NRHS) * The componentwise relative backward error of each solution * vector (i.e., the smallest relative change in any entry of A @@ -128,30 +134,32 @@ * over all the vectors X and XACT using the infinity-norm. * ERRBND = ZERO - DO 30 J = 1, NRHS - IMAX = ISAMAX( N, X( 1, J ), 1 ) - XNORM = MAX( ABS( X( IMAX, J ) ), UNFL ) - DIFF = ZERO - DO 10 I = 1, N - DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) ) - 10 CONTINUE -* - IF( XNORM.GT.ONE ) THEN - GO TO 20 - ELSE IF( DIFF.LE.OVFL*XNORM ) THEN - GO TO 20 - ELSE - ERRBND = ONE / EPS - GO TO 30 - END IF + IF( CHKFERR ) THEN + DO 30 J = 1, NRHS + IMAX = ISAMAX( N, X( 1, J ), 1 ) + XNORM = MAX( ABS( X( IMAX, J ) ), UNFL ) + DIFF = ZERO + DO 10 I = 1, N + DIFF = MAX( DIFF, ABS( X( I, J )-XACT( I, J ) ) ) + 10 CONTINUE +* + IF( XNORM.GT.ONE ) THEN + GO TO 20 + ELSE IF( DIFF.LE.OVFL*XNORM ) THEN + GO TO 20 + ELSE + ERRBND = ONE / EPS + GO TO 30 + END IF * - 20 CONTINUE - IF( DIFF / XNORM.LE.FERR( J ) ) THEN - ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) ) - ELSE - ERRBND = ONE / EPS - END IF - 30 CONTINUE + 20 CONTINUE + IF( DIFF / XNORM.LE.FERR( J ) ) THEN + ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) ) + ELSE + ERRBND = ONE / EPS + END IF + 30 CONTINUE + END IF RESLTS( 1 ) = ERRBND * * Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where diff --git a/TESTING/LIN/slahilb.f b/TESTING/LIN/slahilb.f new file mode 100644 index 00000000..afdc4201 --- /dev/null +++ b/TESTING/LIN/slahilb.f @@ -0,0 +1,166 @@ + SUBROUTINE SLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO) +! +! -- LAPACK auxiliary test routine (version 3.0) -- +! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +! Courant Institute, Argonne National Lab, and Rice University +! 28 August, 2006 +! +! David Vu <dtv@cs.berkeley.edu> +! Yozo Hida <yozo@cs.berkeley.edu> +! Jason Riedy <ejr@cs.berkeley.edu> +! D. Halligan <dhalligan@berkeley.edu> +! + IMPLICIT NONE +! .. Scalar Arguments .. + INTEGER N, NRHS, LDA, LDX, LDB, INFO +! .. Array Arguments .. + REAL A(LDA, N), X(LDX, NRHS), B(LDB, NRHS), WORK(N) +! .. +! +! Purpose +! ======= +! +! SLAHILB generates an N by N scaled Hilbert matrix in A along with +! NRHS right-hand sides in B and solutions in X such that A*X=B. +! +! The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all +! entries are integers. The right-hand sides are the first NRHS +! columns of M * the identity matrix, and the solutions are the +! first NRHS columns of the inverse Hilbert matrix. +! +! The condition number of the Hilbert matrix grows exponentially with +! its size, roughly as O(e ** (3.5*N)). Additionally, the inverse +! Hilbert matrices beyond a relatively small dimension cannot be +! generated exactly without extra precision. Precision is exhausted +! when the largest entry in the inverse Hilbert matrix is greater than +! 2 to the power of the number of bits in the fraction of the data type +! used plus one, which is 24 for single precision. +! +! In single, the generated solution is exact for N <= 6 and has +! small componentwise error for 7 <= N <= 11. +! +! Arguments +! ========= +! +! N (input) INTEGER +! The dimension of the matrix A. +! +! NRHS (input) NRHS +! The requested number of right-hand sides. +! +! A (output) REAL array, dimension (LDA, N) +! The generated scaled Hilbert matrix. +! +! LDA (input) INTEGER +! The leading dimension of the array A. LDA >= N. +! +! X (output) REAL array, dimension (LDX, NRHS) +! The generated exact solutions. Currently, the first NRHS +! columns of the inverse Hilbert matrix. +! +! LDX (input) INTEGER +! The leading dimension of the array X. LDX >= N. +! +! B (output) REAL array, dimension (LDB, NRHS) +! The generated right-hand sides. Currently, the first NRHS +! columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. +! +! LDB (input) INTEGER +! The leading dimension of the array B. LDB >= N. +! +! WORK (workspace) REAL array, dimension (N) +! +! +! INFO (output) INTEGER +! = 0: successful exit +! = 1: N is too large; the data is still generated but may not +! be not exact. +! < 0: if INFO = -i, the i-th argument had an illegal value +! +! ===================================================================== + +! .. Local Scalars .. + INTEGER TM, TI, R + INTEGER M + INTEGER I, J + +! .. Parameters .. +! NMAX_EXACT the largest dimension where the generated data is +! exact. +! NMAX_APPROX the largest dimension where the generated data has +! a small componentwise relative error. + INTEGER NMAX_EXACT, NMAX_APPROX + PARAMETER (NMAX_EXACT = 6, NMAX_APPROX = 11) + +! .. +! .. External Functions + EXTERNAL SLASET + INTRINSIC REAL +! .. +! .. Executable Statements .. +! +! Test the input arguments +! + INFO = 0 + IF (N .LT. 0 .OR. N .GT. NMAX_APPROX) THEN + INFO = -1 + ELSE IF (NRHS .LT. 0) THEN + INFO = -2 + ELSE IF (LDA .LT. N) THEN + INFO = -4 + ELSE IF (LDX .LT. N) THEN + INFO = -6 + ELSE IF (LDB .LT. N) THEN + INFO = -8 + END IF + IF (INFO .LT. 0) THEN + CALL XERBLA('SLAHILB', -INFO) + RETURN + END IF + IF (N .GT. NMAX_EXACT) THEN + INFO = 1 + END IF + +! Compute M = the LCM of the integers [1, 2*N-1]. The largest +! reasonable N is small enough that integers suffice (up to N = 11). + M = 1 + DO I = 2, (2*N-1) + TM = M + TI = I + R = MOD(TM, TI) + DO WHILE (R .NE. 0) + TM = TI + TI = R + R = MOD(TM, TI) + END DO + M = (M / TI) * I + END DO + +! Generate the scaled Hilbert matrix in A + DO J = 1, N + DO I = 1, N + A(I, J) = REAL(M) / (I + J - 1) + END DO + END DO + +! Generate matrix B as simply the first NRHS columns of M * the +! identity. + CALL SLASET('Full', N, NRHS, 0.0, REAL(M), B, LDB) + +! Generate the true solutions in X. Because B = the first NRHS +! columns of M*I, the true solutions are just the first NRHS columns +! of the inverse Hilbert matrix. + WORK(1) = N + DO J = 2, N + WORK(J) = ( ( (WORK(J-1)/(J-1)) * (J-1 - N) ) /(J-1) ) + $ * (N +J -1) + END DO + + DO J = 1, NRHS + DO I = 1, N + X(I, J) = (WORK(I)*WORK(J)) / (I + J - 1) + END DO + END DO + + END + diff --git a/TESTING/LIN/slatb5.f b/TESTING/LIN/slatb5.f new file mode 100644 index 00000000..c819cdda --- /dev/null +++ b/TESTING/LIN/slatb5.f @@ -0,0 +1,166 @@ + SUBROUTINE SLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) +* +* -- LAPACK test routine (version 3.1) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + REAL ANORM, CNDNUM + INTEGER IMAT, KL, KU, MODE, N + CHARACTER DIST, TYPE + CHARACTER*3 PATH +* .. +* +* Purpose +* ======= +* +* SLATB5 sets parameters for the matrix generator based on the type +* of matrix to be generated. +* +* Arguments +* ========= +* +* PATH (input) CHARACTER*3 +* The LAPACK path name. +* +* IMAT (input) INTEGER +* An integer key describing which matrix to generate for this +* path. +* +* N (input) INTEGER +* The number of rows and columns in the matrix to be generated. +* +* TYPE (output) CHARACTER*1 +* The type of the matrix to be generated: +* = 'S': symmetric matrix +* = 'P': symmetric positive (semi)definite matrix +* = 'N': nonsymmetric matrix +* +* KL (output) INTEGER +* The lower band width of the matrix to be generated. +* +* KU (output) INTEGER +* The upper band width of the matrix to be generated. +* +* ANORM (output) REAL +* The desired norm of the matrix to be generated. The diagonal +* matrix of singular values or eigenvalues is scaled by this +* value. +* +* MODE (output) INTEGER +* A key indicating how to choose the vector of eigenvalues. +* +* CNDNUM (output) REAL +* The desired condition number. +* +* DIST (output) CHARACTER*1 +* The type of distribution to be used by the random number +* generator. +* +* ===================================================================== +* +* .. Parameters .. + REAL SHRINK, TENTH + PARAMETER ( SHRINK = 0.25E0, TENTH = 0.1E+0 ) + REAL ONE + PARAMETER ( ONE = 1.0E+0 ) + REAL TWO + PARAMETER ( TWO = 2.0E+0 ) +* .. +* .. Local Scalars .. + REAL BADC1, BADC2, EPS, LARGE, SMALL + LOGICAL FIRST + CHARACTER*2 C2 +* .. +* .. External Functions .. + REAL SLAMCH + EXTERNAL SLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Subroutines .. + EXTERNAL SLABAD +* .. +* .. Save statement .. + SAVE EPS, SMALL, LARGE, BADC1, BADC2, FIRST +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* +* Set some constants for use in the subroutine. +* + IF( FIRST ) THEN + FIRST = .FALSE. + EPS = SLAMCH( 'Precision' ) + BADC2 = TENTH / EPS + BADC1 = SQRT( BADC2 ) + SMALL = SLAMCH( 'Safe minimum' ) + LARGE = ONE / SMALL +* +* If it looks like we're on a Cray, take the square root of +* SMALL and LARGE to avoid overflow and underflow problems. +* + CALL SLABAD( SMALL, LARGE ) + SMALL = SHRINK*( SMALL / EPS ) + LARGE = ONE / SMALL + END IF +* + C2 = PATH( 2: 3 ) +* +* Set some parameters +* + DIST = 'S' + MODE = 3 +* +* Set TYPE, the type of matrix to be generated. +* + TYPE = C2( 1: 1 ) +* +* Set the lower and upper bandwidths. +* + IF( IMAT.EQ.1 ) THEN + KL = 0 + ELSE + KL = MAX( N-1, 0 ) + END IF + KU = KL +* +* Set the condition number and norm.etc +* + IF( IMAT.EQ.3 ) THEN + CNDNUM = 1.0E4 + MODE = 2 + ELSE IF( IMAT.EQ.4 ) THEN + CNDNUM = 1.0E4 + MODE = 1 + ELSE IF( IMAT.EQ.5 ) THEN + CNDNUM = 1.0E4 + MODE = 3 + ELSE IF( IMAT.EQ.6 ) THEN + CNDNUM = BADC1 + ELSE IF( IMAT.EQ.7 ) THEN + CNDNUM = BADC2 + ELSE + CNDNUM = TWO + END IF +* + IF( IMAT.EQ.8 ) THEN + ANORM = SMALL + ELSE IF( IMAT.EQ.9 ) THEN + ANORM = LARGE + ELSE + ANORM = ONE + END IF +* + IF( N.LE.1 ) + $ CNDNUM = ONE +* + RETURN +* +* End of SLATB5 +* + END diff --git a/TESTING/LIN/slqt01.f b/TESTING/LIN/slqt01.f index 57248714..3710ae49 100644 --- a/TESTING/LIN/slqt01.f +++ b/TESTING/LIN/slqt01.f @@ -87,7 +87,7 @@ INTRINSIC MAX, MIN, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/slqt02.f b/TESTING/LIN/slqt02.f index 474d0733..aac1c6fb 100644 --- a/TESTING/LIN/slqt02.f +++ b/TESTING/LIN/slqt02.f @@ -93,7 +93,7 @@ INTRINSIC MAX, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/slqt03.f b/TESTING/LIN/slqt03.f index 12d9dbe7..4f53a142 100644 --- a/TESTING/LIN/slqt03.f +++ b/TESTING/LIN/slqt03.f @@ -99,7 +99,7 @@ INTRINSIC MAX, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/spst01.f b/TESTING/LIN/spst01.f new file mode 100644 index 00000000..ebb7fb3d --- /dev/null +++ b/TESTING/LIN/spst01.f @@ -0,0 +1,225 @@ + SUBROUTINE SPST01( UPLO, N, A, LDA, AFAC, LDAFAC, PERM, LDPERM, + $ PIV, RWORK, RESID, RANK ) +* +* -- LAPACK test routine (version 3.1) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + REAL RESID + INTEGER LDA, LDAFAC, LDPERM, N, RANK + CHARACTER UPLO +* .. +* .. Array Arguments .. + REAL A( LDA, * ), AFAC( LDAFAC, * ), + $ PERM( LDPERM, * ), RWORK( * ) + INTEGER PIV( * ) +* .. +* +* Purpose +* ======= +* +* SPST01 reconstructs a symmetric positive semidefinite matrix A +* from its L or U factors and the permutation matrix P and computes +* the residual +* norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or +* norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ), +* where EPS is the machine epsilon. +* +* Arguments +* ========== +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is stored: +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The number of rows and columns of the matrix A. N >= 0. +* +* A (input) REAL array, dimension (LDA,N) +* The original symmetric matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N) +* +* AFAC (input) REAL array, dimension (LDAFAC,N) +* The factor L or U from the L*L' or U'*U +* factorization of A. +* +* LDAFAC (input) INTEGER +* The leading dimension of the array AFAC. LDAFAC >= max(1,N). +* +* PERM (output) REAL array, dimension (LDPERM,N) +* Overwritten with the reconstructed matrix, and then with the +* difference P*L*L'*P' - A (or P*U'*U*P' - A) +* +* LDPERM (input) INTEGER +* The leading dimension of the array PERM. +* LDAPERM >= max(1,N). +* +* PIV (input) INTEGER array, dimension (N) +* PIV is such that the nonzero entries are +* P( PIV( K ), K ) = 1. +* +* RWORK (workspace) REAL array, dimension (N) +* +* RESID (output) REAL +* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) +* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) +* .. +* .. Local Scalars .. + REAL ANORM, EPS, T + INTEGER I, J, K +* .. +* .. External Functions .. + REAL SDOT, SLAMCH, SLANSY + LOGICAL LSAME + EXTERNAL SDOT, SLAMCH, SLANSY, LSAME +* .. +* .. External Subroutines .. + EXTERNAL SSCAL, SSYR, STRMV +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Exit with RESID = 1/EPS if ANORM = 0. +* + EPS = SLAMCH( 'Epsilon' ) + ANORM = SLANSY( '1', UPLO, N, A, LDA, RWORK ) + IF( ANORM.LE.ZERO ) THEN + RESID = ONE / EPS + RETURN + END IF +* +* Compute the product U'*U, overwriting U. +* + IF( LSAME( UPLO, 'U' ) ) THEN +* + IF( RANK.LT.N ) THEN + DO 110 J = RANK + 1, N + DO 100 I = RANK + 1, J + AFAC( I, J ) = ZERO + 100 CONTINUE + 110 CONTINUE + END IF +* + DO 120 K = N, 1, -1 +* +* Compute the (K,K) element of the result. +* + T = SDOT( K, AFAC( 1, K ), 1, AFAC( 1, K ), 1 ) + AFAC( K, K ) = T +* +* Compute the rest of column K. +* + CALL STRMV( 'Upper', 'Transpose', 'Non-unit', K-1, AFAC, + $ LDAFAC, AFAC( 1, K ), 1 ) +* + 120 CONTINUE +* +* Compute the product L*L', overwriting L. +* + ELSE +* + IF( RANK.LT.N ) THEN + DO 140 J = RANK + 1, N + DO 130 I = J, N + AFAC( I, J ) = ZERO + 130 CONTINUE + 140 CONTINUE + END IF +* + DO 150 K = N, 1, -1 +* Add a multiple of column K of the factor L to each of +* columns K+1 through N. +* + IF( K+1.LE.N ) + $ CALL SSYR( 'Lower', N-K, ONE, AFAC( K+1, K ), 1, + $ AFAC( K+1, K+1 ), LDAFAC ) +* +* Scale column K by the diagonal element. +* + T = AFAC( K, K ) + CALL SSCAL( N-K+1, T, AFAC( K, K ), 1 ) + 150 CONTINUE +* + END IF +* +* Form P*L*L'*P' or P*U'*U*P' +* + IF( LSAME( UPLO, 'U' ) ) THEN +* + DO 170 J = 1, N + DO 160 I = 1, N + IF( PIV( I ).LE.PIV( J ) ) THEN + IF( I.LE.J ) THEN + PERM( PIV( I ), PIV( J ) ) = AFAC( I, J ) + ELSE + PERM( PIV( I ), PIV( J ) ) = AFAC( J, I ) + END IF + END IF + 160 CONTINUE + 170 CONTINUE +* +* + ELSE +* + DO 190 J = 1, N + DO 180 I = 1, N + IF( PIV( I ).GE.PIV( J ) ) THEN + IF( I.GE.J ) THEN + PERM( PIV( I ), PIV( J ) ) = AFAC( I, J ) + ELSE + PERM( PIV( I ), PIV( J ) ) = AFAC( J, I ) + END IF + END IF + 180 CONTINUE + 190 CONTINUE +* + END IF +* +* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A). +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 210 J = 1, N + DO 200 I = 1, J + PERM( I, J ) = PERM( I, J ) - A( I, J ) + 200 CONTINUE + 210 CONTINUE + ELSE + DO 230 J = 1, N + DO 220 I = J, N + PERM( I, J ) = PERM( I, J ) - A( I, J ) + 220 CONTINUE + 230 CONTINUE + END IF +* +* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or +* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). +* + RESID = SLANSY( '1', UPLO, N, PERM, LDAFAC, RWORK ) +* + RESID = ( ( RESID / REAL( N ) ) / ANORM ) / EPS +* + RETURN +* +* End of SPST01 +* + END diff --git a/TESTING/LIN/sqlt01.f b/TESTING/LIN/sqlt01.f index 6d5e4c1b..c105bef7 100644 --- a/TESTING/LIN/sqlt01.f +++ b/TESTING/LIN/sqlt01.f @@ -87,7 +87,7 @@ INTRINSIC MAX, MIN, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/sqlt02.f b/TESTING/LIN/sqlt02.f index d6bd54e0..e6080f11 100644 --- a/TESTING/LIN/sqlt02.f +++ b/TESTING/LIN/sqlt02.f @@ -94,7 +94,7 @@ INTRINSIC MAX, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/sqlt03.f b/TESTING/LIN/sqlt03.f index 4db0a943..964092a6 100644 --- a/TESTING/LIN/sqlt03.f +++ b/TESTING/LIN/sqlt03.f @@ -99,7 +99,7 @@ INTRINSIC MAX, MIN, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/sqrt01.f b/TESTING/LIN/sqrt01.f index bdeed868..69a4a8f3 100644 --- a/TESTING/LIN/sqrt01.f +++ b/TESTING/LIN/sqrt01.f @@ -87,7 +87,7 @@ INTRINSIC MAX, MIN, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/sqrt02.f b/TESTING/LIN/sqrt02.f index 8d6f104a..a08867ca 100644 --- a/TESTING/LIN/sqrt02.f +++ b/TESTING/LIN/sqrt02.f @@ -93,7 +93,7 @@ INTRINSIC MAX, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/sqrt03.f b/TESTING/LIN/sqrt03.f index c8bc6d8d..f45d4792 100644 --- a/TESTING/LIN/sqrt03.f +++ b/TESTING/LIN/sqrt03.f @@ -99,7 +99,7 @@ INTRINSIC MAX, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/srqt01.f b/TESTING/LIN/srqt01.f index ee22efc4..389a6df1 100644 --- a/TESTING/LIN/srqt01.f +++ b/TESTING/LIN/srqt01.f @@ -87,7 +87,7 @@ INTRINSIC MAX, MIN, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/srqt02.f b/TESTING/LIN/srqt02.f index 089a2996..be1578af 100644 --- a/TESTING/LIN/srqt02.f +++ b/TESTING/LIN/srqt02.f @@ -94,7 +94,7 @@ INTRINSIC MAX, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/srqt03.f b/TESTING/LIN/srqt03.f index 2215d754..e4b6ab03 100644 --- a/TESTING/LIN/srqt03.f +++ b/TESTING/LIN/srqt03.f @@ -99,7 +99,7 @@ INTRINSIC MAX, MIN, REAL * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/xerbla.f b/TESTING/LIN/xerbla.f index 5c74db39..38bb2297 100644 --- a/TESTING/LIN/xerbla.f +++ b/TESTING/LIN/xerbla.f @@ -5,7 +5,7 @@ * November 2006 * * .. Scalar Arguments .. - CHARACTER*(*) SRNAME + CHARACTER*(*) SRNAME INTEGER INFO * .. * @@ -44,12 +44,11 @@ * * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. -* .. External Functions .. - INTEGER ILA_LEN_TRIM - EXTERNAL ILA_LEN_TRIM +* .. Intrinsic Functions .. + INTRINSIC LEN_TRIM * .. * .. Common blocks .. COMMON / INFOC / INFOT, NOUT, OK, LERR @@ -61,17 +60,17 @@ IF( INFO.NE.INFOT ) THEN IF( INFOT.NE.0 ) THEN WRITE( NOUT, FMT = 9999 ) - $ SRNAMT(1:ILA_LEN_TRIM(SRNAMT)), INFO, INFOT + $ SRNAMT( 1:LEN_TRIM( SRNAMT ) ), INFO, INFOT ELSE WRITE( NOUT, FMT = 9997 ) - $ SRNAME(1:ILA_LEN_TRIM(SRNAME)), INFO + $ SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO END IF OK = .FALSE. END IF IF( SRNAME.NE.SRNAMT ) THEN WRITE( NOUT, FMT = 9998 ) - $ SRNAME(1:ILA_LEN_TRIM(SRNAME)), - $ SRNAMT(1:ILA_LEN_TRIM(SRNAMT)) + $ SRNAME( 1:LEN_TRIM( SRNAME ) ), + $ SRNAMT( 1:LEN_TRIM( SRNAMT ) ) OK = .FALSE. END IF RETURN diff --git a/TESTING/LIN/zchkaa.f b/TESTING/LIN/zchkaa.f index c3118e07..ac47b6ca 100644 --- a/TESTING/LIN/zchkaa.f +++ b/TESTING/LIN/zchkaa.f @@ -26,6 +26,8 @@ * 5 Number of values of NB * 1 3 3 3 20 Values of NB (the blocksize) * 1 0 5 9 1 Values of NX (crossover point) +* 3 Number of values of RANK +* 30 50 90 Values of rank (as a % of N) * 30.0 Threshold value of test ratio * T Put T to test the LAPACK routines * T Put T to test the driver routines @@ -34,6 +36,7 @@ * ZGB 8 List types on next line if 0 < NTYPES < 8 * ZGT 12 List types on next line if 0 < NTYPES < 12 * ZPO 9 List types on next line if 0 < NTYPES < 9 +* ZPS 9 List types on next line if 0 < NTYPES < 9 * ZPP 9 List types on next line if 0 < NTYPES < 9 * ZPB 8 List types on next line if 0 < NTYPES < 8 * ZPT 12 List types on next line if 0 < NTYPES < 12 @@ -96,7 +99,7 @@ CHARACTER*10 INTSTR CHARACTER*72 ALINE INTEGER I, IC, J, K, LA, LAFAC, LDA, NB, NM, NMATS, NN, - $ NNB, NNB2, NNS, NRHS, NTYPES, + $ NNB, NNB2, NNS, NRHS, NTYPES, NRANK, $ VERS_MAJOR, VERS_MINOR, VERS_PATCH DOUBLE PRECISION EPS, S1, S2, THREQ, THRESH * .. @@ -104,7 +107,8 @@ LOGICAL DOTYPE( MATMAX ) INTEGER IWORK( 25*NMAX ), MVAL( MAXIN ), $ NBVAL( MAXIN ), NBVAL2( MAXIN ), - $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ) + $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), + $ 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 ) @@ -116,15 +120,16 @@ * .. * .. External Subroutines .. EXTERNAL ALAREQ, ZCHKEQ, ZCHKGB, ZCHKGE, ZCHKGT, ZCHKHE, - $ ZCHKHP, ZCHKLQ, ZCHKPB, ZCHKPO, ZCHKPP, ZCHKPT, - $ ZCHKQ3, ZCHKQL, ZCHKQP, ZCHKQR, ZCHKRQ, ZCHKSP, - $ ZCHKSY, ZCHKTB, ZCHKTP, ZCHKTR, ZCHKTZ, ZDRVGB, - $ ZDRVGE, ZDRVGT, ZDRVHE, ZDRVHP, ZDRVLS, ZDRVPB, - $ ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP, ZDRVSY, ILAVER + $ ZCHKHP, ZCHKLQ, ZCHKPB, ZCHKPO, ZCHKPS, ZCHKPP, + $ ZCHKPT, ZCHKQ3, ZCHKQL, ZCHKQP, ZCHKQR, ZCHKRQ, + $ ZCHKSP, ZCHKSY, ZCHKTB, ZCHKTP, ZCHKTR, ZCHKTZ, + $ ZDRVGB, ZDRVGE, ZDRVGT, ZDRVHE, ZDRVHP, ZDRVLS, + $ ZDRVPB, ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP, ZDRVSY, + $ ILAVER * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Arrays in Common .. @@ -275,6 +280,32 @@ IF( NNB.GT.0 ) $ WRITE( NOUT, FMT = 9993 )'NX ', ( NXVAL( I ), I = 1, NNB ) * +* Read the values of RANKVAL +* + READ( NIN, FMT = * )NRANK + IF( NN.LT.1 ) THEN + WRITE( NOUT, FMT = 9996 )' NRANK ', NRANK, 1 + NRANK = 0 + FATAL = .TRUE. + ELSE IF( NN.GT.MAXIN ) THEN + WRITE( NOUT, FMT = 9995 )' NRANK ', NRANK, MAXIN + NRANK = 0 + FATAL = .TRUE. + END IF + READ( NIN, FMT = * )( RANKVAL( I ), I = 1, NRANK ) + DO I = 1, NRANK + IF( RANKVAL( I ).LT.0 ) THEN + WRITE( NOUT, FMT = 9996 )' RANK ', RANKVAL( I ), 0 + FATAL = .TRUE. + ELSE IF( RANKVAL( I ).GT.100 ) THEN + WRITE( NOUT, FMT = 9995 )' RANK ', RANKVAL( I ), 100 + FATAL = .TRUE. + END IF + END DO + IF( NRANK.GT.0 ) + $ WRITE( NOUT, FMT = 9993 )'RANK % OF N', + $ ( RANKVAL( I ), I = 1, NRANK ) +* * Read the threshold value for the test ratios. * READ( NIN, FMT = * )THRESH @@ -453,6 +484,23 @@ WRITE( NOUT, FMT = 9988 )PATH END IF * + ELSE IF( LSAMEN( 2, C2, 'PS' ) ) THEN +* +* PS: positive semi-definite matrices +* + NTYPES = 9 +* + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL ZCHKPS( DOTYPE, NN, NVAL, NNB2, NBVAL2, NRANK, + $ RANKVAL, THRESH, TSTERR, LDA, A( 1, 1 ), + $ A( 1, 2 ), A( 1, 3 ), PIV, WORK, RWORK, + $ NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF +* ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN * * PP: positive definite packed matrices diff --git a/TESTING/LIN/zchkab.f b/TESTING/LIN/zchkab.f index 096ff4e6..d3fb2fa9 100644 --- a/TESTING/LIN/zchkab.f +++ b/TESTING/LIN/zchkab.f @@ -9,7 +9,7 @@ * ======= * * ZCHKAB is the test program for the COMPLEX*16 LAPACK -* ZCGESV routine +* ZCGESV/ZCPOSV routine * * The program must be driven by a short data file. The first 5 records * specify problem dimensions and program options using list-directed @@ -23,9 +23,10 @@ * 1 Number of values of NRHS * 2 Values of NRHS (number of right hand sides) * 20.0 Threshold value of test ratio -* T Put T to test the ZCGESV routine -* T Put T to test the error exits for ZCGESV -* 11 List types on next line if 0 < NTYPES < 11 +* T Put T to test the LAPACK routine +* T Put T to test the error exits +* DGE 11 List types on next line if 0 < NTYPES < 11 +* DPO 9 List types on next line if 0 < NTYPES < 9 * * Internal Parameters * =================== @@ -64,7 +65,12 @@ * .. * .. Local Scalars .. LOGICAL FATAL, TSTDRV, TSTERR - INTEGER I, LDA, NM, NMATS, + CHARACTER C1 + CHARACTER*2 C2 + CHARACTER*3 PATH + CHARACTER*10 INTSTR + CHARACTER*72 ALINE + INTEGER I, IC, K, LDA, NM, NMATS, $ NNS, NRHS, NTYPES, $ VERS_MAJOR, VERS_MINOR, VERS_PATCH DOUBLE PRECISION EPS, S1, S2, THRESH @@ -80,20 +86,24 @@ * .. * .. External Functions .. DOUBLE PRECISION DLAMCH, DSECND + LOGICAL LSAME, LSAMEN REAL SLAMCH - EXTERNAL DLAMCH, DSECND, SLAMCH + EXTERNAL DLAMCH, DSECND, LSAME, LSAMEN, SLAMCH * .. * .. External Subroutines .. - EXTERNAL ALAREQ, ZERRAB, ILAVER + EXTERNAL ALAREQ, ZERRGX, ZERRPX, ILAVER * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. COMMON / INFOC / INFOT, NUNIT, OK, LERR COMMON / SRNAMC / SRNAMT +* +* .. Data statements .. + DATA INTSTR / '0123456789' / * .. * .. Executable Statements .. * @@ -196,35 +206,107 @@ WRITE( NOUT, FMT = 9991 )'(double precision) precision', EPS WRITE( NOUT, FMT = * ) * + 80 CONTINUE +* +* Read a test path and the number of matrix types to use. +* + READ( NIN, FMT = '(A72)', END = 140 )ALINE + PATH = ALINE( 1: 3 ) + NMATS = MATMAX + I = 3 + 90 CONTINUE + I = I + 1 + IF( I.GT.72 ) THEN + NMATS = MATMAX + GO TO 130 + END IF + IF( ALINE( I: I ).EQ.' ' ) + $ GO TO 90 + NMATS = 0 + 100 CONTINUE + C1 = ALINE( I: I ) + DO 110 K = 1, 10 + IF( C1.EQ.INTSTR( K: K ) ) THEN + IC = K - 1 + GO TO 120 + END IF + 110 CONTINUE + GO TO 130 + 120 CONTINUE + NMATS = NMATS*10 + IC + I = I + 1 + IF( I.GT.72 ) + $ GO TO 130 + GO TO 100 + 130 CONTINUE + C1 = PATH( 1: 1 ) + C2 = PATH( 2: 3 ) + NRHS = NSVAL( 1 ) NRHS = NSVAL( 1 ) - READ( NIN, FMT = * ) NMATS * - IF( NMATS.LE.0 ) THEN +* Check first character for correct precision. +* + IF( .NOT.LSAME( C1, 'Zomplex precision' ) ) THEN + WRITE( NOUT, FMT = 9990 )PATH +* + ELSE IF( NMATS.LE.0 ) THEN * * Check for a positive number of tests requested. * WRITE( NOUT, FMT = 9990 )'ZCGESV' GO TO 140 * - END IF + ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN +* +* GE: general matrices * NTYPES = 11 CALL ALAREQ( 'ZGE', NMATS, DOTYPE, NTYPES, NIN, NOUT ) * -* Test the error exits +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRAB( NOUT ) +* + IF( TSTDRV ) THEN + CALL ZDRVAB( DOTYPE, NM, MVAL, NNS, + $ NSVAL, THRESH, LDA, A( 1, 1 ), + $ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), + $ WORK, RWORK, SWORK, IWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )'ZCGESV' + END IF +* + ELSE IF( LSAMEN( 2, C2, 'PO' ) ) THEN +* +* PO: positive definite matrices * - IF( TSTERR ) - $ CALL ZERRAB( NOUT ) + NTYPES = 9 + CALL ALAREQ( 'DPO', NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTERR ) + $ CALL ZERRAC( NOUT ) +* +* + IF( TSTDRV ) THEN + CALL ZDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, + $ THRESH, LDA, A( 1, 1 ), A( 1, 2 ), + $ B( 1, 1 ), B( 1, 2 ), + $ WORK, RWORK, SWORK, NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )'ZCPOSV' + END IF * - IF( TSTDRV ) THEN - CALL ZDRVAB( DOTYPE, NM, MVAL, NNS, - $ NSVAL, THRESH, LDA, A( 1, 1 ), - $ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), - $ WORK, RWORK, SWORK, IWORK, NOUT ) ELSE - WRITE( NOUT, FMT = 9989 )'ZCGESV' +* END IF * +* Go back to get another input line. +* + GO TO 80 +* +* Branch to this line when the last record is read. +* 140 CONTINUE CLOSE ( NIN ) S2 = DSECND( ) @@ -238,7 +320,7 @@ $ I6 ) 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=', $ I6 ) - 9994 FORMAT( ' Tests of the COMPLEX*16 LAPACK ZCGESV routines ', + 9994 FORMAT( ' Tests of the COMPLEX*16 LAPACK ZCGESV/ZCPOSV routines ', $ / ' LAPACK VERSION ', I1, '.', I1, '.', I1, $ / / ' The following parameter values will be used:' ) 9993 FORMAT( 4X, A4, ': ', 10I6, / 11X, 10I6 ) @@ -247,6 +329,7 @@ 9991 FORMAT( ' Relative machine ', A, ' is taken to be', D16.6 ) 9990 FORMAT( / 1X, A6, ' routines were not tested' ) 9989 FORMAT( / 1X, A6, ' driver routines were not tested' ) + 9988 FORMAT( / 1X, A3, ': Unrecognized path name' ) * * End of ZCHKAB * diff --git a/TESTING/LIN/zchkgb.f b/TESTING/LIN/zchkgb.f index fb3da4f6..60c69785 100644 --- a/TESTING/LIN/zchkgb.f +++ b/TESTING/LIN/zchkgb.f @@ -140,7 +140,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchkge.f b/TESTING/LIN/zchkge.f index 5d73900c..0fced985 100644 --- a/TESTING/LIN/zchkge.f +++ b/TESTING/LIN/zchkge.f @@ -139,7 +139,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. @@ -411,7 +411,7 @@ CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, $ RESULT( 5 ) ) CALL ZGET07( TRANS, N, NRHS, A, LDA, B, LDA, X, - $ LDA, XACT, LDA, RWORK, + $ LDA, XACT, LDA, RWORK, .TRUE., $ RWORK( NRHS+1 ), RESULT( 6 ) ) * * Print information about the tests that did not diff --git a/TESTING/LIN/zchkgt.f b/TESTING/LIN/zchkgt.f index ea1d6d73..47fa3fa3 100644 --- a/TESTING/LIN/zchkgt.f +++ b/TESTING/LIN/zchkgt.f @@ -114,7 +114,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchkhe.f b/TESTING/LIN/zchkhe.f index 2e68dd19..151b4f70 100644 --- a/TESTING/LIN/zchkhe.f +++ b/TESTING/LIN/zchkhe.f @@ -125,7 +125,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchkhp.f b/TESTING/LIN/zchkhp.f index c19462f9..ff07c588 100644 --- a/TESTING/LIN/zchkhp.f +++ b/TESTING/LIN/zchkhp.f @@ -123,7 +123,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchklq.f b/TESTING/LIN/zchklq.f index ed1f7e40..3fcf9c75 100644 --- a/TESTING/LIN/zchklq.f +++ b/TESTING/LIN/zchklq.f @@ -135,7 +135,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchkpb.f b/TESTING/LIN/zchkpb.f index 2a12ece0..8d256a15 100644 --- a/TESTING/LIN/zchkpb.f +++ b/TESTING/LIN/zchkpb.f @@ -123,7 +123,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchkpo.f b/TESTING/LIN/zchkpo.f index fe9b0a51..8164e894 100644 --- a/TESTING/LIN/zchkpo.f +++ b/TESTING/LIN/zchkpo.f @@ -120,7 +120,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchkpp.f b/TESTING/LIN/zchkpp.f index 632346c6..d8a8366c 100644 --- a/TESTING/LIN/zchkpp.f +++ b/TESTING/LIN/zchkpp.f @@ -117,7 +117,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchkps.f b/TESTING/LIN/zchkps.f new file mode 100644 index 00000000..4f158a88 --- /dev/null +++ b/TESTING/LIN/zchkps.f @@ -0,0 +1,267 @@ + SUBROUTINE ZCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL, + $ THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK, + $ RWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + DOUBLE PRECISION THRESH + INTEGER NMAX, NN, NNB, NOUT, NRANK + LOGICAL TSTERR +* .. +* .. Array Arguments .. + COMPLEX*16 A( * ), AFAC( * ), PERM( * ), WORK( * ) + DOUBLE PRECISION RWORK( * ) + INTEGER NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * ) + LOGICAL DOTYPE( * ) +* .. +* +* Purpose +* ======= +* +* ZCHKPS tests ZPSTRF. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* NNB (input) INTEGER +* The number of values of NB contained in the vector NBVAL. +* +* NBVAL (input) INTEGER array, dimension (NBVAL) +* The values of the block size NB. +* +* NRANK (input) INTEGER +* The number of values of RANK contained in the vector RANKVAL. +* +* RANKVAL (input) INTEGER array, dimension (NBVAL) +* The values of the block size NB. +* +* THRESH (input) 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. +* +* TSTERR (input) LOGICAL +* Flag that indicates whether error exits are to be tested. +* +* NMAX (input) INTEGER +* The maximum value permitted for N, used in dimensioning the +* work arrays. +* +* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) +* +* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) +* +* PERM (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) +* +* PIV (workspace) INTEGER array, dimension (NMAX) +* +* WORK (workspace) COMPLEX*16 array, dimension (NMAX*3) +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0E+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 9 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION ANORM, CNDNUM, RESULT, TOL + INTEGER COMPRANK, I, IMAT, IN, INB, INFO, IRANK, IUPLO, + $ IZERO, KL, KU, LDA, MODE, N, NB, NERRS, NFAIL, + $ NIMAT, NRUN, RANK, RANKDIFF + CHARACTER DIST, TYPE, UPLO + CHARACTER*3 PATH +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ), ISEEDY( 4 ) + CHARACTER UPLOS( 2 ) +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, XLAENV, ZERRPS, ZLACPY + $ ZLATB5, ZLATMT, ZPST01, ZPSTRF +* .. +* .. Scalars in Common .. + INTEGER INFOT, NUNIT + LOGICAL LERR, OK + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, CEILING +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Zomplex Precision' + PATH( 2: 3 ) = 'PS' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 100 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 100 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRPS( PATH, NOUT ) + INFOT = 0 +* +* Do for each value of N in NVAL +* + DO 150 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + IZERO = 0 + DO 140 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 140 +* +* Do for each value of RANK in RANKVAL +* + DO 130 IRANK = 1, NRANK +* +* Only repeat test 3 to 5 for different ranks +* Other tests use full rank +* + IF( ( IMAT.LT.3 .OR. IMAT.GT.5 ) .AND. IRANK.GT.1 ) + $ GO TO 130 +* + RANK = CEILING( ( N * DBLE( RANKVAL( IRANK ) ) ) + $ / 100.E+0 ) +* +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 120 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with ZLATB5 and generate a test matrix +* with ZLATMT. +* + CALL ZLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'ZLATMT' + CALL ZLATMT( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, RANK, KL, KU, UPLO, A, + $ LDA, WORK, INFO ) +* +* Check error code from ZLATMT. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMT', INFO, 0, UPLO, N, + $ N, -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + GO TO 120 + END IF +* +* Do for each value of NB in NBVAL +* + DO 110 INB = 1, NNB + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) +* +* Compute the pivoted L*L' or U'*U factorization +* of the matrix. +* + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + SRNAMT = 'ZPSTRF' +* +* Use default tolerance +* + TOL = -ONE + CALL ZPSTRF( UPLO, N, AFAC, LDA, PIV, COMPRANK, + $ TOL, RWORK, INFO ) +* +* Check error code from ZPSTRF. +* + IF( (INFO.LT.IZERO) + $ .OR.(INFO.NE.IZERO.AND.RANK.EQ.N) + $ .OR.(INFO.LE.IZERO.AND.RANK.LT.N) ) THEN + CALL ALAERH( PATH, 'ZPSTRF', INFO, IZERO, + $ UPLO, N, N, -1, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) + GO TO 110 + END IF +* +* Skip the test if INFO is not 0. +* + IF( INFO.NE.0 ) + $ GO TO 110 +* +* Reconstruct matrix from factors and compute residual. +* +* PERM holds permuted L*L^T or U^T*U +* + CALL ZPST01( UPLO, N, A, LDA, AFAC, LDA, PERM, LDA, + $ PIV, RWORK, RESULT, COMPRANK ) +* +* Print information about the tests that did not pass +* the threshold or where computed rank was not RANK. +* + IF( N.EQ.0 ) + $ COMPRANK = 0 + RANKDIFF = RANK - COMPRANK + IF( RESULT.GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 )UPLO, N, RANK, + $ RANKDIFF, NB, IMAT, RESULT + NFAIL = NFAIL + 1 + END IF + NRUN = NRUN + 1 + 110 CONTINUE +* + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', RANK =', I3, + $ ', Diff =', I5, ', NB =', I4, ', type ', I2, ', Ratio =', + $ G12.5 ) + RETURN +* +* End of ZCHKPS +* + END diff --git a/TESTING/LIN/zchkpt.f b/TESTING/LIN/zchkpt.f index 4bb7dd9e..fbbda023 100644 --- a/TESTING/LIN/zchkpt.f +++ b/TESTING/LIN/zchkpt.f @@ -114,7 +114,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchkq3.f b/TESTING/LIN/zchkq3.f index 2cd2c26d..d3dcac68 100644 --- a/TESTING/LIN/zchkq3.f +++ b/TESTING/LIN/zchkq3.f @@ -119,7 +119,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchkql.f b/TESTING/LIN/zchkql.f index 5f39f05f..8e08b1f2 100644 --- a/TESTING/LIN/zchkql.f +++ b/TESTING/LIN/zchkql.f @@ -135,7 +135,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchkqp.f b/TESTING/LIN/zchkqp.f index 4c296bd0..2ed2f7a4 100644 --- a/TESTING/LIN/zchkqp.f +++ b/TESTING/LIN/zchkqp.f @@ -109,7 +109,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchkqr.f b/TESTING/LIN/zchkqr.f index 9d9fd703..7dee29bd 100644 --- a/TESTING/LIN/zchkqr.f +++ b/TESTING/LIN/zchkqr.f @@ -135,7 +135,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchkrfp.f b/TESTING/LIN/zchkrfp.f new file mode 100644 index 00000000..14181bec --- /dev/null +++ b/TESTING/LIN/zchkrfp.f @@ -0,0 +1,265 @@ + PROGRAM ZCHKRFP + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* Purpose +* ======= +* +* ZCHKRFP is the main test program for the COMPLEX*16 linear equation +* routines with RFP storage format +* +* +* Internal Parameters +* =================== +* +* MAXIN INTEGER +* The number of different values that can be used for each of +* M, N, or NB +* +* MAXRHS INTEGER +* The maximum number of right hand sides +* +* NTYPES INTEGER +* +* NMAX INTEGER +* The maximum allowable value for N. +* +* NIN INTEGER +* The unit number for input +* +* NOUT INTEGER +* The unit number for output +* +* ===================================================================== +* +* .. Parameters .. + INTEGER MAXIN + PARAMETER ( MAXIN = 12 ) + INTEGER NMAX + PARAMETER ( NMAX = 50 ) + INTEGER MAXRHS + PARAMETER ( MAXRHS = 16 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 9 ) + INTEGER NIN, NOUT + PARAMETER ( NIN = 5, NOUT = 6 ) +* .. +* .. Local Scalars .. + LOGICAL FATAL, TSTERR + INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH + INTEGER I, NN, NNS, NNT + DOUBLE PRECISION EPS, S1, S2, THRESH + +* .. +* .. Local Arrays .. + INTEGER NVAL( MAXIN ), NSVAL( MAXIN ), NTVAL( NTYPES ) + COMPLEX*16 WORKA( NMAX, NMAX ) + COMPLEX*16 WORKASAV( NMAX, NMAX ) + COMPLEX*16 WORKB( NMAX, MAXRHS ) + COMPLEX*16 WORKXACT( NMAX, MAXRHS ) + COMPLEX*16 WORKBSAV( NMAX, MAXRHS ) + COMPLEX*16 WORKX( NMAX, MAXRHS ) + COMPLEX*16 WORKAFAC( NMAX, NMAX ) + COMPLEX*16 WORKAINV( NMAX, NMAX ) + COMPLEX*16 WORKARF( (NMAX*(NMAX+1))/2 ) + COMPLEX*16 WORKAP( (NMAX*(NMAX+1))/2 ) + COMPLEX*16 WORKARFINV( (NMAX*(NMAX+1))/2 ) + COMPLEX*16 Z_WORK_ZLATMS( 3 * NMAX ) + COMPLEX*16 Z_WORK_ZPOT01( NMAX ) + COMPLEX*16 Z_WORK_ZPOT02( NMAX, MAXRHS ) + COMPLEX*16 Z_WORK_ZPOT03( NMAX, NMAX ) + DOUBLE PRECISION D_WORK_ZLATMS( NMAX ) + DOUBLE PRECISION D_WORK_ZLANHE( NMAX ) + DOUBLE PRECISION D_WORK_ZPOT02( NMAX ) + DOUBLE PRECISION D_WORK_ZPOT03( NMAX ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DSECND + EXTERNAL DLAMCH, DSECND +* .. +* .. External Subroutines .. + EXTERNAL ILAVER, ZDRVRFP, ZDRVRF1, ZDRVRF2, ZDRVRF3, + + ZDRVRF4 +* .. +* .. Executable Statements .. +* + S1 = DSECND( ) + FATAL = .FALSE. +* +* Read a dummy line. +* + READ( NIN, FMT = * ) +* +* Report LAPACK version tag (e.g. LAPACK-3.2.0) +* + CALL ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH ) + WRITE( NOUT, FMT = 9994 ) VERS_MAJOR, VERS_MINOR, VERS_PATCH +* +* Read the values of N +* + READ( NIN, FMT = * )NN + IF( NN.LT.1 ) THEN + WRITE( NOUT, FMT = 9996 )' NN ', NN, 1 + NN = 0 + FATAL = .TRUE. + ELSE IF( NN.GT.MAXIN ) THEN + WRITE( NOUT, FMT = 9995 )' NN ', NN, MAXIN + NN = 0 + FATAL = .TRUE. + END IF + READ( NIN, FMT = * )( NVAL( I ), I = 1, NN ) + DO 10 I = 1, NN + IF( NVAL( I ).LT.0 ) THEN + WRITE( NOUT, FMT = 9996 )' M ', NVAL( I ), 0 + FATAL = .TRUE. + ELSE IF( NVAL( I ).GT.NMAX ) THEN + WRITE( NOUT, FMT = 9995 )' M ', NVAL( I ), NMAX + FATAL = .TRUE. + END IF + 10 CONTINUE + IF( NN.GT.0 ) + $ WRITE( NOUT, FMT = 9993 )'N ', ( NVAL( I ), I = 1, NN ) +* +* Read the values of NRHS +* + READ( NIN, FMT = * )NNS + IF( NNS.LT.1 ) THEN + WRITE( NOUT, FMT = 9996 )' NNS', NNS, 1 + NNS = 0 + FATAL = .TRUE. + ELSE IF( NNS.GT.MAXIN ) THEN + WRITE( NOUT, FMT = 9995 )' NNS', NNS, MAXIN + NNS = 0 + FATAL = .TRUE. + END IF + READ( NIN, FMT = * )( NSVAL( I ), I = 1, NNS ) + DO 30 I = 1, NNS + IF( NSVAL( I ).LT.0 ) THEN + WRITE( NOUT, FMT = 9996 )'NRHS', NSVAL( I ), 0 + FATAL = .TRUE. + ELSE IF( NSVAL( I ).GT.MAXRHS ) THEN + WRITE( NOUT, FMT = 9995 )'NRHS', NSVAL( I ), MAXRHS + FATAL = .TRUE. + END IF + 30 CONTINUE + IF( NNS.GT.0 ) + $ WRITE( NOUT, FMT = 9993 )'NRHS', ( NSVAL( I ), I = 1, NNS ) +* +* Read the matrix types +* + READ( NIN, FMT = * )NNT + IF( NNT.LT.1 ) THEN + WRITE( NOUT, FMT = 9996 )' NMA', NNT, 1 + NNT = 0 + FATAL = .TRUE. + ELSE IF( NNT.GT.NTYPES ) THEN + WRITE( NOUT, FMT = 9995 )' NMA', NNT, NTYPES + NNT = 0 + FATAL = .TRUE. + END IF + READ( NIN, FMT = * )( NTVAL( I ), I = 1, NNT ) + DO 320 I = 1, NNT + IF( NTVAL( I ).LT.0 ) THEN + WRITE( NOUT, FMT = 9996 )'TYPE', NTVAL( I ), 0 + FATAL = .TRUE. + ELSE IF( NTVAL( I ).GT.NTYPES ) THEN + WRITE( NOUT, FMT = 9995 )'TYPE', NTVAL( I ), NTYPES + FATAL = .TRUE. + END IF + 320 CONTINUE + IF( NNT.GT.0 ) + $ WRITE( NOUT, FMT = 9993 )'TYPE', ( NTVAL( I ), I = 1, NNT ) +* +* Read the threshold value for the test ratios. +* + READ( NIN, FMT = * )THRESH + WRITE( NOUT, FMT = 9992 )THRESH +* +* Read the flag that indicates whether to test the error exits. +* + READ( NIN, FMT = * )TSTERR +* + IF( FATAL ) THEN + WRITE( NOUT, FMT = 9999 ) + STOP + END IF +* + IF( FATAL ) THEN + WRITE( NOUT, FMT = 9999 ) + STOP + END IF +* +* Calculate and print the machine dependent constants. +* + EPS = DLAMCH( 'Underflow threshold' ) + WRITE( NOUT, FMT = 9991 )'underflow', EPS + EPS = DLAMCH( 'Overflow threshold' ) + WRITE( NOUT, FMT = 9991 )'overflow ', EPS + EPS = DLAMCH( 'Epsilon' ) + WRITE( NOUT, FMT = 9991 )'precision', EPS + WRITE( NOUT, FMT = * ) +* +* Test the error exit of: +* + IF( TSTERR ) + $ CALL ZERRRFP( NOUT ) +* +* Test the routines: zpftrf, zpftri, zpftrs (as in ZDRVPO). +* This also tests the routines: ztfsm, ztftri, ztfttr, ztrttf. +* + CALL ZDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, THRESH, + $ WORKA, WORKASAV, WORKAFAC, WORKAINV, WORKB, + $ WORKBSAV, WORKXACT, WORKX, WORKARF, WORKARFINV, + $ Z_WORK_ZLATMS, Z_WORK_ZPOT01, Z_WORK_ZPOT02, + $ Z_WORK_ZPOT03, D_WORK_ZLATMS, D_WORK_ZLANHE, + $ D_WORK_ZPOT02, D_WORK_ZPOT03 ) +* +* Test the routine: zlanhf +* + CALL ZDRVRF1( NOUT, NN, NVAL, THRESH, WORKA, NMAX, WORKARF, + + D_WORK_ZLANHE ) +* +* Test the convertion routines: +* zhfttp, ztpthf, ztfttr, ztrttf, ztrttp and ztpttr. +* + CALL ZDRVRF2( NOUT, NN, NVAL, WORKA, NMAX, WORKARF, + + WORKAP, WORKASAV ) +* +* Test the routine: ztfsm +* + CALL ZDRVRF3( NOUT, NN, NVAL, THRESH, WORKA, NMAX, WORKARF, + + WORKAINV, WORKAFAC, D_WORK_ZLANHE, + + Z_WORK_ZPOT03, Z_WORK_ZPOT01 ) + +* +* Test the routine: zhfrk +* + CALL ZDRVRF4( NOUT, NN, NVAL, THRESH, WORKA, WORKAFAC, NMAX, + + WORKARF, WORKAINV, NMAX,D_WORK_ZLANHE) +* + CLOSE ( NIN ) + S2 = DSECND( ) + WRITE( NOUT, FMT = 9998 ) + WRITE( NOUT, FMT = 9997 )S2 - S1 +* + 9999 FORMAT( / ' Execution not attempted due to input errors' ) + 9998 FORMAT( / ' End of tests' ) + 9997 FORMAT( ' Total time used = ', F12.2, ' seconds', / ) + 9996 FORMAT( ' !! Invalid input value: ', A4, '=', I6, '; must be >=', + $ I6 ) + 9995 FORMAT( ' !! Invalid input value: ', A4, '=', I6, '; must be <=', + $ I6 ) + 9994 FORMAT( / ' Tests of the COMPLEX*16 LAPACK RFP routines ', + $ / ' LAPACK VERSION ', I1, '.', I1, '.', I1, + $ / / ' The following parameter values will be used:' ) + 9993 FORMAT( 4X, A4, ': ', 10I6, / 11X, 10I6 ) + 9992 FORMAT( / ' Routines pass computational tests if test ratio is ', + $ 'less than', F8.2, / ) + 9991 FORMAT( ' Relative machine ', A, ' is taken to be', D16.6 ) +* +* End of ZCHKRFP +* + END diff --git a/TESTING/LIN/zchkrq.f b/TESTING/LIN/zchkrq.f index 75e963e9..2916fa83 100644 --- a/TESTING/LIN/zchkrq.f +++ b/TESTING/LIN/zchkrq.f @@ -135,7 +135,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchksp.f b/TESTING/LIN/zchksp.f index a6df045c..d6d3bcc0 100644 --- a/TESTING/LIN/zchksp.f +++ b/TESTING/LIN/zchksp.f @@ -123,7 +123,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchksy.f b/TESTING/LIN/zchksy.f index d23bff96..fcc794ae 100644 --- a/TESTING/LIN/zchksy.f +++ b/TESTING/LIN/zchksy.f @@ -125,7 +125,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchktb.f b/TESTING/LIN/zchktb.f index b22fc773..a3517c38 100644 --- a/TESTING/LIN/zchktb.f +++ b/TESTING/LIN/zchktb.f @@ -114,7 +114,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchktp.f b/TESTING/LIN/zchktp.f index 45bc5cad..8e8ae6e6 100644 --- a/TESTING/LIN/zchktp.f +++ b/TESTING/LIN/zchktp.f @@ -114,7 +114,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchktr.f b/TESTING/LIN/zchktr.f index 7f767e93..b0e0e52f 100644 --- a/TESTING/LIN/zchktr.f +++ b/TESTING/LIN/zchktr.f @@ -120,7 +120,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zchktz.f b/TESTING/LIN/zchktz.f index ebd33486..138bf79d 100644 --- a/TESTING/LIN/zchktz.f +++ b/TESTING/LIN/zchktz.f @@ -105,7 +105,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zdrvab.f b/TESTING/LIN/zdrvab.f index ddb0aef4..07c31808 100644 --- a/TESTING/LIN/zdrvab.f +++ b/TESTING/LIN/zdrvab.f @@ -113,7 +113,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER*6 SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. @@ -223,7 +223,7 @@ CALL ZLACPY( 'Full', M, N, A, LDA, AFAC, LDA ) * CALL ZCGESV( N, NRHS, A, LDA, IWORK, B, LDA, X, LDA, - $ WORK, SWORK, ITER, INFO) + $ WORK, SWORK, RWORK, ITER, INFO) * IF (ITER.LT.0) THEN CALL ZLACPY( 'Full', M, N, AFAC, LDA, A, LDA ) diff --git a/TESTING/LIN/zdrvac.f b/TESTING/LIN/zdrvac.f new file mode 100644 index 00000000..423bd7ec --- /dev/null +++ b/TESTING/LIN/zdrvac.f @@ -0,0 +1,376 @@ + SUBROUTINE ZDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX, + $ A, AFAC, B, X, WORK, + $ RWORK, SWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1.2) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* May 2007 +* +* .. Scalar Arguments .. + INTEGER NMAX, NM, NNS, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER MVAL( * ), NSVAL( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX SWORK(*) + COMPLEX*16 A( * ), AFAC( * ), B( * ), + $ WORK( * ), X( * ) +* .. +* +* Purpose +* ======= +* +* ZDRVAC tests ZCPOSV. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NM (input) INTEGER +* The number of values of N contained in the vector MVAL. +* +* MVAL (input) INTEGER array, dimension (NM) +* The values of the matrix dimension N. +* +* NNS (input) INTEGER +* The number of values of NRHS contained in the vector NSVAL. +* +* NSVAL (input) INTEGER array, dimension (NNS) +* The values of the number of right hand sides NRHS. +* +* THRESH (input) 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. +* +* NMAX (input) INTEGER +* The maximum value permitted for N, used in dimensioning the +* work arrays. +* +* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) +* +* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) +* +* B (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) +* +* X (workspace) COMPLEX*16 array, dimension (NMAX*NSMAX) +* +* WORK (workspace) COMPLEX*16 array, dimension +* (NMAX*max(3,NSMAX)) +* +* RWORK (workspace) DOUBLE PRECISION array, dimension +* (max(2*NMAX,2*NSMAX+NWORK)) +* +* SWORK (workspace) COMPLEX array, dimension +* (NMAX*(NSMAX+NMAX)) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 9 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 1 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + CHARACTER DIST, TYPE, UPLO, XTYPE + CHARACTER*3 PATH + INTEGER I, IM, IMAT, INFO, IOFF, IRHS, IUPLO, + $ IZERO, KL, KU, LDA, MODE, N, + $ NERRS, NFAIL, NIMAT, NRHS, NRUN + DOUBLE PRECISION ANORM, CNDNUM +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. Local Variables .. + INTEGER ITER, KASE +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ZLACPY, ZLAIPD, + $ ZLARHS, ZLATB4, ZLATMS, + $ ZPOT06, ZCPOSV +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, 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. +* + KASE = 0 + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'PO' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* + INFOT = 0 +* +* Do for each value of N in MVAL +* + DO 120 IM = 1, NM + N = MVAL( IM ) + LDA = MAX( N, 1 ) + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 110 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 110 +* +* Skip types 3, 4, or 5 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 110 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 100 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with ZLATB4 and generate a test matrix +* with ZLATMS. +* + CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) +* + 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. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 100 + END IF +* +* For types 3-5, zero one row and column 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 + IOFF = ( IZERO-1 )*LDA +* +* Set row and column IZERO of A to 0. +* + IF( IUPLO.EQ.1 ) THEN + 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 + IZERO = 0 + END IF +* +* Set the imaginary part of the diagonals. +* + CALL ZLAIPD( N, A, LDA+1, 0 ) +* + DO 60 IRHS = 1, NNS + NRHS = NSVAL( IRHS ) + XTYPE = 'N' +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, X, LDA, B, LDA, + $ ISEED, INFO ) +* +* Compute the L*L' or U'*U factorization of the +* matrix and solve the system. +* + SRNAMT = 'ZCPOSV ' + KASE = KASE + 1 +* + CALL ZLACPY( 'All', N, N, A, LDA, AFAC, LDA) +* + CALL ZCPOSV( UPLO, N, NRHS, AFAC, LDA, B, LDA, X, LDA, + $ WORK, SWORK, RWORK, ITER, INFO ) +* + IF (ITER.LT.0) THEN + CALL ZLACPY( 'All', N, N, A, LDA, AFAC, LDA ) + ENDIF +* +* Check error code from ZCPOSV . +* + IF( INFO.NE.IZERO ) THEN +* + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + NERRS = NERRS + 1 +* + IF( INFO.NE.IZERO .AND. IZERO.NE.0 ) THEN + WRITE( NOUT, FMT = 9988 )'ZCPOSV',INFO,IZERO,N, + $ IMAT + ELSE + WRITE( NOUT, FMT = 9975 )'ZCPOSV',INFO,N,IMAT + END IF + END IF +* +* Skip the remaining test if the matrix is singular. +* + IF( INFO.NE.0 ) + $ GO TO 110 +* +* Check the quality of the solution +* + CALL ZLACPY( 'All', N, NRHS, B, LDA, WORK, LDA ) +* + CALL ZPOT06( UPLO, N, NRHS, A, LDA, X, LDA, WORK, + $ LDA, RWORK, RESULT( 1 ) ) +* +* Check if the test passes the tesing. +* Print information about the tests that did not +* pass the testing. +* +* If iterative refinement has been used and claimed to +* be successful (ITER>0), we want +* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS*SRQT(N)) < 1 +* +* If double precision has been used (ITER<0), we want +* NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS) < THRES +* (Cf. the linear solver testing routines) +* + IF ((THRESH.LE.0.0E+00) + $ .OR.((ITER.GE.0).AND.(N.GT.0) + $ .AND.(RESULT(1).GE.SQRT(DBLE(N)))) + $ .OR.((ITER.LT.0).AND.(RESULT(1).GE.THRESH))) THEN +* + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN + WRITE( NOUT, FMT = 8999 )'ZPO' + WRITE( NOUT, FMT = '( '' Matrix types:'' )' ) + WRITE( NOUT, FMT = 8979 ) + WRITE( NOUT, FMT = '( '' Test ratios:'' )' ) + WRITE( NOUT, FMT = 8960 )1 + WRITE( NOUT, FMT = '( '' Messages:'' )' ) + END IF +* + WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, IMAT, 1, + $ RESULT( 1 ) +* + NFAIL = NFAIL + 1 +* + END IF +* + NRUN = NRUN + 1 +* + 60 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE +* + 130 CONTINUE +* +* Print a summary of the results. +* + IF( NFAIL.GT.0 ) THEN + WRITE( NOUT, FMT = 9996 )'ZCPOSV', NFAIL, NRUN + ELSE + WRITE( NOUT, FMT = 9995 )'ZCPOSV', NRUN + END IF + IF( NERRS.GT.0 ) THEN + WRITE( NOUT, FMT = 9994 )NERRS + END IF +* + 9998 FORMAT( ' UPLO=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ', + $ I2, ', test(', I2, ') =', G12.5 ) + 9996 FORMAT( 1X, A6, ': ', I6, ' out of ', I6, + $ ' tests failed to pass the threshold' ) + 9995 FORMAT( /1X, 'All tests for ', A6, + $ ' routines passed the threshold (', I6, ' tests run)' ) + 9994 FORMAT( 6X, I6, ' error messages recorded' ) +* +* SUBNAM, INFO, INFOE, N, IMAT +* + 9988 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ', + $ I5, / ' ==> N =', I5, ', type ', + $ I2 ) +* +* SUBNAM, INFO, N, IMAT +* + 9975 FORMAT( ' *** Error code from ', A6, '=', I5, ' for M=', I5, + $ ', type ', I2 ) + 8999 FORMAT( / 1X, A3, ': positive definite dense matrices' ) + 8979 FORMAT( 4X, '1. Diagonal', 24X, '7. Last n/2 columns zero', / 4X, + $ '2. Upper triangular', 16X, + $ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4X, + $ '3. Lower triangular', 16X, '9. Random, CNDNUM = 0.1/EPS', + $ / 4X, '4. Random, CNDNUM = 2', 13X, + $ '10. Scaled near underflow', / 4X, '5. First column zero', + $ 14X, '11. Scaled near overflow', / 4X, + $ '6. Last column zero' ) + 8960 FORMAT( 3X, I2, ': norm_1( B - A * X ) / ', + $ '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF', + $ / 4x, 'or norm_1( B - A * X ) / ', + $ '( norm_1(A) * norm_1(X) * EPS ) > THRES if ZPOTRF' ) + + RETURN +* +* End of ZDRVAC +* + END diff --git a/TESTING/LIN/zdrvgb.f b/TESTING/LIN/zdrvgb.f index 8e0aa90a..d7baa097 100644 --- a/TESTING/LIN/zdrvgb.f +++ b/TESTING/LIN/zdrvgb.f @@ -130,7 +130,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zdrvgbx.f b/TESTING/LIN/zdrvgbx.f new file mode 100644 index 00000000..db84ee14 --- /dev/null +++ b/TESTING/LIN/zdrvgbx.f @@ -0,0 +1,930 @@ + SUBROUTINE ZDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, A, LA, + $ AFB, LAFB, ASAV, B, BSAV, X, XACT, S, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER LA, LAFB, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ), S( * ) + COMPLEX*16 A( * ), AFB( * ), ASAV( * ), B( * ), BSAV( * ), + $ WORK( * ), X( * ), XACT( * ) +* .. +* +* Purpose +* ======= +* +* ZDRVGB tests the driver routines ZGBSV and -SVX. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix column dimension N. +* +* NRHS (input) INTEGER +* The number of right hand side vectors to be generated for +* each linear system. +* +* THRESH (input) 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. +* +* TSTERR (input) LOGICAL +* Flag that indicates whether error exits are to be tested. +* +* A (workspace) COMPLEX*16 array, dimension (LA) +* +* LA (input) INTEGER +* The length of the array A. LA >= (2*NMAX-1)*NMAX +* where NMAX is the largest entry in NVAL. +* +* AFB (workspace) COMPLEX*16 array, dimension (LAFB) +* +* LAFB (input) INTEGER +* The length of the array AFB. LAFB >= (3*NMAX-2)*NMAX +* where NMAX is the largest entry in NVAL. +* +* ASAV (workspace) COMPLEX*16 array, dimension (LA) +* +* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) +* +* BSAV (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) +* +* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) +* +* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) +* +* S (workspace) DOUBLE PRECISION array, dimension (2*NMAX) +* +* WORK (workspace) COMPLEX*16 array, dimension +* (NMAX*max(3,NRHS,NMAX)) +* +* RWORK (workspace) DOUBLE PRECISION array, dimension +* (max(NMAX,2*NRHS)) +* +* IWORK (workspace) INTEGER array, dimension (NMAX) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 8 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) + INTEGER NTRAN + PARAMETER ( NTRAN = 3 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT + CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE + CHARACTER*3 PATH + INTEGER I, I1, I2, IEQUED, IFACT, IKL, IKU, IMAT, IN, + $ INFO, IOFF, ITRAN, IZERO, J, K, K1, KL, KU, + $ LDA, LDAFB, LDB, MODE, N, NB, NBMIN, NERRS, + $ NFACT, NFAIL, NIMAT, NKL, NKU, NRUN, NT, + $ N_ERR_BNDS + DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, ANRMPV, + $ CNDNUM, COLCND, RCOND, RCONDC, RCONDI, RCONDO, + $ ROLDC, ROLDI, ROLDO, ROWCND, RPVGRW, + $ RPVGRW_SVXX +* .. +* .. Local Arrays .. + CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RDUM( 1 ), RESULT( NTESTS ), BERR( NRHS ), + $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DGET06, DLAMCH, ZLANGB, ZLANGE, ZLANTB, + $ ZLA_GBRPVGRW + EXTERNAL LSAME, DGET06, DLAMCH, ZLANGB, ZLANGE, ZLANTB, + $ ZLA_GBRPVGRW +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, ZGBEQU, + $ ZGBSV, ZGBSVX, ZGBT01, ZGBT02, ZGBT05, ZGBTRF, + $ ZGBTRS, ZGET04, ZLACPY, ZLAQGB, ZLARHS, ZLASET, + $ ZLATB4, ZLATMS, ZGBSVXX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DCMPLX, MAX, MIN +* .. +* .. 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 TRANSS / 'N', 'T', 'C' / + DATA FACTS / 'F', 'N', 'E' / + DATA EQUEDS / 'N', 'R', 'C', 'B' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'GB' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 150 IN = 1, NN + N = NVAL( IN ) + LDB = MAX( N, 1 ) + XTYPE = 'N' +* +* Set limits on the number of loop iterations. +* + NKL = MAX( 1, MIN( N, 4 ) ) + IF( N.EQ.0 ) + $ NKL = 1 + NKU = NKL + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 140 IKL = 1, NKL +* +* Do for KL = 0, N-1, (3N-1)/4, and (N+1)/4. This order makes +* it easier to skip redundant values for small values of N. +* + IF( IKL.EQ.1 ) THEN + KL = 0 + ELSE IF( IKL.EQ.2 ) THEN + KL = MAX( N-1, 0 ) + ELSE IF( IKL.EQ.3 ) THEN + KL = ( 3*N-1 ) / 4 + ELSE IF( IKL.EQ.4 ) THEN + KL = ( N+1 ) / 4 + END IF + DO 130 IKU = 1, NKU +* +* Do for KU = 0, N-1, (3N-1)/4, and (N+1)/4. This order +* makes it easier to skip redundant values for small +* values of N. +* + IF( IKU.EQ.1 ) THEN + KU = 0 + ELSE IF( IKU.EQ.2 ) THEN + KU = MAX( N-1, 0 ) + ELSE IF( IKU.EQ.3 ) THEN + KU = ( 3*N-1 ) / 4 + ELSE IF( IKU.EQ.4 ) THEN + KU = ( N+1 ) / 4 + END IF +* +* Check that A and AFB are big enough to generate this +* matrix. +* + LDA = KL + KU + 1 + LDAFB = 2*KL + KU + 1 + IF( LDA*N.GT.LA .OR. LDAFB*N.GT.LAFB ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( LDA*N.GT.LA ) THEN + WRITE( NOUT, FMT = 9999 )LA, N, KL, KU, + $ N*( KL+KU+1 ) + NERRS = NERRS + 1 + END IF + IF( LDAFB*N.GT.LAFB ) THEN + WRITE( NOUT, FMT = 9998 )LAFB, N, KL, KU, + $ N*( 2*KL+KU+1 ) + NERRS = NERRS + 1 + END IF + GO TO 130 + END IF +* + DO 120 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 120 +* +* Skip types 2, 3, or 4 if the matrix is too small. +* + ZEROT = IMAT.GE.2 .AND. IMAT.LE.4 + IF( ZEROT .AND. N.LT.IMAT-1 ) + $ GO TO 120 +* +* Set up parameters with ZLATB4 and generate a +* test matrix with ZLATMS. +* + CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) + RCONDC = ONE / CNDNUM +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, + $ CNDNUM, ANORM, KL, KU, 'Z', A, LDA, WORK, + $ INFO ) +* +* Check the error code from ZLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', N, N, + $ KL, KU, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 120 + END IF +* +* For types 2, 3, and 4, zero one or more columns of +* the matrix to test that INFO is returned correctly. +* + IZERO = 0 + IF( ZEROT ) THEN + IF( IMAT.EQ.2 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.3 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF + IOFF = ( IZERO-1 )*LDA + IF( IMAT.LT.4 ) THEN + I1 = MAX( 1, KU+2-IZERO ) + I2 = MIN( KL+KU+1, KU+1+( N-IZERO ) ) + DO 20 I = I1, I2 + A( IOFF+I ) = ZERO + 20 CONTINUE + ELSE + DO 40 J = IZERO, N + DO 30 I = MAX( 1, KU+2-J ), + $ MIN( KL+KU+1, KU+1+( N-J ) ) + A( IOFF+I ) = ZERO + 30 CONTINUE + IOFF = IOFF + LDA + 40 CONTINUE + END IF + END IF +* +* Save a copy of the matrix A in ASAV. +* + CALL ZLACPY( 'Full', KL+KU+1, N, A, LDA, ASAV, LDA ) +* + DO 110 IEQUED = 1, 4 + EQUED = EQUEDS( IEQUED ) + IF( IEQUED.EQ.1 ) THEN + NFACT = 3 + ELSE + NFACT = 1 + END IF +* + DO 100 IFACT = 1, NFACT + FACT = FACTS( IFACT ) + PREFAC = LSAME( FACT, 'F' ) + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) +* + IF( ZEROT ) THEN + IF( PREFAC ) + $ GO TO 100 + RCONDO = ZERO + RCONDI = ZERO +* + ELSE IF( .NOT.NOFACT ) THEN +* +* Compute the condition number for comparison +* with the value returned by DGESVX (FACT = +* 'N' reuses the condition number from the +* previous iteration with FACT = 'F'). +* + CALL ZLACPY( 'Full', KL+KU+1, N, ASAV, LDA, + $ AFB( KL+1 ), LDAFB ) + IF( EQUIL .OR. IEQUED.GT.1 ) THEN +* +* Compute row and column scale factors to +* equilibrate the matrix A. +* + CALL ZGBEQU( N, N, KL, KU, AFB( KL+1 ), + $ LDAFB, S, S( N+1 ), ROWCND, + $ COLCND, AMAX, INFO ) + IF( INFO.EQ.0 .AND. N.GT.0 ) THEN + IF( LSAME( EQUED, 'R' ) ) THEN + ROWCND = ZERO + COLCND = ONE + ELSE IF( LSAME( EQUED, 'C' ) ) THEN + ROWCND = ONE + COLCND = ZERO + ELSE IF( LSAME( EQUED, 'B' ) ) THEN + ROWCND = ZERO + COLCND = ZERO + END IF +* +* Equilibrate the matrix. +* + CALL ZLAQGB( N, N, KL, KU, AFB( KL+1 ), + $ LDAFB, S, S( N+1 ), + $ ROWCND, COLCND, AMAX, + $ EQUED ) + END IF + END IF +* +* Save the condition number of the +* non-equilibrated system for use in ZGET04. +* + IF( EQUIL ) THEN + ROLDO = RCONDO + ROLDI = RCONDI + END IF +* +* Compute the 1-norm and infinity-norm of A. +* + ANORMO = ZLANGB( '1', N, KL, KU, AFB( KL+1 ), + $ LDAFB, RWORK ) + ANORMI = ZLANGB( 'I', N, KL, KU, AFB( KL+1 ), + $ LDAFB, RWORK ) +* +* Factor the matrix A. +* + CALL ZGBTRF( N, N, KL, KU, AFB, LDAFB, IWORK, + $ INFO ) +* +* Form the inverse of A. +* + CALL ZLASET( 'Full', N, N, DCMPLX( ZERO ), + $ DCMPLX( ONE ), WORK, LDB ) + SRNAMT = 'ZGBTRS' + CALL ZGBTRS( 'No transpose', N, KL, KU, N, + $ AFB, LDAFB, IWORK, WORK, LDB, + $ INFO ) +* +* Compute the 1-norm condition number of A. +* + AINVNM = ZLANGE( '1', N, N, WORK, LDB, + $ RWORK ) + IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDO = ONE + ELSE + RCONDO = ( ONE / ANORMO ) / AINVNM + END IF +* +* Compute the infinity-norm condition number +* of A. +* + AINVNM = ZLANGE( 'I', N, N, WORK, LDB, + $ RWORK ) + IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDI = ONE + ELSE + RCONDI = ( ONE / ANORMI ) / AINVNM + END IF + END IF +* + DO 90 ITRAN = 1, NTRAN +* +* Do for each value of TRANS. +* + TRANS = TRANSS( ITRAN ) + IF( ITRAN.EQ.1 ) THEN + RCONDC = RCONDO + ELSE + RCONDC = RCONDI + END IF +* +* Restore the matrix A. +* + CALL ZLACPY( 'Full', KL+KU+1, N, ASAV, LDA, + $ A, LDA ) +* +* Form an exact solution and set the right hand +* side. +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( PATH, XTYPE, 'Full', TRANS, N, + $ N, KL, KU, NRHS, A, LDA, XACT, + $ LDB, B, LDB, ISEED, INFO ) + XTYPE = 'C' + CALL ZLACPY( 'Full', N, NRHS, B, LDB, BSAV, + $ LDB ) +* + IF( NOFACT .AND. ITRAN.EQ.1 ) THEN +* +* --- Test ZGBSV --- +* +* Compute the LU factorization of the matrix +* and solve the system. +* + CALL ZLACPY( 'Full', KL+KU+1, N, A, LDA, + $ AFB( KL+1 ), LDAFB ) + CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, + $ LDB ) +* + SRNAMT = 'ZGBSV ' + CALL ZGBSV( N, KL, KU, NRHS, AFB, LDAFB, + $ IWORK, X, LDB, INFO ) +* +* Check error code from ZGBSV . +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'ZGBSV ', INFO, + $ IZERO, ' ', N, N, KL, KU, + $ NRHS, IMAT, NFAIL, NERRS, + $ NOUT ) + GOTO 90 + END IF +* +* Reconstruct matrix from factors and +* compute residual. +* + CALL ZGBT01( N, N, KL, KU, A, LDA, AFB, + $ LDAFB, IWORK, WORK, + $ RESULT( 1 ) ) + NT = 1 + IF( IZERO.EQ.0 ) THEN +* +* Compute residual of the computed +* solution. +* + CALL ZLACPY( 'Full', N, NRHS, B, LDB, + $ WORK, LDB ) + CALL ZGBT02( 'No transpose', N, N, KL, + $ KU, NRHS, A, LDA, X, LDB, + $ WORK, LDB, RESULT( 2 ) ) +* +* Check solution from generated exact +* solution. +* + CALL ZGET04( N, NRHS, X, LDB, XACT, + $ LDB, RCONDC, RESULT( 3 ) ) + NT = 3 + END IF +* +* Print information about the tests that did +* not pass the threshold. +* + DO 50 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9997 )'ZGBSV ', + $ N, KL, KU, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 50 CONTINUE + NRUN = NRUN + NT + END IF +* +* --- Test ZGBSVX --- +* + IF( .NOT.PREFAC ) + $ CALL ZLASET( 'Full', 2*KL+KU+1, N, + $ DCMPLX( ZERO ), + $ DCMPLX( ZERO ), AFB, LDAFB ) + CALL ZLASET( 'Full', N, NRHS, DCMPLX( ZERO ), + $ DCMPLX( ZERO ), X, LDB ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT = 'F' and +* EQUED = 'R', 'C', or 'B'. +* + CALL ZLAQGB( N, N, KL, KU, A, LDA, S, + $ S( N+1 ), ROWCND, COLCND, + $ AMAX, EQUED ) + END IF +* +* Solve the system and compute the condition +* number and error bounds using ZGBSVX. +* + SRNAMT = 'ZGBSVX' + CALL ZGBSVX( FACT, TRANS, N, KL, KU, NRHS, A, + $ LDA, AFB, LDAFB, IWORK, EQUED, + $ S, S( LDB+1 ), B, LDB, X, LDB, + $ RCOND, RWORK, RWORK( NRHS+1 ), + $ WORK, RWORK( 2*NRHS+1 ), INFO ) +* +* Check the error code from ZGBSVX. +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'ZGBSVX', INFO, IZERO, + $ FACT // TRANS, N, N, KL, KU, + $ NRHS, IMAT, NFAIL, NERRS, + $ NOUT ) + GOTO 90 + END IF +* Compare RWORK(2*NRHS+1) from ZGBSVX with the +* computed reciprocal pivot growth RPVGRW +* + IF( INFO.NE.0 ) THEN + ANRMPV = ZERO + DO 70 J = 1, INFO + DO 60 I = MAX( KU+2-J, 1 ), + $ MIN( N+KU+1-J, KL+KU+1 ) + ANRMPV = MAX( ANRMPV, + $ ABS( A( I+( J-1 )*LDA ) ) ) + 60 CONTINUE + 70 CONTINUE + RPVGRW = ZLANTB( 'M', 'U', 'N', INFO, + $ MIN( INFO-1, KL+KU ), + $ AFB( MAX( 1, KL+KU+2-INFO ) ), + $ LDAFB, RDUM ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = ANRMPV / RPVGRW + END IF + ELSE + RPVGRW = ZLANTB( 'M', 'U', 'N', N, KL+KU, + $ AFB, LDAFB, RDUM ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = ZLANGB( 'M', N, KL, KU, A, + $ LDA, RDUM ) / RPVGRW + END IF + END IF + RESULT( 7 ) = ABS( RPVGRW-RWORK( 2*NRHS+1 ) ) + $ / MAX( RWORK( 2*NRHS+1 ), + $ RPVGRW ) / DLAMCH( 'E' ) +* + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and +* compute residual. +* + CALL ZGBT01( N, N, KL, KU, A, LDA, AFB, + $ LDAFB, IWORK, WORK, + $ RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* + IF( INFO.EQ.0 ) THEN + TRFCON = .FALSE. +* +* Compute residual of the computed solution. +* + CALL ZLACPY( 'Full', N, NRHS, BSAV, LDB, + $ WORK, LDB ) + CALL ZGBT02( TRANS, N, N, KL, KU, NRHS, + $ ASAV, LDA, X, LDB, WORK, LDB, + $ RESULT( 2 ) ) +* +* Check solution from generated exact +* solution. +* + IF( NOFACT .OR. ( PREFAC .AND. + $ LSAME( EQUED, 'N' ) ) ) THEN + CALL ZGET04( N, NRHS, X, LDB, XACT, + $ LDB, RCONDC, RESULT( 3 ) ) + ELSE + IF( ITRAN.EQ.1 ) THEN + ROLDC = ROLDO + ELSE + ROLDC = ROLDI + END IF + CALL ZGET04( N, NRHS, X, LDB, XACT, + $ LDB, ROLDC, RESULT( 3 ) ) + END IF +* +* Check the error bounds from iterative +* refinement. +* + CALL ZGBT05( TRANS, N, KL, KU, NRHS, ASAV, + $ LDA, BSAV, LDB, X, LDB, XACT, + $ LDB, RWORK, RWORK( NRHS+1 ), + $ RESULT( 4 ) ) + ELSE + TRFCON = .TRUE. + END IF +* +* Compare RCOND from ZGBSVX with the computed +* value in RCONDC. +* + RESULT( 6 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did +* not pass the threshold. +* + IF( .NOT.TRFCON ) THEN + DO 80 K = K1, NTESTS + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9995 ) + $ 'ZGBSVX', FACT, TRANS, N, KL, + $ KU, EQUED, IMAT, K, + $ RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9996 ) + $ 'ZGBSVX', FACT, TRANS, N, KL, + $ KU, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 80 CONTINUE + NRUN = NRUN + 7 - K1 + ELSE + IF( RESULT( 1 ).GE.THRESH .AND. .NOT. + $ PREFAC ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9995 )'ZGBSVX', + $ FACT, TRANS, N, KL, KU, EQUED, + $ IMAT, 1, RESULT( 1 ) + ELSE + WRITE( NOUT, FMT = 9996 )'ZGBSVX', + $ FACT, TRANS, N, KL, KU, IMAT, 1, + $ RESULT( 1 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 6 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9995 )'ZGBSVX', + $ FACT, TRANS, N, KL, KU, EQUED, + $ IMAT, 6, RESULT( 6 ) + ELSE + WRITE( NOUT, FMT = 9996 )'ZGBSVX', + $ FACT, TRANS, N, KL, KU, IMAT, 6, + $ RESULT( 6 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9995 )'ZGBSVX', + $ FACT, TRANS, N, KL, KU, EQUED, + $ IMAT, 7, RESULT( 7 ) + ELSE + WRITE( NOUT, FMT = 9996 )'ZGBSVX', + $ FACT, TRANS, N, KL, KU, IMAT, 7, + $ RESULT( 7 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + END IF + +* --- Test ZGBSVXX --- + +* Restore the matrices A and B. + +c write(*,*) 'begin zgbsvxx testing' + + CALL ZLACPY( 'Full', KL+KU+1, N, ASAV, LDA, A, + $ LDA ) + CALL ZLACPY( 'Full', N, NRHS, BSAV, LDB, B, LDB ) + + IF( .NOT.PREFAC ) + $ CALL ZLASET( 'Full', 2*KL+KU+1, N, ZERO, ZERO, + $ AFB, LDAFB ) + CALL ZLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDB ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT = 'F' and +* EQUED = 'R', 'C', or 'B'. +* + CALL ZLAQGB( N, N, KL, KU, A, LDA, S, + $ S( N+1 ), ROWCND, COLCND, AMAX, EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using ZGBSVXX. +* + SRNAMT = 'ZGBSVXX' + n_err_bnds = 3 + CALL ZGBSVXX( FACT, TRANS, N, KL, KU, NRHS, A, LDA, + $ AFB, LDAFB, IWORK, EQUED, S, S( N+1 ), B, LDB, + $ X, LDB, rcond, rpvgrw_svxx, berr, n_err_bnds, + $ errbnds_n, errbnds_c, 0, ZERO, WORK, + $ RWORK, INFO ) +* +* Check the error code from ZGBSVXX. +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'ZGBSVXX', INFO, IZERO, + $ FACT // TRANS, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GOTO 90 + END IF +* +* Compare rpvgrw_svxx from ZGESVXX with the computed +* reciprocal pivot growth factor RPVGRW +* + + IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN + RPVGRW = ZLA_GBRPVGRW(N, KL, KU, INFO, A, LDA, + $ AFB, LDAFB) + ELSE + RPVGRW = ZLA_GBRPVGRW(N, KL, KU, N, A, LDA, + $ AFB, LDAFB) + ENDIF + + RESULT( 7 ) = ABS( RPVGRW-rpvgrw_svxx ) / + $ MAX( rpvgrw_svxx, RPVGRW ) / + $ DLAMCH( 'E' ) +* + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL ZGBT01( N, N, KL, KU, A, LDA, AFB, LDAFB, + $ IWORK, RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* + IF( INFO.EQ.0 ) THEN + TRFCON = .FALSE. +* +* Compute residual of the computed solution. +* + CALL ZLACPY( 'Full', N, NRHS, BSAV, LDB, WORK, + $ LDB ) + CALL ZGBT02( TRANS, N, N, KL, KU, NRHS, ASAV, + $ LDA, X, LDB, WORK, LDB, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL ZGET04( N, NRHS, X, LDB, XACT, LDB, + $ RCONDC, RESULT( 3 ) ) + ELSE + IF( ITRAN.EQ.1 ) THEN + ROLDC = ROLDO + ELSE + ROLDC = ROLDI + END IF + CALL ZGET04( N, NRHS, X, LDB, XACT, LDB, + $ ROLDC, RESULT( 3 ) ) + END IF + ELSE + TRFCON = .TRUE. + END IF +* +* Compare RCOND from ZGBSVXX with the computed value +* in RCONDC. +* + RESULT( 6 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( .NOT.TRFCON ) THEN + DO 45 K = K1, NTESTS + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'ZGBSVXX', + $ FACT, TRANS, N, KL, KU, EQUED, + $ IMAT, K, RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'ZGBSVXX', + $ FACT, TRANS, N, KL, KU, IMAT, K, + $ RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 45 CONTINUE + NRUN = NRUN + 7 - K1 + ELSE + IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) + $ THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'ZGBSVXX', FACT, + $ TRANS, N, KL, KU, EQUED, IMAT, 1, + $ RESULT( 1 ) + ELSE + WRITE( NOUT, FMT = 9998 )'ZGBSVXX', FACT, + $ TRANS, N, KL, KU, IMAT, 1, + $ RESULT( 1 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 6 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'ZGBSVXX', FACT, + $ TRANS, N, KL, KU, EQUED, IMAT, 6, + $ RESULT( 6 ) + ELSE + WRITE( NOUT, FMT = 9998 )'ZGBSVXX', FACT, + $ TRANS, N, KL, KU, IMAT, 6, + $ RESULT( 6 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'ZGBSVXX', FACT, + $ TRANS, N, KL, KU, EQUED, IMAT, 7, + $ RESULT( 7 ) + ELSE + WRITE( NOUT, FMT = 9998 )'ZGBSVXX', FACT, + $ TRANS, N, KL, KU, IMAT, 7, + $ RESULT( 7 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF +* + END IF +* + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + +* Test Error Bounds from ZGBSVXX + + CALL ZEBCHVXX(THRESH, PATH) + + 9999 FORMAT( ' *** In ZDRVGB, LA=', I5, ' is too small for N=', I5, + $ ', KU=', I5, ', KL=', I5, / ' ==> Increase LA to at least ', + $ I5 ) + 9998 FORMAT( ' *** In ZDRVGB, LAFB=', I5, ' is too small for N=', I5, + $ ', KU=', I5, ', KL=', I5, / + $ ' ==> Increase LAFB to at least ', I5 ) + 9997 FORMAT( 1X, A, ', N=', I5, ', KL=', I5, ', KU=', I5, ', type ', + $ I1, ', test(', I1, ')=', G12.5 ) + 9996 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', + $ I5, ',...), type ', I1, ', test(', I1, ')=', G12.5 ) + 9995 FORMAT( 1X, A, '( ''', A1, ''',''', A1, ''',', I5, ',', I5, ',', + $ I5, ',...), EQUED=''', A1, ''', type ', I1, ', test(', I1, + $ ')=', G12.5 ) +* + RETURN +* +* End of ZDRVGB +* + END diff --git a/TESTING/LIN/zdrvge.f b/TESTING/LIN/zdrvge.f index 5f9439c9..0bab5e41 100644 --- a/TESTING/LIN/zdrvge.f +++ b/TESTING/LIN/zdrvge.f @@ -124,7 +124,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. @@ -515,7 +515,7 @@ * refinement. * CALL ZGET07( TRANS, N, NRHS, ASAV, LDA, B, LDA, - $ X, LDA, XACT, LDA, RWORK, + $ X, LDA, XACT, LDA, RWORK, .TRUE., $ RWORK( NRHS+1 ), RESULT( 4 ) ) ELSE TRFCON = .TRUE. diff --git a/TESTING/LIN/zdrvgex.f b/TESTING/LIN/zdrvgex.f new file mode 100644 index 00000000..a81108ab --- /dev/null +++ b/TESTING/LIN/zdrvgex.f @@ -0,0 +1,800 @@ + SUBROUTINE ZDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, + $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, + $ RWORK, IWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NVAL( * ) + DOUBLE PRECISION RWORK( * ), S( * ) + COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ), + $ BSAV( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* Purpose +* ======= +* +* ZDRVGE tests the driver routines ZGESV, -SVX, and -SVXX. +* +* Note that this file is used only when the XBLAS are available, +* otherwise zdrvge.f defines this subroutine. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix column dimension N. +* +* NRHS (input) INTEGER +* The number of right hand side vectors to be generated for +* each linear system. +* +* THRESH (input) 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. +* +* TSTERR (input) LOGICAL +* Flag that indicates whether error exits are to be tested. +* +* NMAX (input) INTEGER +* The maximum value permitted for N, used in dimensioning the +* work arrays. +* +* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) +* +* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) +* +* ASAV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) +* +* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) +* +* BSAV (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) +* +* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) +* +* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) +* +* S (workspace) DOUBLE PRECISION array, dimension (2*NMAX) +* +* WORK (workspace) COMPLEX*16 array, dimension +* (NMAX*max(3,NRHS)) +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (2*NRHS+NMAX) +* +* IWORK (workspace) INTEGER array, dimension (NMAX) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 11 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 7 ) + INTEGER NTRAN + PARAMETER ( NTRAN = 3 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, PREFAC, TRFCON, ZEROT + CHARACTER DIST, EQUED, FACT, TRANS, TYPE, XTYPE + CHARACTER*3 PATH + INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, ITRAN, + $ IZERO, K, K1, KL, KU, LDA, LWORK, MODE, N, NB, + $ NBMIN, NERRS, NFACT, NFAIL, NIMAT, NRUN, NT, + $ N_ERR_BNDS + DOUBLE PRECISION AINVNM, AMAX, ANORM, ANORMI, ANORMO, CNDNUM, + $ COLCND, RCOND, RCONDC, RCONDI, RCONDO, ROLDC, + $ ROLDI, ROLDO, ROWCND, RPVGRW, RPVGRW_SVXX +* .. +* .. Local Arrays .. + CHARACTER EQUEDS( 4 ), FACTS( 3 ), TRANSS( NTRAN ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RDUM( 1 ), RESULT( NTESTS ), BERR( NRHS ), + $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DGET06, DLAMCH, ZLANGE, ZLANTR, ZLA_RPVGRW + EXTERNAL LSAME, DGET06, DLAMCH, ZLANGE, ZLANTR, + $ ZLA_RPVGRW +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, ZGEEQU, + $ ZGESV, ZGESVX, ZGET01, ZGET02, ZGET04, ZGET07, + $ ZGETRF, ZGETRI, ZLACPY, ZLAQGE, ZLARHS, ZLASET, + $ ZLATB4, ZLATMS, ZGESVXX +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DCMPLX, MAX, DBLE, DIMAG +* .. +* .. 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 TRANSS / 'N', 'T', 'C' / + DATA FACTS / 'F', 'N', 'E' / + DATA EQUEDS / 'N', 'R', 'C', 'B' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'GE' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 90 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 80 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 80 +* +* Skip types 5, 6, or 7 if the matrix size is too small. +* + ZEROT = IMAT.GE.5 .AND. IMAT.LE.7 + IF( ZEROT .AND. N.LT.IMAT-4 ) + $ GO TO 80 +* +* Set up parameters with ZLATB4 and generate a test matrix +* with ZLATMS. +* + CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) + RCONDC = ONE / CNDNUM +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE, CNDNUM, + $ ANORM, KL, KU, 'No packing', A, LDA, WORK, + $ INFO ) +* +* Check error code from ZLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', N, N, -1, -1, + $ -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 80 + END IF +* +* For types 5-7, zero one or more columns of the matrix to +* test that INFO is returned correctly. +* + IF( ZEROT ) THEN + IF( IMAT.EQ.5 ) THEN + IZERO = 1 + ELSE IF( IMAT.EQ.6 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF + IOFF = ( IZERO-1 )*LDA + IF( IMAT.LT.7 ) THEN + DO 20 I = 1, N + A( IOFF+I ) = ZERO + 20 CONTINUE + ELSE + CALL ZLASET( 'Full', N, N-IZERO+1, DCMPLX( ZERO ), + $ DCMPLX( ZERO ), A( IOFF+1 ), LDA ) + END IF + ELSE + IZERO = 0 + END IF +* +* Save a copy of the matrix A in ASAV. +* + CALL ZLACPY( 'Full', N, N, A, LDA, ASAV, LDA ) +* + DO 70 IEQUED = 1, 4 + EQUED = EQUEDS( IEQUED ) + IF( IEQUED.EQ.1 ) THEN + NFACT = 3 + ELSE + NFACT = 1 + END IF +* + DO 60 IFACT = 1, NFACT + FACT = FACTS( IFACT ) + PREFAC = LSAME( FACT, 'F' ) + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) +* + IF( ZEROT ) THEN + IF( PREFAC ) + $ GO TO 60 + RCONDO = ZERO + RCONDI = ZERO +* + ELSE IF( .NOT.NOFACT ) THEN +* +* Compute the condition number for comparison with +* the value returned by ZGESVX (FACT = 'N' reuses +* the condition number from the previous iteration +* with FACT = 'F'). +* + CALL ZLACPY( 'Full', N, N, ASAV, LDA, AFAC, LDA ) + IF( EQUIL .OR. IEQUED.GT.1 ) THEN +* +* Compute row and column scale factors to +* equilibrate the matrix A. +* + CALL ZGEEQU( N, N, AFAC, LDA, S, S( N+1 ), + $ ROWCND, COLCND, AMAX, INFO ) + IF( INFO.EQ.0 .AND. N.GT.0 ) THEN + IF( LSAME( EQUED, 'R' ) ) THEN + ROWCND = ZERO + COLCND = ONE + ELSE IF( LSAME( EQUED, 'C' ) ) THEN + ROWCND = ONE + COLCND = ZERO + ELSE IF( LSAME( EQUED, 'B' ) ) THEN + ROWCND = ZERO + COLCND = ZERO + END IF +* +* Equilibrate the matrix. +* + CALL ZLAQGE( N, N, AFAC, LDA, S, S( N+1 ), + $ ROWCND, COLCND, AMAX, EQUED ) + END IF + END IF +* +* Save the condition number of the non-equilibrated +* system for use in ZGET04. +* + IF( EQUIL ) THEN + ROLDO = RCONDO + ROLDI = RCONDI + END IF +* +* Compute the 1-norm and infinity-norm of A. +* + ANORMO = ZLANGE( '1', N, N, AFAC, LDA, RWORK ) + ANORMI = ZLANGE( 'I', N, N, AFAC, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL ZGETRF( N, N, AFAC, LDA, IWORK, INFO ) +* +* Form the inverse of A. +* + CALL ZLACPY( 'Full', N, N, AFAC, LDA, A, LDA ) + LWORK = NMAX*MAX( 3, NRHS ) + CALL ZGETRI( N, A, LDA, IWORK, WORK, LWORK, INFO ) +* +* Compute the 1-norm condition number of A. +* + AINVNM = ZLANGE( '1', N, N, A, LDA, RWORK ) + IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDO = ONE + ELSE + RCONDO = ( ONE / ANORMO ) / AINVNM + END IF +* +* Compute the infinity-norm condition number of A. +* + AINVNM = ZLANGE( 'I', N, N, A, LDA, RWORK ) + IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDI = ONE + ELSE + RCONDI = ( ONE / ANORMI ) / AINVNM + END IF + END IF +* + DO 50 ITRAN = 1, NTRAN + DO I = 1, NTESTS + RESULT (I) = ZERO + END DO +* +* Do for each value of TRANS. +* + TRANS = TRANSS( ITRAN ) + IF( ITRAN.EQ.1 ) THEN + RCONDC = RCONDO + ELSE + RCONDC = RCONDI + END IF +* +* Restore the matrix A. +* + CALL ZLACPY( 'Full', N, N, ASAV, LDA, A, LDA ) +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( PATH, XTYPE, 'Full', TRANS, N, N, KL, + $ KU, NRHS, A, LDA, XACT, LDA, B, LDA, + $ ISEED, INFO ) + XTYPE = 'C' + CALL ZLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA ) +* + IF( NOFACT .AND. ITRAN.EQ.1 ) THEN +* +* --- Test ZGESV --- +* +* Compute the LU factorization of the matrix and +* solve the system. +* + CALL ZLACPY( 'Full', N, N, A, LDA, AFAC, LDA ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'ZGESV ' + CALL ZGESV( N, NRHS, AFAC, LDA, IWORK, X, LDA, + $ INFO ) +* +* Check error code from ZGESV . +* + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'ZGESV ', INFO, IZERO, + $ ' ', N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) + GOTO 50 + END IF +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL ZGET01( N, N, A, LDA, AFAC, LDA, IWORK, + $ RWORK, RESULT( 1 ) ) + NT = 1 + IF( IZERO.EQ.0 ) THEN +* +* Compute residual of the computed solution. +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, WORK, + $ LDA ) + CALL ZGET02( 'No transpose', N, N, NRHS, A, + $ LDA, X, LDA, WORK, LDA, RWORK, + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + NT = 3 + END IF +* +* Print information about the tests that did not +* pass the threshold. +* + DO 30 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 )'ZGESV ', N, + $ IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 30 CONTINUE + NRUN = NRUN + NT + END IF +* +* --- Test ZGESVX --- +* + IF( .NOT.PREFAC ) + $ CALL ZLASET( 'Full', N, N, DCMPLX( ZERO ), + $ DCMPLX( ZERO ), AFAC, LDA ) + CALL ZLASET( 'Full', N, NRHS, DCMPLX( ZERO ), + $ DCMPLX( ZERO ), X, LDA ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT = 'F' and +* EQUED = 'R', 'C', or 'B'. +* + CALL ZLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND, + $ COLCND, AMAX, EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using ZGESVX. +* + SRNAMT = 'ZGESVX' + CALL ZGESVX( FACT, TRANS, N, NRHS, A, LDA, AFAC, + $ LDA, IWORK, EQUED, S, S( N+1 ), B, + $ LDA, X, LDA, RCOND, RWORK, + $ RWORK( NRHS+1 ), WORK, + $ RWORK( 2*NRHS+1 ), INFO ) +* +* Check the error code from ZGESVX. +* + IF( INFO.EQ.N+1 ) GOTO 50 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'ZGESVX', INFO, IZERO, + $ FACT // TRANS, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GOTO 50 + END IF +* +* Compare RWORK(2*NRHS+1) from ZGESVX with the +* computed reciprocal pivot growth factor RPVGRW +* + IF( INFO.NE.0 ) THEN + RPVGRW = ZLANTR( 'M', 'U', 'N', INFO, INFO, + $ AFAC, LDA, RDUM ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = ZLANGE( 'M', N, INFO, A, LDA, + $ RDUM ) / RPVGRW + END IF + ELSE + RPVGRW = ZLANTR( 'M', 'U', 'N', N, N, AFAC, LDA, + $ RDUM ) + IF( RPVGRW.EQ.ZERO ) THEN + RPVGRW = ONE + ELSE + RPVGRW = ZLANGE( 'M', N, N, A, LDA, RDUM ) / + $ RPVGRW + END IF + END IF + RESULT( 7 ) = ABS( RPVGRW-RWORK( 2*NRHS+1 ) ) / + $ MAX( RWORK( 2*NRHS+1 ), RPVGRW ) / + $ DLAMCH( 'E' ) +* + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL ZGET01( N, N, A, LDA, AFAC, LDA, IWORK, + $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* + IF( INFO.EQ.0 ) THEN + TRFCON = .FALSE. +* +* Compute residual of the computed solution. +* + CALL ZLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, + $ LDA ) + CALL ZGET02( TRANS, N, N, NRHS, ASAV, LDA, X, + $ LDA, WORK, LDA, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + ELSE + IF( ITRAN.EQ.1 ) THEN + ROLDC = ROLDO + ELSE + ROLDC = ROLDI + END IF + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, + $ ROLDC, RESULT( 3 ) ) + END IF +* +* Check the error bounds from iterative +* refinement. +* + CALL ZGET07( TRANS, N, NRHS, ASAV, LDA, B, LDA, + $ X, LDA, XACT, LDA, RWORK, .TRUE., + $ RWORK( NRHS+1 ), RESULT( 4 ) ) + ELSE + TRFCON = .TRUE. + END IF +* +* Compare RCOND from ZGESVX with the computed value +* in RCONDC. +* + RESULT( 6 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( .NOT.TRFCON ) THEN + DO 40 K = K1, NTESTS + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'ZGESVX', + $ FACT, TRANS, N, EQUED, IMAT, K, + $ RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'ZGESVX', + $ FACT, TRANS, N, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 40 CONTINUE + NRUN = NRUN + 7 - K1 + ELSE + IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) + $ THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'ZGESVX', FACT, + $ TRANS, N, EQUED, IMAT, 1, RESULT( 1 ) + ELSE + WRITE( NOUT, FMT = 9998 )'ZGESVX', FACT, + $ TRANS, N, IMAT, 1, RESULT( 1 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 6 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'ZGESVX', FACT, + $ TRANS, N, EQUED, IMAT, 6, RESULT( 6 ) + ELSE + WRITE( NOUT, FMT = 9998 )'ZGESVX', FACT, + $ TRANS, N, IMAT, 6, RESULT( 6 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'ZGESVX', FACT, + $ TRANS, N, EQUED, IMAT, 7, RESULT( 7 ) + ELSE + WRITE( NOUT, FMT = 9998 )'ZGESVX', FACT, + $ TRANS, N, IMAT, 7, RESULT( 7 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF +* + END IF +* +* --- Test ZGESVXX --- +* +* Restore the matrices A and B. +* + + CALL ZLACPY( 'Full', N, N, ASAV, LDA, A, LDA ) + CALL ZLACPY( 'Full', N, NRHS, BSAV, LDA, B, LDA ) + + IF( .NOT.PREFAC ) + $ CALL ZLASET( 'Full', N, N, ZERO, ZERO, AFAC, + $ LDA ) + CALL ZLASET( 'Full', N, NRHS, ZERO, ZERO, X, LDA ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT = 'F' and +* EQUED = 'R', 'C', or 'B'. +* + CALL ZLAQGE( N, N, A, LDA, S, S( N+1 ), ROWCND, + $ COLCND, AMAX, EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using ZGESVXX. +* + SRNAMT = 'ZGESVXX' + N_ERR_BNDS = 3 + CALL ZGESVXX( FACT, TRANS, N, NRHS, A, LDA, AFAC, + $ LDA, IWORK, EQUED, S, S( N+1 ), B, LDA, X, + $ LDA, RCOND, RPVGRW_SVXX, BERR, N_ERR_BNDS, + $ ERRBNDS_N, ERRBNDS_C, 0, ZERO, WORK, + $ RWORK, INFO ) +* +* Check the error code from ZGESVXX. +* + IF( INFO.EQ.N+1 ) GOTO 50 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'ZGESVXX', INFO, IZERO, + $ FACT // TRANS, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GOTO 50 + END IF +* +* Compare rpvgrw_svxx from ZGESVXX with the computed +* reciprocal pivot growth factor RPVGRW +* + + IF ( INFO .GT. 0 .AND. INFO .LT. N+1 ) THEN + RPVGRW = ZLA_RPVGRW(N, INFO, A, LDA, AFAC, LDA) + ELSE + RPVGRW = ZLA_RPVGRW(N, N, A, LDA, AFAC, LDA) + ENDIF + + RESULT( 7 ) = ABS( RPVGRW-rpvgrw_svxx ) / + $ MAX( rpvgrw_svxx, RPVGRW ) / + $ DLAMCH( 'E' ) +* + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL ZGET01( N, N, A, LDA, AFAC, LDA, IWORK, + $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* + IF( INFO.EQ.0 ) THEN + TRFCON = .FALSE. +* +* Compute residual of the computed solution. +* + CALL ZLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, + $ LDA ) + CALL ZGET02( TRANS, N, N, NRHS, ASAV, LDA, X, + $ LDA, WORK, LDA, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + ELSE + IF( ITRAN.EQ.1 ) THEN + ROLDC = ROLDO + ELSE + ROLDC = ROLDI + END IF + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, + $ ROLDC, RESULT( 3 ) ) + END IF + ELSE + TRFCON = .TRUE. + END IF +* +* Compare RCOND from ZGESVXX with the computed value +* in RCONDC. +* + RESULT( 6 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + IF( .NOT.TRFCON ) THEN + DO 45 K = K1, NTESTS + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'ZGESVXX', + $ FACT, TRANS, N, EQUED, IMAT, K, + $ RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'ZGESVXX', + $ FACT, TRANS, N, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 45 CONTINUE + NRUN = NRUN + 7 - K1 + ELSE + IF( RESULT( 1 ).GE.THRESH .AND. .NOT.PREFAC ) + $ THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'ZGESVXX', FACT, + $ TRANS, N, EQUED, IMAT, 1, RESULT( 1 ) + ELSE + WRITE( NOUT, FMT = 9998 )'ZGESVXX', FACT, + $ TRANS, N, IMAT, 1, RESULT( 1 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 6 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'ZGESVXX', FACT, + $ TRANS, N, EQUED, IMAT, 6, RESULT( 6 ) + ELSE + WRITE( NOUT, FMT = 9998 )'ZGESVXX', FACT, + $ TRANS, N, IMAT, 6, RESULT( 6 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF + IF( RESULT( 7 ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'ZGESVXX', FACT, + $ TRANS, N, EQUED, IMAT, 7, RESULT( 7 ) + ELSE + WRITE( NOUT, FMT = 9998 )'ZGESVXX', FACT, + $ TRANS, N, IMAT, 7, RESULT( 7 ) + END IF + NFAIL = NFAIL + 1 + NRUN = NRUN + 1 + END IF +* + END IF +* + 50 CONTINUE + 60 CONTINUE + 70 CONTINUE + 80 CONTINUE + 90 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + +* Test Error Bounds for ZGESVXX + + CALL ZEBCHVXX(THRESH, PATH) + + 9999 FORMAT( 1X, A, ', N =', I5, ', type ', I2, ', test(', I2, ') =', + $ G12.5 ) + 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5, + $ ', type ', I2, ', test(', I1, ')=', G12.5 ) + 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5, + $ ', EQUED=''', A1, ''', type ', I2, ', test(', I1, ')=', + $ G12.5 ) + RETURN +* +* End of ZDRVGE +* + END diff --git a/TESTING/LIN/zdrvgt.f b/TESTING/LIN/zdrvgt.f index 6c0b7973..ee95106f 100644 --- a/TESTING/LIN/zdrvgt.f +++ b/TESTING/LIN/zdrvgt.f @@ -105,7 +105,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zdrvhe.f b/TESTING/LIN/zdrvhe.f index c558bbbd..fdf70f6d 100644 --- a/TESTING/LIN/zdrvhe.f +++ b/TESTING/LIN/zdrvhe.f @@ -112,7 +112,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zdrvhp.f b/TESTING/LIN/zdrvhp.f index 259253e6..cab25cf2 100644 --- a/TESTING/LIN/zdrvhp.f +++ b/TESTING/LIN/zdrvhp.f @@ -115,7 +115,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zdrvls.f b/TESTING/LIN/zdrvls.f index 73bd97c6..dd80058e 100644 --- a/TESTING/LIN/zdrvls.f +++ b/TESTING/LIN/zdrvls.f @@ -154,7 +154,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, IOUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zdrvpb.f b/TESTING/LIN/zdrvpb.f index b7ebb250..0ee9ca3a 100644 --- a/TESTING/LIN/zdrvpb.f +++ b/TESTING/LIN/zdrvpb.f @@ -120,7 +120,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zdrvpo.f b/TESTING/LIN/zdrvpo.f index 5d8cfec5..e68e0d91 100644 --- a/TESTING/LIN/zdrvpo.f +++ b/TESTING/LIN/zdrvpo.f @@ -116,7 +116,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zdrvpox.f b/TESTING/LIN/zdrvpox.f new file mode 100644 index 00000000..030da9d0 --- /dev/null +++ b/TESTING/LIN/zdrvpox.f @@ -0,0 +1,640 @@ + SUBROUTINE ZDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX, + $ A, AFAC, ASAV, B, BSAV, X, XACT, S, WORK, + $ RWORK, NOUT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NMAX, NN, NOUT, NRHS + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER NVAL( * ) + DOUBLE PRECISION RWORK( * ), S( * ) + COMPLEX*16 A( * ), AFAC( * ), ASAV( * ), B( * ), + $ BSAV( * ), WORK( * ), X( * ), XACT( * ) +* .. +* +* Purpose +* ======= +* +* ZDRVPO tests the driver routines ZPOSV, -SVX, and -SVXX. +* +* Arguments +* ========= +* +* DOTYPE (input) 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. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* NRHS (input) INTEGER +* The number of right hand side vectors to be generated for +* each linear system. +* +* THRESH (input) 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. +* +* TSTERR (input) LOGICAL +* Flag that indicates whether error exits are to be tested. +* +* NMAX (input) INTEGER +* The maximum value permitted for N, used in dimensioning the +* work arrays. +* +* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) +* +* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) +* +* ASAV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) +* +* B (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) +* +* BSAV (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) +* +* X (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) +* +* XACT (workspace) COMPLEX*16 array, dimension (NMAX*NRHS) +* +* S (workspace) DOUBLE PRECISION array, dimension (NMAX) +* +* WORK (workspace) COMPLEX*16 array, dimension +* (NMAX*max(3,NRHS)) +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX+2*NRHS) +* +* NOUT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTYPES + PARAMETER ( NTYPES = 9 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 6 ) +* .. +* .. Local Scalars .. + LOGICAL EQUIL, NOFACT, PREFAC, ZEROT + CHARACTER DIST, EQUED, FACT, TYPE, UPLO, XTYPE + CHARACTER*3 PATH + INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO, + $ IZERO, K, K1, KL, KU, LDA, MODE, N, NB, NBMIN, + $ NERRS, NFACT, NFAIL, NIMAT, NRUN, NT, + $ N_ERR_BNDS + DOUBLE PRECISION AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC, + $ ROLDC, SCOND, RPVGRW_SVXX +* .. +* .. Local Arrays .. + CHARACTER EQUEDS( 2 ), FACTS( 3 ), UPLOS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ), BERR( NRHS ), + $ ERRBNDS_N( NRHS, 3 ), ERRBNDS_C( NRHS, 3 ) +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DGET06, ZLANHE + EXTERNAL LSAME, DGET06, ZLANHE +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, XLAENV, ZERRVX, ZGET04, + $ ZLACPY, ZLAIPD, ZLAQHE, ZLARHS, ZLASET, ZLATB4, + $ ZLATMS, ZPOEQU, ZPOSV, ZPOSVX, ZPOT01, ZPOT02, + $ ZPOT05, ZPOTRF, ZPOTRI, ZPOSVXX +* .. +* .. 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 DCMPLX, MAX +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FACTS / 'F', 'N', 'E' / + DATA EQUEDS / 'N', 'Y' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'PO' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRVX( PATH, NOUT ) + INFOT = 0 +* +* Set the block size and minimum block size for testing. +* + NB = 1 + NBMIN = 2 + CALL XLAENV( 1, NB ) + CALL XLAENV( 2, NBMIN ) +* +* Do for each value of N in NVAL +* + DO 130 IN = 1, NN + N = NVAL( IN ) + LDA = MAX( N, 1 ) + XTYPE = 'N' + NIMAT = NTYPES + IF( N.LE.0 ) + $ NIMAT = 1 +* + DO 120 IMAT = 1, NIMAT +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ GO TO 120 +* +* Skip types 3, 4, or 5 if the matrix size is too small. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 + IF( ZEROT .AND. N.LT.IMAT-2 ) + $ GO TO 120 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 110 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Set up parameters with ZLATB4 and generate a test matrix +* with ZLATMS. +* + CALL ZLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) +* + 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. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, UPLO, N, N, -1, + $ -1, -1, IMAT, NFAIL, NERRS, NOUT ) + GO TO 110 + END IF +* +* For types 3-5, zero one row and column 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 + IOFF = ( IZERO-1 )*LDA +* +* Set row and column IZERO of A to 0. +* + IF( IUPLO.EQ.1 ) THEN + 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 + IZERO = 0 + END IF +* +* Set the imaginary part of the diagonals. +* + CALL ZLAIPD( N, A, LDA+1, 0 ) +* +* Save a copy of the matrix A in ASAV. +* + CALL ZLACPY( UPLO, N, N, A, LDA, ASAV, LDA ) +* + DO 100 IEQUED = 1, 2 + EQUED = EQUEDS( IEQUED ) + IF( IEQUED.EQ.1 ) THEN + NFACT = 3 + ELSE + NFACT = 1 + END IF +* + DO 90 IFACT = 1, NFACT + DO I = 1, NTESTS + RESULT (I) = ZERO + END DO + FACT = FACTS( IFACT ) + PREFAC = LSAME( FACT, 'F' ) + NOFACT = LSAME( FACT, 'N' ) + EQUIL = LSAME( FACT, 'E' ) +* + IF( ZEROT ) THEN + IF( PREFAC ) + $ GO TO 90 + RCONDC = ZERO +* + ELSE IF( .NOT.LSAME( FACT, 'N' ) ) THEN +* +* Compute the condition number for comparison with +* the value returned by ZPOSVX (FACT = 'N' reuses +* the condition number from the previous iteration +* with FACT = 'F'). +* + CALL ZLACPY( UPLO, N, N, ASAV, LDA, AFAC, LDA ) + IF( EQUIL .OR. IEQUED.GT.1 ) THEN +* +* Compute row and column scale factors to +* equilibrate the matrix A. +* + CALL ZPOEQU( N, AFAC, LDA, S, SCOND, AMAX, + $ INFO ) + IF( INFO.EQ.0 .AND. N.GT.0 ) THEN + IF( IEQUED.GT.1 ) + $ SCOND = ZERO +* +* Equilibrate the matrix. +* + CALL ZLAQHE( UPLO, N, AFAC, LDA, S, SCOND, + $ AMAX, EQUED ) + END IF + END IF +* +* Save the condition number of the +* non-equilibrated system for use in ZGET04. +* + IF( EQUIL ) + $ ROLDC = RCONDC +* +* Compute the 1-norm of A. +* + ANORM = ZLANHE( '1', UPLO, N, AFAC, LDA, RWORK ) +* +* Factor the matrix A. +* + CALL ZPOTRF( UPLO, N, AFAC, LDA, INFO ) +* +* Form the inverse of A. +* + CALL ZLACPY( UPLO, N, N, AFAC, LDA, A, LDA ) + CALL ZPOTRI( UPLO, N, A, LDA, INFO ) +* +* Compute the 1-norm condition number of A. +* + AINVNM = ZLANHE( '1', UPLO, N, A, LDA, RWORK ) + IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN + RCONDC = ONE + ELSE + RCONDC = ( ONE / ANORM ) / AINVNM + END IF + END IF +* +* Restore the matrix A. +* + CALL ZLACPY( UPLO, N, N, ASAV, LDA, A, LDA ) +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU, + $ NRHS, A, LDA, XACT, LDA, B, LDA, + $ ISEED, INFO ) + XTYPE = 'C' + CALL ZLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA ) +* + IF( NOFACT ) THEN +* +* --- Test ZPOSV --- +* +* Compute the L*L' or U'*U factorization of the +* matrix and solve the system. +* + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, X, LDA ) +* + SRNAMT = 'ZPOSV ' + CALL ZPOSV( UPLO, N, NRHS, AFAC, LDA, X, LDA, + $ INFO ) +* +* Check error code from ZPOSV . +* + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'ZPOSV ', INFO, IZERO, + $ UPLO, N, N, -1, -1, NRHS, IMAT, + $ NFAIL, NERRS, NOUT ) + GO TO 70 + ELSE IF( INFO.NE.0 ) THEN + GO TO 70 + END IF +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL ZPOT01( UPLO, N, A, LDA, AFAC, LDA, RWORK, + $ RESULT( 1 ) ) +* +* 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 ) ) +* +* 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 60 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 )'ZPOSV ', UPLO, + $ N, IMAT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 60 CONTINUE + NRUN = NRUN + NT + 70 CONTINUE + END IF +* +* --- Test ZPOSVX --- +* + IF( .NOT.PREFAC ) + $ CALL ZLASET( UPLO, N, N, DCMPLX( ZERO ), + $ DCMPLX( ZERO ), AFAC, LDA ) + CALL ZLASET( 'Full', N, NRHS, DCMPLX( ZERO ), + $ DCMPLX( ZERO ), X, LDA ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT='F' and +* EQUED='Y'. +* + CALL ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, + $ EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using ZPOSVX. +* + SRNAMT = 'ZPOSVX' + CALL ZPOSVX( FACT, UPLO, N, NRHS, A, LDA, AFAC, + $ LDA, EQUED, S, B, LDA, X, LDA, RCOND, + $ RWORK, RWORK( NRHS+1 ), WORK, + $ RWORK( 2*NRHS+1 ), INFO ) +* +* Check the error code from ZPOSVX. +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'ZPOSVX', INFO, IZERO, + $ FACT // UPLO, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GO TO 90 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL ZPOT01( UPLO, N, A, LDA, AFAC, LDA, + $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* +* Compute residual of the computed solution. +* + CALL ZLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, + $ LDA ) + CALL ZPOT02( UPLO, N, NRHS, ASAV, LDA, X, LDA, + $ WORK, LDA, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + ELSE + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, + $ ROLDC, RESULT( 3 ) ) + END IF +* +* Check the error bounds from iterative +* refinement. +* + CALL ZPOT05( UPLO, N, NRHS, ASAV, LDA, B, LDA, + $ X, LDA, XACT, LDA, RWORK, + $ RWORK( NRHS+1 ), RESULT( 4 ) ) + ELSE + K1 = 6 + END IF +* +* Compare RCOND from ZPOSVX with the computed value +* in RCONDC. +* + RESULT( 6 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 80 K = K1, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'ZPOSVX', FACT, + $ UPLO, N, EQUED, IMAT, K, RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'ZPOSVX', FACT, + $ UPLO, N, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 80 CONTINUE + NRUN = NRUN + 7 - K1 +* +* --- Test ZPOSVXX --- +* +* Restore the matrices A and B. +* + CALL ZLACPY( 'Full', N, N, ASAV, LDA, A, LDA ) + CALL ZLACPY( 'Full', N, NRHS, BSAV, LDA, B, LDA ) + + IF( .NOT.PREFAC ) + $ CALL ZLASET( UPLO, N, N, CMPLX( ZERO ), + $ CMPLX( ZERO ), AFAC, LDA ) + CALL ZLASET( 'Full', N, NRHS, CMPLX( ZERO ), + $ CMPLX( ZERO ), X, LDA ) + IF( IEQUED.GT.1 .AND. N.GT.0 ) THEN +* +* Equilibrate the matrix if FACT='F' and +* EQUED='Y'. +* + CALL ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, + $ EQUED ) + END IF +* +* Solve the system and compute the condition number +* and error bounds using ZPOSVXX. +* + SRNAMT = 'ZPOSVXX' + CALL ZPOSVXX( FACT, UPLO, N, NRHS, A, LDA, AFAC, + $ LDA, EQUED, S, B, LDA, X, + $ LDA, rcond, rpvgrw_svxx, berr, n_err_bnds, + $ errbnds_n, errbnds_c, 0, ZERO, WORK, + $ RWORK( 2*NRHS+1 ), INFO ) +* +* Check the error code from ZPOSVXX. +* + IF( INFO.EQ.N+1 ) GOTO 90 + IF( INFO.NE.IZERO ) THEN + CALL ALAERH( PATH, 'ZPOSVXX', INFO, IZERO, + $ FACT // UPLO, N, N, -1, -1, NRHS, + $ IMAT, NFAIL, NERRS, NOUT ) + GO TO 90 + END IF +* + IF( INFO.EQ.0 ) THEN + IF( .NOT.PREFAC ) THEN +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL ZPOT01( UPLO, N, A, LDA, AFAC, LDA, + $ RWORK( 2*NRHS+1 ), RESULT( 1 ) ) + K1 = 1 + ELSE + K1 = 2 + END IF +* +* Compute residual of the computed solution. +* + CALL ZLACPY( 'Full', N, NRHS, BSAV, LDA, WORK, + $ LDA ) + CALL ZPOT02( UPLO, N, NRHS, ASAV, LDA, X, LDA, + $ WORK, LDA, RWORK( 2*NRHS+1 ), + $ RESULT( 2 ) ) +* +* Check solution from generated exact solution. +* + IF( NOFACT .OR. ( PREFAC .AND. LSAME( EQUED, + $ 'N' ) ) ) THEN + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, + $ RCONDC, RESULT( 3 ) ) + ELSE + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, + $ ROLDC, RESULT( 3 ) ) + END IF +* +* Check the error bounds from iterative +* refinement. +* + CALL ZPOT05( UPLO, N, NRHS, ASAV, LDA, B, LDA, + $ X, LDA, XACT, LDA, RWORK, + $ RWORK( NRHS+1 ), RESULT( 4 ) ) + ELSE + K1 = 6 + END IF +* +* Compare RCOND from ZPOSVXX with the computed value +* in RCONDC. +* + RESULT( 6 ) = DGET06( RCOND, RCONDC ) +* +* Print information about the tests that did not pass +* the threshold. +* + DO 85 K = K1, 6 + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALADHD( NOUT, PATH ) + IF( PREFAC ) THEN + WRITE( NOUT, FMT = 9997 )'ZPOSVXX', FACT, + $ UPLO, N, EQUED, IMAT, K, RESULT( K ) + ELSE + WRITE( NOUT, FMT = 9998 )'ZPOSVXX', FACT, + $ UPLO, N, IMAT, K, RESULT( K ) + END IF + NFAIL = NFAIL + 1 + END IF + 85 CONTINUE + NRUN = NRUN + 7 - K1 + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + +* Test Error Bounds for ZGESVXX + + CALL ZEBCHVXX(THRESH, PATH) + + 9999 FORMAT( 1X, A, ', UPLO=''', A1, ''', N =', I5, ', type ', I1, + $ ', test(', I1, ')=', G12.5 ) + 9998 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5, + $ ', type ', I1, ', test(', I1, ')=', G12.5 ) + 9997 FORMAT( 1X, A, ', FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5, + $ ', EQUED=''', A1, ''', type ', I1, ', test(', I1, ') =', + $ G12.5 ) + RETURN +* +* End of ZDRVPO +* + END diff --git a/TESTING/LIN/zdrvpp.f b/TESTING/LIN/zdrvpp.f index 69e4f3f6..162b9619 100644 --- a/TESTING/LIN/zdrvpp.f +++ b/TESTING/LIN/zdrvpp.f @@ -116,7 +116,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zdrvpt.f b/TESTING/LIN/zdrvpt.f index 5f2d73d9..b393e309 100644 --- a/TESTING/LIN/zdrvpt.f +++ b/TESTING/LIN/zdrvpt.f @@ -108,7 +108,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zdrvrf1.f b/TESTING/LIN/zdrvrf1.f new file mode 100644 index 00000000..592c5ec8 --- /dev/null +++ b/TESTING/LIN/zdrvrf1.f @@ -0,0 +1,220 @@ + SUBROUTINE ZDRVRF1( NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK ) +* + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER LDA, NN, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ) + DOUBLE PRECISION WORK( * ) + COMPLEX*16 A( LDA, * ), ARF( * ) +* .. +* +* Purpose +* ======= +* +* ZDRVRF1 tests the LAPACK RFP routines: +* ZLANHF.F +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* THRESH (input) 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. +* +* A (workspace) COMPLEX*16 array, dimension (LDA,NMAX) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* ARF (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2). +* +* WORK (workspace) DOUBLE PRECISION array, dimension ( NMAX ) +* +* ===================================================================== +* .. +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 1 ) +* .. +* .. Local Scalars .. + CHARACTER UPLO, CFORM, NORM + INTEGER I, IFORM, IIN, IIT, INFO, INORM, IUPLO, J, N, + + NERRS, NFAIL, NRUN + DOUBLE PRECISION EPS, LARGE, NORMA, NORMARF, SMALL +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ), NORMS( 4 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + COMPLEX*16 ZLARND + DOUBLE PRECISION DLAMCH, ZLANHE, ZLANHF + EXTERNAL DLAMCH, ZLARND, ZLANHE, ZLANHF +* .. +* .. External Subroutines .. + EXTERNAL ZTRTTF +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'C' / + DATA NORMS / 'M', '1', 'I', 'F' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + INFO = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* + EPS = DLAMCH( 'Precision' ) + SMALL = DLAMCH( 'Safe minimum' ) + LARGE = ONE / SMALL + SMALL = SMALL * LDA * LDA + LARGE = LARGE / LDA / LDA +* + DO 130 IIN = 1, NN +* + N = NVAL( IIN ) +* + DO 120 IIT = 1, 3 +* +* IIT = 1 : random matrix +* IIT = 2 : random matrix scaled near underflow +* IIT = 3 : random matrix scaled near overflow +* + DO J = 1, N + DO I = 1, N + A( I, J) = ZLARND( 4, ISEED ) + END DO + END DO +* + IF ( IIT.EQ.2 ) THEN + DO J = 1, N + DO I = 1, N + A( I, J) = A( I, J ) * LARGE + END DO + END DO + END IF +* + IF ( IIT.EQ.3 ) THEN + DO J = 1, N + DO I = 1, N + A( I, J) = A( I, J) * SMALL + END DO + END DO + END IF +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 110 IUPLO = 1, 2 +* + UPLO = UPLOS( IUPLO ) +* +* Do first for CFORM = 'N', then for CFORM = 'C' +* + DO 100 IFORM = 1, 2 +* + CFORM = FORMS( IFORM ) +* + SRNAMT = 'ZTRTTF' + CALL ZTRTTF( CFORM, UPLO, N, A, LDA, ARF, INFO ) +* +* Check error code from ZTRTTF +* + IF( INFO.NE.0 ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9998 ) SRNAMT, UPLO, CFORM, N + NERRS = NERRS + 1 + GO TO 100 + END IF +* + DO 90 INORM = 1, 4 +* +* Check all four norms: 'M', '1', 'I', 'F' +* + NORM = NORMS( INORM ) + NORMARF = ZLANHF( NORM, CFORM, UPLO, N, ARF, WORK ) + NORMA = ZLANHE( NORM, UPLO, N, A, LDA, WORK ) +* + RESULT(1) = ( NORMA - NORMARF ) / NORMA / EPS + NRUN = NRUN + 1 +* + IF( RESULT(1).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9997 ) 'ZLANHF', + + N, IIT, UPLO, CFORM, NORM, RESULT(1) + NFAIL = NFAIL + 1 + END IF + 90 CONTINUE + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE +* +* Print a summary of the results. +* + IF ( NFAIL.EQ.0 ) THEN + WRITE( NOUT, FMT = 9996 ) 'ZLANHF', NRUN + ELSE + WRITE( NOUT, FMT = 9995 ) 'ZLANHF', NFAIL, NRUN + END IF + IF ( NERRS.NE.0 ) THEN + WRITE( NOUT, FMT = 9994 ) NERRS, 'ZLANHF' + END IF +* + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing ZLANHF + + ***') + 9998 FORMAT( 1X, ' Error in ',A6,' with UPLO=''',A1,''', FORM=''', + + A1,''', N=',I5) + 9997 FORMAT( 1X, ' Failure in ',A6,' N=',I5,' TYPE=',I5,' UPLO=''', + + A1, ''', FORM =''',A1,''', NORM=''',A1,''', test=',G12.5) + 9996 FORMAT( 1X, 'All tests for ',A6,' auxiliary routine passed the ', + + 'threshold (',I5,' tests run)') + 9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5, + + ' tests failed to pass the threshold') + 9994 FORMAT( 26X, I5,' error message recorded (',A6,')') +* + RETURN +* +* End of ZDRVRF1 +* + END diff --git a/TESTING/LIN/zdrvrf2.f b/TESTING/LIN/zdrvrf2.f new file mode 100644 index 00000000..b173d63c --- /dev/null +++ b/TESTING/LIN/zdrvrf2.f @@ -0,0 +1,204 @@ + SUBROUTINE ZDRVRF2( NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV ) +* + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER LDA, NN, NOUT +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ) + COMPLEX*16 A( LDA, * ), ARF( * ), AP(*), ASAV( LDA, * ) +* .. +* +* Purpose +* ======= +* +* ZDRVRF2 tests the LAPACK RFP convertion routines. +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* A (workspace) COMPLEX*16 array, dimension (LDA,NMAX) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* ARF (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2). +* +* AP (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2). +* +* A2 (workspace) COMPLEX*16 array, dimension (LDA,NMAX) +* +* ===================================================================== +* .. +* .. Local Scalars .. + LOGICAL LOWER, OK1, OK2 + CHARACTER UPLO, CFORM + INTEGER I, IFORM, IIN, INFO, IUPLO, J, N, + + NERRS, NRUN +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) +* .. +* .. External Functions .. + COMPLEX*16 ZLARND + EXTERNAL ZLARND +* .. +* .. External Subroutines .. + EXTERNAL ZTFTTR, ZTFTTP, ZTRTTF, ZTRTTP, ZTPTTR, ZTPTTF +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'C' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NERRS = 0 + INFO = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* + DO 120 IIN = 1, NN +* + N = NVAL( IIN ) +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 110 IUPLO = 1, 2 +* + UPLO = UPLOS( IUPLO ) + LOWER = .TRUE. + IF ( IUPLO.EQ.1 ) LOWER = .FALSE. +* +* Do first for CFORM = 'N', then for CFORM = 'C' +* + DO 100 IFORM = 1, 2 +* + CFORM = FORMS( IFORM ) +* + NRUN = NRUN + 1 +* + DO J = 1, N + DO I = 1, N + A( I, J) = ZLARND( 4, ISEED ) + END DO + END DO +* + SRNAMT = 'ZTRTTF' + CALL ZTRTTF( CFORM, UPLO, N, A, LDA, ARF, INFO ) +* + SRNAMT = 'ZTFTTP' + CALL ZTFTTP( CFORM, UPLO, N, ARF, AP, INFO ) +* + SRNAMT = 'ZTPTTR' + CALL ZTPTTR( UPLO, N, AP, ASAV, LDA, INFO ) +* + OK1 = .TRUE. + IF ( LOWER ) THEN + DO J = 1, N + DO I = J, N + IF ( A(I,J).NE.ASAV(I,J) ) THEN + OK1 = .FALSE. + END IF + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, J + IF ( A(I,J).NE.ASAV(I,J) ) THEN + OK1 = .FALSE. + END IF + END DO + END DO + END IF +* + NRUN = NRUN + 1 +* + SRNAMT = 'ZTRTTP' + CALL ZTRTTP( UPLO, N, A, LDA, AP, INFO ) +* + SRNAMT = 'ZTPTTF' + CALL ZTPTTF( CFORM, UPLO, N, AP, ARF, INFO ) +* + SRNAMT = 'ZTFTTR' + CALL ZTFTTR( CFORM, UPLO, N, ARF, ASAV, LDA, INFO ) +* + OK2 = .TRUE. + IF ( LOWER ) THEN + DO J = 1, N + DO I = J, N + IF ( A(I,J).NE.ASAV(I,J) ) THEN + OK2 = .FALSE. + END IF + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, J + IF ( A(I,J).NE.ASAV(I,J) ) THEN + OK2 = .FALSE. + END IF + END DO + END DO + END IF +* + IF (( .NOT.OK1 ).OR.( .NOT.OK2 )) THEN + IF( NERRS.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9998 ) N, UPLO, CFORM + NERRS = NERRS + 1 + END IF +* + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE +* +* Print a summary of the results. +* + IF ( NERRS.EQ.0 ) THEN + WRITE( NOUT, FMT = 9997 ) NRUN + ELSE + WRITE( NOUT, FMT = 9996 ) NERRS, NRUN + END IF +* + 9999 FORMAT( 1X, ' *** Error(s) while testing the RFP convertion', + + ' routines ***') + 9998 FORMAT( 1X, ' Error in RFP,convertion routines N=',I5, + + ' UPLO=''', A1, ''', FORM =''',A1,'''') + 9997 FORMAT( 1X, 'All tests for the RFP convertion routines passed (', + + I5,' tests run)') + 9996 FORMAT( 1X, 'RFP convertion routines:',I5,' out of ',I5, + + ' error message recorded') +* + RETURN +* +* End of ZDRVRF2 +* + END diff --git a/TESTING/LIN/zdrvrf3.f b/TESTING/LIN/zdrvrf3.f new file mode 100644 index 00000000..acd11244 --- /dev/null +++ b/TESTING/LIN/zdrvrf3.f @@ -0,0 +1,310 @@ + SUBROUTINE ZDRVRF3( NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, + + D_WORK_ZLANGE, Z_WORK_ZGEQRF, TAU ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER LDA, NN, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ) + DOUBLE PRECISION D_WORK_ZLANGE( * ) + COMPLEX*16 A( LDA, * ), ARF( * ), B1( LDA, * ), + + B2( LDA, * ) + COMPLEX*16 Z_WORK_ZGEQRF( * ), TAU( * ) +* .. +* +* Purpose +* ======= +* +* ZDRVRF3 tests the LAPACK RFP routines: +* ZTFSM +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* THRESH (input) 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. +* +* A (workspace) COMPLEX*16 array, dimension (LDA,NMAX) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* ARF (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2). +* +* B1 (workspace) COMPLEX*16 array, dimension (LDA,NMAX) +* +* B2 (workspace) COMPLEX*16 array, dimension (LDA,NMAX) +* +* D_WORK_ZLANGE (workspace) DOUBLE PRECISION array, dimension (NMAX) +* +* Z_WORK_ZGEQRF (workspace) COMPLEX*16 array, dimension (NMAX) +* +* TAU (workspace) COMPLEX*16 array, dimension (NMAX) +* +* ===================================================================== +* .. +* .. Parameters .. + COMPLEX*16 ZERO, ONE + PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) , + + ONE = ( 1.0D+0, 0.0D+0 ) ) + INTEGER NTESTS + PARAMETER ( NTESTS = 1 ) +* .. +* .. Local Scalars .. + CHARACTER UPLO, CFORM, DIAG, TRANS, SIDE + INTEGER I, IFORM, IIM, IIN, INFO, IUPLO, J, M, N, NA, + + NFAIL, NRUN, ISIDE, IDIAG, IALPHA, ITRANS + COMPLEX*16 ALPHA + DOUBLE PRECISION EPS +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ), + + DIAGS( 2 ), SIDES( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, ZLANGE + COMPLEX*16 ZLARND + EXTERNAL DLAMCH, ZLARND, ZLANGE +* .. +* .. External Subroutines .. + EXTERNAL ZTRTTF, ZGEQRF, ZGEQLF, ZTFSM, ZTRSM +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'C' / + DATA SIDES / 'L', 'R' / + DATA TRANSS / 'N', 'C' / + DATA DIAGS / 'N', 'U' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NFAIL = 0 + INFO = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + EPS = DLAMCH( 'Precision' ) +* + DO 170 IIM = 1, NN +* + M = NVAL( IIM ) +* + DO 160 IIN = 1, NN +* + N = NVAL( IIN ) +* + DO 150 IFORM = 1, 2 +* + CFORM = FORMS( IFORM ) +* + DO 140 IUPLO = 1, 2 +* + UPLO = UPLOS( IUPLO ) +* + DO 130 ISIDE = 1, 2 +* + SIDE = SIDES( ISIDE ) +* + DO 120 ITRANS = 1, 2 +* + TRANS = TRANSS( ITRANS ) +* + DO 110 IDIAG = 1, 2 +* + DIAG = DIAGS( IDIAG ) +* + DO 100 IALPHA = 1, 3 +* + IF ( IALPHA.EQ. 1) THEN + ALPHA = ZERO + ELSE IF ( IALPHA.EQ. 1) THEN + ALPHA = ONE + ELSE + ALPHA = ZLARND( 4, ISEED ) + END IF +* +* All the parameters are set: +* CFORM, SIDE, UPLO, TRANS, DIAG, M, N, +* and ALPHA +* READY TO TEST! +* + NRUN = NRUN + 1 +* + IF ( ISIDE.EQ.1 ) THEN +* +* The case ISIDE.EQ.1 is when SIDE.EQ.'L' +* -> A is M-by-M ( B is M-by-N ) +* + NA = M +* + ELSE +* +* The case ISIDE.EQ.2 is when SIDE.EQ.'R' +* -> A is N-by-N ( B is M-by-N ) +* + NA = N +* + END IF +* +* Generate A our NA--by--NA triangular +* matrix. +* Our test is based on forward error so we +* do want A to be well conditionned! To get +* a well-conditionned triangular matrix, we +* take the R factor of the QR/LQ factorization +* of a random matrix. +* + DO J = 1, NA + DO I = 1, NA + A( I, J) = ZLARND( 4, ISEED ) + END DO + END DO +* + IF ( IUPLO.EQ.1 ) THEN +* +* The case IUPLO.EQ.1 is when SIDE.EQ.'U' +* -> QR factorization. +* + SRNAMT = 'ZGEQRF' + CALL ZGEQRF( NA, NA, A, LDA, TAU, + + Z_WORK_ZGEQRF, LDA, + + INFO ) + ELSE +* +* The case IUPLO.EQ.2 is when SIDE.EQ.'L' +* -> QL factorization. +* + SRNAMT = 'ZGELQF' + CALL ZGELQF( NA, NA, A, LDA, TAU, + + Z_WORK_ZGEQRF, LDA, + + INFO ) + END IF +* +* After the QR factorization, the diagonal +* of A is made of real numbers, we multiply +* by a random complex number of absolute +* value 1.0E+00. +* + DO J = 1, NA + A( J, J) = A(J,J) * ZLARND( 5, ISEED ) + END DO +* +* Store a copy of A in RFP format (in ARF). +* + SRNAMT = 'ZTRTTF' + CALL ZTRTTF( CFORM, UPLO, NA, A, LDA, ARF, + + INFO ) +* +* Generate B1 our M--by--N right-hand side +* and store a copy in B2. +* + DO J = 1, N + DO I = 1, M + B1( I, J) = ZLARND( 4, ISEED ) + B2( I, J) = B1( I, J) + END DO + END DO +* +* Solve op( A ) X = B or X op( A ) = B +* with ZTRSM +* + SRNAMT = 'ZTRSM' + CALL ZTRSM( SIDE, UPLO, TRANS, DIAG, M, N, + + ALPHA, A, LDA, B1, LDA ) +* +* Solve op( A ) X = B or X op( A ) = B +* with ZTFSM +* + SRNAMT = 'ZTFSM' + CALL ZTFSM( CFORM, SIDE, UPLO, TRANS, + + DIAG, M, N, ALPHA, ARF, B2, + + LDA ) +* +* Check that the result agrees. +* + DO J = 1, N + DO I = 1, M + B1( I, J) = B2( I, J ) - B1( I, J ) + END DO + END DO +* + RESULT(1) = ZLANGE( 'I', M, N, B1, LDA, + + D_WORK_ZLANGE ) +* + RESULT(1) = RESULT(1) / SQRT( EPS ) + + / MAX ( MAX( M, N), 1 ) +* + IF( RESULT(1).GE.THRESH ) THEN + IF( NFAIL.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9997 ) 'ZTFSM', + + CFORM, SIDE, UPLO, TRANS, DIAG, M, + + N, RESULT(1) + NFAIL = NFAIL + 1 + END IF +* + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE +* +* Print a summary of the results. +* + IF ( NFAIL.EQ.0 ) THEN + WRITE( NOUT, FMT = 9996 ) 'ZTFSM', NRUN + ELSE + WRITE( NOUT, FMT = 9995 ) 'ZTFSM', NFAIL, NRUN + END IF +* + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing ZTFSM + + ***') + 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', + + ' SIDE=''',A1,''',',' UPLO=''',A1,''',',' TRANS=''',A1,''',', + + ' DIAG=''',A1,''',',' M=',I3,', N =', I3,', test=',G12.5) + 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ', + + 'threshold (',I5,' tests run)') + 9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5, + + ' tests failed to pass the threshold') +* + RETURN +* +* End of ZDRVRF3 +* + END diff --git a/TESTING/LIN/zdrvrf4.f b/TESTING/LIN/zdrvrf4.f new file mode 100644 index 00000000..fc6b4035 --- /dev/null +++ b/TESTING/LIN/zdrvrf4.f @@ -0,0 +1,283 @@ + SUBROUTINE ZDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, + + LDA, D_WORK_ZLANGE ) +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER LDA, LDC, NN, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ) + DOUBLE PRECISION D_WORK_ZLANGE( * ) + COMPLEX*16 A( LDA, * ), C1( LDC, * ), C2( LDC, *), + + CRF( * ) +* .. +* +* Purpose +* ======= +* +* ZDRVRF4 tests the LAPACK RFP routines: +* ZHFRK +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* THRESH (input) 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. +* +* C1 (workspace) COMPLEX*16 array, dimension (LDC,NMAX) +* +* C2 (workspace) COMPLEX*16 array, dimension (LDC,NMAX) +* +* LDC (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* CRF (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2). +* +* A (workspace) COMPLEX*16 array, dimension (LDA,NMAX) +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,NMAX). +* +* D_WORK_ZLANGE (workspace) DOUBLE PRECISION array, dimension (NMAX) +* +* ===================================================================== +* .. +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 1 ) +* .. +* .. Local Scalars .. + CHARACTER UPLO, CFORM, TRANS + INTEGER I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N, + + NFAIL, NRUN, IALPHA, ITRANS + DOUBLE PRECISION ALPHA, BETA, EPS, NORMA, NORMC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DLARND, ZLANGE + COMPLEX*16 ZLARND + EXTERNAL DLAMCH, DLARND, ZLANGE, ZLARND +* .. +* .. External Subroutines .. + EXTERNAL ZHERK, ZHFRK, ZTFTTR, ZTRTTF +* .. +* .. Intrinsic Functions .. + INTRINSIC DABS, MAX +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'C' / + DATA TRANSS / 'N', 'C' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NFAIL = 0 + INFO = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE + EPS = DLAMCH( 'Precision' ) +* + DO 150 IIN = 1, NN +* + N = NVAL( IIN ) +* + DO 140 IIK = 1, NN +* + K = NVAL( IIN ) +* + DO 130 IFORM = 1, 2 +* + CFORM = FORMS( IFORM ) +* + DO 120 IUPLO = 1, 2 +* + UPLO = UPLOS( IUPLO ) +* + DO 110 ITRANS = 1, 2 +* + TRANS = TRANSS( ITRANS ) +* + DO 100 IALPHA = 1, 4 +* + IF ( IALPHA.EQ. 1) THEN + ALPHA = ZERO + BETA = ZERO + ELSE IF ( IALPHA.EQ. 1) THEN + ALPHA = ONE + BETA = ZERO + ELSE IF ( IALPHA.EQ. 1) THEN + ALPHA = ZERO + BETA = ONE + ELSE + ALPHA = DLARND( 2, ISEED ) + BETA = DLARND( 2, ISEED ) + END IF +* +* All the parameters are set: +* CFORM, UPLO, TRANS, M, N, +* ALPHA, and BETA +* READY TO TEST! +* + NRUN = NRUN + 1 +* + IF ( ITRANS.EQ.1 ) THEN +* +* In this case we are NOTRANS, so A is N-by-K +* + DO J = 1, K + DO I = 1, N + A( I, J) = ZLARND( 4, ISEED ) + END DO + END DO +* + NORMA = ZLANGE( 'I', N, K, A, LDA, + + D_WORK_ZLANGE ) +* + ELSE +* +* In this case we are TRANS, so A is K-by-N +* + DO J = 1,N + DO I = 1, K + A( I, J) = ZLARND( 4, ISEED ) + END DO + END DO +* + NORMA = ZLANGE( 'I', K, N, A, LDA, + + D_WORK_ZLANGE ) +* + END IF +* +* +* Generate C1 our N--by--N Hermitian matrix. +* Make sure C2 has the same upper/lower part, +* (the one that we do not touch), so +* copy the initial C1 in C2 in it. +* + DO J = 1, N + DO I = 1, N + C1( I, J) = ZLARND( 4, ISEED ) + C2(I,J) = C1(I,J) + END DO + END DO +* +* (See comment later on for why we use ZLANGE and +* not ZLANHE for C1.) +* + NORMC = ZLANGE( 'I', N, N, C1, LDC, + + D_WORK_ZLANGE ) +* + SRNAMT = 'ZTRTTF' + CALL ZTRTTF( CFORM, UPLO, N, C1, LDC, CRF, + + INFO ) +* +* call zherk the BLAS routine -> gives C1 +* + SRNAMT = 'ZHERK ' + CALL ZHERK( UPLO, TRANS, N, K, ALPHA, A, LDA, + + BETA, C1, LDC ) +* +* call zhfrk the RFP routine -> gives CRF +* + SRNAMT = 'ZHFRK ' + CALL ZHFRK( CFORM, UPLO, TRANS, N, K, ALPHA, A, + + LDA, BETA, CRF ) +* +* convert CRF in full format -> gives C2 +* + SRNAMT = 'ZTFTTR' + CALL ZTFTTR( CFORM, UPLO, N, CRF, C2, LDC, + + INFO ) +* +* compare C1 and C2 +* + DO J = 1, N + DO I = 1, N + C1(I,J) = C1(I,J)-C2(I,J) + END DO + END DO +* +* Yes, C1 is Hermitian so we could call ZLANHE, +* but we want to check the upper part that is +* supposed to be unchanged and the diagonal that +* is supposed to be real -> ZLANGE +* + RESULT(1) = ZLANGE( 'I', N, N, C1, LDC, + + D_WORK_ZLANGE ) + RESULT(1) = RESULT(1) + + / MAX( DABS( ALPHA ) * NORMA * NORMA + + + DABS( BETA ) * NORMC, ONE ) + + / MAX( N , 1 ) / EPS +* + IF( RESULT(1).GE.THRESH ) THEN + IF( NFAIL.EQ.0 ) THEN + WRITE( NOUT, * ) + WRITE( NOUT, FMT = 9999 ) + END IF + WRITE( NOUT, FMT = 9997 ) 'ZHFRK', + + CFORM, UPLO, TRANS, N, K, RESULT(1) + NFAIL = NFAIL + 1 + END IF +* + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 130 CONTINUE + 140 CONTINUE + 150 CONTINUE +* +* Print a summary of the results. +* + IF ( NFAIL.EQ.0 ) THEN + WRITE( NOUT, FMT = 9996 ) 'ZHFRK', NRUN + ELSE + WRITE( NOUT, FMT = 9995 ) 'ZHFRK', NFAIL, NRUN + END IF +* + 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing ZHFRK + + ***') + 9997 FORMAT( 1X, ' Failure in ',A5,', CFORM=''',A1,''',', + + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3, + + ', test=',G12.5) + 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ', + + 'threshold (',I5,' tests run)') + 9995 FORMAT( 1X, A6, ' auxiliary routine:',I5,' out of ',I5, + + ' tests failed to pass the threshold') +* + RETURN +* +* End of ZDRVRF4 +* + END diff --git a/TESTING/LIN/zdrvrfp.f b/TESTING/LIN/zdrvrfp.f new file mode 100644 index 00000000..2a917e15 --- /dev/null +++ b/TESTING/LIN/zdrvrfp.f @@ -0,0 +1,454 @@ + SUBROUTINE ZDRVRFP( NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, + + THRESH, A, ASAV, AFAC, AINV, B, + + BSAV, XACT, X, ARF, ARFINV, + + Z_WORK_ZLATMS, Z_WORK_ZPOT01, Z_WORK_ZPOT02, + + Z_WORK_ZPOT03, D_WORK_ZLATMS, D_WORK_ZLANHE, + + D_WORK_ZPOT02, D_WORK_ZPOT03 ) +* + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER NN, NNS, NNT, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + INTEGER NVAL( NN ), NSVAL( NNS ), NTVAL( NNT ) + COMPLEX*16 A( * ) + COMPLEX*16 AINV( * ) + COMPLEX*16 ASAV( * ) + COMPLEX*16 B( * ) + COMPLEX*16 BSAV( * ) + COMPLEX*16 AFAC( * ) + COMPLEX*16 ARF( * ) + COMPLEX*16 ARFINV( * ) + COMPLEX*16 XACT( * ) + COMPLEX*16 X( * ) + COMPLEX*16 Z_WORK_ZLATMS( * ) + COMPLEX*16 Z_WORK_ZPOT01( * ) + COMPLEX*16 Z_WORK_ZPOT02( * ) + COMPLEX*16 Z_WORK_ZPOT03( * ) + DOUBLE PRECISION D_WORK_ZLATMS( * ) + DOUBLE PRECISION D_WORK_ZLANHE( * ) + DOUBLE PRECISION D_WORK_ZPOT02( * ) + DOUBLE PRECISION D_WORK_ZPOT03( * ) +* .. +* +* Purpose +* ======= +* +* ZDRVRFP tests the LAPACK RFP routines: +* ZPFTRF, ZPFTRS, and ZPFTRI. +* +* This testing routine follow the same tests as ZDRVPO (test for the full +* format Symmetric Positive Definite solver). +* +* The tests are performed in Full Format, convertion back and forth from +* full format to RFP format are performed using the routines ZTRTTF and +* ZTFTTR. +* +* First, a specific matrix A of size N is created. There is nine types of +* different matrixes possible. +* 1. Diagonal 6. Random, CNDNUM = sqrt(0.1/EPS) +* 2. Random, CNDNUM = 2 7. Random, CNDNUM = 0.1/EPS +* *3. First row and column zero 8. Scaled near underflow +* *4. Last row and column zero 9. Scaled near overflow +* *5. Middle row and column zero +* (* - tests error exits from ZPFTRF, no test ratios are computed) +* A solution XACT of size N-by-NRHS is created and the associated right +* hand side B as well. Then ZPFTRF is called to compute L (or U), the +* Cholesky factor of A. Then L (or U) is used to solve the linear system +* of equations AX = B. This gives X. Then L (or U) is used to compute the +* inverse of A, AINV. The following four tests are then performed: +* (1) norm( L*L' - A ) / ( N * norm(A) * EPS ) or +* norm( U'*U - A ) / ( N * norm(A) * EPS ), +* (2) norm(B - A*X) / ( norm(A) * norm(X) * EPS ), +* (3) norm( I - A*AINV ) / ( N * norm(A) * norm(AINV) * EPS ), +* (4) ( norm(X-XACT) * RCOND ) / ( norm(XACT) * EPS ), +* where EPS is the machine precision, RCOND the condition number of A, and +* norm( . ) the 1-norm for (1,2,3) and the inf-norm for (4). +* Errors occur when INFO parameter is not as expected. Failures occur when +* a test ratios is greater than THRES. +* +* Arguments +* ========= +* +* NOUT (input) INTEGER +* The unit number for output. +* +* NN (input) INTEGER +* The number of values of N contained in the vector NVAL. +* +* NVAL (input) INTEGER array, dimension (NN) +* The values of the matrix dimension N. +* +* NNS (input) INTEGER +* The number of values of NRHS contained in the vector NSVAL. +* +* NSVAL (input) INTEGER array, dimension (NNS) +* The values of the number of right-hand sides NRHS. +* +* NNT (input) INTEGER +* The number of values of MATRIX TYPE contained in the vector NTVAL. +* +* NTVAL (input) INTEGER array, dimension (NNT) +* The values of matrix type (between 0 and 9 for PO/PP/PF matrices). +* +* THRESH (input) 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. +* +* A (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) +* +* ASAV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) +* +* AFAC (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) +* +* AINV (workspace) COMPLEX*16 array, dimension (NMAX*NMAX) +* +* B (workspace) COMPLEX*16 array, dimension (NMAX*MAXRHS) +* +* BSAV (workspace) COMPLEX*16 array, dimension (NMAX*MAXRHS) +* +* XACT (workspace) COMPLEX*16 array, dimension (NMAX*MAXRHS) +* +* X (workspace) COMPLEX*16 array, dimension (NMAX*MAXRHS) +* +* ARF (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2) +* +* ARFINV (workspace) COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2) +* +* Z_WORK_ZLATMS (workspace) COMPLEX*16 array, dimension ( 3*NMAX ) +* +* Z_WORK_ZPOT01 (workspace) COMPLEX*16 array, dimension ( NMAX ) +* +* Z_WORK_ZPOT02 (workspace) COMPLEX*16 array, dimension ( NMAX*MAXRHS ) +* +* Z_WORK_ZPOT03 (workspace) COMPLEX*16 array, dimension ( NMAX*NMAX ) +* +* D_WORK_ZLATMS (workspace) DOUBLE PRECISION array, dimension ( NMAX ) +* +* D_WORK_ZLANHE (workspace) DOUBLE PRECISION array, dimension ( NMAX ) +* +* D_WORK_ZPOT02 (workspace) DOUBLE PRECISION array, dimension ( NMAX ) +* +* D_WORK_ZPOT03 (workspace) DOUBLE PRECISION array, dimension ( NMAX ) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 4 ) +* .. +* .. Local Scalars .. + LOGICAL ZEROT + INTEGER I, INFO, IUPLO, LDA, LDB, IMAT, NERRS, NFAIL, + + NRHS, NRUN, IZERO, IOFF, K, NT, N, IFORM, IIN, + + IIT, IIS + CHARACTER DIST, CTYPE, UPLO, CFORM + INTEGER KL, KU, MODE + DOUBLE PRECISION ANORM, AINVNM, CNDNUM, RCONDC +* .. +* .. Local Arrays .. + CHARACTER UPLOS( 2 ), FORMS( 2 ) + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION ZLANHE + EXTERNAL ZLANHE +* .. +* .. External Subroutines .. + EXTERNAL ALADHD, ALAERH, ALASVM, ZGET04, ZTFTTR, ZLACPY, + + ZLAIPD, ZLARHS, ZLATB4, ZLATMS, ZPFTRI, ZPFTRF, + + ZPFTRS, ZPOT01, ZPOT02, ZPOT03, ZPOTRI, ZPOTRF, + + ZTRTTF +* .. +* .. Scalars in Common .. + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / + DATA UPLOS / 'U', 'L' / + DATA FORMS / 'N', 'C' / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO 10 I = 1, 4 + ISEED( I ) = ISEEDY( I ) + 10 CONTINUE +* + DO 130 IIN = 1, NN +* + N = NVAL( IIN ) + LDA = MAX( N, 1 ) + LDB = MAX( N, 1 ) +* + DO 980 IIS = 1, NNS +* + NRHS = NSVAL( IIS ) +* + DO 120 IIT = 1, NNT +* + IMAT = NTVAL( IIT ) +* +* If N.EQ.0, only consider the first type +* + IF( N.EQ.0 .AND. IIT.GT.1 ) GO TO 120 +* +* Skip types 3, 4, or 5 if the matrix size is too small. +* + IF( IMAT.EQ.4 .AND. N.LE.1 ) GO TO 120 + IF( IMAT.EQ.5 .AND. N.LE.2 ) GO TO 120 +* +* Do first for UPLO = 'U', then for UPLO = 'L' +* + DO 110 IUPLO = 1, 2 + UPLO = UPLOS( IUPLO ) +* +* Do first for CFORM = 'N', then for CFORM = 'C' +* + DO 100 IFORM = 1, 2 + CFORM = FORMS( IFORM ) +* +* Set up parameters with ZLATB4 and generate a test +* matrix with ZLATMS. +* + CALL ZLATB4( 'ZPO', IMAT, N, N, CTYPE, KL, KU, + + ANORM, MODE, CNDNUM, DIST ) +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( N, N, DIST, ISEED, CTYPE, + + D_WORK_ZLATMS, + + MODE, CNDNUM, ANORM, KL, KU, UPLO, A, + + LDA, Z_WORK_ZLATMS, INFO ) +* +* Check error code from ZLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( 'ZPF', 'ZLATMS', INFO, 0, UPLO, N, + + N, -1, -1, -1, IIT, NFAIL, NERRS, + + NOUT ) + GO TO 100 + END IF +* +* For types 3-5, zero one row and column of the matrix to +* test that INFO is returned correctly. +* + ZEROT = IMAT.GE.3 .AND. IMAT.LE.5 + IF( ZEROT ) THEN + IF( IIT.EQ.3 ) THEN + IZERO = 1 + ELSE IF( IIT.EQ.4 ) THEN + IZERO = N + ELSE + IZERO = N / 2 + 1 + END IF + IOFF = ( IZERO-1 )*LDA +* +* Set row and column IZERO of A to 0. +* + IF( IUPLO.EQ.1 ) THEN + 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 + IZERO = 0 + END IF +* +* Set the imaginary part of the diagonals. +* + CALL ZLAIPD( N, A, LDA+1, 0 ) +* +* Save a copy of the matrix A in ASAV. +* + CALL ZLACPY( UPLO, N, N, A, LDA, ASAV, LDA ) +* +* Compute the condition number of A (RCONDC). +* + IF( ZEROT ) THEN + RCONDC = ZERO + ELSE +* +* Compute the 1-norm of A. +* + ANORM = ZLANHE( '1', UPLO, N, A, LDA, + + D_WORK_ZLANHE ) +* +* Factor the matrix A. +* + CALL ZPOTRF( UPLO, N, A, LDA, INFO ) +* +* Form the inverse of A. +* + CALL ZPOTRI( UPLO, N, A, LDA, INFO ) +* +* Compute the 1-norm condition number of A. +* + AINVNM = ZLANHE( '1', UPLO, N, A, LDA, + + D_WORK_ZLANHE ) + RCONDC = ( ONE / ANORM ) / AINVNM +* +* Restore the matrix A. +* + CALL ZLACPY( UPLO, N, N, ASAV, LDA, A, LDA ) +* + END IF +* +* Form an exact solution and set the right hand side. +* + SRNAMT = 'ZLARHS' + CALL ZLARHS( 'ZPO', 'N', UPLO, ' ', N, N, KL, KU, + + NRHS, A, LDA, XACT, LDA, B, LDA, + + ISEED, INFO ) + CALL ZLACPY( 'Full', N, NRHS, B, LDA, BSAV, LDA ) +* +* Compute the L*L' or U'*U factorization of the +* matrix and solve the system. +* + CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA ) + CALL ZLACPY( 'Full', N, NRHS, B, LDB, X, LDB ) +* + SRNAMT = 'ZTRTTF' + CALL ZTRTTF( CFORM, UPLO, N, AFAC, LDA, ARF, INFO ) + SRNAMT = 'ZPFTRF' + CALL ZPFTRF( CFORM, UPLO, N, ARF, INFO ) +* +* Check error code from ZPFTRF. +* + IF( INFO.NE.IZERO ) THEN +* +* LANGOU: there is a small hick here: IZERO should +* always be INFO however if INFO is ZERO, ALAERH does not +* complain. +* + CALL ALAERH( 'ZPF', 'ZPFSV ', INFO, IZERO, + + UPLO, N, N, -1, -1, NRHS, IIT, + + NFAIL, NERRS, NOUT ) + GO TO 100 + END IF +* +* Skip the tests if INFO is not 0. +* + IF( INFO.NE.0 ) THEN + GO TO 100 + END IF +* + SRNAMT = 'ZPFTRS' + CALL ZPFTRS( CFORM, UPLO, N, NRHS, ARF, X, LDB, + + INFO ) +* + SRNAMT = 'ZTFTTR' + CALL ZTFTTR( CFORM, UPLO, N, ARF, AFAC, LDA, INFO ) +* +* Reconstruct matrix from factors and compute +* residual. +* + CALL ZLACPY( UPLO, N, N, AFAC, LDA, ASAV, LDA ) + CALL ZPOT01( UPLO, N, A, LDA, AFAC, LDA, + + Z_WORK_ZPOT01, RESULT( 1 ) ) + CALL ZLACPY( UPLO, N, N, ASAV, LDA, AFAC, LDA ) +* +* Form the inverse and compute the residual. +* + IF(MOD(N,2).EQ.0)THEN + CALL ZLACPY( 'A', N+1, N/2, ARF, N+1, ARFINV, + + N+1 ) + ELSE + CALL ZLACPY( 'A', N, (N+1)/2, ARF, N, ARFINV, + + N ) + END IF +* + SRNAMT = 'ZPFTRI' + CALL ZPFTRI( CFORM, UPLO, N, ARFINV , INFO ) +* + SRNAMT = 'ZTFTTR' + CALL ZTFTTR( CFORM, UPLO, N, ARFINV, AINV, LDA, + + INFO ) +* +* Check error code from ZPFTRI. +* + IF( INFO.NE.0 ) + + CALL ALAERH( 'ZPO', 'ZPFTRI', INFO, 0, UPLO, N, + + N, -1, -1, -1, IMAT, NFAIL, NERRS, + + NOUT ) +* + CALL ZPOT03( UPLO, N, A, LDA, AINV, LDA, + + Z_WORK_ZPOT03, LDA, D_WORK_ZPOT03, + + RCONDC, RESULT( 2 ) ) +* +* Compute residual of the computed solution. +* + CALL ZLACPY( 'Full', N, NRHS, B, LDA, + + Z_WORK_ZPOT02, LDA ) + CALL ZPOT02( UPLO, N, NRHS, A, LDA, X, LDA, + + Z_WORK_ZPOT02, LDA, D_WORK_ZPOT02, + + RESULT( 3 ) ) +* +* Check solution from generated exact solution. +* + CALL ZGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC, + + RESULT( 4 ) ) + NT = 4 +* +* Print information about the tests that did not +* pass the threshold. +* + DO 60 K = 1, NT + IF( RESULT( K ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + + CALL ALADHD( NOUT, 'ZPF' ) + WRITE( NOUT, FMT = 9999 )'ZPFSV ', UPLO, + + N, IIT, K, RESULT( K ) + NFAIL = NFAIL + 1 + END IF + 60 CONTINUE + NRUN = NRUN + NT + 100 CONTINUE + 110 CONTINUE + 120 CONTINUE + 980 CONTINUE + 130 CONTINUE +* +* Print a summary of the results. +* + CALL ALASVM( 'ZPF', NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A6, ', UPLO=''', A1, ''', N =', I5, ', type ', I1, + + ', test(', I1, ')=', G12.5 ) +* + RETURN +* +* End of ZDRVRFP +* + END diff --git a/TESTING/LIN/zdrvsp.f b/TESTING/LIN/zdrvsp.f index 088d196e..3a1334ea 100644 --- a/TESTING/LIN/zdrvsp.f +++ b/TESTING/LIN/zdrvsp.f @@ -115,7 +115,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zdrvsy.f b/TESTING/LIN/zdrvsy.f index 907c706f..c8814dba 100644 --- a/TESTING/LIN/zdrvsy.f +++ b/TESTING/LIN/zdrvsy.f @@ -112,7 +112,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NUNIT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zebchvxx.f b/TESTING/LIN/zebchvxx.f new file mode 100644 index 00000000..d5debfab --- /dev/null +++ b/TESTING/LIN/zebchvxx.f @@ -0,0 +1,474 @@ + SUBROUTINE ZEBCHVXX( THRESH, PATH ) + IMPLICIT NONE +* .. Scalar Arguments .. + DOUBLE PRECISION THRESH + CHARACTER*3 PATH +* +* Purpose +* ====== +* +* ZEBCHVXX will run Z**SVXX on a series of Hilbert matrices and then +* compare the error bounds returned by Z**SVXX to see if the returned +* answer indeed falls within those bounds. +* +* Eight test ratios will be computed. The tests will pass if they are .LT. +* THRESH. There are two cases that are determined by 1 / (SQRT( N ) * EPS). +* If that value is .LE. to the component wise reciprocal condition number, +* it uses the guaranteed case, other wise it uses the unguaranteed case. +* +* Test ratios: +* Let Xc be X_computed and Xt be X_truth. +* The norm used is the infinity norm. + +* Let A be the guaranteed case and B be the unguaranteed case. +* +* 1. Normwise guaranteed forward error bound. +* A: norm ( abs( Xc - Xt ) / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ) and +* ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N),10) * EPS. +* If these conditions are met, the test ratio is set to be +* ERRBND( *, nwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. +* B: For this case, CGESVXX should just return 1. If it is less than +* one, treat it the same as in 1A. Otherwise it fails. (Set test +* ratio to ERRBND( *, nwise_i, bnd_i ) * THRESH?) +* +* 2. Componentwise guaranteed forward error bound. +* A: norm ( abs( Xc(j) - Xt(j) ) ) / norm (Xt(j)) .LE. ERRBND( *, cwise_i, bnd_i ) +* for all j .AND. ERRBND( *, cwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS. +* If these conditions are met, the test ratio is set to be +* ERRBND( *, cwise_i, bnd_i ) / MAX(SQRT(N), 10). Otherwise it is 1/EPS. +* B: Same as normwise test ratio. +* +* 3. Backwards error. +* A: The test ratio is set to BERR/EPS. +* B: Same test ratio. +* +* 4. Reciprocal condition number. +* A: A condition number is computed with Xt and compared with the one +* returned from CGESVXX. Let RCONDc be the RCOND returned by CGESVXX +* and RCONDt be the RCOND from the truth value. Test ratio is set to +* MAX(RCONDc/RCONDt, RCONDt/RCONDc). +* B: Test ratio is set to 1 / (EPS * RCONDc). +* +* 5. Reciprocal normwise condition number. +* A: The test ratio is set to +* MAX(ERRBND( *, nwise_i, cond_i ) / NCOND, NCOND / ERRBND( *, nwise_i, cond_i )). +* B: Test ratio is set to 1 / (EPS * ERRBND( *, nwise_i, cond_i )). +* +* 6. Reciprocal componentwise condition number. +* A: Test ratio is set to +* MAX(ERRBND( *, cwise_i, cond_i ) / CCOND, CCOND / ERRBND( *, cwise_i, cond_i )). +* B: Test ratio is set to 1 / (EPS * ERRBND( *, cwise_i, cond_i )). +* +* .. Parameters .. +* NMAX is determined by the largest number in the inverse of the hilbert +* matrix. Precision is exhausted when the largest entry in it is greater +* than 2 to the power of the number of bits in the fraction of the data +* type used plus one, which is 24 for single precision. +* NMAX should be 6 for single and 11 for double. + + INTEGER NMAX, NPARAMS, NERRBND, NTESTS, KL, KU + PARAMETER (NMAX = 10, NPARAMS = 2, NERRBND = 3, + $ NTESTS = 6) + +* .. Local Scalars .. + INTEGER N, NRHS, INFO, I ,J, k, NFAIL, LDA, + $ N_AUX_TESTS, LDAB, LDAFB + CHARACTER FACT, TRANS, UPLO, EQUED + CHARACTER*2 C2 + CHARACTER(3) NGUAR, CGUAR + LOGICAL printed_guide + DOUBLE PRECISION NCOND, CCOND, M, NORMDIF, NORMT, RCOND, + $ RNORM, RINORM, SUMR, SUMRI, EPS, + $ BERR(NMAX), RPVGRW, ORCOND, + $ CWISE_ERR, NWISE_ERR, CWISE_BND, NWISE_BND, + $ CWISE_RCOND, NWISE_RCOND, + $ CONDTHRESH, ERRTHRESH + COMPLEX*16 ZDUM + +* .. Local Arrays .. + DOUBLE PRECISION TSTRAT(NTESTS), RINV(NMAX), PARAMS(NPARAMS), + $ S(NMAX),R(NMAX),C(NMAX),RWORK(3*NMAX), + $ DIFF(NMAX, NMAX), + $ ERRBND_N(NMAX*3), ERRBND_C(NMAX*3) + INTEGER IPIV(NMAX) + COMPLEX*16 A(NMAX,NMAX),INVHILB(NMAX,NMAX),X(NMAX,NMAX), + $ WORK(NMAX*3*5), AF(NMAX, NMAX),B(NMAX, NMAX), + $ ACOPY(NMAX, NMAX), + $ AB( (NMAX-1)+(NMAX-1)+1, NMAX ), + $ ABCOPY( (NMAX-1)+(NMAX-1)+1, NMAX ), + $ AFB( 2*(NMAX-1)+(NMAX-1)+1, NMAX ) + +* .. External Functions .. + DOUBLE PRECISION DLAMCH + +* .. External Subroutines .. + EXTERNAL ZLAHILB, ZGESVXX, ZPOSVXX, ZSYSVXX, + $ ZGBSVXX, ZLACPY, LSAMEN + LOGICAL LSAMEN + +* .. Intrinsic Functions .. + INTRINSIC SQRT, MAX, ABS, DBLE, DIMAG + +* .. Statement Functions .. + DOUBLE PRECISION CABS1 + +* .. Statement Function Definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) + +* .. Parameters .. + INTEGER NWISE_I, CWISE_I + PARAMETER (NWISE_I = 1, CWISE_I = 1) + INTEGER BND_I, COND_I + PARAMETER (BND_I = 2, COND_I = 3) + +* Create the loop to test out the Hilbert matrices + + FACT = 'E' + UPLO = 'U' + TRANS = 'N' + EQUED = 'N' + EPS = DLAMCH('Epsilon') + NFAIL = 0 + N_AUX_TESTS = 0 + LDA = NMAX + LDAB = (NMAX-1)+(NMAX-1)+1 + LDAFB = 2*(NMAX-1)+(NMAX-1)+1 + C2 = PATH( 2: 3 ) + +* Main loop to test the different Hilbert Matrices. + + printed_guide = .false. + + DO N = 1 , NMAX + PARAMS(1) = -1 + PARAMS(2) = -1 + + KL = N-1 + KU = N-1 + NRHS = n + M = MAX(SQRT(DBLE(N)), 10.0D+0) + +* Generate the Hilbert matrix, its inverse, and the +* right hand side, all scaled by the LCM(1,..,2N-1). + CALL ZLAHILB(N, N, A, LDA, INVHILB, LDA, B, + $ LDA, WORK, INFO, PATH) + +* Copy A into ACOPY. + CALL ZLACPY('ALL', N, N, A, NMAX, ACOPY, NMAX) + +* Store A in band format for GB tests + DO J = 1, N + DO I = 1, KL+KU+1 + AB( I, J ) = (0.0D+0,0.0D+0) + END DO + END DO + DO J = 1, N + DO I = MAX( 1, J-KU ), MIN( N, J+KL ) + AB( KU+1+I-J, J ) = A( I, J ) + END DO + END DO + +* Copy AB into ABCOPY. + DO J = 1, N + DO I = 1, KL+KU+1 + ABCOPY( I, J ) = (0.0D+0,0.0D+0) + END DO + END DO + CALL ZLACPY('ALL', KL+KU+1, N, AB, LDAB, ABCOPY, LDAB) + +* Call Z**SVXX with default PARAMS and N_ERR_BND = 3. + IF ( LSAMEN( 2, C2, 'SY' ) ) THEN + CALL ZSYSVXX(FACT, UPLO, N, NRHS, ACOPY, LDA, AF, LDA, + $ IPIV, EQUED, S, B, LDA, X, LDA, ORCOND, + $ RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS, + $ PARAMS, WORK, RWORK, INFO) + ELSE IF ( LSAMEN( 2, C2, 'PO' ) ) THEN + CALL ZPOSVXX(FACT, UPLO, N, NRHS, ACOPY, LDA, AF, LDA, + $ EQUED, S, B, LDA, X, LDA, ORCOND, + $ RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS, + $ PARAMS, WORK, RWORK, INFO) + ELSE IF ( LSAMEN( 2, C2, 'HE' ) ) THEN + CALL ZHESVXX(FACT, UPLO, N, NRHS, ACOPY, LDA, AF, LDA, + $ IPIV, EQUED, S, B, LDA, X, LDA, ORCOND, + $ RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS, + $ PARAMS, WORK, RWORK, INFO) + ELSE IF ( LSAMEN( 2, C2, 'GB' ) ) THEN + CALL ZGBSVXX(FACT, TRANS, N, KL, KU, NRHS, ABCOPY, + $ LDAB, AFB, LDAFB, IPIV, EQUED, R, C, B, + $ LDA, X, LDA, ORCOND, RPVGRW, BERR, NERRBND, + $ ERRBND_N, ERRBND_C, NPARAMS, PARAMS, WORK, RWORK, + $ INFO) + ELSE + CALL ZGESVXX(FACT, TRANS, N, NRHS, ACOPY, LDA, AF, LDA, + $ IPIV, EQUED, R, C, B, LDA, X, LDA, ORCOND, + $ RPVGRW, BERR, NERRBND, ERRBND_N, ERRBND_C, NPARAMS, + $ PARAMS, WORK, RWORK, INFO) + END IF + + N_AUX_TESTS = N_AUX_TESTS + 1 + IF (ORCOND .LT. EPS) THEN +! Either factorization failed or the matrix is flagged, and 1 <= +! INFO <= N+1. We don't decide based on rcond anymore. +! IF (INFO .EQ. 0 .OR. INFO .GT. N+1) THEN +! NFAIL = NFAIL + 1 +! WRITE (*, FMT=8000) N, INFO, ORCOND, RCOND +! END IF + ELSE +! Either everything succeeded (INFO == 0) or some solution failed +! to converge (INFO > N+1). + IF (INFO .GT. 0 .AND. INFO .LE. N+1) THEN + NFAIL = NFAIL + 1 + WRITE (*, FMT=8000) C2, N, INFO, ORCOND, RCOND + END IF + END IF + +* Calculating the difference between Z**SVXX's X and the true X. + DO I = 1,N + DO J =1,NRHS + DIFF(I,J) = X(I,J) - INVHILB(I,J) + END DO + END DO + +* Calculating the RCOND + RNORM = 0 + RINORM = 0 + IF ( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'SY' ) .OR. + $ LSAMEN( 2, C2, 'HE' ) ) THEN + DO I = 1, N + SUMR = 0 + SUMRI = 0 + DO J = 1, N + SUMR = SUMR + S(I) * CABS1(A(I,J)) * S(J) + SUMRI = SUMRI + CABS1(INVHILB(I, J)) / (S(J) * S(I)) + END DO + RNORM = MAX(RNORM,SUMR) + RINORM = MAX(RINORM,SUMRI) + END DO + ELSE IF ( LSAMEN( 2, C2, 'GE' ) .OR. LSAMEN( 2, C2, 'GB' ) ) + $ THEN + DO I = 1, N + SUMR = 0 + SUMRI = 0 + DO J = 1, N + SUMR = SUMR + R(I) * CABS1(A(I,J)) * C(J) + SUMRI = SUMRI + CABS1(INVHILB(I, J)) / (R(J) * C(I)) + END DO + RNORM = MAX(RNORM,SUMR) + RINORM = MAX(RINORM,SUMRI) + END DO + END IF + + RNORM = RNORM / CABS1(A(1, 1)) + RCOND = 1.0D+0/(RNORM * RINORM) + +* Calculating the R for normwise rcond. + DO I = 1, N + RINV(I) = 0.0D+0 + END DO + DO J = 1, N + DO I = 1, N + RINV(I) = RINV(I) + CABS1(A(I,J)) + END DO + END DO + +* Calculating the Normwise rcond. + RINORM = 0.0D+0 + DO I = 1, N + SUMRI = 0.0D+0 + DO J = 1, N + SUMRI = SUMRI + CABS1(INVHILB(I,J) * RINV(J)) + END DO + RINORM = MAX(RINORM, SUMRI) + END DO + +! invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm +! by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) + NCOND = CABS1(A(1,1)) / RINORM + + CONDTHRESH = M * EPS + ERRTHRESH = M * EPS + + DO K = 1, NRHS + NORMT = 0.0D+0 + NORMDIF = 0.0D+0 + CWISE_ERR = 0.0D+0 + DO I = 1, N + NORMT = MAX(CABS1(INVHILB(I, K)), NORMT) + NORMDIF = MAX(CABS1(X(I,K) - INVHILB(I,K)), NORMDIF) + IF (INVHILB(I,K) .NE. 0.0D+0) THEN + CWISE_ERR = MAX(CABS1(X(I,K) - INVHILB(I,K)) + $ /CABS1(INVHILB(I,K)), CWISE_ERR) + ELSE IF (X(I, K) .NE. 0.0D+0) THEN + CWISE_ERR = DLAMCH('OVERFLOW') + END IF + END DO + IF (NORMT .NE. 0.0D+0) THEN + NWISE_ERR = NORMDIF / NORMT + ELSE IF (NORMDIF .NE. 0.0D+0) THEN + NWISE_ERR = DLAMCH('OVERFLOW') + ELSE + NWISE_ERR = 0.0D+0 + ENDIF + + DO I = 1, N + RINV(I) = 0.0D+0 + END DO + DO J = 1, N + DO I = 1, N + RINV(I) = RINV(I) + CABS1(A(I, J) * INVHILB(J, K)) + END DO + END DO + RINORM = 0.0D+0 + DO I = 1, N + SUMRI = 0.0D+0 + DO J = 1, N + SUMRI = SUMRI + $ + CABS1(INVHILB(I, J) * RINV(J) / INVHILB(I, K)) + END DO + RINORM = MAX(RINORM, SUMRI) + END DO +! invhilb is the inverse *unscaled* Hilbert matrix, so scale its norm +! by 1/A(1,1) to make the scaling match A (the scaled Hilbert matrix) + CCOND = CABS1(A(1,1))/RINORM + +! Forward error bound tests + NWISE_BND = ERRBND_N(K + (BND_I-1)*NRHS) + CWISE_BND = ERRBND_C(K + (BND_I-1)*NRHS) + NWISE_RCOND = ERRBND_N(K + (COND_I-1)*NRHS) + CWISE_RCOND = ERRBND_C(K + (COND_I-1)*NRHS) +! write (*,*) 'nwise : ', n, k, ncond, nwise_rcond, +! $ condthresh, ncond.ge.condthresh +! write (*,*) 'nwise2: ', k, nwise_bnd, nwise_err, errthresh + IF (NCOND .GE. CONDTHRESH) THEN + NGUAR = 'YES' + IF (NWISE_BND .GT. ERRTHRESH) THEN + TSTRAT(1) = 1/(2.0D+0*EPS) + ELSE + IF (NWISE_BND .NE. 0.0D+0) THEN + TSTRAT(1) = NWISE_ERR / NWISE_BND + ELSE IF (NWISE_ERR .NE. 0.0D+0) THEN + TSTRAT(1) = 1/(16.0*EPS) + ELSE + TSTRAT(1) = 0.0D+0 + END IF + IF (TSTRAT(1) .GT. 1.0D+0) THEN + TSTRAT(1) = 1/(4.0D+0*EPS) + END IF + END IF + ELSE + NGUAR = 'NO' + IF (NWISE_BND .LT. 1.0D+0) THEN + TSTRAT(1) = 1/(8.0D+0*EPS) + ELSE + TSTRAT(1) = 1.0D+0 + END IF + END IF +! write (*,*) 'cwise : ', n, k, ccond, cwise_rcond, +! $ condthresh, ccond.ge.condthresh +! write (*,*) 'cwise2: ', k, cwise_bnd, cwise_err, errthresh + IF (CCOND .GE. CONDTHRESH) THEN + CGUAR = 'YES' + IF (CWISE_BND .GT. ERRTHRESH) THEN + TSTRAT(2) = 1/(2.0D+0*EPS) + ELSE + IF (CWISE_BND .NE. 0.0D+0) THEN + TSTRAT(2) = CWISE_ERR / CWISE_BND + ELSE IF (CWISE_ERR .NE. 0.0D+0) THEN + TSTRAT(2) = 1/(16.0D+0*EPS) + ELSE + TSTRAT(2) = 0.0D+0 + END IF + IF (TSTRAT(2) .GT. 1.0D+0) TSTRAT(2) = 1/(4.0D+0*EPS) + END IF + ELSE + CGUAR = 'NO' + IF (CWISE_BND .LT. 1.0D+0) THEN + TSTRAT(2) = 1/(8.0D+0*EPS) + ELSE + TSTRAT(2) = 1.0D+0 + END IF + END IF + +! Backwards error test + TSTRAT(3) = BERR(K)/EPS + +! Condition number tests + TSTRAT(4) = RCOND / ORCOND + IF (RCOND .GE. CONDTHRESH .AND. TSTRAT(4) .LT. 1.0D+0) + $ TSTRAT(4) = 1.0D+0 / TSTRAT(4) + + TSTRAT(5) = NCOND / NWISE_RCOND + IF (NCOND .GE. CONDTHRESH .AND. TSTRAT(5) .LT. 1.0D+0) + $ TSTRAT(5) = 1.0D+0 / TSTRAT(5) + + TSTRAT(6) = CCOND / NWISE_RCOND + IF (CCOND .GE. CONDTHRESH .AND. TSTRAT(6) .LT. 1.0D+0) + $ TSTRAT(6) = 1.0D+0 / TSTRAT(6) + + DO I = 1, NTESTS + IF (TSTRAT(I) .GT. THRESH) THEN + IF (.NOT.PRINTED_GUIDE) THEN + WRITE(*,*) + WRITE( *, 9996) 1 + WRITE( *, 9995) 2 + WRITE( *, 9994) 3 + WRITE( *, 9993) 4 + WRITE( *, 9992) 5 + WRITE( *, 9991) 6 + WRITE( *, 9990) 7 + WRITE( *, 9989) 8 + WRITE(*,*) + PRINTED_GUIDE = .TRUE. + END IF + WRITE( *, 9999) C2, N, K, NGUAR, CGUAR, I, TSTRAT(I) + NFAIL = NFAIL + 1 + END IF + END DO + END DO + +c$$$ WRITE(*,*) +c$$$ WRITE(*,*) 'Normwise Error Bounds' +c$$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,nwise_i,bnd_i) +c$$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,nwise_i,cond_i) +c$$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,nwise_i,rawbnd_i) +c$$$ WRITE(*,*) +c$$$ WRITE(*,*) 'Componentwise Error Bounds' +c$$$ WRITE(*,*) 'Guaranteed error bound: ',ERRBND(NRHS,cwise_i,bnd_i) +c$$$ WRITE(*,*) 'Reciprocal condition number: ',ERRBND(NRHS,cwise_i,cond_i) +c$$$ WRITE(*,*) 'Raw error estimate: ',ERRBND(NRHS,cwise_i,rawbnd_i) +c$$$ print *, 'Info: ', info +c$$$ WRITE(*,*) +* WRITE(*,*) 'TSTRAT: ',TSTRAT + + END DO + + WRITE(*,*) + IF( NFAIL .GT. 0 ) THEN + WRITE(*,9998) C2, NFAIL, NTESTS*N+N_AUX_TESTS + ELSE + WRITE(*,9997) C2 + END IF + 9999 FORMAT( ' Z', A2, 'SVXX: N =', I2, ', RHS = ', I2, + $ ', NWISE GUAR. = ', A, ', CWISE GUAR. = ', A, + $ ' test(',I1,') =', G12.5 ) + 9998 FORMAT( ' Z', A2, 'SVXX: ', I6, ' out of ', I6, + $ ' tests failed to pass the threshold' ) + 9997 FORMAT( ' Z', A2, 'SVXX passed the tests of error bounds' ) +* Test ratios. + 9996 FORMAT( 3X, I2, ': Normwise guaranteed forward error', / 5X, + $ 'Guaranteed case: if norm ( abs( Xc - Xt )', + $ ' / norm ( Xt ) .LE. ERRBND( *, nwise_i, bnd_i ), then', + $ / 5X, + $ 'ERRBND( *, nwise_i, bnd_i ) .LE. MAX(SQRT(N), 10) * EPS') + 9995 FORMAT( 3X, I2, ': Componentwise guaranteed forward error' ) + 9994 FORMAT( 3X, I2, ': Backwards error' ) + 9993 FORMAT( 3X, I2, ': Reciprocal condition number' ) + 9992 FORMAT( 3X, I2, ': Reciprocal normwise condition number' ) + 9991 FORMAT( 3X, I2, ': Raw normwise error estimate' ) + 9990 FORMAT( 3X, I2, ': Reciprocal componentwise condition number' ) + 9989 FORMAT( 3X, I2, ': Raw componentwise error estimate' ) + + 8000 FORMAT( ' Z', A2, 'SVXX: N =', I2, ', INFO = ', I3, + $ ', ORCOND = ', G12.5, ', real RCOND = ', G12.5 ) + + END diff --git a/TESTING/LIN/zerrab.f b/TESTING/LIN/zerrab.f index 45231416..f5c109cd 100644 --- a/TESTING/LIN/zerrab.f +++ b/TESTING/LIN/zerrab.f @@ -35,6 +35,7 @@ $ W( 2*NMAX ), X( NMAX ) COMPLEX*16 WORK(1) COMPLEX SWORK(1) + DOUBLE PRECISION RWORK(1) * .. * .. External Functions .. * .. @@ -78,19 +79,19 @@ * SRNAMT = 'ZCGESV' INFOT = 1 - CALL ZCGESV(-1,0,A,1,IP,B,1,X,1,WORK,SWORK,ITER,INFO) + CALL ZCGESV(-1,0,A,1,IP,B,1,X,1,WORK,SWORK,RWORK,ITER,INFO) CALL CHKXER( 'ZCGESV', INFOT, NOUT, LERR, OK ) INFOT = 2 - CALL ZCGESV(0,-1,A,1,IP,B,1,X,1,WORK,SWORK,ITER,INFO) + CALL ZCGESV(0,-1,A,1,IP,B,1,X,1,WORK,SWORK,RWORK,ITER,INFO) CALL CHKXER( 'ZCGESV', INFOT, NOUT, LERR, OK ) INFOT = 4 - CALL ZCGESV(2,1,A,1,IP,B,2,X,2,WORK,SWORK,ITER,INFO) + CALL ZCGESV(2,1,A,1,IP,B,2,X,2,WORK,SWORK,RWORK,ITER,INFO) CALL CHKXER( 'ZCGESV', INFOT, NOUT, LERR, OK ) INFOT = 7 - CALL ZCGESV(2,1,A,2,IP,B,1,X,2,WORK,SWORK,ITER,INFO) + CALL ZCGESV(2,1,A,2,IP,B,1,X,2,WORK,SWORK,RWORK,ITER,INFO) CALL CHKXER( 'ZCGESV', INFOT, NOUT, LERR, OK ) INFOT = 9 - CALL ZCGESV(2,1,A,2,IP,B,2,X,1,WORK,SWORK,ITER,INFO) + CALL ZCGESV(2,1,A,2,IP,B,2,X,1,WORK,SWORK,RWORK,ITER,INFO) CALL CHKXER( 'ZCGESV', INFOT, NOUT, LERR, OK ) * * Print a summary line. diff --git a/TESTING/LIN/zerrac.f b/TESTING/LIN/zerrac.f new file mode 100644 index 00000000..e1bf7659 --- /dev/null +++ b/TESTING/LIN/zerrac.f @@ -0,0 +1,113 @@ + SUBROUTINE ZERRAC( NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.1.2) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* May 2007 +* +* .. Scalar Arguments .. + INTEGER NUNIT +* .. +* +* Purpose +* ======= +* +* ZERRPX tests the error exits for ZCPOSV. +* +* Arguments +* ========= +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 4 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, ITER, J +* .. +* .. Local Arrays .. + COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), + $ C( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ), + $ W( 2*NMAX ), X( NMAX ) + DOUBLE PRECISION RWORK( NMAX ) + COMPLEX*16 WORK(NMAX*NMAX) + COMPLEX SWORK(NMAX*NMAX) +* .. +* .. External Subroutines .. + EXTERNAL CHKXER, ZCPOSV +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + 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 + 20 CONTINUE + OK = .TRUE. +* + SRNAMT = 'ZCPOSV' + INFOT = 1 + CALL ZCPOSV('/',0,0,A,1,B,1,X,1,WORK,SWORK,RWORK,ITER,INFO) + CALL CHKXER( 'ZCPOSV', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZCPOSV('U',-1,0,A,1,B,1,X,1,WORK,SWORK,RWORK,ITER,INFO) + CALL CHKXER( 'ZCPOSV', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZCPOSV('U',0,-1,A,1,B,1,X,1,WORK,SWORK,RWORK,ITER,INFO) + CALL CHKXER( 'ZCPOSV', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZCPOSV('U',2,1,A,1,B,2,X,2,WORK,SWORK,RWORK,ITER,INFO) + CALL CHKXER( 'ZCPOSV', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZCPOSV('U',2,1,A,2,B,1,X,2,WORK,SWORK,RWORK,ITER,INFO) + CALL CHKXER( 'ZCPOSV', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZCPOSV('U',2,1,A,2,B,2,X,1,WORK,SWORK,RWORK,ITER,INFO) + CALL CHKXER( 'ZCPOSV', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + IF( OK ) THEN + WRITE( NOUT, FMT = 9999 )'ZCPOSV' + ELSE + WRITE( NOUT, FMT = 9998 )'ZCPOSV' + END IF +* + 9999 FORMAT( 1X, A6, ' drivers passed the tests of the error exits' ) + 9998 FORMAT( ' *** ', A6, ' drivers failed the tests of the error ', + $ 'exits ***' ) +* + RETURN +* +* End of ZERRAC +* + END diff --git a/TESTING/LIN/zerrge.f b/TESTING/LIN/zerrge.f index 09ad1d83..f3dd60a2 100644 --- a/TESTING/LIN/zerrge.f +++ b/TESTING/LIN/zerrge.f @@ -52,7 +52,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zerrgex.f b/TESTING/LIN/zerrgex.f new file mode 100644 index 00000000..d0e87ee9 --- /dev/null +++ b/TESTING/LIN/zerrgex.f @@ -0,0 +1,526 @@ + SUBROUTINE ZERRGE( PATH, NUNIT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* Purpose +* ======= +* +* ZERRGE tests the error exits for the COMPLEX*16 routines +* for general matrices. +* +* Note that this file is used only when the XBLAS are available, +* otherwise zerrge.f defines this subroutine. +* +* Arguments +* ========= +* +* PATH (input) CHARACTER*3 +* The LAPACK path name for the routines to be tested. +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 4 ) +* .. +* .. Local Scalars .. + CHARACTER EQ + CHARACTER*2 C2 + INTEGER I, INFO, J, n_err_bnds, nparams + DOUBLE PRECISION ANRM, CCOND, RCOND, berr +* .. +* .. Local Arrays .. + INTEGER IP( NMAX ) + DOUBLE PRECISION R( NMAX ), R1( NMAX ), R2( NMAX ), CS( NMAX ), + $ RS( NMAX ) + COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), + $ W( 2*NMAX ), X( NMAX ), err_bnds_n( NMAX, 3 ), + $ err_bnds_c( NMAX, 3 ), params +* .. +* .. External Functions .. + LOGICAL LSAMEN + EXTERNAL LSAMEN +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, ZGBCON, ZGBEQU, ZGBRFS, ZGBTF2, + $ ZGBTRF, ZGBTRS, ZGECON, ZGEEQU, ZGERFS, ZGETF2, + $ ZGETRF, ZGETRI, ZGETRS, ZGEEQUB, ZGERFSX, + $ ZGBEQUB, ZGBRFSX +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) + C2 = PATH( 2: 3 ) +* +* Set the variables to innocuous values. +* + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + A( I, J ) = DCMPLX( 1.D0 / DBLE( I+J ), + $ -1.D0 / DBLE( I+J ) ) + AF( I, J ) = DCMPLX( 1.D0 / DBLE( 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 + CS( J ) = 0.D0 + RS( J ) = 0.D0 + IP( J ) = J + 20 CONTINUE + OK = .TRUE. +* +* Test error exits of the routines that use the LU decomposition +* of a general matrix. +* + IF( LSAMEN( 2, C2, 'GE' ) ) THEN +* +* ZGETRF +* + SRNAMT = 'ZGETRF' + INFOT = 1 + CALL ZGETRF( -1, 0, A, 1, IP, INFO ) + CALL CHKXER( 'ZGETRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGETRF( 0, -1, A, 1, IP, INFO ) + CALL CHKXER( 'ZGETRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGETRF( 2, 1, A, 1, IP, INFO ) + CALL CHKXER( 'ZGETRF', INFOT, NOUT, LERR, OK ) +* +* ZGETF2 +* + SRNAMT = 'ZGETF2' + INFOT = 1 + CALL ZGETF2( -1, 0, A, 1, IP, INFO ) + CALL CHKXER( 'ZGETF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGETF2( 0, -1, A, 1, IP, INFO ) + CALL CHKXER( 'ZGETF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGETF2( 2, 1, A, 1, IP, INFO ) + CALL CHKXER( 'ZGETF2', INFOT, NOUT, LERR, OK ) +* +* ZGETRI +* + SRNAMT = 'ZGETRI' + INFOT = 1 + CALL ZGETRI( -1, A, 1, IP, W, 1, INFO ) + CALL CHKXER( 'ZGETRI', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGETRI( 2, A, 1, IP, W, 2, INFO ) + CALL CHKXER( 'ZGETRI', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZGETRI( 2, A, 2, IP, W, 1, INFO ) + CALL CHKXER( 'ZGETRI', INFOT, NOUT, LERR, OK ) +* +* ZGETRS +* + SRNAMT = 'ZGETRS' + INFOT = 1 + CALL ZGETRS( '/', 0, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZGETRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGETRS( 'N', -1, 0, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZGETRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGETRS( 'N', 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZGETRS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGETRS( 'N', 2, 1, A, 1, IP, B, 2, INFO ) + CALL CHKXER( 'ZGETRS', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGETRS( 'N', 2, 1, A, 2, IP, B, 1, INFO ) + CALL CHKXER( 'ZGETRS', INFOT, NOUT, LERR, OK ) +* +* ZGERFS +* + SRNAMT = 'ZGERFS' + INFOT = 1 + CALL ZGERFS( '/', 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'ZGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGERFS( 'N', -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, + $ W, R, INFO ) + CALL CHKXER( 'ZGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGERFS( 'N', 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, R2, + $ W, R, INFO ) + CALL CHKXER( 'ZGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGERFS( 'N', 2, 1, A, 1, AF, 2, IP, B, 2, X, 2, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'ZGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZGERFS( 'N', 2, 1, A, 2, AF, 1, IP, B, 2, X, 2, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'ZGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZGERFS( 'N', 2, 1, A, 2, AF, 2, IP, B, 1, X, 2, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'ZGERFS', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL ZGERFS( 'N', 2, 1, A, 2, AF, 2, IP, B, 2, X, 1, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'ZGERFS', INFOT, NOUT, LERR, OK ) +* +* ZGERFSX +* + N_ERR_BNDS = 3 + NPARAMS = 0 + SRNAMT = 'ZGERFSX' + INFOT = 1 + CALL ZGERFSX( '/', EQ, 0, 0, A, 1, AF, 1, IP, RS, CS, B, 1, X, + $ 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 2 + EQ = '/' + CALL ZGERFSX( 'N', EQ, 2, 1, A, 1, AF, 2, IP, RS, CS, B, 2, X, + $ 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 3 + EQ = 'R' + CALL ZGERFSX( 'N', EQ, -1, 0, A, 1, AF, 1, IP, RS, CS, B, 1, X, + $ 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGERFSX( 'N', EQ, 0, -1, A, 1, AF, 1, IP, RS, CS, B, 1, X, + $ 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZGERFSX( 'N', EQ, 2, 1, A, 1, AF, 2, IP, RS, CS, B, 2, X, + $ 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGERFSX( 'N', EQ, 2, 1, A, 2, AF, 1, IP, RS, CS, B, 2, X, + $ 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 13 + EQ = 'C' + CALL ZGERFSX( 'N', EQ, 2, 1, A, 2, AF, 2, IP, RS, CS, B, 1, X, + $ 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGERFSX', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL ZGERFSX( 'N', EQ, 2, 1, A, 2, AF, 2, IP, RS, CS, B, 2, X, + $ 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, ERR_BNDS_C, + $ NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGERFSX', INFOT, NOUT, LERR, OK ) +* +* ZGECON +* + SRNAMT = 'ZGECON' + INFOT = 1 + CALL ZGECON( '/', 0, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZGECON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGECON( '1', -1, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZGECON', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGECON( '1', 2, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZGECON', INFOT, NOUT, LERR, OK ) +* +* ZGEEQU +* + SRNAMT = 'ZGEEQU' + INFOT = 1 + CALL ZGEEQU( -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'ZGEEQU', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGEEQU( 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'ZGEEQU', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEEQU( 2, 2, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'ZGEEQU', INFOT, NOUT, LERR, OK ) +* +* ZGEEQUB +* + SRNAMT = 'ZGEEQUB' + INFOT = 1 + CALL ZGEEQUB( -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'ZGEEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGEEQUB( 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'ZGEEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGEEQUB( 2, 2, A, 1, R1, R2, RCOND, CCOND, ANRM, INFO ) + CALL CHKXER( 'ZGEEQUB', INFOT, NOUT, LERR, OK ) +* +* Test error exits of the routines that use the LU decomposition +* of a general band matrix. +* + ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN +* +* ZGBTRF +* + SRNAMT = 'ZGBTRF' + INFOT = 1 + CALL ZGBTRF( -1, 0, 0, 0, A, 1, IP, INFO ) + CALL CHKXER( 'ZGBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGBTRF( 0, -1, 0, 0, A, 1, IP, INFO ) + CALL CHKXER( 'ZGBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGBTRF( 1, 1, -1, 0, A, 1, IP, INFO ) + CALL CHKXER( 'ZGBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGBTRF( 1, 1, 0, -1, A, 1, IP, INFO ) + CALL CHKXER( 'ZGBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZGBTRF( 2, 2, 1, 1, A, 3, IP, INFO ) + CALL CHKXER( 'ZGBTRF', INFOT, NOUT, LERR, OK ) +* +* ZGBTF2 +* + SRNAMT = 'ZGBTF2' + INFOT = 1 + CALL ZGBTF2( -1, 0, 0, 0, A, 1, IP, INFO ) + CALL CHKXER( 'ZGBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGBTF2( 0, -1, 0, 0, A, 1, IP, INFO ) + CALL CHKXER( 'ZGBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGBTF2( 1, 1, -1, 0, A, 1, IP, INFO ) + CALL CHKXER( 'ZGBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGBTF2( 1, 1, 0, -1, A, 1, IP, INFO ) + CALL CHKXER( 'ZGBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZGBTF2( 2, 2, 1, 1, A, 3, IP, INFO ) + CALL CHKXER( 'ZGBTF2', INFOT, NOUT, LERR, OK ) +* +* ZGBTRS +* + SRNAMT = 'ZGBTRS' + INFOT = 1 + CALL ZGBTRS( '/', 0, 0, 0, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGBTRS( 'N', -1, 0, 0, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGBTRS( 'N', 1, -1, 0, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGBTRS( 'N', 1, 0, -1, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGBTRS( 'N', 1, 0, 0, -1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZGBTRS( 'N', 2, 1, 1, 1, A, 3, IP, B, 2, INFO ) + CALL CHKXER( 'ZGBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZGBTRS( 'N', 2, 0, 0, 1, A, 1, IP, B, 1, INFO ) + CALL CHKXER( 'ZGBTRS', INFOT, NOUT, LERR, OK ) +* +* ZGBRFS +* + SRNAMT = 'ZGBRFS' + INFOT = 1 + CALL ZGBRFS( '/', 0, 0, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'ZGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGBRFS( 'N', -1, 0, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'ZGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGBRFS( 'N', 1, -1, 0, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'ZGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGBRFS( 'N', 1, 0, -1, 0, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'ZGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZGBRFS( 'N', 1, 0, 0, -1, A, 1, AF, 1, IP, B, 1, X, 1, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'ZGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZGBRFS( 'N', 2, 1, 1, 1, A, 2, AF, 4, IP, B, 2, X, 2, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'ZGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZGBRFS( 'N', 2, 1, 1, 1, A, 3, AF, 3, IP, B, 2, X, 2, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'ZGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL ZGBRFS( 'N', 2, 0, 0, 1, A, 1, AF, 1, IP, B, 1, X, 2, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'ZGBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 14 + CALL ZGBRFS( 'N', 2, 0, 0, 1, A, 1, AF, 1, IP, B, 2, X, 1, R1, + $ R2, W, R, INFO ) + CALL CHKXER( 'ZGBRFS', INFOT, NOUT, LERR, OK ) +* +* ZGBRFSX +* + N_ERR_BNDS = 3 + NPARAMS = 0 + SRNAMT = 'ZGBRFSX' + INFOT = 1 + CALL ZGBRFSX( '/', EQ, 0, 0, 0, 0, A, 1, AF, 1, IP, RS, CS, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 2 + EQ = '/' + CALL ZGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 1, AF, 2, IP, RS, CS, B, + $ 2, X, 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 3 + EQ = 'R' + CALL ZGBRFSX( 'N', EQ, -1, 1, 1, 0, A, 1, AF, 1, IP, RS, CS, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 4 + EQ = 'R' + CALL ZGBRFSX( 'N', EQ, 2, -1, 1, 1, A, 3, AF, 4, IP, RS, CS, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 5 + EQ = 'R' + CALL ZGBRFSX( 'N', EQ, 2, 1, -1, 1, A, 3, AF, 4, IP, RS, CS, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZGBRFSX( 'N', EQ, 0, 0, 0, -1, A, 1, AF, 1, IP, RS, CS, B, + $ 1, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 1, AF, 2, IP, RS, CS, B, + $ 2, X, 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 3, AF, 3, IP, RS, CS, B, + $ 2, X, 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 13 + EQ = 'C' + CALL ZGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 3, AF, 5, IP, RS, CS, B, + $ 1, X, 2, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGBRFSX', INFOT, NOUT, LERR, OK ) + INFOT = 15 + CALL ZGBRFSX( 'N', EQ, 2, 1, 1, 1, A, 3, AF, 5, IP, RS, CS, B, + $ 2, X, 1, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_N, + $ ERR_BNDS_C, NPARAMS, PARAMS, W, R, INFO ) + CALL CHKXER( 'ZGBRFSX', INFOT, NOUT, LERR, OK ) +* +* ZGBCON +* + SRNAMT = 'ZGBCON' + INFOT = 1 + CALL ZGBCON( '/', 0, 0, 0, A, 1, IP, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZGBCON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGBCON( '1', -1, 0, 0, A, 1, IP, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZGBCON', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGBCON( '1', 1, -1, 0, A, 1, IP, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZGBCON', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGBCON( '1', 1, 0, -1, A, 1, IP, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZGBCON', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZGBCON( '1', 2, 1, 1, A, 3, IP, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZGBCON', INFOT, NOUT, LERR, OK ) +* +* ZGBEQU +* + SRNAMT = 'ZGBEQU' + INFOT = 1 + CALL ZGBEQU( -1, 0, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'ZGBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGBEQU( 0, -1, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'ZGBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGBEQU( 1, 1, -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'ZGBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGBEQU( 1, 1, 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'ZGBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZGBEQU( 2, 2, 1, 1, A, 2, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'ZGBEQU', INFOT, NOUT, LERR, OK ) +* +* ZGBEQUB +* + SRNAMT = 'ZGBEQUB' + INFOT = 1 + CALL ZGBEQUB( -1, 0, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'ZGBEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZGBEQUB( 0, -1, 0, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'ZGBEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZGBEQUB( 1, 1, -1, 0, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'ZGBEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZGBEQUB( 1, 1, 0, -1, A, 1, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'ZGBEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZGBEQUB( 2, 2, 1, 1, A, 2, R1, R2, RCOND, CCOND, ANRM, + $ INFO ) + CALL CHKXER( 'ZGBEQUB', INFOT, NOUT, LERR, OK ) + END IF +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of ZERRGE +* + END diff --git a/TESTING/LIN/zerrgt.f b/TESTING/LIN/zerrgt.f index babce1e5..28efc43f 100644 --- a/TESTING/LIN/zerrgt.f +++ b/TESTING/LIN/zerrgt.f @@ -53,7 +53,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zerrhe.f b/TESTING/LIN/zerrhe.f index 57c3066d..60980a90 100644 --- a/TESTING/LIN/zerrhe.f +++ b/TESTING/LIN/zerrhe.f @@ -53,7 +53,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zerrlq.f b/TESTING/LIN/zerrlq.f index ecb9624d..7fc01b4f 100644 --- a/TESTING/LIN/zerrlq.f +++ b/TESTING/LIN/zerrlq.f @@ -43,7 +43,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zerrls.f b/TESTING/LIN/zerrls.f index ff30bbfc..252edece 100644 --- a/TESTING/LIN/zerrls.f +++ b/TESTING/LIN/zerrls.f @@ -50,7 +50,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zerrpo.f b/TESTING/LIN/zerrpo.f index 388f8f0e..b2e6dd38 100644 --- a/TESTING/LIN/zerrpo.f +++ b/TESTING/LIN/zerrpo.f @@ -52,7 +52,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zerrpox.f b/TESTING/LIN/zerrpox.f new file mode 100644 index 00000000..5d5d16e2 --- /dev/null +++ b/TESTING/LIN/zerrpox.f @@ -0,0 +1,495 @@ + SUBROUTINE ZERRPO( PATH, NUNIT ) +* +* -- LAPACK test routine (version 3.1) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2006 +* +* .. Scalar Arguments .. + CHARACTER*3 PATH + INTEGER NUNIT +* .. +* +* Purpose +* ======= +* +* ZERRPO tests the error exits for the COMPLEX*16 routines +* for Hermitian positive definite matrices. +* +* Arguments +* ========= +* +* PATH (input) CHARACTER*3 +* The LAPACK path name for the routines to be tested. +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 4 ) +* .. +* .. Local Scalars .. + CHARACTER EQ + CHARACTER*2 C2 + INTEGER I, INFO, J, N_ERR_BNDS, NPARAMS + DOUBLE PRECISION ANRM, RCOND, BERR +* .. +* .. Local Arrays .. + DOUBLE PRECISION S( NMAX ), R( NMAX ), R1( NMAX ), R2( NMAX ), + $ ERR_BNDS_N( NMAX, 3 ), ERR_BNDS_C( NMAX, 3 ), + $ PARAMS + COMPLEX*16 A( NMAX, NMAX ), AF( NMAX, NMAX ), B( NMAX ), + $ W( 2*NMAX ), X( NMAX ) +* .. +* .. External Functions .. + LOGICAL LSAMEN + EXTERNAL LSAMEN +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, ZPBCON, ZPBEQU, ZPBRFS, ZPBTF2, + $ ZPBTRF, ZPBTRS, ZPOCON, ZPOEQU, ZPORFS, ZPOTF2, + $ ZPOTRF, ZPOTRI, ZPOTRS, ZPPCON, ZPPEQU, ZPPRFS, + $ ZPPTRF, ZPPTRI, ZPPTRS, ZPOEQUB, ZPORFSX +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) + C2 = PATH( 2: 3 ) +* +* Set the variables to innocuous values. +* + DO 20 J = 1, NMAX + DO 10 I = 1, NMAX + A( I, J ) = DCMPLX( 1.D0 / DBLE( I+J ), + $ -1.D0 / DBLE( I+J ) ) + AF( I, J ) = DCMPLX( 1.D0 / DBLE( 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 + S( J ) = 0.D0 + 20 CONTINUE + ANRM = 1.D0 + OK = .TRUE. +* +* Test error exits of the routines that use the Cholesky +* decomposition of a Hermitian positive definite matrix. +* + IF( LSAMEN( 2, C2, 'PO' ) ) THEN +* +* ZPOTRF +* + SRNAMT = 'ZPOTRF' + INFOT = 1 + CALL ZPOTRF( '/', 0, A, 1, INFO ) + CALL CHKXER( 'ZPOTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPOTRF( 'U', -1, A, 1, INFO ) + CALL CHKXER( 'ZPOTRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZPOTRF( 'U', 2, A, 1, INFO ) + CALL CHKXER( 'ZPOTRF', INFOT, NOUT, LERR, OK ) +* +* ZPOTF2 +* + SRNAMT = 'ZPOTF2' + INFOT = 1 + CALL ZPOTF2( '/', 0, A, 1, INFO ) + CALL CHKXER( 'ZPOTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPOTF2( 'U', -1, A, 1, INFO ) + CALL CHKXER( 'ZPOTF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZPOTF2( 'U', 2, A, 1, INFO ) + CALL CHKXER( 'ZPOTF2', INFOT, NOUT, LERR, OK ) +* +* ZPOTRI +* + SRNAMT = 'ZPOTRI' + INFOT = 1 + CALL ZPOTRI( '/', 0, A, 1, INFO ) + CALL CHKXER( 'ZPOTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPOTRI( 'U', -1, A, 1, INFO ) + CALL CHKXER( 'ZPOTRI', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZPOTRI( 'U', 2, A, 1, INFO ) + CALL CHKXER( 'ZPOTRI', INFOT, NOUT, LERR, OK ) +* +* ZPOTRS +* + SRNAMT = 'ZPOTRS' + INFOT = 1 + CALL ZPOTRS( '/', 0, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'ZPOTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPOTRS( 'U', -1, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'ZPOTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZPOTRS( 'U', 0, -1, A, 1, B, 1, INFO ) + CALL CHKXER( 'ZPOTRS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZPOTRS( 'U', 2, 1, A, 1, B, 2, INFO ) + CALL CHKXER( 'ZPOTRS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZPOTRS( 'U', 2, 1, A, 2, B, 1, INFO ) + CALL CHKXER( 'ZPOTRS', INFOT, NOUT, LERR, OK ) +* +* ZPORFS +* + SRNAMT = 'ZPORFS' + INFOT = 1 + CALL ZPORFS( '/', 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'ZPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPORFS( 'U', -1, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'ZPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZPORFS( 'U', 0, -1, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'ZPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZPORFS( 'U', 2, 1, A, 1, AF, 2, B, 2, X, 2, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'ZPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZPORFS( 'U', 2, 1, A, 2, AF, 1, B, 2, X, 2, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'ZPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZPORFS( 'U', 2, 1, A, 2, AF, 2, B, 1, X, 2, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'ZPORFS', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZPORFS( 'U', 2, 1, A, 2, AF, 2, B, 2, X, 1, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'ZPORFS', INFOT, NOUT, LERR, OK ) +* +* ZPORFSX +* + n_err_bnds = 3 + nparams = 0 + SRNAMT = 'ZPORFSX' + INFOT = 1 + CALL ZPORFSX( '/', EQ, 0, 0, A, 1, AF, 1, S, B, 1, X, 1, + $ RCOND, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams, + $ params, W, R, INFO ) + CALL CHKXER( 'ZPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPORFSX( 'U', EQ, -1, 0, A, 1, AF, 1, S, B, 1, X, 1, + $ RCOND, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams, + $ params, W, R, INFO ) + CALL CHKXER( 'ZPORFSX', INFOT, NOUT, LERR, OK ) + EQ = 'N' + INFOT = 3 + CALL ZPORFSX( 'U', EQ, -1, 0, A, 1, AF, 1, S, B, 1, X, 1, + $ RCOND, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams, + $ params, W, R, INFO ) + CALL CHKXER( 'ZPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZPORFSX( 'U', EQ, 0, -1, A, 1, AF, 1, S, B, 1, X, 1, + $ RCOND, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams, + $ params, W, R, INFO ) + CALL CHKXER( 'ZPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZPORFSX( 'U', EQ, 2, 1, A, 1, AF, 2, S, B, 2, X, 2, + $ RCOND, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams, + $ params, W, R, INFO ) + CALL CHKXER( 'ZPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZPORFSX( 'U', EQ, 2, 1, A, 2, AF, 1, S, B, 2, X, 2, + $ RCOND, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams, + $ params, W, R, INFO ) + CALL CHKXER( 'ZPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZPORFSX( 'U', EQ, 2, 1, A, 2, AF, 2, S, B, 1, X, 2, + $ RCOND, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams, + $ params, W, R, INFO ) + CALL CHKXER( 'ZPORFSX', INFOT, NOUT, LERR, OK ) + INFOT = 13 + CALL ZPORFSX( 'U', EQ, 2, 1, A, 2, AF, 2, S, B, 2, X, 1, + $ RCOND, berr, n_err_bnds, err_bnds_n, err_bnds_c, nparams, + $ params, W, R, INFO ) + CALL CHKXER( 'ZPORFSX', INFOT, NOUT, LERR, OK ) +* +* ZPOCON +* + SRNAMT = 'ZPOCON' + INFOT = 1 + CALL ZPOCON( '/', 0, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZPOCON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPOCON( 'U', -1, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZPOCON', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZPOCON( 'U', 2, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZPOCON', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZPOCON( 'U', 1, A, 1, -ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZPOCON', INFOT, NOUT, LERR, OK ) +* +* ZPOEQU +* + SRNAMT = 'ZPOEQU' + INFOT = 1 + CALL ZPOEQU( -1, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'ZPOEQU', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZPOEQU( 2, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'ZPOEQU', INFOT, NOUT, LERR, OK ) +* +* ZPOEQUB +* + SRNAMT = 'ZPOEQUB' + INFOT = 1 + CALL ZPOEQUB( -1, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'ZPOEQUB', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZPOEQUB( 2, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'ZPOEQUB', INFOT, NOUT, LERR, OK ) +* +* Test error exits of the routines that use the Cholesky +* decomposition of a Hermitian positive definite packed matrix. +* + ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN +* +* ZPPTRF +* + SRNAMT = 'ZPPTRF' + INFOT = 1 + CALL ZPPTRF( '/', 0, A, INFO ) + CALL CHKXER( 'ZPPTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPPTRF( 'U', -1, A, INFO ) + CALL CHKXER( 'ZPPTRF', INFOT, NOUT, LERR, OK ) +* +* ZPPTRI +* + SRNAMT = 'ZPPTRI' + INFOT = 1 + CALL ZPPTRI( '/', 0, A, INFO ) + CALL CHKXER( 'ZPPTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPPTRI( 'U', -1, A, INFO ) + CALL CHKXER( 'ZPPTRI', INFOT, NOUT, LERR, OK ) +* +* ZPPTRS +* + SRNAMT = 'ZPPTRS' + INFOT = 1 + CALL ZPPTRS( '/', 0, 0, A, B, 1, INFO ) + CALL CHKXER( 'ZPPTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPPTRS( 'U', -1, 0, A, B, 1, INFO ) + CALL CHKXER( 'ZPPTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZPPTRS( 'U', 0, -1, A, B, 1, INFO ) + CALL CHKXER( 'ZPPTRS', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZPPTRS( 'U', 2, 1, A, B, 1, INFO ) + CALL CHKXER( 'ZPPTRS', INFOT, NOUT, LERR, OK ) +* +* ZPPRFS +* + SRNAMT = 'ZPPRFS' + INFOT = 1 + CALL ZPPRFS( '/', 0, 0, A, AF, B, 1, X, 1, R1, R2, W, R, INFO ) + CALL CHKXER( 'ZPPRFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPPRFS( 'U', -1, 0, A, AF, B, 1, X, 1, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'ZPPRFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZPPRFS( 'U', 0, -1, A, AF, B, 1, X, 1, R1, R2, W, R, + $ INFO ) + CALL CHKXER( 'ZPPRFS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZPPRFS( 'U', 2, 1, A, AF, B, 1, X, 2, R1, R2, W, R, INFO ) + CALL CHKXER( 'ZPPRFS', INFOT, NOUT, LERR, OK ) + INFOT = 9 + CALL ZPPRFS( 'U', 2, 1, A, AF, B, 2, X, 1, R1, R2, W, R, INFO ) + CALL CHKXER( 'ZPPRFS', INFOT, NOUT, LERR, OK ) +* +* ZPPCON +* + SRNAMT = 'ZPPCON' + INFOT = 1 + CALL ZPPCON( '/', 0, A, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZPPCON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPPCON( 'U', -1, A, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZPPCON', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZPPCON( 'U', 1, A, -ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZPPCON', INFOT, NOUT, LERR, OK ) +* +* ZPPEQU +* + SRNAMT = 'ZPPEQU' + INFOT = 1 + CALL ZPPEQU( '/', 0, A, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'ZPPEQU', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPPEQU( 'U', -1, A, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'ZPPEQU', INFOT, NOUT, LERR, OK ) +* +* Test error exits of the routines that use the Cholesky +* decomposition of a Hermitian positive definite band matrix. +* + ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN +* +* ZPBTRF +* + SRNAMT = 'ZPBTRF' + INFOT = 1 + CALL ZPBTRF( '/', 0, 0, A, 1, INFO ) + CALL CHKXER( 'ZPBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPBTRF( 'U', -1, 0, A, 1, INFO ) + CALL CHKXER( 'ZPBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZPBTRF( 'U', 1, -1, A, 1, INFO ) + CALL CHKXER( 'ZPBTRF', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZPBTRF( 'U', 2, 1, A, 1, INFO ) + CALL CHKXER( 'ZPBTRF', INFOT, NOUT, LERR, OK ) +* +* ZPBTF2 +* + SRNAMT = 'ZPBTF2' + INFOT = 1 + CALL ZPBTF2( '/', 0, 0, A, 1, INFO ) + CALL CHKXER( 'ZPBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPBTF2( 'U', -1, 0, A, 1, INFO ) + CALL CHKXER( 'ZPBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZPBTF2( 'U', 1, -1, A, 1, INFO ) + CALL CHKXER( 'ZPBTF2', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZPBTF2( 'U', 2, 1, A, 1, INFO ) + CALL CHKXER( 'ZPBTF2', INFOT, NOUT, LERR, OK ) +* +* ZPBTRS +* + SRNAMT = 'ZPBTRS' + INFOT = 1 + CALL ZPBTRS( '/', 0, 0, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'ZPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPBTRS( 'U', -1, 0, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'ZPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZPBTRS( 'U', 1, -1, 0, A, 1, B, 1, INFO ) + CALL CHKXER( 'ZPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZPBTRS( 'U', 0, 0, -1, A, 1, B, 1, INFO ) + CALL CHKXER( 'ZPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZPBTRS( 'U', 2, 1, 1, A, 1, B, 1, INFO ) + CALL CHKXER( 'ZPBTRS', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZPBTRS( 'U', 2, 0, 1, A, 1, B, 1, INFO ) + CALL CHKXER( 'ZPBTRS', INFOT, NOUT, LERR, OK ) +* +* ZPBRFS +* + SRNAMT = 'ZPBRFS' + INFOT = 1 + CALL ZPBRFS( '/', 0, 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'ZPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPBRFS( 'U', -1, 0, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'ZPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZPBRFS( 'U', 1, -1, 0, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'ZPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZPBRFS( 'U', 0, 0, -1, A, 1, AF, 1, B, 1, X, 1, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'ZPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZPBRFS( 'U', 2, 1, 1, A, 1, AF, 2, B, 2, X, 2, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'ZPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZPBRFS( 'U', 2, 1, 1, A, 2, AF, 1, B, 2, X, 2, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'ZPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 10 + CALL ZPBRFS( 'U', 2, 0, 1, A, 1, AF, 1, B, 1, X, 2, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'ZPBRFS', INFOT, NOUT, LERR, OK ) + INFOT = 12 + CALL ZPBRFS( 'U', 2, 0, 1, A, 1, AF, 1, B, 2, X, 1, R1, R2, W, + $ R, INFO ) + CALL CHKXER( 'ZPBRFS', INFOT, NOUT, LERR, OK ) +* +* ZPBCON +* + SRNAMT = 'ZPBCON' + INFOT = 1 + CALL ZPBCON( '/', 0, 0, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZPBCON', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPBCON( 'U', -1, 0, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZPBCON', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZPBCON( 'U', 1, -1, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZPBCON', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZPBCON( 'U', 2, 1, A, 1, ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZPBCON', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZPBCON( 'U', 1, 0, A, 1, -ANRM, RCOND, W, R, INFO ) + CALL CHKXER( 'ZPBCON', INFOT, NOUT, LERR, OK ) +* +* ZPBEQU +* + SRNAMT = 'ZPBEQU' + INFOT = 1 + CALL ZPBEQU( '/', 0, 0, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'ZPBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPBEQU( 'U', -1, 0, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'ZPBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZPBEQU( 'U', 1, -1, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'ZPBEQU', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZPBEQU( 'U', 2, 1, A, 1, R1, RCOND, ANRM, INFO ) + CALL CHKXER( 'ZPBEQU', INFOT, NOUT, LERR, OK ) + END IF +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of ZERRPO +* + END diff --git a/TESTING/LIN/zerrps.f b/TESTING/LIN/zerrps.f new file mode 100644 index 00000000..60c6ac5e --- /dev/null +++ b/TESTING/LIN/zerrps.f @@ -0,0 +1,114 @@ + SUBROUTINE ZERRPS( PATH, NUNIT ) +* +* -- LAPACK test routine (version 3.1) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + INTEGER NUNIT + CHARACTER*3 PATH +* .. +* +* Purpose +* ======= +* +* ZERRPS tests the error exits for the COMPLEX routines +* for ZPSTRF. +* +* Arguments +* ========= +* +* PATH (input) CHARACTER*3 +* The LAPACK path name for the routines to be tested. +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 4 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J +* .. +* .. Local Arrays .. + COMPLEX*16 A( NMAX, NMAX ) + DOUBLE PRECISION RWORK( 2*NMAX ) + INTEGER PIV( NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, ZPSTF2, ZPSTRF +* .. +* .. Scalars in Common .. + INTEGER INFOT, NOUT + LOGICAL LERR, OK + CHARACTER*32 SRNAMT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO 110 J = 1, NMAX + DO 100 I = 1, NMAX + A( I, J ) = 1.D0 / DBLE( I+J ) +* + 100 CONTINUE + PIV( J ) = J + RWORK( J ) = 0.D0 + RWORK( NMAX+J ) = 0.D0 +* + 110 CONTINUE + OK = .TRUE. +* +* +* Test error exits of the routines that use the Cholesky +* decomposition of an Hermitian positive semidefinite matrix. +* +* ZPSTRF +* + SRNAMT = 'ZPSTRF' + INFOT = 1 + CALL ZPSTRF( '/', 0, A, 1, PIV, 1, -1.D0, RWORK, INFO ) + CALL CHKXER( 'ZPSTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPSTRF( 'U', -1, A, 1, PIV, 1, -1.D0, RWORK, INFO ) + CALL CHKXER( 'ZPSTRF', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZPSTRF( 'U', 2, A, 1, PIV, 1, -1.D0, RWORK, INFO ) + CALL CHKXER( 'ZPSTRF', INFOT, NOUT, LERR, OK ) +* +* ZPSTF2 +* + SRNAMT = 'ZPSTF2' + INFOT = 1 + CALL ZPSTF2( '/', 0, A, 1, PIV, 1, -1.D0, RWORK, INFO ) + CALL CHKXER( 'ZPSTF2', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPSTF2( 'U', -1, A, 1, PIV, 1, -1.D0, RWORK, INFO ) + CALL CHKXER( 'ZPSTF2', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZPSTF2( 'U', 2, A, 1, PIV, 1, -1.D0, RWORK, INFO ) + CALL CHKXER( 'ZPSTF2', INFOT, NOUT, LERR, OK ) +* +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of ZERRPS +* + END diff --git a/TESTING/LIN/zerrql.f b/TESTING/LIN/zerrql.f index 729da5ac..bc6c34de 100644 --- a/TESTING/LIN/zerrql.f +++ b/TESTING/LIN/zerrql.f @@ -43,7 +43,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zerrqp.f b/TESTING/LIN/zerrqp.f index 497aa39e..d839a5bc 100644 --- a/TESTING/LIN/zerrqp.f +++ b/TESTING/LIN/zerrqp.f @@ -48,7 +48,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zerrqr.f b/TESTING/LIN/zerrqr.f index b07fcfea..1e938955 100644 --- a/TESTING/LIN/zerrqr.f +++ b/TESTING/LIN/zerrqr.f @@ -43,7 +43,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zerrrfp.f b/TESTING/LIN/zerrrfp.f new file mode 100644 index 00000000..96b02dbd --- /dev/null +++ b/TESTING/LIN/zerrrfp.f @@ -0,0 +1,251 @@ + SUBROUTINE ZERRRFP( NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine (version 3.2.0) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* November 2008 +* +* .. Scalar Arguments .. + INTEGER NUNIT +* .. +* +* Purpose +* ======= +* +* ZERRRFP tests the error exits for the COMPLEX*16 driver routines +* for solving linear systems of equations. +* +* ZDRVRFP tests the COMPLEX*16 LAPACK RFP routines: +* ZTFSM, ZTFTRI, ZHFRK, ZTFTTP, ZTFTTR, ZPFTRF, ZPFTRS, ZTPTTF, +* ZTPTTR, ZTRTTF, and ZTRTTP +* +* Arguments +* ========= +* +* NUNIT (input) INTEGER +* The unit number for output. +* +* ===================================================================== +* +* .. +* .. Local Scalars .. + INTEGER INFO + COMPLEX*16 ALPHA, BETA +* .. +* .. Local Arrays .. + COMPLEX*16 A( 1, 1), B( 1, 1) +* .. +* .. External Subroutines .. + EXTERNAL CHKXER, ZTFSM, ZTFTRI, ZHFRK, ZTFTTP, ZTFTTR, + + ZPFTRI, ZPFTRF, ZPFTRS, ZTPTTF, ZTPTTR, ZTRTTF, + + ZTRTTP +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Intrinsic Functions .. + INTRINSIC DCMPLX +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + OK = .TRUE. + A( 1, 1 ) = DCMPLX( 1.D0 , 1.D0 ) + B( 1, 1 ) = DCMPLX( 1.D0 , 1.D0 ) + ALPHA = DCMPLX( 1.D0 , 1.D0 ) + BETA = DCMPLX( 1.D0 , 1.D0 ) +* + SRNAMT = 'ZPFTRF' + INFOT = 1 + CALL ZPFTRF( '/', 'U', 0, A, INFO ) + CALL CHKXER( 'ZPFTRF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPFTRF( 'N', '/', 0, A, INFO ) + CALL CHKXER( 'ZPFTRF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZPFTRF( 'N', 'U', -1, A, INFO ) + CALL CHKXER( 'ZPFTRF', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'ZPFTRS' + INFOT = 1 + CALL ZPFTRS( '/', 'U', 0, 0, A, B, 1, INFO ) + CALL CHKXER( 'ZPFTRS', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPFTRS( 'N', '/', 0, 0, A, B, 1, INFO ) + CALL CHKXER( 'ZPFTRS', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZPFTRS( 'N', 'U', -1, 0, A, B, 1, INFO ) + CALL CHKXER( 'ZPFTRS', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZPFTRS( 'N', 'U', 0, -1, A, B, 1, INFO ) + CALL CHKXER( 'ZPFTRS', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZPFTRS( 'N', 'U', 0, 0, A, B, 0, INFO ) + CALL CHKXER( 'ZPFTRS', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'ZPFTRI' + INFOT = 1 + CALL ZPFTRI( '/', 'U', 0, A, INFO ) + CALL CHKXER( 'ZPFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZPFTRI( 'N', '/', 0, A, INFO ) + CALL CHKXER( 'ZPFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZPFTRI( 'N', 'U', -1, A, INFO ) + CALL CHKXER( 'ZPFTRI', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'ZTFSM ' + INFOT = 1 + CALL ZTFSM( '/', 'L', 'U', 'C', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'ZTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZTFSM( 'N', '/', 'U', 'C', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'ZTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZTFSM( 'N', 'L', '/', 'C', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'ZTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZTFSM( 'N', 'L', 'U', '/', 'U', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'ZTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZTFSM( 'N', 'L', 'U', 'C', '/', 0, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'ZTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZTFSM( 'N', 'L', 'U', 'C', 'U', -1, 0, ALPHA, A, B, 1 ) + CALL CHKXER( 'ZTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 7 + CALL ZTFSM( 'N', 'L', 'U', 'C', 'U', 0, -1, ALPHA, A, B, 1 ) + CALL CHKXER( 'ZTFSM ', INFOT, NOUT, LERR, OK ) + INFOT = 11 + CALL ZTFSM( 'N', 'L', 'U', 'C', 'U', 0, 0, ALPHA, A, B, 0 ) + CALL CHKXER( 'ZTFSM ', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'ZTFTRI' + INFOT = 1 + CALL ZTFTRI( '/', 'L', 'N', 0, A, INFO ) + CALL CHKXER( 'ZTFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZTFTRI( 'N', '/', 'N', 0, A, INFO ) + CALL CHKXER( 'ZTFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZTFTRI( 'N', 'L', '/', 0, A, INFO ) + CALL CHKXER( 'ZTFTRI', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZTFTRI( 'N', 'L', 'N', -1, A, INFO ) + CALL CHKXER( 'ZTFTRI', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'ZTFTTR' + INFOT = 1 + CALL ZTFTTR( '/', 'U', 0, A, B, 1, INFO ) + CALL CHKXER( 'ZTFTTR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZTFTTR( 'N', '/', 0, A, B, 1, INFO ) + CALL CHKXER( 'ZTFTTR', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZTFTTR( 'N', 'U', -1, A, B, 1, INFO ) + CALL CHKXER( 'ZTFTTR', INFOT, NOUT, LERR, OK ) + INFOT = 6 + CALL ZTFTTR( 'N', 'U', 0, A, B, 0, INFO ) + CALL CHKXER( 'ZTFTTR', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'ZTRTTF' + INFOT = 1 + CALL ZTRTTF( '/', 'U', 0, A, 1, B, INFO ) + CALL CHKXER( 'ZTRTTF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZTRTTF( 'N', '/', 0, A, 1, B, INFO ) + CALL CHKXER( 'ZTRTTF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZTRTTF( 'N', 'U', -1, A, 1, B, INFO ) + CALL CHKXER( 'ZTRTTF', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZTRTTF( 'N', 'U', 0, A, 0, B, INFO ) + CALL CHKXER( 'ZTRTTF', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'ZTFTTP' + INFOT = 1 + CALL ZTFTTP( '/', 'U', 0, A, B, INFO ) + CALL CHKXER( 'ZTFTTP', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZTFTTP( 'N', '/', 0, A, B, INFO ) + CALL CHKXER( 'ZTFTTP', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZTFTTP( 'N', 'U', -1, A, B, INFO ) + CALL CHKXER( 'ZTFTTP', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'ZTPTTF' + INFOT = 1 + CALL ZTPTTF( '/', 'U', 0, A, B, INFO ) + CALL CHKXER( 'ZTPTTF', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZTPTTF( 'N', '/', 0, A, B, INFO ) + CALL CHKXER( 'ZTPTTF', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZTPTTF( 'N', 'U', -1, A, B, INFO ) + CALL CHKXER( 'ZTPTTF', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'ZTRTTP' + INFOT = 1 + CALL ZTRTTP( '/', 0, A, 1, B, INFO ) + CALL CHKXER( 'ZTRTTP', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZTRTTP( 'U', -1, A, 1, B, INFO ) + CALL CHKXER( 'ZTRTTP', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZTRTTP( 'U', 0, A, 0, B, INFO ) + CALL CHKXER( 'ZTRTTP', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'ZTPTTR' + INFOT = 1 + CALL ZTPTTR( '/', 0, A, B, 1, INFO ) + CALL CHKXER( 'ZTPTTR', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZTPTTR( 'U', -1, A, B, 1, INFO ) + CALL CHKXER( 'ZTPTTR', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZTPTTR( 'U', 0, A, B, 0, INFO ) + CALL CHKXER( 'ZTPTTR', INFOT, NOUT, LERR, OK ) +* + SRNAMT = 'ZHFRK ' + INFOT = 1 + CALL ZHFRK( '/', 'U', 'N', 0, 0, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'ZHFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 2 + CALL ZHFRK( 'N', '/', 'N', 0, 0, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'ZHFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 3 + CALL ZHFRK( 'N', 'U', '/', 0, 0, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'ZHFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 4 + CALL ZHFRK( 'N', 'U', 'N', -1, 0, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'ZHFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 5 + CALL ZHFRK( 'N', 'U', 'N', 0, -1, ALPHA, A, 1, BETA, B ) + CALL CHKXER( 'ZHFRK ', INFOT, NOUT, LERR, OK ) + INFOT = 8 + CALL ZHFRK( 'N', 'U', 'N', 0, 0, ALPHA, A, 0, BETA, B ) + CALL CHKXER( 'ZHFRK ', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + IF( OK ) THEN + WRITE( NOUT, FMT = 9999 ) + ELSE + WRITE( NOUT, FMT = 9998 ) + END IF +* + 9999 FORMAT( 1X, 'COMPLEX*16 RFP routines passed the tests of the ', + $ 'error exits' ) + 9998 FORMAT( ' *** RFP routines failed the tests of the error ', + $ 'exits ***' ) + RETURN +* +* End of ZERRRFP +* + END diff --git a/TESTING/LIN/zerrrq.f b/TESTING/LIN/zerrrq.f index fe50655c..9eff0723 100644 --- a/TESTING/LIN/zerrrq.f +++ b/TESTING/LIN/zerrrq.f @@ -43,7 +43,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zerrsy.f b/TESTING/LIN/zerrsy.f index 9e813eca..5eb1ecd8 100644 --- a/TESTING/LIN/zerrsy.f +++ b/TESTING/LIN/zerrsy.f @@ -52,7 +52,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zerrtr.f b/TESTING/LIN/zerrtr.f index f16577d1..ba46360d 100644 --- a/TESTING/LIN/zerrtr.f +++ b/TESTING/LIN/zerrtr.f @@ -50,7 +50,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zerrtz.f b/TESTING/LIN/zerrtz.f index 70e4434e..ac3b9f13 100644 --- a/TESTING/LIN/zerrtz.f +++ b/TESTING/LIN/zerrtz.f @@ -45,7 +45,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zerrvx.f b/TESTING/LIN/zerrvx.f index efc3d75b..b8a784f4 100644 --- a/TESTING/LIN/zerrvx.f +++ b/TESTING/LIN/zerrvx.f @@ -55,7 +55,7 @@ * .. * .. Scalars in Common .. LOGICAL LERR, OK - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT INTEGER INFOT, NOUT * .. * .. Common blocks .. diff --git a/TESTING/LIN/zget07.f b/TESTING/LIN/zget07.f index eea47243..c6595341 100644 --- a/TESTING/LIN/zget07.f +++ b/TESTING/LIN/zget07.f @@ -1,5 +1,5 @@ SUBROUTINE ZGET07( TRANS, N, NRHS, A, LDA, B, LDB, X, LDX, XACT, - $ LDXACT, FERR, BERR, RESLTS ) + $ LDXACT, FERR, CHKFERR, BERR, RESLTS ) * * -- LAPACK test routine (version 3.1) -- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. @@ -7,6 +7,7 @@ * * .. Scalar Arguments .. CHARACTER TRANS + LOGICAL CHKFERR INTEGER LDA, LDB, LDX, LDXACT, N, NRHS * .. * .. Array Arguments .. @@ -79,6 +80,11 @@ * of the largest entry in (X - XTRUE) divided by the magnitude * of the largest entry in X. * +* CHKFERR (input) LOGICAL +* Set to .TRUE. to check FERR, .FALSE. not to check FERR. +* When the test system is ill-conditioned, the "true" +* solution in XACT may be incorrect. +* * BERR (input) DOUBLE PRECISION array, dimension (NRHS) * The componentwise relative backward error of each solution * vector (i.e., the smallest relative change in any entry of A @@ -136,30 +142,32 @@ * over all the vectors X and XACT using the infinity-norm. * ERRBND = ZERO - DO 30 J = 1, NRHS - IMAX = IZAMAX( N, X( 1, J ), 1 ) - XNORM = MAX( CABS1( X( IMAX, J ) ), UNFL ) - DIFF = ZERO - DO 10 I = 1, N - DIFF = MAX( DIFF, CABS1( X( I, J )-XACT( I, J ) ) ) - 10 CONTINUE -* - IF( XNORM.GT.ONE ) THEN - GO TO 20 - ELSE IF( DIFF.LE.OVFL*XNORM ) THEN - GO TO 20 - ELSE - ERRBND = ONE / EPS - GO TO 30 - END IF + IF( CHKFERR ) THEN + DO 30 J = 1, NRHS + IMAX = IZAMAX( N, X( 1, J ), 1 ) + XNORM = MAX( CABS1( X( IMAX, J ) ), UNFL ) + DIFF = ZERO + DO 10 I = 1, N + DIFF = MAX( DIFF, CABS1( X( I, J )-XACT( I, J ) ) ) + 10 CONTINUE +* + IF( XNORM.GT.ONE ) THEN + GO TO 20 + ELSE IF( DIFF.LE.OVFL*XNORM ) THEN + GO TO 20 + ELSE + ERRBND = ONE / EPS + GO TO 30 + END IF * - 20 CONTINUE - IF( DIFF / XNORM.LE.FERR( J ) ) THEN - ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) ) - ELSE - ERRBND = ONE / EPS - END IF - 30 CONTINUE + 20 CONTINUE + IF( DIFF / XNORM.LE.FERR( J ) ) THEN + ERRBND = MAX( ERRBND, ( DIFF / XNORM ) / FERR( J ) ) + ELSE + ERRBND = ONE / EPS + END IF + 30 CONTINUE + END IF RESLTS( 1 ) = ERRBND * * Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where diff --git a/TESTING/LIN/zlahilb.f b/TESTING/LIN/zlahilb.f new file mode 100644 index 00000000..9350684b --- /dev/null +++ b/TESTING/LIN/zlahilb.f @@ -0,0 +1,206 @@ + SUBROUTINE ZLAHILB(N, NRHS, A, LDA, X, LDX, B, LDB, WORK, + $ INFO, PATH) +! +! -- LAPACK auxiliary test routine (version 3.0) -- +! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +! Courant Institute, Argonne National Lab, and Rice University +! 28 August, 2006 +! +! David Vu <dtv@cs.berkeley.edu> +! Yozo Hida <yozo@cs.berkeley.edu> +! Jason Riedy <ejr@cs.berkeley.edu> +! D. Halligan <dhalligan@berkeley.edu> +! + IMPLICIT NONE +! .. Scalar Arguments .. + INTEGER N, NRHS, LDA, LDX, LDB, INFO +! .. Array Arguments .. + DOUBLE PRECISION WORK(N) + COMPLEX*16 A(LDA,N), X(LDX, NRHS), B(LDB, NRHS) + CHARACTER*3 PATH +! .. +! +! Purpose +! ======= +! +! ZLAHILB generates an N by N scaled Hilbert matrix in A along with +! NRHS right-hand sides in B and solutions in X such that A*X=B. +! +! The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all +! entries are integers. The right-hand sides are the first NRHS +! columns of M * the identity matrix, and the solutions are the +! first NRHS columns of the inverse Hilbert matrix. +! +! The condition number of the Hilbert matrix grows exponentially with +! its size, roughly as O(e ** (3.5*N)). Additionally, the inverse +! Hilbert matrices beyond a relatively small dimension cannot be +! generated exactly without extra precision. Precision is exhausted +! when the largest entry in the inverse Hilbert matrix is greater than +! 2 to the power of the number of bits in the fraction of the data type +! used plus one, which is 24 for single precision. +! +! In single, the generated solution is exact for N <= 6 and has +! small componentwise error for 7 <= N <= 11. +! +! Arguments +! ========= +! +! N (input) INTEGER +! The dimension of the matrix A. +! +! NRHS (input) NRHS +! The requested number of right-hand sides. +! +! A (output) COMPLEX array, dimension (LDA, N) +! The generated scaled Hilbert matrix. +! +! LDA (input) INTEGER +! The leading dimension of the array A. LDA >= N. +! +! X (output) COMPLEX array, dimension (LDX, NRHS) +! The generated exact solutions. Currently, the first NRHS +! columns of the inverse Hilbert matrix. +! +! LDX (input) INTEGER +! The leading dimension of the array X. LDX >= N. +! +! B (output) REAL array, dimension (LDB, NRHS) +! The generated right-hand sides. Currently, the first NRHS +! columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. +! +! LDB (input) INTEGER +! The leading dimension of the array B. LDB >= N. +! +! WORK (workspace) REAL array, dimension (N) +! +! +! INFO (output) INTEGER +! = 0: successful exit +! = 1: N is too large; the data is still generated but may not +! be not exact. +! < 0: if INFO = -i, the i-th argument had an illegal value +! +! ===================================================================== + +! .. Local Scalars .. + INTEGER TM, TI, R + INTEGER M + INTEGER I, J + COMPLEX*16 TMP + CHARACTER*2 C2 + +! .. Parameters .. +! NMAX_EXACT the largest dimension where the generated data is +! exact. +! NMAX_APPROX the largest dimension where the generated data has +! a small componentwise relative error. +! ??? complex uses how many bits ??? + INTEGER NMAX_EXACT, NMAX_APPROX, SIZE_D + PARAMETER (NMAX_EXACT = 6, NMAX_APPROX = 11, SIZE_D = 8) + +! d's are generated from random permuation of those eight elements. + COMPLEX*16 d1(8), d2(8), invd1(8), invd2(8) + DATA D1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/ + DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/ + + DATA INVD1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0), + $ (-.5,-.5),(.5,-.5),(.5,.5)/ + DATA INVD2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0), + $ (-.5,.5),(.5,.5),(.5,-.5)/ +! .. +! .. External Functions + EXTERNAL ZLASET, LSAMEN + INTRINSIC DBLE + LOGICAL LSAMEN +! .. +! .. Executable Statements .. + C2 = PATH( 2: 3 ) +! +! Test the input arguments +! + INFO = 0 + IF (N .LT. 0 .OR. N .GT. NMAX_APPROX) THEN + INFO = -1 + ELSE IF (NRHS .LT. 0) THEN + INFO = -2 + ELSE IF (LDA .LT. N) THEN + INFO = -4 + ELSE IF (LDX .LT. N) THEN + INFO = -6 + ELSE IF (LDB .LT. N) THEN + INFO = -8 + END IF + IF (INFO .LT. 0) THEN + CALL XERBLA('ZLAHILB', -INFO) + RETURN + END IF + IF (N .GT. NMAX_EXACT) THEN + INFO = 1 + END IF + +! Compute M = the LCM of the integers [1, 2*N-1]. The largest +! reasonable N is small enough that integers suffice (up to N = 11). + M = 1 + DO I = 2, (2*N-1) + TM = M + TI = I + R = MOD(TM, TI) + DO WHILE (R .NE. 0) + TM = TI + TI = R + R = MOD(TM, TI) + END DO + M = (M / TI) * I + END DO + +! Generate the scaled Hilbert matrix in A +! If we are testing SY routines, take D1_i = D2_i, else, D1_i = D2_i* + IF ( LSAMEN( 2, C2, 'SY' ) ) THEN + DO J = 1, N + DO I = 1, N + A(I, J) = D1(MOD(J,SIZE_D)+1) * (DBLE(M) / (I + J - 1)) + $ * D1(MOD(I,SIZE_D)+1) + END DO + END DO + ELSE + DO J = 1, N + DO I = 1, N + A(I, J) = D1(MOD(J,SIZE_D)+1) * (DBLE(M) / (I + J - 1)) + $ * D2(MOD(I,SIZE_D)+1) + END DO + END DO + END IF + +! Generate matrix B as simply the first NRHS columns of M * the +! identity. + TMP = DBLE(M) + CALL ZLASET('Full', N, NRHS, (0.0D+0,0.0D+0), TMP, B, LDB) + +! Generate the true solutions in X. Because B = the first NRHS +! columns of M*I, the true solutions are just the first NRHS columns +! of the inverse Hilbert matrix. + WORK(1) = N + DO J = 2, N + WORK(J) = ( ( (WORK(J-1)/(J-1)) * (J-1 - N) ) /(J-1) ) + $ * (N +J -1) + END DO + +! If we are testing SY routines, take D1_i = D2_i, else, D1_i = D2_i* + IF ( LSAMEN( 2, C2, 'SY' ) ) THEN + DO J = 1, NRHS + DO I = 1, N + X(I, J) = INVD1(MOD(J,SIZE_D)+1) * + $ ((WORK(I)*WORK(J)) / (I + J - 1)) + $ * INVD1(MOD(I,SIZE_D)+1) + END DO + END DO + ELSE + DO J = 1, NRHS + DO I = 1, N + X(I, J) = INVD2(MOD(J,SIZE_D)+1) * + $ ((WORK(I)*WORK(J)) / (I + J - 1)) + $ * INVD1(MOD(I,SIZE_D)+1) + END DO + END DO + END IF + END diff --git a/TESTING/LIN/zlatb5.f b/TESTING/LIN/zlatb5.f new file mode 100644 index 00000000..e0fcd491 --- /dev/null +++ b/TESTING/LIN/zlatb5.f @@ -0,0 +1,166 @@ + SUBROUTINE ZLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM, MODE, + $ CNDNUM, DIST ) +* +* -- LAPACK test routine (version 3.1) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + DOUBLE PRECISION ANORM, CNDNUM + INTEGER IMAT, KL, KU, MODE, N + CHARACTER DIST, TYPE + CHARACTER*3 PATH +* .. +* +* Purpose +* ======= +* +* ZLATB5 sets parameters for the matrix generator based on the type +* of matrix to be generated. +* +* Arguments +* ========= +* +* PATH (input) CHARACTER*3 +* The LAPACK path name. +* +* IMAT (input) INTEGER +* An integer key describing which matrix to generate for this +* path. +* +* N (input) INTEGER +* The number of rows and columns in the matrix to be generated. +* +* TYPE (output) CHARACTER*1 +* The type of the matrix to be generated: +* = 'S': symmetric matrix +* = 'P': symmetric positive (semi)definite matrix +* = 'N': nonsymmetric matrix +* +* KL (output) INTEGER +* The lower band width of the matrix to be generated. +* +* KU (output) INTEGER +* The upper band width of the matrix to be generated. +* +* ANORM (output) DOUBLE PRECISION +* The desired norm of the matrix to be generated. The diagonal +* matrix of singular values or eigenvalues is scaled by this +* value. +* +* MODE (output) INTEGER +* A key indicating how to choose the vector of eigenvalues. +* +* CNDNUM (output) DOUBLE PRECISION +* The desired condition number. +* +* DIST (output) CHARACTER*1 +* The type of distribution to be used by the random number +* generator. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION SHRINK, TENTH + PARAMETER ( SHRINK = 0.25D0, TENTH = 0.1D+0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D+0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION BADC1, BADC2, EPS, LARGE, SMALL + LOGICAL FIRST + CHARACTER*2 C2 +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT +* .. +* .. External Subroutines .. + EXTERNAL DLABAD +* .. +* .. Save statement .. + SAVE EPS, SMALL, LARGE, BADC1, BADC2, FIRST +* .. +* .. Data statements .. + DATA FIRST / .TRUE. / +* .. +* .. Executable Statements .. +* +* Set some constants for use in the subroutine. +* + IF( FIRST ) THEN + FIRST = .FALSE. + EPS = DLAMCH( 'Precision' ) + BADC2 = TENTH / EPS + BADC1 = SQRT( BADC2 ) + SMALL = DLAMCH( 'Safe minimum' ) + LARGE = ONE / SMALL +* +* If it looks like we're on a Cray, take the square root of +* SMALL and LARGE to avoid overflow and underflow problems. +* + CALL DLABAD( SMALL, LARGE ) + SMALL = SHRINK*( SMALL / EPS ) + LARGE = ONE / SMALL + END IF +* + C2 = PATH( 2: 3 ) +* +* Set some parameters +* + DIST = 'S' + MODE = 3 +* +* Set TYPE, the type of matrix to be generated. +* + TYPE = C2( 1: 1 ) +* +* Set the lower and upper bandwidths. +* + IF( IMAT.EQ.1 ) THEN + KL = 0 + ELSE + KL = MAX( N-1, 0 ) + END IF + KU = KL +* +* Set the condition number and norm.etc +* + IF( IMAT.EQ.3 ) THEN + CNDNUM = 1.0D12 + MODE = 2 + ELSE IF( IMAT.EQ.4 ) THEN + CNDNUM = 1.0D12 + MODE = 1 + ELSE IF( IMAT.EQ.5 ) THEN + CNDNUM = 1.0D12 + MODE = 3 + ELSE IF( IMAT.EQ.6 ) THEN + CNDNUM = BADC1 + ELSE IF( IMAT.EQ.7 ) THEN + CNDNUM = BADC2 + ELSE + CNDNUM = TWO + END IF +* + IF( IMAT.EQ.8 ) THEN + ANORM = SMALL + ELSE IF( IMAT.EQ.9 ) THEN + ANORM = LARGE + ELSE + ANORM = ONE + END IF +* + IF( N.LE.1 ) + $ CNDNUM = ONE +* + RETURN +* +* End of ZLATB5 +* + END diff --git a/TESTING/LIN/zlqt01.f b/TESTING/LIN/zlqt01.f index 4dd4147b..350917d3 100644 --- a/TESTING/LIN/zlqt01.f +++ b/TESTING/LIN/zlqt01.f @@ -87,7 +87,7 @@ INTRINSIC DBLE, DCMPLX, MAX, MIN * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/zlqt02.f b/TESTING/LIN/zlqt02.f index ee0eae91..8b7eb4f5 100644 --- a/TESTING/LIN/zlqt02.f +++ b/TESTING/LIN/zlqt02.f @@ -93,7 +93,7 @@ INTRINSIC DBLE, DCMPLX, MAX * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/zlqt03.f b/TESTING/LIN/zlqt03.f index cd4b7235..7fa05999 100644 --- a/TESTING/LIN/zlqt03.f +++ b/TESTING/LIN/zlqt03.f @@ -99,7 +99,7 @@ INTRINSIC DBLE, DCMPLX, MAX * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/zpot06.f b/TESTING/LIN/zpot06.f new file mode 100644 index 00000000..2e5aae6e --- /dev/null +++ b/TESTING/LIN/zpot06.f @@ -0,0 +1,147 @@ + SUBROUTINE ZPOT06( UPLO, N, NRHS, A, LDA, X, LDX, B, LDB, + $ RWORK, RESID ) +* +* -- LAPACK test routine (version 3.1.2) -- +* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. +* May 2007 +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER LDA, LDB, LDX, N, NRHS + DOUBLE PRECISION RESID +* .. +* .. Array Arguments .. + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), B( LDB, * ), X( LDX, * ) +* .. +* +* Purpose +* ======= +* +* ZPOT06 computes the residual for a solution of a system of linear +* equations A*x = b : +* RESID = norm(B - A*X,inf) / ( norm(A,inf) * norm(X,inf) * EPS ), +* where EPS is the machine epsilon. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is stored: +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The number of rows and columns of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of columns of B, the matrix of right hand sides. +* NRHS >= 0. +* +* A (input) COMPLEX*16 array, dimension (LDA,N) +* The original M x N matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* X (input) COMPLEX*16 array, dimension (LDX,NRHS) +* The computed solution vectors for the system of linear +* equations. +* +* LDX (input) INTEGER +* The leading dimension of the array X. If TRANS = 'N', +* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,N). +* +* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) +* On entry, the right hand side vectors for the system of +* linear equations. +* On exit, B is overwritten with the difference B - A*X. +* +* LDB (input) INTEGER +* The leading dimension of the array B. IF TRANS = 'N', +* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N). +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (N) +* +* RESID (output) DOUBLE PRECISION +* The maximum over the number of right hand sides of +* norm(B - A*X) / ( norm(A) * norm(X) * EPS ). +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE, NEGONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + PARAMETER ( NEGONE = -1.0D+0 ) + COMPLEX*16 CONE, NEGCONE + PARAMETER ( CONE = ( 1.0D+0, 0.0D+0 ) ) + PARAMETER ( NEGCONE = ( -1.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + INTEGER IFAIL, J + DOUBLE PRECISION ANORM, BNORM, EPS, XNORM + COMPLEX*16 ZDUM +* .. +* .. External Functions .. + LOGICAL LSAME + INTEGER IZAMAX + DOUBLE PRECISION DLAMCH, ZLANSY + EXTERNAL LSAME, IZAMAX, DLAMCH, ZLANSY +* .. +* .. External Subroutines .. + EXTERNAL ZHEMM +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, DBLE, DIMAG, MAX +* .. +* .. Statement Functions .. + DOUBLE PRECISION CABS1 +* .. +* .. Statement Function definitions .. + CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) ) +* .. +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0 or NRHS = 0 +* + IF( N.LE.0 .OR. NRHS.EQ.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Exit with RESID = 1/EPS if ANORM = 0. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = ZLANSY( 'I', UPLO, N, A, LDA, RWORK ) + IF( ANORM.LE.ZERO ) THEN + RESID = ONE / EPS + RETURN + END IF +* +* Compute B - A*X and store in B. + IFAIL=0 +* + CALL ZHEMM( 'Left', UPLO, N, NRHS, NEGCONE, A, LDA, X, + $ LDX, CONE, B, LDB ) +* +* Compute the maximum over the number of right hand sides of +* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) . +* + RESID = ZERO + DO 10 J = 1, NRHS + BNORM = CABS1(B(IZAMAX( N, B( 1, J ), 1 ),J)) + XNORM = CABS1(X(IZAMAX( N, X( 1, J ), 1 ),J)) + IF( XNORM.LE.ZERO ) THEN + RESID = ONE / EPS + ELSE + RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS ) + END IF + 10 CONTINUE +* + RETURN +* +* End of ZPOT06 +* + END diff --git a/TESTING/LIN/zpst01.f b/TESTING/LIN/zpst01.f new file mode 100644 index 00000000..3da729c9 --- /dev/null +++ b/TESTING/LIN/zpst01.f @@ -0,0 +1,243 @@ + SUBROUTINE ZPST01( UPLO, N, A, LDA, AFAC, LDAFAC, PERM, LDPERM, + $ PIV, RWORK, RESID, RANK ) +* +* -- LAPACK test routine (version 3.1) -- +* Craig Lucas, University of Manchester / NAG Ltd. +* October, 2008 +* +* .. Scalar Arguments .. + DOUBLE PRECISION RESID + INTEGER LDA, LDAFAC, LDPERM, N, RANK + CHARACTER UPLO +* .. +* .. Array Arguments .. + COMPLEX*16 A( LDA, * ), AFAC( LDAFAC, * ), + $ PERM( LDPERM, * ) + DOUBLE PRECISION RWORK( * ) + INTEGER PIV( * ) +* .. +* +* Purpose +* ======= +* +* ZPST01 reconstructs an Hermitian positive semidefinite matrix A +* from its L or U factors and the permutation matrix P and computes +* the residual +* norm( P*L*L'*P' - A ) / ( N * norm(A) * EPS ) or +* norm( P*U'*U*P' - A ) / ( N * norm(A) * EPS ), +* where EPS is the machine epsilon, L' is the conjugate transpose of L, +* and U' is the conjugate transpose of U. +* +* Arguments +* ========== +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* Hermitian matrix A is stored: +* = 'U': Upper triangular +* = 'L': Lower triangular +* +* N (input) INTEGER +* The number of rows and columns of the matrix A. N >= 0. +* +* A (input) COMPLEX*16 array, dimension (LDA,N) +* The original Hermitian matrix A. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N) +* +* AFAC (input) COMPLEX*16 array, dimension (LDAFAC,N) +* The factor L or U from the L*L' or U'*U +* factorization of A. +* +* LDAFAC (input) INTEGER +* The leading dimension of the array AFAC. LDAFAC >= max(1,N). +* +* PERM (output) COMPLEX*16 array, dimension (LDPERM,N) +* Overwritten with the reconstructed matrix, and then with the +* difference P*L*L'*P' - A (or P*U'*U*P' - A) +* +* LDPERM (input) INTEGER +* The leading dimension of the array PERM. +* LDAPERM >= max(1,N). +* +* PIV (input) INTEGER array, dimension (N) +* PIV is such that the nonzero entries are +* P( PIV( K ), K ) = 1. +* +* RWORK (workspace) DOUBLE PRECISION array, dimension (N) +* +* RESID (output) DOUBLE PRECISION +* If UPLO = 'L', norm(L*L' - A) / ( N * norm(A) * EPS ) +* If UPLO = 'U', norm(U'*U - A) / ( N * norm(A) * EPS ) +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + COMPLEX*16 CZERO + PARAMETER ( CZERO = ( 0.0D+0, 0.0D+0 ) ) +* .. +* .. Local Scalars .. + COMPLEX*16 TC + DOUBLE PRECISION ANORM, EPS, TR + INTEGER I, J, K +* .. +* .. External Functions .. + COMPLEX*16 ZDOTC + DOUBLE PRECISION DLAMCH, ZLANHE + LOGICAL LSAME + EXTERNAL ZDOTC, DLAMCH, ZLANHE, LSAME +* .. +* .. External Subroutines .. + EXTERNAL ZHER, ZSCAL, ZTRMV +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCONJG, DIMAG +* .. +* .. Executable Statements .. +* +* Quick exit if N = 0. +* + IF( N.LE.0 ) THEN + RESID = ZERO + RETURN + END IF +* +* Exit with RESID = 1/EPS if ANORM = 0. +* + EPS = DLAMCH( 'Epsilon' ) + ANORM = ZLANHE( '1', UPLO, N, A, LDA, RWORK ) + IF( ANORM.LE.ZERO ) THEN + RESID = ONE / EPS + RETURN + END IF +* +* Check the imaginary parts of the diagonal elements and return with +* an error code if any are nonzero. +* + DO 100 J = 1, N + IF( DIMAG( AFAC( J, J ) ).NE.ZERO ) THEN + RESID = ONE / EPS + RETURN + END IF + 100 CONTINUE +* +* Compute the product U'*U, overwriting U. +* + IF( LSAME( UPLO, 'U' ) ) THEN +* + IF( RANK.LT.N ) THEN + DO 120 J = RANK + 1, N + DO 110 I = RANK + 1, J + AFAC( I, J ) = CZERO + 110 CONTINUE + 120 CONTINUE + END IF +* + DO 130 K = N, 1, -1 +* +* Compute the (K,K) element of the result. +* + TR = ZDOTC( K, AFAC( 1, K ), 1, AFAC( 1, K ), 1 ) + AFAC( K, K ) = TR +* +* Compute the rest of column K. +* + CALL ZTRMV( 'Upper', 'Conjugate', 'Non-unit', K-1, AFAC, + $ LDAFAC, AFAC( 1, K ), 1 ) +* + 130 CONTINUE +* +* Compute the product L*L', overwriting L. +* + ELSE +* + IF( RANK.LT.N ) THEN + DO 150 J = RANK + 1, N + DO 140 I = J, N + AFAC( I, J ) = CZERO + 140 CONTINUE + 150 CONTINUE + END IF +* + DO 160 K = N, 1, -1 +* Add a multiple of column K of the factor L to each of +* columns K+1 through N. +* + IF( K+1.LE.N ) + $ CALL ZHER( 'Lower', N-K, ONE, AFAC( K+1, K ), 1, + $ AFAC( K+1, K+1 ), LDAFAC ) +* +* Scale column K by the diagonal element. +* + TC = AFAC( K, K ) + CALL ZSCAL( N-K+1, TC, AFAC( K, K ), 1 ) + 160 CONTINUE +* + END IF +* +* Form P*L*L'*P' or P*U'*U*P' +* + IF( LSAME( UPLO, 'U' ) ) THEN +* + DO 180 J = 1, N + DO 170 I = 1, N + IF( PIV( I ).LE.PIV( J ) ) THEN + IF( I.LE.J ) THEN + PERM( PIV( I ), PIV( J ) ) = AFAC( I, J ) + ELSE + PERM( PIV( I ), PIV( J ) ) = DCONJG( AFAC( J, I ) ) + END IF + END IF + 170 CONTINUE + 180 CONTINUE +* +* + ELSE +* + DO 200 J = 1, N + DO 190 I = 1, N + IF( PIV( I ).GE.PIV( J ) ) THEN + IF( I.GE.J ) THEN + PERM( PIV( I ), PIV( J ) ) = AFAC( I, J ) + ELSE + PERM( PIV( I ), PIV( J ) ) = DCONJG( AFAC( J, I ) ) + END IF + END IF + 190 CONTINUE + 200 CONTINUE +* + END IF +* +* Compute the difference P*L*L'*P' - A (or P*U'*U*P' - A). +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 220 J = 1, N + DO 210 I = 1, J - 1 + PERM( I, J ) = PERM( I, J ) - A( I, J ) + 210 CONTINUE + PERM( J, J ) = PERM( J, J ) - DBLE( A( J, J ) ) + 220 CONTINUE + ELSE + DO 240 J = 1, N + PERM( J, J ) = PERM( J, J ) - DBLE( A( J, J ) ) + DO 230 I = J + 1, N + PERM( I, J ) = PERM( I, J ) - A( I, J ) + 230 CONTINUE + 240 CONTINUE + END IF +* +* Compute norm( P*L*L'P - A ) / ( N * norm(A) * EPS ), or +* ( P*U'*U*P' - A )/ ( N * norm(A) * EPS ). +* + RESID = ZLANHE( '1', UPLO, N, PERM, LDAFAC, RWORK ) +* + RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS +* + RETURN +* +* End of ZPST01 +* + END diff --git a/TESTING/LIN/zqlt01.f b/TESTING/LIN/zqlt01.f index 604767ed..e4ce8c5d 100644 --- a/TESTING/LIN/zqlt01.f +++ b/TESTING/LIN/zqlt01.f @@ -87,7 +87,7 @@ INTRINSIC DBLE, DCMPLX, MAX, MIN * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/zqlt02.f b/TESTING/LIN/zqlt02.f index 348666b5..1c156fc1 100644 --- a/TESTING/LIN/zqlt02.f +++ b/TESTING/LIN/zqlt02.f @@ -94,7 +94,7 @@ INTRINSIC DBLE, DCMPLX, MAX * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/zqlt03.f b/TESTING/LIN/zqlt03.f index 28535800..1283daa3 100644 --- a/TESTING/LIN/zqlt03.f +++ b/TESTING/LIN/zqlt03.f @@ -99,7 +99,7 @@ INTRINSIC DBLE, DCMPLX, MAX, MIN * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/zqrt01.f b/TESTING/LIN/zqrt01.f index 58d48eac..d0a723c1 100644 --- a/TESTING/LIN/zqrt01.f +++ b/TESTING/LIN/zqrt01.f @@ -87,7 +87,7 @@ INTRINSIC DBLE, DCMPLX, MAX, MIN * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/zqrt02.f b/TESTING/LIN/zqrt02.f index 01bb1334..ac69c20f 100644 --- a/TESTING/LIN/zqrt02.f +++ b/TESTING/LIN/zqrt02.f @@ -93,7 +93,7 @@ INTRINSIC DBLE, DCMPLX, MAX * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/zqrt03.f b/TESTING/LIN/zqrt03.f index 8e239905..5866af2b 100644 --- a/TESTING/LIN/zqrt03.f +++ b/TESTING/LIN/zqrt03.f @@ -99,7 +99,7 @@ INTRINSIC DBLE, DCMPLX, MAX * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/zrqt01.f b/TESTING/LIN/zrqt01.f index 2a3a588e..35bbc29d 100644 --- a/TESTING/LIN/zrqt01.f +++ b/TESTING/LIN/zrqt01.f @@ -87,7 +87,7 @@ INTRINSIC DBLE, DCMPLX, MAX, MIN * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/zrqt02.f b/TESTING/LIN/zrqt02.f index 9bb6a582..5b888ef8 100644 --- a/TESTING/LIN/zrqt02.f +++ b/TESTING/LIN/zrqt02.f @@ -94,7 +94,7 @@ INTRINSIC DBLE, DCMPLX, MAX * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT diff --git a/TESTING/LIN/zrqt03.f b/TESTING/LIN/zrqt03.f index b90e0a72..1c9fb22c 100644 --- a/TESTING/LIN/zrqt03.f +++ b/TESTING/LIN/zrqt03.f @@ -99,7 +99,7 @@ INTRINSIC DBLE, DCMPLX, MAX, MIN * .. * .. Scalars in Common .. - CHARACTER(32) SRNAMT + CHARACTER*32 SRNAMT * .. * .. Common blocks .. COMMON / SRNAMC / SRNAMT |