diff --git a/cmake/lapack.cmake b/cmake/lapack.cmake index bf346a1b5b..ab98c93648 100644 --- a/cmake/lapack.cmake +++ b/cmake/lapack.cmake @@ -124,7 +124,7 @@ set(SLASRC ssbev_2stage.f ssbevx_2stage.f ssbevd_2stage.f ssygv_2stage.f sgesvdq.f slaorhr_col_getrfnp.f slaorhr_col_getrfnp2.f sorgtsqr.f sorgtsqr_row.f sorhr_col.f - slatrs3.f strsyl3.f sgelst.f sgedmd.f90 sgedmdq.f90) + slatrs3.f strsyl3.f sgelst.f sgedmd.f90 sgedmdq.f90 sgecxx.f) set(SXLASRC sgesvxx.f sgerfsx.f sla_gerfsx_extended.f sla_geamv.f sla_gercond.f sla_gerpvgrw.f ssysvxx.f ssyrfsx.f @@ -224,7 +224,7 @@ set(CLASRC chbev_2stage.f chbevx_2stage.f chbevd_2stage.f chegv_2stage.f cgesvdq.f claunhr_col_getrfnp.f claunhr_col_getrfnp2.f cungtsqr.f cungtsqr_row.f cunhr_col.f - clatrs3.f ctrsyl3.f cgelst.f cgedmd.f90 cgedmdq.f90) + clatrs3.f ctrsyl3.f cgelst.f cgedmd.f90 cgedmdq.f90 cgecxx.f) set(CXLASRC cgesvxx.f cgerfsx.f cla_gerfsx_extended.f cla_geamv.f cla_gercond_c.f cla_gercond_x.f cla_gerpvgrw.f @@ -317,7 +317,7 @@ set(DLASRC dsbev_2stage.f dsbevx_2stage.f dsbevd_2stage.f dsygv_2stage.f dcombssq.f dgesvdq.f dlaorhr_col_getrfnp.f dlaorhr_col_getrfnp2.f dorgtsqr.f dorgtsqr_row.f dorhr_col.f - dlatrs3.f dtrsyl3.f dgelst.f dgedmd.f90 dgedmdq.f90) + dlatrs3.f dtrsyl3.f dgelst.f dgedmd.f90 dgedmdq.f90 dgecxx.f) set(DXLASRC dgesvxx.f dgerfsx.f dla_gerfsx_extended.f dla_geamv.f dla_gercond.f dla_gerpvgrw.f dsysvxx.f dsyrfsx.f @@ -420,7 +420,7 @@ set(ZLASRC zhbev_2stage.f zhbevx_2stage.f zhbevd_2stage.f zhegv_2stage.f zgesvdq.f zlaunhr_col_getrfnp.f zlaunhr_col_getrfnp2.f zungtsqr.f zungtsqr_row.f zunhr_col.f - zlatrs3.f ztrsyl3.f zgelst.f zgedmd.f90 zgedmdq.f90) + zlatrs3.f ztrsyl3.f zgelst.f zgedmd.f90 zgedmdq.f90 zgecxx.f) set(ZXLASRC zgesvxx.f zgerfsx.f zla_gerfsx_extended.f zla_geamv.f zla_gercond_c.f zla_gercond_x.f zla_gerpvgrw.f zsysvxx.f zsyrfsx.f @@ -629,7 +629,7 @@ set(SLASRC ssbev_2stage.c ssbevx_2stage.c ssbevd_2stage.c ssygv_2stage.c sgesvdq.c slaorhr_col_getrfnp.c slaorhr_col_getrfnp2.c sorgtsqr.c sorgtsqr_row.c sorhr_col.c - slatrs3.c strsyl3.c sgelst.c sgedmd.c sgedmdq.c) + slatrs3.c strsyl3.c sgelst.c sgedmd.c sgedmdq.c sgecxx.c) set(SXLASRC sgesvxx.c sgerfsx.c sla_gerfsx_extended.c sla_geamv.c sla_gercond.c sla_gerpvgrw.c ssysvxx.c ssyrfsx.c @@ -728,7 +728,7 @@ set(CLASRC chbev_2stage.c chbevx_2stage.c chbevd_2stage.c chegv_2stage.c cgesvdq.c claunhr_col_getrfnp.c claunhr_col_getrfnp2.c cungtsqr.c cungtsqr_row.c cunhr_col.c - clatrs3.c ctrsyl3.c cgelst.c cgedmd.c cgedmdq.c) + clatrs3.c ctrsyl3.c cgelst.c cgedmd.c cgedmdq.c cgecxx.c) set(CXLASRC cgesvxx.c cgerfsx.c cla_gerfsx_extended.c cla_geamv.c cla_gercond_c.c cla_gercond_x.c cla_gerpvgrw.c @@ -820,7 +820,7 @@ set(DLASRC dsbev_2stage.c dsbevx_2stage.c dsbevd_2stage.c dsygv_2stage.c dcombssq.c dgesvdq.c dlaorhr_col_getrfnp.c dlaorhr_col_getrfnp2.c dorgtsqr.c dorgtsqr_row.c dorhr_col.c - dlatrs3.c dtrsyl3.c dgelst.c dgedmd.c dgedmdq.c) + dlatrs3.c dtrsyl3.c dgelst.c dgedmd.c dgedmdq.c dgecxx.c) set(DXLASRC dgesvxx.c dgerfsx.c dla_gerfsx_extended.c dla_geamv.c dla_gercond.c dla_gerpvgrw.c dsysvxx.c dsyrfsx.c @@ -922,7 +922,7 @@ set(ZLASRC zhbev_2stage.c zhbevx_2stage.c zhbevd_2stage.c zhegv_2stage.c zgesvdq.c zlaunhr_col_getrfnp.c zlaunhr_col_getrfnp2.c zungtsqr.c zungtsqr_row.c zunhr_col.c zlatrs3.c ztrsyl3.c zgelst.c - zgedmd.c zgedmdq.c) + zgedmd.c zgedmdq.c zgecxx.c) set(ZXLASRC zgesvxx.c zgerfsx.c zla_gerfsx_extended.c zla_geamv.c zla_gercond_c.c zla_gercond_x.c zla_gerpvgrw.c zsysvxx.c zsyrfsx.c diff --git a/cmake/lapacke.cmake b/cmake/lapacke.cmake index 94224d8baf..1777fd99cb 100644 --- a/cmake/lapacke.cmake +++ b/cmake/lapacke.cmake @@ -30,6 +30,8 @@ set(CSRC lapacke_cgebrd_work.c lapacke_cgecon.c lapacke_cgecon_work.c + lapacke_cgecxx.c + lapacke_cgecxx_work.c lapacke_cgeequ.c lapacke_cgeequ_work.c lapacke_cgeequb.c @@ -659,6 +661,8 @@ set(DSRC lapacke_dgebrd_work.c lapacke_dgecon.c lapacke_dgecon_work.c + lapacke_dgecxx.c + lapacke_dgecxx_work.c lapacke_dgeequ.c lapacke_dgeequ_work.c lapacke_dgeequb.c @@ -1241,6 +1245,8 @@ set(SSRC lapacke_sgebrd_work.c lapacke_sgecon.c lapacke_sgecon_work.c + lapacke_sgecxx.c + lapacke_sgecxx_work.c lapacke_sgeequ.c lapacke_sgeequ_work.c lapacke_sgeequb.c @@ -1817,6 +1823,8 @@ set(ZSRC lapacke_zgebrd_work.c lapacke_zgecon.c lapacke_zgecon_work.c + lapacke_zgecxx.c + lapacke_zgecxx_work.c lapacke_zgeequ.c lapacke_zgeequ_work.c lapacke_zgeequb.c diff --git a/exports/gensymbol b/exports/gensymbol index 1429959cfe..8bbeb6ca37 100755 --- a/exports/gensymbol +++ b/exports/gensymbol @@ -917,6 +917,7 @@ lapackobjs2c="$lapackobjs2c clatrs3 crscl ctrsyl3 + cgecxx " # claqz0 # claqz1 @@ -932,6 +933,7 @@ lapackobjs2d="$lapackobjs2d dlarmm dlatrs3 dtrsyl3 + dgecxx " # dlaqz0 # dlaqz1 @@ -947,6 +949,7 @@ lapackobjs2s="$lapackobjs2s slarmm slatrs3 strsyl3 + sgecxx " lapackobjs2z="$lapackobjs2z @@ -957,6 +960,7 @@ lapackobjs2z="$lapackobjs2z zlatrs3 zrscl ztrsyl3 + zgecxx " # zlaqz0 # zlaqz1 @@ -1142,6 +1146,8 @@ lapackeobjsc=" LAPACKE_cgedmd_work LAPACKE_cgedmdq LAPACKE_cgedmdq_work + LAPACKE_cgecxx + LAPACKE_cgecxx_work LAPACKE_cgeequ LAPACKE_cgeequ_work LAPACKE_cgeequb @@ -1813,6 +1819,8 @@ lapackeobjsd=" LAPACKE_dgedmd_work LAPACKE_dgedmdq LAPACKE_dgedmdq_work + LAPACKE_dgecxx + LAPACKE_dgecxx_work LAPACKE_dgeequ LAPACKE_dgeequ_work LAPACKE_dgeequb @@ -2438,6 +2446,8 @@ lapackeobjss=" LAPACKE_sgedmd_work LAPACKE_sgedmdq LAPACKE_sgedmdq_work + LAPACKE_sgecxx + LAPACKE_sgecxx_work LAPACKE_sgeequ LAPACKE_sgeequ_work LAPACKE_sgeequb @@ -3059,6 +3069,8 @@ lapackeobjsz=" LAPACKE_zgedmd_work LAPACKE_zgedmdq LAPACKE_zgedmdq_work + LAPACKE_zgecxx + LAPACKE_zgecxx_work LAPACKE_zgeequ LAPACKE_zgeequ_work LAPACKE_zgeequb diff --git a/exports/gensymbol.pl b/exports/gensymbol.pl index 72e30dff2d..e7a3e74e89 100644 --- a/exports/gensymbol.pl +++ b/exports/gensymbol.pl @@ -893,7 +893,8 @@ claqp3rk, clatrs3, crscl, - ctrsyl3 + ctrsyl3, + cgecxx ); # claqz0 # claqz1 @@ -908,7 +909,8 @@ dlaqp3rk, dlarmm, dlatrs3, - dtrsyl3 + dtrsyl3, + dgecxx ); @lapackobjs2s = (@lapackobjs2s, @@ -918,7 +920,8 @@ slaqp3rk, slarmm, slatrs3, - strsyl3 + strsyl3, + sgecxx ); @lapackobjs2z = (@lapackobjs2z, @@ -928,7 +931,8 @@ zlaqp3rk, zlatrs3, zrscl, - ztrsyl3 + ztrsyl3, + zgecxx ); # zlaqz0 # zlaqz1 @@ -1110,6 +1114,8 @@ LAPACKE_cgedmd_work, LAPACKE_cgedmdq, LAPACKE_cgedmdq_work, + LAPACKE_cgecxx, + LAPACKE_cgecxx_work, LAPACKE_cgeequ, LAPACKE_cgeequ_work, LAPACKE_cgeequb, @@ -1780,6 +1786,8 @@ LAPACKE_dgedmd_work, LAPACKE_dgedmdq, LAPACKE_dgedmdq_work, + LAPACKE_dgecxx, + LAPACKE_dgecxx_work, LAPACKE_dgeequ, LAPACKE_dgeequ_work, LAPACKE_dgeequb, @@ -2405,6 +2413,8 @@ LAPACKE_sgedmd_work, LAPACKE_sgedmdq, LAPACKE_sgedmdq_work, + LAPACKE_sgecxx, + LAPACKE_sgecxx_work, LAPACKE_sgeequ, LAPACKE_sgeequ_work, LAPACKE_sgeequb, @@ -3026,6 +3036,8 @@ LAPACKE_zgedmd_work, LAPACKE_zgedmdq, LAPACKE_zgedmdq_work, + LAPACKE_zgecxx, + LAPACKE_zgecxx_work, LAPACKE_zgeequ, LAPACKE_zgeequ_work, LAPACKE_zgeequb, diff --git a/lapack-netlib/LAPACKE/include/lapack.h b/lapack-netlib/LAPACKE/include/lapack.h index 0ed9ad01a9..f9eb145035 100644 --- a/lapack-netlib/LAPACKE/include/lapack.h +++ b/lapack-netlib/LAPACKE/include/lapack.h @@ -1553,6 +1553,148 @@ void LAPACK_zgecon_base( #define LAPACK_zgecon(...) LAPACK_zgecon_base(__VA_ARGS__) #endif +#define LAPACK_cgecxx_base LAPACK_GLOBAL(cgecxx,CGECXX) +void LAPACK_cgecxx_base( + char const* fact, + char const* usesd, + lapack_int const* m, + lapack_int const* n, + lapack_int const* SESEL_ROWS, + lapack_int const* SEL_DESEL_COLS, + lapack_int const* kmaxfree, + float const* abstol, + float const* reltol, + lapack_complex_float* A, lapack_int const* lda, + lapack_int* k, + float* maxc2nrmk, + float* relmaxc2nrmk, + float* fnrmk, + lapack_int* IPIV, + lapack_int* JPIV, + lapack_complex_float* TAU, + lapack_complex_float* C, lapack_int const* ldc, + lapack_complex_float* QRC, lapack_int const* ldqrc, + lapack_complex_float* X, lapack_int const* ldx, + lapack_complex_float* work, lapack_int const* lwork, + float* rwork, lapack_int const* lrwork, + lapack_int* iwork, lapack_int const* liwork, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_cgecxx(...) LAPACK_cgecxx_base(__VA_ARGS__, 1, 1) +#else + #define LAPACK_cgecxx(...) LAPACK_cgecxx_base(__VA_ARGS__) +#endif + +#define LAPACK_dgecxx_base LAPACK_GLOBAL(dgecxx,DGECXX) +void LAPACK_dgecxx_base( + char const* fact, + char const* usesd, + lapack_int const* m, + lapack_int const* n, + lapack_int const* SESEL_ROWS, + lapack_int const* SEL_DESEL_COLS, + lapack_int const* kmaxfree, + double const* abstol, + double const* reltol, + double* A, lapack_int const* lda, + lapack_int* k, + double* maxc2nrmk, + double* relmaxc2nrmk, + double* fnrmk, + lapack_int* IPIV, + lapack_int* JPIV, + double* TAU, + double* C, lapack_int const* ldc, + double* QRC, lapack_int const* ldqrc, + double* X, lapack_int const* ldx, + double* work, lapack_int const* lwork, + lapack_int* iwork, lapack_int const* liwork, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_dgecxx(...) LAPACK_dgecxx_base(__VA_ARGS__, 1, 1) +#else + #define LAPACK_dgecxx(...) LAPACK_dgecxx_base(__VA_ARGS__) +#endif + +#define LAPACK_sgecxx_base LAPACK_GLOBAL(sgecxx,SGECXX) +void LAPACK_sgecxx_base( + char const* fact, + char const* usesd, + lapack_int const* m, + lapack_int const* n, + lapack_int const* SESEL_ROWS, + lapack_int const* SEL_DESEL_COLS, + lapack_int const* kmaxfree, + float const* abstol, + float const* reltol, + float* A, lapack_int const* lda, + lapack_int* k, + float* maxc2nrmk, + float* relmaxc2nrmk, + float* fnrmk, + lapack_int* IPIV, + lapack_int* JPIV, + float* TAU, + float* C, lapack_int const* ldc, + float* QRC, lapack_int const* ldqrc, + float* X, lapack_int const* ldx, + float* work, lapack_int const* lwork, + lapack_int* iwork, lapack_int const* liwork, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_sgecxx(...) LAPACK_sgecxx_base(__VA_ARGS__, 1, 1) +#else + #define LAPACK_sgecxx(...) LAPACK_sgecxx_base(__VA_ARGS__) +#endif + +#define LAPACK_zgecxx_base LAPACK_GLOBAL(zgecxx,ZGECXX) +void LAPACK_zgecxx_base( + char const* fact, + char const* usesd, + lapack_int const* m, + lapack_int const* n, + lapack_int const* SESEL_ROWS, + lapack_int const* SEL_DESEL_COLS, + lapack_int const* kmaxfree, + double const* abstol, + double const* reltol, + lapack_complex_double* A, lapack_int const* lda, + lapack_int* k, + double* maxc2nrmk, + double* relmaxc2nrmk, + double* fnrmk, + lapack_int* IPIV, + lapack_int* JPIV, + lapack_complex_double* TAU, + lapack_complex_double* C, lapack_int const* ldc, + lapack_complex_double* QRC, lapack_int const* ldqrc, + lapack_complex_double* X, lapack_int const* ldx, + lapack_complex_double* work, lapack_int const* lwork, + double* rwork, lapack_int const* lrwork, + lapack_int* iwork, lapack_int const* liwork, + lapack_int* info +#ifdef LAPACK_FORTRAN_STRLEN_END + , FORTRAN_STRLEN, FORTRAN_STRLEN +#endif +); +#ifdef LAPACK_FORTRAN_STRLEN_END + #define LAPACK_zgecxx(...) LAPACK_zgecxx_base(__VA_ARGS__, 1, 1) +#else + #define LAPACK_zgecxx(...) LAPACK_zgecxx_base(__VA_ARGS__) +#endif + #define LAPACK_cgeequ LAPACK_GLOBAL(cgeequ,CGEEQU) void LAPACK_cgeequ( lapack_int const* m, lapack_int const* n, diff --git a/lapack-netlib/LAPACKE/include/lapacke.h b/lapack-netlib/LAPACKE/include/lapacke.h index 377e2a6bbc..25998b76bf 100644 --- a/lapack-netlib/LAPACKE/include/lapacke.h +++ b/lapack-netlib/LAPACKE/include/lapacke.h @@ -448,6 +448,45 @@ lapack_int LAPACKE_zgecon( int matrix_layout, char norm, lapack_int n, const lapack_complex_double* a, lapack_int lda, double anorm, double* rcond ); +lapack_int LAPACKE_sgecxx( int matrix_layout, + char fact, char usesd, lapack_int m, lapack_int n, + lapack_int* desel_rows, lapack_int* sel_desel_cols, + lapack_int kmaxfree, float abstol, float reltol, + float* a, lapack_int lda, lapack_int* k, + float* maxc2nrmk, float* relmaxc2nrmk, float* fnrmk, + lapack_int* ipiv, lapack_int* jpiv, float* tau, + float* c, lapack_int ldc, float* qrc, lapack_int ldqrc, + float* x, lapack_int ldx ); +lapack_int LAPACKE_dgecxx( int matrix_layout, + char fact, char usesd, lapack_int m, lapack_int n, + lapack_int* desel_rows, lapack_int* sel_desel_cols, + lapack_int kmaxfree, double abstol, double reltol, + double* a, lapack_int lda, lapack_int* k, + double* maxc2nrmk, double* relmaxc2nrmk, double* fnrmk, + lapack_int* ipiv, lapack_int* jpiv, double* tau, + double* c, lapack_int ldc, double* qrc, lapack_int ldqrc, + double* x, lapack_int ldx ); +lapack_int LAPACKE_cgecxx( int matrix_layout, + char fact, char usesd, lapack_int m, lapack_int n, + lapack_int* desel_rows, lapack_int* sel_desel_cols, + lapack_int kmaxfree, float abstol, float reltol, + lapack_complex_float* a, lapack_int lda, lapack_int* k, + float* maxc2nrmk, float* relmaxc2nrmk, float* fnrmk, + lapack_int* ipiv, lapack_int* jpiv, lapack_complex_float* tau, + lapack_complex_float* c, lapack_int ldc, + lapack_complex_float* qrc, lapack_int ldqrc, + lapack_complex_float* x, lapack_int ldx ); +lapack_int LAPACKE_zgecxx( int matrix_layout, + char fact, char usesd, lapack_int m, lapack_int n, + lapack_int* desel_rows, lapack_int* sel_desel_cols, + lapack_int kmaxfree, double abstol, double reltol, + lapack_complex_double* a, lapack_int lda, lapack_int* k, + double* maxc2nrmk, double* relmaxc2nrmk, double* fnrmk, + lapack_int* ipiv, lapack_int* jpiv, lapack_complex_double* tau, + lapack_complex_double* c, lapack_int ldc, + lapack_complex_double* qrc, lapack_int ldqrc, + lapack_complex_double* x, lapack_int ldx ); + lapack_int LAPACKE_sgeequ( int matrix_layout, lapack_int m, lapack_int n, const float* a, lapack_int lda, float* r, float* c, float* rowcnd, float* colcnd, float* amax ); @@ -5175,6 +5214,53 @@ lapack_int LAPACKE_zgecon_work( int matrix_layout, char norm, lapack_int n, double anorm, double* rcond, lapack_complex_double* work, double* rwork ); +lapack_int LAPACKE_sgecxx_work( int matrix_layout, char fact, char usesd, + lapack_int m, lapack_int n, + lapack_int* desel_rows, lapack_int* sel_desel_cols, + lapack_int kmaxfree, float abstol, float reltol, + float* a, lapack_int lda, lapack_int* k, + float* maxc2nrmk, float* relmaxc2nrmk, float* fnrmk, + lapack_int* ipiv, lapack_int* jpiv, float* tau, + float* c, lapack_int ldc, float* qrc, lapack_int ldqrc, + float* x, lapack_int ldx, float* work, lapack_int lwork, + lapack_int* iwork, lapack_int liwork ); +lapack_int LAPACKE_dgecxx_work( int matrix_layout, char fact, char usesd, + lapack_int m, lapack_int n, + lapack_int* desel_rows, lapack_int* sel_desel_cols, + lapack_int kmaxfree, double abstol, double reltol, + double* a, lapack_int lda, lapack_int* k, + double* maxc2nrmk, double* relmaxc2nrmk, double* fnrmk, + lapack_int* ipiv, lapack_int* jpiv, double* tau, + double* c, lapack_int ldc, double* qrc, lapack_int ldqrc, + double* x, lapack_int ldx, double* work, lapack_int lwork, + lapack_int* iwork, lapack_int liwork ); +lapack_int LAPACKE_cgecxx_work( int matrix_layout, char fact, char usesd, + lapack_int m, lapack_int n, + lapack_int* desel_rows, lapack_int* sel_desel_cols, + lapack_int kmaxfree, float abstol, float reltol, + lapack_complex_float* a, lapack_int lda, lapack_int* k, + float* maxc2nrmk, float* relmaxc2nrmk, float* fnrmk, + lapack_int* ipiv, lapack_int* jpiv, lapack_complex_float* tau, + lapack_complex_float* c, lapack_int ldc, + lapack_complex_float* qrc, lapack_int ldqrc, + lapack_complex_float* x, lapack_int ldx, + lapack_complex_float* work, lapack_int lwork, + float* rwork, lapack_int lrwork, + lapack_int* iwork, lapack_int liwork ); +lapack_int LAPACKE_zgecxx_work( int matrix_layout, char fact, char usesd, + lapack_int m, lapack_int n, + lapack_int* desel_rows, lapack_int* sel_desel_cols, + lapack_int kmaxfree, double abstol, double reltol, + lapack_complex_double* a, lapack_int lda, lapack_int* k, + double* maxc2nrmk, double* relmaxc2nrmk, double* fnrmk, + lapack_int* ipiv, lapack_int* jpiv, lapack_complex_double* tau, + lapack_complex_double* c, lapack_int ldc, + lapack_complex_double* qrc, lapack_int ldqrc, + lapack_complex_double* x, lapack_int ldx, + lapack_complex_double* work, lapack_int lwork, + double* rwork, lapack_int lrwork, + lapack_int* iwork, lapack_int liwork ); + lapack_int LAPACKE_sgeequ_work( int matrix_layout, lapack_int m, lapack_int n, const float* a, lapack_int lda, float* r, float* c, float* rowcnd, float* colcnd, diff --git a/lapack-netlib/LAPACKE/src/Makefile b/lapack-netlib/LAPACKE/src/Makefile index 969288f424..c99da4cfb9 100644 --- a/lapack-netlib/LAPACKE/src/Makefile +++ b/lapack-netlib/LAPACKE/src/Makefile @@ -77,6 +77,8 @@ lapacke_cgebrd.o \ lapacke_cgebrd_work.o \ lapacke_cgecon.o \ lapacke_cgecon_work.o \ +lapacke_cgecxx.o \ +lapacke_cgecxx_work.o \ lapacke_cgeequ.o \ lapacke_cgeequ_work.o \ lapacke_cgeequb.o \ @@ -707,6 +709,8 @@ lapacke_dgebrd.o \ lapacke_dgebrd_work.o \ lapacke_dgecon.o \ lapacke_dgecon_work.o \ +lapacke_dgecxx.o \ +lapacke_dgecxx_work.o \ lapacke_dgeequ.o \ lapacke_dgeequ_work.o \ lapacke_dgeequb.o \ @@ -1291,6 +1295,8 @@ lapacke_sgebrd.o \ lapacke_sgebrd_work.o \ lapacke_sgecon.o \ lapacke_sgecon_work.o \ +lapacke_sgecxx.o \ +lapacke_sgecxx_work.o \ lapacke_sgeequ.o \ lapacke_sgeequ_work.o \ lapacke_sgeequb.o \ @@ -1865,6 +1871,8 @@ lapacke_zgebrd.o \ lapacke_zgebrd_work.o \ lapacke_zgecon.o \ lapacke_zgecon_work.o \ +lapacke_zgecxx.o \ +lapacke_zgecxx_work.o \ lapacke_zgeequ.o \ lapacke_zgeequ_work.o \ lapacke_zgeequb.o \ diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgecxx.c b/lapack-netlib/LAPACKE/src/lapacke_cgecxx.c new file mode 100644 index 0000000000..16ba287f35 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cgecxx.c @@ -0,0 +1,115 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function cgecxx +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cgecxx( int matrix_layout, + char fact, char usesd, lapack_int m, lapack_int n, + lapack_int* desel_rows, lapack_int* sel_desel_cols, + lapack_int kmaxfree, float abstol, float reltol, + lapack_complex_float* a, lapack_int lda, lapack_int* k, + float* maxc2nrmk, float* relmaxc2nrmk, float* fnrmk, + lapack_int* ipiv, lapack_int* jpiv, lapack_complex_float* tau, + lapack_complex_float* c, lapack_int ldc, + lapack_complex_float* qrc, lapack_int ldqrc, + lapack_complex_float* x, lapack_int ldx ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_int lrwork = -1; + lapack_int liwork = -1; + lapack_complex_float* work = NULL; + float* rwork = NULL; + lapack_int* iwork = NULL; + lapack_complex_float work_query; + float rwork_query; + lapack_int iwork_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_cgecxx", -1 ); + return -1; + } + +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( LAPACKE_cge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -11; + } + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_cgecxx_work( matrix_layout, fact, usesd, m, n, + desel_rows, sel_desel_cols, kmaxfree, abstol, reltol, + a, lda, k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, ldc, qrc, ldqrc, x, ldx, + &work_query, lwork, &rwork_query, lrwork, &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = iwork_query; + lrwork = (lapack_int)rwork_query; + lwork = LAPACK_C2INT( work_query ); + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + rwork = (float*)LAPACKE_malloc( sizeof(float) * lrwork ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + work = (lapack_complex_float*) + LAPACKE_malloc( sizeof(lapack_complex_float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_2; + } + /* Call middle-level interface */ + info = LAPACKE_cgecxx_work( matrix_layout, fact, usesd, m, n, + desel_rows, sel_desel_cols, kmaxfree, abstol, reltol, + a, lda, k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, ldc, qrc, ldqrc, x, ldx, + work, lwork, rwork, lrwork, iwork, liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_2: + LAPACKE_free( rwork ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cgecxx", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_cgecxx_work.c b/lapack-netlib/LAPACKE/src/lapacke_cgecxx_work.c new file mode 100644 index 0000000000..7ef9c8adeb --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_cgecxx_work.c @@ -0,0 +1,191 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function cgecxx +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_cgecxx_work( int matrix_layout, + char fact, char usesd, lapack_int m, lapack_int n, + lapack_int* desel_rows, lapack_int* sel_desel_cols, + lapack_int kmaxfree, float abstol, float reltol, + lapack_complex_float* a, lapack_int lda, lapack_int* k, + float* maxc2nrmk, float* relmaxc2nrmk, float* fnrmk, + lapack_int* ipiv, lapack_int* jpiv, lapack_complex_float* tau, + lapack_complex_float* c, lapack_int ldc, + lapack_complex_float* qrc, lapack_int ldqrc, + lapack_complex_float* x, lapack_int ldx, + lapack_complex_float* work, lapack_int lwork, + float* rwork, lapack_int lrwork, + lapack_int* iwork, lapack_int liwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_cgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a, &lda, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, &ldc, qrc, &ldqrc, x, &ldx, + work, &lwork, rwork, &lrwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_logical fact_p = LAPACKE_lsame( fact, 'p' ); + lapack_logical fact_c = LAPACKE_lsame( fact, 'c' ); + lapack_logical fact_x = LAPACKE_lsame( fact, 'x' ); + lapack_int lda_t = MAX(1,m); + lapack_int ldc_t = MAX(1,m); + lapack_int ldqrc_t = MAX(1,m); + lapack_int ldx_t = MAX(1,m); + lapack_complex_float* a_t = NULL; + lapack_complex_float* c_t = NULL; + lapack_complex_float* qrc_t = NULL; + lapack_complex_float* x_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -12; + LAPACKE_xerbla( "LAPACKE_cgecxx_work", info ); + return info; + } + if( ldc < n ) { + info = -21; + LAPACKE_xerbla( "LAPACKE_cgecxx_work", info ); + return info; + } + if( ldqrc < MIN(m,n) ) { + info = -23; + LAPACKE_xerbla( "LAPACKE_cgecxx_work", info ); + return info; + } + if( ldx < n ) { + info = -25; + LAPACKE_xerbla( "LAPACKE_cgecxx_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 || lrwork == -1 || liwork == -1 ) { + LAPACK_cgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a, &lda_t, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, &ldc_t, qrc, &ldqrc_t, x, &ldx_t, + work, &lwork, rwork, &lrwork, iwork, &liwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_float*)LAPACKE_malloc( sizeof(lapack_complex_float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( fact_c || fact_x ) { + c_t = (lapack_complex_float*)LAPACKE_malloc( sizeof(lapack_complex_float) * ldc_t * MAX(1,n) ); + if( c_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + if( fact_x ) { + qrc_t = (lapack_complex_float*)LAPACKE_malloc( sizeof(lapack_complex_float) * ldqrc_t * MAX(1,MIN(m,n)) ); + if( qrc_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + x_t = (lapack_complex_float*)LAPACKE_malloc( sizeof(lapack_complex_float) * ldx_t * MAX(1,n) ); + if( x_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_3; + } + } + /* Transpose input matrices */ + LAPACKE_cge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); + if( fact_c || fact_x ) { + LAPACKE_cge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t ); + } + if( fact_x ) { + LAPACKE_cge_trans( matrix_layout, m, MIN(m,n), qrc, ldqrc, qrc_t, ldqrc_t ); + LAPACKE_cge_trans( matrix_layout, m, n, x, ldx, x_t, ldx_t ); + } + /* Call LAPACK function and adjust info */ + if( fact_p ) { + LAPACK_cgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a_t, &lda_t, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, &ldc_t, qrc, &ldqrc_t, x, &ldx_t, + work, &lwork, rwork, &lrwork, iwork, &liwork, &info ); + } else if ( fact_c ) { + LAPACK_cgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a_t, &lda_t, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c_t, &ldc_t, qrc, &ldqrc_t, x, &ldx_t, + work, &lwork, rwork, &lrwork, iwork, &liwork, &info ); + } else if ( fact_x ) { + LAPACK_cgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a_t, &lda_t, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c_t, &ldc_t, qrc_t, &ldqrc_t, x_t, &ldx_t, + work, &lwork, rwork, &lrwork, iwork, &liwork, &info ); + } + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_cge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); + if( fact_c || fact_x ) { + LAPACKE_cge_trans( LAPACK_COL_MAJOR, m, n, c_t, ldc_t, c, ldc ); + } + if( fact_x ) { + LAPACKE_cge_trans( LAPACK_COL_MAJOR, m, MIN(m,n), qrc_t, ldqrc_t, qrc, ldqrc ); + LAPACKE_cge_trans( LAPACK_COL_MAJOR, m, n, x_t, ldx_t, x, ldx ); + } + /* Release memory and exit */ + if( fact_x ) { + LAPACKE_free( x_t ); + } +exit_level_3: + if( fact_x ) { + LAPACKE_free( qrc_t ); + } +exit_level_2: + if( fact_c || fact_x ) { + LAPACKE_free( c_t ); + } +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_cgecxx_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_cgecxx_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgecxx.c b/lapack-netlib/LAPACKE/src/lapacke_dgecxx.c new file mode 100644 index 0000000000..6c0be2f9cc --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dgecxx.c @@ -0,0 +1,102 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dgecxx +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dgecxx( int matrix_layout, + char fact, char usesd, lapack_int m, lapack_int n, + lapack_int* desel_rows, lapack_int* sel_desel_cols, + lapack_int kmaxfree, double abstol, double reltol, + double* a, lapack_int lda, lapack_int* k, + double* maxc2nrmk, double* relmaxc2nrmk, double* fnrmk, + lapack_int* ipiv, lapack_int* jpiv, double* tau, + double* c, lapack_int ldc, double* qrc, lapack_int ldqrc, + double* x, lapack_int ldx ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_int liwork = -1; + double* work = NULL; + lapack_int* iwork = NULL; + double work_query; + lapack_int iwork_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_dgecxx", -1 ); + return -1; + } + +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( LAPACKE_dge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -11; + } + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_dgecxx_work( matrix_layout, fact, usesd, m, n, + desel_rows, sel_desel_cols, kmaxfree, abstol, reltol, + a, lda, k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, ldc, qrc, ldqrc, x, ldx, + &work_query, lwork, &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = iwork_query; + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_dgecxx_work( matrix_layout, fact, usesd, m, n, + desel_rows, sel_desel_cols, kmaxfree, abstol, reltol, + a, lda, k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, ldc, qrc, ldqrc, x, ldx, + work, lwork, iwork, liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dgecxx", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dgecxx_work.c b/lapack-netlib/LAPACKE/src/lapacke_dgecxx_work.c new file mode 100644 index 0000000000..d936d85d8c --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dgecxx_work.c @@ -0,0 +1,188 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dgecxx +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_dgecxx_work( int matrix_layout, + char fact, char usesd, lapack_int m, lapack_int n, + lapack_int* desel_rows, lapack_int* sel_desel_cols, + lapack_int kmaxfree, double abstol, double reltol, + double* a, lapack_int lda, lapack_int* k, + double* maxc2nrmk, double* relmaxc2nrmk, double* fnrmk, + lapack_int* ipiv, lapack_int* jpiv, double* tau, + double* c, lapack_int ldc, double* qrc, lapack_int ldqrc, + double* x, lapack_int ldx, double* work, lapack_int lwork, + lapack_int* iwork, lapack_int liwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_dgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a, &lda, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, &ldc, qrc, &ldqrc, x, &ldx, + work, &lwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_logical fact_p = LAPACKE_lsame( fact, 'p' ); + lapack_logical fact_c = LAPACKE_lsame( fact, 'c' ); + lapack_logical fact_x = LAPACKE_lsame( fact, 'x' ); + lapack_int lda_t = MAX(1,m); + lapack_int ldc_t = MAX(1,m); + lapack_int ldqrc_t = MAX(1,m); + lapack_int ldx_t = MAX(1,m); + double* a_t = NULL; + double* c_t = NULL; + double* qrc_t = NULL; + double* x_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -12; + LAPACKE_xerbla( "LAPACKE_dgecxx_work", info ); + return info; + } + if( ldc < n ) { + info = -21; + LAPACKE_xerbla( "LAPACKE_dgecxx_work", info ); + return info; + } + if( ldqrc < MIN(m,n) ) { + info = -23; + LAPACKE_xerbla( "LAPACKE_dgecxx_work", info ); + return info; + } + if( ldx < n ) { + info = -25; + LAPACKE_xerbla( "LAPACKE_dgecxx_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 || liwork == -1 ) { + LAPACK_dgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a, &lda_t, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, &ldc_t, qrc, &ldqrc_t, x, &ldx_t, + work, &lwork, iwork, &liwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (double*)LAPACKE_malloc( sizeof(double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( fact_c || fact_x ) { + c_t = (double*)LAPACKE_malloc( sizeof(double) * ldc_t * MAX(1,n) ); + if( c_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + if( fact_x ) { + qrc_t = (double*)LAPACKE_malloc( sizeof(double) * ldqrc_t * MAX(1,MIN(m,n)) ); + if( qrc_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + x_t = (double*)LAPACKE_malloc( sizeof(double) * ldx_t * MAX(1,n) ); + if( x_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_3; + } + } + /* Transpose input matrices */ + LAPACKE_dge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); + if( fact_c || fact_x ) { + LAPACKE_dge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t ); + } + if( fact_x ) { + LAPACKE_dge_trans( matrix_layout, m, MIN(m,n), qrc, ldqrc, qrc_t, ldqrc_t ); + LAPACKE_dge_trans( matrix_layout, m, n, x, ldx, x_t, ldx_t ); + } + /* Call LAPACK function and adjust info */ + if( fact_p ) { + LAPACK_dgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a_t, &lda_t, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, &ldc_t, qrc, &ldqrc_t, x, &ldx_t, + work, &lwork, iwork, &liwork, &info ); + } else if ( fact_c ) { + LAPACK_dgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a_t, &lda_t, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c_t, &ldc_t, qrc, &ldqrc_t, x, &ldx_t, + work, &lwork, iwork, &liwork, &info ); + } else if ( fact_x ) { + LAPACK_dgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a_t, &lda_t, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c_t, &ldc_t, qrc_t, &ldqrc_t, x_t, &ldx_t, + work, &lwork, iwork, &liwork, &info ); + } + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_dge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); + if( fact_c || fact_x ) { + LAPACKE_dge_trans( LAPACK_COL_MAJOR, m, n, c_t, ldc_t, c, ldc ); + } + if( fact_x ) { + LAPACKE_dge_trans( LAPACK_COL_MAJOR, m, MIN(m,n), qrc_t, ldqrc_t, qrc, ldqrc ); + LAPACKE_dge_trans( LAPACK_COL_MAJOR, m, n, x_t, ldx_t, x, ldx ); + } + /* Release memory and exit */ + if( fact_x ) { + LAPACKE_free( x_t ); + } +exit_level_3: + if( fact_x ) { + LAPACKE_free( qrc_t ); + } +exit_level_2: + if( fact_c || fact_x ) { + LAPACKE_free( c_t ); + } +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_dgecxx_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_dgecxx_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgecxx.c b/lapack-netlib/LAPACKE/src/lapacke_sgecxx.c new file mode 100644 index 0000000000..bb450da7aa --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_sgecxx.c @@ -0,0 +1,102 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function sgecxx +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sgecxx( int matrix_layout, + char fact, char usesd, lapack_int m, lapack_int n, + lapack_int* desel_rows, lapack_int* sel_desel_cols, + lapack_int kmaxfree, float abstol, float reltol, + float* a, lapack_int lda, lapack_int* k, + float* maxc2nrmk, float* relmaxc2nrmk, float* fnrmk, + lapack_int* ipiv, lapack_int* jpiv, float* tau, + float* c, lapack_int ldc, float* qrc, lapack_int ldqrc, + float* x, lapack_int ldx ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_int liwork = -1; + float* work = NULL; + lapack_int* iwork = NULL; + float work_query; + lapack_int iwork_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_sgecxx", -1 ); + return -1; + } + +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( LAPACKE_sge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -11; + } + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_sgecxx_work( matrix_layout, fact, usesd, m, n, + desel_rows, sel_desel_cols, kmaxfree, abstol, reltol, + a, lda, k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, ldc, qrc, ldqrc, x, ldx, + &work_query, lwork, &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = iwork_query; + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = LAPACKE_sgecxx_work( matrix_layout, fact, usesd, m, n, + desel_rows, sel_desel_cols, kmaxfree, abstol, reltol, + a, lda, k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, ldc, qrc, ldqrc, x, ldx, + work, lwork, iwork, liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sgecxx", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_sgecxx_work.c b/lapack-netlib/LAPACKE/src/lapacke_sgecxx_work.c new file mode 100644 index 0000000000..30f9c2ce66 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_sgecxx_work.c @@ -0,0 +1,188 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function sgecxx +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_sgecxx_work( int matrix_layout, + char fact, char usesd, lapack_int m, lapack_int n, + lapack_int* desel_rows, lapack_int* sel_desel_cols, + lapack_int kmaxfree, float abstol, float reltol, + float* a, lapack_int lda, lapack_int* k, + float* maxc2nrmk, float* relmaxc2nrmk, float* fnrmk, + lapack_int* ipiv, lapack_int* jpiv, float* tau, + float* c, lapack_int ldc, float* qrc, lapack_int ldqrc, + float* x, lapack_int ldx, float* work, lapack_int lwork, + lapack_int* iwork, lapack_int liwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_sgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a, &lda, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, &ldc, qrc, &ldqrc, x, &ldx, + work, &lwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_logical fact_p = LAPACKE_lsame( fact, 'p' ); + lapack_logical fact_c = LAPACKE_lsame( fact, 'c' ); + lapack_logical fact_x = LAPACKE_lsame( fact, 'x' ); + lapack_int lda_t = MAX(1,m); + lapack_int ldc_t = MAX(1,m); + lapack_int ldqrc_t = MAX(1,m); + lapack_int ldx_t = MAX(1,m); + float* a_t = NULL; + float* c_t = NULL; + float* qrc_t = NULL; + float* x_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -12; + LAPACKE_xerbla( "LAPACKE_sgecxx_work", info ); + return info; + } + if( ldc < n ) { + info = -21; + LAPACKE_xerbla( "LAPACKE_sgecxx_work", info ); + return info; + } + if( ldqrc < MIN(m,n) ) { + info = -23; + LAPACKE_xerbla( "LAPACKE_sgecxx_work", info ); + return info; + } + if( ldx < n ) { + info = -25; + LAPACKE_xerbla( "LAPACKE_sgecxx_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 || liwork == -1 ) { + LAPACK_sgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a, &lda_t, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, &ldc_t, qrc, &ldqrc_t, x, &ldx_t, + work, &lwork, iwork, &liwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (float*)LAPACKE_malloc( sizeof(float) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( fact_c || fact_x ) { + c_t = (float*)LAPACKE_malloc( sizeof(float) * ldc_t * MAX(1,n) ); + if( c_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + if( fact_x ) { + qrc_t = (float*)LAPACKE_malloc( sizeof(float) * ldqrc_t * MAX(1,MIN(m,n)) ); + if( qrc_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + x_t = (float*)LAPACKE_malloc( sizeof(float) * ldx_t * MAX(1,n) ); + if( x_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_3; + } + } + /* Transpose input matrices */ + LAPACKE_sge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); + if( fact_c || fact_x ) { + LAPACKE_sge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t ); + } + if( fact_x ) { + LAPACKE_sge_trans( matrix_layout, m, MIN(m,n), qrc, ldqrc, qrc_t, ldqrc_t ); + LAPACKE_sge_trans( matrix_layout, m, n, x, ldx, x_t, ldx_t ); + } + /* Call LAPACK function and adjust info */ + if( fact_p ) { + LAPACK_sgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a_t, &lda_t, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, &ldc_t, qrc, &ldqrc_t, x, &ldx_t, + work, &lwork, iwork, &liwork, &info ); + } else if ( fact_c ) { + LAPACK_sgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a_t, &lda_t, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c_t, &ldc_t, qrc, &ldqrc_t, x, &ldx_t, + work, &lwork, iwork, &liwork, &info ); + } else if ( fact_x ) { + LAPACK_sgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a_t, &lda_t, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c_t, &ldc_t, qrc_t, &ldqrc_t, x_t, &ldx_t, + work, &lwork, iwork, &liwork, &info ); + } + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_sge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); + if( fact_c || fact_x ) { + LAPACKE_sge_trans( LAPACK_COL_MAJOR, m, n, c_t, ldc_t, c, ldc ); + } + if( fact_x ) { + LAPACKE_sge_trans( LAPACK_COL_MAJOR, m, MIN(m,n), qrc_t, ldqrc_t, qrc, ldqrc ); + LAPACKE_sge_trans( LAPACK_COL_MAJOR, m, n, x_t, ldx_t, x, ldx ); + } + /* Release memory and exit */ + if( fact_x ) { + LAPACKE_free( x_t ); + } +exit_level_3: + if( fact_x ) { + LAPACKE_free( qrc_t ); + } +exit_level_2: + if( fact_c || fact_x ) { + LAPACKE_free( c_t ); + } +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_sgecxx_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_sgecxx_work", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgecxx.c b/lapack-netlib/LAPACKE/src/lapacke_zgecxx.c new file mode 100644 index 0000000000..be90a6c2fc --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zgecxx.c @@ -0,0 +1,115 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function zgecxx +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zgecxx( int matrix_layout, + char fact, char usesd, lapack_int m, lapack_int n, + lapack_int* desel_rows, lapack_int* sel_desel_cols, + lapack_int kmaxfree, double abstol, double reltol, + lapack_complex_double* a, lapack_int lda, lapack_int* k, + double* maxc2nrmk, double* relmaxc2nrmk, double* fnrmk, + lapack_int* ipiv, lapack_int* jpiv, lapack_complex_double* tau, + lapack_complex_double* c, lapack_int ldc, + lapack_complex_double* qrc, lapack_int ldqrc, + lapack_complex_double* x, lapack_int ldx ) +{ + lapack_int info = 0; + lapack_int lwork = -1; + lapack_int lrwork = -1; + lapack_int liwork = -1; + lapack_complex_double* work = NULL; + double* rwork = NULL; + lapack_int* iwork = NULL; + lapack_complex_double work_query; + double rwork_query; + lapack_int iwork_query; + if( matrix_layout != LAPACK_COL_MAJOR && matrix_layout != LAPACK_ROW_MAJOR ) { + LAPACKE_xerbla( "LAPACKE_zgecxx", -1 ); + return -1; + } + +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( LAPACKE_zge_nancheck( matrix_layout, m, n, a, lda ) ) { + return -11; + } + } +#endif + /* Query optimal working array(s) size */ + info = LAPACKE_zgecxx_work( matrix_layout, fact, usesd, m, n, + desel_rows, sel_desel_cols, kmaxfree, abstol, reltol, + a, lda, k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, ldc, qrc, ldqrc, x, ldx, + &work_query, lwork, &rwork_query, lrwork, &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = iwork_query; + lrwork = (lapack_int)rwork_query; + lwork = LAPACK_Z2INT( work_query ); + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + rwork = (double*)LAPACKE_malloc( sizeof(double) * lrwork ); + if( rwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + work = (lapack_complex_double*) + LAPACKE_malloc( sizeof(lapack_complex_double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_2; + } + /* Call middle-level interface */ + info = LAPACKE_zgecxx_work( matrix_layout, fact, usesd, m, n, + desel_rows, sel_desel_cols, kmaxfree, abstol, reltol, + a, lda, k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, ldc, qrc, ldqrc, x, ldx, + work, lwork, rwork, lrwork, iwork, liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_2: + LAPACKE_free( rwork ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zgecxx", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_zgecxx_work.c b/lapack-netlib/LAPACKE/src/lapacke_zgecxx_work.c new file mode 100644 index 0000000000..81596a83d8 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_zgecxx_work.c @@ -0,0 +1,191 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function zgecxx +* Author: Intel Corporation +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int LAPACKE_zgecxx_work( int matrix_layout, + char fact, char usesd, lapack_int m, lapack_int n, + lapack_int* desel_rows, lapack_int* sel_desel_cols, + lapack_int kmaxfree, double abstol, double reltol, + lapack_complex_double* a, lapack_int lda, lapack_int* k, + double* maxc2nrmk, double* relmaxc2nrmk, double* fnrmk, + lapack_int* ipiv, lapack_int* jpiv, lapack_complex_double* tau, + lapack_complex_double* c, lapack_int ldc, + lapack_complex_double* qrc, lapack_int ldqrc, + lapack_complex_double* x, lapack_int ldx, + lapack_complex_double* work, lapack_int lwork, + double* rwork, lapack_int lrwork, + lapack_int* iwork, lapack_int liwork ) +{ + lapack_int info = 0; + if( matrix_layout == LAPACK_COL_MAJOR ) { + /* Call LAPACK function and adjust info */ + LAPACK_zgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a, &lda, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, &ldc, qrc, &ldqrc, x, &ldx, + work, &lwork, rwork, &lrwork, iwork, &liwork, &info ); + if( info < 0 ) { + info = info - 1; + } + } else if( matrix_layout == LAPACK_ROW_MAJOR ) { + lapack_logical fact_p = LAPACKE_lsame( fact, 'p' ); + lapack_logical fact_c = LAPACKE_lsame( fact, 'c' ); + lapack_logical fact_x = LAPACKE_lsame( fact, 'x' ); + lapack_int lda_t = MAX(1,m); + lapack_int ldc_t = MAX(1,m); + lapack_int ldqrc_t = MAX(1,m); + lapack_int ldx_t = MAX(1,m); + lapack_complex_double* a_t = NULL; + lapack_complex_double* c_t = NULL; + lapack_complex_double* qrc_t = NULL; + lapack_complex_double* x_t = NULL; + /* Check leading dimension(s) */ + if( lda < n ) { + info = -12; + LAPACKE_xerbla( "LAPACKE_zgecxx_work", info ); + return info; + } + if( ldc < n ) { + info = -21; + LAPACKE_xerbla( "LAPACKE_zgecxx_work", info ); + return info; + } + if( ldqrc < MIN(m,n) ) { + info = -23; + LAPACKE_xerbla( "LAPACKE_zgecxx_work", info ); + return info; + } + if( ldx < n ) { + info = -25; + LAPACKE_xerbla( "LAPACKE_zgecxx_work", info ); + return info; + } + /* Query optimal working array(s) size if requested */ + if( lwork == -1 || lrwork == -1 || liwork == -1 ) { + LAPACK_zgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a, &lda_t, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, &ldc_t, qrc, &ldqrc_t, x, &ldx_t, + work, &lwork, rwork, &lrwork, iwork, &liwork, &info ); + return (info < 0) ? (info - 1) : info; + } + /* Allocate memory for temporary array(s) */ + a_t = (lapack_complex_double*)LAPACKE_malloc( sizeof(lapack_complex_double) * lda_t * MAX(1,n) ); + if( a_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_0; + } + if( fact_c || fact_x ) { + c_t = (lapack_complex_double*)LAPACKE_malloc( sizeof(lapack_complex_double) * ldc_t * MAX(1,n) ); + if( c_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_1; + } + } + if( fact_x ) { + qrc_t = (lapack_complex_double*)LAPACKE_malloc( sizeof(lapack_complex_double) * ldqrc_t * MAX(1,MIN(m,n)) ); + if( qrc_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_2; + } + x_t = (lapack_complex_double*)LAPACKE_malloc( sizeof(lapack_complex_double) * ldx_t * MAX(1,n) ); + if( x_t == NULL ) { + info = LAPACK_TRANSPOSE_MEMORY_ERROR; + goto exit_level_3; + } + } + /* Transpose input matrices */ + LAPACKE_zge_trans( matrix_layout, m, n, a, lda, a_t, lda_t ); + if( fact_c || fact_x ) { + LAPACKE_zge_trans( matrix_layout, m, n, c, ldc, c_t, ldc_t ); + } + if( fact_x ) { + LAPACKE_zge_trans( matrix_layout, m, MIN(m,n), qrc, ldqrc, qrc_t, ldqrc_t ); + LAPACKE_zge_trans( matrix_layout, m, n, x, ldx, x_t, ldx_t ); + } + /* Call LAPACK function and adjust info */ + if( fact_p ) { + LAPACK_zgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a_t, &lda_t, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c, &ldc_t, qrc, &ldqrc_t, x, &ldx_t, + work, &lwork, rwork, &lrwork, iwork, &liwork, &info ); + } else if ( fact_c ) { + LAPACK_zgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a_t, &lda_t, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c_t, &ldc_t, qrc, &ldqrc_t, x, &ldx_t, + work, &lwork, rwork, &lrwork, iwork, &liwork, &info ); + } else if ( fact_x ) { + LAPACK_zgecxx( &fact, &usesd, &m, &n, desel_rows, sel_desel_cols, + &kmaxfree, &abstol, &reltol, a_t, &lda_t, + k, maxc2nrmk, relmaxc2nrmk, fnrmk, + ipiv, jpiv, tau, c_t, &ldc_t, qrc_t, &ldqrc_t, x_t, &ldx_t, + work, &lwork, rwork, &lrwork, iwork, &liwork, &info ); + } + if( info < 0 ) { + info = info - 1; + } + /* Transpose output matrices */ + LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, n, a_t, lda_t, a, lda ); + if( fact_c || fact_x ) { + LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, n, c_t, ldc_t, c, ldc ); + } + if( fact_x ) { + LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, MIN(m,n), qrc_t, ldqrc_t, qrc, ldqrc ); + LAPACKE_zge_trans( LAPACK_COL_MAJOR, m, n, x_t, ldx_t, x, ldx ); + } + /* Release memory and exit */ + if( fact_x ) { + LAPACKE_free( x_t ); + } +exit_level_3: + if( fact_x ) { + LAPACKE_free( qrc_t ); + } +exit_level_2: + if( fact_c || fact_x ) { + LAPACKE_free( c_t ); + } +exit_level_1: + LAPACKE_free( a_t ); +exit_level_0: + if( info == LAPACK_TRANSPOSE_MEMORY_ERROR ) { + LAPACKE_xerbla( "LAPACKE_zgecxx_work", info ); + } + } else { + info = -1; + LAPACKE_xerbla( "LAPACKE_zgecxx_work", info ); + } + return info; +} diff --git a/lapack-netlib/SRC/Makefile b/lapack-netlib/SRC/Makefile index 2200a4628d..4708359574 100644 --- a/lapack-netlib/SRC/Makefile +++ b/lapack-netlib/SRC/Makefile @@ -207,7 +207,7 @@ SLASRC_O = \ ssytrd_2stage.o ssytrd_sy2sb.o ssytrd_sb2st.o ssb2st_kernels.o \ ssyevd_2stage.o ssyev_2stage.o ssyevx_2stage.o ssyevr_2stage.o \ ssbev_2stage.o ssbevx_2stage.o ssbevd_2stage.o ssygv_2stage.o \ - sgesvdq.o slatrs3.o strsyl3.o sgelst.o sgedmd.o sgedmdq.o + sgesvdq.o slatrs3.o strsyl3.o sgelst.o sgedmd.o sgedmdq.o sgecxx.o endif @@ -317,7 +317,7 @@ CLASRC_O = \ chetrd_2stage.o chetrd_he2hb.o chetrd_hb2st.o chb2st_kernels.o \ cheevd_2stage.o cheev_2stage.o cheevx_2stage.o cheevr_2stage.o \ chbev_2stage.o chbevx_2stage.o chbevd_2stage.o chegv_2stage.o \ - cgesvdq.o clatrs3.o ctrsyl3.o cgelst.o cgedmd.o cgedmdq.o + cgesvdq.o clatrs3.o ctrsyl3.o cgelst.o cgedmd.o cgedmdq.o cgecxx.o endif ifdef USEXBLAS @@ -418,7 +418,7 @@ DLASRC_O = \ dsytrd_2stage.o dsytrd_sy2sb.o dsytrd_sb2st.o dsb2st_kernels.o \ dsyevd_2stage.o dsyev_2stage.o dsyevx_2stage.o dsyevr_2stage.o \ dsbev_2stage.o dsbevx_2stage.o dsbevd_2stage.o dsygv_2stage.o \ - dgesvdq.o dlatrs3.o dtrsyl3.o dgelst.o dgedmd.o dgedmdq.o + dgesvdq.o dlatrs3.o dtrsyl3.o dgelst.o dgedmd.o dgedmdq.o dgecxx.o endif ifdef USEXBLAS @@ -527,7 +527,7 @@ ZLASRC_O = \ zhetrd_2stage.o zhetrd_he2hb.o zhetrd_hb2st.o zhb2st_kernels.o \ zheevd_2stage.o zheev_2stage.o zheevx_2stage.o zheevr_2stage.o \ zhbev_2stage.o zhbevx_2stage.o zhbevd_2stage.o zhegv_2stage.o \ - zgesvdq.o zlatrs3.o ztrsyl3.o zgelst.o zgedmd.o zgedmdq.o + zgesvdq.o zlatrs3.o ztrsyl3.o zgelst.o zgedmd.o zgedmdq.o zgecxx.o endif ifdef USEXBLAS diff --git a/lapack-netlib/SRC/cgecxx.c b/lapack-netlib/SRC/cgecxx.c new file mode 100644 index 0000000000..b8f0692a82 --- /dev/null +++ b/lapack-netlib/SRC/cgecxx.c @@ -0,0 +1,1456 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i msub) { + *info = -6; + } else if (*kmaxfree < 0) { + *info = -7; + } else if (sisnan_(abstol)) { + *info = -8; + } else if (sisnan_(reltol)) { + *info = -9; + } else if (*lda < f2cmax(1,*m)) { + *info = -11; +/* This is a check for LDC */ + } else if (returnc && *ldc < f2cmax(1,*m) || ! returnc && *ldc < 1) { + *info = -20; +/* This is a check for LDQRC */ + } else if (returnx && *ldqrc < f2cmax(1,*m) || ! returnx && *ldqrc < 1) { + *info = -22; +/* This is a check for LDX */ + } else if (returnx && *ldx < f2cmax(1,*m) || ! returnx && *ldx < 1) { + *info = -24; + } + + } + +/* ================================================================== */ + +/* a) Test the input workspace size LWORK, LRWORK, LIWORK for the */ +/* minimum size requirement LWKMIN, LRWKMIN, LIWKMIN */ +/* respectively. */ +/* b) Determine the optimal workspace sizes LWKOPT, LRWKOPT, */ +/* and LIWKOPT to be returned in */ +/* WORK( 1 ), RWORK( 1 ) and IWORK( 1 ) respectively, */ +/* if INFO >= 0 in cases: */ +/* (1) LQUERY = .TRUE., */ +/* (2) when the routine exits. */ +/* Here, LWKMIN, LRWKMIN and LIWKMIN are the minimum workspaces */ +/* required for unblocked code. */ + + if (*info == 0) { + if (minmn == 0) { + lwkmin = 1; + lwkopt = 1; + lrwkmin = 1; + lrwkopt = 1; + liwkmin = 1; + liwkopt = 1; + } else { + +/* (Complex_wk_part_1) Complex minimum and optimal workspace */ +/* computation. */ + + lwkmin = 1; + lwkopt = lwkmin; + +/* (Real_wk_part_1) Real minimum workspace computation. */ +/* LRWKMIN = MAX(1, NSUB) for column 2-norm computation */ + + lrwkmin = f2cmax(1,nsub); + +/* (Int_wk_part_1) Integer minimum workspace computation. */ + + liwkmin = 1; + +/* Call of CGEQRF. */ + + if (nsel > 0) { + +/* (Complex_wk_part_2) Complex minimum workspace */ +/* computation. */ + + lwkmin = f2cmax(lwkmin,nsel); + +/* Query for optimal workspace size for CGEQRF. */ + + cgeqrf_(&msub, &nsel, &a[a_offset], lda, &tau[1], &work[1], & + c_n1, &iinfo); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[1].r; + lwkopt = f2cmax(i__1,i__2); + +/* Call of CUNMQR. */ + + if (nfree > 0) { + +/* (Complex_wk_part_3) Complex minimum workspace */ +/* computation. */ + + lwkmin = f2cmax(lwkmin,nfree); + +/* Query for optimal workspace size for CUNMQR. */ + + cunmqr_("L", "C", &msub, &nfree, &nsel, &a[a_offset], lda, + &tau[1], &a[(nsel + 1) * a_dim1 + 1], lda, &work[ + 1], &c_n1, &iinfo); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[1].r; + lwkopt = f2cmax(i__1,i__2); + } + + } + +/* Call of CGEQP3RK. */ + + if (minmnfree != 0) { + +/* (Complex_wk_part_4) Complex minimum workspace */ +/* computation. */ +/* LWKMIN = MAX(1, NFREE-1) for the call of CGEQP3RK. */ + +/* Computing MAX */ + i__1 = lwkmin, i__2 = nfree - 1; + lwkmin = f2cmax(i__1,i__2); + +/* Query for optimal workspace size for CGEQP3RK. */ + + cgeqp3rk_(&mfree, &nfree, &c__0, &nfree, &c_b15, &c_b15, &a[ + a_dim1 + 1], lda, &kfree, &maxc2nrmkfree, & + relmaxc2nrmkfree, &jpiv[1], &tau[1], &work[1], &c_n1, + &rwork[1], &iwork[1], &iinfo); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[1].r; + lwkopt = f2cmax(i__1,i__2); + +/* (Real_wk_part_2) Real minimum workspace computation. */ +/* LRWKMIN = MAX(1, 2*NFREE) for the call of CGEQP3RK. */ + +/* Computing MAX */ + i__1 = lrwkmin, i__2 = nfree << 1; + lrwkmin = f2cmax(i__1,i__2); + +/* (Int_wk_part_2) Integer minimum workspace computation. */ +/* LIWKMIN = NFREE-1 for the call of CGEQP3RK. */ + +/* Computing MAX */ + i__1 = liwkmin, i__2 = nfree - 1; + liwkmin = f2cmax(i__1,i__2); + + if (nsel != 0) { + +/* (Int_wk_part_3) Integer minimum workspace computation. */ +/* NFREE is for CGEQP3RK and NFREE-1 for JPIV adjustment. */ + +/* Computing MAX */ + i__1 = liwkmin, i__2 = nfree + nfree - 1; + liwkmin = f2cmax(i__1,i__2); + } + + } + + if (returnc) { + +/* Integer minimum workspace computation. */ +/* (Int_wk_part_4) LIWKMIN = 2*N for applying the */ +/* interchanges for the columns in the matrix C. */ + +/* Computing MAX */ + i__1 = liwkmin, i__2 = *n << 1; + liwkmin = f2cmax(i__1,i__2); + } + +/* Real and Integer optimal workspace computation. */ + + lrwkopt = lrwkmin; + liwkopt = liwkmin; + +/* Call of CGELS. */ + + if (returnx) { + +/* (Complex_wk_part_5) Complex minimum workspace computation. */ +/* LWKMIN = f2cmax( 1, MINMN + f2cmax( MINMN, N ) ) = */ +/* = f2cmax( 1, MINMN + N ) for the call of CGELS. */ + +/* Computing MAX */ + i__1 = lwkmin, i__2 = minmn + *n; + lwkmin = f2cmax(i__1,i__2); + +/* Query for optimal workspace size for CGELS. */ + + kmaxls = minmn; + + cgels_("N", m, &kmaxls, n, &qrc[qrc_offset], ldqrc, &x[ + x_offset], ldx, &work[1], &c_n1, &iinfo); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[1].r; + lwkopt = f2cmax(i__1,i__2); + + } + +/* End of ELSE for IF( MINMN.EQ.0 ) */ + + } + + if (*lwork < lwkmin && ! lquery) { + *info = -26; + } else if (*lrwork < lrwkmin && ! lquery) { + *info = -28; + } else if (*liwork < liwkmin && ! lquery) { + *info = -30; + } + } + + if (*info == 0) { + q__1.r = (real) lwkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + rwork[1] = (real) lrwkopt; + iwork[1] = liwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("CGECXX", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* ================================================================== */ + +/* Quick return if possible for: */ +/* a) M = 0 or N = 0. There is no matrix A(1:M,1:N). */ +/* b) MSUB = 0 or NSUB = 0. There is no matrix A_sub(1:MSUB,1:NSUB). */ +/* NOTE: f2cmin( M, N) = 0 implies f2cmin( MSUB, NSUB) = 0. */ +/* We need to return correct values for all scalar output parameters, */ +/* (including WORK(1) and IWORK(1), which are set above). */ + + if (f2cmin(msub,nsub) == 0) { + *k = 0; + *maxc2nrmk = 0.f; + *relmaxc2nrmk = 0.f; + *fnrmk = 0.f; + return 0; + } + +/* ================================================================== */ + + *k = 0; + +/* If we need to return factor X, copy the original untouched matrix */ +/* A into the array X. */ + + if (returnx) { + clacpy_("F", m, n, &a[a_offset], lda, &x[x_offset], ldx); + } + +/* If we need to return the factor C, copy the original matrix A */ +/* into the array C, only if do not return the factor X. In this */ +/* case, we need to choose the columns of the matrix A in the array C */ +/* in place, otherwise we can copy the columns of the matrix A from */ +/* the array X. */ + + if (returnc && ! returnx) { + clacpy_("F", m, n, &a[a_offset], lda, &c__[c_offset], ldc); + } + +/* ================================================================== */ +/* Permute the deselected rows to the bottom of the matrix A. */ +/* 1) The initial order of included rows in their block is preserved. */ +/* 2) The initial order of deselected rows in their block is not */ +/* preserved. */ +/* ================================================================== */ + +/* I is an index of DESEL_ROWS array and a row index of */ +/* the matrix A. MSUB is the number of processed included rows, which */ +/* is also an index pointer to the last included row in the matrix A. */ +/* We can think of I as a row source index, and MSUB as a destination */ +/* index for moving an included row in the matrix A. */ + +/* ( We start with MSUB = 0. We loop over index I in (1:M), and */ +/* for each position I in DESEL_ROWS array, we check if the row at */ +/* the position I in the matrix A is an included row (not -1 value). */ +/* If it is an included row, we increment MSUB pointer, otherwise */ +/* we do not change MSUB index pointer. Then, we bring this included */ +/* row from the index I in the matrix A into smaller (or same) */ +/* MSUB index in the matrix A. If I = MSUB, then the included row */ +/* is already in place. Due to row swap, the deselected row */ +/* at MSUB index will move into I index in the matrix A. In this way, */ +/* we move all the included rows to the top matrix block preserving */ +/* their initial order within the included block. The initial order */ +/* of deselected rows will not be preserved within their block. */ + + if (use_desel_rows__) { + + msub = 0; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Initialize the row pivot array IPIV. */ + ipiv[i__] = i__; + +/* The row at the index I is an included row and should be */ +/* moved to the top of the matrix A. */ + + if (desel_rows__[i__] != -1) { + ++msub; + +/* This is a check whether the included row is */ +/* on the included place already. */ + + if (i__ != msub) { + +/* Here, we swap A(I,1:N) into A(MSUB,1:N). */ + + cswap_(n, &a[i__ + a_dim1], lda, &a[msub + a_dim1], lda); + +/* Save the interchange. */ + + ipiv[i__] = ipiv[msub]; + ipiv[msub] = i__; + desel_rows__[msub] = desel_rows__[i__]; + desel_rows__[i__] = -1; + } + } + + } + + } else { + +/* We do not use the row deselection DESEL_ROWS array. */ +/* Initialize the row pivot array IPIV. */ +/* NOTE: MSUB=M has default value, */ +/* which is set at the beginning of the routine, before argument */ +/* checks. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + ipiv[i__] = i__; + } + } + +/* ================================================================== */ +/* Permute the preselected columns to the left and deselected */ +/* columns to the right of the matrix A. */ +/* 1) The order of preselected columns is preserved. */ +/* 2) The order of free columns is not preserved. */ +/* 3) The order of deselected columns is not preserved. */ +/* ================================================================== */ + +/* J is the index of SEL_DESEL_COLS array and column J */ +/* of the matrix A. */ + + if (use_sel_desel_cols__) { + +/* Column selection. */ +/* NSEL is the number of selected columns, also the pointer to */ +/* the last selected column. */ + + nsel = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Initialize column pivot array JPIV. */ + jpiv[j] = j; + + if (sel_desel_cols__[j] == 1) { + ++nsel; + +/* This is the check whether the selected column is */ +/* on the selected place already. */ + + if (j != nsel) { + +/* Here, we swap the column A(1:M,J) into A(1:M,NSEL) */ + + cswap_(m, &a[j * a_dim1 + 1], &c__1, &a[nsel * a_dim1 + 1] + , &c__1); + jpiv[j] = jpiv[nsel]; + jpiv[nsel] = j; + sel_desel_cols__[j] = sel_desel_cols__[nsel]; + sel_desel_cols__[nsel] = 1; + } + } + } + +/* Column deselection. */ +/* JDESEL the pointer to the last */ +/* deselected column counting right-to-left. */ + + jdesel = *n + 1; + i__1 = nsel + 1; + for (j = *n; j >= i__1; --j) { + if (sel_desel_cols__[j] == -1) { + --jdesel; + +/* This is the check whether the deselected column is */ +/* on the deselected place already. */ + + if (j != jdesel) { + +/* Here, we swap the column A(1:M,J) into A(1:M,JDESEL) */ + + cswap_(m, &a[j * a_dim1 + 1], &c__1, &a[jdesel * a_dim1 + + 1], &c__1); + itemp = jpiv[j]; + jpiv[j] = jpiv[jdesel]; + jpiv[jdesel] = itemp; + sel_desel_cols__[j] = sel_desel_cols__[jdesel]; + sel_desel_cols__[jdesel] = -1; + } + } + } + + nsub = jdesel - 1; + + } else { + +/* We do not use the column selection deselection */ +/* SEL_DESEL_COLS array. */ +/* Initialize column pivot array JPIV. */ +/* NOTE: NSUB=N has default value, */ +/* which is set at the beginning of the routine, before argument */ +/* checks. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jpiv[j] = j; + } + + } + +/* ================================================================== */ +/* Compute the complete column 2-norms of the submatrix */ +/* A_sub = A(1:MSUB, 1:NSUB) and store them in WORK(1:NSUB). */ + + i__1 = nsub; + for (j = 1; j <= i__1; ++j) { + rwork[j] = scnrm2_(&msub, &a[j * a_dim1 + 1], &c__1); + } + +/* Compute the column index of the maximum column 2-norm and */ +/* the maximum column 2-norm itself for the submatrix */ +/* A_sub = A(1:MSUB, 1:NSUB). */ + + kp0 = icamax_(&nsub, &work[1], &c__1); + maxc2nrm = rwork[kp0]; + +/* ================================================================== */ +/* Process preselected columns */ + +/* Compute the QR factorization of NSEL preselected columns (1:NSEL) */ +/* in the submatrix A_sub = A(1:MSUB, 1:NSUB) and update */ +/* remaining NFREE free columns (NSEL+1:NSUB). */ +/* NSUB = NSEL + NFREE */ + + if (nsel > 0) { + +/* Case (a): MSUB < NSEL. */ + +/* This is handled at the argument check stage in the */ +/* beginning of the routine. When the number of preselected */ +/* columns is larger than MSUB, hence the factorization of */ +/* all NSEL columns cannot be completed. Return from the */ +/* routine with the error of COL_SEL_DESEL parameter. */ + +/* Case (b): MSUB = NSEL. */ +/* Case (c-1): MSUB > NSEL and NSEL = NSUB. */ + +/* For cases (b) and (c-1), there will be no residual */ +/* submatrix after factorization of NSEL columns */ +/* at step K = NSEL: */ +/* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). */ + +/* Case (c-2): MSUB > NSEL and NSEL < NSUB. */ + +/* For Case (c-2) is a submatrix residual at step K=NSEL */ +/* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) */ + + cgeqrf_(&msub, &nsel, &a[a_offset], lda, &tau[1], &work[1], lwork, & + iinfo); + +/* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) */ + + if (nfree > 0) { + +/* This is only for case (c-2) ('L' = Left, 'T' = Transpose) */ + + cunmqr_("L", "C", &msub, &nfree, &nsel, &a[a_offset], lda, &tau[1] + , &a[(nsel + 1) * a_dim1 + 1], lda, &work[1], lwork, & + iinfo); + } + + *k += nsel; + +/* End of IF(NSEL.GT.0) */ + + } + +/* ================================================================== */ + + kfree = 0; + + if (minmnfree != 0) { + +/* Factorize NFREE free columns of */ +/* A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), */ +/* KFREE is the number of columns that were actually factorized */ +/* among NFREE columns. */ + +/* ================================================================== */ + + eps = slamch_("Epsilon"); + + usetol = FALSE_; + +/* Adjust ABSTOL only if nonnegative. Negative value means disabled. */ +/* We need to keep negative value for later use in criterion */ +/* check. */ + + if (*abstol >= 0.f) { + safmin = slamch_("Safe minimum"); +/* Computing MAX */ + r__1 = *abstol, r__2 = safmin * 2.f; + *abstol = f2cmax(r__1,r__2); + usetol = TRUE_; + } + +/* Adjust RELTOL only if nonnegative. Negative value means disabled. */ +/* We need to keep negative value for later use in criterion */ +/* check. */ + + if (*reltol >= 0.f) { + *reltol = f2cmax(*reltol,eps); + usetol = TRUE_; + } + +/* ================================================================== */ + +/* Disable RELTOLFREE when calling CGEQP3RK for free columns */ +/* factorization, since CGEQP3RK expects RELTOLFREE with respect */ +/* to the residual matrix A_sub_resid(NSEL), not the whole */ +/* original matrix A. We can use RELTOL criterion by passing it */ +/* to ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that */ +/* the negative values of ABSTOL and RELTOL are propagated */ +/* to ABSTOLFREE and RELTOLFREE, since negative values means */ +/* that the criterion is disabled. */ + + if (usetol) { +/* Computing MAX */ + r__1 = *abstol, r__2 = *reltol * maxc2nrm; + abstolfree = f2cmax(r__1,r__2); + } else { + abstolfree = -1.f; + } + reltolfree = -1.f; + +/* Save JPIV(NSEL+1:NSUB) into WORK(NFREE+1:2*NFREE-1) */ + + if (nsel != 0) { + i__1 = nfree; + for (j = 1; j <= i__1; ++j) { + iwork[nfree + j] = jpiv[nsel + j]; + } + } + + cgeqp3rk_(&mfree, &nfree, &c__0, kmaxfree, &abstolfree, &reltolfree, & + a[nsel + 1 + (nsel + 1) * a_dim1], lda, &kfree, & + maxc2nrmkfree, &relmaxc2nrmkfree, &jpiv[nsel + 1], &tau[nsel + + 1], &work[1], lwork, &rwork[1], &iwork[1], &iinfo); + +/* Adjust JPIV */ + + if (nsel != 0) { + i__1 = nfree; + for (j = 1; j <= i__1; ++j) { + jpiv[nsel + j] = iwork[nfree + jpiv[nsel + j]]; + } + } + +/* 1) Adjust the return value for the number of factorized */ +/* columns K for the whole submatrix A_sub. */ +/* 2) MAXC2NRMK is returned transparently without change */ +/* as MAXC2NRMKFREE is returned from CGEQP3RK. */ +/* 3) Adjust the return value RELMAXC2NRMK for the whole */ +/* submatrix A_sub. We do not use RELMAXC2NRMKFREE */ +/* returned from CGEQP3RK. */ + + *k += kfree; + *maxc2nrmk = maxc2nrmkfree; + *relmaxc2nrmk = *maxc2nrmk / maxc2nrm; + + } else { + +/* Set norms to zero */ + + *maxc2nrmk = 0.f; + *relmaxc2nrmk = 0.f; + + } + +/* Now, MRESID and NRESID is the number of rows and columns */ +/* respectively in A_free_resid = A(K+1:MSUB,K+1:NSUB). */ + + mresid = mfree - kfree; + nresid = nfree - kfree; + + if (f2cmin(mresid,nresid) != 0) { + *fnrmk = clange_("F", &mresid, &nresid, &a[*k + 1 + (*k + 1) * a_dim1] + , lda, &work[1]); + } else { + *fnrmk = 0.f; + } + +/* ================================================================== */ + +/* Return the matrix C. */ + + if (returnc && *k > 0) { + + if (returnx) { + +/* Copy the selected K columns of the original matrix A (that was */ +/* saved into the array X) into the array C according to */ +/* the pivot array JPIV. If we return X, then the matrix A is */ +/* saved in the array X, and it is faster to copy into C than */ +/* doing column permutation in place, as it is the ELSE case. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + ccopy_(m, &x[jpiv[j] * x_dim1 + 1], &c__1, &c__[j * c_dim1 + + 1], &c__1); + } + + } else { + +/* Swap the columns of the original matrix A copied into */ +/* the array C in place. */ + +/* The original M-by-N matrix A was copied into the array C at */ +/* the beginning of the routine, if RETURNC = .TRUE.. */ +/* Apply the column permutation matrix P stored in JPIV(1:K) */ +/* to the columns 1:K in the M-by-N array C in place. */ +/* After column interchanges, the first K columns of C should */ +/* be the same as the first K columns of A*P, i.e. */ +/* (A*P)(1:M,1:K) = C(1:M,1:K). The complexity of this algorithm */ +/* is f2cmin(K,N-1). */ + +/* Index I is the original column index in the */ +/* array C before interchanges. */ +/* J is the current column index of the original column I at */ +/* each step of interchanges. */ + +/* Auxiliary array IWORK(1:N) stores the inverse P_inv(J) */ +/* of the current column permutation matrix P(J) at each */ +/* column interchange step J only for the array */ +/* values >= J:N. */ +/* C_prev = P_inv(J) * C_next. */ +/* Each IWORK(I) contains JJ corresponding to I */ +/* Initialize IWORK(1:N) as (1:N). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = i__; + } + +/* Auxiliary array IWORK(N+1:2N) stores the current column */ +/* permutation matrix P_(J) at each column interchange step J */ +/* only for the array index >= J:N. */ +/* C_prev * P_(J) = C_next. */ +/* Each IWORK(N+JJ) contains I corresponding to JJ. */ +/* Initialize IWORK(N+1:2*N) as (1:N). */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + iwork[*n + j] = j; + } + +/* Loop over the columns J = ( 1:f2cmin( K, N-1 ) ) in C. */ + +/* Computing MIN */ + i__2 = *k, i__3 = *n - 1; + i__1 = f2cmin(i__2,i__3); + for (j = 1; j <= i__1; ++j) { + +/* IP is the original pivot column, i.e. is the original */ +/* column that should be placed in the current column index */ +/* J in the array C. */ + + ip = jpiv[j]; + +/* I is the original column that is */ +/* currently in the column index J in the array C after */ +/* previous column interchanges. */ + + i__ = iwork[*n + j]; + + if (i__ != ip) { + +/* JP is the current index of the original pivot */ +/* column IP in the array C after previous column */ +/* interchanges. */ + + jp = iwork[ip]; +/* Swap the original pivot column IP = JPIV( J ), */ +/* at the current pivot index JP = IWORK( IP ) into */ +/* index J. */ + + cswap_(m, &c__[j * c_dim1 + 1], &c__1, &c__[jp * c_dim1 + + 1], &c__1); + +/* Update the array IWORK(1:N) for the original column */ +/* I that was swapped with IP. */ + + iwork[i__] = iwork[ip]; + +/* Update the array IWORK(N+1:2*N) for the current column */ +/* index JP that was swapped with the current column */ +/* index J. */ + + iwork[*n + jp] = iwork[*n + j]; + + } + + } + +/* End of ELSE( RETURNX ) */ + + } + +/* End of IF( RETURNC .AND. K.GT.0 ) */ + + } + +/* ================================================================== */ + +/* Return the matrix X. */ + + if (returnx && *k > 0) { + +/* We need to use C and A to compute X = pseudoinv(C) * A, as */ +/* the linear least squares solution to the overdetermined system */ +/* C*X = A. We use LLS routine that uses the QR factorization. For */ +/* that purpose, we store the matrix C into the array QRC. */ +/* The matrix A was copied into the array X at the beginning */ +/* of the routine. */ + + clacpy_("F", m, k, &c__[c_offset], ldc, &qrc[qrc_offset], ldqrc); + + cgels_("N", m, k, n, &qrc[qrc_offset], ldqrc, &x[x_offset], ldx, & + work[1], lwork, &iinfo); + *info = iinfo; + + } + + q__1.r = (real) lwkopt, q__1.i = 0.f; + work[1].r = q__1.r, work[1].i = q__1.i; + rwork[1] = (real) lrwkopt; + iwork[1] = liwkopt; + +/* End of CGECXX */ + + return 0; +} /* cgecxx_ */ + diff --git a/lapack-netlib/SRC/cgecxx.f b/lapack-netlib/SRC/cgecxx.f new file mode 100644 index 0000000000..7bda3deda5 --- /dev/null +++ b/lapack-netlib/SRC/cgecxx.f @@ -0,0 +1,1776 @@ +*> \brief \b CGECXX computes a CX factorization of a real M-by-N matrix A using a truncated (rank k) Householder QR factorization with column pivoting. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download CGECXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE CGECXX( FACT, USESD, M, N, +* $ DESEL_ROWS, SEL_DESEL_COLS, +* $ KMAXFREE, ABSTOL, RELTOL, A, LDA, +* $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, +* $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, +* $ X, LDX, WORK, LWORK, RWORK, LRWORK, +* $ IWORK, LIWORK, INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER FACT, USESD +* INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, +* $ LDX, LIWORK, LRWORK, LWORK, M, N +* REAL ABSTOL, FNRMK, MAXC2NRMK, +* $ RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. +* INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), +* $ JPIV( * ), SEL_DESEL_COLS( * ) +* REAL RWORK( * ) +* COMPLEX A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), +* $ TAU( * ), WORK( * ), X( LDX, *) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CGECXX computes a CX factorization of a real M-by-N matrix A using +*> a truncated rank-K Householder QR factorization with a column +*> pivoting algorithm, which is implemented in the CGEQP3RK routine. +*> +*> A * P = C*X + A_resid, where +*> +*> C is an M-by-K matrix consisting of K columns selected +*> from the original matrix A, +*> +*> X is a K-by-N matrix that minimizes the Frobenius norm of the +*> residual matrix A_resid, X = pseudoinv(C) * A, +*> +*> P is an N-by-N permutation matrix chosen so that the first +*> K columns of A*P equal C, +*> +*> A_resid is an M-by-N residual matrix. +*> +*> The column selection for the matrix C has two stages. +*> +*> Column preselection stage 1 (optional). +*> ======================================= +*> +*> The user can select N_sel columns and deselect N_desel columns +*> of the matrix A that MUST be included and excluded respectively +*> from the matrix C a priori, before running the column selection +*> algorithm. This is controlled by flags in the array +*> SEL_DESEL_COLS. The deselected columns are permuted to the right +*> side of the matrix A and selected columns are permuted to the left +*> side of the matrix A. The details of the column permutation +*> (i.e. the column permutation matrix P) are stored in the +*> array JPIV. This feature can be used when the goal is to approximate +*> the deselected columns by linear combinations of K selected columns, +*> where the K columns MUST include the N_sel preselected columns. +*> +*> Column selection stage 2. +*> ========================= +*> +*> The routine runs a column selection algorithm that can +*> be controlled by three stopping criteria described below. +*> For column selection, the routine uses a truncated (rank-K) +*> Householder QR factorization with column pivoting algorithm using +*> the routine CGEQP3RK. +*> +*> Optionally, before running the column selection +*> algorithm, the user can deselect M_desel rows of the matrix A that +*> should NOT be considered by the column selection algorithm (i.e. +*> during the factorization). This is controlled by flags in +*> the array DESEL_ROWS. The deselected rows are permuted to the +*> bottom of the matrix A. The details of the row permutation (i.e. the +*> row permutation matrix) are stored in the array IPIV. This feature +*> can be used when the goal is to use the deselected rows as test data, +*> and the selected rows as training data. +*> +*> This means that the column selection factorization algorithm is +*> effectively running on the submatrix A_sub = A(1:M_sub,1:N_sub) of +*> the matrix A after the permutations described above. Here M_sub is +*> the number of rows of the matrix A minus the number of deselected +*> rows M_desel, i.e. M_sub = M - M_desel, and N_sub is the number +*> of columns of the matrix A minus the number of deselected columns +*> N_desel, i.e. N_sub = N - N_desel. +*> +*> The reported column selection error metrics MAXC2NRMK, RELMAXC2NRMK +*> and FNRMK described below are computed using only A_sub. +*> +*> Column selection criteria. +*> ========================== +*> +*> The column selection criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) KMAXFREE: This input parameter specifies the maximum number of +*> columns to factorize in addition to the N_sel preselected +*> columns. The factorization rank is limited to N_sel + KMAXFREE. +*> If N_sel + KMAXFREE >= min(M_sub, N_sub), this criterion +*> is not used. +*> +*> 2) ABSTOL: This input parameter specifies the absolute tolerance +*> for the maximum column 2-norm of the submatrix residual +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub), where +*> A_sub(K) denotes the contents of the array +*> A_sub = A(1:M_sub, 1:N_sub) after K columns were factorized. +*> This means that the factorization stops if this norm is less +*> than or equal to ABSTOL. If ABSTOL < 0.0, this criterion is +*> not used. +*> +*> 3) RELTOL: This input parameter specifies the tolerance for +*> the maximum column 2-norm of the submatrix residual +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) divided +*> by the maximum column 2-norm of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub), where A_sub(K) denotes the contents +*> of the array A_sub after K columns were factorized. +*> This means that the factorization stops when the ratio of the +*> maximum column 2-norm of A_sub_resid(K) to the maximum column +*> 2-norm of A_sub is less than or equal to RELTOL. +*> If RELTOL < 0.0, this criterion is not used. +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the entire submatrix A_sub is factorized. +*> +*> To perform a full-rank factorization of the matrix A_sub, use +*> selection criteria that satisfy N_sel + KMAXFREE >= min(M_sub,N_sub) +*> and ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> If the user wishes to verify that the columns of the matrix C are +*> sufficiently linearly independent for their intended use, the user +*> can compute the condition number of its R factor by calling DTRCON +*> on the upper-triangular part of QRC(1:K,1:K) in the output +*> array QRC. +*> +*> How N_sel affects the column selection algorithm. +*> ================================================= +*> +*> As mentioned above, the N_sel preselected columns are permuted to the +*> left side of the matrix A, and will be included in the column +*> selection. Then the routine factorizes that block A(1:M_sub,1:N_sel), +*> and if any of the three stopping criteria is met immediately after +*> factoring the first N_sel columns the routine exits +*> (i.e. if the user does not want to select KMAXFREE > 0 extra columns, +*> or if the absolute or relative tolerance of the maximum column 2-norm +*> of the residual is satisfied). In this case, the number +*> of selected columns would be K = N_sel. Otherwise, the factorization +*> routine finds a new column to select with the maximum column 2-norm +*> in the residual A(N_sel+1:M_sub,N_sel+1:N_sub), and swaps that +*> column with the first column of A(1:M,N_sel+1:N_sub). Then the +*> routine checks if the stopping criteria are met in the next residual +*> A(N_sel+2:M_sub,N_sel+2:N_sub), and so on. +*> +*> Computation of the matrix factors. +*> ================================== +*> +*> When the columns are selected for the factor C, and: +*> (a) If the flag FACT = 'P', the routine returns only the indices of +*> the selected columns from the original matrix A, which are +*> stored in the first K elements of the JPIV array. +*> (b) If the flag FACT = 'C', then in addition to (a), the routine +*> explicitly returns the matrix C in the array C. +*> (c) If the flag FACT = 'X', then in addition to (a) and (b), +*> the routine explicitly computes and returns the factor +*> X = pseudoinv(C) * A in the array X, and it also returns +*> the factor R alongside the Householder vectors +*> of the QR factorization of the matrix C in the array QRC. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> The flag specifies how the factors of a CX factorization +*> are returned. +*> +*> = 'P': the routine returns: +*> (1) only the column permutation matrix P in +*> the array JPIV. +*> (The first K elements of the array JPIV +*> contain indices of the columns that were +*> selected from the matrix A to form the +*> factor C.) +*> (fastest option, smallest memory space) +*> +*> = 'C': the routine returns: +*> (1) the column permutation matrix P +*> in the array JPIV. (The first K elements are +*> indices of the selected columns from +*> the matrix A.) +*> (2) the M-by-K factor C explicitly in the array C. +*> (slower option, more memory space) +*> +*> = 'X': the routine returns: +*> (1) the column permutation matrix P in +*> the array JPIV. (The first K elements are +*> indices of the selected columns from +*> the matrix A.) +*> (2) the M-by-K factor C explicitly in the array C. +*> (3) the K-by-N factor X explicitly in the array X. +*> (4) the K-by-K upper triangular factor R and +*> the Householder vectors of the QR factorization +*> of the factor C in the array QRC. +*> ( The factor R may be useful for checking +*> the factor C for singularity, in which case +*> R will have a zero on the diagonal, and +*> the factor X cannot be computed. ) +*> (slowest option, largest memory space) +*> \endverbatim +*> +*> \param[in] USESD +*> \verbatim +*> USESD is CHARACTER*1 +*> The flag specifies whether the row deselection and column +*> preselection-deselection functionality is turned ON or OFF. +*> +*> = 'N': Both row deselection and column +*> preselection-deselection are OFF. +*> Both arrays DESEL_ROWS and SEL_DESEL_COLS +*> are not used. +*> +*> = 'R': Only row deselection is ON. +*> Column preselection-deselection is OFF. +*> The array SEL_DESEL_COLS is not used. +*> +*> = 'C': Only column preselection-deselection is ON. +*> Row deselection is OFF. +*> The array DESEL_ROWS is not used. +*> +*> = 'A': Means "All". Both row deselection and column +*> preselection-deselection are ON. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] DESEL_ROWS +*> \verbatim +*> DESEL_ROWS is INTEGER array, dimension (M) +*> DESEL_ROWS is only accessed if USESD = 'R' or 'A'. +*> This is a row deselection mask array that separates +*> the rows of matrix A into 2 sets. +*> +*> On entry: +*> a) If DESEL_ROWS(i) = -1, the i-th row of the matrix A is +*> deselected by the user, i.e. chosen to be excluded from +*> the column selection algorithm (in both preselection and +*> selection stages) and will be permuted to the bottom +*> of the matrix A. +*> The number of deselected rows is denoted by M_desel. +*> +*> b) If DESEL_ROWS(i) is not equal -1, +*> the i-th row of A will be used in the column selection +*> algorithm (in both preselection and selection stages). +*> This defines a set of M_sub = M - M_desel rows that +*> the algorithm will use to select columns. +*> After the permutation, this set will be at the top +*> of the matrix A. +*> +*> On exit: +*> DESEL_ROWS will be permuted according to IPIV(i), +*> so that, if IPIV(i) = k, then the entry i of DESEL_ROWS +*> on exit was the entry k of DESEL_ROWS on entry. +*> +*> \endverbatim +*> +*> \param[in,out] SEL_DESEL_COLS +*> \verbatim +*> SEL_DESEL_COLS is INTEGER array, dimension (N) +*> SEL_DESEL_COLS is only accessed if USESD = 'C' or 'A'. +*> This is a column preselection-deselection mask array that +*> separates the columns of matrix A into 3 sets. +*> +*> On entry: +*> a) If SEL_DESEL_COLS(j) = +1, the j-th column of the matrix +*> A is preselected by the user to be included +*> in the factor C and will be permuted to the left side +*> of the array A. The number of selected columns is +*> denoted by N_sel. +*> +*> b) If SEL_DESEL_COLS(j) = -1, the j-th column of the matrix +*> A is deselected by the user, i.e. chosen to be excluded +*> from the factor C and will be permuted to the right side +*> of the array A. The number of deselected columns is +*> denoted by N_desel. +*> +*> c) If SEL_DESEL_COLS(j) is not equal to 1 and not equal +*> to -1, the j-th column of A is a free column and will be +*> used by the column selection algorithm to determine if +*> this column will be selected. This defines a set of +*> columns of size N_free = N - N_sel - N_desel. +*> +*> On exit: +*> SEL_DESEL_COLS will be permuted according to JPIV(j), +*> so that, if JPIV(j) = k, then the entry j +*> of SEL_DESEL_COLS on exit was the entry k +*> of SEL_DESEL_COLS on entry. +*> +*> NOTE: An error returned as INFO = -6 means that the number +*> of preselected N_sel columns is larger than M_sub. +*> Therefore, the QR factorization of all N_sel preselected +*> columns cannot be completed. +*> \endverbatim +*> +*> \param[in] KMAXFREE +*> \verbatim +*> KMAXFREE is INTEGER, KMAXFREE >= 0. +*> +*> The first column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> KMAXFREE is the maximum number of columns of the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) to select +*> during the column selection stage 2. +*> +*> KMAXFREE does not include the preselected N_sel columns. +*> N_sel + KMAXFREE is the maximum factorization rank of +*> the matrix A_sub. +*> +*> a) If N_sel + KMAXFREE >= min(M_sub, N_sub), then this +*> stopping criterion is not used, i.e. columns are +*> selected in the factorization stage 2 depending +*> on ABSTOL and RELTOL. +*> +*> b) If KMAXFREE = 0, then this stopping criterion is +*> satisfied on input and the routine exits without +*> performing column selection stage 2 +*> on the submatrix A_sub. This means that the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) is not modified +*> in the column selection stage 2 +*> and A_free is itself the residual for the factorization. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL, cannot be NaN. +*> +*> The second column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> ABSTOL is the absolute tolerance (stopping threshold) +*> for maxcol2norm(A_sub_resid(K)), where K >= N_sel. +*> +*> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm +*> of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) +*> when K columns have been factorized. +*> The column selection algorithm converges +*> (stops the factorization) when +*> maxcol2norm(A_sub_resid(K)) <= ABSTOL, where K >= N_sel. +*> +*> In the following, +*> SAFMIN = SLAMCH('S'), +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub), +*> maxcol2norm(A_free) is the maximum column 2-norm +*> of the matrix A_free. +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -8 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, and the column selection algorithm stops +*> the factorization of A_free depending +*> on KMAXFREE and RELTOL. +*> This includes the case where ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case where ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> If ABSTOL chosen above is >= maxcol2norm(A_free), then +*> this stopping criterion is satisfied on input, and +*> the routine only preselects K = N_sel columns. The leftmost +*> preselected N_sel columns in the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) are factorized. The routine +*> then computes maxcol2norm(A_free) and returns it +*> in MAXC2NORMK, computes and returns RELMAXC2NORMK of A_free, +*> and exits immediately. +*> This means that the factorization residual +*> A_sub_resid(N_sel) = A_free = A(N_sel+1:M_sub,N_sel+1:N_sub) +*> is not modified in the column selection stage 2. +*> This includes the case where ABSTOL = +Inf. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is REAL, cannot be NaN. +*> +*> The third column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> RELTOL is the tolerance (stopping threshold) for the ratio +*> relmaxcol2norm(A_sub_resid(K)) = +*> = maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub), +*> where K >= N_sel. +*> +*> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm +*> of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) +*> when K columns have been factorized. +*> maxcol2norm(A_sub) is the maximum column 2-norm +*> of the original submatrix A_sub = A(1:M_sub, 1:N_sub). +*> The column selection algorithm converges +*> (stops the factorization) when the ratio +*> relmaxcol2norm(A_sub_resid(K)) <= RELTOL, where K >= N_sel. +*> +*> In the following, +*> EPS = SLAMCH('E'), +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub). +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -9 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used and the column selection algorithm stops +*> the factorization of A_free depending +*> on KMAXFREE and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. +*> This includes the case RELTOL = -0.0. +*> +*> d) If EPS <= RELTOL then the input value of RELTOL +*> is used. +*> +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input, and the routine +*> only preselects K = N_sel columns. The leftmost +*> preselected N_sel columns in the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) are factorized. +*> The routine then computes maxcol2norm(A_free) and returns +*> it in MAXC2NORMK, returns RELMAXC2NORMK as 1.0, and exits +*> immediately. +*> This means that the factorization residual +*> A_sub_resid(N_sel) = A_free = A(N_sel+1:M_sub,N_sel+1:N_sub) +*> is not modified. +*> This includes the case RELTOL = +Inf. +*> +*> NOTE: We recommend RELTOL to satisfy +*> min(max(M_sub,N_sub)*EPS, sqrt(EPS)) <= RELTOL +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX array, dimension (LDA,N) +*> +*> On entry: +*> the M-by-N matrix A. +*> +*> On exit: +*> +*> NOTE: +*> The output parameter K, the number of selected +*> columns, is described later. +*> A_sub = A(1:M_sub, 1:N_sub). +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> +*> 2) If K > 0, A(1:M,1:N) contains the following parts: +*> +*> (a) If M_sub < M (which is the same as M_desel > 0), +*> the subarray A(M_sub+1:M,1:N) contains the deselected +*> rows. +*> +*> (b) If N_sub < N ( which is the same as N_desel > 0 ), +*> the subarray A(1:M,N_sub+1:N) contains the +*> deselected columns. +*> +*> (c) If N_sel > 0, +*> the union of the subarray A(1:M_sub, 1:N_sel) +*> and the subarray A(1:N_sel, 1:N_sub) contains parts +*> of the factors obtained by computing Householder QR +*> factorization WITHOUT column pivoting of N_sel +*> preselected columns using the routine CGEQRF. +*> +*> (d) The subarray A(N_sel+1:M_sub, N_sel+1:N_sub) +*> contains parts of the factors obtained by computing +*> a truncated (rank K) Householder QR factorization with +*> column pivoting using the routine CGEQP3RK on +*> the matrix A_free = A(N_sel+1:M_sub, N_sel+1:N_sub), +*> which is the result of applying selection and +*> deselection of columns, applying deselection of rows +*> to the original matrix A, and applying orthogonal +*> transformation from the factorization of the first +*> N_sel columns as described in part (c). +*> +*> 1. The elements below the diagonal of the subarray +*> A_sub(1:M_sub,1:K) together with TAU(1:K) +*> represent the orthogonal matrix Q(K) as a +*> product of K Householder elementary reflectors. +*> +*> 2. The elements on and above the diagonal of +*> the subarray A_sub(1:K,1:N_sub) contain the +*> K-by-N_sub upper-trapezoidal matrix +*> R_sub_approx(K) = ( R_sub11(K), R_sub12(K) ). +*> NOTE: If K = min(M_sub,N_sub), i.e. full rank +*> factorization, then R_sub_approx(K) is the +*> full factor R which is upper-trapezoidal. +*> If, in addition, M_sub >= N_sub, then R is +*> upper-triangular. +*> +*> 3. The subarray A_sub(K+1:M_sub,K+1:N_sub) contains +*> the (M_sub-K)-by-(N_sub-K) rectangular matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> The number of columns that were selected +*> (K is the factorization rank). +*> 0 <= K <= min( M_sub, N_sel+KMAXFREE, N_sub ). +*> +*> NOTE: If K = 0, a) the arrays A is not, modified. +*> b) the array TAU(1,min(M_sub,N_sub)) +*> is set to ZERO. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is REAL +*> The maximum column 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub), +*> when factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, so +*> the matrix A_sub = A(1:M_sub, 1:N_sub) was not modified +*> and is itself a residual matrix, then MAXC2NRMK equals +*> the maximum column 2-norm of the original matrix A_sub. +*> +*> b) If 0 < K < min(M_sub, N_sub), then MAXC2NRMK is returned. +*> +*> c) If K = min(M_sub, N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK at the factorization step K is equal +*> to the diagonal element R_sub(K+1,K+1) of the factor +*> R_sub in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is REAL +*> The ratio MAXC2NRMK / MAXC2NRM +*> of the maximum column 2-norm MAXC2NRMK of the residual +*> matrix A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) (when +*> factorization stopped at rank K) and maximum column 2-norm +*> MAXC2NRM of the matrix A_sub = A(1:M_sub, 1:N_sub). +*> RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A_sub was not modified +*> and is itself a residual matrix, +*> then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M_sub,N_sub), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M_sub,N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no residual matrix +*> A_sub_resid(K), then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK at the factorization step K would equal +*> abs(R_sub(K+1,K+1))/MAXC2NRM in the next +*> factorization step K+1, where R_sub(K+1,K+1) is the +*> diagonal element of the factor R_sub in the next +*> factorization step K+1. +*> \endverbatim +*> +*> \param[out] FNRMK +*> \verbatim +*> FNRMK is REAL +*> Frobenius norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub). +*> FNRMK >= 0.0 +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (M) +*> Row permutation indices due to row deselection, +*> for 1 <= i <= M. +*> If IPIV(i) = k, then the row i of A was +*> the row k of A. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column permutation indices, for 1 <= j <= N. +*> If JPIV(j)= k, then the column j of A*P was +*> the column k of A. +*> +*> The first K elements of the array JPIV contain +*> indices of the columns of the factor C that were selected +*> from the matrix A. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX array, dimension (min(M_sub,N_sub)) +*> The scalar factors of the elementary reflectors. +*> +*> If K = 0, all elements TAU(1:min(M_sub,N_sub)) are set +*> to zero. +*> If 0 < K <= min(M_sub,N_sub): +*> only the elements TAU(1:K) may be modified, +*> the elements TAU(K+1:min(M_sub,N_sub)) are set to zero. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX array. +*> +*> If FACT = 'P': +*> the array is not used, the array dimension >= (1,1). +*> +*> If FACT = 'C': +*> the array dimension is (LDC,N). +*> If K = 0: +*> the M-by-N array C contains a copy of +*> the original M-by-N matrix A. +*> If K > 0: +*> a) columns (1:K) of the array C contain +*> the M-by-K factor C (the selected columns +*> from the original matrix A). +*> b) columns (K+1:N) of the array C contain +*> the deselected columns from the original +*> matrix A. +*> +*> If FACT = 'X': +*> the array dimension is (LDC,N). +*> If K = 0: +*> the M-by-N array C is not used. +*> If K > 0: +*> a) columns (1:K) of the array C contain +*> the M-by-K factor C (the selected columns +*> from the original matrix A). +*> b) columns (K+1:N) of the array C are +*> not used. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. +*> If FACT = 'P', LDC >= 1. +*> If FACT = 'C' or 'X', LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] QRC +*> \verbatim +*> QRC is COMPLEX array. +*> +*> If FACT = 'P' or 'C': The array is not used, +*> the array dimension is >= (1,1). +*> +*> If FACT = 'X': the array dimension is (LDQRC,min(M,N)). +*> +*> If K = 0, the array is not used. +*> If K > 0, QRC(1:M,1:K) stores two components from +*> the QR factorization of the factor C. The K-by-K +*> factor R is stored in the upper triangle. +*> The Householder vectors are stored in the lower +*> trapezoid below the diagonal. +*> \endverbatim +*> +*> \param[in] LDQRC +*> \verbatim +*> LDQRC is INTEGER +*> The leading dimension of the array QRC. +*> If FACT = 'P' or 'C', LDQRC >= 1. +*> If FACT = 'X', LDQRC >= max(1,M). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array. +*> If FACT = 'P' or 'C': The array is not used, +*> the array dimension is >= (1,1). +*> +*> If FACT = 'X': The array dimension is (LDX,N). +*> 1) If K = 0: +*> the M-by-N array X contains a copy of +*> the original M-by-N matrix A. +*> 2) If K > 0: +*> a) rows (1:K) of the M-by-N array X contain +*> the K-by-N factor X, where K <= N. +*> b) rows (K+1:M) of the M-by-N array X. +*> Each column of these rows contains the elements +*> whose sum of squares is the residual sum of +*> squares for the solution in each column of +*> the least squares problem. +*> min|| A - C*X ||_F for the unknown X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. +*> If FACT = 'P' or 'C', LDX >= 1. +*> If FACT = 'X', LDX >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array, dimension (max(1,LWORK)). +*> +*> On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> +*> Minimal LWORK workspace general requirement. +*> LWORK >= max( 1, min(M,N) + N ) would be sufficient for all +*> values of FACT and USESD flags. +*> +*> For good performance, LWORK should generally be larger, and +*> the user should query the routine for the optimal LWORK. +*> +*> If LWORK = -1, or LRWORK, or LIWORK =-1 then a workspace +*> query is assumed. The routine only calculates the optimal +*> size of the WORK, RWORK and IWORK arrays, returns these +*> values as the first entry of the WORK, RWORK, and IWORK +*> arrays respectively, and no error message related to LWORK +*> is issued by XERBLA. +*> +*> Exact minimal workspace requirements. +*> For USESD = 'N' or 'R' and for all FACT: +*> a) If FACT = 'P' or 'C': +*> LWORK >= max( 1, N-1 ) +*> b) If FACT = 'X': +*> LWORK >= max( 1, min(M,N) + N ) +*> For USESD = 'C' or 'A': +*> a) If FACT = 'P' or 'C': +*> LWORK >= max( 1, min(1,N_sel)*max(N_sel,N_free), +*> min(1,MINMNFREE)*(N_free-1) ) +*> b) If FACT = 'X': +*> LWORK >= max( 1, min(M,N) + N ) +*> where MINMNFREE = min( M_free, N_free ). +*> +*> NOTE: The decision, whether the routine uses unblocked +*> BLAS 2 or blocked BLAS 3 code is based not only on the +*> dimension LWORK of the available workspace WORK, but +*> also on: +*> 1a) column preselection stage using CGEQRF: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine CGEQRF +*> in comparison to N_sel. (For N_sel <= NX +*> or N_sel <= NB, unblocked code is used in CGEQRF.) +*> 1b) column preselection stage using CUNMQR: +*> the optimal block size NB returned by ILAENV for +*> the routine CUNMQR in comparison to N_sel. (For +*> N_sel <= NB, unblocked code is used in CUNMQR.) +*> 2) column selection stage via criteria using CGEQRP3RK: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine CGEQRP3RK +*> in comparison to min(M,N_sel). (For +*> min(M_sub, N_free, KMAXFREE) <= NX +*> or min(M_sub, N_free, KMAXFREE) <= NB, unblocked code +*> is used in CGEQRP3RK.) +*> 3a) computation of the factor X using CGEQRFin CGELS: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine CGEQRF +*> in comparison to K. (For K <= NX or K <= NB, +*> unblocked code is used in CGEQRFinside CGELS.) +*> 3b) computation of the factor X using CUNMQR in CGELS: +*> the optimal block size NB returned by ILAENV for +*> the routine CUNMQR in comparison to N. (For +*> N <= NB, unblocked code is used in CUNMQR +*> inside CGELS.) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (max(1,LRWORK)). +*> +*> On exit, if INFO >= 0, RWORK(1) returns the optimal LRWORK. +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The dimension of the array RWORK. +*> +*> Minimal LRWORK workspace general requirement. +*> LRWORK >= max( 1, 2*N ) would be sufficient for all values +*> of FACT and USESD flags. +*> +*> The optimal LRWORK is the same as the minimal LRWORK. +*> The user can still query the routine for the optimal LRWORK. +*> +*> If LWORK =-1, or LRWORK = -1, or LWORK = -1, then +*> a workspace query is assumed. The routine only calculates +*> the optimal size of the WORK, RWORK, and IWORK arrays, +*> returns these values as the first entry of the WORK, RWORK, +*> and IWORK arrays respectively, and no error message related +*> to LRWORK is issued by XERBLA. +*> +*> Exact minimal workspace requirements. +*> For USESD = 'N' or 'R' and all FACT, +*> LRWORK >= max( 1, 2*N ) +*> For USESD = 'C' or 'A' and all FACT, +*> LRWORK >= max( 1, max(N_sub, 2*N_free) ) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (max(1,LIWORK)). +*> +*> On exit, if INFO >= 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> +*> Minimal LIWORK workspace general requirement. +*> LIWORK >= max( 1, 2*N ) would be sufficient for all values +*> of FACT and USESD flags. +*> +*> The optimal LIWORK is the same as the minimal LIWORK. +*> The user can still query the routine for the optimal LIWORK. +*> +*> If LWORK =-1, or LRWORK = -1, or LWORK = -1, then +*> a workspace query is assumed. The routine only calculates +*> the optimal size of the WORK, RWORK, and IWORK arrays, +*> returns these values as the first entry of the WORK, RWORK, +*> and IWORK arrays respectively, and no error message related +*> to LIWORK is issued by XERBLA. +*> +*> Exact minimal workspace requirements. +*> For USESD = 'N' or 'R': +*> a) If FACT = 'P': +*> LIWORK >= max( 1, N-1 ) +*> b) If FACT = 'C' or 'X': +*> LIWORK >= max( 1, 2*N ) +*> For USESD = 'C' or 'A': +*> a) If FACT = 'P': +*> LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free ) +*> b) If FACT = 'C' or 'X': +*> LIWORK >= max( 1, 2*N ) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the i-th diagonal element of the +*> triangular R factor of the QR factorization of +*> the matrix C is zero. Consequently, C does not have +*> full rank, and X cannot be computed as the least +*> squares solution to the overdetermined system C*X = A. +*> (R is stored in the array QRC.) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2026, Igor Kozachenko, James Demmel, +*> EECS Department, +*> University of California, Berkeley, USA. +*> \endverbatim +* +*> \ingroup gecxx +* +* ===================================================================== + SUBROUTINE CGECXX( FACT, USESD, M, N, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ KMAXFREE, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, + $ X, LDX, WORK, LWORK, RWORK, LRWORK, + $ IWORK, LIWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER FACT, USESD + INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, + $ LDX, LIWORK, LRWORK, LWORK, M, N + REAL ABSTOL, FNRMK, MAXC2NRMK, + $ RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. + INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), + $ JPIV( * ), SEL_DESEL_COLS( * ) + REAL RWORK( * ) + COMPLEX A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), + $ TAU( * ), WORK( * ), X( LDX, *) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, TWO, MINUSONE + PARAMETER ( ZERO = 0.0E+0, TWO = 2.0E+0, + $ MINUSONE = -1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, RETURNC, RETURNX, + $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL + INTEGER I, IP, IINFO, ITEMP, J, JDESEL, JP, KFREE, + $ KMAXLS, KP0, LIWKMIN, LIWKOPT, LRWKMIN, + $ LRWKOPT, LWKMIN, LWKOPT, MFREE, MDESEL, MINMN, + $ MINMNFREE, MRESID, MSUB, NFREE, NDESEL, NRESID, + $ NSEL, NSUB + REAL ABSTOLFREE, EPS, MAXC2NRM, MAXC2NRMKFREE, + $ RELTOLFREE, RELMAXC2NRMKFREE, SAFMIN + +* .. External Subroutines .. + EXTERNAL CCOPY, CGELS, CGEQP3RK, CGEQRF, CLACPY, + $ CUNMQR, CSWAP, XERBLA +* .. +* .. External Functions .. + LOGICAL SISNAN, LSAME + INTEGER ICAMAX, ILAENV + REAL SLAMCH, CLANGE, SCNRM2 + EXTERNAL SISNAN, SLAMCH, CLANGE, SCNRM2, ICAMAX, + $ ILAENV, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, CMPLX, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + MDESEL = 0 + NSEL = 0 + NDESEL = 0 + MSUB = M + NSUB = N + MFREE = MSUB + NFREE = NSUB + MINMN = MIN( M, N ) +* + LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + RETURNX = LSAME( FACT, 'X' ) + RETURNC = LSAME( FACT, 'C' ) .OR. RETURNX +* + USE_DESEL_ROWS = LSAME( USESD, 'R' ) + $ .OR. LSAME( USESD, 'A' ) + USE_SEL_DESEL_COLS = LSAME( USESD, 'C' ) + $ .OR. LSAME( USESD, 'A' ) +* + IF( .NOT.( RETURNC .OR. LSAME( FACT, 'P') ) ) THEN + INFO = -1 + ELSE IF( .NOT.( USE_DESEL_ROWS .OR. USE_SEL_DESEL_COLS + $ .OR. LSAME( USESD, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE +* +* This is to check that the number of preselected columns NSEL +* cannot be larger than MSUB, which is the number of rows +* without MDESEL deselected rows. When the number of +* preselected columns NSEL is larger than MSUB, +* the factorization of all preselected NSEL columns cannot be +* completed. MSUB also will be used for LDX argument check +* later. +* + IF( USE_DESEL_ROWS ) THEN +* +* Count the number of free rows MSUB. +* + DO I = 1, M + IF( DESEL_ROWS( I ).EQ.-1 ) MDESEL = MDESEL + 1 + END DO + MSUB = M - MDESEL + MFREE = MSUB + END IF +* + IF( USE_SEL_DESEL_COLS ) THEN +* +* Count the number of preselected columns NSEL and the +* number of preselected and free columns NSUB = N - NDESEL. +* + DO J = 1, N + IF( SEL_DESEL_COLS( J ).EQ.1 ) NSEL = NSEL + 1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) NDESEL = NDESEL + 1 + END DO + NSUB = N - NDESEL + MFREE = MSUB - NSEL + NFREE = NSUB - NSEL +* + END IF + MINMNFREE = MIN( MFREE, NFREE ) +* + IF( NSEL.GT.MSUB ) THEN + INFO = -6 + ELSE IF( KMAXFREE.LT.0 ) THEN + INFO = -7 + ELSE IF( SISNAN( ABSTOL ) ) THEN + INFO = -8 + ELSE IF( SISNAN( RELTOL ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -11 +* This is a check for LDC + ELSE IF( ( RETURNC .AND. LDC.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNC .AND. LDC.LT.1 ) ) THEN + INFO = -20 +* This is a check for LDQRC + ELSE IF( ( RETURNX .AND. LDQRC.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNX .AND. LDQRC.LT.1 ) ) THEN + INFO = -22 +* This is a check for LDX + ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNX .AND. LDX.LT.1 ) ) THEN + INFO = -24 + END IF +* + END IF +* +* ================================================================== +* +* a) Test the input workspace size LWORK, LRWORK, LIWORK for the +* minimum size requirement LWKMIN, LRWKMIN, LIWKMIN +* respectively. +* b) Determine the optimal workspace sizes LWKOPT, LRWKOPT, +* and LIWKOPT to be returned in +* WORK( 1 ), RWORK( 1 ) and IWORK( 1 ) respectively, +* if INFO >= 0 in cases: +* (1) LQUERY = .TRUE., +* (2) when the routine exits. +* Here, LWKMIN, LRWKMIN and LIWKMIN are the minimum workspaces +* required for unblocked code. +* + IF( INFO.EQ.0 ) THEN + IF( MINMN.EQ.0 ) THEN + LWKMIN = 1 + LWKOPT = 1 + LRWKMIN = 1 + LRWKOPT = 1 + LIWKMIN = 1 + LIWKOPT = 1 + ELSE +* +* (Complex_wk_part_1) Complex minimum and optimal workspace +* computation. +* + LWKMIN = 1 + LWKOPT = LWKMIN +* +* (Real_wk_part_1) Real minimum workspace computation. +* LRWKMIN = MAX(1, NSUB) for column 2-norm computation +* + LRWKMIN = MAX( 1, NSUB ) +* +* (Int_wk_part_1) Integer minimum workspace computation. +* + LIWKMIN = 1 +* +* Call of CGEQRF. +* + IF( NSEL.GT.0 ) THEN +* +* (Complex_wk_part_2) Complex minimum workspace +* computation. +* + LWKMIN = MAX( LWKMIN, NSEL ) +* +* Query for optimal workspace size for CGEQRF. +* + CALL CGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, + $ -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* +* Call of CUNMQR. +* + IF( NFREE.GT.0 ) THEN +* +* (Complex_wk_part_3) Complex minimum workspace +* computation. +* + LWKMIN = MAX( LWKMIN, NFREE ) +* +* Query for optimal workspace size for CUNMQR. +* + CALL CUNMQR( 'L', 'C', MSUB, NFREE, + $ NSEL, A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, + $ -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) + END IF +* + END IF +* +* Call of CGEQP3RK. +* + IF ( MINMNFREE.NE.0 ) THEN +* +* (Complex_wk_part_4) Complex minimum workspace +* computation. +* LWKMIN = MAX(1, NFREE-1) for the call of CGEQP3RK. +* + LWKMIN = MAX( LWKMIN, NFREE - 1 ) +* +* Query for optimal workspace size for CGEQP3RK. +* + CALL CGEQP3RK( MFREE, NFREE, 0, NFREE, + $ MINUSONE, MINUSONE, + $ A( 1, 1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( 1 ), TAU( 1 ), + $ WORK, -1, RWORK, IWORK, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* +* (Real_wk_part_2) Real minimum workspace computation. +* LRWKMIN = MAX(1, 2*NFREE) for the call of CGEQP3RK. +* + LRWKMIN = MAX( LRWKMIN, 2*NFREE ) +* +* (Int_wk_part_2) Integer minimum workspace computation. +* LIWKMIN = NFREE-1 for the call of CGEQP3RK. +* + LIWKMIN = MAX( LIWKMIN, NFREE-1 ) +* + IF( NSEL.NE.0 ) THEN +* +* (Int_wk_part_3) Integer minimum workspace computation. +* NFREE is for CGEQP3RK and NFREE-1 for JPIV adjustment. +* + LIWKMIN = MAX( LIWKMIN, NFREE + NFREE-1 ) + END IF +* + END IF +* + IF( RETURNC ) THEN +* +* Integer minimum workspace computation. +* (Int_wk_part_4) LIWKMIN = 2*N for applying the +* interchanges for the columns in the matrix C. +* + LIWKMIN = MAX( LIWKMIN, 2*N ) + END IF +* +* Real and Integer optimal workspace computation. +* + LRWKOPT = LRWKMIN + LIWKOPT = LIWKMIN +* +* Call of CGELS. +* + IF( RETURNX ) THEN +* +* (Complex_wk_part_5) Complex minimum workspace computation. +* LWKMIN = max( 1, MINMN + max( MINMN, N ) ) = +* = max( 1, MINMN + N ) for the call of CGELS. +* + LWKMIN = MAX( LWKMIN, MINMN + N ) +* +* Query for optimal workspace size for CGELS. +* + KMAXLS = MINMN +* + CALL CGELS( 'N', M, KMAXLS, N, QRC, LDQRC, X, LDX, + $ WORK, -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK(1) ) ) +* + END IF + +* +* End of ELSE for IF( MINMN.EQ.0 ) +* + END IF +* + IF( ( LWORK.LT.LWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -26 + ELSE IF( ( LRWORK.LT.LRWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -28 + ELSE IF( ( LIWORK.LT.LIWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -30 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = CMPLX( LWKOPT ) + RWORK( 1 ) = REAL( LRWKOPT ) + IWORK( 1 ) = LIWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'CGECXX', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* ================================================================== +* +* Quick return if possible for: +* a) M = 0 or N = 0. There is no matrix A(1:M,1:N). +* b) MSUB = 0 or NSUB = 0. There is no matrix A_sub(1:MSUB,1:NSUB). +* NOTE: min( M, N) = 0 implies min( MSUB, NSUB) = 0. +* We need to return correct values for all scalar output parameters, +* (including WORK(1) and IWORK(1), which are set above). +* + IF( MIN( MSUB, NSUB ).EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + FNRMK = ZERO + RETURN + END IF +* +* ================================================================== +* + K = 0 +* +* If we need to return factor X, copy the original untouched matrix +* A into the array X. +* + IF( RETURNX ) THEN + CALL CLACPY( 'F', M, N, A, LDA, X, LDX ) + END IF +* +* If we need to return the factor C, copy the original matrix A +* into the array C, only if do not return the factor X. In this +* case, we need to choose the columns of the matrix A in the array C +* in place, otherwise we can copy the columns of the matrix A from +* the array X. +* + IF( RETURNC .AND. .NOT. RETURNX ) THEN + CALL CLACPY( 'F', M, N, A, LDA, C, LDC ) + END IF +* +* ================================================================== +* Permute the deselected rows to the bottom of the matrix A. +* 1) The initial order of included rows in their block is preserved. +* 2) The initial order of deselected rows in their block is not +* preserved. +* ================================================================== +* +* I is an index of DESEL_ROWS array and a row index of +* the matrix A. MSUB is the number of processed included rows, which +* is also an index pointer to the last included row in the matrix A. +* We can think of I as a row source index, and MSUB as a destination +* index for moving an included row in the matrix A. +* +* ( We start with MSUB = 0. We loop over index I in (1:M), and +* for each position I in DESEL_ROWS array, we check if the row at +* the position I in the matrix A is an included row (not -1 value). +* If it is an included row, we increment MSUB pointer, otherwise +* we do not change MSUB index pointer. Then, we bring this included +* row from the index I in the matrix A into smaller (or same) +* MSUB index in the matrix A. If I = MSUB, then the included row +* is already in place. Due to row swap, the deselected row +* at MSUB index will move into I index in the matrix A. In this way, +* we move all the included rows to the top matrix block preserving +* their initial order within the included block. The initial order +* of deselected rows will not be preserved within their block. +* + IF( USE_DESEL_ROWS ) THEN +* + MSUB = 0 + DO I = 1, M, 1 +* +* Initialize the row pivot array IPIV. + IPIV( I ) = I +* +* The row at the index I is an included row and should be +* moved to the top of the matrix A. +* + IF( DESEL_ROWS( I ).NE.-1 ) THEN + MSUB = MSUB + 1 +* +* This is a check whether the included row is +* on the included place already. +* + IF( I.NE.MSUB ) THEN +* +* Here, we swap A(I,1:N) into A(MSUB,1:N). +* + CALL CSWAP( N, A( I, 1 ), LDA, A( MSUB, 1 ), LDA ) +* +* Save the interchange. +* + IPIV( I ) = IPIV( MSUB ) + IPIV( MSUB ) = I + DESEL_ROWS( MSUB ) = DESEL_ROWS( I ) + DESEL_ROWS( I ) = -1 + END IF + END IF +* + END DO +* + ELSE +* +* We do not use the row deselection DESEL_ROWS array. +* Initialize the row pivot array IPIV. +* NOTE: MSUB=M has default value, +* which is set at the beginning of the routine, before argument +* checks. +* + DO I = 1, M, 1 + IPIV( I ) = I + END DO + END IF +* +* ================================================================== +* Permute the preselected columns to the left and deselected +* columns to the right of the matrix A. +* 1) The order of preselected columns is preserved. +* 2) The order of free columns is not preserved. +* 3) The order of deselected columns is not preserved. +* ================================================================== +* +* J is the index of SEL_DESEL_COLS array and column J +* of the matrix A. +* + IF( USE_SEL_DESEL_COLS ) THEN +* +* Column selection. +* NSEL is the number of selected columns, also the pointer to +* the last selected column. +* + NSEL = 0 + DO J = 1, N, 1 +* +* Initialize column pivot array JPIV. + JPIV( J ) = J +* + IF( SEL_DESEL_COLS( J ).EQ.1 ) THEN + NSEL = NSEL + 1 +* +* This is the check whether the selected column is +* on the selected place already. +* + IF( J.NE.NSEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,NSEL) +* + CALL CSWAP( M, A( 1, J ), 1, A( 1, NSEL ), 1 ) + JPIV( J ) = JPIV( NSEL ) + JPIV( NSEL ) = J + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( NSEL ) + SEL_DESEL_COLS( NSEL ) = 1 + END IF + END IF + END DO +* +* Column deselection. +* JDESEL the pointer to the last +* deselected column counting right-to-left. +* + JDESEL = N+1 + DO J = N, NSEL+1, -1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) THEN + JDESEL = JDESEL - 1 +* +* This is the check whether the deselected column is +* on the deselected place already. +* + IF( J.NE.JDESEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,JDESEL) +* + CALL CSWAP( M, A( 1, J ), 1, A( 1, JDESEL ), 1 ) + ITEMP = JPIV( J ) + JPIV( J ) = JPIV( JDESEL ) + JPIV( JDESEL ) = ITEMP + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( JDESEL ) + SEL_DESEL_COLS( JDESEL ) = -1 + END IF + END IF + END DO +* + NSUB = JDESEL - 1 +* + ELSE +* +* We do not use the column selection deselection +* SEL_DESEL_COLS array. +* Initialize column pivot array JPIV. +* NOTE: NSUB=N has default value, +* which is set at the beginning of the routine, before argument +* checks. +* + DO J = 1, N, 1 + JPIV( J ) = J + END DO +* + END IF +* +* ================================================================== +* Compute the complete column 2-norms of the submatrix +* A_sub = A(1:MSUB, 1:NSUB) and store them in WORK(1:NSUB). +* + DO J = 1, NSUB + RWORK( J ) = SCNRM2( MSUB, A( 1, J ), 1 ) + END DO +* +* Compute the column index of the maximum column 2-norm and +* the maximum column 2-norm itself for the submatrix +* A_sub = A(1:MSUB, 1:NSUB). +* + KP0 = ICAMAX( NSUB, WORK( 1 ), 1 ) + MAXC2NRM = RWORK( KP0 ) +* +* ================================================================== +* Process preselected columns +* +* Compute the QR factorization of NSEL preselected columns (1:NSEL) +* in the submatrix A_sub = A(1:MSUB, 1:NSUB) and update +* remaining NFREE free columns (NSEL+1:NSUB). +* NSUB = NSEL + NFREE +* + IF( NSEL.GT.0 ) THEN +* +* Case (a): MSUB < NSEL. +* +* This is handled at the argument check stage in the +* beginning of the routine. When the number of preselected +* columns is larger than MSUB, hence the factorization of +* all NSEL columns cannot be completed. Return from the +* routine with the error of COL_SEL_DESEL parameter. +* +* Case (b): MSUB = NSEL. +* Case (c-1): MSUB > NSEL and NSEL = NSUB. +* +* For cases (b) and (c-1), there will be no residual +* submatrix after factorization of NSEL columns +* at step K = NSEL: +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). +* +* Case (c-2): MSUB > NSEL and NSEL < NSUB. +* +* For Case (c-2) is a submatrix residual at step K=NSEL +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) +* + CALL CGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, LWORK, IINFO ) +* +* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) +* + IF( NFREE.GT.0 ) THEN +* +* This is only for case (c-2) ('L' = Left, 'T' = Transpose) +* + CALL CUNMQR( 'L', 'C', MSUB, NFREE, NSEL, + $ A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, + $ LWORK, IINFO ) + END IF +* + K = K + NSEL +* +* End of IF(NSEL.GT.0) +* + END IF +* +* ================================================================== +* + KFREE = 0 +* + IF( MINMNFREE.NE.0 ) THEN +* +* Factorize NFREE free columns of +* A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), +* KFREE is the number of columns that were actually factorized +* among NFREE columns. +* +* ================================================================== +* + EPS = SLAMCH('Epsilon') +* + USETOL = .FALSE. +* +* Adjust ABSTOL only if nonnegative. Negative value means disabled. +* We need to keep negative value for later use in criterion +* check. +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = SLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + USETOL = .TRUE. + END IF +* +* Adjust RELTOL only if nonnegative. Negative value means disabled. +* We need to keep negative value for later use in criterion +* check. +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + USETOL = .TRUE. + END IF +* +* ================================================================== +* +* Disable RELTOLFREE when calling CGEQP3RK for free columns +* factorization, since CGEQP3RK expects RELTOLFREE with respect +* to the residual matrix A_sub_resid(NSEL), not the whole +* original matrix A. We can use RELTOL criterion by passing it +* to ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that +* the negative values of ABSTOL and RELTOL are propagated +* to ABSTOLFREE and RELTOLFREE, since negative values means +* that the criterion is disabled. +* + IF( USETOL ) THEN + ABSTOLFREE = MAX( ABSTOL, RELTOL * MAXC2NRM ) + ELSE + ABSTOLFREE = MINUSONE + END IF + RELTOLFREE = MINUSONE +* +* Save JPIV(NSEL+1:NSUB) into WORK(NFREE+1:2*NFREE-1) +* + IF( NSEL.NE.0 ) THEN + DO J = 1, NFREE, 1 + IWORK( NFREE + J ) = JPIV( NSEL+J ) + END DO + END IF +* + CALL CGEQP3RK( MFREE, NFREE, 0, KMAXFREE, + $ ABSTOLFREE, RELTOLFREE, + $ A( NSEL+1, NSEL+1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( NSEL+1 ), + $ TAU( NSEL+1 ), WORK, LWORK, RWORK, IWORK, + $ IINFO ) +* +* Adjust JPIV +* + IF( NSEL.NE.0 ) THEN + DO J = 1, NFREE, 1 + JPIV( NSEL+J ) = IWORK( NFREE + JPIV( NSEL+J ) ) + END DO + END IF +* +* 1) Adjust the return value for the number of factorized +* columns K for the whole submatrix A_sub. +* 2) MAXC2NRMK is returned transparently without change +* as MAXC2NRMKFREE is returned from CGEQP3RK. +* 3) Adjust the return value RELMAXC2NRMK for the whole +* submatrix A_sub. We do not use RELMAXC2NRMKFREE +* returned from CGEQP3RK. +* + K = K + KFREE + MAXC2NRMK = MAXC2NRMKFREE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + ELSE +* +* Set norms to zero +* + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + END IF +* +* Now, MRESID and NRESID is the number of rows and columns +* respectively in A_free_resid = A(K+1:MSUB,K+1:NSUB). +* + MRESID = MFREE-KFREE + NRESID = NFREE-KFREE +* + IF( MIN( MRESID, NRESID ).NE.0 ) THEN + FNRMK = CLANGE( 'F', MRESID, NRESID, A( K+1, K+1 ), + $ LDA, WORK ) + ELSE + FNRMK = ZERO + END IF +* +* ================================================================== +* +* Return the matrix C. +* + IF( RETURNC .AND. K.GT.0 ) THEN +* + IF( RETURNX ) THEN +* +* Copy the selected K columns of the original matrix A (that was +* saved into the array X) into the array C according to +* the pivot array JPIV. If we return X, then the matrix A is +* saved in the array X, and it is faster to copy into C than +* doing column permutation in place, as it is the ELSE case. +* + DO J = 1, K, 1 + CALL CCOPY( M, X( 1, JPIV( J ) ), 1, C( 1, J ), 1 ) + END DO +* + ELSE +* +* Swap the columns of the original matrix A copied into +* the array C in place. +* +* The original M-by-N matrix A was copied into the array C at +* the beginning of the routine, if RETURNC = .TRUE.. + +* Apply the column permutation matrix P stored in JPIV(1:K) +* to the columns 1:K in the M-by-N array C in place. +* After column interchanges, the first K columns of C should +* be the same as the first K columns of A*P, i.e. +* (A*P)(1:M,1:K) = C(1:M,1:K). The complexity of this algorithm +* is min(K,N-1). +* +* Index I is the original column index in the +* array C before interchanges. +* J is the current column index of the original column I at +* each step of interchanges. +* +* Auxiliary array IWORK(1:N) stores the inverse P_inv(J) +* of the current column permutation matrix P(J) at each +* column interchange step J only for the array +* values >= J:N. +* C_prev = P_inv(J) * C_next. +* Each IWORK(I) contains JJ corresponding to I +* Initialize IWORK(1:N) as (1:N). +* + DO I = 1, N, 1 + IWORK( I ) = I + END DO +* +* Auxiliary array IWORK(N+1:2N) stores the current column +* permutation matrix P_(J) at each column interchange step J +* only for the array index >= J:N. +* C_prev * P_(J) = C_next. +* Each IWORK(N+JJ) contains I corresponding to JJ. +* Initialize IWORK(N+1:2*N) as (1:N). +* + DO J = 1, N, 1 + IWORK( N + J ) = J + END DO +* +* Loop over the columns J = ( 1:min( K, N-1 ) ) in C. +* + DO J = 1, MIN( K, N-1 ), 1 +* +* IP is the original pivot column, i.e. is the original +* column that should be placed in the current column index +* J in the array C. +* + IP = JPIV( J ) +* +* I is the original column that is +* currently in the column index J in the array C after +* previous column interchanges. +* + I = IWORK( N+J ) +* + IF( I.NE.IP ) THEN +* +* JP is the current index of the original pivot +* column IP in the array C after previous column +* interchanges. +* + JP = IWORK( IP ) + +* Swap the original pivot column IP = JPIV( J ), +* at the current pivot index JP = IWORK( IP ) into +* index J. +* + CALL CSWAP( M, C( 1, J ), 1, C( 1, JP ), 1 ) +* +* Update the array IWORK(1:N) for the original column +* I that was swapped with IP. +* + IWORK( I ) = IWORK( IP ) +* +* Update the array IWORK(N+1:2*N) for the current column +* index JP that was swapped with the current column +* index J. +* + IWORK( N + JP ) = IWORK( N + J ) +* + END IF +* + END DO +* +* End of ELSE( RETURNX ) +* + END IF +* +* End of IF( RETURNC .AND. K.GT.0 ) +* + END IF +* +* ================================================================== +* +* Return the matrix X. +* + IF( RETURNX .AND. K.GT.0 ) THEN +* +* We need to use C and A to compute X = pseudoinv(C) * A, as +* the linear least squares solution to the overdetermined system +* C*X = A. We use LLS routine that uses the QR factorization. For +* that purpose, we store the matrix C into the array QRC. +* The matrix A was copied into the array X at the beginning +* of the routine. +* + CALL CLACPY( 'F', M, K, C, LDC, QRC, LDQRC ) +* + CALL CGELS( 'N', M, K, N, QRC, LDQRC, X, LDX, + $ WORK, LWORK, IINFO ) + INFO = IINFO +* + END IF +* + WORK( 1 ) = CMPLX( LWKOPT ) + RWORK( 1 ) = REAL( LRWKOPT ) + IWORK( 1 ) = LIWKOPT +* +* End of CGECXX +* + END diff --git a/lapack-netlib/SRC/dgecxx.c b/lapack-netlib/SRC/dgecxx.c new file mode 100644 index 0000000000..a4beaae8a9 --- /dev/null +++ b/lapack-netlib/SRC/dgecxx.c @@ -0,0 +1,1432 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i msub) { + *info = -6; + } else if (*kmaxfree < 0) { + *info = -7; + } else if (disnan_(abstol)) { + *info = -8; + } else if (disnan_(reltol)) { + *info = -9; + } else if (*lda < f2cmax(1,*m)) { + *info = -11; +/* This is a check for LDC */ + } else if (returnc && *ldc < f2cmax(1,*m) || ! returnc && *ldc < 1) { + *info = -20; +/* This is a check for LDQRC */ + } else if (returnx && *ldqrc < f2cmax(1,*m) || ! returnx && *ldqrc < 1) { + *info = -22; +/* This is a check for LDX */ + } else if (returnx && *ldx < f2cmax(1,*m) || ! returnx && *ldx < 1) { + *info = -24; + } + + } + +/* ================================================================== */ + +/* a) Test the input workspace size LWORK and LIWORK for the */ +/* minimum size requirement LWKMIN and LIWKMIN respectively. */ +/* b) Determine the optimal workspace sizes LWKOPT and LIWKOPT to */ +/* be returned in WORK( 1 ) and IWORK( 1 ) respectively, */ +/* if INFO >= 0 in cases: */ +/* (1) LQUERY = .TRUE., */ +/* (2) when the routine exits. */ +/* Here, LWKMIN and LIWKMIN are the minimum workspaces required for */ +/* unblocked code. */ + + if (*info == 0) { + if (minmn == 0) { + lwkmin = 1; + lwkopt = 1; + liwkmin = 1; + liwkopt = 1; + } else { + +/* (Real_wk_part_1) Real minimum and optimal workspace */ +/* computation. */ +/* LWKMIN = MAX(1, NSUB) for column 2-norm computation */ + + lwkmin = f2cmax(1,nsub); + lwkopt = lwkmin; + +/* (Int_wk_part_1) Integer minimum workspace computation. */ + + liwkmin = 1; + +/* Call of DGEQRF. */ + + if (nsel > 0) { + +/* (Real_wk_part_2) Real minimum workspace computation. */ +/* LWKMIN = MAX(1, NSEL) for the call of DGEQRF. */ +/* We can skip counting this workspace as */ +/* LWKMIN = MAX( LWKMIN, NSEL ), since NSEL <= NSUB. */ + +/* Query for optimal workspace size for DGEQRF. */ + + dgeqrf_(&msub, &nsel, &a[a_offset], lda, &tau[1], &work[1], & + c_n1, &iinfo); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + +/* Call of DORMQR. */ + + if (nfree > 0) { + +/* (Real_wk_part_3) Real minimum workspace computation. */ +/* NOTE: minimum workspace requirement for DORMQR */ +/* LWKMIN = MAX(1, NFREE) is smaller than NSUB */ +/* and it is smaller than LWKMIN = 3*NFREE-1 for */ +/* DGEQP3RK. We can skip counting this workspace as */ +/* as LWKMIN = MAX( LWKMIN, NFREE ). */ + +/* Query for optimal workspace size for DORMQR. */ + + dormqr_("L", "T", &msub, &nfree, &nsel, &a[a_offset], lda, + &tau[1], &a[(nsel + 1) * a_dim1 + 1], lda, &work[ + 1], &c_n1, &iinfo); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + } + + } + +/* Call of DGEQP3RK. */ + + if (minmnfree != 0) { + +/* (Real_wk_part_4) Real minimum workspace computation. */ +/* LWKMIN = MAX(1, 3*NFREE-1) for the call of DGEQP3RK. */ + +/* Computing MAX */ + i__1 = lwkmin, i__2 = nfree * 3 - 1; + lwkmin = f2cmax(i__1,i__2); + +/* Query for optimal workspace size for DGEQP3RK. */ + + dgeqp3rk_(&mfree, &nfree, &c__0, &nfree, &c_b15, &c_b15, &a[ + a_dim1 + 1], lda, &kfree, &maxc2nrmkfree, & + relmaxc2nrmkfree, &jpiv[1], &tau[1], &work[1], &c_n1, + &iwork[1], &iinfo); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + +/* (Int_wk_part_2) Integer minimum workspace computation. */ +/* LIWKMIN = NFREE-1 for the call of DGEQP3RK. */ + +/* Computing MAX */ + i__1 = liwkmin, i__2 = nfree - 1; + liwkmin = f2cmax(i__1,i__2); + + if (nsel != 0) { + +/* (Int_wk_part_3) Integer minimum workspace computation. */ +/* NFREE is for DGEQP3RK and NFREE-1 for JPIV adjustment. */ + +/* Computing MAX */ + i__1 = liwkmin, i__2 = nfree + nfree - 1; + liwkmin = f2cmax(i__1,i__2); + } + + } + + if (returnc) { + +/* Integer minimum workspace computation. */ +/* (Int_wk_part_4) LIWKMIN = 2*N for applying the */ +/* interchanges for the columns in the matrix C. */ + +/* Computing MAX */ + i__1 = liwkmin, i__2 = *n << 1; + liwkmin = f2cmax(i__1,i__2); + } + +/* Integer optimal workspace computation. */ + + liwkopt = liwkmin; + +/* Call of DGELS. */ + + if (returnx) { + +/* (Real_wk_part_5) Real minimum workspace computation. */ +/* LWKMIN = f2cmax( 1, MINMN + f2cmax( MINMN, N ) ) = */ +/* = f2cmax( 1, MINMN + N ) for the call of DGELS. */ + +/* Computing MAX */ + i__1 = lwkmin, i__2 = minmn + *n; + lwkmin = f2cmax(i__1,i__2); + +/* Query for optimal workspace size for DGELS. */ + + kmaxls = minmn; + + dgels_("N", m, &kmaxls, n, &qrc[qrc_offset], ldqrc, &x[ + x_offset], ldx, &work[1], &c_n1, &iinfo); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + + } + +/* End of ELSE for IF( MINMN.EQ.0 ) */ + + } + + if (*lwork < lwkmin && ! lquery) { + *info = -26; + } else if (*liwork < liwkmin && ! lquery) { + *info = -28; + } + } + + if (*info == 0) { + work[1] = (doublereal) lwkopt; + iwork[1] = liwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DGECXX", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* ================================================================== */ + +/* Quick return if possible for: */ +/* a) M = 0 or N = 0. There is no matrix A(1:M,1:N). */ +/* b) MSUB = 0 or NSUB = 0. There is no matrix A_sub(1:MSUB,1:NSUB). */ +/* NOTE: f2cmin( M, N) = 0 implies f2cmin( MSUB, NSUB) = 0. */ +/* We need to return correct values for all scalar output parameters, */ +/* (including WORK(1) and IWORK(1), which are set above). */ + + if (f2cmin(msub,nsub) == 0) { + *k = 0; + *maxc2nrmk = 0.; + *relmaxc2nrmk = 0.; + *fnrmk = 0.; + return 0; + } + +/* ================================================================== */ + + *k = 0; + +/* If we need to return factor X, copy the original untouched matrix */ +/* A into the array X. */ + + if (returnx) { + dlacpy_("F", m, n, &a[a_offset], lda, &x[x_offset], ldx); + } + +/* If we need to return the factor C, copy the original matrix A */ +/* into the array C, only if do not return the factor X. In this */ +/* case, we need to choose the columns of the matrix A in the array C */ +/* in place, otherwise we can copy the columns of the matrix A from */ +/* the array X. */ + + if (returnc && ! returnx) { + dlacpy_("F", m, n, &a[a_offset], lda, &c__[c_offset], ldc); + } + +/* ================================================================== */ +/* Permute the deselected rows to the bottom of the matrix A. */ +/* 1) The initial order of included rows in their block is preserved. */ +/* 2) The initial order of deselected rows in their block is not */ +/* preserved. */ +/* ================================================================== */ + +/* I is an index of DESEL_ROWS array and a row index of */ +/* the matrix A. MSUB is the number of processed included rows, which */ +/* is also an index pointer to the last included row in the matrix A. */ +/* We can think of I as a row source index, and MSUB as a destination */ +/* index for moving an included row in the matrix A. */ + +/* ( We start with MSUB = 0. We loop over index I in (1:M), and */ +/* for each position I in DESEL_ROWS array, we check if the row at */ +/* the position I in the matrix A is an included row (not -1 value). */ +/* If it is an included row, we increment MSUB pointer, otherwise */ +/* we do not change MSUB index pointer. Then, we bring this included */ +/* row from the index I in the matrix A into smaller (or same) */ +/* MSUB index in the matrix A. If I = MSUB, then the included row */ +/* is already in place. Due to row swap, the deselected row */ +/* at MSUB index will move into I index in the matrix A. In this way, */ +/* we move all the included rows to the top matrix block preserving */ +/* their initial order within the included block. The initial order */ +/* of deselected rows will not be preserved within their block. */ + + if (use_desel_rows__) { + + msub = 0; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Initialize the row pivot array IPIV. */ + ipiv[i__] = i__; + +/* The row at the index I is an included row and should be */ +/* moved to the top of the matrix A. */ + + if (desel_rows__[i__] != -1) { + ++msub; + +/* This is a check whether the included row is */ +/* on the included place already. */ + + if (i__ != msub) { + +/* Here, we swap A(I,1:N) into A(MSUB,1:N). */ + + dswap_(n, &a[i__ + a_dim1], lda, &a[msub + a_dim1], lda); + +/* Save the interchange. */ + + ipiv[i__] = ipiv[msub]; + ipiv[msub] = i__; + desel_rows__[msub] = desel_rows__[i__]; + desel_rows__[i__] = -1; + } + } + + } + + } else { + +/* We do not use the row deselection DESEL_ROWS array. */ +/* Initialize the row pivot array IPIV. */ +/* NOTE: MSUB=M has default value, */ +/* which is set at the beginning of the routine, before argument */ +/* checks. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + ipiv[i__] = i__; + } + } + +/* ================================================================== */ +/* Permute the preselected columns to the left and deselected */ +/* columns to the right of the matrix A. */ +/* 1) The order of preselected columns is preserved. */ +/* 2) The order of free columns is not preserved. */ +/* 3) The order of deselected columns is not preserved. */ +/* ================================================================== */ + +/* J is the index of SEL_DESEL_COLS array and column J */ +/* of the matrix A. */ + + if (use_sel_desel_cols__) { + +/* Column selection. */ +/* NSEL is the number of selected columns, also the pointer to */ +/* the last selected column. */ + + nsel = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Initialize column pivot array JPIV. */ + jpiv[j] = j; + + if (sel_desel_cols__[j] == 1) { + ++nsel; + +/* This is the check whether the selected column is */ +/* on the selected place already. */ + + if (j != nsel) { + +/* Here, we swap the column A(1:M,J) into A(1:M,NSEL) */ + + dswap_(m, &a[j * a_dim1 + 1], &c__1, &a[nsel * a_dim1 + 1] + , &c__1); + jpiv[j] = jpiv[nsel]; + jpiv[nsel] = j; + sel_desel_cols__[j] = sel_desel_cols__[nsel]; + sel_desel_cols__[nsel] = 1; + } + } + } + +/* Column deselection. */ +/* JDESEL the pointer to the last */ +/* deselected column counting right-to-left. */ + + jdesel = *n + 1; + i__1 = nsel + 1; + for (j = *n; j >= i__1; --j) { + if (sel_desel_cols__[j] == -1) { + --jdesel; + +/* This is the check whether the deselected column is */ +/* on the deselected place already. */ + + if (j != jdesel) { + +/* Here, we swap the column A(1:M,J) into A(1:M,JDESEL) */ + + dswap_(m, &a[j * a_dim1 + 1], &c__1, &a[jdesel * a_dim1 + + 1], &c__1); + itemp = jpiv[j]; + jpiv[j] = jpiv[jdesel]; + jpiv[jdesel] = itemp; + sel_desel_cols__[j] = sel_desel_cols__[jdesel]; + sel_desel_cols__[jdesel] = -1; + } + } + } + + nsub = jdesel - 1; + + } else { + +/* We do not use the column selection deselection */ +/* SEL_DESEL_COLS array. */ +/* Initialize column pivot array JPIV. */ +/* NOTE: NSUB=N has default value, */ +/* which is set at the beginning of the routine, before argument */ +/* checks. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jpiv[j] = j; + } + + } + +/* ================================================================== */ +/* Compute the complete column 2-norms of the submatrix */ +/* A_sub = A(1:MSUB, 1:NSUB) and store them in WORK(1:NSUB). */ + + i__1 = nsub; + for (j = 1; j <= i__1; ++j) { + work[j] = dnrm2_(&msub, &a[j * a_dim1 + 1], &c__1); + } + +/* Compute the column index of the maximum column 2-norm and */ +/* the maximum column 2-norm itself for the submatrix */ +/* A_sub = A(1:MSUB, 1:NSUB). */ + + kp0 = idamax_(&nsub, &work[1], &c__1); + maxc2nrm = work[kp0]; + +/* ================================================================== */ +/* Process preselected columns */ + +/* Compute the QR factorization of NSEL preselected columns (1:NSEL) */ +/* in the submatrix A_sub = A(1:MSUB, 1:NSUB) and update */ +/* remaining NFREE free columns (NSEL+1:NSUB). */ +/* NSUB = NSEL + NFREE */ + + if (nsel > 0) { + +/* Case (a): MSUB < NSEL. */ + +/* This is handled at the argument check stage in the */ +/* beginning of the routine. When the number of preselected */ +/* columns is larger than MSUB, hence the factorization of */ +/* all NSEL columns cannot be completed. Return from the */ +/* routine with the error of COL_SEL_DESEL parameter. */ + +/* Case (b): MSUB = NSEL. */ +/* Case (c-1): MSUB > NSEL and NSEL = NSUB. */ + +/* For cases (b) and (c-1), there will be no residual */ +/* submatrix after factorization of NSEL columns */ +/* at step K = NSEL: */ +/* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). */ + +/* Case (c-2): MSUB > NSEL and NSEL < NSUB. */ + +/* For Case (c-2) is a submatrix residual at step K=NSEL */ +/* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) */ + + dgeqrf_(&msub, &nsel, &a[a_offset], lda, &tau[1], &work[1], lwork, & + iinfo); + +/* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) */ + + if (nfree > 0) { + +/* This is only for case (c-2) ('L' = Left, 'T' = Transpose) */ + + dormqr_("L", "T", &msub, &nfree, &nsel, &a[a_offset], lda, &tau[1] + , &a[(nsel + 1) * a_dim1 + 1], lda, &work[1], lwork, & + iinfo); + } + + *k += nsel; + +/* End of IF(NSEL.GT.0) */ + + } + +/* ================================================================== */ + + kfree = 0; + + if (minmnfree != 0) { + +/* Factorize NFREE free columns of */ +/* A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), */ +/* KFREE is the number of columns that were actually factorized */ +/* among NFREE columns. */ + +/* ================================================================== */ + + eps = dlamch_("Epsilon"); + + usetol = FALSE_; + +/* Adjust ABSTOL only if nonnegative. Negative value means disabled. */ +/* We need to keep negative value for later use in criterion */ +/* check. */ + + if (*abstol >= 0.) { + safmin = dlamch_("Safe minimum"); +/* Computing MAX */ + d__1 = *abstol, d__2 = safmin * 2.; + *abstol = f2cmax(d__1,d__2); + usetol = TRUE_; + } + +/* Adjust RELTOL only if nonnegative. Negative value means disabled. */ +/* We need to keep negative value for later use in criterion */ +/* check. */ + + if (*reltol >= 0.) { + *reltol = f2cmax(*reltol,eps); + usetol = TRUE_; + } + +/* ================================================================== */ + +/* Disable RELTOLFREE when calling DGEQP3RK for free columns */ +/* factorization, since DGEQP3RK expects RELTOLFREE with respect */ +/* to the residual matrix A_sub_resid(NSEL), not the whole */ +/* original matrix A. We can use RELTOL criterion by passing it */ +/* to ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that */ +/* the negative values of ABSTOL and RELTOL are propagated */ +/* to ABSTOLFREE and RELTOLFREE, since negative values means */ +/* that the criterion is disabled. */ + + if (usetol) { +/* Computing MAX */ + d__1 = *abstol, d__2 = *reltol * maxc2nrm; + abstolfree = f2cmax(d__1,d__2); + } else { + abstolfree = -1.; + } + reltolfree = -1.; + +/* Save JPIV(NSEL+1:NSUB) into WORK(NFREE+1:2*NFREE-1) */ + + if (nsel != 0) { + i__1 = nfree; + for (j = 1; j <= i__1; ++j) { + iwork[nfree + j] = jpiv[nsel + j]; + } + } + + dgeqp3rk_(&mfree, &nfree, &c__0, kmaxfree, &abstolfree, &reltolfree, & + a[nsel + 1 + (nsel + 1) * a_dim1], lda, &kfree, & + maxc2nrmkfree, &relmaxc2nrmkfree, &jpiv[nsel + 1], &tau[nsel + + 1], &work[1], lwork, &iwork[1], &iinfo); + +/* Adjust JPIV */ + + if (nsel != 0) { + i__1 = nfree; + for (j = 1; j <= i__1; ++j) { + jpiv[nsel + j] = iwork[nfree + jpiv[nsel + j]]; + } + } + +/* 1) Adjust the return value for the number of factorized */ +/* columns K for the whole submatrix A_sub. */ +/* 2) MAXC2NRMK is returned transparently without change */ +/* as MAXC2NRMKFREE is returned from DGEQP3RK. */ +/* 3) Adjust the return value RELMAXC2NRMK for the whole */ +/* submatrix A_sub. We do not use RELMAXC2NRMKFREE */ +/* returned from DGEQP3RK. */ + + *k += kfree; + *maxc2nrmk = maxc2nrmkfree; + *relmaxc2nrmk = *maxc2nrmk / maxc2nrm; + + } else { + +/* Set norms to zero */ + + *maxc2nrmk = 0.; + *relmaxc2nrmk = 0.; + + } + +/* Now, MRESID and NRESID is the number of rows and columns */ +/* respectively in A_free_resid = A(K+1:MSUB,K+1:NSUB). */ + + mresid = mfree - kfree; + nresid = nfree - kfree; + + if (f2cmin(mresid,nresid) != 0) { + *fnrmk = dlange_("F", &mresid, &nresid, &a[*k + 1 + (*k + 1) * a_dim1] + , lda, &work[1]); + } else { + *fnrmk = 0.; + } + +/* ================================================================== */ + +/* Return the matrix C. */ + + if (returnc && *k > 0) { + + if (returnx) { + +/* Copy the selected K columns of the original matrix A (that was */ +/* saved into the array X) into the array C according to */ +/* the pivot array JPIV. If we return X, then the matrix A is */ +/* saved in the array X, and it is faster to copy into C than */ +/* doing column permutation in place, as it is the ELSE case. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dcopy_(m, &x[jpiv[j] * x_dim1 + 1], &c__1, &c__[j * c_dim1 + + 1], &c__1); + } + + } else { + +/* Swap the columns of the original matrix A copied into */ +/* the array C in place. */ + +/* The original M-by-N matrix A was copied into the array C at */ +/* the beginning of the routine, if RETURNC = .TRUE.. */ +/* Apply the column permutation matrix P stored in JPIV(1:K) */ +/* to the columns 1:K in the M-by-N array C in place. */ +/* After column interchanges, the first K columns of C should */ +/* be the same as the first K columns of A*P, i.e. */ +/* (A*P)(1:M,1:K) = C(1:M,1:K). The complexity of this algorithm */ +/* is f2cmin(K,N-1). */ + +/* Index I is the original column index in the */ +/* array C before interchanges. */ +/* J is the current column index of the original column I at */ +/* each step of interchanges. */ + +/* Auxiliary array IWORK(1:N) stores the inverse P_inv(J) */ +/* of the current column permutation matrix P(J) at each */ +/* column interchange step J only for the array */ +/* values >= J:N. */ +/* C_prev = P_inv(J) * C_next. */ +/* Each IWORK(I) contains JJ corresponding to I */ +/* Initialize IWORK(1:N) as (1:N). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = i__; + } + +/* Auxiliary array IWORK(N+1:2N) stores the current column */ +/* permutation matrix P_(J) at each column interchange step J */ +/* only for the array index >= J:N. */ +/* C_prev * P_(J) = C_next. */ +/* Each IWORK(N+JJ) contains I corresponding to JJ. */ +/* Initialize IWORK(N+1:2*N) as (1:N). */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + iwork[*n + j] = j; + } + +/* Loop over the columns J = ( 1:f2cmin( K, N-1 ) ) in C. */ + +/* Computing MIN */ + i__2 = *k, i__3 = *n - 1; + i__1 = f2cmin(i__2,i__3); + for (j = 1; j <= i__1; ++j) { + +/* IP is the original pivot column, i.e. is the original */ +/* column that should be placed in the current column index */ +/* J in the array C. */ + + ip = jpiv[j]; + +/* I is the original column that is */ +/* currently in the column index J in the array C after */ +/* previous column interchanges. */ + + i__ = iwork[*n + j]; + + if (i__ != ip) { + +/* JP is the current index of the original pivot */ +/* column IP in the array C after previous column */ +/* interchanges. */ + + jp = iwork[ip]; +/* Swap the original pivot column IP = JPIV( J ), */ +/* at the current pivot index JP = IWORK( IP ) into */ +/* index J. */ + + dswap_(m, &c__[j * c_dim1 + 1], &c__1, &c__[jp * c_dim1 + + 1], &c__1); + +/* Update the array IWORK(1:N) for the original column */ +/* I that was swapped with IP. */ + + iwork[i__] = iwork[ip]; + +/* Update the array IWORK(N+1:2*N) for the current column */ +/* index JP that was swapped with the current column */ +/* index J. */ + + iwork[*n + jp] = iwork[*n + j]; + + } + + } + +/* End of ELSE( RETURNX ) */ + + } + +/* End of IF( RETURNC .AND. K.GT.0 ) */ + + } + +/* ================================================================== */ + +/* Return the matrix X. */ + + if (returnx && *k > 0) { + +/* We need to use C and A to compute X = pseudoinv(C) * A, as */ +/* the linear least squares solution to the overdetermined system */ +/* C*X = A. We use LLS routine that uses the QR factorization. For */ +/* that purpose, we store the matrix C into the array QRC. */ +/* The matrix A was copied into the array X at the beginning */ +/* of the routine. */ + + dlacpy_("F", m, k, &c__[c_offset], ldc, &qrc[qrc_offset], ldqrc); + + dgels_("N", m, k, n, &qrc[qrc_offset], ldqrc, &x[x_offset], ldx, & + work[1], lwork, &iinfo); + *info = iinfo; + + } + + work[1] = (doublereal) lwkopt; + iwork[1] = liwkopt; + +/* End of DGECXX */ + + return 0; +} /* dgecxx_ */ + diff --git a/lapack-netlib/SRC/dgecxx.f b/lapack-netlib/SRC/dgecxx.f new file mode 100644 index 0000000000..5d3af6c95a --- /dev/null +++ b/lapack-netlib/SRC/dgecxx.f @@ -0,0 +1,1714 @@ +*> \brief \b DGECXX computes a CX factorization of a real M-by-N matrix A using a truncated (rank k) Householder QR factorization with column pivoting. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download DGECXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGECXX( FACT, USESD, M, N, +* $ DESEL_ROWS, SEL_DESEL_COLS, +* $ KMAXFREE, ABSTOL, RELTOL, A, LDA, +* $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, +* $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, +* $ X, LDX, WORK, LWORK, IWORK, LIWORK, INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER FACT, USESD +* INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, +* $ LDX, LIWORK, LWORK, M, N +* DOUBLE PRECISION ABSTOL, FNRMK, MAXC2NRMK, +* $ RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. +* INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), +* $ JPIV( * ), SEL_DESEL_COLS( * ) +* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), +* $ TAU( * ), WORK( * ), X( LDX, *) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DGECXX computes a CX factorization of a real M-by-N matrix A using +*> a truncated rank-K Householder QR factorization with a column +*> pivoting algorithm, which is implemented in the DGEQP3RK routine. +*> +*> A * P = C*X + A_resid, where +*> +*> C is an M-by-K matrix consisting of K columns selected +*> from the original matrix A, +*> +*> X is a K-by-N matrix that minimizes the Frobenius norm of the +*> residual matrix A_resid, X = pseudoinv(C) * A, +*> +*> P is an N-by-N permutation matrix chosen so that the first +*> K columns of A*P equal C, +*> +*> A_resid is an M-by-N residual matrix. +*> +*> The column selection for the matrix C has two stages. +*> +*> Column preselection stage 1 (optional). +*> ======================================= +*> +*> The user can select N_sel columns and deselect N_desel columns +*> of the matrix A that MUST be included and excluded respectively +*> from the matrix C a priori, before running the column selection +*> algorithm. This is controlled by flags in the array +*> SEL_DESEL_COLS. The deselected columns are permuted to the right +*> side of the matrix A and selected columns are permuted to the left +*> side of the matrix A. The details of the column permutation +*> (i.e. the column permutation matrix P) are stored in the +*> array JPIV. This feature can be used when the goal is to approximate +*> the deselected columns by linear combinations of K selected columns, +*> where the K columns MUST include the N_sel preselected columns. +*> +*> Column selection stage 2. +*> ========================= +*> +*> The routine runs a column selection algorithm that can +*> be controlled by three stopping criteria described below. +*> For column selection, the routine uses a truncated (rank-K) +*> Householder QR factorization with column pivoting algorithm using +*> the routine DGEQP3RK. +*> +*> Optionally, before running the column selection +*> algorithm, the user can deselect M_desel rows of the matrix A that +*> should NOT be considered by the column selection algorithm (i.e. +*> during the factorization). This is controlled by flags in +*> the array DESEL_ROWS. The deselected rows are permuted to the +*> bottom of the matrix A. The details of the row permutation (i.e. the +*> row permutation matrix) are stored in the array IPIV. This feature +*> can be used when the goal is to use the deselected rows as test data, +*> and the selected rows as training data. +*> +*> This means that the column selection factorization algorithm is +*> effectively running on the submatrix A_sub = A(1:M_sub,1:N_sub) of +*> the matrix A after the permutations described above. Here M_sub is +*> the number of rows of the matrix A minus the number of deselected +*> rows M_desel, i.e. M_sub = M - M_desel, and N_sub is the number +*> of columns of the matrix A minus the number of deselected columns +*> N_desel, i.e. N_sub = N - N_desel. +*> +*> The reported column selection error metrics MAXC2NRMK, RELMAXC2NRMK +*> and FNRMK described below are computed using only A_sub. +*> +*> Column selection criteria. +*> ========================== +*> +*> The column selection criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) KMAXFREE: This input parameter specifies the maximum number of +*> columns to factorize in addition to the N_sel preselected +*> columns. The factorization rank is limited to N_sel + KMAXFREE. +*> If N_sel + KMAXFREE >= min(M_sub, N_sub), this criterion +*> is not used. +*> +*> 2) ABSTOL: This input parameter specifies the absolute tolerance +*> for the maximum column 2-norm of the submatrix residual +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub), where +*> A_sub(K) denotes the contents of the array +*> A_sub = A(1:M_sub, 1:N_sub) after K columns were factorized. +*> This means that the factorization stops if this norm is less +*> than or equal to ABSTOL. If ABSTOL < 0.0, this criterion is +*> not used. +*> +*> 3) RELTOL: This input parameter specifies the tolerance for +*> the maximum column 2-norm of the submatrix residual +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) divided +*> by the maximum column 2-norm of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub), where A_sub(K) denotes the contents +*> of the array A_sub after K columns were factorized. +*> This means that the factorization stops when the ratio of the +*> maximum column 2-norm of A_sub_resid(K) to the maximum column +*> 2-norm of A_sub is less than or equal to RELTOL. +*> If RELTOL < 0.0, this criterion is not used. +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the entire submatrix A_sub is factorized. +*> +*> To perform a full-rank factorization of the matrix A_sub, use +*> selection criteria that satisfy N_sel + KMAXFREE >= min(M_sub,N_sub) +*> and ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> If the user wishes to verify that the columns of the matrix C are +*> sufficiently linearly independent for their intended use, the user +*> can compute the condition number of its R factor by calling DTRCON +*> on the upper-triangular part of QRC(1:K,1:K) in the output +*> array QRC. +*> +*> How N_sel affects the column selection algorithm. +*> ================================================= +*> +*> As mentioned above, the N_sel preselected columns are permuted to the +*> left side of the matrix A, and will be included in the column +*> selection. Then the routine factorizes that block A(1:M_sub,1:N_sel), +*> and if any of the three stopping criteria is met immediately after +*> factoring the first N_sel columns the routine exits +*> (i.e. if the user does not want to select KMAXFREE > 0 extra columns, +*> or if the absolute or relative tolerance of the maximum column 2-norm +*> of the residual is satisfied). In this case, the number +*> of selected columns would be K = N_sel. Otherwise, the factorization +*> routine finds a new column to select with the maximum column 2-norm +*> in the residual A(N_sel+1:M_sub,N_sel+1:N_sub), and swaps that +*> column with the first column of A(1:M,N_sel+1:N_sub). Then the +*> routine checks if the stopping criteria are met in the next residual +*> A(N_sel+2:M_sub,N_sel+2:N_sub), and so on. +*> +*> Computation of the matrix factors. +*> ================================== +*> +*> When the columns are selected for the factor C, and: +*> (a) If the flag FACT = 'P', the routine returns only the indices of +*> the selected columns from the original matrix A, which are +*> stored in the first K elements of the JPIV array. +*> (b) If the flag FACT = 'C', then in addition to (a), the routine +*> explicitly returns the matrix C in the array C. +*> (c) If the flag FACT = 'X', then in addition to (a) and (b), +*> the routine explicitly computes and returns the factor +*> X = pseudoinv(C) * A in the array X, and it also returns +*> the factor R alongside the Householder vectors +*> of the QR factorization of the matrix C in the array QRC. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> The flag specifies how the factors of a CX factorization +*> are returned. +*> +*> = 'P': the routine returns: +*> (1) only the column permutation matrix P in +*> the array JPIV. +*> (The first K elements of the array JPIV +*> contain indices of the columns that were +*> selected from the matrix A to form the +*> factor C.) +*> (fastest option, smallest memory space) +*> +*> = 'C': the routine returns: +*> (1) the column permutation matrix P +*> in the array JPIV. (The first K elements are +*> indices of the selected columns from +*> the matrix A.) +*> (2) the M-by-K factor C explicitly in the array C. +*> (slower option, more memory space) +*> +*> = 'X': the routine returns: +*> (1) the column permutation matrix P in +*> the array JPIV. (The first K elements are +*> indices of the selected columns from +*> the matrix A.) +*> (2) the M-by-K factor C explicitly in the array C. +*> (3) the K-by-N factor X explicitly in the array X. +*> (4) the K-by-K upper triangular factor R and +*> the Householder vectors of the QR factorization +*> of the factor C in the array QRC. +*> ( The factor R may be useful for checking +*> the factor C for singularity, in which case +*> R will have a zero on the diagonal, and +*> the factor X cannot be computed. ) +*> (slowest option, largest memory space) +*> \endverbatim +*> +*> \param[in] USESD +*> \verbatim +*> USESD is CHARACTER*1 +*> The flag specifies whether the row deselection and column +*> preselection-deselection functionality is turned ON or OFF. +*> +*> = 'N': Both row deselection and column +*> preselection-deselection are OFF. +*> Both arrays DESEL_ROWS and SEL_DESEL_COLS +*> are not used. +*> +*> = 'R': Only row deselection is ON. +*> Column preselection-deselection is OFF. +*> The array SEL_DESEL_COLS is not used. +*> +*> = 'C': Only column preselection-deselection is ON. +*> Row deselection is OFF. +*> The array DESEL_ROWS is not used. +*> +*> = 'A': Means "All". Both row deselection and column +*> preselection-deselection are ON. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] DESEL_ROWS +*> \verbatim +*> DESEL_ROWS is INTEGER array, dimension (M) +*> DESEL_ROWS is only accessed if USESD = 'R' or 'A'. +*> This is a row deselection mask array that separates +*> the rows of matrix A into 2 sets. +*> +*> On entry: +*> a) If DESEL_ROWS(i) = -1, the i-th row of the matrix A is +*> deselected by the user, i.e. chosen to be excluded from +*> the column selection algorithm (in both preselection and +*> selection stages) and will be permuted to the bottom +*> of the matrix A. +*> The number of deselected rows is denoted by M_desel. +*> +*> b) If DESEL_ROWS(i) is not equal -1, +*> the i-th row of A will be used in the column selection +*> algorithm (in both preselection and selection stages). +*> This defines a set of M_sub = M - M_desel rows that +*> the algorithm will use to select columns. +*> After the permutation, this set will be at the top +*> of the matrix A. +*> +*> On exit: +*> DESEL_ROWS will be permuted according to IPIV(i), +*> so that, if IPIV(i) = k, then the entry i of DESEL_ROWS +*> on exit was the entry k of DESEL_ROWS on entry. +*> +*> \endverbatim +*> +*> \param[in,out] SEL_DESEL_COLS +*> \verbatim +*> SEL_DESEL_COLS is INTEGER array, dimension (N) +*> SEL_DESEL_COLS is only accessed if USESD = 'C' or 'A'. +*> This is a column preselection-deselection mask array that +*> separates the columns of matrix A into 3 sets. +*> +*> On entry: +*> a) If SEL_DESEL_COLS(j) = +1, the j-th column of the matrix +*> A is preselected by the user to be included +*> in the factor C and will be permuted to the left side +*> of the array A. The number of selected columns is +*> denoted by N_sel. +*> +*> b) If SEL_DESEL_COLS(j) = -1, the j-th column of the matrix +*> A is deselected by the user, i.e. chosen to be excluded +*> from the factor C and will be permuted to the right side +*> of the array A. The number of deselected columns is +*> denoted by N_desel. +*> +*> c) If SEL_DESEL_COLS(j) is not equal to 1 and not equal +*> to -1, the j-th column of A is a free column and will be +*> used by the column selection algorithm to determine if +*> this column will be selected. This defines a set of +*> columns of size N_free = N - N_sel - N_desel. +*> +*> On exit: +*> SEL_DESEL_COLS will be permuted according to JPIV(j), +*> so that, if JPIV(j) = k, then the entry j +*> of SEL_DESEL_COLS on exit was the entry k +*> of SEL_DESEL_COLS on entry. +*> +*> NOTE: An error returned as INFO = -6 means that the number +*> of preselected N_sel columns is larger than M_sub. +*> Therefore, the QR factorization of all N_sel preselected +*> columns cannot be completed. +*> \endverbatim +*> +*> \param[in] KMAXFREE +*> \verbatim +*> KMAXFREE is INTEGER, KMAXFREE >= 0. +*> +*> The first column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> KMAXFREE is the maximum number of columns of the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) to select +*> during the column selection stage 2. +*> +*> KMAXFREE does not include the preselected N_sel columns. +*> N_sel + KMAXFREE is the maximum factorization rank of +*> the matrix A_sub. +*> +*> a) If N_sel + KMAXFREE >= min(M_sub, N_sub), then this +*> stopping criterion is not used, i.e. columns are +*> selected in the factorization stage 2 depending +*> on ABSTOL and RELTOL. +*> +*> b) If KMAXFREE = 0, then this stopping criterion is +*> satisfied on input and the routine exits without +*> performing column selection stage 2 +*> on the submatrix A_sub. This means that the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) is not modified +*> in the column selection stage 2 +*> and A_free is itself the residual for the factorization. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> ABSTOL is the absolute tolerance (stopping threshold) +*> for maxcol2norm(A_sub_resid(K)), where K >= N_sel. +*> +*> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm +*> of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) +*> when K columns have been factorized. +*> The column selection algorithm converges +*> (stops the factorization) when +*> maxcol2norm(A_sub_resid(K)) <= ABSTOL, where K >= N_sel. +*> +*> In the following, +*> SAFMIN = DLAMCH('S'), +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub), +*> maxcol2norm(A_free) is the maximum column 2-norm +*> of the matrix A_free. +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -8 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, and the column selection algorithm stops +*> the factorization of A_free depending +*> on KMAXFREE and RELTOL. +*> This includes the case where ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case where ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> If ABSTOL chosen above is >= maxcol2norm(A_free), then +*> this stopping criterion is satisfied on input, and +*> the routine only preselects K = N_sel columns. The leftmost +*> preselected N_sel columns in the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) are factorized. The routine +*> then computes maxcol2norm(A_free) and returns it +*> in MAXC2NORMK, computes and returns RELMAXC2NORMK of A_free, +*> and exits immediately. +*> This means that the factorization residual +*> A_sub_resid(N_sel) = A_free = A(N_sel+1:M_sub,N_sel+1:N_sub) +*> is not modified in the column selection stage 2. +*> This includes the case where ABSTOL = +Inf. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> RELTOL is the tolerance (stopping threshold) for the ratio +*> relmaxcol2norm(A_sub_resid(K)) = +*> = maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub), +*> where K >= N_sel. +*> +*> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm +*> of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) +*> when K columns have been factorized. +*> maxcol2norm(A_sub) is the maximum column 2-norm +*> of the original submatrix A_sub = A(1:M_sub, 1:N_sub). +*> The column selection algorithm converges +*> (stops the factorization) when the ratio +*> relmaxcol2norm(A_sub_resid(K)) <= RELTOL, where K >= N_sel. +*> +*> In the following, +*> EPS = DLAMCH('E'), +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub). +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -9 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used and the column selection algorithm stops +*> the factorization of A_free depending +*> on KMAXFREE and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. +*> This includes the case RELTOL = -0.0. +*> +*> d) If EPS <= RELTOL then the input value of RELTOL +*> is used. +*> +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input, and the routine +*> only preselects K = N_sel columns. The leftmost +*> preselected N_sel columns in the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) are factorized. +*> The routine then computes maxcol2norm(A_free) and returns +*> it in MAXC2NORMK, returns RELMAXC2NORMK as 1.0, and exits +*> immediately. +*> This means that the factorization residual +*> A_sub_resid(N_sel) = A_free = A(N_sel+1:M_sub,N_sel+1:N_sub) +*> is not modified. +*> This includes the case RELTOL = +Inf. +*> +*> NOTE: We recommend RELTOL to satisfy +*> min(max(M_sub,N_sub)*EPS, sqrt(EPS)) <= RELTOL +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> +*> On entry: +*> the M-by-N matrix A. +*> +*> On exit: +*> +*> NOTE: +*> The output parameter K, the number of selected +*> columns, is described later. +*> A_sub = A(1:M_sub, 1:N_sub). +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> +*> 2) If K > 0, A(1:M,1:N) contains the following parts: +*> +*> (a) If M_sub < M (which is the same as M_desel > 0), +*> the subarray A(M_sub+1:M,1:N) contains the deselected +*> rows. +*> +*> (b) If N_sub < N ( which is the same as N_desel > 0 ), +*> the subarray A(1:M,N_sub+1:N) contains the +*> deselected columns. +*> +*> (c) If N_sel > 0, +*> the union of the subarray A(1:M_sub, 1:N_sel) +*> and the subarray A(1:N_sel, 1:N_sub) contains parts +*> of the factors obtained by computing Householder QR +*> factorization WITHOUT column pivoting of N_sel +*> preselected columns using the routine DGEQRF. +*> +*> (d) The subarray A(N_sel+1:M_sub, N_sel+1:N_sub) +*> contains parts of the factors obtained by computing +*> a truncated (rank K) Householder QR factorization with +*> column pivoting using the routine DGEQP3RK on +*> the matrix A_free = A(N_sel+1:M_sub, N_sel+1:N_sub), +*> which is the result of applying selection and +*> deselection of columns, applying deselection of rows +*> to the original matrix A, and applying orthogonal +*> transformation from the factorization of the first +*> N_sel columns as described in part (c). +*> +*> 1. The elements below the diagonal of the subarray +*> A_sub(1:M_sub,1:K) together with TAU(1:K) +*> represent the orthogonal matrix Q(K) as a +*> product of K Householder elementary reflectors. +*> +*> 2. The elements on and above the diagonal of +*> the subarray A_sub(1:K,1:N_sub) contain the +*> K-by-N_sub upper-trapezoidal matrix +*> R_sub_approx(K) = ( R_sub11(K), R_sub12(K) ). +*> NOTE: If K = min(M_sub,N_sub), i.e. full rank +*> factorization, then R_sub_approx(K) is the +*> full factor R which is upper-trapezoidal. +*> If, in addition, M_sub >= N_sub, then R is +*> upper-triangular. +*> +*> 3. The subarray A_sub(K+1:M_sub,K+1:N_sub) contains +*> the (M_sub-K)-by-(N_sub-K) rectangular matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> The number of columns that were selected +*> (K is the factorization rank). +*> 0 <= K <= min( M_sub, N_sel+KMAXFREE, N_sub ). +*> +*> NOTE: If K = 0, a) the arrays A is not, modified. +*> b) the array TAU(1,min(M_sub,N_sub)) +*> is set to ZERO. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub), +*> when factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, so +*> the matrix A_sub = A(1:M_sub, 1:N_sub) was not modified +*> and is itself a residual matrix, then MAXC2NRMK equals +*> the maximum column 2-norm of the original matrix A_sub. +*> +*> b) If 0 < K < min(M_sub, N_sub), then MAXC2NRMK is returned. +*> +*> c) If K = min(M_sub, N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK at the factorization step K is equal +*> to the diagonal element R_sub(K+1,K+1) of the factor +*> R_sub in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM +*> of the maximum column 2-norm MAXC2NRMK of the residual +*> matrix A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) (when +*> factorization stopped at rank K) and maximum column 2-norm +*> MAXC2NRM of the matrix A_sub = A(1:M_sub, 1:N_sub). +*> RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A_sub was not modified +*> and is itself a residual matrix, +*> then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M_sub,N_sub), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M_sub,N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no residual matrix +*> A_sub_resid(K), then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK at the factorization step K would equal +*> abs(R_sub(K+1,K+1))/MAXC2NRM in the next +*> factorization step K+1, where R_sub(K+1,K+1) is the +*> diagonal element of the factor R_sub in the next +*> factorization step K+1. +*> \endverbatim +*> +*> \param[out] FNRMK +*> \verbatim +*> FNRMK is DOUBLE PRECISION +*> Frobenius norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub). +*> FNRMK >= 0.0 +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (M) +*> Row permutation indices due to row deselection, +*> for 1 <= i <= M. +*> If IPIV(i) = k, then the row i of A was +*> the row k of A. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column permutation indices, for 1 <= j <= N. +*> If JPIV(j)= k, then the column j of A*P was +*> the column k of A. +*> +*> The first K elements of the array JPIV contain +*> indices of the columns of the factor C that were selected +*> from the matrix A. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (min(M_sub,N_sub)) +*> The scalar factors of the elementary reflectors. +*> +*> If K = 0, all elements TAU(1:min(M_sub,N_sub)) are set +*> to zero. +*> If 0 < K <= min(M_sub,N_sub): +*> only the elements TAU(1:K) may be modified, +*> the elements TAU(K+1:min(M_sub,N_sub)) are set to zero. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array. +*> +*> If FACT = 'P': +*> the array is not used, the array dimension >= (1,1). +*> +*> If FACT = 'C': +*> the array dimension is (LDC,N). +*> If K = 0: +*> the M-by-N array C contains a copy of +*> the original M-by-N matrix A. +*> If K > 0: +*> a) columns (1:K) of the array C contain +*> the M-by-K factor C (the selected columns +*> from the original matrix A). +*> b) columns (K+1:N) of the array C contain +*> the deselected columns from the original +*> matrix A. +*> +*> If FACT = 'X': +*> the array dimension is (LDC,N). +*> If K = 0: +*> the M-by-N array C is not used. +*> If K > 0: +*> a) columns (1:K) of the array C contain +*> the M-by-K factor C (the selected columns +*> from the original matrix A). +*> b) columns (K+1:N) of the array C are +*> not used. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. +*> If FACT = 'P', LDC >= 1. +*> If FACT = 'C' or 'X', LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] QRC +*> \verbatim +*> QRC is DOUBLE PRECISION array. +*> +*> If FACT = 'P' or 'C': The array is not used, +*> the array dimension is >= (1,1). +*> +*> If FACT = 'X': the array dimension is (LDQRC,min(M,N)). +*> +*> If K = 0, the array is not used. +*> If K > 0, QRC(1:M,1:K) stores two components from +*> the QR factorization of the factor C. The K-by-K +*> factor R is stored in the upper triangle. +*> The Householder vectors are stored in the lower +*> trapezoid below the diagonal. +*> \endverbatim +*> +*> \param[in] LDQRC +*> \verbatim +*> LDQRC is INTEGER +*> The leading dimension of the array QRC. +*> If FACT = 'P' or 'C', LDQRC >= 1. +*> If FACT = 'X', LDQRC >= max(1,M). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array. +*> If FACT = 'P' or 'C': The array is not used, +*> the array dimension is >= (1,1). +*> +*> If FACT = 'X': The array dimension is (LDX,N). +*> 1) If K = 0: +*> the M-by-N array X contains a copy of +*> the original M-by-N matrix A. +*> 2) If K > 0: +*> a) rows (1:K) of the M-by-N array X contain +*> the K-by-N factor X, where K <= N. +*> b) rows (K+1:M) of the M-by-N array X. +*> Each column of these rows contains the elements +*> whose sum of squares is the residual sum of +*> squares for the solution in each column of +*> the least squares problem. +*> min|| A - C*X ||_F for the unknown X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. +*> If FACT = 'P' or 'C', LDX >= 1. +*> If FACT = 'X', LDX >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (max(1,LWORK)). +*> +*> On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> +*> Minimal LWORK workspace general requirement. +*> LWORK >= max( 1, 3*N - 1 ) would be sufficient for all +*> values of FACT and USESD flags. +*> +*> For good performance, LWORK should generally be larger, and +*> the user should query the routine for the optimal LWORK. +*> +*> If LWORK = -1 or LIWORK =-1 then a workspace query is +*> assumed. The routine only calculates the optimal size of +*> the WORK and IWORK arrays, returns these values as the +*> first entry of the WORK and IWORK arrays respectively, and +*> no error message related to LWORK is issued by XERBLA. +*> +*> Exact minimal workspace requirements. +*> For USESD = 'N' or 'R' and for all FACT: +*> LWORK >= max( 1, 3*N - 1 ) +*> For USESD = 'C' or 'A': +*> a) If FACT = 'P' or 'C': +*> LWORK >= max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +*> b) If FACT = 'X': +*> LWORK >= max( 1, min(M,N)+N, +*> min(1,MINMNFREE)*(3*N_free-1) ) +*> where MINMNFREE = min( M_free, N_free ). +*> +*> NOTE: The decision, whether the routine uses unblocked +*> BLAS 2 or blocked BLAS 3 code is based not only on the +*> dimension LWORK of the available workspace WORK, but +*> also on: +*> 1a) column preselection stage using DGEQRF: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine DGEQRF +*> in comparison to N_sel. (For N_sel <= NX +*> or N_sel <= NB, unblocked code is used in DGEQRF.) +*> 1b) column preselection stage using DORMQR: +*> the optimal block size NB returned by ILAENV for +*> the routine DORMQR in comparison to N_sel. (For +*> N_sel <= NB, unblocked code is used in DORMQR.) +*> 2) column selection stage via criteria using DGEQRP3RK: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine DGEQRP3RK +*> in comparison to min(M,N_sel). (For +*> min(M_sub, N_free, KMAXFREE) <= NX +*> or min(M_sub, N_free, KMAXFREE) <= NB, unblocked code +*> is used in DGEQRP3RK.) +*> 3a) computation of the factor X using DGEQRF in DGELS: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine DGEQRF +*> in comparison to K. (For K <= NX or K <= NB, +*> unblocked code is used in DGEQRF inside DGELS.) +*> 3b) computation of the factor X using DORMQR in DGELS: +*> the optimal block size NB returned by ILAENV for +*> the routine DORMQR in comparison to N. (For +*> N <= NB, unblocked code is used in DORMQR +*> inside DGELS.) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (max(1,LIWORK)). +*> +*> On exit, if INFO >= 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> +*> Minimal LIWORK workspace general requirement. +*> LIWORK >= max( 1, 2*N ) would be sufficient for all values +*> of FACT and USESD flags. +*> +*> The optimal LIWORK is the same as the minimal LIWORK. +*> The user can still query the routine for the optimal LIWORK. +*> +*> If LWORK = -1 or LIWORK =-1 then a workspace query is +*> assumed. The routine only calculates the optimal size of +*> the WORK and IWORK arrays, returns these values as the first +*> entry of the WORK and IWORK arrays respectively, and no +*> error message related to LIWORK is issued by XERBLA. +*> +*> Exact minimal workspace requirements. +*> For USESD = 'N' or 'R': +*> a) If FACT = 'P': +*> LIWORK >= max( 1, N-1 ) +*> b) If FACT = 'C' or 'X': +*> LIWORK >= max( 1, 2*N ) +*> For USESD = 'C' or 'A': +*> a) If FACT = 'P': +*> LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free ) +*> b) If FACT = 'C' or 'X': +*> LIWORK >= max( 1, 2*N ) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the i-th diagonal element of the +*> triangular R factor of the QR factorization of +*> the matrix C is zero. Consequently, C does not have +*> full rank, and X cannot be computed as the least +*> squares solution to the overdetermined system C*X = A. +*> (R is stored in the array QRC.) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2026, Igor Kozachenko, James Demmel, +*> EECS Department, +*> University of California, Berkeley, USA. +*> \endverbatim +* +*> \ingroup gecxx +* +* ===================================================================== + SUBROUTINE DGECXX( FACT, USESD, M, N, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ KMAXFREE, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, + $ X, LDX, WORK, LWORK, IWORK, LIWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER FACT, USESD + INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, + $ LDX, LIWORK, LWORK, M, N + DOUBLE PRECISION ABSTOL, FNRMK, MAXC2NRMK, + $ RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. + INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), + $ JPIV( * ), SEL_DESEL_COLS( * ) + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), + $ TAU( * ), WORK( * ), X( LDX, *) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, TWO, MINUSONE + PARAMETER ( ZERO = 0.0D+0, TWO = 2.0D+0, + $ MINUSONE = -1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, RETURNC, RETURNX, + $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL + INTEGER I, IP, IINFO, ITEMP, J, JDESEL, JP, KFREE, + $ KMAXLS, KP0, LIWKMIN, LIWKOPT, LWKMIN, + $ LWKOPT, MFREE, MDESEL, MINMN, MINMNFREE, + $ MRESID, MSUB, NFREE, NDESEL, NRESID, NSEL, + $ NSUB + DOUBLE PRECISION ABSTOLFREE, EPS, MAXC2NRM, MAXC2NRMKFREE, + $ RELTOLFREE, RELMAXC2NRMKFREE, SAFMIN + +* .. External Subroutines .. + EXTERNAL DCOPY, DGELS, DGEQP3RK, DGEQRF, DLACPY, + $ DORMQR, DSWAP, XERBLA +* .. +* .. External Functions .. + LOGICAL DISNAN, LSAME + INTEGER IDAMAX, ILAENV + DOUBLE PRECISION DLAMCH, DLANGE, DNRM2 + EXTERNAL DISNAN, DLAMCH, DLANGE, DNRM2, IDAMAX, + $ ILAENV, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + MDESEL = 0 + NSEL = 0 + NDESEL = 0 + MSUB = M + NSUB = N + MFREE = MSUB + NFREE = NSUB + MINMN = MIN( M, N ) +* + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + RETURNX = LSAME( FACT, 'X' ) + RETURNC = LSAME( FACT, 'C' ) .OR. RETURNX +* + USE_DESEL_ROWS = LSAME( USESD, 'R' ) + $ .OR. LSAME( USESD, 'A' ) + USE_SEL_DESEL_COLS = LSAME( USESD, 'C' ) + $ .OR. LSAME( USESD, 'A' ) +* + IF( .NOT.( RETURNC .OR. LSAME( FACT, 'P') ) ) THEN + INFO = -1 + ELSE IF( .NOT.( USE_DESEL_ROWS .OR. USE_SEL_DESEL_COLS + $ .OR. LSAME( USESD, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE +* +* This is to check that the number of preselected columns NSEL +* cannot be larger than MSUB, which is the number of rows +* without MDESEL deselected rows. When the number of +* preselected columns NSEL is larger than MSUB, +* the factorization of all preselected NSEL columns cannot be +* completed. MSUB also will be used for LDX argument check +* later. +* + IF( USE_DESEL_ROWS ) THEN +* +* Count the number of free rows MSUB. +* + DO I = 1, M + IF( DESEL_ROWS( I ).EQ.-1 ) MDESEL = MDESEL + 1 + END DO + MSUB = M - MDESEL + MFREE = MSUB + END IF +* + IF( USE_SEL_DESEL_COLS ) THEN +* +* Count the number of preselected columns NSEL and the +* number of preselected and free columns NSUB = N - NDESEL. +* + DO J = 1, N + IF( SEL_DESEL_COLS( J ).EQ.1 ) NSEL = NSEL + 1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) NDESEL = NDESEL + 1 + END DO + NSUB = N - NDESEL + MFREE = MSUB - NSEL + NFREE = NSUB - NSEL +* + END IF + MINMNFREE = MIN( MFREE, NFREE ) +* + IF( NSEL.GT.MSUB ) THEN + INFO = -6 + ELSE IF( KMAXFREE.LT.0 ) THEN + INFO = -7 + ELSE IF( DISNAN( ABSTOL ) ) THEN + INFO = -8 + ELSE IF( DISNAN( RELTOL ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -11 +* This is a check for LDC + ELSE IF( ( RETURNC .AND. LDC.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNC .AND. LDC.LT.1 ) ) THEN + INFO = -20 +* This is a check for LDQRC + ELSE IF( ( RETURNX .AND. LDQRC.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNX .AND. LDQRC.LT.1 ) ) THEN + INFO = -22 +* This is a check for LDX + ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNX .AND. LDX.LT.1 ) ) THEN + INFO = -24 + END IF +* + END IF +* +* ================================================================== +* +* a) Test the input workspace size LWORK and LIWORK for the +* minimum size requirement LWKMIN and LIWKMIN respectively. +* b) Determine the optimal workspace sizes LWKOPT and LIWKOPT to +* be returned in WORK( 1 ) and IWORK( 1 ) respectively, +* if INFO >= 0 in cases: +* (1) LQUERY = .TRUE., +* (2) when the routine exits. +* Here, LWKMIN and LIWKMIN are the minimum workspaces required for +* unblocked code. +* + IF( INFO.EQ.0 ) THEN + IF( MINMN.EQ.0 ) THEN + LWKMIN = 1 + LWKOPT = 1 + LIWKMIN = 1 + LIWKOPT = 1 + ELSE +* +* (Real_wk_part_1) Real minimum and optimal workspace +* computation. +* LWKMIN = MAX(1, NSUB) for column 2-norm computation +* + LWKMIN = MAX( 1, NSUB ) + LWKOPT = LWKMIN +* +* (Int_wk_part_1) Integer minimum workspace computation. +* + LIWKMIN = 1 +* +* Call of DGEQRF. +* + IF( NSEL.GT.0 ) THEN +* +* (Real_wk_part_2) Real minimum workspace computation. +* LWKMIN = MAX(1, NSEL) for the call of DGEQRF. +* We can skip counting this workspace as +* LWKMIN = MAX( LWKMIN, NSEL ), since NSEL <= NSUB. +* +* Query for optimal workspace size for DGEQRF. +* + CALL DGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, + $ -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* +* Call of DORMQR. +* + IF( NFREE.GT.0 ) THEN +* +* (Real_wk_part_3) Real minimum workspace computation. +* NOTE: minimum workspace requirement for DORMQR +* LWKMIN = MAX(1, NFREE) is smaller than NSUB +* and it is smaller than LWKMIN = 3*NFREE-1 for +* DGEQP3RK. We can skip counting this workspace as +* as LWKMIN = MAX( LWKMIN, NFREE ). +* +* Query for optimal workspace size for DORMQR. +* + CALL DORMQR( 'L', 'T', MSUB, NFREE, + $ NSEL, A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, + $ -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) + END IF +* + END IF +* +* Call of DGEQP3RK. +* + IF ( MINMNFREE.NE.0 ) THEN +* +* (Real_wk_part_4) Real minimum workspace computation. +* LWKMIN = MAX(1, 3*NFREE-1) for the call of DGEQP3RK. +* + LWKMIN = MAX( LWKMIN, 3*NFREE - 1 ) +* +* Query for optimal workspace size for DGEQP3RK. +* + CALL DGEQP3RK( MFREE, NFREE, 0, NFREE, + $ MINUSONE, MINUSONE, + $ A( 1, 1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( 1 ), TAU( 1 ), + $ WORK, -1, IWORK, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* +* (Int_wk_part_2) Integer minimum workspace computation. +* LIWKMIN = NFREE-1 for the call of DGEQP3RK. +* + LIWKMIN = MAX( LIWKMIN, NFREE-1 ) +* + IF( NSEL.NE.0 ) THEN +* +* (Int_wk_part_3) Integer minimum workspace computation. +* NFREE is for DGEQP3RK and NFREE-1 for JPIV adjustment. +* + LIWKMIN = MAX( LIWKMIN, NFREE + NFREE-1 ) + END IF +* + END IF +* + IF( RETURNC ) THEN +* +* Integer minimum workspace computation. +* (Int_wk_part_4) LIWKMIN = 2*N for applying the +* interchanges for the columns in the matrix C. +* + LIWKMIN = MAX( LIWKMIN, 2*N ) + END IF +* +* Integer optimal workspace computation. +* + LIWKOPT = LIWKMIN +* +* Call of DGELS. +* + IF( RETURNX ) THEN +* +* (Real_wk_part_5) Real minimum workspace computation. +* LWKMIN = max( 1, MINMN + max( MINMN, N ) ) = +* = max( 1, MINMN + N ) for the call of DGELS. +* + LWKMIN = MAX( LWKMIN, MINMN + N ) +* +* Query for optimal workspace size for DGELS. +* + KMAXLS = MINMN +* + CALL DGELS( 'N', M, KMAXLS, N, QRC, LDQRC, X, LDX, + $ WORK, -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK(1) ) ) +* + END IF +* +* End of ELSE for IF( MINMN.EQ.0 ) +* + END IF +* + IF( ( LWORK.LT.LWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -26 + ELSE IF( ( LIWORK.LT.LIWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -28 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = DBLE( LWKOPT ) + IWORK( 1 ) = LIWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGECXX', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* ================================================================== +* +* Quick return if possible for: +* a) M = 0 or N = 0. There is no matrix A(1:M,1:N). +* b) MSUB = 0 or NSUB = 0. There is no matrix A_sub(1:MSUB,1:NSUB). +* NOTE: min( M, N) = 0 implies min( MSUB, NSUB) = 0. +* We need to return correct values for all scalar output parameters, +* (including WORK(1) and IWORK(1), which are set above). +* + IF( MIN( MSUB, NSUB ).EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + FNRMK = ZERO + RETURN + END IF +* +* ================================================================== +* + K = 0 +* +* If we need to return factor X, copy the original untouched matrix +* A into the array X. +* + IF( RETURNX ) THEN + CALL DLACPY( 'F', M, N, A, LDA, X, LDX ) + END IF +* +* If we need to return the factor C, copy the original matrix A +* into the array C, only if do not return the factor X. In this +* case, we need to choose the columns of the matrix A in the array C +* in place, otherwise we can copy the columns of the matrix A from +* the array X. +* + IF( RETURNC .AND. .NOT. RETURNX ) THEN + CALL DLACPY( 'F', M, N, A, LDA, C, LDC ) + END IF +* +* ================================================================== +* Permute the deselected rows to the bottom of the matrix A. +* 1) The initial order of included rows in their block is preserved. +* 2) The initial order of deselected rows in their block is not +* preserved. +* ================================================================== +* +* I is an index of DESEL_ROWS array and a row index of +* the matrix A. MSUB is the number of processed included rows, which +* is also an index pointer to the last included row in the matrix A. +* We can think of I as a row source index, and MSUB as a destination +* index for moving an included row in the matrix A. +* +* ( We start with MSUB = 0. We loop over index I in (1:M), and +* for each position I in DESEL_ROWS array, we check if the row at +* the position I in the matrix A is an included row (not -1 value). +* If it is an included row, we increment MSUB pointer, otherwise +* we do not change MSUB index pointer. Then, we bring this included +* row from the index I in the matrix A into smaller (or same) +* MSUB index in the matrix A. If I = MSUB, then the included row +* is already in place. Due to row swap, the deselected row +* at MSUB index will move into I index in the matrix A. In this way, +* we move all the included rows to the top matrix block preserving +* their initial order within the included block. The initial order +* of deselected rows will not be preserved within their block. +* + IF( USE_DESEL_ROWS ) THEN +* + MSUB = 0 + DO I = 1, M, 1 +* +* Initialize the row pivot array IPIV. + IPIV( I ) = I +* +* The row at the index I is an included row and should be +* moved to the top of the matrix A. +* + IF( DESEL_ROWS( I ).NE.-1 ) THEN + MSUB = MSUB + 1 +* +* This is a check whether the included row is +* on the included place already. +* + IF( I.NE.MSUB ) THEN +* +* Here, we swap A(I,1:N) into A(MSUB,1:N). +* + CALL DSWAP( N, A( I, 1 ), LDA, A( MSUB, 1 ), LDA ) +* +* Save the interchange. +* + IPIV( I ) = IPIV( MSUB ) + IPIV( MSUB ) = I + DESEL_ROWS( MSUB ) = DESEL_ROWS( I ) + DESEL_ROWS( I ) = -1 + END IF + END IF +* + END DO +* + ELSE +* +* We do not use the row deselection DESEL_ROWS array. +* Initialize the row pivot array IPIV. +* NOTE: MSUB=M has default value, +* which is set at the beginning of the routine, before argument +* checks. +* + DO I = 1, M, 1 + IPIV( I ) = I + END DO + END IF +* +* ================================================================== +* Permute the preselected columns to the left and deselected +* columns to the right of the matrix A. +* 1) The order of preselected columns is preserved. +* 2) The order of free columns is not preserved. +* 3) The order of deselected columns is not preserved. +* ================================================================== +* +* J is the index of SEL_DESEL_COLS array and column J +* of the matrix A. +* + IF( USE_SEL_DESEL_COLS ) THEN +* +* Column selection. +* NSEL is the number of selected columns, also the pointer to +* the last selected column. +* + NSEL = 0 + DO J = 1, N, 1 +* +* Initialize column pivot array JPIV. + JPIV( J ) = J +* + IF( SEL_DESEL_COLS( J ).EQ.1 ) THEN + NSEL = NSEL + 1 +* +* This is the check whether the selected column is +* on the selected place already. +* + IF( J.NE.NSEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,NSEL) +* + CALL DSWAP( M, A( 1, J ), 1, A( 1, NSEL ), 1 ) + JPIV( J ) = JPIV( NSEL ) + JPIV( NSEL ) = J + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( NSEL ) + SEL_DESEL_COLS( NSEL ) = 1 + END IF + END IF + END DO +* +* Column deselection. +* JDESEL the pointer to the last +* deselected column counting right-to-left. +* + JDESEL = N+1 + DO J = N, NSEL+1, -1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) THEN + JDESEL = JDESEL - 1 +* +* This is the check whether the deselected column is +* on the deselected place already. +* + IF( J.NE.JDESEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,JDESEL) +* + CALL DSWAP( M, A( 1, J ), 1, A( 1, JDESEL ), 1 ) + ITEMP = JPIV( J ) + JPIV( J ) = JPIV( JDESEL ) + JPIV( JDESEL ) = ITEMP + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( JDESEL ) + SEL_DESEL_COLS( JDESEL ) = -1 + END IF + END IF + END DO +* + NSUB = JDESEL - 1 +* + ELSE +* +* We do not use the column selection deselection +* SEL_DESEL_COLS array. +* Initialize column pivot array JPIV. +* NOTE: NSUB=N has default value, +* which is set at the beginning of the routine, before argument +* checks. +* + DO J = 1, N, 1 + JPIV( J ) = J + END DO +* + END IF +* +* ================================================================== +* Compute the complete column 2-norms of the submatrix +* A_sub = A(1:MSUB, 1:NSUB) and store them in WORK(1:NSUB). +* + DO J = 1, NSUB + WORK( J ) = DNRM2( MSUB, A( 1, J ), 1 ) + END DO +* +* Compute the column index of the maximum column 2-norm and +* the maximum column 2-norm itself for the submatrix +* A_sub = A(1:MSUB, 1:NSUB). +* + KP0 = IDAMAX( NSUB, WORK( 1 ), 1 ) + MAXC2NRM = WORK( KP0 ) +* +* ================================================================== +* Process preselected columns +* +* Compute the QR factorization of NSEL preselected columns (1:NSEL) +* in the submatrix A_sub = A(1:MSUB, 1:NSUB) and update +* remaining NFREE free columns (NSEL+1:NSUB). +* NSUB = NSEL + NFREE +* + IF( NSEL.GT.0 ) THEN +* +* Case (a): MSUB < NSEL. +* +* This is handled at the argument check stage in the +* beginning of the routine. When the number of preselected +* columns is larger than MSUB, hence the factorization of +* all NSEL columns cannot be completed. Return from the +* routine with the error of COL_SEL_DESEL parameter. +* +* Case (b): MSUB = NSEL. +* Case (c-1): MSUB > NSEL and NSEL = NSUB. +* +* For cases (b) and (c-1), there will be no residual +* submatrix after factorization of NSEL columns +* at step K = NSEL: +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). +* +* Case (c-2): MSUB > NSEL and NSEL < NSUB. +* +* For Case (c-2) is a submatrix residual at step K=NSEL +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) +* + CALL DGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, LWORK, IINFO ) +* +* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) +* + IF( NFREE.GT.0 ) THEN +* +* This is only for case (c-2) ('L' = Left, 'T' = Transpose) +* + CALL DORMQR( 'L', 'T', MSUB, NFREE, NSEL, + $ A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, + $ LWORK, IINFO ) + END IF +* + K = K + NSEL +* +* End of IF(NSEL.GT.0) +* + END IF +* +* ================================================================== +* + KFREE = 0 +* + IF( MINMNFREE.NE.0 ) THEN +* +* Factorize NFREE free columns of +* A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), +* KFREE is the number of columns that were actually factorized +* among NFREE columns. +* +* ================================================================== +* + EPS = DLAMCH('Epsilon') +* + USETOL = .FALSE. +* +* Adjust ABSTOL only if nonnegative. Negative value means disabled. +* We need to keep negative value for later use in criterion +* check. +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = DLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + USETOL = .TRUE. + END IF +* +* Adjust RELTOL only if nonnegative. Negative value means disabled. +* We need to keep negative value for later use in criterion +* check. +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + USETOL = .TRUE. + END IF +* +* ================================================================== +* +* Disable RELTOLFREE when calling DGEQP3RK for free columns +* factorization, since DGEQP3RK expects RELTOLFREE with respect +* to the residual matrix A_sub_resid(NSEL), not the whole +* original matrix A. We can use RELTOL criterion by passing it +* to ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that +* the negative values of ABSTOL and RELTOL are propagated +* to ABSTOLFREE and RELTOLFREE, since negative values means +* that the criterion is disabled. +* + IF( USETOL ) THEN + ABSTOLFREE = MAX( ABSTOL, RELTOL * MAXC2NRM ) + ELSE + ABSTOLFREE = MINUSONE + END IF + RELTOLFREE = MINUSONE +* +* Save JPIV(NSEL+1:NSUB) into WORK(NFREE+1:2*NFREE-1) +* + IF( NSEL.NE.0 ) THEN + DO J = 1, NFREE, 1 + IWORK( NFREE + J ) = JPIV( NSEL+J ) + END DO + END IF +* + CALL DGEQP3RK( MFREE, NFREE, 0, KMAXFREE, + $ ABSTOLFREE, RELTOLFREE, + $ A( NSEL+1, NSEL+1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( NSEL+1 ), + $ TAU( NSEL+1 ), WORK, LWORK, IWORK, IINFO ) +* +* Adjust JPIV +* + IF( NSEL.NE.0 ) THEN + DO J = 1, NFREE, 1 + JPIV( NSEL+J ) = IWORK( NFREE + JPIV( NSEL+J ) ) + END DO + END IF +* +* 1) Adjust the return value for the number of factorized +* columns K for the whole submatrix A_sub. +* 2) MAXC2NRMK is returned transparently without change +* as MAXC2NRMKFREE is returned from DGEQP3RK. +* 3) Adjust the return value RELMAXC2NRMK for the whole +* submatrix A_sub. We do not use RELMAXC2NRMKFREE +* returned from DGEQP3RK. +* + K = K + KFREE + MAXC2NRMK = MAXC2NRMKFREE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + ELSE +* +* Set norms to zero +* + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + END IF +* +* Now, MRESID and NRESID is the number of rows and columns +* respectively in A_free_resid = A(K+1:MSUB,K+1:NSUB). +* + MRESID = MFREE-KFREE + NRESID = NFREE-KFREE +* + IF( MIN( MRESID, NRESID ).NE.0 ) THEN + FNRMK = DLANGE( 'F', MRESID, NRESID, A( K+1, K+1 ), + $ LDA, WORK ) + ELSE + FNRMK = ZERO + END IF +* +* ================================================================== +* +* Return the matrix C. +* + IF( RETURNC .AND. K.GT.0 ) THEN +* + IF( RETURNX ) THEN +* +* Copy the selected K columns of the original matrix A (that was +* saved into the array X) into the array C according to +* the pivot array JPIV. If we return X, then the matrix A is +* saved in the array X, and it is faster to copy into C than +* doing column permutation in place, as it is the ELSE case. +* + DO J = 1, K, 1 + CALL DCOPY( M, X( 1, JPIV( J ) ), 1, C( 1, J ), 1 ) + END DO +* + ELSE +* +* Swap the columns of the original matrix A copied into +* the array C in place. +* +* The original M-by-N matrix A was copied into the array C at +* the beginning of the routine, if RETURNC = .TRUE.. + +* Apply the column permutation matrix P stored in JPIV(1:K) +* to the columns 1:K in the M-by-N array C in place. +* After column interchanges, the first K columns of C should +* be the same as the first K columns of A*P, i.e. +* (A*P)(1:M,1:K) = C(1:M,1:K). The complexity of this algorithm +* is min(K,N-1). +* +* Index I is the original column index in the +* array C before interchanges. +* J is the current column index of the original column I at +* each step of interchanges. +* +* Auxiliary array IWORK(1:N) stores the inverse P_inv(J) +* of the current column permutation matrix P(J) at each +* column interchange step J only for the array +* values >= J:N. +* C_prev = P_inv(J) * C_next. +* Each IWORK(I) contains JJ corresponding to I +* Initialize IWORK(1:N) as (1:N). +* + DO I = 1, N, 1 + IWORK( I ) = I + END DO +* +* Auxiliary array IWORK(N+1:2N) stores the current column +* permutation matrix P_(J) at each column interchange step J +* only for the array index >= J:N. +* C_prev * P_(J) = C_next. +* Each IWORK(N+JJ) contains I corresponding to JJ. +* Initialize IWORK(N+1:2*N) as (1:N). +* + DO J = 1, N, 1 + IWORK( N + J ) = J + END DO +* +* Loop over the columns J = ( 1:min( K, N-1 ) ) in C. +* + DO J = 1, MIN( K, N-1 ), 1 +* +* IP is the original pivot column, i.e. is the original +* column that should be placed in the current column index +* J in the array C. +* + IP = JPIV( J ) +* +* I is the original column that is +* currently in the column index J in the array C after +* previous column interchanges. +* + I = IWORK( N+J ) +* + IF( I.NE.IP ) THEN +* +* JP is the current index of the original pivot +* column IP in the array C after previous column +* interchanges. +* + JP = IWORK( IP ) + +* Swap the original pivot column IP = JPIV( J ), +* at the current pivot index JP = IWORK( IP ) into +* index J. +* + CALL DSWAP( M, C( 1, J ), 1, C( 1, JP ), 1 ) +* +* Update the array IWORK(1:N) for the original column +* I that was swapped with IP. +* + IWORK( I ) = IWORK( IP ) +* +* Update the array IWORK(N+1:2*N) for the current column +* index JP that was swapped with the current column +* index J. +* + IWORK( N + JP ) = IWORK( N + J ) +* + END IF +* + END DO +* +* End of ELSE( RETURNX ) +* + END IF +* +* End of IF( RETURNC .AND. K.GT.0 ) +* + END IF +* +* ================================================================== +* +* Return the matrix X. +* + IF( RETURNX .AND. K.GT.0 ) THEN +* +* We need to use C and A to compute X = pseudoinv(C) * A, as +* the linear least squares solution to the overdetermined system +* C*X = A. We use LLS routine that uses the QR factorization. For +* that purpose, we store the matrix C into the array QRC. +* The matrix A was copied into the array X at the beginning +* of the routine. +* + CALL DLACPY( 'F', M, K, C, LDC, QRC, LDQRC ) +* + CALL DGELS( 'N', M, K, N, QRC, LDQRC, X, LDX, + $ WORK, LWORK, IINFO ) + INFO = IINFO +* + END IF +* + WORK( 1 ) = DBLE( LWKOPT ) + IWORK( 1 ) = LIWKOPT +* +* End of DGECXX +* + END diff --git a/lapack-netlib/SRC/sgecxx.c b/lapack-netlib/SRC/sgecxx.c new file mode 100644 index 0000000000..46c8fe6a4d --- /dev/null +++ b/lapack-netlib/SRC/sgecxx.c @@ -0,0 +1,1433 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i msub) { + *info = -6; + } else if (*kmaxfree < 0) { + *info = -7; + } else if (sisnan_(abstol)) { + *info = -8; + } else if (sisnan_(reltol)) { + *info = -9; + } else if (*lda < f2cmax(1,*m)) { + *info = -11; +/* This is a check for LDC */ + } else if (returnc && *ldc < f2cmax(1,*m) || ! returnc && *ldc < 1) { + *info = -20; +/* This is a check for LDQRC */ + } else if (returnx && *ldqrc < f2cmax(1,*m) || ! returnx && *ldqrc < 1) { + *info = -22; +/* This is a check for LDX */ + } else if (returnx && *ldx < f2cmax(1,*m) || ! returnx && *ldx < 1) { + *info = -24; + } + + } + +/* ================================================================== */ + +/* a) Test the input workspace size LWORK and LIWORK for the */ +/* minimum size requirement LWKMIN and LIWKMIN respectively. */ +/* b) Determine the optimal workspace sizes LWKOPT and LIWKOPT to */ +/* be returned in WORK( 1 ) and IWORK( 1 ) respectively, */ +/* if INFO >= 0 in cases: */ +/* (1) LQUERY = .TRUE., */ +/* (2) when the routine exits. */ +/* Here, LWKMIN and LIWKMIN are the minimum workspaces required for */ +/* unblocked code. */ + + if (*info == 0) { + if (minmn == 0) { + lwkmin = 1; + lwkopt = 1; + liwkmin = 1; + liwkopt = 1; + } else { + +/* (Real_wk_part_1) Real minimum and optimal workspace */ +/* computation. */ +/* LWKMIN = MAX(1, NSUB) for column 2-norm computation */ + + lwkmin = f2cmax(1,nsub); + lwkopt = lwkmin; + +/* (Int_wk_part_1) Integer minimum workspace computation. */ + + liwkmin = 1; + +/* Call of SGEQRF. */ + + if (nsel > 0) { + +/* (Real_wk_part_2) Real minimum workspace computation. */ +/* LWKMIN = MAX(1, NSEL) for the call of SGEQRF. */ +/* We can skip counting this workspace as */ +/* LWKMIN = MAX( LWKMIN, NSEL ), since NSEL <= NSUB. */ + +/* Query for optimal workspace size for SGEQRF. */ + + sgeqrf_(&msub, &nsel, &a[a_offset], lda, &tau[1], &work[1], & + c_n1, &iinfo); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + +/* Call of SORMQR. */ + + if (nfree > 0) { + +/* (Real_wk_part_3) Real minimum workspace computation. */ +/* NOTE: minimum workspace requirement for DORMQR */ +/* LWKMIN = MAX(1, NFREE) is smaller than NSUB */ +/* and it is smaller than LWKMIN = 3*NFREE-1 for */ +/* DGEQP3RK. We can skip counting this workspace as */ +/* as LWKMIN = MAX( LWKMIN, NFREE ).). */ + +/* Query for optimal workspace size for SORMQR. */ + + sormqr_("L", "T", &msub, &nfree, &nsel, &a[a_offset], lda, + &tau[1], &a[(nsel + 1) * a_dim1 + 1], lda, &work[ + 1], &c_n1, &iinfo); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + } + + } + +/* Call of SGEQP3RK. */ + + if (minmnfree != 0) { + +/* (Real_wk_part_4) Real minimum workspace computation. */ +/* LWKMIN = MAX(1, 3*NFREE-1) for the call of SGEQP3RK. */ + +/* Computing MAX */ + i__1 = lwkmin, i__2 = nfree * 3 - 1; + lwkmin = f2cmax(i__1,i__2); + +/* Query for optimal workspace size for SGEQP3RK. */ + + sgeqp3rk_(&mfree, &nfree, &c__0, &nfree, &c_b15, &c_b15, &a[ + a_dim1 + 1], lda, &kfree, &maxc2nrmkfree, & + relmaxc2nrmkfree, &jpiv[1], &tau[1], &work[1], &c_n1, + &iwork[1], &iinfo); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + +/* (Int_wk_part_2) Integer minimum workspace computation. */ +/* LIWKMIN = NFREE-1 for the call of SGEQP3RK. */ + +/* Computing MAX */ + i__1 = liwkmin, i__2 = nfree - 1; + liwkmin = f2cmax(i__1,i__2); + + if (nsel != 0) { + +/* (Int_wk_part_3) Integer minimum workspace computation. */ +/* NFREE is for SGEQP3RK and NFREE-1 for JPIV adjustment. */ + +/* Computing MAX */ + i__1 = liwkmin, i__2 = nfree + nfree - 1; + liwkmin = f2cmax(i__1,i__2); + } + + } + + if (returnc) { + +/* Integer minimum workspace computation. */ +/* (Int_wk_part_4) LIWKMIN = 2*N for applying the */ +/* interchanges for the columns in the matrix C. */ + +/* Computing MAX */ + i__1 = liwkmin, i__2 = *n << 1; + liwkmin = f2cmax(i__1,i__2); + } + +/* Integer optimal workspace computation. */ + + liwkopt = liwkmin; + +/* Call of SGELS. */ + + if (returnx) { + +/* (Real_wk_part_5) Real minimum workspace computation. */ +/* LWKMIN = f2cmax( 1, MINMN + f2cmax( MINMN, N ) ) = */ +/* = f2cmax( 1, MINMN + N ) for the call of SGELS. */ + +/* Computing MAX */ + i__1 = lwkmin, i__2 = minmn + *n; + lwkmin = f2cmax(i__1,i__2); + +/* Query for optimal workspace size for SGELS. */ + + kmaxls = minmn; + + sgels_("N", m, &kmaxls, n, &qrc[qrc_offset], ldqrc, &x[ + x_offset], ldx, &work[1], &c_n1, &iinfo); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + + } + +/* End of ELSE for IF( MINMN.EQ.0 ) */ + + } + + if (*lwork < lwkmin && ! lquery) { + *info = -26; + } else if (*liwork < liwkmin && ! lquery) { + *info = -28; + } + } + + if (*info == 0) { + work[1] = (real) lwkopt; + iwork[1] = liwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGECXX", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* ================================================================== */ + +/* Quick return if possible for: */ +/* a) M = 0 or N = 0. There is no matrix A(1:M,1:N). */ +/* b) MSUB = 0 or NSUB = 0. There is no matrix A_sub(1:MSUB,1:NSUB). */ +/* NOTE: f2cmin( M, N) = 0 implies f2cmin( MSUB, NSUB) = 0. */ +/* We need to return correct values for all scalar output parameters, */ +/* (including WORK(1) and IWORK(1), which are set above). */ + + if (f2cmin(msub,nsub) == 0) { + *k = 0; + *maxc2nrmk = 0.f; + *relmaxc2nrmk = 0.f; + *fnrmk = 0.f; + return 0; + } + +/* ================================================================== */ + + *k = 0; + +/* If we need to return factor X, copy the original untouched matrix */ +/* A into the array X. */ + + if (returnx) { + slacpy_("F", m, n, &a[a_offset], lda, &x[x_offset], ldx); + } + +/* If we need to return the factor C, copy the original matrix A */ +/* into the array C, only if do not return the factor X. In this */ +/* case, we need to choose the columns of the matrix A in the array C */ +/* in place, otherwise we can copy the columns of the matrix A from */ +/* the array X. */ + + if (returnc && ! returnx) { + slacpy_("F", m, n, &a[a_offset], lda, &c__[c_offset], ldc); + } + +/* ================================================================== */ +/* Permute the deselected rows to the bottom of the matrix A. */ +/* 1) The initial order of included rows in their block is preserved. */ +/* 2) The initial order of deselected rows in their block is not */ +/* preserved. */ +/* ================================================================== */ + +/* I is an index of DESEL_ROWS array and a row index of */ +/* the matrix A. MSUB is the number of processed included rows, which */ +/* is also an index pointer to the last included row in the matrix A. */ +/* We can think of I as a row source index, and MSUB as a destination */ +/* index for moving an included row in the matrix A. */ + +/* ( We start with MSUB = 0. We loop over index I in (1:M), and */ +/* for each position I in DESEL_ROWS array, we check if the row at */ +/* the position I in the matrix A is an included row (not -1 value). */ +/* If it is an included row, we increment MSUB pointer, otherwise */ +/* we do not change MSUB index pointer. Then, we bring this included */ +/* row from the index I in the matrix A into smaller (or same) */ +/* MSUB index in the matrix A. If I = MSUB, then the included row */ +/* is already in place. Due to row swap, the deselected row */ +/* at MSUB index will move into I index in the matrix A. In this way, */ +/* we move all the included rows to the top matrix block preserving */ +/* their initial order within the included block. The initial order */ +/* of deselected rows will not be preserved within their block. */ + + if (use_desel_rows__) { + + msub = 0; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Initialize the row pivot array IPIV. */ + ipiv[i__] = i__; + +/* The row at the index I is an included row and should be */ +/* moved to the top of the matrix A. */ + + if (desel_rows__[i__] != -1) { + ++msub; + +/* This is a check whether the included row is */ +/* on the included place already. */ + + if (i__ != msub) { + +/* Here, we swap A(I,1:N) into A(MSUB,1:N). */ + + sswap_(n, &a[i__ + a_dim1], lda, &a[msub + a_dim1], lda); + +/* Save the interchange. */ + + ipiv[i__] = ipiv[msub]; + ipiv[msub] = i__; + desel_rows__[msub] = desel_rows__[i__]; + desel_rows__[i__] = -1; + } + } + + } + + } else { + +/* We do not use the row deselection DESEL_ROWS array. */ +/* Initialize the row pivot array IPIV. */ +/* NOTE: MSUB=M has default value, */ +/* which is set at the beginning of the routine, before argument */ +/* checks. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + ipiv[i__] = i__; + } + } + +/* ================================================================== */ +/* Permute the preselected columns to the left and deselected */ +/* columns to the right of the matrix A. */ +/* 1) The order of preselected columns is preserved. */ +/* 2) The order of free columns is not preserved. */ +/* 3) The order of deselected columns is not preserved. */ +/* ================================================================== */ + +/* J is the index of SEL_DESEL_COLS array and column J */ +/* of the matrix A. */ + + if (use_sel_desel_cols__) { + +/* Column selection. */ +/* NSEL is the number of selected columns, also the pointer to */ +/* the last selected column. */ + + nsel = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Initialize column pivot array JPIV. */ + jpiv[j] = j; + + if (sel_desel_cols__[j] == 1) { + ++nsel; + +/* This is the check whether the selected column is */ +/* on the selected place already. */ + + if (j != nsel) { + +/* Here, we swap the column A(1:M,J) into A(1:M,NSEL) */ + + sswap_(m, &a[j * a_dim1 + 1], &c__1, &a[nsel * a_dim1 + 1] + , &c__1); + jpiv[j] = jpiv[nsel]; + jpiv[nsel] = j; + sel_desel_cols__[j] = sel_desel_cols__[nsel]; + sel_desel_cols__[nsel] = 1; + } + } + } + +/* Column deselection. */ +/* JDESEL the pointer to the last */ +/* deselected column counting right-to-left. */ + + jdesel = *n + 1; + i__1 = nsel + 1; + for (j = *n; j >= i__1; --j) { + if (sel_desel_cols__[j] == -1) { + --jdesel; + +/* This is the check whether the deselected column is */ +/* on the deselected place already. */ + + if (j != jdesel) { + +/* Here, we swap the column A(1:M,J) into A(1:M,JDESEL) */ + + sswap_(m, &a[j * a_dim1 + 1], &c__1, &a[jdesel * a_dim1 + + 1], &c__1); + itemp = jpiv[j]; + jpiv[j] = jpiv[jdesel]; + jpiv[jdesel] = itemp; + sel_desel_cols__[j] = sel_desel_cols__[jdesel]; + sel_desel_cols__[jdesel] = -1; + } + } + } + + nsub = jdesel - 1; + + } else { + +/* We do not use the column selection deselection */ +/* SEL_DESEL_COLS array. */ +/* Initialize column pivot array JPIV. */ +/* NOTE: NSUB=N has default value, */ +/* which is set at the beginning of the routine, before argument */ +/* checks. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jpiv[j] = j; + } + + } + +/* ================================================================== */ +/* Compute the complete column 2-norms of the submatrix */ +/* A_sub = A(1:MSUB, 1:NSUB) and store them in WORK(1:NSUB). */ + + i__1 = nsub; + for (j = 1; j <= i__1; ++j) { + work[j] = snrm2_(&msub, &a[j * a_dim1 + 1], &c__1); + } + +/* Compute the column index of the maximum column 2-norm and */ +/* the maximum column 2-norm itself for the submatrix */ +/* A_sub = A(1:MSUB, 1:NSUB). */ + + kp0 = isamax_(&nsub, &work[1], &c__1); + maxc2nrm = work[kp0]; + +/* ================================================================== */ +/* Process preselected columns */ + +/* Compute the QR factorization of NSEL preselected columns (1:NSEL) */ +/* in the submatrix A_sub = A(1:MSUB, 1:NSUB) and update */ +/* remaining NFREE free columns (NSEL+1:NSUB). */ +/* NSUB = NSEL + NFREE */ + + if (nsel > 0) { + +/* Case (a): MSUB < NSEL. */ + +/* This is handled at the argument check stage in the */ +/* beginning of the routine. When the number of preselected */ +/* columns is larger than MSUB, hence the factorization of */ +/* all NSEL columns cannot be completed. Return from the */ +/* routine with the error of COL_SEL_DESEL parameter. */ + +/* Case (b): MSUB = NSEL. */ +/* Case (c-1): MSUB > NSEL and NSEL = NSUB. */ + +/* For cases (b) and (c-1), there will be no residual */ +/* submatrix after factorization of NSEL columns */ +/* at step K = NSEL: */ +/* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). */ + +/* Case (c-2): MSUB > NSEL and NSEL < NSUB. */ + +/* For Case (c-2) is a submatrix residual at step K=NSEL */ +/* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) */ + + sgeqrf_(&msub, &nsel, &a[a_offset], lda, &tau[1], &work[1], lwork, & + iinfo); + +/* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) */ + + if (nfree > 0) { + +/* This is only for case (c-2) ('L' = Left, 'T' = Transpose) */ + + sormqr_("L", "T", &msub, &nfree, &nsel, &a[a_offset], lda, &tau[1] + , &a[(nsel + 1) * a_dim1 + 1], lda, &work[1], lwork, & + iinfo); + } + + *k += nsel; + +/* End of IF(NSEL.GT.0) */ + + } + +/* ================================================================== */ + + kfree = 0; + + if (minmnfree != 0) { + +/* Factorize NFREE free columns of */ +/* A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), */ +/* KFREE is the number of columns that were actually factorized */ +/* among NFREE columns. */ + +/* ================================================================== */ + + eps = slamch_("Epsilon"); + + usetol = FALSE_; + +/* Adjust ABSTOL only if nonnegative. Negative value means disabled. */ +/* We need to keep negative value for later use in criterion */ +/* check. */ + + if (*abstol >= 0.f) { + safmin = slamch_("Safe minimum"); +/* Computing MAX */ + r__1 = *abstol, r__2 = safmin * 2.f; + *abstol = f2cmax(r__1,r__2); + usetol = TRUE_; + } + +/* Adjust RELTOL only if nonnegative. Negative value means disabled. */ +/* We need to keep negative value for later use in criterion */ +/* check. */ + + if (*reltol >= 0.f) { + *reltol = f2cmax(*reltol,eps); + usetol = TRUE_; + } + +/* ================================================================== */ + +/* Disable RELTOLFREE when calling SGEQP3RK for free columns */ +/* factorization, since SGEQP3RK expects RELTOLFREE with respect */ +/* to the residual matrix A_sub_resid(NSEL), not the whole */ +/* original matrix A. We can use RELTOL criterion by passing it */ +/* to ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that */ +/* the negative values of ABSTOL and RELTOL are propagated */ +/* to ABSTOLFREE and RELTOLFREE, since negative values means */ +/* that the criterion is disabled. */ + + if (usetol) { +/* Computing MAX */ + r__1 = *abstol, r__2 = *reltol * maxc2nrm; + abstolfree = f2cmax(r__1,r__2); + } else { + abstolfree = -1.f; + } + reltolfree = -1.f; + +/* Save JPIV(NSEL+1:NSUB) into WORK(NFREE+1:2*NFREE-1) */ + + if (nsel != 0) { + i__1 = nfree; + for (j = 1; j <= i__1; ++j) { + iwork[nfree + j] = jpiv[nsel + j]; + } + } + + sgeqp3rk_(&mfree, &nfree, &c__0, kmaxfree, &abstolfree, &reltolfree, & + a[nsel + 1 + (nsel + 1) * a_dim1], lda, &kfree, & + maxc2nrmkfree, &relmaxc2nrmkfree, &jpiv[nsel + 1], &tau[nsel + + 1], &work[1], lwork, &iwork[1], &iinfo); + +/* Adjust JPIV */ + + if (nsel != 0) { + i__1 = nfree; + for (j = 1; j <= i__1; ++j) { + jpiv[nsel + j] = iwork[nfree + jpiv[nsel + j]]; + } + } + +/* 1) Adjust the return value for the number of factorized */ +/* columns K for the whole submatrix A_sub. */ +/* 2) MAXC2NRMK is returned transparently without change */ +/* as MAXC2NRMKFREE is returned from SGEQP3RK. */ +/* 3) Adjust the return value RELMAXC2NRMK for the whole */ +/* submatrix A_sub. We do not use RELMAXC2NRMKFREE */ +/* returned from SGEQP3RK. */ + + *k += kfree; + *maxc2nrmk = maxc2nrmkfree; + *relmaxc2nrmk = *maxc2nrmk / maxc2nrm; + + } else { + +/* Set norms to zero */ + + *maxc2nrmk = 0.f; + *relmaxc2nrmk = 0.f; + + } + +/* Now, MRESID and NRESID is the number of rows and columns */ +/* respectively in A_free_resid = A(K+1:MSUB,K+1:NSUB). */ + + mresid = mfree - kfree; + nresid = nfree - kfree; + + if (f2cmin(mresid,nresid) != 0) { + *fnrmk = slange_("F", &mresid, &nresid, &a[*k + 1 + (*k + 1) * a_dim1] + , lda, &work[1]); + } else { + *fnrmk = 0.f; + } + +/* ================================================================== */ + +/* Return the matrix C. */ + + if (returnc && *k > 0) { + + if (returnx) { + +/* Copy the selected K columns of the original matrix A (that was */ +/* saved into the array X) into the array C according to */ +/* the pivot array JPIV. If we return X, then the matrix A is */ +/* saved in the array X, and it is faster to copy into C than */ +/* doing column permutation in place, as it is the ELSE case. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(m, &x[jpiv[j] * x_dim1 + 1], &c__1, &c__[j * c_dim1 + + 1], &c__1); + } + + } else { + +/* Swap the columns of the original matrix A copied into */ +/* the array C in place. */ + +/* The original M-by-N matrix A was copied into the array C at */ +/* the beginning of the routine, if RETURNC = .TRUE.. */ +/* Apply the column permutation matrix P stored in JPIV(1:K) */ +/* to the columns 1:K in the M-by-N array C in place. */ +/* After column interchanges, the first K columns of C should */ +/* be the same as the first K columns of A*P, i.e. */ +/* (A*P)(1:M,1:K) = C(1:M,1:K). The complexity of this algorithm */ +/* is f2cmin(K,N-1). */ + +/* Index I is the original column index in the */ +/* array C before interchanges. */ +/* J is the current column index of the original column I at */ +/* each step of interchanges. */ + +/* Auxiliary array IWORK(1:N) stores the inverse P_inv(J) */ +/* of the current column permutation matrix P(J) at each */ +/* column interchange step J only for the array */ +/* values >= J:N. */ +/* C_prev = P_inv(J) * C_next. */ +/* Each IWORK(I) contains JJ corresponding to I */ +/* Initialize IWORK(1:N) as (1:N). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = i__; + } + +/* Auxiliary array IWORK(N+1:2N) stores the current column */ +/* permutation matrix P_(J) at each column interchange step J */ +/* only for the array index >= J:N. */ +/* C_prev * P_(J) = C_next. */ +/* Each IWORK(N+JJ) contains I corresponding to JJ. */ +/* Initialize IWORK(N+1:2*N) as (1:N). */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + iwork[*n + j] = j; + } + +/* Loop over the columns J = ( 1:f2cmin( K, N-1 ) ) in C. */ + +/* Computing MIN */ + i__2 = *k, i__3 = *n - 1; + i__1 = f2cmin(i__2,i__3); + for (j = 1; j <= i__1; ++j) { + +/* IP is the original pivot column, i.e. is the original */ +/* column that should be placed in the current column index */ +/* J in the array C. */ + + ip = jpiv[j]; + +/* I is the original column that is */ +/* currently in the column index J in the array C after */ +/* previous column interchanges. */ + + i__ = iwork[*n + j]; + + if (i__ != ip) { + +/* JP is the current index of the original pivot */ +/* column IP in the array C after previous column */ +/* interchanges. */ + + jp = iwork[ip]; +/* Swap the original pivot column IP = JPIV( J ), */ +/* at the current pivot index JP = IWORK( IP ) into */ +/* index J. */ + + sswap_(m, &c__[j * c_dim1 + 1], &c__1, &c__[jp * c_dim1 + + 1], &c__1); + +/* Update the array IWORK(1:N) for the original column */ +/* I that was swapped with IP. */ + + iwork[i__] = iwork[ip]; + +/* Update the array IWORK(N+1:2*N) for the current column */ +/* index JP that was swapped with the current column */ +/* index J. */ + + iwork[*n + jp] = iwork[*n + j]; + + } + + } + +/* End of ELSE( RETURNX ) */ + + } + +/* End of IF( RETURNC .AND. K.GT.0 ) */ + + } + +/* ================================================================== */ + +/* Return the matrix X. */ + + if (returnx && *k > 0) { + +/* We need to use C and A to compute X = pseudoinv(C) * A, as */ +/* the linear least squares solution to the overdetermined system */ +/* C*X = A. We use LLS routine that uses the QR factorization. For */ +/* that purpose, we store the matrix C into the array QRC. */ +/* The matrix A was copied into the array X at the beginning */ +/* of the routine. */ + + slacpy_("F", m, k, &c__[c_offset], ldc, &qrc[qrc_offset], ldqrc); + + sgels_("N", m, k, n, &qrc[qrc_offset], ldqrc, &x[x_offset], ldx, & + work[1], lwork, &iinfo); + *info = iinfo; + + } + + work[1] = (real) lwkopt; + iwork[1] = liwkopt; + +/* End of SGECXX */ + + return 0; +} /* sgecxx_ */ + diff --git a/lapack-netlib/SRC/sgecxx.f b/lapack-netlib/SRC/sgecxx.f new file mode 100644 index 0000000000..d50cf78efc --- /dev/null +++ b/lapack-netlib/SRC/sgecxx.f @@ -0,0 +1,1714 @@ +*> \brief \b SGECXX computes a CX factorization of a real M-by-N matrix A using a truncated (rank k) Householder QR factorization with column pivoting. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download SGECXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE SGECXX( FACT, USESD, M, N, +* $ DESEL_ROWS, SEL_DESEL_COLS, +* $ KMAXFREE, ABSTOL, RELTOL, A, LDA, +* $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, +* $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, +* $ X, LDX, WORK, LWORK, IWORK, LIWORK, INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER FACT, USESD +* INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, +* $ LDX, LIWORK, LWORK, M, N +* REAL ABSTOL, FNRMK, MAXC2NRMK, +* $ RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. +* INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), +* $ JPIV( * ), SEL_DESEL_COLS( * ) +* REAL A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), +* $ TAU( * ), WORK( * ), X( LDX, *) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SGECXX computes a CX factorization of a real M-by-N matrix A using +*> a truncated rank-K Householder QR factorization with a column +*> pivoting algorithm, which is implemented in the SGEQP3RK routine. +*> +*> A * P = C*X + A_resid, where +*> +*> C is an M-by-K matrix consisting of K columns selected +*> from the original matrix A, +*> +*> X is a K-by-N matrix that minimizes the Frobenius norm of the +*> residual matrix A_resid, X = pseudoinv(C) * A, +*> +*> P is an N-by-N permutation matrix chosen so that the first +*> K columns of A*P equal C, +*> +*> A_resid is an M-by-N residual matrix. +*> +*> The column selection for the matrix C has two stages. +*> +*> Column preselection stage 1 (optional). +*> ======================================= +*> +*> The user can select N_sel columns and deselect N_desel columns +*> of the matrix A that MUST be included and excluded respectively +*> from the matrix C a priori, before running the column selection +*> algorithm. This is controlled by flags in the array +*> SEL_DESEL_COLS. The deselected columns are permuted to the right +*> side of the matrix A and selected columns are permuted to the left +*> side of the matrix A. The details of the column permutation +*> (i.e. the column permutation matrix P) are stored in the +*> array JPIV. This feature can be used when the goal is to approximate +*> the deselected columns by linear combinations of K selected columns, +*> where the K columns MUST include the N_sel preselected columns. +*> +*> Column selection stage 2. +*> ========================= +*> +*> The routine runs a column selection algorithm that can +*> be controlled by three stopping criteria described below. +*> For column selection, the routine uses a truncated (rank-K) +*> Householder QR factorization with column pivoting algorithm using +*> the routine SGEQP3RK. +*> +*> Optionally, before running the column selection +*> algorithm, the user can deselect M_desel rows of the matrix A that +*> should NOT be considered by the column selection algorithm (i.e. +*> during the factorization). This is controlled by flags in +*> the array DESEL_ROWS. The deselected rows are permuted to the +*> bottom of the matrix A. The details of the row permutation (i.e. the +*> row permutation matrix) are stored in the array IPIV. This feature +*> can be used when the goal is to use the deselected rows as test data, +*> and the selected rows as training data. +*> +*> This means that the column selection factorization algorithm is +*> effectively running on the submatrix A_sub = A(1:M_sub,1:N_sub) of +*> the matrix A after the permutations described above. Here M_sub is +*> the number of rows of the matrix A minus the number of deselected +*> rows M_desel, i.e. M_sub = M - M_desel, and N_sub is the number +*> of columns of the matrix A minus the number of deselected columns +*> N_desel, i.e. N_sub = N - N_desel. +*> +*> The reported column selection error metrics MAXC2NRMK, RELMAXC2NRMK +*> and FNRMK described below are computed using only A_sub. +*> +*> Column selection criteria. +*> ========================== +*> +*> The column selection criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) KMAXFREE: This input parameter specifies the maximum number of +*> columns to factorize in addition to the N_sel preselected +*> columns. The factorization rank is limited to N_sel + KMAXFREE. +*> If N_sel + KMAXFREE >= min(M_sub, N_sub), this criterion +*> is not used. +*> +*> 2) ABSTOL: This input parameter specifies the absolute tolerance +*> for the maximum column 2-norm of the submatrix residual +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub), where +*> A_sub(K) denotes the contents of the array +*> A_sub = A(1:M_sub, 1:N_sub) after K columns were factorized. +*> This means that the factorization stops if this norm is less +*> than or equal to ABSTOL. If ABSTOL < 0.0, this criterion is +*> not used. +*> +*> 3) RELTOL: This input parameter specifies the tolerance for +*> the maximum column 2-norm of the submatrix residual +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) divided +*> by the maximum column 2-norm of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub), where A_sub(K) denotes the contents +*> of the array A_sub after K columns were factorized. +*> This means that the factorization stops when the ratio of the +*> maximum column 2-norm of A_sub_resid(K) to the maximum column +*> 2-norm of A_sub is less than or equal to RELTOL. +*> If RELTOL < 0.0, this criterion is not used. +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the entire submatrix A_sub is factorized. +*> +*> To perform a full-rank factorization of the matrix A_sub, use +*> selection criteria that satisfy N_sel + KMAXFREE >= min(M_sub,N_sub) +*> and ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> If the user wishes to verify that the columns of the matrix C are +*> sufficiently linearly independent for their intended use, the user +*> can compute the condition number of its R factor by calling DTRCON +*> on the upper-triangular part of QRC(1:K,1:K) in the output +*> array QRC. +*> +*> How N_sel affects the column selection algorithm. +*> ================================================= +*> +*> As mentioned above, the N_sel preselected columns are permuted to the +*> left side of the matrix A, and will be included in the column +*> selection. Then the routine factorizes that block A(1:M_sub,1:N_sel), +*> and if any of the three stopping criteria is met immediately after +*> factoring the first N_sel columns the routine exits +*> (i.e. if the user does not want to select KMAXFREE > 0 extra columns, +*> or if the absolute or relative tolerance of the maximum column 2-norm +*> of the residual is satisfied). In this case, the number +*> of selected columns would be K = N_sel. Otherwise, the factorization +*> routine finds a new column to select with the maximum column 2-norm +*> in the residual A(N_sel+1:M_sub,N_sel+1:N_sub), and swaps that +*> column with the first column of A(1:M,N_sel+1:N_sub). Then the +*> routine checks if the stopping criteria are met in the next residual +*> A(N_sel+2:M_sub,N_sel+2:N_sub), and so on. +*> +*> Computation of the matrix factors. +*> ================================== +*> +*> When the columns are selected for the factor C, and: +*> (a) If the flag FACT = 'P', the routine returns only the indices of +*> the selected columns from the original matrix A, which are +*> stored in the first K elements of the JPIV array. +*> (b) If the flag FACT = 'C', then in addition to (a), the routine +*> explicitly returns the matrix C in the array C. +*> (c) If the flag FACT = 'X', then in addition to (a) and (b), +*> the routine explicitly computes and returns the factor +*> X = pseudoinv(C) * A in the array X, and it also returns +*> the factor R alongside the Householder vectors +*> of the QR factorization of the matrix C in the array QRC. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> The flag specifies how the factors of a CX factorization +*> are returned. +*> +*> = 'P': the routine returns: +*> (1) only the column permutation matrix P in +*> the array JPIV. +*> (The first K elements of the array JPIV +*> contain indices of the columns that were +*> selected from the matrix A to form the +*> factor C.) +*> (fastest option, smallest memory space) +*> +*> = 'C': the routine returns: +*> (1) the column permutation matrix P +*> in the array JPIV. (The first K elements are +*> indices of the selected columns from +*> the matrix A.) +*> (2) the M-by-K factor C explicitly in the array C. +*> (slower option, more memory space) +*> +*> = 'X': the routine returns: +*> (1) the column permutation matrix P in +*> the array JPIV. (The first K elements are +*> indices of the selected columns from +*> the matrix A.) +*> (2) the M-by-K factor C explicitly in the array C. +*> (3) the K-by-N factor X explicitly in the array X. +*> (4) the K-by-K upper triangular factor R and +*> the Householder vectors of the QR factorization +*> of the factor C in the array QRC. +*> ( The factor R may be useful for checking +*> the factor C for singularity, in which case +*> R will have a zero on the diagonal, and +*> the factor X cannot be computed. ) +*> (slowest option, largest memory space) +*> \endverbatim +*> +*> \param[in] USESD +*> \verbatim +*> USESD is CHARACTER*1 +*> The flag specifies whether the row deselection and column +*> preselection-deselection functionality is turned ON or OFF. +*> +*> = 'N': Both row deselection and column +*> preselection-deselection are OFF. +*> Both arrays DESEL_ROWS and SEL_DESEL_COLS +*> are not used. +*> +*> = 'R': Only row deselection is ON. +*> Column preselection-deselection is OFF. +*> The array SEL_DESEL_COLS is not used. +*> +*> = 'C': Only column preselection-deselection is ON. +*> Row deselection is OFF. +*> The array DESEL_ROWS is not used. +*> +*> = 'A': Means "All". Both row deselection and column +*> preselection-deselection are ON. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] DESEL_ROWS +*> \verbatim +*> DESEL_ROWS is INTEGER array, dimension (M) +*> DESEL_ROWS is only accessed if USESD = 'R' or 'A'. +*> This is a row deselection mask array that separates +*> the rows of matrix A into 2 sets. +*> +*> On entry: +*> a) If DESEL_ROWS(i) = -1, the i-th row of the matrix A is +*> deselected by the user, i.e. chosen to be excluded from +*> the column selection algorithm (in both preselection and +*> selection stages) and will be permuted to the bottom +*> of the matrix A. +*> The number of deselected rows is denoted by M_desel. +*> +*> b) If DESEL_ROWS(i) is not equal -1, +*> the i-th row of A will be used in the column selection +*> algorithm (in both preselection and selection stages). +*> This defines a set of M_sub = M - M_desel rows that +*> the algorithm will use to select columns. +*> After the permutation, this set will be at the top +*> of the matrix A. +*> +*> On exit: +*> DESEL_ROWS will be permuted according to IPIV(i), +*> so that, if IPIV(i) = k, then the entry i of DESEL_ROWS +*> on exit was the entry k of DESEL_ROWS on entry. +*> +*> \endverbatim +*> +*> \param[in,out] SEL_DESEL_COLS +*> \verbatim +*> SEL_DESEL_COLS is INTEGER array, dimension (N) +*> SEL_DESEL_COLS is only accessed if USESD = 'C' or 'A'. +*> This is a column preselection-deselection mask array that +*> separates the columns of matrix A into 3 sets. +*> +*> On entry: +*> a) If SEL_DESEL_COLS(j) = +1, the j-th column of the matrix +*> A is preselected by the user to be included +*> in the factor C and will be permuted to the left side +*> of the array A. The number of selected columns is +*> denoted by N_sel. +*> +*> b) If SEL_DESEL_COLS(j) = -1, the j-th column of the matrix +*> A is deselected by the user, i.e. chosen to be excluded +*> from the factor C and will be permuted to the right side +*> of the array A. The number of deselected columns is +*> denoted by N_desel. +*> +*> c) If SEL_DESEL_COLS(j) is not equal to 1 and not equal +*> to -1, the j-th column of A is a free column and will be +*> used by the column selection algorithm to determine if +*> this column will be selected. This defines a set of +*> columns of size N_free = N - N_sel - N_desel. +*> +*> On exit: +*> SEL_DESEL_COLS will be permuted according to JPIV(j), +*> so that, if JPIV(j) = k, then the entry j +*> of SEL_DESEL_COLS on exit was the entry k +*> of SEL_DESEL_COLS on entry. +*> +*> NOTE: An error returned as INFO = -6 means that the number +*> of preselected N_sel columns is larger than M_sub. +*> Therefore, the QR factorization of all N_sel preselected +*> columns cannot be completed. +*> \endverbatim +*> +*> \param[in] KMAXFREE +*> \verbatim +*> KMAXFREE is INTEGER, KMAXFREE >= 0. +*> +*> The first column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> KMAXFREE is the maximum number of columns of the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) to select +*> during the column selection stage 2. +*> +*> KMAXFREE does not include the preselected N_sel columns. +*> N_sel + KMAXFREE is the maximum factorization rank of +*> the matrix A_sub. +*> +*> a) If N_sel + KMAXFREE >= min(M_sub, N_sub), then this +*> stopping criterion is not used, i.e. columns are +*> selected in the factorization stage 2 depending +*> on ABSTOL and RELTOL. +*> +*> b) If KMAXFREE = 0, then this stopping criterion is +*> satisfied on input and the routine exits without +*> performing column selection stage 2 +*> on the submatrix A_sub. This means that the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) is not modified +*> in the column selection stage 2 +*> and A_free is itself the residual for the factorization. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is REAL, cannot be NaN. +*> +*> The second column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> ABSTOL is the absolute tolerance (stopping threshold) +*> for maxcol2norm(A_sub_resid(K)), where K >= N_sel. +*> +*> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm +*> of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) +*> when K columns have been factorized. +*> The column selection algorithm converges +*> (stops the factorization) when +*> maxcol2norm(A_sub_resid(K)) <= ABSTOL, where K >= N_sel. +*> +*> In the following, +*> SAFMIN = SLAMCH('S'), +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub), +*> maxcol2norm(A_free) is the maximum column 2-norm +*> of the matrix A_free. +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -8 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, and the column selection algorithm stops +*> the factorization of A_free depending +*> on KMAXFREE and RELTOL. +*> This includes the case where ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case where ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> If ABSTOL chosen above is >= maxcol2norm(A_free), then +*> this stopping criterion is satisfied on input, and +*> the routine only preselects K = N_sel columns. The leftmost +*> preselected N_sel columns in the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) are factorized. The routine +*> then computes maxcol2norm(A_free) and returns it +*> in MAXC2NORMK, computes and returns RELMAXC2NORMK of A_free, +*> and exits immediately. +*> This means that the factorization residual +*> A_sub_resid(N_sel) = A_free = A(N_sel+1:M_sub,N_sel+1:N_sub) +*> is not modified in the column selection stage 2. +*> This includes the case where ABSTOL = +Inf. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is REAL, cannot be NaN. +*> +*> The third column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> RELTOL is the tolerance (stopping threshold) for the ratio +*> relmaxcol2norm(A_sub_resid(K)) = +*> = maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub), +*> where K >= N_sel. +*> +*> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm +*> of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) +*> when K columns have been factorized. +*> maxcol2norm(A_sub) is the maximum column 2-norm +*> of the original submatrix A_sub = A(1:M_sub, 1:N_sub). +*> The column selection algorithm converges +*> (stops the factorization) when the ratio +*> relmaxcol2norm(A_sub_resid(K)) <= RELTOL, where K >= N_sel. +*> +*> In the following, +*> EPS = SLAMCH('E'), +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub). +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -9 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used and the column selection algorithm stops +*> the factorization of A_free depending +*> on KMAXFREE and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. +*> This includes the case RELTOL = -0.0. +*> +*> d) If EPS <= RELTOL then the input value of RELTOL +*> is used. +*> +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input, and the routine +*> only preselects K = N_sel columns. The leftmost +*> preselected N_sel columns in the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) are factorized. +*> The routine then computes maxcol2norm(A_free) and returns +*> it in MAXC2NORMK, returns RELMAXC2NORMK as 1.0, and exits +*> immediately. +*> This means that the factorization residual +*> A_sub_resid(N_sel) = A_free = A(N_sel+1:M_sub,N_sel+1:N_sub) +*> is not modified. +*> This includes the case RELTOL = +Inf. +*> +*> NOTE: We recommend RELTOL to satisfy +*> min(max(M_sub,N_sub)*EPS, sqrt(EPS)) <= RELTOL +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is REAL array, dimension (LDA,N) +*> +*> On entry: +*> the M-by-N matrix A. +*> +*> On exit: +*> +*> NOTE: +*> The output parameter K, the number of selected +*> columns, is described later. +*> A_sub = A(1:M_sub, 1:N_sub). +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> +*> 2) If K > 0, A(1:M,1:N) contains the following parts: +*> +*> (a) If M_sub < M (which is the same as M_desel > 0), +*> the subarray A(M_sub+1:M,1:N) contains the deselected +*> rows. +*> +*> (b) If N_sub < N ( which is the same as N_desel > 0 ), +*> the subarray A(1:M,N_sub+1:N) contains the +*> deselected columns. +*> +*> (c) If N_sel > 0, +*> the union of the subarray A(1:M_sub, 1:N_sel) +*> and the subarray A(1:N_sel, 1:N_sub) contains parts +*> of the factors obtained by computing Householder QR +*> factorization WITHOUT column pivoting of N_sel +*> preselected columns using the routine SGEQRF. +*> +*> (d) The subarray A(N_sel+1:M_sub, N_sel+1:N_sub) +*> contains parts of the factors obtained by computing +*> a truncated (rank K) Householder QR factorization with +*> column pivoting using the routine SGEQP3RK on +*> the matrix A_free = A(N_sel+1:M_sub, N_sel+1:N_sub), +*> which is the result of applying selection and +*> deselection of columns, applying deselection of rows +*> to the original matrix A, and applying orthogonal +*> transformation from the factorization of the first +*> N_sel columns as described in part (c). +*> +*> 1. The elements below the diagonal of the subarray +*> A_sub(1:M_sub,1:K) together with TAU(1:K) +*> represent the orthogonal matrix Q(K) as a +*> product of K Householder elementary reflectors. +*> +*> 2. The elements on and above the diagonal of +*> the subarray A_sub(1:K,1:N_sub) contain the +*> K-by-N_sub upper-trapezoidal matrix +*> R_sub_approx(K) = ( R_sub11(K), R_sub12(K) ). +*> NOTE: If K = min(M_sub,N_sub), i.e. full rank +*> factorization, then R_sub_approx(K) is the +*> full factor R which is upper-trapezoidal. +*> If, in addition, M_sub >= N_sub, then R is +*> upper-triangular. +*> +*> 3. The subarray A_sub(K+1:M_sub,K+1:N_sub) contains +*> the (M_sub-K)-by-(N_sub-K) rectangular matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> The number of columns that were selected +*> (K is the factorization rank). +*> 0 <= K <= min( M_sub, N_sel+KMAXFREE, N_sub ). +*> +*> NOTE: If K = 0, a) the arrays A is not, modified. +*> b) the array TAU(1,min(M_sub,N_sub)) +*> is set to ZERO. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is REAL +*> The maximum column 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub), +*> when factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, so +*> the matrix A_sub = A(1:M_sub, 1:N_sub) was not modified +*> and is itself a residual matrix, then MAXC2NRMK equals +*> the maximum column 2-norm of the original matrix A_sub. +*> +*> b) If 0 < K < min(M_sub, N_sub), then MAXC2NRMK is returned. +*> +*> c) If K = min(M_sub, N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK at the factorization step K is equal +*> to the diagonal element R_sub(K+1,K+1) of the factor +*> R_sub in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is REAL +*> The ratio MAXC2NRMK / MAXC2NRM +*> of the maximum column 2-norm MAXC2NRMK of the residual +*> matrix A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) (when +*> factorization stopped at rank K) and maximum column 2-norm +*> MAXC2NRM of the matrix A_sub = A(1:M_sub, 1:N_sub). +*> RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A_sub was not modified +*> and is itself a residual matrix, +*> then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M_sub,N_sub), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M_sub,N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no residual matrix +*> A_sub_resid(K), then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK at the factorization step K would equal +*> abs(R_sub(K+1,K+1))/MAXC2NRM in the next +*> factorization step K+1, where R_sub(K+1,K+1) is the +*> diagonal element of the factor R_sub in the next +*> factorization step K+1. +*> \endverbatim +*> +*> \param[out] FNRMK +*> \verbatim +*> FNRMK is REAL +*> Frobenius norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub). +*> FNRMK >= 0.0 +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (M) +*> Row permutation indices due to row deselection, +*> for 1 <= i <= M. +*> If IPIV(i) = k, then the row i of A was +*> the row k of A. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column permutation indices, for 1 <= j <= N. +*> If JPIV(j)= k, then the column j of A*P was +*> the column k of A. +*> +*> The first K elements of the array JPIV contain +*> indices of the columns of the factor C that were selected +*> from the matrix A. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array, dimension (min(M_sub,N_sub)) +*> The scalar factors of the elementary reflectors. +*> +*> If K = 0, all elements TAU(1:min(M_sub,N_sub)) are set +*> to zero. +*> If 0 < K <= min(M_sub,N_sub): +*> only the elements TAU(1:K) may be modified, +*> the elements TAU(K+1:min(M_sub,N_sub)) are set to zero. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is REAL array. +*> +*> If FACT = 'P': +*> the array is not used, the array dimension >= (1,1). +*> +*> If FACT = 'C': +*> the array dimension is (LDC,N). +*> If K = 0: +*> the M-by-N array C contains a copy of +*> the original M-by-N matrix A. +*> If K > 0: +*> a) columns (1:K) of the array C contain +*> the M-by-K factor C (the selected columns +*> from the original matrix A). +*> b) columns (K+1:N) of the array C contain +*> the deselected columns from the original +*> matrix A. +*> +*> If FACT = 'X': +*> the array dimension is (LDC,N). +*> If K = 0: +*> the M-by-N array C is not used. +*> If K > 0: +*> a) columns (1:K) of the array C contain +*> the M-by-K factor C (the selected columns +*> from the original matrix A). +*> b) columns (K+1:N) of the array C are +*> not used. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. +*> If FACT = 'P', LDC >= 1. +*> If FACT = 'C' or 'X', LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] QRC +*> \verbatim +*> QRC is REAL array. +*> +*> If FACT = 'P' or 'C': The array is not used, +*> the array dimension is >= (1,1). +*> +*> If FACT = 'X': the array dimension is (LDQRC,min(M,N)). +*> +*> If K = 0, the array is not used. +*> If K > 0, QRC(1:M,1:K) stores two components from +*> the QR factorization of the factor C. The K-by-K +*> factor R is stored in the upper triangle. +*> The Householder vectors are stored in the lower +*> trapezoid below the diagonal. +*> \endverbatim +*> +*> \param[in] LDQRC +*> \verbatim +*> LDQRC is INTEGER +*> The leading dimension of the array QRC. +*> If FACT = 'P' or 'C', LDQRC >= 1. +*> If FACT = 'X', LDQRC >= max(1,M). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is REAL array. +*> If FACT = 'P' or 'C': The array is not used, +*> the array dimension is >= (1,1). +*> +*> If FACT = 'X': The array dimension is (LDX,N). +*> 1) If K = 0: +*> the M-by-N array X contains a copy of +*> the original M-by-N matrix A. +*> 2) If K > 0: +*> a) rows (1:K) of the M-by-N array X contain +*> the K-by-N factor X, where K <= N. +*> b) rows (K+1:M) of the M-by-N array X. +*> Each column of these rows contains the elements +*> whose sum of squares is the residual sum of +*> squares for the solution in each column of +*> the least squares problem. +*> min|| A - C*X ||_F for the unknown X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. +*> If FACT = 'P' or 'C', LDX >= 1. +*> If FACT = 'X', LDX >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (max(1,LWORK)). +*> +*> On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> +*> Minimal LWORK workspace general requirement. +*> LWORK >= max( 1, 3*N - 1 ) would be sufficient for all values +*> of FACT and USESD flags. +*> +*> For good performance, LWORK should generally be larger, and +*> the user should query the routine for the optimal LWORK. +*> +*> If LWORK = -1 or LIWORK =-1 then a workspace query is assumed. +*> The routine only calculates the optimal size of the WORK and +*> IWORK arrays, returns these values as the first entry of +*> the WORK and IWORK arrays respectively, and no error message +*> related to LWORK is issued by XERBLA. +*> +*> Exact minimal workspace requirements. +*> For USESD = 'N' or 'R' and for all FACT: +*> LWORK >= max( 1, 3*N - 1 ) +*> For USESD = 'C' or 'A': +*> a) If FACT = 'P' or 'C': +*> LWORK >= max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +*> b) If FACT = 'X': +*> LWORK >= max( 1, min(M,N)+N, +*> min(1,MINMNFREE)*(3*N_free-1) ) +*> where MINMNFREE = min( M_free, N_free ). +*> +*> NOTE: The decision, whether the routine uses unblocked +*> BLAS 2 or blocked BLAS 3 code is based not only on the +*> dimension LWORK of the available workspace WORK, but +*> also on: +*> 1a) column preselection stage using SGEQRF: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine SGEQRF +*> in comparison to N_sel. (For N_sel <= NX +*> or N_sel <= NB, unblocked code is used in SGEQRF.) +*> 1b) column preselection stage using SORMQR: +*> the optimal block size NB returned by ILAENV for +*> the routine SORMQR in comparison to N_sel. (For +*> N_sel <= NB, unblocked code is used in SORMQR.) +*> 2) column selection stage via criteria using SGEQRP3RK: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine SGEQRP3RK +*> in comparison to min(M,N_sel). (For +*> min(M_sub, N_free, KMAXFREE) <= NX +*> or min(M_sub, N_free, KMAXFREE) <= NB, unblocked code +*> is used in SGEQRP3RK.) +*> 3a) computation of the factor X using SGEQRF in SGELS: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine SGEQRF +*> in comparison to K. (For K <= NX or K <= NB, +*> unblocked code is used in SGEQRF inside SGELS.) +*> 3b) computation of the factor X using SORMQR in SGELS: +*> the optimal block size NB returned by ILAENV for +*> the routine SORMQR in comparison to N. (For +*> N <= NB, unblocked code is used in SORMQR +*> inside SGELS.) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (max(1,LIWORK)). +*> +*> On exit, if INFO >= 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> +*> Minimal LIWORK workspace general requirement. +*> LIWORK >= max( 1, 2*N ) would be sufficient for all values +*> of FACT and USESD flags. +*> +*> The optimal LIWORK is the same as the minimal LIWORK. +*> The user can still query the routine for the optimal LIWORK. +*> +*> If LWORK = -1 or LIWORK =-1 then a workspace query is +*> assumed. The routine only calculates the optimal size of +*> the WORK and IWORK arrays, returns these values as the first +*> entry of the WORK and IWORK arrays respectively, and no +*> error message related to LIWORK is issued by XERBLA. +*> +*> Exact minimal workspace requirements. +*> For USESD = 'N' or 'R': +*> a) If FACT = 'P': +*> LIWORK >= max( 1, N-1 ) +*> b) If FACT = 'C' or 'X': +*> LIWORK >= max( 1, 2*N ) +*> For USESD = 'C' or 'A': +*> a) If FACT = 'P': +*> LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free ) +*> b) If FACT = 'C' or 'X': +*> LIWORK >= max( 1, 2*N ) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the i-th diagonal element of the +*> triangular R factor of the QR factorization of +*> the matrix C is zero. Consequently, C does not have +*> full rank, and X cannot be computed as the least +*> squares solution to the overdetermined system C*X = A. +*> (R is stored in the array QRC.) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2026, Igor Kozachenko, James Demmel, +*> EECS Department, +*> University of California, Berkeley, USA. +*> \endverbatim +* +*> \ingroup gecxx +* +* ===================================================================== + SUBROUTINE SGECXX( FACT, USESD, M, N, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ KMAXFREE, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, + $ X, LDX, WORK, LWORK, IWORK, LIWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER FACT, USESD + INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, + $ LDX, LIWORK, LWORK, M, N + REAL ABSTOL, FNRMK, MAXC2NRMK, + $ RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. + INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), + $ JPIV( * ), SEL_DESEL_COLS( * ) + REAL A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), + $ TAU( * ), WORK( * ), X( LDX, *) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, TWO, MINUSONE + PARAMETER ( ZERO = 0.0E+0, TWO = 2.0E+0, + $ MINUSONE = -1.0E+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, RETURNC, RETURNX, + $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL + INTEGER I, IP, IINFO, ITEMP, J, JDESEL, JP, KFREE, + $ KMAXLS, KP0, LIWKMIN, LIWKOPT, LWKMIN, + $ LWKOPT, MFREE, MDESEL, MINMN, MINMNFREE, + $ MRESID, MSUB, NFREE, NDESEL, NRESID, NSEL, + $ NSUB + REAL ABSTOLFREE, EPS, MAXC2NRM, MAXC2NRMKFREE, + $ RELTOLFREE, RELMAXC2NRMKFREE, SAFMIN + +* .. External Subroutines .. + EXTERNAL SCOPY, SGELS, SGEQP3RK, SGEQRF, SLACPY, + $ SORMQR, SSWAP, XERBLA +* .. +* .. External Functions .. + LOGICAL SISNAN, LSAME + INTEGER ISAMAX, ILAENV + REAL SLAMCH, SLANGE, SNRM2 + EXTERNAL SISNAN, SLAMCH, SLANGE, SNRM2, ISAMAX, + $ ILAENV, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + MDESEL = 0 + NSEL = 0 + NDESEL = 0 + MSUB = M + NSUB = N + MFREE = MSUB + NFREE = NSUB + MINMN = MIN( M, N ) +* + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + RETURNX = LSAME( FACT, 'X' ) + RETURNC = LSAME( FACT, 'C' ) .OR. RETURNX +* + USE_DESEL_ROWS = LSAME( USESD, 'R' ) + $ .OR. LSAME( USESD, 'A' ) + USE_SEL_DESEL_COLS = LSAME( USESD, 'C' ) + $ .OR. LSAME( USESD, 'A' ) +* + IF( .NOT.( RETURNC .OR. LSAME( FACT, 'P') ) ) THEN + INFO = -1 + ELSE IF( .NOT.( USE_DESEL_ROWS .OR. USE_SEL_DESEL_COLS + $ .OR. LSAME( USESD, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE +* +* This is to check that the number of preselected columns NSEL +* cannot be larger than MSUB, which is the number of rows +* without MDESEL deselected rows. When the number of +* preselected columns NSEL is larger than MSUB, +* the factorization of all preselected NSEL columns cannot be +* completed. MSUB also will be used for LDX argument check +* later. +* + IF( USE_DESEL_ROWS ) THEN +* +* Count the number of free rows MSUB. +* + DO I = 1, M + IF( DESEL_ROWS( I ).EQ.-1 ) MDESEL = MDESEL + 1 + END DO + MSUB = M - MDESEL + MFREE = MSUB + END IF +* + IF( USE_SEL_DESEL_COLS ) THEN +* +* Count the number of preselected columns NSEL and the +* number of preselected and free columns NSUB = N - NDESEL. +* + DO J = 1, N + IF( SEL_DESEL_COLS( J ).EQ.1 ) NSEL = NSEL + 1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) NDESEL = NDESEL + 1 + END DO + NSUB = N - NDESEL + MFREE = MSUB - NSEL + NFREE = NSUB - NSEL +* + END IF + MINMNFREE = MIN( MFREE, NFREE ) +* + IF( NSEL.GT.MSUB ) THEN + INFO = -6 + ELSE IF( KMAXFREE.LT.0 ) THEN + INFO = -7 + ELSE IF( SISNAN( ABSTOL ) ) THEN + INFO = -8 + ELSE IF( SISNAN( RELTOL ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -11 +* This is a check for LDC + ELSE IF( ( RETURNC .AND. LDC.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNC .AND. LDC.LT.1 ) ) THEN + INFO = -20 +* This is a check for LDQRC + ELSE IF( ( RETURNX .AND. LDQRC.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNX .AND. LDQRC.LT.1 ) ) THEN + INFO = -22 +* This is a check for LDX + ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNX .AND. LDX.LT.1 ) ) THEN + INFO = -24 + END IF +* + END IF +* +* ================================================================== +* +* a) Test the input workspace size LWORK and LIWORK for the +* minimum size requirement LWKMIN and LIWKMIN respectively. +* b) Determine the optimal workspace sizes LWKOPT and LIWKOPT to +* be returned in WORK( 1 ) and IWORK( 1 ) respectively, +* if INFO >= 0 in cases: +* (1) LQUERY = .TRUE., +* (2) when the routine exits. +* Here, LWKMIN and LIWKMIN are the minimum workspaces required for +* unblocked code. +* + IF( INFO.EQ.0 ) THEN + IF( MINMN.EQ.0 ) THEN + LWKMIN = 1 + LWKOPT = 1 + LIWKMIN = 1 + LIWKOPT = 1 + ELSE +* +* (Real_wk_part_1) Real minimum and optimal workspace +* computation. +* LWKMIN = MAX(1, NSUB) for column 2-norm computation +* + LWKMIN = MAX( 1, NSUB ) + LWKOPT = LWKMIN +* +* (Int_wk_part_1) Integer minimum workspace computation. +* + LIWKMIN = 1 +* +* Call of SGEQRF. +* + IF( NSEL.GT.0 ) THEN +* +* (Real_wk_part_2) Real minimum workspace computation. +* LWKMIN = MAX(1, NSEL) for the call of SGEQRF. +* We can skip counting this workspace as +* LWKMIN = MAX( LWKMIN, NSEL ), since NSEL <= NSUB. +* +* Query for optimal workspace size for SGEQRF. +* + CALL SGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, + $ -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* +* Call of SORMQR. +* + IF( NFREE.GT.0 ) THEN +* +* (Real_wk_part_3) Real minimum workspace computation. +* NOTE: minimum workspace requirement for DORMQR +* LWKMIN = MAX(1, NFREE) is smaller than NSUB +* and it is smaller than LWKMIN = 3*NFREE-1 for +* DGEQP3RK. We can skip counting this workspace as +* as LWKMIN = MAX( LWKMIN, NFREE ).). +* +* Query for optimal workspace size for SORMQR. +* + CALL SORMQR( 'L', 'T', MSUB, NFREE, + $ NSEL, A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, + $ -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) + END IF +* + END IF +* +* Call of SGEQP3RK. +* + IF ( MINMNFREE.NE.0 ) THEN +* +* (Real_wk_part_4) Real minimum workspace computation. +* LWKMIN = MAX(1, 3*NFREE-1) for the call of SGEQP3RK. +* + LWKMIN = MAX( LWKMIN, 3*NFREE - 1 ) +* +* Query for optimal workspace size for SGEQP3RK. +* + CALL SGEQP3RK( MFREE, NFREE, 0, NFREE, + $ MINUSONE, MINUSONE, + $ A( 1, 1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( 1 ), TAU( 1 ), + $ WORK, -1, IWORK, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* +* (Int_wk_part_2) Integer minimum workspace computation. +* LIWKMIN = NFREE-1 for the call of SGEQP3RK. +* + LIWKMIN = MAX( LIWKMIN, NFREE-1 ) +* + IF( NSEL.NE.0 ) THEN +* +* (Int_wk_part_3) Integer minimum workspace computation. +* NFREE is for SGEQP3RK and NFREE-1 for JPIV adjustment. +* + LIWKMIN = MAX( LIWKMIN, NFREE + NFREE-1 ) + END IF +* + END IF +* + IF( RETURNC ) THEN +* +* Integer minimum workspace computation. +* (Int_wk_part_4) LIWKMIN = 2*N for applying the +* interchanges for the columns in the matrix C. +* + LIWKMIN = MAX( LIWKMIN, 2*N ) + END IF +* +* Integer optimal workspace computation. +* + LIWKOPT = LIWKMIN +* +* Call of SGELS. +* + IF( RETURNX ) THEN +* +* (Real_wk_part_5) Real minimum workspace computation. +* LWKMIN = max( 1, MINMN + max( MINMN, N ) ) = +* = max( 1, MINMN + N ) for the call of SGELS. +* + LWKMIN = MAX( LWKMIN, MINMN + N ) +* +* Query for optimal workspace size for SGELS. +* + KMAXLS = MINMN +* + CALL SGELS( 'N', M, KMAXLS, N, QRC, LDQRC, X, LDX, + $ WORK, -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK(1) ) ) +* + END IF +* +* End of ELSE for IF( MINMN.EQ.0 ) +* + END IF +* + IF( ( LWORK.LT.LWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -26 + ELSE IF( ( LIWORK.LT.LIWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -28 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = REAL( LWKOPT ) + IWORK( 1 ) = LIWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SGECXX', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* ================================================================== +* +* Quick return if possible for: +* a) M = 0 or N = 0. There is no matrix A(1:M,1:N). +* b) MSUB = 0 or NSUB = 0. There is no matrix A_sub(1:MSUB,1:NSUB). +* NOTE: min( M, N) = 0 implies min( MSUB, NSUB) = 0. +* We need to return correct values for all scalar output parameters, +* (including WORK(1) and IWORK(1), which are set above). +* + IF( MIN( MSUB, NSUB ).EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + FNRMK = ZERO + RETURN + END IF +* +* ================================================================== +* + K = 0 +* +* If we need to return factor X, copy the original untouched matrix +* A into the array X. +* + IF( RETURNX ) THEN + CALL SLACPY( 'F', M, N, A, LDA, X, LDX ) + END IF +* +* If we need to return the factor C, copy the original matrix A +* into the array C, only if do not return the factor X. In this +* case, we need to choose the columns of the matrix A in the array C +* in place, otherwise we can copy the columns of the matrix A from +* the array X. +* + IF( RETURNC .AND. .NOT. RETURNX ) THEN + CALL SLACPY( 'F', M, N, A, LDA, C, LDC ) + END IF +* +* ================================================================== +* Permute the deselected rows to the bottom of the matrix A. +* 1) The initial order of included rows in their block is preserved. +* 2) The initial order of deselected rows in their block is not +* preserved. +* ================================================================== +* +* I is an index of DESEL_ROWS array and a row index of +* the matrix A. MSUB is the number of processed included rows, which +* is also an index pointer to the last included row in the matrix A. +* We can think of I as a row source index, and MSUB as a destination +* index for moving an included row in the matrix A. +* +* ( We start with MSUB = 0. We loop over index I in (1:M), and +* for each position I in DESEL_ROWS array, we check if the row at +* the position I in the matrix A is an included row (not -1 value). +* If it is an included row, we increment MSUB pointer, otherwise +* we do not change MSUB index pointer. Then, we bring this included +* row from the index I in the matrix A into smaller (or same) +* MSUB index in the matrix A. If I = MSUB, then the included row +* is already in place. Due to row swap, the deselected row +* at MSUB index will move into I index in the matrix A. In this way, +* we move all the included rows to the top matrix block preserving +* their initial order within the included block. The initial order +* of deselected rows will not be preserved within their block. +* + IF( USE_DESEL_ROWS ) THEN +* + MSUB = 0 + DO I = 1, M, 1 +* +* Initialize the row pivot array IPIV. + IPIV( I ) = I +* +* The row at the index I is an included row and should be +* moved to the top of the matrix A. +* + IF( DESEL_ROWS( I ).NE.-1 ) THEN + MSUB = MSUB + 1 +* +* This is a check whether the included row is +* on the included place already. +* + IF( I.NE.MSUB ) THEN +* +* Here, we swap A(I,1:N) into A(MSUB,1:N). +* + CALL SSWAP( N, A( I, 1 ), LDA, A( MSUB, 1 ), LDA ) +* +* Save the interchange. +* + IPIV( I ) = IPIV( MSUB ) + IPIV( MSUB ) = I + DESEL_ROWS( MSUB ) = DESEL_ROWS( I ) + DESEL_ROWS( I ) = -1 + END IF + END IF +* + END DO +* + ELSE +* +* We do not use the row deselection DESEL_ROWS array. +* Initialize the row pivot array IPIV. +* NOTE: MSUB=M has default value, +* which is set at the beginning of the routine, before argument +* checks. +* + DO I = 1, M, 1 + IPIV( I ) = I + END DO + END IF +* +* ================================================================== +* Permute the preselected columns to the left and deselected +* columns to the right of the matrix A. +* 1) The order of preselected columns is preserved. +* 2) The order of free columns is not preserved. +* 3) The order of deselected columns is not preserved. +* ================================================================== +* +* J is the index of SEL_DESEL_COLS array and column J +* of the matrix A. +* + IF( USE_SEL_DESEL_COLS ) THEN +* +* Column selection. +* NSEL is the number of selected columns, also the pointer to +* the last selected column. +* + NSEL = 0 + DO J = 1, N, 1 +* +* Initialize column pivot array JPIV. + JPIV( J ) = J +* + IF( SEL_DESEL_COLS( J ).EQ.1 ) THEN + NSEL = NSEL + 1 +* +* This is the check whether the selected column is +* on the selected place already. +* + IF( J.NE.NSEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,NSEL) +* + CALL SSWAP( M, A( 1, J ), 1, A( 1, NSEL ), 1 ) + JPIV( J ) = JPIV( NSEL ) + JPIV( NSEL ) = J + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( NSEL ) + SEL_DESEL_COLS( NSEL ) = 1 + END IF + END IF + END DO +* +* Column deselection. +* JDESEL the pointer to the last +* deselected column counting right-to-left. +* + JDESEL = N+1 + DO J = N, NSEL+1, -1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) THEN + JDESEL = JDESEL - 1 +* +* This is the check whether the deselected column is +* on the deselected place already. +* + IF( J.NE.JDESEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,JDESEL) +* + CALL SSWAP( M, A( 1, J ), 1, A( 1, JDESEL ), 1 ) + ITEMP = JPIV( J ) + JPIV( J ) = JPIV( JDESEL ) + JPIV( JDESEL ) = ITEMP + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( JDESEL ) + SEL_DESEL_COLS( JDESEL ) = -1 + END IF + END IF + END DO +* + NSUB = JDESEL - 1 +* + ELSE +* +* We do not use the column selection deselection +* SEL_DESEL_COLS array. +* Initialize column pivot array JPIV. +* NOTE: NSUB=N has default value, +* which is set at the beginning of the routine, before argument +* checks. +* + DO J = 1, N, 1 + JPIV( J ) = J + END DO +* + END IF +* +* ================================================================== +* Compute the complete column 2-norms of the submatrix +* A_sub = A(1:MSUB, 1:NSUB) and store them in WORK(1:NSUB). +* + DO J = 1, NSUB + WORK( J ) = SNRM2( MSUB, A( 1, J ), 1 ) + END DO +* +* Compute the column index of the maximum column 2-norm and +* the maximum column 2-norm itself for the submatrix +* A_sub = A(1:MSUB, 1:NSUB). +* + KP0 = ISAMAX( NSUB, WORK( 1 ), 1 ) + MAXC2NRM = WORK( KP0 ) +* +* ================================================================== +* Process preselected columns +* +* Compute the QR factorization of NSEL preselected columns (1:NSEL) +* in the submatrix A_sub = A(1:MSUB, 1:NSUB) and update +* remaining NFREE free columns (NSEL+1:NSUB). +* NSUB = NSEL + NFREE +* + IF( NSEL.GT.0 ) THEN +* +* Case (a): MSUB < NSEL. +* +* This is handled at the argument check stage in the +* beginning of the routine. When the number of preselected +* columns is larger than MSUB, hence the factorization of +* all NSEL columns cannot be completed. Return from the +* routine with the error of COL_SEL_DESEL parameter. +* +* Case (b): MSUB = NSEL. +* Case (c-1): MSUB > NSEL and NSEL = NSUB. +* +* For cases (b) and (c-1), there will be no residual +* submatrix after factorization of NSEL columns +* at step K = NSEL: +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). +* +* Case (c-2): MSUB > NSEL and NSEL < NSUB. +* +* For Case (c-2) is a submatrix residual at step K=NSEL +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) +* + CALL SGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, LWORK, IINFO ) +* +* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) +* + IF( NFREE.GT.0 ) THEN +* +* This is only for case (c-2) ('L' = Left, 'T' = Transpose) +* + CALL SORMQR( 'L', 'T', MSUB, NFREE, NSEL, + $ A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, + $ LWORK, IINFO ) + END IF +* + K = K + NSEL +* +* End of IF(NSEL.GT.0) +* + END IF +* +* ================================================================== +* + KFREE = 0 +* + IF( MINMNFREE.NE.0 ) THEN +* +* Factorize NFREE free columns of +* A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), +* KFREE is the number of columns that were actually factorized +* among NFREE columns. +* +* ================================================================== +* + EPS = SLAMCH('Epsilon') +* + USETOL = .FALSE. +* +* Adjust ABSTOL only if nonnegative. Negative value means disabled. +* We need to keep negative value for later use in criterion +* check. +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = SLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + USETOL = .TRUE. + END IF +* +* Adjust RELTOL only if nonnegative. Negative value means disabled. +* We need to keep negative value for later use in criterion +* check. +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + USETOL = .TRUE. + END IF +* +* ================================================================== +* +* Disable RELTOLFREE when calling SGEQP3RK for free columns +* factorization, since SGEQP3RK expects RELTOLFREE with respect +* to the residual matrix A_sub_resid(NSEL), not the whole +* original matrix A. We can use RELTOL criterion by passing it +* to ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that +* the negative values of ABSTOL and RELTOL are propagated +* to ABSTOLFREE and RELTOLFREE, since negative values means +* that the criterion is disabled. +* + IF( USETOL ) THEN + ABSTOLFREE = MAX( ABSTOL, RELTOL * MAXC2NRM ) + ELSE + ABSTOLFREE = MINUSONE + END IF + RELTOLFREE = MINUSONE +* +* Save JPIV(NSEL+1:NSUB) into WORK(NFREE+1:2*NFREE-1) +* + IF( NSEL.NE.0 ) THEN + DO J = 1, NFREE, 1 + IWORK( NFREE + J ) = JPIV( NSEL+J ) + END DO + END IF +* + CALL SGEQP3RK( MFREE, NFREE, 0, KMAXFREE, + $ ABSTOLFREE, RELTOLFREE, + $ A( NSEL+1, NSEL+1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( NSEL+1 ), + $ TAU( NSEL+1 ), WORK, LWORK, IWORK, IINFO ) +* +* Adjust JPIV +* + IF( NSEL.NE.0 ) THEN + DO J = 1, NFREE, 1 + JPIV( NSEL+J ) = IWORK( NFREE + JPIV( NSEL+J ) ) + END DO + END IF +* +* 1) Adjust the return value for the number of factorized +* columns K for the whole submatrix A_sub. +* 2) MAXC2NRMK is returned transparently without change +* as MAXC2NRMKFREE is returned from SGEQP3RK. +* 3) Adjust the return value RELMAXC2NRMK for the whole +* submatrix A_sub. We do not use RELMAXC2NRMKFREE +* returned from SGEQP3RK. +* + K = K + KFREE + MAXC2NRMK = MAXC2NRMKFREE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + ELSE +* +* Set norms to zero +* + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + END IF +* +* Now, MRESID and NRESID is the number of rows and columns +* respectively in A_free_resid = A(K+1:MSUB,K+1:NSUB). +* + MRESID = MFREE-KFREE + NRESID = NFREE-KFREE +* + IF( MIN( MRESID, NRESID ).NE.0 ) THEN + FNRMK = SLANGE( 'F', MRESID, NRESID, A( K+1, K+1 ), + $ LDA, WORK ) + ELSE + FNRMK = ZERO + END IF +* +* ================================================================== +* +* Return the matrix C. +* + IF( RETURNC .AND. K.GT.0 ) THEN +* + IF( RETURNX ) THEN +* +* Copy the selected K columns of the original matrix A (that was +* saved into the array X) into the array C according to +* the pivot array JPIV. If we return X, then the matrix A is +* saved in the array X, and it is faster to copy into C than +* doing column permutation in place, as it is the ELSE case. +* + DO J = 1, K, 1 + CALL SCOPY( M, X( 1, JPIV( J ) ), 1, C( 1, J ), 1 ) + END DO +* + ELSE +* +* Swap the columns of the original matrix A copied into +* the array C in place. +* +* The original M-by-N matrix A was copied into the array C at +* the beginning of the routine, if RETURNC = .TRUE.. + +* Apply the column permutation matrix P stored in JPIV(1:K) +* to the columns 1:K in the M-by-N array C in place. +* After column interchanges, the first K columns of C should +* be the same as the first K columns of A*P, i.e. +* (A*P)(1:M,1:K) = C(1:M,1:K). The complexity of this algorithm +* is min(K,N-1). +* +* Index I is the original column index in the +* array C before interchanges. +* J is the current column index of the original column I at +* each step of interchanges. +* +* Auxiliary array IWORK(1:N) stores the inverse P_inv(J) +* of the current column permutation matrix P(J) at each +* column interchange step J only for the array +* values >= J:N. +* C_prev = P_inv(J) * C_next. +* Each IWORK(I) contains JJ corresponding to I +* Initialize IWORK(1:N) as (1:N). +* + DO I = 1, N, 1 + IWORK( I ) = I + END DO +* +* Auxiliary array IWORK(N+1:2N) stores the current column +* permutation matrix P_(J) at each column interchange step J +* only for the array index >= J:N. +* C_prev * P_(J) = C_next. +* Each IWORK(N+JJ) contains I corresponding to JJ. +* Initialize IWORK(N+1:2*N) as (1:N). +* + DO J = 1, N, 1 + IWORK( N + J ) = J + END DO +* +* Loop over the columns J = ( 1:min( K, N-1 ) ) in C. +* + DO J = 1, MIN( K, N-1 ), 1 +* +* IP is the original pivot column, i.e. is the original +* column that should be placed in the current column index +* J in the array C. +* + IP = JPIV( J ) +* +* I is the original column that is +* currently in the column index J in the array C after +* previous column interchanges. +* + I = IWORK( N+J ) +* + IF( I.NE.IP ) THEN +* +* JP is the current index of the original pivot +* column IP in the array C after previous column +* interchanges. +* + JP = IWORK( IP ) + +* Swap the original pivot column IP = JPIV( J ), +* at the current pivot index JP = IWORK( IP ) into +* index J. +* + CALL SSWAP( M, C( 1, J ), 1, C( 1, JP ), 1 ) +* +* Update the array IWORK(1:N) for the original column +* I that was swapped with IP. +* + IWORK( I ) = IWORK( IP ) +* +* Update the array IWORK(N+1:2*N) for the current column +* index JP that was swapped with the current column +* index J. +* + IWORK( N + JP ) = IWORK( N + J ) +* + END IF +* + END DO +* +* End of ELSE( RETURNX ) +* + END IF +* +* End of IF( RETURNC .AND. K.GT.0 ) +* + END IF +* +* ================================================================== +* +* Return the matrix X. +* + IF( RETURNX .AND. K.GT.0 ) THEN +* +* We need to use C and A to compute X = pseudoinv(C) * A, as +* the linear least squares solution to the overdetermined system +* C*X = A. We use LLS routine that uses the QR factorization. For +* that purpose, we store the matrix C into the array QRC. +* The matrix A was copied into the array X at the beginning +* of the routine. +* + CALL SLACPY( 'F', M, K, C, LDC, QRC, LDQRC ) +* + CALL SGELS( 'N', M, K, N, QRC, LDQRC, X, LDX, + $ WORK, LWORK, IINFO ) + INFO = IINFO +* + END IF +* + WORK( 1 ) = REAL( LWKOPT ) + IWORK( 1 ) = LIWKOPT +* +* End of SGECXX +* + END diff --git a/lapack-netlib/SRC/zgecxx.c b/lapack-netlib/SRC/zgecxx.c new file mode 100644 index 0000000000..9b688d7506 --- /dev/null +++ b/lapack-netlib/SRC/zgecxx.c @@ -0,0 +1,1458 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +#ifdef _MSC_VER +static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;} +static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} +static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;} +static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} +#else +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#endif +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#ifdef _MSC_VER +#define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);} +#define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/Cd(b)._Val[1]);} +#else +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#endif +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimagf(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) {ceil(w)} +#define myhuge_(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#ifdef _MSC_VER +static _Fcomplex cpow_ui(complex x, integer n) { + complex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; + for(u = n; ; ) { + if(u & 01) pow.r *= x.r, pow.i *= x.i; + if(u >>= 1) x.r *= x.r, x.i *= x.i; + else break; + } + } + _Fcomplex p={pow.r, pow.i}; + return p; +} +#else +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +#ifdef _MSC_VER +static _Dcomplex zpow_ui(_Dcomplex x, integer n) { + _Dcomplex pow={1.0,0.0}; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; + for(u = n; ; ) { + if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; + if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; + else break; + } + } + _Dcomplex p = {pow._Val[0], pow._Val[1]}; + return p; +} +#else +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +#endif +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; +#ifdef _MSC_VER + _Fcomplex zdotc = {0.0, 0.0}; + if (incx == 1 && incy == 1) { + for (i=0;i msub) { + *info = -6; + } else if (*kmaxfree < 0) { + *info = -7; + } else if (disnan_(abstol)) { + *info = -8; + } else if (disnan_(reltol)) { + *info = -9; + } else if (*lda < f2cmax(1,*m)) { + *info = -11; +/* This is a check for LDC */ + } else if (returnc && *ldc < f2cmax(1,*m) || ! returnc && *ldc < 1) { + *info = -20; +/* This is a check for LDQRC */ + } else if (returnx && *ldqrc < f2cmax(1,*m) || ! returnx && *ldqrc < 1) { + *info = -22; +/* This is a check for LDX */ + } else if (returnx && *ldx < f2cmax(1,*m) || ! returnx && *ldx < 1) { + *info = -24; + } + + } + +/* ================================================================== */ + +/* a) Test the input workspace size LWORK, LRWORK, LIWORK for the */ +/* minimum size requirement LWKMIN, LRWKMIN, LIWKMIN */ +/* respectively. */ +/* b) Determine the optimal workspace sizes LWKOPT, LRWKOPT, */ +/* and LIWKOPT to be returned in */ +/* WORK( 1 ), RWORK( 1 ) and IWORK( 1 ) respectively, */ +/* if INFO >= 0 in cases: */ +/* (1) LQUERY = .TRUE., */ +/* (2) when the routine exits. */ +/* Here, LWKMIN, LRWKMIN and LIWKMIN are the minimum workspaces */ +/* required for unblocked code. */ + + if (*info == 0) { + if (minmn == 0) { + lwkmin = 1; + lwkopt = 1; + lrwkmin = 1; + lrwkopt = 1; + liwkmin = 1; + liwkopt = 1; + } else { + +/* (Complex_wk_part_1) Complex minimum and optimal workspace */ +/* computation. */ + + lwkmin = 1; + lwkopt = lwkmin; + +/* (Real_wk_part_1) Real minimum workspace computation. */ +/* LRWKMIN = MAX(1, NSUB) for column 2-norm computation */ + + lrwkmin = f2cmax(1,nsub); + +/* (Int_wk_part_1) Integer minimum workspace computation. */ + + liwkmin = 1; + +/* Call of ZGEQRF. */ + + if (nsel > 0) { + +/* (Complex_wk_part_2) Complex minimum workspace */ +/* computation. */ + + lwkmin = f2cmax(lwkmin,nsel); + +/* Query for optimal workspace size for ZGEQRF. */ + + zgeqrf_(&msub, &nsel, &a[a_offset], lda, &tau[1], &work[1], & + c_n1, &iinfo); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[1].r; + lwkopt = f2cmax(i__1,i__2); + +/* Call of ZUNMQR. */ + + if (nfree > 0) { + +/* (Complex_wk_part_3) Complex minimum workspace */ +/* computation. */ + + lwkmin = f2cmax(lwkmin,nfree); + +/* Query for optimal workspace size for ZUNMQR. */ + + zunmqr_("L", "C", &msub, &nfree, &nsel, &a[a_offset], lda, + &tau[1], &a[(nsel + 1) * a_dim1 + 1], lda, &work[ + 1], &c_n1, &iinfo); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[1].r; + lwkopt = f2cmax(i__1,i__2); + } + + } + +/* Call of ZGEQP3RK. */ + + if (minmnfree != 0) { + +/* (Complex_wk_part_4) Complex minimum workspace */ +/* computation. */ +/* LWKMIN = MAX(1, NFREE-1) for the call of ZGEQP3RK. */ + +/* Computing MAX */ + i__1 = lwkmin, i__2 = nfree - 1; + lwkmin = f2cmax(i__1,i__2); + +/* Query for optimal workspace size for ZGEQP3RK. */ + + zgeqp3rk_(&mfree, &nfree, &c__0, &nfree, &c_b15, &c_b15, &a[ + a_dim1 + 1], lda, &kfree, &maxc2nrmkfree, & + relmaxc2nrmkfree, &jpiv[1], &tau[1], &work[1], &c_n1, + &rwork[1], &iwork[1], &iinfo); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[1].r; + lwkopt = f2cmax(i__1,i__2); + +/* (Real_wk_part_2) Real minimum workspace computation. */ +/* LRWKMIN = MAX(1, 2*NFREE) for the call of ZGEQP3RK. */ + +/* Computing MAX */ + i__1 = lrwkmin, i__2 = nfree << 1; + lrwkmin = f2cmax(i__1,i__2); + +/* (Int_wk_part_2) Integer minimum workspace computation. */ +/* LIWKMIN = NFREE-1 for the call of ZGEQP3RK. */ + +/* Computing MAX */ + i__1 = liwkmin, i__2 = nfree - 1; + liwkmin = f2cmax(i__1,i__2); + + if (nsel != 0) { + +/* (Int_wk_part_3) Integer minimum workspace computation. */ +/* NFREE is for ZGEQP3RK and NFREE-1 for JPIV adjustment. */ + +/* Computing MAX */ + i__1 = liwkmin, i__2 = nfree + nfree - 1; + liwkmin = f2cmax(i__1,i__2); + } + + } + + if (returnc) { + +/* Integer minimum workspace computation. */ +/* (Int_wk_part_4) LIWKMIN = 2*N for applying the */ +/* interchanges for the columns in the matrix C. */ + +/* Computing MAX */ + i__1 = liwkmin, i__2 = *n << 1; + liwkmin = f2cmax(i__1,i__2); + } + +/* Real and Integer optimal workspace computation. */ + + lrwkopt = lrwkmin; + liwkopt = liwkmin; + +/* Call of ZGELS. */ + + if (returnx) { + +/* (Complex_wk_part_5) Complex minimum workspace computation. */ +/* LWKMIN = f2cmax( 1, MINMN + f2cmax( MINMN, N ) ) = */ +/* = f2cmax( 1, MINMN + N ) for the call of ZGELS. */ + +/* Computing MAX */ + i__1 = lwkmin, i__2 = minmn + *n; + lwkmin = f2cmax(i__1,i__2); + +/* Query for optimal workspace size for ZGELS. */ + + kmaxls = minmn; + + zgels_("N", m, &kmaxls, n, &qrc[qrc_offset], ldqrc, &x[ + x_offset], ldx, &work[1], &c_n1, &iinfo); +/* Computing MAX */ + i__1 = lwkopt, i__2 = (integer) work[1].r; + lwkopt = f2cmax(i__1,i__2); + + } + +/* End of ELSE for IF( MINMN.EQ.0 ) */ + + } + + if (*lwork < lwkmin && ! lquery) { + *info = -26; + } else if (*lrwork < lrwkmin && ! lquery) { + *info = -28; + } else if (*liwork < liwkmin && ! lquery) { + *info = -30; + } + } + + if (*info == 0) { + z__1.r = (doublereal) lwkopt, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + rwork[1] = (doublereal) lrwkopt; + iwork[1] = liwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGECXX", &i__1); + return 0; + } else if (lquery) { + return 0; + } + +/* ================================================================== */ + +/* Quick return if possible for: */ +/* a) M = 0 or N = 0. There is no matrix A(1:M,1:N). */ +/* b) MSUB = 0 or NSUB = 0. There is no matrix A_sub(1:MSUB,1:NSUB). */ +/* NOTE: f2cmin( M, N) = 0 implies f2cmin( MSUB, NSUB) = 0. */ +/* We need to return correct values for all scalar output parameters, */ +/* (including WORK(1) and IWORK(1), which are set above). */ + + if (f2cmin(msub,nsub) == 0) { + *k = 0; + *maxc2nrmk = 0.; + *relmaxc2nrmk = 0.; + *fnrmk = 0.; + return 0; + } + +/* ================================================================== */ + + *k = 0; + +/* If we need to return factor X, copy the original untouched matrix */ +/* A into the array X. */ + + if (returnx) { + zlacpy_("F", m, n, &a[a_offset], lda, &x[x_offset], ldx); + } + +/* If we need to return the factor C, copy the original matrix A */ +/* into the array C, only if do not return the factor X. In this */ +/* case, we need to choose the columns of the matrix A in the array C */ +/* in place, otherwise we can copy the columns of the matrix A from */ +/* the array X. */ + + if (returnc && ! returnx) { + zlacpy_("F", m, n, &a[a_offset], lda, &c__[c_offset], ldc); + } + +/* ================================================================== */ +/* Permute the deselected rows to the bottom of the matrix A. */ +/* 1) The initial order of included rows in their block is preserved. */ +/* 2) The initial order of deselected rows in their block is not */ +/* preserved. */ +/* ================================================================== */ + +/* I is an index of DESEL_ROWS array and a row index of */ +/* the matrix A. MSUB is the number of processed included rows, which */ +/* is also an index pointer to the last included row in the matrix A. */ +/* We can think of I as a row source index, and MSUB as a destination */ +/* index for moving an included row in the matrix A. */ + +/* ( We start with MSUB = 0. We loop over index I in (1:M), and */ +/* for each position I in DESEL_ROWS array, we check if the row at */ +/* the position I in the matrix A is an included row (not -1 value). */ +/* If it is an included row, we increment MSUB pointer, otherwise */ +/* we do not change MSUB index pointer. Then, we bring this included */ +/* row from the index I in the matrix A into smaller (or same) */ +/* MSUB index in the matrix A. If I = MSUB, then the included row */ +/* is already in place. Due to row swap, the deselected row */ +/* at MSUB index will move into I index in the matrix A. In this way, */ +/* we move all the included rows to the top matrix block preserving */ +/* their initial order within the included block. The initial order */ +/* of deselected rows will not be preserved within their block. */ + + if (use_desel_rows__) { + + msub = 0; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Initialize the row pivot array IPIV. */ + ipiv[i__] = i__; + +/* The row at the index I is an included row and should be */ +/* moved to the top of the matrix A. */ + + if (desel_rows__[i__] != -1) { + ++msub; + +/* This is a check whether the included row is */ +/* on the included place already. */ + + if (i__ != msub) { + +/* Here, we swap A(I,1:N) into A(MSUB,1:N). */ + + zswap_(n, &a[i__ + a_dim1], lda, &a[msub + a_dim1], lda); + +/* Save the interchange. */ + + ipiv[i__] = ipiv[msub]; + ipiv[msub] = i__; + desel_rows__[msub] = desel_rows__[i__]; + desel_rows__[i__] = -1; + } + } + + } + + } else { + +/* We do not use the row deselection DESEL_ROWS array. */ +/* Initialize the row pivot array IPIV. */ +/* NOTE: MSUB=M has default value, */ +/* which is set at the beginning of the routine, before argument */ +/* checks. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + ipiv[i__] = i__; + } + } + +/* ================================================================== */ +/* Permute the preselected columns to the left and deselected */ +/* columns to the right of the matrix A. */ +/* 1) The order of preselected columns is preserved. */ +/* 2) The order of free columns is not preserved. */ +/* 3) The order of deselected columns is not preserved. */ +/* ================================================================== */ + +/* J is the index of SEL_DESEL_COLS array and column J */ +/* of the matrix A. */ + + if (use_sel_desel_cols__) { + +/* Column selection. */ +/* NSEL is the number of selected columns, also the pointer to */ +/* the last selected column. */ + + nsel = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + +/* Initialize column pivot array JPIV. */ + jpiv[j] = j; + + if (sel_desel_cols__[j] == 1) { + ++nsel; + +/* This is the check whether the selected column is */ +/* on the selected place already. */ + + if (j != nsel) { + +/* Here, we swap the column A(1:M,J) into A(1:M,NSEL) */ + + zswap_(m, &a[j * a_dim1 + 1], &c__1, &a[nsel * a_dim1 + 1] + , &c__1); + jpiv[j] = jpiv[nsel]; + jpiv[nsel] = j; + sel_desel_cols__[j] = sel_desel_cols__[nsel]; + sel_desel_cols__[nsel] = 1; + } + } + } + +/* Column deselection. */ +/* JDESEL the pointer to the last */ +/* deselected column counting right-to-left. */ + + jdesel = *n + 1; + i__1 = nsel + 1; + for (j = *n; j >= i__1; --j) { + if (sel_desel_cols__[j] == -1) { + --jdesel; + +/* This is the check whether the deselected column is */ +/* on the deselected place already. */ + + if (j != jdesel) { + +/* Here, we swap the column A(1:M,J) into A(1:M,JDESEL) */ + + zswap_(m, &a[j * a_dim1 + 1], &c__1, &a[jdesel * a_dim1 + + 1], &c__1); + itemp = jpiv[j]; + jpiv[j] = jpiv[jdesel]; + jpiv[jdesel] = itemp; + sel_desel_cols__[j] = sel_desel_cols__[jdesel]; + sel_desel_cols__[jdesel] = -1; + } + } + } + + nsub = jdesel - 1; + + } else { + +/* We do not use the column selection deselection */ +/* SEL_DESEL_COLS array. */ +/* Initialize column pivot array JPIV. */ +/* NOTE: NSUB=N has default value, */ +/* which is set at the beginning of the routine, before argument */ +/* checks. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jpiv[j] = j; + } + + } + +/* ================================================================== */ +/* Compute the complete column 2-norms of the submatrix */ +/* A_sub = A(1:MSUB, 1:NSUB) and store them in WORK(1:NSUB). */ + + i__1 = nsub; + for (j = 1; j <= i__1; ++j) { + rwork[j] = dznrm2_(&msub, &a[j * a_dim1 + 1], &c__1); + } + +/* Compute the column index of the maximum column 2-norm and */ +/* the maximum column 2-norm itself for the submatrix */ +/* A_sub = A(1:MSUB, 1:NSUB). */ + + kp0 = izamax_(&nsub, &work[1], &c__1); + maxc2nrm = rwork[kp0]; + +/* ================================================================== */ +/* Process preselected columns */ + +/* Compute the QR factorization of NSEL preselected columns (1:NSEL) */ +/* in the submatrix A_sub = A(1:MSUB, 1:NSUB) and update */ +/* remaining NFREE free columns (NSEL+1:NSUB). */ +/* NSUB = NSEL + NFREE */ + + if (nsel > 0) { + +/* Case (a): MSUB < NSEL. */ + +/* This is handled at the argument check stage in the */ +/* beginning of the routine. When the number of preselected */ +/* columns is larger than MSUB, hence the factorization of */ +/* all NSEL columns cannot be completed. Return from the */ +/* routine with the error of COL_SEL_DESEL parameter. */ + +/* Case (b): MSUB = NSEL. */ +/* Case (c-1): MSUB > NSEL and NSEL = NSUB. */ + +/* For cases (b) and (c-1), there will be no residual */ +/* submatrix after factorization of NSEL columns */ +/* at step K = NSEL: */ +/* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). */ + +/* Case (c-2): MSUB > NSEL and NSEL < NSUB. */ + +/* For Case (c-2) is a submatrix residual at step K=NSEL */ +/* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) */ + + zgeqrf_(&msub, &nsel, &a[a_offset], lda, &tau[1], &work[1], lwork, & + iinfo); + +/* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) */ + + if (nfree > 0) { + +/* This is only for case (c-2) ('L' = Left, 'T' = Transpose) */ + + zunmqr_("L", "C", &msub, &nfree, &nsel, &a[a_offset], lda, &tau[1] + , &a[(nsel + 1) * a_dim1 + 1], lda, &work[1], lwork, & + iinfo); + } + + *k += nsel; + +/* End of IF(NSEL.GT.0) */ + + } + +/* ================================================================== */ + + kfree = 0; + + if (minmnfree != 0) { + +/* Factorize NFREE free columns of */ +/* A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), */ +/* KFREE is the number of columns that were actually factorized */ +/* among NFREE columns. */ + +/* ================================================================== */ + + eps = dlamch_("Epsilon"); + + usetol = FALSE_; + +/* Adjust ABSTOL only if nonnegative. Negative value means disabled. */ +/* We need to keep negative value for later use in criterion */ +/* check. */ + + if (*abstol >= 0.) { + safmin = dlamch_("Safe minimum"); +/* Computing MAX */ + d__1 = *abstol, d__2 = safmin * 2.; + *abstol = f2cmax(d__1,d__2); + usetol = TRUE_; + } + +/* Adjust RELTOL only if nonnegative. Negative value means disabled. */ +/* We need to keep negative value for later use in criterion */ +/* check. */ + + if (*reltol >= 0.) { + *reltol = f2cmax(*reltol,eps); + usetol = TRUE_; + } + +/* ================================================================== */ + +/* Disable RELTOLFREE when calling ZGEQP3RK for free columns */ +/* factorization, since ZGEQP3RK expects RELTOLFREE with respect */ +/* to the residual matrix A_sub_resid(NSEL), not the whole */ +/* original matrix A. We can use RELTOL criterion by passing it */ +/* to ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that */ +/* the negative values of ABSTOL and RELTOL are propagated */ +/* to ABSTOLFREE and RELTOLFREE, since negative values means */ +/* that the criterion is disabled. */ + + if (usetol) { +/* Computing MAX */ + d__1 = *abstol, d__2 = *reltol * maxc2nrm; + abstolfree = f2cmax(d__1,d__2); + } else { + abstolfree = -1.; + } + reltolfree = -1.; + +/* Save JPIV(NSEL+1:NSUB) into WORK(NFREE+1:2*NFREE-1) */ + + if (nsel != 0) { + i__1 = nfree; + for (j = 1; j <= i__1; ++j) { + iwork[nfree + j] = jpiv[nsel + j]; + } + } + + zgeqp3rk_(&mfree, &nfree, &c__0, kmaxfree, &abstolfree, &reltolfree, & + a[nsel + 1 + (nsel + 1) * a_dim1], lda, &kfree, & + maxc2nrmkfree, &relmaxc2nrmkfree, &jpiv[nsel + 1], &tau[nsel + + 1], &work[1], lwork, &rwork[1], &iwork[1], &iinfo); + +/* Adjust JPIV */ + + if (nsel != 0) { + i__1 = nfree; + for (j = 1; j <= i__1; ++j) { + jpiv[nsel + j] = iwork[nfree + jpiv[nsel + j]]; + } + } + +/* 1) Adjust the return value for the number of factorized */ +/* columns K for the whole submatrix A_sub. */ +/* 2) MAXC2NRMK is returned transparently without change */ +/* as MAXC2NRMKFREE is returned from ZGEQP3RK. */ +/* 3) Adjust the return value RELMAXC2NRMK for the whole */ +/* submatrix A_sub. We do not use RELMAXC2NRMKFREE */ +/* returned from ZGEQP3RK. */ + + *k += kfree; + *maxc2nrmk = maxc2nrmkfree; + *relmaxc2nrmk = *maxc2nrmk / maxc2nrm; + + } else { + +/* Set norms to zero */ + + *maxc2nrmk = 0.; + *relmaxc2nrmk = 0.; + + } + +/* Now, MRESID and NRESID is the number of rows and columns */ +/* respectively in A_free_resid = A(K+1:MSUB,K+1:NSUB). */ + + mresid = mfree - kfree; + nresid = nfree - kfree; + + if (f2cmin(mresid,nresid) != 0) { + *fnrmk = zlange_("F", &mresid, &nresid, &a[*k + 1 + (*k + 1) * a_dim1] + , lda, &work[1]); + } else { + *fnrmk = 0.; + } + +/* ================================================================== */ + +/* Return the matrix C. */ + + if (returnc && *k > 0) { + + if (returnx) { + +/* Copy the selected K columns of the original matrix A (that was */ +/* saved into the array X) into the array C according to */ +/* the pivot array JPIV. If we return X, then the matrix A is */ +/* saved in the array X, and it is faster to copy into C than */ +/* doing column permutation in place, as it is the ELSE case. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(m, &x[jpiv[j] * x_dim1 + 1], &c__1, &c__[j * c_dim1 + + 1], &c__1); + } + + } else { + +/* Swap the columns of the original matrix A copied into */ +/* the array C in place. */ + +/* The original M-by-N matrix A was copied into the array C at */ +/* the beginning of the routine, if RETURNC = .TRUE.. */ +/* Apply the column permutation matrix P stored in JPIV(1:K) */ +/* to the columns 1:K in the M-by-N array C in place. */ +/* After column interchanges, the first K columns of C should */ +/* be the same as the first K columns of A*P, i.e. */ +/* (A*P)(1:M,1:K) = C(1:M,1:K). The complexity of this algorithm */ +/* is f2cmin(K,N-1). */ + +/* Index I is the original column index in the */ +/* array C before interchanges. */ +/* J is the current column index of the original column I at */ +/* each step of interchanges. */ + +/* Auxiliary array IWORK(1:N) stores the inverse P_inv(J) */ +/* of the current column permutation matrix P(J) at each */ +/* column interchange step J only for the array */ +/* values >= J:N. */ +/* C_prev = P_inv(J) * C_next. */ +/* Each IWORK(I) contains JJ corresponding to I */ +/* Initialize IWORK(1:N) as (1:N). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = i__; + } + +/* Auxiliary array IWORK(N+1:2N) stores the current column */ +/* permutation matrix P_(J) at each column interchange step J */ +/* only for the array index >= J:N. */ +/* C_prev * P_(J) = C_next. */ +/* Each IWORK(N+JJ) contains I corresponding to JJ. */ +/* Initialize IWORK(N+1:2*N) as (1:N). */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + iwork[*n + j] = j; + } + +/* Loop over the columns J = ( 1:f2cmin( K, N-1 ) ) in C. */ + +/* Computing MIN */ + i__2 = *k, i__3 = *n - 1; + i__1 = f2cmin(i__2,i__3); + for (j = 1; j <= i__1; ++j) { + +/* IP is the original pivot column, i.e. is the original */ +/* column that should be placed in the current column index */ +/* J in the array C. */ + + ip = jpiv[j]; + +/* I is the original column that is */ +/* currently in the column index J in the array C after */ +/* previous column interchanges. */ + + i__ = iwork[*n + j]; + + if (i__ != ip) { + +/* JP is the current index of the original pivot */ +/* column IP in the array C after previous column */ +/* interchanges. */ + + jp = iwork[ip]; +/* Swap the original pivot column IP = JPIV( J ), */ +/* at the current pivot index JP = IWORK( IP ) into */ +/* index J. */ + + zswap_(m, &c__[j * c_dim1 + 1], &c__1, &c__[jp * c_dim1 + + 1], &c__1); + +/* Update the array IWORK(1:N) for the original column */ +/* I that was swapped with IP. */ + + iwork[i__] = iwork[ip]; + +/* Update the array IWORK(N+1:2*N) for the current column */ +/* index JP that was swapped with the current column */ +/* index J. */ + + iwork[*n + jp] = iwork[*n + j]; + + } + + } + +/* End of ELSE( RETURNX ) */ + + } + +/* End of IF( RETURNC .AND. K.GT.0 ) */ + + } + +/* ================================================================== */ + +/* Return the matrix X. */ + + if (returnx && *k > 0) { + +/* We need to use C and A to compute X = pseudoinv(C) * A, as */ +/* the linear least squares solution to the overdetermined system */ +/* C*X = A. We use LLS routine that uses the QR factorization. For */ +/* that purpose, we store the matrix C into the array QRC. */ +/* The matrix A was copied into the array X at the beginning */ +/* of the routine. */ + + zlacpy_("F", m, k, &c__[c_offset], ldc, &qrc[qrc_offset], ldqrc); + + zgels_("N", m, k, n, &qrc[qrc_offset], ldqrc, &x[x_offset], ldx, & + work[1], lwork, &iinfo); + *info = iinfo; + + } + + z__1.r = (doublereal) lwkopt, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + rwork[1] = (doublereal) lrwkopt; + iwork[1] = liwkopt; + +/* End of ZGECXX */ + + return 0; +} /* zgecxx_ */ + diff --git a/lapack-netlib/SRC/zgecxx.f b/lapack-netlib/SRC/zgecxx.f new file mode 100644 index 0000000000..c5a4cff118 --- /dev/null +++ b/lapack-netlib/SRC/zgecxx.f @@ -0,0 +1,1776 @@ +*> \brief \b ZGECXX computes a CX factorization of a real M-by-N matrix A using a truncated (rank k) Householder QR factorization with column pivoting. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +*> \htmlonly +*> Download ZGECXX + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE ZGECXX( FACT, USESD, M, N, +* $ DESEL_ROWS, SEL_DESEL_COLS, +* $ KMAXFREE, ABSTOL, RELTOL, A, LDA, +* $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, +* $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, +* $ X, LDX, WORK, LWORK, RWORK, LRWORK, +* $ IWORK, LIWORK, INFO ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* CHARACTER FACT, USESD +* INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, +* $ LDX, LIWORK, LRWORK, LWORK, M, N +* DOUBLE PRECISION ABSTOL, FNRMK, MAXC2NRMK, +* $ RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. +* INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), +* $ JPIV( * ), SEL_DESEL_COLS( * ) +* DOUBLE PRECISION RWORK( * ) +* COMPLEX*16 A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), +* $ TAU( * ), WORK( * ), X( LDX, *) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZGECXX computes a CX factorization of a real M-by-N matrix A using +*> a truncated rank-K Householder QR factorization with a column +*> pivoting algorithm, which is implemented in the ZGEQP3RK routine. +*> +*> A * P = C*X + A_resid, where +*> +*> C is an M-by-K matrix consisting of K columns selected +*> from the original matrix A, +*> +*> X is a K-by-N matrix that minimizes the Frobenius norm of the +*> residual matrix A_resid, X = pseudoinv(C) * A, +*> +*> P is an N-by-N permutation matrix chosen so that the first +*> K columns of A*P equal C, +*> +*> A_resid is an M-by-N residual matrix. +*> +*> The column selection for the matrix C has two stages. +*> +*> Column preselection stage 1 (optional). +*> ======================================= +*> +*> The user can select N_sel columns and deselect N_desel columns +*> of the matrix A that MUST be included and excluded respectively +*> from the matrix C a priori, before running the column selection +*> algorithm. This is controlled by flags in the array +*> SEL_DESEL_COLS. The deselected columns are permuted to the right +*> side of the matrix A and selected columns are permuted to the left +*> side of the matrix A. The details of the column permutation +*> (i.e. the column permutation matrix P) are stored in the +*> array JPIV. This feature can be used when the goal is to approximate +*> the deselected columns by linear combinations of K selected columns, +*> where the K columns MUST include the N_sel preselected columns. +*> +*> Column selection stage 2. +*> ========================= +*> +*> The routine runs a column selection algorithm that can +*> be controlled by three stopping criteria described below. +*> For column selection, the routine uses a truncated (rank-K) +*> Householder QR factorization with column pivoting algorithm using +*> the routine ZGEQP3RK. +*> +*> Optionally, before running the column selection +*> algorithm, the user can deselect M_desel rows of the matrix A that +*> should NOT be considered by the column selection algorithm (i.e. +*> during the factorization). This is controlled by flags in +*> the array DESEL_ROWS. The deselected rows are permuted to the +*> bottom of the matrix A. The details of the row permutation (i.e. the +*> row permutation matrix) are stored in the array IPIV. This feature +*> can be used when the goal is to use the deselected rows as test data, +*> and the selected rows as training data. +*> +*> This means that the column selection factorization algorithm is +*> effectively running on the submatrix A_sub = A(1:M_sub,1:N_sub) of +*> the matrix A after the permutations described above. Here M_sub is +*> the number of rows of the matrix A minus the number of deselected +*> rows M_desel, i.e. M_sub = M - M_desel, and N_sub is the number +*> of columns of the matrix A minus the number of deselected columns +*> N_desel, i.e. N_sub = N - N_desel. +*> +*> The reported column selection error metrics MAXC2NRMK, RELMAXC2NRMK +*> and FNRMK described below are computed using only A_sub. +*> +*> Column selection criteria. +*> ========================== +*> +*> The column selection criteria (i.e. when to stop the factorization) +*> can be any of the following: +*> +*> 1) KMAXFREE: This input parameter specifies the maximum number of +*> columns to factorize in addition to the N_sel preselected +*> columns. The factorization rank is limited to N_sel + KMAXFREE. +*> If N_sel + KMAXFREE >= min(M_sub, N_sub), this criterion +*> is not used. +*> +*> 2) ABSTOL: This input parameter specifies the absolute tolerance +*> for the maximum column 2-norm of the submatrix residual +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub), where +*> A_sub(K) denotes the contents of the array +*> A_sub = A(1:M_sub, 1:N_sub) after K columns were factorized. +*> This means that the factorization stops if this norm is less +*> than or equal to ABSTOL. If ABSTOL < 0.0, this criterion is +*> not used. +*> +*> 3) RELTOL: This input parameter specifies the tolerance for +*> the maximum column 2-norm of the submatrix residual +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) divided +*> by the maximum column 2-norm of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub), where A_sub(K) denotes the contents +*> of the array A_sub after K columns were factorized. +*> This means that the factorization stops when the ratio of the +*> maximum column 2-norm of A_sub_resid(K) to the maximum column +*> 2-norm of A_sub is less than or equal to RELTOL. +*> If RELTOL < 0.0, this criterion is not used. +*> +*> The algorithm stops when any of these conditions is first +*> satisfied, otherwise the entire submatrix A_sub is factorized. +*> +*> To perform a full-rank factorization of the matrix A_sub, use +*> selection criteria that satisfy N_sel + KMAXFREE >= min(M_sub,N_sub) +*> and ABSTOL < 0.0 and RELTOL < 0.0. +*> +*> If the user wishes to verify that the columns of the matrix C are +*> sufficiently linearly independent for their intended use, the user +*> can compute the condition number of its R factor by calling DTRCON +*> on the upper-triangular part of QRC(1:K,1:K) in the output +*> array QRC. +*> +*> How N_sel affects the column selection algorithm. +*> ================================================= +*> +*> As mentioned above, the N_sel preselected columns are permuted to the +*> left side of the matrix A, and will be included in the column +*> selection. Then the routine factorizes that block A(1:M_sub,1:N_sel), +*> and if any of the three stopping criteria is met immediately after +*> factoring the first N_sel columns the routine exits +*> (i.e. if the user does not want to select KMAXFREE > 0 extra columns, +*> or if the absolute or relative tolerance of the maximum column 2-norm +*> of the residual is satisfied). In this case, the number +*> of selected columns would be K = N_sel. Otherwise, the factorization +*> routine finds a new column to select with the maximum column 2-norm +*> in the residual A(N_sel+1:M_sub,N_sel+1:N_sub), and swaps that +*> column with the first column of A(1:M,N_sel+1:N_sub). Then the +*> routine checks if the stopping criteria are met in the next residual +*> A(N_sel+2:M_sub,N_sel+2:N_sub), and so on. +*> +*> Computation of the matrix factors. +*> ================================== +*> +*> When the columns are selected for the factor C, and: +*> (a) If the flag FACT = 'P', the routine returns only the indices of +*> the selected columns from the original matrix A, which are +*> stored in the first K elements of the JPIV array. +*> (b) If the flag FACT = 'C', then in addition to (a), the routine +*> explicitly returns the matrix C in the array C. +*> (c) If the flag FACT = 'X', then in addition to (a) and (b), +*> the routine explicitly computes and returns the factor +*> X = pseudoinv(C) * A in the array X, and it also returns +*> the factor R alongside the Householder vectors +*> of the QR factorization of the matrix C in the array QRC. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] FACT +*> \verbatim +*> FACT is CHARACTER*1 +*> The flag specifies how the factors of a CX factorization +*> are returned. +*> +*> = 'P': the routine returns: +*> (1) only the column permutation matrix P in +*> the array JPIV. +*> (The first K elements of the array JPIV +*> contain indices of the columns that were +*> selected from the matrix A to form the +*> factor C.) +*> (fastest option, smallest memory space) +*> +*> = 'C': the routine returns: +*> (1) the column permutation matrix P +*> in the array JPIV. (The first K elements are +*> indices of the selected columns from +*> the matrix A.) +*> (2) the M-by-K factor C explicitly in the array C. +*> (slower option, more memory space) +*> +*> = 'X': the routine returns: +*> (1) the column permutation matrix P in +*> the array JPIV. (The first K elements are +*> indices of the selected columns from +*> the matrix A.) +*> (2) the M-by-K factor C explicitly in the array C. +*> (3) the K-by-N factor X explicitly in the array X. +*> (4) the K-by-K upper triangular factor R and +*> the Householder vectors of the QR factorization +*> of the factor C in the array QRC. +*> ( The factor R may be useful for checking +*> the factor C for singularity, in which case +*> R will have a zero on the diagonal, and +*> the factor X cannot be computed. ) +*> (slowest option, largest memory space) +*> \endverbatim +*> +*> \param[in] USESD +*> \verbatim +*> USESD is CHARACTER*1 +*> The flag specifies whether the row deselection and column +*> preselection-deselection functionality is turned ON or OFF. +*> +*> = 'N': Both row deselection and column +*> preselection-deselection are OFF. +*> Both arrays DESEL_ROWS and SEL_DESEL_COLS +*> are not used. +*> +*> = 'R': Only row deselection is ON. +*> Column preselection-deselection is OFF. +*> The array SEL_DESEL_COLS is not used. +*> +*> = 'C': Only column preselection-deselection is ON. +*> Row deselection is OFF. +*> The array DESEL_ROWS is not used. +*> +*> = 'A': Means "All". Both row deselection and column +*> preselection-deselection are ON. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the matrix A. N >= 0. +*> \endverbatim +*> +*> \param[in,out] DESEL_ROWS +*> \verbatim +*> DESEL_ROWS is INTEGER array, dimension (M) +*> DESEL_ROWS is only accessed if USESD = 'R' or 'A'. +*> This is a row deselection mask array that separates +*> the rows of matrix A into 2 sets. +*> +*> On entry: +*> a) If DESEL_ROWS(i) = -1, the i-th row of the matrix A is +*> deselected by the user, i.e. chosen to be excluded from +*> the column selection algorithm (in both preselection and +*> selection stages) and will be permuted to the bottom +*> of the matrix A. +*> The number of deselected rows is denoted by M_desel. +*> +*> b) If DESEL_ROWS(i) is not equal -1, +*> the i-th row of A will be used in the column selection +*> algorithm (in both preselection and selection stages). +*> This defines a set of M_sub = M - M_desel rows that +*> the algorithm will use to select columns. +*> After the permutation, this set will be at the top +*> of the matrix A. +*> +*> On exit: +*> DESEL_ROWS will be permuted according to IPIV(i), +*> so that, if IPIV(i) = k, then the entry i of DESEL_ROWS +*> on exit was the entry k of DESEL_ROWS on entry. +*> +*> \endverbatim +*> +*> \param[in,out] SEL_DESEL_COLS +*> \verbatim +*> SEL_DESEL_COLS is INTEGER array, dimension (N) +*> SEL_DESEL_COLS is only accessed if USESD = 'C' or 'A'. +*> This is a column preselection-deselection mask array that +*> separates the columns of matrix A into 3 sets. +*> +*> On entry: +*> a) If SEL_DESEL_COLS(j) = +1, the j-th column of the matrix +*> A is preselected by the user to be included +*> in the factor C and will be permuted to the left side +*> of the array A. The number of selected columns is +*> denoted by N_sel. +*> +*> b) If SEL_DESEL_COLS(j) = -1, the j-th column of the matrix +*> A is deselected by the user, i.e. chosen to be excluded +*> from the factor C and will be permuted to the right side +*> of the array A. The number of deselected columns is +*> denoted by N_desel. +*> +*> c) If SEL_DESEL_COLS(j) is not equal to 1 and not equal +*> to -1, the j-th column of A is a free column and will be +*> used by the column selection algorithm to determine if +*> this column will be selected. This defines a set of +*> columns of size N_free = N - N_sel - N_desel. +*> +*> On exit: +*> SEL_DESEL_COLS will be permuted according to JPIV(j), +*> so that, if JPIV(j) = k, then the entry j +*> of SEL_DESEL_COLS on exit was the entry k +*> of SEL_DESEL_COLS on entry. +*> +*> NOTE: An error returned as INFO = -6 means that the number +*> of preselected N_sel columns is larger than M_sub. +*> Therefore, the QR factorization of all N_sel preselected +*> columns cannot be completed. +*> \endverbatim +*> +*> \param[in] KMAXFREE +*> \verbatim +*> KMAXFREE is INTEGER, KMAXFREE >= 0. +*> +*> The first column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> KMAXFREE is the maximum number of columns of the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) to select +*> during the column selection stage 2. +*> +*> KMAXFREE does not include the preselected N_sel columns. +*> N_sel + KMAXFREE is the maximum factorization rank of +*> the matrix A_sub. +*> +*> a) If N_sel + KMAXFREE >= min(M_sub, N_sub), then this +*> stopping criterion is not used, i.e. columns are +*> selected in the factorization stage 2 depending +*> on ABSTOL and RELTOL. +*> +*> b) If KMAXFREE = 0, then this stopping criterion is +*> satisfied on input and the routine exits without +*> performing column selection stage 2 +*> on the submatrix A_sub. This means that the matrix +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub) is not modified +*> in the column selection stage 2 +*> and A_free is itself the residual for the factorization. +*> \endverbatim +*> +*> \param[in] ABSTOL +*> \verbatim +*> ABSTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The second column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> ABSTOL is the absolute tolerance (stopping threshold) +*> for maxcol2norm(A_sub_resid(K)), where K >= N_sel. +*> +*> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm +*> of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) +*> when K columns have been factorized. +*> The column selection algorithm converges +*> (stops the factorization) when +*> maxcol2norm(A_sub_resid(K)) <= ABSTOL, where K >= N_sel. +*> +*> In the following, +*> SAFMIN = DLAMCH('S'), +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub), +*> maxcol2norm(A_free) is the maximum column 2-norm +*> of the matrix A_free. +*> +*> a) If ABSTOL is NaN, then no computation is performed +*> and an error message ( INFO = -8 ) is issued +*> by XERBLA. +*> +*> b) If ABSTOL < 0.0, then this stopping criterion is not +*> used, and the column selection algorithm stops +*> the factorization of A_free depending +*> on KMAXFREE and RELTOL. +*> This includes the case where ABSTOL = -Inf. +*> +*> c) If 0.0 <= ABSTOL < 2*SAFMIN, then ABSTOL = 2*SAFMIN +*> is used. This includes the case where ABSTOL = -0.0. +*> +*> d) If 2*SAFMIN <= ABSTOL then the input value +*> of ABSTOL is used. +*> +*> If ABSTOL chosen above is >= maxcol2norm(A_free), then +*> this stopping criterion is satisfied on input, and +*> the routine only preselects K = N_sel columns. The leftmost +*> preselected N_sel columns in the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) are factorized. The routine +*> then computes maxcol2norm(A_free) and returns it +*> in MAXC2NORMK, computes and returns RELMAXC2NORMK of A_free, +*> and exits immediately. +*> This means that the factorization residual +*> A_sub_resid(N_sel) = A_free = A(N_sel+1:M_sub,N_sel+1:N_sub) +*> is not modified in the column selection stage 2. +*> This includes the case where ABSTOL = +Inf. +*> \endverbatim +*> +*> \param[in] RELTOL +*> \verbatim +*> RELTOL is DOUBLE PRECISION, cannot be NaN. +*> +*> The third column selection stopping criterion from +*> the N_free columns (N_sel+1:N_sub) of the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) in the column selection stage 2. +*> +*> RELTOL is the tolerance (stopping threshold) for the ratio +*> relmaxcol2norm(A_sub_resid(K)) = +*> = maxcol2norm(A_sub_resid(K))/maxcol2norm(A_sub), +*> where K >= N_sel. +*> +*> maxcol2norm(A_sub_resid(K)) is the maximum column 2-norm +*> of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub) +*> when K columns have been factorized. +*> maxcol2norm(A_sub) is the maximum column 2-norm +*> of the original submatrix A_sub = A(1:M_sub, 1:N_sub). +*> The column selection algorithm converges +*> (stops the factorization) when the ratio +*> relmaxcol2norm(A_sub_resid(K)) <= RELTOL, where K >= N_sel. +*> +*> In the following, +*> EPS = DLAMCH('E'), +*> A_free = A(N_sel+1:M_sub, N_sel+1:N_sub). +*> +*> a) If RELTOL is NaN, then no computation is performed +*> and an error message ( INFO = -9 ) is issued +*> by XERBLA. +*> +*> b) If RELTOL < 0.0, then this stopping criterion is not +*> used and the column selection algorithm stops +*> the factorization of A_free depending +*> on KMAXFREE and ABSTOL. +*> This includes the case RELTOL = -Inf. +*> +*> c) If 0.0 <= RELTOL < EPS, then RELTOL = EPS is used. +*> This includes the case RELTOL = -0.0. +*> +*> d) If EPS <= RELTOL then the input value of RELTOL +*> is used. +*> +*> If RELTOL chosen above is >= 1.0, then this stopping +*> criterion is satisfied on input, and the routine +*> only preselects K = N_sel columns. The leftmost +*> preselected N_sel columns in the submatrix +*> A_sub = A(1:M_sub, 1:N_sub) are factorized. +*> The routine then computes maxcol2norm(A_free) and returns +*> it in MAXC2NORMK, returns RELMAXC2NORMK as 1.0, and exits +*> immediately. +*> This means that the factorization residual +*> A_sub_resid(N_sel) = A_free = A(N_sel+1:M_sub,N_sel+1:N_sub) +*> is not modified. +*> This includes the case RELTOL = +Inf. +*> +*> NOTE: We recommend RELTOL to satisfy +*> min(max(M_sub,N_sub)*EPS, sqrt(EPS)) <= RELTOL +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (LDA,N) +*> +*> On entry: +*> the M-by-N matrix A. +*> +*> On exit: +*> +*> NOTE: +*> The output parameter K, the number of selected +*> columns, is described later. +*> A_sub = A(1:M_sub, 1:N_sub). +*> +*> 1) If K = 0, A(1:M,1:N) contains the original matrix A. +*> +*> 2) If K > 0, A(1:M,1:N) contains the following parts: +*> +*> (a) If M_sub < M (which is the same as M_desel > 0), +*> the subarray A(M_sub+1:M,1:N) contains the deselected +*> rows. +*> +*> (b) If N_sub < N ( which is the same as N_desel > 0 ), +*> the subarray A(1:M,N_sub+1:N) contains the +*> deselected columns. +*> +*> (c) If N_sel > 0, +*> the union of the subarray A(1:M_sub, 1:N_sel) +*> and the subarray A(1:N_sel, 1:N_sub) contains parts +*> of the factors obtained by computing Householder QR +*> factorization WITHOUT column pivoting of N_sel +*> preselected columns using the routine ZGEQRF. +*> +*> (d) The subarray A(N_sel+1:M_sub, N_sel+1:N_sub) +*> contains parts of the factors obtained by computing +*> a truncated (rank K) Householder QR factorization with +*> column pivoting using the routine ZGEQP3RK on +*> the matrix A_free = A(N_sel+1:M_sub, N_sel+1:N_sub), +*> which is the result of applying selection and +*> deselection of columns, applying deselection of rows +*> to the original matrix A, and applying orthogonal +*> transformation from the factorization of the first +*> N_sel columns as described in part (c). +*> +*> 1. The elements below the diagonal of the subarray +*> A_sub(1:M_sub,1:K) together with TAU(1:K) +*> represent the orthogonal matrix Q(K) as a +*> product of K Householder elementary reflectors. +*> +*> 2. The elements on and above the diagonal of +*> the subarray A_sub(1:K,1:N_sub) contain the +*> K-by-N_sub upper-trapezoidal matrix +*> R_sub_approx(K) = ( R_sub11(K), R_sub12(K) ). +*> NOTE: If K = min(M_sub,N_sub), i.e. full rank +*> factorization, then R_sub_approx(K) is the +*> full factor R which is upper-trapezoidal. +*> If, in addition, M_sub >= N_sub, then R is +*> upper-triangular. +*> +*> 3. The subarray A_sub(K+1:M_sub,K+1:N_sub) contains +*> the (M_sub-K)-by-(N_sub-K) rectangular matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub). +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[out] K +*> \verbatim +*> K is INTEGER +*> The number of columns that were selected +*> (K is the factorization rank). +*> 0 <= K <= min( M_sub, N_sel+KMAXFREE, N_sub ). +*> +*> NOTE: If K = 0, a) the arrays A is not, modified. +*> b) the array TAU(1,min(M_sub,N_sub)) +*> is set to ZERO. +*> \endverbatim +*> +*> \param[out] MAXC2NRMK +*> \verbatim +*> MAXC2NRMK is DOUBLE PRECISION +*> The maximum column 2-norm of the residual matrix +*> A_sub_resid(K) = A_sub(K)(K+1:M_sub, K+1:N_sub), +*> when factorization stopped at rank K. MAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, so +*> the matrix A_sub = A(1:M_sub, 1:N_sub) was not modified +*> and is itself a residual matrix, then MAXC2NRMK equals +*> the maximum column 2-norm of the original matrix A_sub. +*> +*> b) If 0 < K < min(M_sub, N_sub), then MAXC2NRMK is returned. +*> +*> c) If K = min(M_sub, N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no residual matrix, +*> then MAXC2NRMK = 0.0. +*> +*> NOTE: MAXC2NRMK at the factorization step K is equal +*> to the diagonal element R_sub(K+1,K+1) of the factor +*> R_sub in the next factorization step K+1. +*> \endverbatim +*> +*> \param[out] RELMAXC2NRMK +*> \verbatim +*> RELMAXC2NRMK is DOUBLE PRECISION +*> The ratio MAXC2NRMK / MAXC2NRM +*> of the maximum column 2-norm MAXC2NRMK of the residual +*> matrix A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub) (when +*> factorization stopped at rank K) and maximum column 2-norm +*> MAXC2NRM of the matrix A_sub = A(1:M_sub, 1:N_sub). +*> RELMAXC2NRMK >= 0. +*> +*> a) If K = 0, i.e. the factorization was not performed, +*> the matrix A_sub was not modified +*> and is itself a residual matrix, +*> then RELMAXC2NRMK = 1.0. +*> +*> b) If 0 < K < min(M_sub,N_sub), then +*> RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM is returned. +*> +*> c) If K = min(M_sub,N_sub), i.e. the whole matrix A_sub was +*> factorized and there is no residual matrix +*> A_sub_resid(K), then RELMAXC2NRMK = 0.0. +*> +*> NOTE: RELMAXC2NRMK at the factorization step K would equal +*> abs(R_sub(K+1,K+1))/MAXC2NRM in the next +*> factorization step K+1, where R_sub(K+1,K+1) is the +*> diagonal element of the factor R_sub in the next +*> factorization step K+1. +*> \endverbatim +*> +*> \param[out] FNRMK +*> \verbatim +*> FNRMK is DOUBLE PRECISION +*> Frobenius norm of the residual matrix +*> A_sub_resid(K) = A_sub(K+1:M_sub, K+1:N_sub). +*> FNRMK >= 0.0 +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (M) +*> Row permutation indices due to row deselection, +*> for 1 <= i <= M. +*> If IPIV(i) = k, then the row i of A was +*> the row k of A. +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (N) +*> Column permutation indices, for 1 <= j <= N. +*> If JPIV(j)= k, then the column j of A*P was +*> the column k of A. +*> +*> The first K elements of the array JPIV contain +*> indices of the columns of the factor C that were selected +*> from the matrix A. +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (min(M_sub,N_sub)) +*> The scalar factors of the elementary reflectors. +*> +*> If K = 0, all elements TAU(1:min(M_sub,N_sub)) are set +*> to zero. +*> If 0 < K <= min(M_sub,N_sub): +*> only the elements TAU(1:K) may be modified, +*> the elements TAU(K+1:min(M_sub,N_sub)) are set to zero. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX*16 array. +*> +*> If FACT = 'P': +*> the array is not used, the array dimension >= (1,1). +*> +*> If FACT = 'C': +*> the array dimension is (LDC,N). +*> If K = 0: +*> the M-by-N array C contains a copy of +*> the original M-by-N matrix A. +*> If K > 0: +*> a) columns (1:K) of the array C contain +*> the M-by-K factor C (the selected columns +*> from the original matrix A). +*> b) columns (K+1:N) of the array C contain +*> the deselected columns from the original +*> matrix A. +*> +*> If FACT = 'X': +*> the array dimension is (LDC,N). +*> If K = 0: +*> the M-by-N array C is not used. +*> If K > 0: +*> a) columns (1:K) of the array C contain +*> the M-by-K factor C (the selected columns +*> from the original matrix A). +*> b) columns (K+1:N) of the array C are +*> not used. +*> \endverbatim +*> +*> \param[in] LDC +*> \verbatim +*> LDC is INTEGER +*> The leading dimension of the array C. +*> If FACT = 'P', LDC >= 1. +*> If FACT = 'C' or 'X', LDC >= max(1,M). +*> \endverbatim +*> +*> \param[out] QRC +*> \verbatim +*> QRC is COMPLEX*16 array. +*> +*> If FACT = 'P' or 'C': The array is not used, +*> the array dimension is >= (1,1). +*> +*> If FACT = 'X': the array dimension is (LDQRC,min(M,N)). +*> +*> If K = 0, the array is not used. +*> If K > 0, QRC(1:M,1:K) stores two components from +*> the QR factorization of the factor C. The K-by-K +*> factor R is stored in the upper triangle. +*> The Householder vectors are stored in the lower +*> trapezoid below the diagonal. +*> \endverbatim +*> +*> \param[in] LDQRC +*> \verbatim +*> LDQRC is INTEGER +*> The leading dimension of the array QRC. +*> If FACT = 'P' or 'C', LDQRC >= 1. +*> If FACT = 'X', LDQRC >= max(1,M). +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array. +*> If FACT = 'P' or 'C': The array is not used, +*> the array dimension is >= (1,1). +*> +*> If FACT = 'X': The array dimension is (LDX,N). +*> 1) If K = 0: +*> the M-by-N array X contains a copy of +*> the original M-by-N matrix A. +*> 2) If K > 0: +*> a) rows (1:K) of the M-by-N array X contain +*> the K-by-N factor X, where K <= N. +*> b) rows (K+1:M) of the M-by-N array X. +*> Each column of these rows contains the elements +*> whose sum of squares is the residual sum of +*> squares for the solution in each column of +*> the least squares problem. +*> min|| A - C*X ||_F for the unknown X. +*> \endverbatim +*> +*> \param[in] LDX +*> \verbatim +*> LDX is INTEGER +*> The leading dimension of the array X. +*> If FACT = 'P' or 'C', LDX >= 1. +*> If FACT = 'X', LDX >= max(1,M). +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array, dimension (max(1,LWORK)). +*> +*> On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> +*> Minimal LWORK workspace general requirement. +*> LWORK >= max( 1, min(M,N) + N ) would be sufficient for all +*> values of FACT and USESD flags. +*> +*> For good performance, LWORK should generally be larger, and +*> the user should query the routine for the optimal LWORK. +*> +*> If LWORK = -1, or LRWORK, or LIWORK =-1 then a workspace +*> query is assumed. The routine only calculates the optimal +*> size of the WORK, RWORK and IWORK arrays, returns these +*> values as the first entry of the WORK, RWORK, and IWORK +*> arrays respectively, and no error message related to LWORK +*> is issued by XERBLA. +*> +*> Exact minimal workspace requirements. +*> For USESD = 'N' or 'R' and for all FACT: +*> a) If FACT = 'P' or 'C': +*> LWORK >= max( 1, N-1 ) +*> b) If FACT = 'X': +*> LWORK >= max( 1, min(M,N) + N ) +*> For USESD = 'C' or 'A': +*> a) If FACT = 'P' or 'C': +*> LWORK >= max( 1, min(1,N_sel)*max(N_sel,N_free), +*> min(1,MINMNFREE)*(N_free-1) ) +*> b) If FACT = 'X': +*> LWORK >= max( 1, min(M,N) + N ) +*> where MINMNFREE = min( M_free, N_free ). +*> +*> NOTE: The decision, whether the routine uses unblocked +*> BLAS 2 or blocked BLAS 3 code is based not only on the +*> dimension LWORK of the available workspace WORK, but +*> also on: +*> 1a) column preselection stage using ZGEQRF: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine ZGEQRF +*> in comparison to N_sel. (For N_sel <= NX +*> or N_sel <= NB, unblocked code is used in ZGEQRF.) +*> 1b) column preselection stage using ZUNMQR: +*> the optimal block size NB returned by ILAENV for +*> the routine ZUNMQR in comparison to N_sel. (For +*> N_sel <= NB, unblocked code is used in ZUNMQR.) +*> 2) column selection stage via criteria using ZGEQRP3RK: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine ZGEQRP3RK +*> in comparison to min(M,N_sel). (For +*> min(M_sub, N_free, KMAXFREE) <= NX +*> or min(M_sub, N_free, KMAXFREE) <= NB, unblocked code +*> is used in ZGEQRP3RK.) +*> 3a) computation of the factor X using ZGEQRF in ZGELS: +*> the optimal block size NB, the crossover point NX +*> returned by ILAENV for the routine ZGEQRF +*> in comparison to K. (For K <= NX or K <= NB, +*> unblocked code is used in ZGEQRF inside ZGELS.) +*> 3b) computation of the factor X using ZUNMQR in ZGELS: +*> the optimal block size NB returned by ILAENV for +*> the routine ZUNMQR in comparison to N. (For +*> N <= NB, unblocked code is used in ZUNMQR +*> inside ZGELS.) +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (max(1,LRWORK)). +*> +*> On exit, if INFO >= 0, RWORK(1) returns the optimal LRWORK. +*> \endverbatim +*> +*> \param[in] LRWORK +*> \verbatim +*> LRWORK is INTEGER +*> The dimension of the array RWORK. +*> +*> Minimal LRWORK workspace general requirement. +*> LRWORK >= max( 1, 2*N ) would be sufficient for all values +*> of FACT and USESD flags. +*> +*> The optimal LRWORK is the same as the minimal LRWORK. +*> The user can still query the routine for the optimal LRWORK. +*> +*> If LWORK =-1, or LRWORK = -1, or LWORK = -1, then +*> a workspace query is assumed. The routine only calculates +*> the optimal size of the WORK, RWORK, and IWORK arrays, +*> returns these values as the first entry of the WORK, RWORK, +*> and IWORK arrays respectively, and no error message related +*> to LRWORK is issued by XERBLA. +*> +*> Exact minimal workspace requirements. +*> For USESD = 'N' or 'R' and all FACT, +*> LRWORK >= max( 1, 2*N ) +*> For USESD = 'C' or 'A' and all FACT, +*> LRWORK >= max( 1, max(N_sub, 2*N_free) ) +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (max(1,LIWORK)). +*> +*> On exit, if INFO >= 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> +*> Minimal LIWORK workspace general requirement. +*> LIWORK >= max( 1, 2*N ) would be sufficient for all values +*> of FACT and USESD flags. +*> +*> The optimal LIWORK is the same as the minimal LIWORK. +*> The user can still query the routine for the optimal LIWORK. +*> +*> If LWORK =-1, or LRWORK = -1, or LWORK = -1, then +*> a workspace query is assumed. The routine only calculates +*> the optimal size of the WORK, RWORK, and IWORK arrays, +*> returns these values as the first entry of the WORK, RWORK, +*> and IWORK arrays respectively, and no error message related +*> to LIWORK is issued by XERBLA. +*> +*> Exact minimal workspace requirements. +*> For USESD = 'N' or 'R': +*> a) If FACT = 'P': +*> LIWORK >= max( 1, N-1 ) +*> b) If FACT = 'C' or 'X': +*> LIWORK >= max( 1, 2*N ) +*> For USESD = 'C' or 'A': +*> a) If FACT = 'P': +*> LIWORK >= max( 1, (N_free-1) + min(1,N_sel)*N_free ) +*> b) If FACT = 'C' or 'X': +*> LIWORK >= max( 1, 2*N ) +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: if INFO = i, the i-th diagonal element of the +*> triangular R factor of the QR factorization of +*> the matrix C is zero. Consequently, C does not have +*> full rank, and X cannot be computed as the least +*> squares solution to the overdetermined system C*X = A. +*> (R is stored in the array QRC.) +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \par Contributors: +* ================== +*> +*> \verbatim +*> +*> April 2026, Igor Kozachenko, James Demmel, +*> EECS Department, +*> University of California, Berkeley, USA. +*> \endverbatim +* +*> \ingroup gecxx +* +* ===================================================================== + SUBROUTINE ZGECXX( FACT, USESD, M, N, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ KMAXFREE, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, + $ X, LDX, WORK, LWORK, RWORK, LRWORK, + $ IWORK, LIWORK, INFO ) + IMPLICIT NONE +* +* -- LAPACK computational routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER FACT, USESD + INTEGER INFO, K, KMAXFREE, LDA, LDC, LDQRC, + $ LDX, LIWORK, LRWORK, LWORK, M, N + DOUBLE PRECISION ABSTOL, FNRMK, MAXC2NRMK, + $ RELMAXC2NRMK, RELTOL +* .. +* .. Array Arguments .. + INTEGER DESEL_ROWS( * ), IPIV( * ), IWORK( * ), + $ JPIV( * ), SEL_DESEL_COLS( * ) + DOUBLE PRECISION RWORK( * ) + COMPLEX*16 A( LDA, * ), C( LDC, * ), QRC( LDQRC, * ), + $ TAU( * ), WORK( * ), X( LDX, *) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, TWO, MINUSONE + PARAMETER ( ZERO = 0.0D+0, TWO = 2.0D+0, + $ MINUSONE = -1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY, RETURNC, RETURNX, + $ USE_DESEL_ROWS, USE_SEL_DESEL_COLS, USETOL + INTEGER I, IP, IINFO, ITEMP, J, JDESEL, JP, KFREE, + $ KMAXLS, KP0, LIWKMIN, LIWKOPT, LRWKMIN, + $ LRWKOPT, LWKMIN, LWKOPT, MFREE, MDESEL, MINMN, + $ MINMNFREE, MRESID, MSUB, NFREE, NDESEL, NRESID, + $ NSEL, NSUB + DOUBLE PRECISION ABSTOLFREE, EPS, MAXC2NRM, MAXC2NRMKFREE, + $ RELTOLFREE, RELMAXC2NRMKFREE, SAFMIN + +* .. External Subroutines .. + EXTERNAL ZCOPY, ZGELS, ZGEQP3RK, ZGEQRF, ZLACPY, + $ ZUNMQR, ZSWAP, XERBLA +* .. +* .. External Functions .. + LOGICAL DISNAN, LSAME + INTEGER IZAMAX, ILAENV + DOUBLE PRECISION DLAMCH, ZLANGE, DZNRM2 + EXTERNAL DISNAN, DLAMCH, ZLANGE, DZNRM2, IZAMAX, + $ ILAENV, LSAME +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, MAX, MIN +* .. +* .. Executable Statements .. +* +* Test the input arguments +* + INFO = 0 + MDESEL = 0 + NSEL = 0 + NDESEL = 0 + MSUB = M + NSUB = N + MFREE = MSUB + NFREE = NSUB + MINMN = MIN( M, N ) +* + LQUERY = ( LWORK.EQ.-1 .OR. LRWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + RETURNX = LSAME( FACT, 'X' ) + RETURNC = LSAME( FACT, 'C' ) .OR. RETURNX +* + USE_DESEL_ROWS = LSAME( USESD, 'R' ) + $ .OR. LSAME( USESD, 'A' ) + USE_SEL_DESEL_COLS = LSAME( USESD, 'C' ) + $ .OR. LSAME( USESD, 'A' ) +* + IF( .NOT.( RETURNC .OR. LSAME( FACT, 'P') ) ) THEN + INFO = -1 + ELSE IF( .NOT.( USE_DESEL_ROWS .OR. USE_SEL_DESEL_COLS + $ .OR. LSAME( USESD, 'N' ) ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE +* +* This is to check that the number of preselected columns NSEL +* cannot be larger than MSUB, which is the number of rows +* without MDESEL deselected rows. When the number of +* preselected columns NSEL is larger than MSUB, +* the factorization of all preselected NSEL columns cannot be +* completed. MSUB also will be used for LDX argument check +* later. +* + IF( USE_DESEL_ROWS ) THEN +* +* Count the number of free rows MSUB. +* + DO I = 1, M + IF( DESEL_ROWS( I ).EQ.-1 ) MDESEL = MDESEL + 1 + END DO + MSUB = M - MDESEL + MFREE = MSUB + END IF +* + IF( USE_SEL_DESEL_COLS ) THEN +* +* Count the number of preselected columns NSEL and the +* number of preselected and free columns NSUB = N - NDESEL. +* + DO J = 1, N + IF( SEL_DESEL_COLS( J ).EQ.1 ) NSEL = NSEL + 1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) NDESEL = NDESEL + 1 + END DO + NSUB = N - NDESEL + MFREE = MSUB - NSEL + NFREE = NSUB - NSEL +* + END IF + MINMNFREE = MIN( MFREE, NFREE ) +* + IF( NSEL.GT.MSUB ) THEN + INFO = -6 + ELSE IF( KMAXFREE.LT.0 ) THEN + INFO = -7 + ELSE IF( DISNAN( ABSTOL ) ) THEN + INFO = -8 + ELSE IF( DISNAN( RELTOL ) ) THEN + INFO = -9 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -11 +* This is a check for LDC + ELSE IF( ( RETURNC .AND. LDC.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNC .AND. LDC.LT.1 ) ) THEN + INFO = -20 +* This is a check for LDQRC + ELSE IF( ( RETURNX .AND. LDQRC.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNX .AND. LDQRC.LT.1 ) ) THEN + INFO = -22 +* This is a check for LDX + ELSE IF( ( RETURNX .AND. LDX.LT.MAX( 1, M ) ) + $ .OR. ( .NOT.RETURNX .AND. LDX.LT.1 ) ) THEN + INFO = -24 + END IF +* + END IF +* +* ================================================================== +* +* a) Test the input workspace size LWORK, LRWORK, LIWORK for the +* minimum size requirement LWKMIN, LRWKMIN, LIWKMIN +* respectively. +* b) Determine the optimal workspace sizes LWKOPT, LRWKOPT, +* and LIWKOPT to be returned in +* WORK( 1 ), RWORK( 1 ) and IWORK( 1 ) respectively, +* if INFO >= 0 in cases: +* (1) LQUERY = .TRUE., +* (2) when the routine exits. +* Here, LWKMIN, LRWKMIN and LIWKMIN are the minimum workspaces +* required for unblocked code. +* + IF( INFO.EQ.0 ) THEN + IF( MINMN.EQ.0 ) THEN + LWKMIN = 1 + LWKOPT = 1 + LRWKMIN = 1 + LRWKOPT = 1 + LIWKMIN = 1 + LIWKOPT = 1 + ELSE +* +* (Complex_wk_part_1) Complex minimum and optimal workspace +* computation. +* + LWKMIN = 1 + LWKOPT = LWKMIN +* +* (Real_wk_part_1) Real minimum workspace computation. +* LRWKMIN = MAX(1, NSUB) for column 2-norm computation +* + LRWKMIN = MAX( 1, NSUB ) +* +* (Int_wk_part_1) Integer minimum workspace computation. +* + LIWKMIN = 1 +* +* Call of ZGEQRF. +* + IF( NSEL.GT.0 ) THEN +* +* (Complex_wk_part_2) Complex minimum workspace +* computation. +* + LWKMIN = MAX( LWKMIN, NSEL ) +* +* Query for optimal workspace size for ZGEQRF. +* + CALL ZGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, + $ -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* +* Call of ZUNMQR. +* + IF( NFREE.GT.0 ) THEN +* +* (Complex_wk_part_3) Complex minimum workspace +* computation. +* + LWKMIN = MAX( LWKMIN, NFREE ) +* +* Query for optimal workspace size for ZUNMQR. +* + CALL ZUNMQR( 'L', 'C', MSUB, NFREE, + $ NSEL, A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, + $ -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) + END IF +* + END IF +* +* Call of ZGEQP3RK. +* + IF ( MINMNFREE.NE.0 ) THEN +* +* (Complex_wk_part_4) Complex minimum workspace +* computation. +* LWKMIN = MAX(1, NFREE-1) for the call of ZGEQP3RK. +* + LWKMIN = MAX( LWKMIN, NFREE - 1 ) +* +* Query for optimal workspace size for ZGEQP3RK. +* + CALL ZGEQP3RK( MFREE, NFREE, 0, NFREE, + $ MINUSONE, MINUSONE, + $ A( 1, 1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( 1 ), TAU( 1 ), + $ WORK, -1, RWORK, IWORK, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK( 1 ) ) ) +* +* (Real_wk_part_2) Real minimum workspace computation. +* LRWKMIN = MAX(1, 2*NFREE) for the call of ZGEQP3RK. +* + LRWKMIN = MAX( LRWKMIN, 2*NFREE ) +* +* (Int_wk_part_2) Integer minimum workspace computation. +* LIWKMIN = NFREE-1 for the call of ZGEQP3RK. +* + LIWKMIN = MAX( LIWKMIN, NFREE-1 ) +* + IF( NSEL.NE.0 ) THEN +* +* (Int_wk_part_3) Integer minimum workspace computation. +* NFREE is for ZGEQP3RK and NFREE-1 for JPIV adjustment. +* + LIWKMIN = MAX( LIWKMIN, NFREE + NFREE-1 ) + END IF +* + END IF +* + IF( RETURNC ) THEN +* +* Integer minimum workspace computation. +* (Int_wk_part_4) LIWKMIN = 2*N for applying the +* interchanges for the columns in the matrix C. +* + LIWKMIN = MAX( LIWKMIN, 2*N ) + END IF +* +* Real and Integer optimal workspace computation. +* + LRWKOPT = LRWKMIN + LIWKOPT = LIWKMIN +* +* Call of ZGELS. +* + IF( RETURNX ) THEN +* +* (Complex_wk_part_5) Complex minimum workspace computation. +* LWKMIN = max( 1, MINMN + max( MINMN, N ) ) = +* = max( 1, MINMN + N ) for the call of ZGELS. +* + LWKMIN = MAX( LWKMIN, MINMN + N ) +* +* Query for optimal workspace size for ZGELS. +* + KMAXLS = MINMN +* + CALL ZGELS( 'N', M, KMAXLS, N, QRC, LDQRC, X, LDX, + $ WORK, -1, IINFO ) + LWKOPT = MAX( LWKOPT, INT( WORK(1) ) ) +* + END IF + +* +* End of ELSE for IF( MINMN.EQ.0 ) +* + END IF +* + IF( ( LWORK.LT.LWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -26 + ELSE IF( ( LRWORK.LT.LRWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -28 + ELSE IF( ( LIWORK.LT.LIWKMIN ) .AND. .NOT.LQUERY ) THEN + INFO = -30 + END IF + END IF +* + IF( INFO.EQ.0 ) THEN + WORK( 1 ) = DCMPLX( LWKOPT ) + RWORK( 1 ) = DBLE( LRWKOPT ) + IWORK( 1 ) = LIWKOPT + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'ZGECXX', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* +* ================================================================== +* +* Quick return if possible for: +* a) M = 0 or N = 0. There is no matrix A(1:M,1:N). +* b) MSUB = 0 or NSUB = 0. There is no matrix A_sub(1:MSUB,1:NSUB). +* NOTE: min( M, N) = 0 implies min( MSUB, NSUB) = 0. +* We need to return correct values for all scalar output parameters, +* (including WORK(1) and IWORK(1), which are set above). +* + IF( MIN( MSUB, NSUB ).EQ.0 ) THEN + K = 0 + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO + FNRMK = ZERO + RETURN + END IF +* +* ================================================================== +* + K = 0 +* +* If we need to return factor X, copy the original untouched matrix +* A into the array X. +* + IF( RETURNX ) THEN + CALL ZLACPY( 'F', M, N, A, LDA, X, LDX ) + END IF +* +* If we need to return the factor C, copy the original matrix A +* into the array C, only if do not return the factor X. In this +* case, we need to choose the columns of the matrix A in the array C +* in place, otherwise we can copy the columns of the matrix A from +* the array X. +* + IF( RETURNC .AND. .NOT. RETURNX ) THEN + CALL ZLACPY( 'F', M, N, A, LDA, C, LDC ) + END IF +* +* ================================================================== +* Permute the deselected rows to the bottom of the matrix A. +* 1) The initial order of included rows in their block is preserved. +* 2) The initial order of deselected rows in their block is not +* preserved. +* ================================================================== +* +* I is an index of DESEL_ROWS array and a row index of +* the matrix A. MSUB is the number of processed included rows, which +* is also an index pointer to the last included row in the matrix A. +* We can think of I as a row source index, and MSUB as a destination +* index for moving an included row in the matrix A. +* +* ( We start with MSUB = 0. We loop over index I in (1:M), and +* for each position I in DESEL_ROWS array, we check if the row at +* the position I in the matrix A is an included row (not -1 value). +* If it is an included row, we increment MSUB pointer, otherwise +* we do not change MSUB index pointer. Then, we bring this included +* row from the index I in the matrix A into smaller (or same) +* MSUB index in the matrix A. If I = MSUB, then the included row +* is already in place. Due to row swap, the deselected row +* at MSUB index will move into I index in the matrix A. In this way, +* we move all the included rows to the top matrix block preserving +* their initial order within the included block. The initial order +* of deselected rows will not be preserved within their block. +* + IF( USE_DESEL_ROWS ) THEN +* + MSUB = 0 + DO I = 1, M, 1 +* +* Initialize the row pivot array IPIV. + IPIV( I ) = I +* +* The row at the index I is an included row and should be +* moved to the top of the matrix A. +* + IF( DESEL_ROWS( I ).NE.-1 ) THEN + MSUB = MSUB + 1 +* +* This is a check whether the included row is +* on the included place already. +* + IF( I.NE.MSUB ) THEN +* +* Here, we swap A(I,1:N) into A(MSUB,1:N). +* + CALL ZSWAP( N, A( I, 1 ), LDA, A( MSUB, 1 ), LDA ) +* +* Save the interchange. +* + IPIV( I ) = IPIV( MSUB ) + IPIV( MSUB ) = I + DESEL_ROWS( MSUB ) = DESEL_ROWS( I ) + DESEL_ROWS( I ) = -1 + END IF + END IF +* + END DO +* + ELSE +* +* We do not use the row deselection DESEL_ROWS array. +* Initialize the row pivot array IPIV. +* NOTE: MSUB=M has default value, +* which is set at the beginning of the routine, before argument +* checks. +* + DO I = 1, M, 1 + IPIV( I ) = I + END DO + END IF +* +* ================================================================== +* Permute the preselected columns to the left and deselected +* columns to the right of the matrix A. +* 1) The order of preselected columns is preserved. +* 2) The order of free columns is not preserved. +* 3) The order of deselected columns is not preserved. +* ================================================================== +* +* J is the index of SEL_DESEL_COLS array and column J +* of the matrix A. +* + IF( USE_SEL_DESEL_COLS ) THEN +* +* Column selection. +* NSEL is the number of selected columns, also the pointer to +* the last selected column. +* + NSEL = 0 + DO J = 1, N, 1 +* +* Initialize column pivot array JPIV. + JPIV( J ) = J +* + IF( SEL_DESEL_COLS( J ).EQ.1 ) THEN + NSEL = NSEL + 1 +* +* This is the check whether the selected column is +* on the selected place already. +* + IF( J.NE.NSEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,NSEL) +* + CALL ZSWAP( M, A( 1, J ), 1, A( 1, NSEL ), 1 ) + JPIV( J ) = JPIV( NSEL ) + JPIV( NSEL ) = J + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( NSEL ) + SEL_DESEL_COLS( NSEL ) = 1 + END IF + END IF + END DO +* +* Column deselection. +* JDESEL the pointer to the last +* deselected column counting right-to-left. +* + JDESEL = N+1 + DO J = N, NSEL+1, -1 + IF( SEL_DESEL_COLS( J ).EQ.-1 ) THEN + JDESEL = JDESEL - 1 +* +* This is the check whether the deselected column is +* on the deselected place already. +* + IF( J.NE.JDESEL ) THEN +* +* Here, we swap the column A(1:M,J) into A(1:M,JDESEL) +* + CALL ZSWAP( M, A( 1, J ), 1, A( 1, JDESEL ), 1 ) + ITEMP = JPIV( J ) + JPIV( J ) = JPIV( JDESEL ) + JPIV( JDESEL ) = ITEMP + SEL_DESEL_COLS( J ) = SEL_DESEL_COLS( JDESEL ) + SEL_DESEL_COLS( JDESEL ) = -1 + END IF + END IF + END DO +* + NSUB = JDESEL - 1 +* + ELSE +* +* We do not use the column selection deselection +* SEL_DESEL_COLS array. +* Initialize column pivot array JPIV. +* NOTE: NSUB=N has default value, +* which is set at the beginning of the routine, before argument +* checks. +* + DO J = 1, N, 1 + JPIV( J ) = J + END DO +* + END IF +* +* ================================================================== +* Compute the complete column 2-norms of the submatrix +* A_sub = A(1:MSUB, 1:NSUB) and store them in WORK(1:NSUB). +* + DO J = 1, NSUB + RWORK( J ) = DZNRM2( MSUB, A( 1, J ), 1 ) + END DO +* +* Compute the column index of the maximum column 2-norm and +* the maximum column 2-norm itself for the submatrix +* A_sub = A(1:MSUB, 1:NSUB). +* + KP0 = IZAMAX( NSUB, WORK( 1 ), 1 ) + MAXC2NRM = RWORK( KP0 ) +* +* ================================================================== +* Process preselected columns +* +* Compute the QR factorization of NSEL preselected columns (1:NSEL) +* in the submatrix A_sub = A(1:MSUB, 1:NSUB) and update +* remaining NFREE free columns (NSEL+1:NSUB). +* NSUB = NSEL + NFREE +* + IF( NSEL.GT.0 ) THEN +* +* Case (a): MSUB < NSEL. +* +* This is handled at the argument check stage in the +* beginning of the routine. When the number of preselected +* columns is larger than MSUB, hence the factorization of +* all NSEL columns cannot be completed. Return from the +* routine with the error of COL_SEL_DESEL parameter. +* +* Case (b): MSUB = NSEL. +* Case (c-1): MSUB > NSEL and NSEL = NSUB. +* +* For cases (b) and (c-1), there will be no residual +* submatrix after factorization of NSEL columns +* at step K = NSEL: +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB). +* +* Case (c-2): MSUB > NSEL and NSEL < NSUB. +* +* For Case (c-2) is a submatrix residual at step K=NSEL +* A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB) +* + CALL ZGEQRF( MSUB, NSEL, A, LDA, TAU, WORK, LWORK, IINFO ) +* +* Apply Q**T from the left to A(NSEL+1:MSUB, NSEL+1:NSUB) +* + IF( NFREE.GT.0 ) THEN +* +* This is only for case (c-2) ('L' = Left, 'T' = Transpose) +* + CALL ZUNMQR( 'L', 'C', MSUB, NFREE, NSEL, + $ A, LDA, TAU, A( 1, NSEL+1 ), LDA, WORK, + $ LWORK, IINFO ) + END IF +* + K = K + NSEL +* +* End of IF(NSEL.GT.0) +* + END IF +* +* ================================================================== +* + KFREE = 0 +* + IF( MINMNFREE.NE.0 ) THEN +* +* Factorize NFREE free columns of +* A_free = A_sub_resid(NSEL) = A(NSEL+1:MSUB, NSEL+1:NSUB), +* KFREE is the number of columns that were actually factorized +* among NFREE columns. +* +* ================================================================== +* + EPS = DLAMCH('Epsilon') +* + USETOL = .FALSE. +* +* Adjust ABSTOL only if nonnegative. Negative value means disabled. +* We need to keep negative value for later use in criterion +* check. +* + IF( ABSTOL.GE.ZERO ) THEN + SAFMIN = DLAMCH('Safe minimum') + ABSTOL = MAX( ABSTOL, TWO*SAFMIN ) + USETOL = .TRUE. + END IF +* +* Adjust RELTOL only if nonnegative. Negative value means disabled. +* We need to keep negative value for later use in criterion +* check. +* + IF( RELTOL.GE.ZERO ) THEN + RELTOL = MAX( RELTOL, EPS ) + USETOL = .TRUE. + END IF +* +* ================================================================== +* +* Disable RELTOLFREE when calling ZGEQP3RK for free columns +* factorization, since ZGEQP3RK expects RELTOLFREE with respect +* to the residual matrix A_sub_resid(NSEL), not the whole +* original matrix A. We can use RELTOL criterion by passing it +* to ABSTOLFREE as RELTOL*MAXC2NRM. We need to make sure that +* the negative values of ABSTOL and RELTOL are propagated +* to ABSTOLFREE and RELTOLFREE, since negative values means +* that the criterion is disabled. +* + IF( USETOL ) THEN + ABSTOLFREE = MAX( ABSTOL, RELTOL * MAXC2NRM ) + ELSE + ABSTOLFREE = MINUSONE + END IF + RELTOLFREE = MINUSONE +* +* Save JPIV(NSEL+1:NSUB) into WORK(NFREE+1:2*NFREE-1) +* + IF( NSEL.NE.0 ) THEN + DO J = 1, NFREE, 1 + IWORK( NFREE + J ) = JPIV( NSEL+J ) + END DO + END IF +* + CALL ZGEQP3RK( MFREE, NFREE, 0, KMAXFREE, + $ ABSTOLFREE, RELTOLFREE, + $ A( NSEL+1, NSEL+1 ), LDA, KFREE, MAXC2NRMKFREE, + $ RELMAXC2NRMKFREE, JPIV( NSEL+1 ), + $ TAU( NSEL+1 ), WORK, LWORK, RWORK, IWORK, + $ IINFO ) +* +* Adjust JPIV +* + IF( NSEL.NE.0 ) THEN + DO J = 1, NFREE, 1 + JPIV( NSEL+J ) = IWORK( NFREE + JPIV( NSEL+J ) ) + END DO + END IF +* +* 1) Adjust the return value for the number of factorized +* columns K for the whole submatrix A_sub. +* 2) MAXC2NRMK is returned transparently without change +* as MAXC2NRMKFREE is returned from ZGEQP3RK. +* 3) Adjust the return value RELMAXC2NRMK for the whole +* submatrix A_sub. We do not use RELMAXC2NRMKFREE +* returned from ZGEQP3RK. +* + K = K + KFREE + MAXC2NRMK = MAXC2NRMKFREE + RELMAXC2NRMK = MAXC2NRMK / MAXC2NRM +* + ELSE +* +* Set norms to zero +* + MAXC2NRMK = ZERO + RELMAXC2NRMK = ZERO +* + END IF +* +* Now, MRESID and NRESID is the number of rows and columns +* respectively in A_free_resid = A(K+1:MSUB,K+1:NSUB). +* + MRESID = MFREE-KFREE + NRESID = NFREE-KFREE +* + IF( MIN( MRESID, NRESID ).NE.0 ) THEN + FNRMK = ZLANGE( 'F', MRESID, NRESID, A( K+1, K+1 ), + $ LDA, WORK ) + ELSE + FNRMK = ZERO + END IF +* +* ================================================================== +* +* Return the matrix C. +* + IF( RETURNC .AND. K.GT.0 ) THEN +* + IF( RETURNX ) THEN +* +* Copy the selected K columns of the original matrix A (that was +* saved into the array X) into the array C according to +* the pivot array JPIV. If we return X, then the matrix A is +* saved in the array X, and it is faster to copy into C than +* doing column permutation in place, as it is the ELSE case. +* + DO J = 1, K, 1 + CALL ZCOPY( M, X( 1, JPIV( J ) ), 1, C( 1, J ), 1 ) + END DO +* + ELSE +* +* Swap the columns of the original matrix A copied into +* the array C in place. +* +* The original M-by-N matrix A was copied into the array C at +* the beginning of the routine, if RETURNC = .TRUE.. + +* Apply the column permutation matrix P stored in JPIV(1:K) +* to the columns 1:K in the M-by-N array C in place. +* After column interchanges, the first K columns of C should +* be the same as the first K columns of A*P, i.e. +* (A*P)(1:M,1:K) = C(1:M,1:K). The complexity of this algorithm +* is min(K,N-1). +* +* Index I is the original column index in the +* array C before interchanges. +* J is the current column index of the original column I at +* each step of interchanges. +* +* Auxiliary array IWORK(1:N) stores the inverse P_inv(J) +* of the current column permutation matrix P(J) at each +* column interchange step J only for the array +* values >= J:N. +* C_prev = P_inv(J) * C_next. +* Each IWORK(I) contains JJ corresponding to I +* Initialize IWORK(1:N) as (1:N). +* + DO I = 1, N, 1 + IWORK( I ) = I + END DO +* +* Auxiliary array IWORK(N+1:2N) stores the current column +* permutation matrix P_(J) at each column interchange step J +* only for the array index >= J:N. +* C_prev * P_(J) = C_next. +* Each IWORK(N+JJ) contains I corresponding to JJ. +* Initialize IWORK(N+1:2*N) as (1:N). +* + DO J = 1, N, 1 + IWORK( N + J ) = J + END DO +* +* Loop over the columns J = ( 1:min( K, N-1 ) ) in C. +* + DO J = 1, MIN( K, N-1 ), 1 +* +* IP is the original pivot column, i.e. is the original +* column that should be placed in the current column index +* J in the array C. +* + IP = JPIV( J ) +* +* I is the original column that is +* currently in the column index J in the array C after +* previous column interchanges. +* + I = IWORK( N+J ) +* + IF( I.NE.IP ) THEN +* +* JP is the current index of the original pivot +* column IP in the array C after previous column +* interchanges. +* + JP = IWORK( IP ) + +* Swap the original pivot column IP = JPIV( J ), +* at the current pivot index JP = IWORK( IP ) into +* index J. +* + CALL ZSWAP( M, C( 1, J ), 1, C( 1, JP ), 1 ) +* +* Update the array IWORK(1:N) for the original column +* I that was swapped with IP. +* + IWORK( I ) = IWORK( IP ) +* +* Update the array IWORK(N+1:2*N) for the current column +* index JP that was swapped with the current column +* index J. +* + IWORK( N + JP ) = IWORK( N + J ) +* + END IF +* + END DO +* +* End of ELSE( RETURNX ) +* + END IF +* +* End of IF( RETURNC .AND. K.GT.0 ) +* + END IF +* +* ================================================================== +* +* Return the matrix X. +* + IF( RETURNX .AND. K.GT.0 ) THEN +* +* We need to use C and A to compute X = pseudoinv(C) * A, as +* the linear least squares solution to the overdetermined system +* C*X = A. We use LLS routine that uses the QR factorization. For +* that purpose, we store the matrix C into the array QRC. +* The matrix A was copied into the array X at the beginning +* of the routine. +* + CALL ZLACPY( 'F', M, K, C, LDC, QRC, LDQRC ) +* + CALL ZGELS( 'N', M, K, N, QRC, LDQRC, X, LDX, + $ WORK, LWORK, IINFO ) + INFO = IINFO +* + END IF +* + WORK( 1 ) = DCMPLX( LWKOPT ) + RWORK( 1 ) = DBLE( LRWKOPT ) + IWORK( 1 ) = LIWKOPT +* +* End of ZGECXX +* + END diff --git a/lapack-netlib/TESTING/LIN/CMakeLists.txt b/lapack-netlib/TESTING/LIN/CMakeLists.txt index 95baa31229..3dac38784b 100644 --- a/lapack-netlib/TESTING/LIN/CMakeLists.txt +++ b/lapack-netlib/TESTING/LIN/CMakeLists.txt @@ -9,15 +9,15 @@ set(DZLNTST dlaord.f) set(SLINTST schkaa.F schkeq.f schkgb.f schkge.f schkgt.f schklq.f schkpb.f schkpo.f schkps.f schkpp.f - schkpt.f schkq3.f schkqp3rk.f schkql.f schkqr.f schkrq.f - schksp.f schksy.f schksy_rook.f schksy_rk.f - schksy_aa.f schksy_aa_2stage.f + schkpt.f schkq3.f schkqp3rk.f schkcxx.f schkql.f schkqr.f schkrq.f + schksp.f schksy.f schksy_rook.f schksy_rk.f + schksy_aa.f schksy_aa_2stage.f schktb.f schktp.f schktr.f schktz.f sdrvgt.f sdrvls.f sdrvpb.f - sdrvpp.f sdrvpt.f sdrvsp.f sdrvsy_rook.f sdrvsy_rk.f + sdrvpp.f sdrvpt.f sdrvsp.f sdrvsy_rook.f sdrvsy_rk.f sdrvsy_aa.f sdrvsy_aa_2stage.f - serrgt.f serrlq.f serrls.f + serrcxx.f serrgt.f serrlq.f serrls.f serrps.f serrql.f serrqp.f serrqr.f serrrq.f serrtr.f serrtz.f sgbt01.f sgbt02.f sgbt05.f sgeqls.f @@ -32,7 +32,7 @@ set(SLINTST schkaa.F sqrt01.f sqrt01p.f sqrt02.f sqrt03.f sqrt11.f sqrt12.f sqrt13.f sqrt14.f sqrt15.f sqrt16.f sqrt17.f srqt01.f srqt02.f srqt03.f srzt01.f srzt02.f - sspt01.f ssyt01.f ssyt01_rook.f ssyt01_3.f + sspt01.f ssyt01.f ssyt01_rook.f ssyt01_3.f ssyt01_aa.f stbt02.f stbt03.f stbt05.f stbt06.f stpt01.f stpt02.f stpt03.f stpt05.f stpt06.f strt01.f @@ -53,21 +53,21 @@ endif() set(CLINTST cchkaa.F cchkeq.f cchkgb.f cchkge.f cchkgt.f - cchkhe.f cchkhe_rook.f cchkhe_rk.f + cchkhe.f cchkhe_rook.f cchkhe_rk.f cchkhe_aa.f cchkhe_aa_2stage.f cchkhp.f cchklq.f cchkpb.f - cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkqp3rk.f cchkql.f + cchkpo.f cchkps.f cchkpp.f cchkpt.f cchkq3.f cchkqp3rk.f cchkcxx.f cchkql.f cchkqr.f cchkrq.f cchksp.f cchksy.f cchksy_rook.f cchksy_rk.f cchksy_aa.f cchksy_aa_2stage.f cchktb.f cchktp.f cchktr.f cchktz.f - cdrvgt.f cdrvhe_rook.f cdrvhe_rk.f + cdrvgt.f cdrvhe_rook.f cdrvhe_rk.f cdrvhe_aa.f cdrvhe_aa_2stage.f cdrvsy_aa_2stage.f cdrvhp.f cdrvls.f cdrvpb.f cdrvpp.f cdrvpt.f - cdrvsp.f cdrvsy_rook.f cdrvsy_rk.f - cdrvsy_aa.f - cerrgt.f cerrlq.f + cdrvsp.f cdrvsy_rook.f cdrvsy_rk.f + cdrvsy_aa.f + cerrcxx.f cerrgt.f cerrlq.f cerrls.f cerrps.f cerrql.f cerrqp.f cerrqr.f cerrrq.f cerrtr.f cerrtz.f cgbt01.f cgbt02.f cgbt05.f cgeqls.f @@ -87,7 +87,7 @@ set(CLINTST cchkaa.F cqrt17.f crqt01.f crqt02.f crqt03.f crzt01.f crzt02.f csbmv.f cspt01.f cspt02.f cspt03.f csyt01.f csyt01_rook.f csyt01_3.f - csyt01_aa.f + csyt01_aa.f csyt02.f csyt03.f ctbt02.f ctbt03.f ctbt05.f ctbt06.f ctpt01.f ctpt02.f ctpt03.f ctpt05.f ctpt06.f ctrt01.f @@ -110,15 +110,15 @@ endif() set(DLINTST dchkaa.F dchkeq.f dchkgb.f dchkge.f dchkgt.f dchklq.f dchkpb.f dchkpo.f dchkps.f dchkpp.f - dchkpt.f dchkq3.f dchkqp3rk.f dchkql.f dchkqr.f dchkrq.f - dchksp.f dchksy.f dchksy_rook.f dchksy_rk.f + dchkpt.f dchkq3.f dchkqp3rk.f dchkcxx.f dchkql.f dchkqr.f + dchkrq.f dchksp.f dchksy.f dchksy_rook.f dchksy_rk.f dchksy_aa.f dchksy_aa_2stage.f dchktb.f dchktp.f dchktr.f dchktz.f ddrvgt.f ddrvls.f ddrvpb.f - ddrvpp.f ddrvpt.f ddrvsp.f ddrvsy_rook.f ddrvsy_rk.f + ddrvpp.f ddrvpt.f ddrvsp.f ddrvsy_rook.f ddrvsy_rk.f ddrvsy_aa.f ddrvsy_aa_2stage.f - derrgt.f derrlq.f derrls.f + derrcxx.f derrgt.f derrlq.f derrls.f derrps.f derrql.f derrqp.f derrqr.f derrrq.f derrtr.f derrtz.f dgbt01.f dgbt02.f dgbt05.f dgeqls.f @@ -155,21 +155,21 @@ endif() set(ZLINTST zchkaa.F zchkeq.f zchkgb.f zchkge.f zchkgt.f - zchkhe.f zchkhe_rook.f zchkhe_rk.f + zchkhe.f zchkhe_rook.f zchkhe_rk.f zchkhe_aa.f zchkhe_aa_2stage.f zchkhp.f zchklq.f zchkpb.f - zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkqp3rk.f zchkql.f - zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_rook.f zchksy_rk.f + zchkpo.f zchkps.f zchkpp.f zchkpt.f zchkq3.f zchkqp3rk.f zchkcxx.f + zchkql.f zchkqr.f zchkrq.f zchksp.f zchksy.f zchksy_rook.f zchksy_rk.f zchksy_aa.f zchksy_aa_2stage.f zchktb.f zchktp.f zchktr.f zchktz.f - zdrvgt.f zdrvhe_rook.f zdrvhe_rk.f + zdrvgt.f zdrvhe_rook.f zdrvhe_rk.f zdrvhe_aa.f zdrvhe_aa_2stage.f zdrvhp.f zdrvls.f zdrvpb.f zdrvpp.f zdrvpt.f - zdrvsp.f zdrvsy_rook.f zdrvsy_rk.f - zdrvsy_aa.f zdrvsy_aa_2stage.f - zerrgt.f zerrlq.f + zdrvsp.f zdrvsy_rook.f zdrvsy_rk.f + zdrvsy_aa.f zdrvsy_aa_2stage.f + zerrcxx.f zerrgt.f zerrlq.f zerrls.f zerrps.f zerrql.f zerrqp.f zerrqr.f zerrrq.f zerrtr.f zerrtz.f zgbt01.f zgbt02.f zgbt05.f zgeqls.f @@ -240,7 +240,6 @@ set(ZLINTSTRFP zchkrfp.f zdrvrfp.f zdrvrf1.f zdrvrf2.f zdrvrf3.f zdrvrf4.f zerrr macro(add_lin_executable name) add_executable(${name} ${ARGN}) target_link_libraries(${name} ${LIBNAMEPREFIX}openblas${LIBNAMESUFFIX}${SUFFIX64_UNDERSCORE}) -#${TMGLIB} ${LAPACK_LIBRARIES} ${BLAS_LIBRARIES}) endmacro() if(BUILD_SINGLE) diff --git a/lapack-netlib/TESTING/LIN/Makefile b/lapack-netlib/TESTING/LIN/Makefile index 714efa52a1..94fef302ec 100644 --- a/lapack-netlib/TESTING/LIN/Makefile +++ b/lapack-netlib/TESTING/LIN/Makefile @@ -45,14 +45,14 @@ DZLNTST = dlaord.o SLINTST = schkaa.o \ schkeq.o schkgb.o schkge.o schkgt.o \ schklq.o schkpb.o schkpo.o schkps.o schkpp.o \ - schkpt.o schkq3.o schkqp3rk.o schkql.o schkqr.o schkrq.o \ + schkpt.o schkq3.o schkqp3rk.o schkcxx.o schkql.o schkqr.o schkrq.o \ schksp.o schksy.o schksy_rook.o schksy_rk.o \ schksy_aa.o schksy_aa_2stage.o schktb.o schktp.o schktr.o \ schktz.o \ sdrvgt.o sdrvls.o sdrvpb.o \ sdrvpp.o sdrvpt.o sdrvsp.o sdrvsy_rook.o sdrvsy_rk.o \ sdrvsy_aa.o sdrvsy_aa_2stage.o \ - serrgt.o serrlq.o serrls.o \ + serrcxx.o serrgt.o serrlq.o serrls.o \ serrps.o serrql.o serrqp.o serrqr.o \ serrrq.o serrtr.o serrtz.o \ sgbt01.o sgbt02.o sgbt05.o sgeqls.o \ @@ -89,7 +89,7 @@ CLINTST = cchkaa.o \ cchkeq.o cchkgb.o cchkge.o cchkgt.o \ cchkhe.o cchkhe_rook.o cchkhe_rk.o \ cchkhe_aa.o cchkhe_aa_2stage.o cchkhp.o cchklq.o cchkpb.o \ - cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkqp3rk.o cchkql.o \ + cchkpo.o cchkps.o cchkpp.o cchkpt.o cchkq3.o cchkqp3rk.o cchkcxx.o cchkql.o \ cchkqr.o cchkrq.o cchksp.o cchksy.o cchksy_rook.o cchksy_rk.o \ cchksy_aa.o cchksy_aa_2stage.o cchktb.o \ cchktp.o cchktr.o cchktz.o \ @@ -97,7 +97,7 @@ CLINTST = cchkaa.o \ cdrvhe_aa_2stage.o \ cdrvls.o cdrvpb.o cdrvpp.o cdrvpt.o \ cdrvsp.o cdrvsy_rook.o cdrvsy_rk.o cdrvsy_aa.o cdrvsy_aa_2stage.o \ - cerrgt.o cerrlq.o \ + cerrcxx.o cerrgt.o cerrlq.o \ cerrls.o cerrps.o cerrql.o cerrqp.o \ cerrqr.o cerrrq.o cerrtr.o cerrtz.o \ cgbt01.o cgbt02.o cgbt05.o cgeqls.o \ @@ -137,14 +137,14 @@ endif DLINTST = dchkaa.o \ dchkeq.o dchkgb.o dchkge.o dchkgt.o \ dchklq.o dchkpb.o dchkpo.o dchkps.o dchkpp.o \ - dchkpt.o dchkq3.o dchkqp3rk.o dchkql.o dchkqr.o dchkrq.o \ - dchksp.o dchksy.o dchksy_rook.o dchksy_rk.o \ + dchkpt.o dchkq3.o dchkqp3rk.o dchkcxx.o dchkql.o dchkqr.o \ + dchkrq.o dchksp.o dchksy.o dchksy_rook.o dchksy_rk.o \ dchksy_aa.o dchksy_aa_2stage.o dchktb.o dchktp.o dchktr.o \ dchktz.o \ ddrvgt.o ddrvls.o ddrvpb.o \ ddrvpp.o ddrvpt.o ddrvsp.o ddrvsy_rook.o ddrvsy_rk.o \ ddrvsy_aa.o ddrvsy_aa_2stage.o \ - derrgt.o derrlq.o derrls.o \ + derrcxx.o derrgt.o derrlq.o derrls.o \ derrps.o derrql.o derrqp.o derrqr.o \ derrrq.o derrtr.o derrtz.o \ dgbt01.o dgbt02.o dgbt05.o dgeqls.o \ @@ -182,14 +182,14 @@ ZLINTST = zchkaa.o \ zchkeq.o zchkgb.o zchkge.o zchkgt.o \ zchkhe.o zchkhe_rook.o zchkhe_rk.o zchkhe_aa.o zchkhe_aa_2stage.o \ zchkhp.o zchklq.o zchkpb.o \ - zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkqp3rk.o zchkql.o \ + zchkpo.o zchkps.o zchkpp.o zchkpt.o zchkq3.o zchkqp3rk.o zchkcxx.o zchkql.o \ zchkqr.o zchkrq.o zchksp.o zchksy.o zchksy_rook.o zchksy_rk.o \ zchksy_aa.o zchksy_aa_2stage.o zchktb.o \ zchktp.o zchktr.o zchktz.o \ zdrvgt.o zdrvhe_rook.o zdrvhe_rk.o zdrvhe_aa.o zdrvhe_aa_2stage.o zdrvhp.o \ zdrvls.o zdrvpb.o zdrvpp.o zdrvpt.o \ zdrvsp.o zdrvsy_rook.o zdrvsy_rk.o zdrvsy_aa.o zdrvsy_aa_2stage.o \ - zerrgt.o zerrlq.o \ + zerrcxx.o zerrgt.o zerrlq.o \ zerrls.o zerrps.o zerrql.o zerrqp.o \ zerrqr.o zerrrq.o zerrtr.o zerrtz.o \ zgbt01.o zgbt02.o zgbt05.o zgeqls.o \ @@ -268,37 +268,37 @@ proto-single: xlintstrfs proto-double: xlintstds xlintstrfd proto-complex: xlintstrfc proto-complex16: xlintstzc xlintstrfz - + xlintsts: $(ALINTST) $(SLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ - + xlintstc: $(ALINTST) $(CLINTST) $(SCLNTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ - + xlintstd: $(ALINTST) $(DLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ - + xlintstz: $(ALINTST) $(ZLINTST) $(DZLNTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(XBLASLIB) $(BLASLIB) $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ - + xlintstds: $(DSLINTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ - + xlintstzc: $(ZCLINTST) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ - + xlintstrfs: $(SLINTSTRFP) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ - + xlintstrfd: $(DLINTSTRFP) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ - + xlintstrfc: $(CLINTSTRFP) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ - + xlintstrfz: $(ZLINTSTRFP) $(TMGLIB) $(VARLIB) ../$(LAPACKLIB) $(BLASLIB) $(LOADER) $(FFLAGS) $(LDFLAGS) -o $@ $^ - + $(ALINTST): $(FRC) $(SCLNTST): $(FRC) $(DZLNTST): $(FRC) diff --git a/lapack-netlib/TESTING/LIN/alaerh.f b/lapack-netlib/TESTING/LIN/alaerh.f index 6c8a47f1e2..7c4f7a431c 100644 --- a/lapack-netlib/TESTING/LIN/alaerh.f +++ b/lapack-netlib/TESTING/LIN/alaerh.f @@ -144,6 +144,7 @@ * ===================================================================== SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, $ N5, IMAT, NFAIL, NERRS, NOUT ) + IMPLICIT NONE * * -- LAPACK test routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -809,6 +810,18 @@ SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, WRITE( NOUT, FMT = 9978 ) $ SUBNAM(1:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT END IF +* + ELSE IF( LSAMEN( 2, P2, 'CX' ) ) THEN +* +* xCX: CX decomposition +* + IF( LSAMEN( 7, SUBNAM( 2: 8 ), 'GECXX' ) ) THEN + WRITE( NOUT, FMT = 9930 ) + $ 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:LEN_TRIM( SUBNAM )), INFO, M, N, IMAT + END IF * ELSE IF( LSAMEN( 2, P2, 'LQ' ) ) THEN * @@ -1160,7 +1173,7 @@ SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU, * 9949 FORMAT( ' ==> Doing only the condition estimate for this case' ) * -* SUBNAM, INFO, M, N, NB, IMAT +* SUBNAM, INFO, M, N, NX, NB, IMAT * 9930 FORMAT( ' *** Error code from ', A, '=', I5, / ' ==> M =', I5, $ ', N =', I5, ', NX =', I5, ', NB =', I4, ', type ', I2 ) diff --git a/lapack-netlib/TESTING/LIN/alahd.f b/lapack-netlib/TESTING/LIN/alahd.f index c0334b5de9..b04a3f7961 100644 --- a/lapack-netlib/TESTING/LIN/alahd.f +++ b/lapack-netlib/TESTING/LIN/alahd.f @@ -75,6 +75,8 @@ *> _TP: Triangular packed *> _TB: Triangular band *> _QR: QR (general matrices) +*> _QK: truncated QR decomposition with column pivoting +*> _CX: CX decomposition *> _LQ: LQ (general matrices) *> _QL: QL (general matrices) *> _RQ: RQ (general matrices) @@ -104,6 +106,7 @@ * * ===================================================================== SUBROUTINE ALAHD( IOUNIT, PATH ) + IMPLICIT NONE * * -- LAPACK test routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -605,6 +608,19 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) WRITE( IOUNIT, FMT = 8063 )4 WRITE( IOUNIT, FMT = 8064 )5 WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) + + ELSE IF( LSAMEN( 2, P2, 'CX' ) ) THEN +* +* CX decomposition +* + WRITE( IOUNIT, FMT = 8007 )PATH + WRITE( IOUNIT, FMT = 9871 ) + WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' ) + WRITE( IOUNIT, FMT = 8060 )1 + WRITE( IOUNIT, FMT = 8061 )2 + WRITE( IOUNIT, FMT = 8062 )3 + WRITE( IOUNIT, FMT = 8063 )4 + WRITE( IOUNIT, FMT = '( '' Messages:'' )' ) * ELSE IF( LSAMEN( 2, P2, 'TZ' ) ) THEN * @@ -795,6 +811,7 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) $ ' factorization output ', /,' for tall-skinny matrices.' ) 8006 FORMAT( / 1X, A3, ': truncated QR factorization', $ ' with column pivoting' ) + 8007 FORMAT( / 1X, A3, ': CX decomposition' ) * * GE matrix types * @@ -941,28 +958,42 @@ SUBROUTINE ALAHD( IOUNIT, PATH ) * QK matrix types * 9871 FORMAT( 4X, ' 1. Zero matrix', / - $ 4X, ' 2. Random, Diagonal, CNDNUM = 2', / - $ 4X, ' 3. Random, Upper triangular, CNDNUM = 2', / - $ 4X, ' 4. Random, Lower triangular, CNDNUM = 2', / - $ 4X, ' 5. Random, First column is zero, CNDNUM = 2', / - $ 4X, ' 6. Random, Last MINMN column is zero, CNDNUM = 2', / - $ 4X, ' 7. Random, Last N column is zero, CNDNUM = 2', / + $ 4X, ' 2. Random, Diagonal, CNDNUM = 2, NORM = 1', / + $ 4X, ' 3. Random, Upper triangular, CNDNUM = 2,', + $ ' NORM = 1', / + $ 4X, ' 4. Random, Lower triangular, CNDNUM = 2,', + $ ' NORM = 1', / + $ 4X, ' 5. Random, First column is zero, CNDNUM = 2,', + $ ' NORM = 1', / + $ 4X, ' 6. Random, Last MINMN column is zero, CNDNUM = 2,', + $ ' NORM = 1', / + $ 4X, ' 7. Random, Last N column is zero, CNDNUM = 2,', + $ ' NORM = 1', / $ 4X, ' 8. Random, Middle column in MINMN is zero,', - $ ' CNDNUM = 2', / - $ 4X, ' 9. Random, First half of MINMN columns are zero,', - $ ' CNDNUM = 2', / + $ ' CNDNUM = 2, NORM = 1', / + $ 4X, ' 9. Random, First half of MINMN columns are zero,', / + $ 4x, ' zero block size MINMN/2, CNDNUM = 2,', + $ ' NORM = 1', / $ 4X, '10. Random, Last columns are zero starting from', - $ ' MINMN/2+1, CNDNUM = 2', / - $ 4X, '11. Random, Half MINMN columns in the middle are', - $ ' zero starting from MINMN/2-(MINMN/2)/2+1,', - $ ' CNDNUM = 2', / - $ 4X, '12. Random, Odd columns are ZERO, CNDNUM = 2', / - $ 4X, '13. Random, Even columns are ZERO, CNDNUM = 2', / - $ 4X, '14. Random, CNDNUM = 2', / - $ 4X, '15. Random, CNDNUM = sqrt(0.1/EPS)', / - $ 4X, '16. Random, CNDNUM = 0.1/EPS', / + $ ' MINMN/2+1 column,', / + $ 4x, ' zero block size N - MINMN/2', + $ ' CNDNUM = 2, NORM = 1', / + $ 4X, '11. Random, Half of MINMN columns in the middle are', + $ ' zero,', / + $ 4X, ' starting from MINMN/2-(MINMN/2)/2+1', + $ ' column,', / + $ 4x, ' zero block size', + $ ' MINMN/2, CNDNUM = 2, NORM = 1', / + $ 4X, '12. Random, Odd columns are ZERO, CNDNUM = 2,', + $ ' NORM = 1', / + $ 4X, '13. Random, Even columns are ZERO, CNDNUM = 2,', + $ ' NORM = 1', / + $ 4X, '14. Random, CNDNUM = 2, NORM = 1', / + $ 4X, '15. Random, CNDNUM = sqrt(0.1/EPS), NORM = 1', / + $ 4X, '16. Random, CNDNUM = 0.1/EPS, NORM = 1', / $ 4X, '17. Random, CNDNUM = 0.1/EPS,', - $ ' one small singular value S(N)=1/CNDNUM', / + $ ' one small singular value S(N)=1/CNDNUM,', + $ ' NORM = 1', / $ 4X, '18. Random, CNDNUM = 2, scaled near underflow,', $ ' NORM = SMALL = SAFMIN', / $ 4X, '19. Random, CNDNUM = 2, scaled near overflow,', diff --git a/lapack-netlib/TESTING/LIN/cchkaa.F b/lapack-netlib/TESTING/LIN/cchkaa.F index a5a3428c14..fa40000506 100644 --- a/lapack-netlib/TESTING/LIN/cchkaa.F +++ b/lapack-netlib/TESTING/LIN/cchkaa.F @@ -70,6 +70,7 @@ *> CQL 8 List types on next line if 0 < NTYPES < 8 *> CQP 6 List types on next line if 0 < NTYPES < 6 *> ZQK 19 List types on next line if 0 < NTYPES < 19 +*> CCX 19 List types on next line if 0 < NTYPES < 19 *> CTZ 3 List types on next line if 0 < NTYPES < 3 *> CLS 6 List types on next line if 0 < NTYPES < 6 *> CEQ @@ -150,13 +151,14 @@ PROGRAM CCHKAA * .. * .. Local Arrays .. LOGICAL DOTYPE( MATMAX ) - INTEGER IWORK( 25*NMAX ), MVAL( MAXIN ), + INTEGER MVAL( MAXIN ), $ NBVAL( MAXIN ), NBVAL2( MAXIN ), $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) * .. * .. Allocatable Arrays .. INTEGER AllocateStatus + INTEGER, DIMENSION(:), ALLOCATABLE :: IWORK REAL, DIMENSION(:), ALLOCATABLE :: RWORK, S COMPLEX, DIMENSION(:), ALLOCATABLE :: E COMPLEX, DIMENSION(:,:), ALLOCATABLE :: A, B, WORK @@ -167,7 +169,8 @@ PROGRAM CCHKAA EXTERNAL LSAME, LSAMEN, SECOND, SLAMCH * .. * .. External Subroutines .. - EXTERNAL ALAREQ, CCHKEQ, CCHKGB, CCHKGE, CCHKGT, CCHKHE, + EXTERNAL ALAREQ, CCHKCXX, + $ CCHKEQ, CCHKGB, CCHKGE, CCHKGT, CCHKHE, $ CCHKHE_ROOK, CCHKHE_RK, CCHKHE_AA, CCHKHP, $ CCHKLQ, CCHKUNHR_COL, CCHKPB, CCHKPO, CCHKPS, $ CCHKPP, CCHKPT, CCHKQ3, CCHKQP3RK, CCHKQL, @@ -177,7 +180,10 @@ PROGRAM CCHKAA $ CDRVHE_ROOK, CDRVHE_RK, CDRVHE_AA, CDRVHP, $ CDRVLS, CDRVPB, CDRVPO, CDRVPP, CDRVPT, CDRVSP, $ CDRVSY, CDRVSY_ROOK, CDRVSY_RK, CDRVSY_AA, - $ ILAVER, CCHKQRT, CCHKQRTP + $ ILAVER, CCHKQRT, CCHKQRTP, + $ CCHKLQT, CCHKLQTP, CCHKTSQR, + $ CCHKHE_AA_2STAGE, CDRVHE_AA_2STAGE, + $ CCHKSY_AA_2STAGE, CDRVSY_AA_2STAGE * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -197,7 +203,9 @@ PROGRAM CCHKAA * .. * .. Allocate memory dynamically .. * - ALLOCATE ( A( ( KDMAX+1 )*NMAX, 7 ), STAT = AllocateStatus ) + ALLOCATE ( IWORK( 34*NMAX ), STAT = AllocateStatus ) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( A( ( KDMAX+1 )*NMAX, 8 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE ( B( NMAX*MAXRHS, 4 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" @@ -1130,6 +1138,30 @@ PROGRAM CCHKAA ELSE WRITE( NOUT, FMT = 9989 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'CX' ) ) THEN +* +* CX: CX decomposition +* + NTYPES = 19 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL CCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, + $ NNB, NBVAL, NXVAL, THRESH, TSTERR, + $ A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), A( 1, 4 ), + $ A( 1, 5 ), A( 1, 6 ), + $ A( 1, 7 ), A( 1, 8 ), + $ S( 1 ), B( 1, 1 ), + $ IWORK( 1 ), IWORK( 1+2*NMAX ), + $ IWORK(1+4*NMAX), IWORK(1+6*NMAX), + $ IWORK(1+8*NMAX), IWORK(1+10*NMAX), + $ IWORK(1+12*NMAX), IWORK(1+14*NMAX), + $ WORK, RWORK, IWORK(1+16*NMAX), NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/cchkcxx.f b/lapack-netlib/TESTING/LIN/cchkcxx.f new file mode 100644 index 0000000000..cba7e91d2e --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cchkcxx.f @@ -0,0 +1,1000 @@ +*> \brief \b CCHKCXX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, +* $ NNB, NBVAL, NXVAL, THRESH, TSTERR, +* $ A, COPYA, +* $ C, COPYC, QRC, COPYQRC, X, COPYX, S, TAU, +* $ DESEL_ROWS, COPY_DESEL_ROWS, +* $ SEL_DESEL_COLS, COPY_SEL_DESEL_COLS, +* $ IPIV, COPY_IPIV, JPIV, COPY_JPIV, +* $ WORK, RWORK, IWORK, NOUT ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), +* $ NXVAL( * ), +* $ DESEL_ROWS( * ), COPY_DESEL_ROWS( * ), +* $ SEL_DESEL_COLS( * ), COPY_SEL_DESEL_COLS( * ), +* $ IPIV( * ), COPY_IPIV( * ), +* $ JPIV( * ), COPY_JPIV( * ) +* REAL RWORK( * ), S( * ) +* COMPLEX A( * ), COPYA( * ), C( * ), COPYC( * ), +* $ QRC( * ), COPYQRC( * ), X( * ), COPYX( * ), +* $ TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CCHKCXX tests CGECXX. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB and NX contained in the +*> vectors NBVAL and NXVAL. The blocking parameters are used +*> in pairs (NB,NX). +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NNB) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NXVAL +*> \verbatim +*> NXVAL is INTEGER array, dimension (NNB) +*> The values of the crossover point NX. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYA +*> \verbatim +*> COPYA is COMPLEX array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYC +*> \verbatim +*> COPYC is COMPLEX array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] QRC +*> \verbatim +*> QRC is COMPLEX array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYQRC +*> \verbatim +*> COPYQRC is COMPLEX array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX array, dimension (NMAX*NMAX) +*> NMAX is the maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYX +*> \verbatim +*> COPYX is COMPLEX array, dimension (NMAX*NMAX) +*> NMAX is the maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is REAL array, dimension +*> (min(MMAX,NMAX)) +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] DESEL_ROWS +*> \verbatim +*> DESEL_ROWS is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] COPY_DESEL_ROWS +*> \verbatim +*> COPY_DESEL_ROWS is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] SEL_DESEL_COLS +*> \verbatim +*> SEL_DESEL_COLS is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] COPY_SEL_DESEL_COLS +*> \verbatim +*> COPY_SEL_DESEL_COLS is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] COPY_IPIV +*> \verbatim +*> COPY_IPIV is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] COPY_JPIV +*> \verbatim +*> COPY_JPIV is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX array. +*> Dimension is the maximum of the following two expressions: +*> (1) Optimal complex workspace dimension for matrix generation +*> and test routines. +*> (MMAX + 3) * max(MMAX,NMAX) +*> This is an upper bound for: +*> a) CLATMS: 3*max(M,N) +*> b) CQRT12: M*N + 2*min(M,N) + max(M,N) +*> c) CQPT01: M*N + N +*> d) CQRT11: M*M + M +*> +*> (2) Optimal complex workspace dimension for CGECXX. +*> max( NMAX*NBMAX, \\ for CGEQRF inside +*> NMAX*min(NBMAX_UNMQR,NBMAX) \\ for CUNMQR inside +*> + (NBMAX_UNMQR+1)*NBMAX_UNMQR ), +*> NBMAX*( NMAX + 1 ), \\ for CGEQP3RK inside +*> min(MMAX,NMAX) + NMAX*NBMAX ) \\ for CGELS inside +*> where NBMAX_UNMQR=64 is hardwired in CUNMQR. +*> +*> Assuming MMAX = NMAX, and NBMAX = NMAX, the expressions become: +*> (1) NMAX*NMAX + 3*NMAX +*> (2) NMAX * min(64,NMAX) + 4160 +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is REAL array, dimension (2*NMAX) +*> +*> Dimension is the maximum of the following two expressions: +*> (1) Optimal real workspace dimension for matrix generation and test routines. +*> 2*min(MMAX,NMAX) +*> This is an upper bound for CQRT12 routine 2*min(M,N). +*> +*> (2) Optimal real workspace dimension for CGECXX. +*> 2*NMAX +*> This is an upper bound for CGEQP3RK routine 2*N. +*> +*> Assuming MMAX = NMAX, the expressions (1) anf (2) become 2*NMAX. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> for CGECXX optimal IWORK size. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, + $ NNB, NBVAL, NXVAL, THRESH, TSTERR, + $ A, COPYA, + $ C, COPYC, QRC, COPYQRC, X, COPYX, S, TAU, + $ DESEL_ROWS, COPY_DESEL_ROWS, + $ SEL_DESEL_COLS, COPY_SEL_DESEL_COLS, + $ IPIV, COPY_IPIV, JPIV, COPY_JPIV, + $ WORK, RWORK, IWORK, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), + $ NXVAL( * ), + $ DESEL_ROWS( * ), COPY_DESEL_ROWS( * ), + $ SEL_DESEL_COLS( * ), COPY_SEL_DESEL_COLS( * ), + $ IPIV( * ), COPY_IPIV( * ), + $ JPIV( * ), COPY_JPIV( * ) + REAL RWORK( * ), S( * ) + COMPLEX A( * ), COPYA( * ), C( * ), COPYC( * ), + $ QRC( * ), COPYQRC( * ), X( * ), COPYX( * ), + $ TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTYPES + PARAMETER ( NTYPES = 19 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 5 ) + REAL ONE, ZERO, BIGNUM + COMPLEX CZERO + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, + $ CZERO = ( 0.0E+0, 0.0E+0 ), + $ BIGNUM = 1.0E+38 ) +* .. +* .. Local Scalars .. + CHARACTER DIST, TYPE, FACT, USESD + CHARACTER*3 PATH + INTEGER I, IM, IMAT, IN, INB, IND_OFFSET_GEN, + $ IND_IN, IND_OUT, INFO, J, J_INC, J_FIRST_NZ, + $ JB_ZERO, K, KL, KMAXFREE, KU, LDA, LDC, + $ LDQRC, LDX, LIWORK, LRWORK, LWORK, LWKTST, + $ M, MINMN, MINMNB_GEN, MODE, N, + $ NB, NBMAX_UNMQR, NB_ZERO, NERRS, NFAIL, + $ NB_GEN, NRUN, NX, T + REAL ANORM, CNDNUM, EPS, ABSTOL, RELTOL, + $ DTEMP, MAXC2NRMK, RELMAXC2NRMK, FNRMK +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL SLAMCH, CQPT01, CQRT11, CQRT12 + EXTERNAL SLAMCH, CQPT01, CQRT11, CQRT12 +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, CERRCXX, + $ CGECXX, CLACPY, SLAORD, CLASET, + $ CLATB4, CLATMS, CSWAP, ICOPY, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, MOD +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, IOUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, IOUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Complex precision' + PATH( 2: 3 ) = 'CX' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO I = 1, 4 + ISEED( I ) = ISEEDY( I ) + END DO + EPS = SLAMCH( 'Epsilon' ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL CERRCXX( PATH, NOUT ) +* + INFOT = 0 +* + DO IM = 1, NM +* +* Do for each value of M in MVAL. +* + M = MVAL( IM ) + LDA = MAX( 1, M ) + LDC = MAX( 1, M ) + LDQRC = MAX( 1, M ) +* + DO IN = 1, NN +* +* Do for each value of N in NVAL. +* + N = NVAL( IN ) + MINMN = MIN( M, N ) + LDX = MAX( 1, N ) +* +* 1) NOTE: for matrix generation routine CLATMS, the workspace length +* LWKTMS = 3*MAX( M, N ). LWKTMS not used in the code. +* +* 2) Set workspace length for testing routines. +* a) for CQRT12, real LRWKTST = 2*MIN(M,N). LRWKTST not used in the code. +* for CQRT12, complex: +* + LWKTST = MAX( 1, M*N + 2*MINMN + MAX( M, N ) ) +* +* b) for CQPT01, complex: +* + LWKTST = MAX( LWKTST, M*N + N ) +* +* c) for CQRT11, complex: +* + LWKTST = MAX( LWKTST, M*M + M ) +* + DO IMAT = 1, NTYPES +* +* Do for each value of IMAT in NTYPES. +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ CYCLE +* +* The type of distribution used to generate the random +* eigen-/singular values: +* ( 'S' for symmetric distribution ) => UNIFORM( -1, 1 ) +* +* Do for each type of NON-SYMMETRIC matrix: CNDNUM NORM MODE +* 1. Zero matrix CNDNUM = Inf 0 N/A +* 2. Random, Diagonal CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 3. Random, Upper triangular CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 4. Random, Lower triangular CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 5. Random, First column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 6. Random, Last MINMN column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 7. Random, Last N column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 8. Random, Middle column in MINMN is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 9. Random, First half of MINMN columns are zero, +* zero block size MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 10. Random, Last columns are zero starting from MINMN/2+1 column, +* zero block size N - MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 11. Random, Half of MINMN columns in the middle are zero starting +* from MINMN/2-(MINMN/2)/2+1 column, +* zero block size MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 12. Random, Odd columns are ZERO CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 13. Random, Even columns are ZERO CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 14. Random, CNDNUM = 2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 15. Random, CNDNUM = sqrt(0.1/EPS) CNDNUM = BADC1 = sqrt(0.1/EPS) 1 3 ( geometric distribution of singular values ) +* 16. Random, CNDNUM = 0.1/EPS CNDNUM = BADC2 = 0.1/EPS 1 3 ( geometric distribution of singular values ) +* 17. Random, CNDNUM = 0.1/EPS, one small singular value S(N)=1/CNDNUM CNDNUM = BADC2 = 0.1/EPS 1 2 ( one small singular value, S(N)=1/CNDNUM ) +* 18. Random, CNDNUM = 2, scaled near underflow CNDNUM = 2 SMALL = SAFMIN 3 ( geometric distribution of singular values ) +* 19. Random, CNDNUM = 2, scaled near overflow CNDNUM = 2 LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) ) 3 ( geometric distribution of singular values ) +* +* Generate matrices. +* + IF( IMAT.EQ.1 ) THEN +* +* Matrix 1 (Zero matrix). +* + CALL CLASET( 'Full', M, N, CZERO, CZERO, COPYA, LDA ) +* +* Array S(1:min(M,N)) should contain svd(A), the sigular +* values of the generated matrix A in decreasing absolute +* value order. S in this format will be used later in the test. +* We set the array S explicitly here, since we are not using +* CLATMS (which sets the array S) to generate zero matrix. +* + DO I = 1, MINMN + S( I ) = ZERO + END DO +* + ELSE IF( ( IMAT.EQ.2 .OR. IMAT.EQ.3 .OR. IMAT.EQ.4 ) + $ .OR. ( IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN +* +* Matrix 2 (Diagonal), +* Matrix 3 (Upper triangular), +* Matrix 4 (Lower triangular), +* Matrices 14-19 (Various rectangular random matrices +* without zero columns). +* +* Set up parameters with CLATB4 and generate a test +* matrix with CLATMS. +* + CALL CLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'CLATMS' + CALL CLATMS( M, N, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA, LDA, WORK, INFO ) +* +* Check error code from CLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', M, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* +* Array S(1:min(M,N)) should contain svd(A), the sigular +* values of the generated matrix A in decreasing absolute +* value order. S in this format will be used later in +* the test. Unordered singular values are returned by +* CLATMS in S. We need to order singular values in S. +* + CALL SLAORD( 'Decreasing', MINMN, S, 1 ) +* + ELSE IF( MINMN.GE.2 + $ .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN +* +* Matrices 5-13 (Rectangular random matrices that +* contain zero columns). Only for matrices MINMN >= 2. +* +* JB_ZERO is the column index of ZERO block. +* NB_ZERO is the column block size of ZERO block. +* NB_GEN is the column blcok size of the +* generated block. +* J_INC in the non_zero column index increment +* to generate matrix 12 and 13. +* J_FIRS_NZ is the index of the first non-zero +* column to generate matrix 12 and 13. +* + IF( IMAT.EQ.5 ) THEN +* +* Matrix 5. First column is zero. +* + JB_ZERO = 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.6 ) THEN +* +* Matrix 6. Last column MINMN is zero. +* + JB_ZERO = MINMN + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.7 ) THEN +* +* Matrix 7. Last column N is zero. +* + JB_ZERO = N + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.8 ) THEN +* +* MAtrix 8. Middle column in MINMN is zero. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.9 ) THEN +* +* Matrix 9. First half of MINMN columns is zero, zero block size MINMN/2. +* + JB_ZERO = 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.10 ) THEN +* +* Matrix 10. Last columns are zero columns, +* starting from (MINMN / 2 + 1) column,zero block size N - MINMN/2 +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = N - MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.11 ) THEN +* +* Matrix 11. Half of the columns in the middle of first MINMN +* columns is zero, starting from MINMN/2 - (MINMN/2)/2 + 1 column, +* zero block size MINMN/2. +* + JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.12 ) THEN +* +* Matrix 12. Odd-numbered columns are zero, +* + NB_GEN = N / 2 + NB_ZERO = N - NB_GEN + J_INC = 2 + J_FIRST_NZ = 2 +* + ELSE IF( IMAT.EQ.13 ) THEN +* +* Matrix 13. Even-numbered columns are zero. +* + NB_ZERO = N / 2 + NB_GEN = N - NB_ZERO + J_INC = 2 + J_FIRST_NZ = 1 +* + END IF +* +* +* 1) Set the first NB_ZERO columns in COPYA(1:M,1:N) +* to zero. +* + CALL CLASET( 'Full', M, NB_ZERO, CZERO, CZERO, + $ COPYA, LDA ) +* +* 2) Generate an M-by-(N-NB_ZERO) matrix with the +* chosen singular value distribution +* in COPYA(1:M,NB_ZERO+1:N). +* + CALL CLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* + SRNAMT = 'CLATMS' +* + IND_OFFSET_GEN = NB_ZERO * LDA +* + CALL CLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA( IND_OFFSET_GEN + 1 ), LDA, + $ WORK, INFO ) +* +* Check error code from CLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'CLATMS', INFO, 0, ' ', M, + $ NB_GEN, -1, -1, -1, IMAT, NFAIL, + $ NERRS, NOUT ) + CYCLE + END IF +* +* 3) Swap the gererated colums from the right side +* NB_GEN-size block in COPYA into correct column +* positions. +* + IF( IMAT.EQ.6 + $ .OR. IMAT.EQ.7 + $ .OR. IMAT.EQ.8 + $ .OR. IMAT.EQ.10 + $ .OR. IMAT.EQ.11 ) THEN +* +* Move by swapping the generated columns +* from the right NB_GEN-size block from +* (NB_ZERO+1:NB_ZERO+JB_ZERO) +* into columns (1:JB_ZERO-1). +* + DO J = 1, JB_ZERO-1, 1 + CALL CSWAP( M, + $ COPYA( ( NB_ZERO+J-1)*LDA+1), 1, + $ COPYA( (J-1)*LDA + 1 ), 1 ) + END DO +* + ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN +* +* ( IMAT = 12, Odd-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the even zero colums in the +* left NB_ZERO-size block. +* +* ( IMAT = 13, Even-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the odd zero colums in the +* left NB_ZERO-size block. +* + DO J = 1, NB_GEN, 1 + IND_OUT = ( NB_ZERO+J-1 )*LDA + 1 + IND_IN = ( J_INC*(J-1)+(J_FIRST_NZ-1) )*LDA + $ + 1 + CALL CSWAP( M, + $ COPYA( IND_OUT ), 1, + $ COPYA( IND_IN ), 1 ) + END DO +* + END IF +* +* 5) Order the singular values generated by +* CLAMTS in decreasing absolute value order and +* add trailing zeros that correspond to zero columns. +* The total number of singular values is MINMN. +* + MINMNB_GEN = MIN( M, NB_GEN ) + CALL SLAORD( 'Decreasing', MINMNB_GEN, S, 1 ) +* + DO I = MINMNB_GEN+1, MINMN + S( I ) = ZERO + END DO +* + ELSE +* +* IF( MINMN.LT.2 .AND. ( IMAT.GE.5 .AND. IMAT.LE.13 ) ) +* skip this size for this matrix type. +* + CYCLE + END IF +* +* End generate COPYA matrix. +* +* Initialize COPYC matrix with zeros. +* + CALL CLASET( 'Full', M, N, CZERO, CZERO, + $ COPYC, LDC ) +* +* Initialize COPYQRC matrix with zeros. +* + CALL CLASET( 'Full', M, N, CZERO, CZERO, + $ COPYQRC, LDQRC ) +* +* Initialize COPYX matrix with zeros. +* + CALL CLASET( 'Full', MINMN, N, CZERO, CZERO, + $ COPYX, LDX ) +* +* Initialize a copy array for pivot IPIV for CGECXX. +* + DO I = 1, M + COPY_IPIV( I ) = 0 + END DO +* +* Initialize a copy array for pivot JPIV for CGECXX. +* + DO J = 1, N + COPY_JPIV( J ) = 0 + END DO +* +* Initialize a copy array COPY_DESEL_ROWS for CGECXX. +* + DO I = 1, M + COPY_DESEL_ROWS( I ) = 0 + END DO +* +* Initialize a copy array COPY_SEL_DESEL_COLS for CGECXX. +* + DO J = 1, N + COPY_SEL_DESEL_COLS( J ) = 0 + END DO +* + DO INB = 1, NNB +* +* Do for each pair of values (NB,NX) in NBVAL and NXVAL. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + NX = NXVAL( INB ) + CALL XLAENV( 3, NX ) +* +* We do MIN(M,N)+1 because we need a test for KMAX > N, +* when KMAX is larger than MIN(M,N), KMAX should be +* KMAX = MIN(M,N) +* + DO KMAXFREE = 0, MIN(M,N)+1 +* +* Get a working copy of COPYA into A( 1:M,1:N ). +* Get a working copy of COPYC into C( 1:M,1:N ). +* Get a working copy of COPYQRC into QRC( 1:M,1:N ). +* Get a working copy of COPYX into X( 1:N,1:N ). +* Get a working copy of COPY_IPIV(1:M) into IPIV(1:M). +* Get a working copy of COPY_JPIV(1:N) into JPIV(1:N). +* Get a working copy of COPY_DESEL_ROWS(1:M) into DESEL_ROWS(1:M). +* Get a working copy of COPY_SEL_DESEL_COLS(1:N) into SEL_DESEL_COLS(1:N). +* + CALL CLACPY( 'All', M, N, COPYA, LDA, A, LDA ) + CALL CLACPY( 'All', M, N, COPYC, LDC, C, LDC ) + CALL CLACPY( 'All', M, N, COPYQRC, LDQRC, QRC, LDQRC ) + CALL CLACPY( 'All', MINMN, N, COPYX, LDX, X, LDX ) + CALL ICOPY( M, COPY_IPIV, 1, IPIV, 1 ) + CALL ICOPY( N, COPY_JPIV, 1, JPIV, 1 ) + CALL ICOPY( M, COPY_DESEL_ROWS, 1, DESEL_ROWS, 1 ) + CALL ICOPY( N, COPY_SEL_DESEL_COLS, 1, + $ SEL_DESEL_COLS, 1 ) +* +* Set test ratios for all tests to zero. +* + DO I = 1, NTESTS + RESULT( I ) = ZERO + END DO +* +* We are not testing with ABSTOL and RELTOL stopping criteria. +* Disable them. +* + FACT = 'C' + USESD = 'N' + ABSTOL = -ONE + RELTOL = -ONE +* +* Compute the QR factorization with pivoting of A +* +* Determine LWORK +* +* NBMAX_UNMQR is hardwired in CUNMQR as NBMAX = 64. +* + NBMAX_UNMQR = 64 +* +* a) For CGEQRF inside CGECXX, complex +* + LWORK = MAX( 1, N*NB ) +* +* b) For CUNMQR inside CGECXX, complex +* + LWORK = MAX( LWORK, + $ N*MIN(NBMAX_UNMQR,NB)+(NBMAX_UNMQR+1)*NBMAX_UNMQR ) +* +* c1) For CGEQP3RK inside CGECXX, complex +* + LWORK = MAX( LWORK, NB*( N + 1 ) ) +* +* c2) For CGEQP3RK inside CGECXX, real +* + LRWORK = MAX( 1, 2*N ) +* +* d) For CGELS inside CGECXX, complex +* + LWORK = MAX( LWORK, MIN(M,N) + N*NB ) +* +* Determine LIWORK +* + LIWORK = MAX( 1, 2*N ) +* +* Compute CGECXX factorization of A. +* + SRNAMT = 'CGECXX' + CALL CGECXX( FACT, USESD, M, N, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ KMAXFREE, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, + $ X, LDX, WORK, LWORK, RWORK, LRWORK, + $ IWORK, LIWORK, INFO ) +* +* Check an error code from CGECXX. +* + IF( INFO.LT.0 ) + $ CALL ALAERH( PATH, 'CGECXX', INFO, 0, ' ', + $ M, N, NX, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute test 1: +* +* This test in only for the full rank factorization of +* the matrix A. +* +* Array S(1:min(M,N)) contains svd(A) the sigular values +* of the original matrix A in decreasing absolute value +* order. The test computes svd(R), the vector sigular +* values of the upper trapezoid of A(1:M,1:N) that +* contains the factor R, in decreasing order. The test +* returns the ratio: +* +* 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS ) +* + IF( K.EQ.MINMN ) THEN +* + RESULT( 1 ) = CQRT12( M, N, A, LDA, S, WORK, + $ LWKTST, RWORK ) +* + NRUN = NRUN + 1 +* +* End test 1 +* + END IF +* +* +* Compute test 2: +* +* The test returns the ratio: +* +* 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS ) +* + RESULT( 2 ) = CQPT01( M, N, K, COPYA, A, LDA, TAU, + $ JPIV, WORK, LWKTST ) +* +* Compute test 3: +* +* The test returns the ratio: +* +* 1-norm( Q**T * Q - I ) / ( M * EPS ) +* + RESULT( 3 ) = CQRT11( M, K, A, LDA, TAU, WORK, + $ LWKTST ) +* + NRUN = NRUN + 2 +* +* Compute test 4: +* +* This test is only for the factorizations with the +* rank greater then 1. +* The elements on the diagonal of R should be non- +* increasing. +* +* The test returns the ratio: +* +* Returns 1.0E+38 if abs(R(j+1,j+1)) > abs(R(j,j)), +* j=1:K-1 +* + IF( MIN(K, MINMN).GT.1 ) THEN +* + DO J = 1, K-1, 1 + + DTEMP = (( ABS( A( (J-1)*LDA+J ) ) - + $ ABS( A( (J)*LDA+J+1 ) ) ) / + $ ABS( A(1) ) ) +* + IF( DTEMP.LT.ZERO ) THEN + RESULT( 4 ) = BIGNUM + END IF +* + END DO +* + NRUN = NRUN + 1 +* +* End test 4. +* + END IF +* +* =============== +* Compute test 5: +* =============== +* This test is only for the factorizations with the +* rank greater than 0. +* For J=1:K, the J-th column of C should be elementwise +* equal (including NaN and Inf) +* to the JPIV(J)-th column of A. +* + RESULT( 5 ) = ZERO +* Disable for now, incomplete test. + IF(.FALSE.) THEN + DO J = 1, K, 1 + DO I = 1, M, 1 + IF( .NOT. (C( (J-1)*LDC+I ) + $ .EQ. A( (JPIV( J )-1)*LDA+I ) ) ) THEN + RESULT( 5 ) = BIGNUM + END IF + END DO + END DO + END IF +* +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'CGECXX', M, N, + $ FACT, USESD, KMAXFREE, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO +* +* END DO KMAX = 1, MIN(M,N)+1 +* + END DO +* +* END DO for INB = 1, NNB +* + END DO +* +* END DO for IMAT = 1, NTYPES +* + END DO +* +* END DO for IN = 1, NN +* + END DO +* +* END DO for IM = 1, NM +* + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, + $ ', FACT = ''', A1, ''', USESD = ''', A1, + $ ''', KMAXFREE =', I5, ', ABSTOL =', G12.5, + $ ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4, + $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) +* +* End of CCHKCXX +* + END diff --git a/lapack-netlib/TESTING/LIN/cerrcxx.f b/lapack-netlib/TESTING/LIN/cerrcxx.f new file mode 100644 index 0000000000..101e09ff44 --- /dev/null +++ b/lapack-netlib/TESTING/LIN/cerrcxx.f @@ -0,0 +1,2014 @@ +*> \brief \b CERRCXX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE CERRCXX( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> CERRCXX tests the error exits for CERRCXX that does +*> CX decomposition. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex_lin +* +* ===================================================================== + SUBROUTINE CERRCXX( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER(LEN=3) PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 5 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J, K + REAL MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ NAN, ONE, ZERO +* .. +* .. Local Arrays .. + INTEGER DESEL_ROWS( NMAX ), SEL_DESEL_COLS( NMAX ), + $ IPIV( NMAX ), JPIV( NMAX ), IW( NMAX ) + COMPLEX A( NMAX, NMAX ), C( NMAX, NMAX ), + $ QRC( NMAX, NMAX ), X( NMAX, NMAX ), + $ TAU( NMAX ), W( NMAX ) + REAL RW( NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, CGECXX +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER(LEN=32) SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, CMPLX, SQRT +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DESEL_ROWS( J ) = 0 + SEL_DESEL_COLS( J ) = 0 + IPIV( J ) = 0 + JPIV( J ) = 0 + TAU( J ) = 1.E+0 / CMPLX( J ) + W( J ) = 1.E+0 / CMPLX( J ) + RW( J ) = 1.E+0 / REAL( J ) + IW( J ) = -J + DO I = 1, NMAX + A( I, J ) = 1.E+0 / CMPLX( I+J ) + C( I, J ) = 1.E+0 / CMPLX( I+J ) + QRC( I, J ) = 1.E+0 / CMPLX( I+J ) + X( I, J ) = 1.E+0 / CMPLX( I+J ) + END DO + END DO +* +* Create a NaN +* + ONE = 1.0E+0 + ZERO = 0.0E+0 + NAN = SQRT( -ONE ) +* + OK = .TRUE. +* +* Error exits for CX decomposition +* +* CGECXX +* + SRNAMT = 'CGECXX' +* +* ====================== +* Test parameter FACT +* ====================== + INFOT = 1 + CALL CGECXX( '/', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* ====================== +* Test parameter USESD +* ====================== +* + INFOT = 2 +* + CALL CGECXX( 'P', '/', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* ====================== +* Test parameter M +* ====================== +* + INFOT = 3 +* + CALL CGECXX( 'P', 'A', -1, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter N +* ======================= +* + INFOT = 4 +* + CALL CGECXX( 'P', 'A', 0, -1, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter SEL_DESEL_COLS +* ======================= +* +* NSEL (the number of preselected columns in SEL_DESEL_COLS +* (element value = 1)) cannot be greater then MSUB. +* + INFOT = 6 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + CALL CGECXX( 'P', 'A', 1, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) + + +* +* ======================= +* Test parameter KMAXFREE +* ======================= +* + INFOT = 7 +* + CALL CGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ -1, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter ABSTOL +* ======================= +* + INFOT = 8 +* + CALL CGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, NAN, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) + +* +* ======================= +* Test parameter RELTOL +* ======================= +* + INFOT = 9 +* + CALL CGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, NAN, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDA +* ======================= +* + INFOT = 11 +* +* min(M,N) = 0 +* + CALL CGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 0, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* + CALL CGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 2, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDC +* ======================= +* + INFOT = 20 +* +* min(M,N) = 0 +* + CALL CGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 0, QRC, 1, + $ X, 1, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL CGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 0, QRC, 2, + $ X, 2, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL CGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 2, + $ X, 2, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL CGECXX( 'X', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 2, + $ X, 2, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDQRC +* ======================= +* +* QRC is used only when the matrix X is returned. +* + INFOT = 22 +* +* min(M,N) = 0 +* + CALL CGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 0, + $ X, 1, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL CGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 0, + $ X, 1, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL CGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 0, + $ X, 2, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL CGECXX( 'X', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 1, + $ X, 2, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDX +* ======================= +* + INFOT = 24 +* +* min(M,N) = 0 +* + CALL CGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 0, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL CGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 0, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL CGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 0, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL CGECXX( 'X', 'A', 4, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 3, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LWORK +* ======================= +* + INFOT = 26 +* +* Test group 1. LWORK test for MIN(M,N) = 0, then LWKMIN => 1 +* ========================================== +* + CALL CGECXX( 'X', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 0, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 2. LWORK tests for USESD = 'N'. +* ========================================== +* if FACT = 'P', LWKMIN = MAX(1, N - 1) +* if FACT = 'C', LWKMIN = MAX(1, N - 1) +* if FACT = 'X', LWKMIN = MAX(1, MINMN + N) +* + CALL CGECXX( 'P', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* + CALL CGECXX( 'C', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* + CALL CGECXX( 'X', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 5, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) + + +* +* Test group 3. LWORK tests for USESD = 'R'. +* ========================================== +* if FACT = 'P', LWKMIN = MAX(1, N - 1) +* if FACT = 'C', LWKMIN = MAX(1, N - 1) +* if FACT = 'X', LWKMIN = MAX(1, MINMN + N) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL CGECXX( 'P', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL CGECXX( 'C', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL CGECXX( 'X', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 7, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 4. LWORK tests for USESD = 'C'. +* ========================================== +* (a) if FACT = 'P', LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ) +* (b) if FACT = 'C', LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ) +* (c) if FACT = 'X', LWKMIN = max( 1, min(M,N)+N ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g4(a1). +* Set N_sel = 0, then min(1,N_sel)*max(N_sel,N_free) = 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND (N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (N_free - 1) = 3 +* LWKMIN = max(1, 0, 3) = 3 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL CGECXX( 'P', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g4(a2) +* Set N_sel = 3, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND N_sel is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* N_free - 1 = 0 +* LWKMIN = max(1, 3, 0) = 3 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL CGECXX( 'P', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g4(a3). +* Set N_sel = 1, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND N_free is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 3, 3 ) = 3, +* N_free - 1 = 2 +* LWKMIN = max(1, 3, 2) = 3 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL CGECXX( 'P', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g4(a4). +* Set N_sel = 4, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 0 ( i.e. disable (N_free-1) ) AND N_free is the largest component. +* M = 4, N = 4, +* M_sub = M = 2, N_sub = N = 4, +* N_sel = 4, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 0, +* MINMNFREE = min( M_free, N_free ) = min( 2, 2 ) = 0, +* N_free - 1 = 1 +* LWKMIN = max(1, 4, 0) = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 +* + CALL CGECXX( 'P', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 3, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g4(b1). +* Set N_sel = 0, then min(1,N_sel)*max(N_sel,N_free) = 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND (N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (N_free - 1) = 3 +* LWKMIN = max(1, 0, 3) = 3 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL CGECXX( 'C', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g4(b2) +* Set N_sel = 3, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND N_sel is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* N_free - 1 = 0 +* LWKMIN = max(1, 3, 0) = 3 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + + CALL CGECXX( 'C', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g4(b3). +* Set N_sel = 1, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND N_free is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 3, 3 ) = 3, +* N_free - 1 = 2 +* LWKMIN = max(1, 3, 2) = 3 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL CGECXX( 'C', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g4(b4). +* Set N_sel = 4, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 0 ( i.e. disable (N_free-1) ) AND N_free is the largest component. +* M = 4, N = 4, +* M_sub = M = 2, N_sub = N = 4, +* N_sel = 4, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 0, +* MINMNFREE = min( M_free, N_free ) = min( 2, 2 ) = 0, +* N_free - 1 = 1 +* LWKMIN = max(1, 4, 0) = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 +* + CALL CGECXX( 'C', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 3, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N ). +* Test g4(c1). +* Set M < N. +* M = 3, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 3, 4 ) = 3, +* (N_free - 1) = 3 +* (min(M,N)+N) = 3 + 4 = 7 +* LWKMIN = (3 + 4) = 7 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL CGECXX( 'X', 'C', 3, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 6, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N ). +* Test g4(c2). +* Set M > N. +* M = 4, N = 3, +* M_sub = M = 4, N_sub = N = 3, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 3, 4 ) = 3, +* (N_free - 1) = 2 +* (min(M,N)+N) = 3 + 3 = 6 +* LWKMIN = (3 + 3) = 6 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL CGECXX( 'X', 'C', 4, 3, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 5, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 5. LWORK tests for USESD = 'A'. +* ========================================== +* (a) if FACT = 'P', LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ) +* (b) if FACT = 'C', LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ) +* (c) if FACT = 'X', LWKMIN = max( 1, min(M,N)+N ) +* +* Parameter LWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g5(a1). +* Set N_sel = 0, then min(1,N_sel)*max(N_sel,N_free) = 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND (N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (N_free - 1) = 3 +* LWKMIN = max(1, 0, 3) = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL CGECXX( 'P', 'A', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g5(a2) +* Set N_sel = 3, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND N_sel is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* N_free - 1 = 0 +* LWKMIN = max(1, 3, 0) = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL CGECXX( 'P', 'A', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g5(a3). +* Set N_sel = 1, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND N_free is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 3, 3 ) = 3, +* N_free - 1 = 2 +* LWKMIN = max(1, 3, 2) = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL CGECXX( 'P', 'A', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g5(a4). +* Set N_sel = 4, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 0 ( i.e. disable (N_free-1) ) AND N_free is the largest component. +* M = 4, N = 4, +* M_sub = M = 2, N_sub = N = 4, +* N_sel = 4, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 0, +* MINMNFREE = min( M_free, N_free ) = min( 2, 2 ) = 0, +* N_free - 1 = 1 +* LWKMIN = max(1, 4, 0) = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 +* + CALL CGECXX( 'P', 'A', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 3, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g5(b1). +* Set N_sel = 0, then min(1,N_sel)*max(N_sel,N_free) = 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND (N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (N_free - 1) = 3 +* LWKMIN = max(1, 0, 3) = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL CGECXX( 'C', 'A', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g5(b2) +* Set N_sel = 3, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND N_sel is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* N_free - 1 = 0 +* LWKMIN = max(1, 3, 0) = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + + CALL CGECXX( 'C', 'A', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g5(b3). +* Set N_sel = 1, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND N_free is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 3, 3 ) = 3, +* N_free - 1 = 2 +* LWKMIN = max(1, 3, 2) = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL CGECXX( 'C', 'A', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g5(b4). +* Set N_sel = 4, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 0 ( i.e. disable (N_free-1) ) AND N_free is the largest component. +* M = 4, N = 4, +* M_sub = M = 2, N_sub = N = 4, +* N_sel = 4, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 0, +* MINMNFREE = min( M_free, N_free ) = min( 2, 2 ) = 0, +* N_free - 1 = 1 +* LWKMIN = max(1, 4, 0) = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 +* + CALL CGECXX( 'C', 'A', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 3, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N ). +* Test g5(c1). +* Set M < N. +* M = 3, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 3, 4 ) = 3, +* (N_free - 1) = 3 +* (min(M,N)+N) = 3 + 4 = 7 +* LWKMIN = (3 + 4) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL CGECXX( 'X', 'A', 3, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 6, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N ). +* Test g5(c2). +* Set M > N. +* M = 4, N = 3, +* M_sub = M = 4, N_sub = N = 3, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 3, 4 ) = 3, +* (N_free - 1) = 2 +* (min(M,N)+N) = 3 + 3 = 6 +* LWKMIN = (3 + 3) = 6 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL CGECXX( 'X', 'A', 4, 3, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 5, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LRWORK +* ======================= +* + INFOT = 28 +* +* Test group 1. LIWORK test for MIN(M,N) = 0, then LRcdWKMIN => 1 +* ========================================== +* + CALL CGECXX( 'X', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 0, IW, 1, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 2. LRWORK tests for USESD = 'N' +* ========================================== +* For all FACT = 'P', 'C', 'X', LRWKMIN = MAX(1, 2*N) +* + CALL CGECXX( 'P', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 20, RW, 7, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* + CALL CGECXX( 'C', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 20, RW, 7, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* + CALL CGECXX( 'X', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 20, RW, 7, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 3. LRWORK tests for USESD = 'R' +* ========================================== +* For all FACT = 'P', 'C', 'X', LRWKMIN = MAX(1, 2*N) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 +* + CALL CGECXX( 'P', 'R', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 7, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 +* + CALL CGECXX( 'C', 'R', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 7, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 +* + CALL CGECXX( 'X', 'R', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 7, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 4. LRWORK tests for USESD = 'C' +* ========================================== +* For all FACT = 'P', 'C', 'X', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* +* Parameter RWORK. +* Case g4(a). USESD = 'C', FACT = 'P', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g4(a1). Set N_sub < 2*N_free. +* M = 4, N = 5, +* M_sub = M = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 3, +* 2*N_free = 6 +* LRWKMIN = MAX(4, 6) = 6 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = -1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'P', 'C', 4, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 5, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g4(a). USESD = 'C', FACT = 'P', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g4(a2). Set N_sub > 2*N_free. +* M = 4, N = 5, +* M_sub = M = 4, N_sub = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* 2*N_free = 2 +* LRWKMIN = MAX(4, 2) = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = -1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'P', 'C', 4, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 3, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g4(b). USESD = 'C', FACT = 'C', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g4(b1). Set N_sub < 2*N_free. +* M = 4, N = 5, +* M_sub = M = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 3, +* 2*N_free = 6 +* LRWKMIN = MAX(4, 6) = 6 + + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = -1 +* + CALL CGECXX( 'C', 'C', 4, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 5, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g4(b). USESD = 'C', FACT = 'C', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g4(b2). Set N_sub > 2*N_free. +* M = 4, N = 5, +* M_sub = M = 4, N_sub = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* 2*N_free = 2 +* LRWKMIN = MAX(4, 2) = 4 +* + SEL_DESEL_COLS( 1 ) = -1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'C', 'C', 4, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 3, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g4(c). USESD = 'C', FACT = 'X', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g4(c1). Set N_sub < 2*N_free. +* M = 4, N = 5, +* M_sub = M = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 3, +* 2*N_free = 6 +* LRWKMIN = MAX(4, 6) = 6 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'X', 'C', 4, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 5, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g4(c). USESD = 'C', FACT = 'X', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g4(c2). Set N_sub > 2*N_free. +* M = 4, N = 5, +* M_sub = M = 4, N_sub = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* 2*N_free = 2 +* LRWKMIN = MAX(4, 2) = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = -1 +* + CALL CGECXX( 'X', 'C', 4, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 3, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 5. LRWORK tests for USESD = 'A' +* ========================================== +* For all FACT = 'P', 'C', 'X', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* +* Parameter RWORK. +* Case g5(a). USESD = 'A', FACT = 'P', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g5(a1). Set N_sub < 2*N_free. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* 2*N_free = 6 +* LRWKMIN = MAX(4, 6) = 6 +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = -1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'P', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 20, RW, 5, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g5(a). USESD = 'A', FACT = 'P', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g5(a2). Set N_sub > 2*N_free. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* 2*N_free = 2 +* LRWKMIN = MAX(4, 2) = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = -1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'P', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 20, RW, 3, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g5(b). USESD = 'A', FACT = 'C', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g5(b1). Set N_sub < 2*N_free. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* 2*N_free = 6 +* LRWKMIN = MAX(4, 6) = 6 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = -1 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 1 +* + CALL CGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 20, RW, 5, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g5(b). USESD = 'A', FACT = 'C', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g5(b2). Set N_sub > 2*N_free. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* 2*N_free = 2 +* LRWKMIN = MAX(4, 2) = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 1 +* + CALL CGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 20, RW, 3, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g5(c). USESD = 'A', FACT = 'X', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g5(c1). Set N_sub < 2*N_free. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* 2*N_free = 6 +* LRWKMIN = MAX(4, 6) = 6 +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = -1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 20, RW, 5, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g5(c). USESD = 'A', FACT = 'X', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g5(c2). Set N_sub > 2*N_free. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* 2*N_free = 2 +* LRWKMIN = MAX(4, 2) = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = -1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 1 +* + CALL CGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 20, RW, 3, IW, 20, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LIWORK +* ======================= +* + INFOT = 30 +* +* Test group 1. LIWORK test for MIN(M,N) = 0, then LIWKMIN => 1 +* ========================================== +* + CALL CGECXX( 'X', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 0, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 2. LIWORK tests for USESD = 'N' +* ========================================== +* if FACT = 'P', LIWKMIN = MAX(1, N-1) +* if FACT = 'C', LIWKMIN = MAX(1, 2*N) +* if FACT = 'X', LIWKMIN = MAX(1, 2*N) +* + CALL CGECXX( 'P', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, RW, 20, IW, 2, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) + CALL CGECXX( 'C', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, RW, 20, IW, 7, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) + CALL CGECXX( 'X', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, RW, 20, IW, 7, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 3. LIWORK tests for USESD = 'R' +* ========================================== +* if FACT = 'P', LIWKMIN = MAX(1, N-1) +* if FACT = 'C', LIWKMIN = MAX(1, 2*N) +* if FACT = 'X', LIWKMIN = MAX(1, 2*N) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL CGECXX( 'P', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 2, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL CGECXX( 'C', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 7, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL CGECXX( 'X', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 7, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 4. LIWORK tests for USESD = 'C'. +* ========================================== +* (a) if FACT = 'P', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ) +* (b) if FACT = 'C', LIWKMIN = max( 1, 2*N ) +* (c) if FACT = 'X', LIWKMIN = max( 1, 2*N ) +* +* Parameter LIWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g4(a1). Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = (N_free-1) = 4 - 1 = 3 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'P', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 2, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g4(a2). Set min(1,N_sel) = 1 (i.e. enable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 3, +* min(1,N_sel) = 1 +* LIWKMIN = (N_free-1) + N_free = 3 - 1 + 3 = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'P', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20,IW, 4, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b1). (N_free-1) + min(1,N_sel)*N_free. +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c2). (N_free-1) + min(1,N_sel)*N_free. +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5` +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 5. LIWORK tests for USESD = 'A'. +* ========================================== +* (a) if FACT = 'P', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ) +* (b) if FACT = 'C', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free, N ) +* (c) if FACT = 'X', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free, N ) +* +* Parameter LIWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g5(a1). Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = (N_free-1) = 4 - 1 = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'P', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 2, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g5(a2). Set min(1,N_sel) = 1 (i.e. enable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* min(1,N_sel) = 1 +* LIWKMIN = (N_free-1) + N_free = 3 - 1 + 3 = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'P', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 4, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 2, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 4, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 2, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 4, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL CGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'CGECXX', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of CERRCXX +* + END diff --git a/lapack-netlib/TESTING/LIN/clatb4.f b/lapack-netlib/TESTING/LIN/clatb4.f index 233a8631a8..dde7ba8c11 100644 --- a/lapack-netlib/TESTING/LIN/clatb4.f +++ b/lapack-netlib/TESTING/LIN/clatb4.f @@ -118,6 +118,7 @@ * ===================================================================== SUBROUTINE CLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, $ CNDNUM, DIST ) + IMPLICIT NONE * * -- LAPACK test routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -237,11 +238,115 @@ SUBROUTINE CLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, TYPE = 'N' * * Set DIST, the type of distribution for the random -* number generator. 'S' is +* number generator. 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) * DIST = 'S' * -* Set the lower and upper bandwidths. +* Set the lower bandwidth KL and the upper bandwidth KU. +* + IF( IMAT.EQ.2 ) THEN +* +* 2. Random, Diagonal, CNDNUM = 2 +* + KL = 0 + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.3 ) THEN +* +* 3. Random, Upper triangular, CNDNUM = 2 +* + KL = 0 + KU = MAX( N-1, 0 ) + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.4 ) THEN +* +* 4. Random, Lower triangular, CNDNUM = 2 +* + KL = MAX( M-1, 0 ) + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE +* +* 5.-19. Rectangular matrix +* + KL = MAX( M-1, 0 ) + KU = MAX( N-1, 0 ) +* + IF( IMAT.GE.5 .AND. IMAT.LE.14 ) THEN +* +* 5.-14. Random, CNDNUM = 2. +* + CNDNUM = TWO + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.15 ) THEN +* +* 15. Random, CNDNUM = sqrt(0.1/EPS) +* + CNDNUM = BADC1 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.16 ) THEN +* +* 16. Random, CNDNUM = 0.1/EPS +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.17 ) THEN +* +* 17. Random, CNDNUM = 0.1/EPS, +* one small singular value S(N)=1/CNDNUM +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 2 +* + ELSE IF( IMAT.EQ.18 ) THEN +* +* 18. Random, scaled near underflow +* + CNDNUM = TWO + ANORM = SMALL + MODE = 3 +* + ELSE IF( IMAT.EQ.19 ) THEN +* +* 19. Random, scaled near overflow +* + CNDNUM = TWO + ANORM = LARGE + MODE = 3 +* + END IF +* + END IF +* + ELSE IF( LSAMEN( 2, C2, 'CX' ) ) THEN +* +* xCX: CX factorization +* Set parameters to generate a general +* M x N matrix. +* +* Set TYPE, the type of matrix to be generated. 'N' is nonsymmetric. +* + TYPE = 'N' +* +* Set DIST, the type of distribution for the random +* number generator. 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) +* + DIST = 'S' +* +* Set the lower bandwidth KL and the upper bandwidth KU. * IF( IMAT.EQ.2 ) THEN * diff --git a/lapack-netlib/TESTING/LIN/dchkaa.F b/lapack-netlib/TESTING/LIN/dchkaa.F index 91ed659661..856185c65a 100644 --- a/lapack-netlib/TESTING/LIN/dchkaa.F +++ b/lapack-netlib/TESTING/LIN/dchkaa.F @@ -64,6 +64,7 @@ *> DQL 8 List types on next line if 0 < NTYPES < 8 *> DQP 6 List types on next line if 0 < NTYPES < 6 *> DQK 19 List types on next line if 0 < NTYPES < 19 +*> DCX 19 List types on next line if 0 < NTYPES < 19 *> DTZ 3 List types on next line if 0 < NTYPES < 3 *> DLS 6 List types on next line if 0 < NTYPES < 6 *> DEQ @@ -146,13 +147,14 @@ PROGRAM DCHKAA * .. * .. Local Arrays .. LOGICAL DOTYPE( MATMAX ) - INTEGER IWORK( 25*NMAX ), MVAL( MAXIN ), + INTEGER MVAL( MAXIN ), $ NBVAL( MAXIN ), NBVAL2( MAXIN ), $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) * .. * .. Allocatable Arrays .. INTEGER AllocateStatus + INTEGER, DIMENSION(:), ALLOCATABLE :: IWORK DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: RWORK, S DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE :: E DOUBLE PRECISION, DIMENSION(:,:), ALLOCATABLE :: A, B, WORK @@ -163,15 +165,17 @@ PROGRAM DCHKAA EXTERNAL LSAME, LSAMEN, DLAMCH, DSECND * .. * .. External Subroutines .. - EXTERNAL ALAREQ, DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ, + EXTERNAL ALAREQ, DCHKCXX, + $ DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ, $ DCHKORHR_COL, DCHKPB, DCHKPO, DCHKPS, DCHKPP, $ DCHKPT, DCHKQ3, DCHKQP3RK, DCHKQL, DCHKQR, $ DCHKRQ, DCHKSP, DCHKSY, DCHKSY_ROOK, DCHKSY_RK, $ DCHKSY_AA, DCHKTB, DCHKTP, DCHKTR, DCHKTZ, $ DDRVGB, DDRVGE, DDRVGT, DDRVLS, DDRVPB, DDRVPO, $ DDRVPP, DDRVPT, DDRVSP, DDRVSY, DDRVSY_ROOK, - $ DDRVSY_RK, DDRVSY_AA, ILAVER, DCHKLQTP, DCHKQRT, - $ DCHKQRTP, DCHKLQT,DCHKTSQR + $ DDRVSY_RK, DDRVSY_AA, ILAVER, DCHKLQTP, + $ DCHKQRT, DCHKQRTP, DCHKLQT, DCHKTSQR, + $ DCHKSY_AA_2STAGE, DDRVSY_AA_2STAGE * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -192,7 +196,9 @@ PROGRAM DCHKAA * .. * .. Allocate memory dynamically .. * - ALLOCATE ( A( ( KDMAX+1 )*NMAX, 7 ), STAT = AllocateStatus ) + ALLOCATE ( IWORK( 34*NMAX ), STAT = AllocateStatus ) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( A( ( KDMAX+1 )*NMAX, 8 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE ( B( NMAX*MAXRHS, 4 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" @@ -441,6 +447,7 @@ PROGRAM DCHKAA * IF( .NOT.LSAME( C1, 'Double precision' ) ) THEN WRITE( NOUT, FMT = 9990 )PATH + * ELSE IF( NMATS.LE.0 ) THEN * @@ -947,6 +954,30 @@ PROGRAM DCHKAA ELSE WRITE( NOUT, FMT = 9989 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'CX' ) ) THEN +* +* CX: CX decomposition +* + NTYPES = 19 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL DCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, + $ NNB, NBVAL, NXVAL, THRESH, TSTERR, + $ A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), A( 1, 4 ), + $ A( 1, 5 ), A( 1, 6 ), + $ A( 1, 7 ), A( 1, 8 ), + $ B( 1, 1 ), B( 1, 2 ), + $ IWORK( 1 ), IWORK( 1+2*NMAX ), + $ IWORK(1+4*NMAX), IWORK(1+6*NMAX), + $ IWORK(1+8*NMAX), IWORK(1+10*NMAX), + $ IWORK(1+12*NMAX), IWORK(1+14*NMAX), + $ WORK, IWORK(1+16*NMAX), NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/dchkcxx.f b/lapack-netlib/TESTING/LIN/dchkcxx.f new file mode 100644 index 0000000000..58a555f4ce --- /dev/null +++ b/lapack-netlib/TESTING/LIN/dchkcxx.f @@ -0,0 +1,972 @@ +*> \brief \b DCHKCXX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, +* $ NNB, NBVAL, NXVAL, THRESH, TSTERR, +* $ A, COPYA, +* $ C, COPYC, QRC, COPYQRC, X, COPYX, S, TAU, +* $ DESEL_ROWS, COPY_DESEL_ROWS, +* $ SEL_DESEL_COLS, COPY_SEL_DESEL_COLS, +* $ IPIV, COPY_IPIV, JPIV, COPY_JPIV, +* $ WORK, IWORK, NOUT ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), +* $ NXVAL( * ), +* $ DESEL_ROWS( * ), COPY_DESEL_ROWS( * ), +* $ SEL_DESEL_COLS( * ), COPY_SEL_DESEL_COLS( * ), +* $ IPIV( * ), COPY_IPIV( * ), +* $ JPIV( * ), COPY_JPIV( * ) +* DOUBLE PRECISION A( * ), COPYA( * ), C( * ), COPYC( * ), +* $ QRC( * ), COPYQRC( * ), X( * ), COPYX( * ), +* $ S( * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DCHKCXX tests DGECXX. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB and NX contained in the +*> vectors NBVAL and NXVAL. The blocking parameters are used +*> in pairs (NB,NX). +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NNB) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NXVAL +*> \verbatim +*> NXVAL is INTEGER array, dimension (NNB) +*> The values of the crossover point NX. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYA +*> \verbatim +*> COPYA is DOUBLE PRECISION array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is DOUBLE PRECISION array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYC +*> \verbatim +*> COPYC is DOUBLE PRECISION array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] QRC +*> \verbatim +*> QRC is DOUBLE PRECISION array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYQRC +*> \verbatim +*> COPYQRC is DOUBLE PRECISION array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> NMAX is the maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYX +*> \verbatim +*> COPYX is DOUBLE PRECISION array, dimension (NMAX*NMAX) +*> NMAX is the maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension +*> (min(MMAX,NMAX)) +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is DOUBLE PRECISION array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] DESEL_ROWS +*> \verbatim +*> DESEL_ROWS is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] COPY_DESEL_ROWS +*> \verbatim +*> COPY_DESEL_ROWS is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] SEL_DESEL_COLS +*> \verbatim +*> SEL_DESEL_COLS is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] COPY_SEL_DESEL_COLS +*> \verbatim +*> COPY_SEL_DESEL_COLS is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] COPY_IPIV +*> \verbatim +*> COPY_IPIV is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] COPY_JPIV +*> \verbatim +*> COPY_JPIV is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array. +*> Dimension is the maximum of the following two expressions: +*> (1) Optimal complex workspace dimension for matrix generation +*> and test routines. +*> (MMAX + 6) * max(MMAX,NMAX) +*> This is an upper bound for: +*> a) DLATMS: 3*max(M,N) +*> b) DQRT12: max( M*N + 4*min(M,N) + max(M,N), +*> M*N + 2*min(M,N) + 4*N ) +*> c) DQPT01: M*N + N +*> d) DQRT11: M*M + M +*> +*> (2) Optimal workspace dimension for DGECXX. +*> max( NMAX*NBMAX, \\ for DGEQRF inside +*> NMAX*min(NBMAX_ORMQR,NBMAX) \\ for DORMQR inside +*> + (NBMAX_ORMQR+1)*NBMAX_ORMQR ), +*> 2*NMAX + NBMAX*( NMAX + 1 ), \\ for DGEQP3RK inside +*> min(MMAX,NMAX) + NMAX*NBMAX ), \\ for DGELS inside +*> where NBMAX_ORMQR=64 is hardwired in DORMQR. +*> +*> Assuming MMAX = NMAX, and NBMAX = NMAX, the expressions become: +*> (1) NMAX*NMAX + 6*NMAX +*> (2) NMAX * min(64,NMAX) + 4160 +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> for DGECXX optimal IWORK size. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, + $ NNB, NBVAL, NXVAL, THRESH, TSTERR, + $ A, COPYA, + $ C, COPYC, QRC, COPYQRC, X, COPYX, S, TAU, + $ DESEL_ROWS, COPY_DESEL_ROWS, + $ SEL_DESEL_COLS, COPY_SEL_DESEL_COLS, + $ IPIV, COPY_IPIV, JPIV, COPY_JPIV, + $ WORK, IWORK, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), + $ NXVAL( * ), + $ DESEL_ROWS( * ), COPY_DESEL_ROWS( * ), + $ SEL_DESEL_COLS( * ), COPY_SEL_DESEL_COLS( * ), + $ IPIV( * ), COPY_IPIV( * ), + $ JPIV( * ), COPY_JPIV( * ) + DOUBLE PRECISION A( * ), COPYA( * ), C( * ), COPYC( * ), + $ QRC( * ), COPYQRC( * ), X( * ), COPYX( * ), + $ S( * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTYPES + PARAMETER ( NTYPES = 19 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 5 ) + DOUBLE PRECISION ONE, ZERO, BIGNUM + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, + $ BIGNUM = 1.0D+38 ) +* .. +* .. Local Scalars .. + CHARACTER DIST, TYPE, FACT, USESD + CHARACTER*3 PATH + INTEGER I, IM, IMAT, IN, INB, IND_OFFSET_GEN, + $ IND_IN, IND_OUT, INFO, J, J_INC, J_FIRST_NZ, + $ JB_ZERO, K, KL, KMAXFREE, KU, LDA, LDC, + $ LDQRC, LDX, LIWORK, LWORK, LWKTST, + $ M, MINMN, MINMNB_GEN, MODE, N, + $ NB, NBMAX_ORMQR, NB_ZERO, NERRS, NFAIL, + $ NB_GEN, NRUN, NX, T + DOUBLE PRECISION ANORM, CNDNUM, EPS, ABSTOL, RELTOL, + $ DTEMP, MAXC2NRMK, RELMAXC2NRMK, FNRMK +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, DQPT01, DQRT11, DQRT12 + EXTERNAL DLAMCH, DQPT01, DQRT11, DQRT12 +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, DERRCXX, + $ DGECXX, DLACPY, DLAORD, DLASET, DLATB4, + $ DLATMS, DSWAP, ICOPY, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, MOD +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, IOUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, IOUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Double precision' + PATH( 2: 3 ) = 'CX' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO I = 1, 4 + ISEED( I ) = ISEEDY( I ) + END DO + EPS = DLAMCH( 'Epsilon' ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL DERRCXX( PATH, NOUT ) +* + INFOT = 0 +* + DO IM = 1, NM +* +* Do for each value of M in MVAL. +* + M = MVAL( IM ) + LDA = MAX( 1, M ) + LDC = MAX( 1, M ) + LDQRC = MAX( 1, M ) +* + DO IN = 1, NN +* +* Do for each value of N in NVAL. +* + N = NVAL( IN ) + MINMN = MIN( M, N ) + LDX = MAX( 1, N ) +* +* 1) NOTE: for matrix generation routine DLATMS, the workspace length +* LWKTMS = 3*MAX( M, N ). LWKTMS not used in the code. +* +* 2) Set workspace length for testing routines. +* a) for DQRT12 + LWKTST = MAX( 1, M*N + 4*MINMN + MAX( M, N ), + $ M*N + 2*MINMN + 4*N ) +* +* b) for DQPT01 +* + LWKTST = MAX( LWKTST, M*N + N ) +* +* c) for DQRT11 +* + LWKTST = MAX( LWKTST, M*M + M ) +* + DO IMAT = 1, NTYPES +* +* Do for each value of IMAT in NTYPES. +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ CYCLE +* +* The type of distribution used to generate the random +* eigen-/singular values: +* ( 'S' for symmetric distribution ) => UNIFORM( -1, 1 ) +* +* Do for each type of NON-SYMMETRIC matrix: CNDNUM NORM MODE +* 1. Zero matrix CNDNUM = Inf 0 N/A +* 2. Random, Diagonal CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 3. Random, Upper triangular CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 4. Random, Lower triangular CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 5. Random, First column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 6. Random, Last MINMN column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 7. Random, Last N column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 8. Random, Middle column in MINMN is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 9. Random, First half of MINMN columns are zero, +* zero block size MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 10. Random, Last columns are zero starting from MINMN/2+1 column, +* zero block size N - MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 11. Random, Half of MINMN columns in the middle are zero starting +* from MINMN/2-(MINMN/2)/2+1 column, +* zero block size MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 12. Random, Odd columns are ZERO CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 13. Random, Even columns are ZERO CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 14. Random, CNDNUM = 2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 15. Random, CNDNUM = sqrt(0.1/EPS) CNDNUM = BADC1 = sqrt(0.1/EPS) 1 3 ( geometric distribution of singular values ) +* 16. Random, CNDNUM = 0.1/EPS CNDNUM = BADC2 = 0.1/EPS 1 3 ( geometric distribution of singular values ) +* 17. Random, CNDNUM = 0.1/EPS, one small singular value S(N)=1/CNDNUM CNDNUM = BADC2 = 0.1/EPS 1 2 ( one small singular value, S(N)=1/CNDNUM ) +* 18. Random, CNDNUM = 2, scaled near underflow CNDNUM = 2 SMALL = SAFMIN 3 ( geometric distribution of singular values ) +* 19. Random, CNDNUM = 2, scaled near overflow CNDNUM = 2 LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) ) 3 ( geometric distribution of singular values ) +* +* Generate matrices. +* + IF( IMAT.EQ.1 ) THEN +* +* Matrix 1 (Zero matrix). +* + CALL DLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA ) +* +* Array S(1:min(M,N)) should contain svd(A), the sigular +* values of the generated matrix A in decreasing absolute +* value order. S in this format will be used later in the test. +* We set the array S explicitly here, since we are not using +* DLATMS (which sets the array S) to generate zero matrix. +* + DO I = 1, MINMN + S( I ) = ZERO + END DO +* + ELSE IF( ( IMAT.EQ.2 .OR. IMAT.EQ.3 .OR. IMAT.EQ.4 ) + $ .OR. ( IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN +* +* Matrix 2 (Diagonal), +* Matrix 3 (Upper triangular), +* Matrix 4 (Lower triangular), +* Matrices 14-19 (Various rectangular random matrices +* without zero columns). +* +* Set up parameters with DLATB4 and generate a test +* matrix with DLATMS. +* + CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'DLATMS' + CALL DLATMS( M, N, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA, LDA, WORK, INFO ) +* +* Check error code from DLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* +* Array S(1:min(M,N)) should contain svd(A), the sigular +* values of the generated matrix A in decreasing absolute +* value order. S in this format will be used later in +* the test. Unordered singular values are returned by +* DLATMS in S. We need to order singular values in S. +* + CALL DLAORD( 'Decreasing', MINMN, S, 1 ) +* + ELSE IF( MINMN.GE.2 + $ .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN +* +* Matrices 5-13 (Rectangular random matrices that +* contain zero columns). Only for matrices MINMN >= 2. +* +* JB_ZERO is the column index of ZERO block. +* NB_ZERO is the column block size of ZERO block. +* NB_GEN is the column blcok size of the +* generated block. +* J_INC in the non_zero column index increment +* to generate matrix 12 and 13. +* J_FIRS_NZ is the index of the first non-zero +* column to generate matrix 12 and 13. +* + IF( IMAT.EQ.5 ) THEN +* +* Matrix 5. First column is zero. +* + JB_ZERO = 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.6 ) THEN +* +* Matrix 6. Last column MINMN is zero. +* + JB_ZERO = MINMN + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.7 ) THEN +* +* Matrix 7. Last column N is zero. +* + JB_ZERO = N + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.8 ) THEN +* +* MAtrix 8. Middle column in MINMN is zero. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.9 ) THEN +* +* Matrix 9. First half of MINMN columns is zero, zero block size MINMN/2. +* + JB_ZERO = 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.10 ) THEN +* +* Matrix 10. Last columns are zero columns, +* starting from (MINMN / 2 + 1) column,zero block size N - MINMN/2 +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = N - MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.11 ) THEN +* +* Matrix 11. Half of the columns in the middle of first MINMN +* columns is zero, starting from MINMN/2 - (MINMN/2)/2 + 1 column, +* zero block size MINMN/2. +* + JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.12 ) THEN +* +* Matrix 12. Odd-numbered columns are zero, +* + NB_GEN = N / 2 + NB_ZERO = N - NB_GEN + J_INC = 2 + J_FIRST_NZ = 2 +* + ELSE IF( IMAT.EQ.13 ) THEN +* +* Matrix 13. Even-numbered columns are zero. +* + NB_ZERO = N / 2 + NB_GEN = N - NB_ZERO + J_INC = 2 + J_FIRST_NZ = 1 +* + END IF +* +* +* 1) Set the first NB_ZERO columns in COPYA(1:M,1:N) +* to zero. +* + CALL DLASET( 'Full', M, NB_ZERO, ZERO, ZERO, + $ COPYA, LDA ) +* +* 2) Generate an M-by-(N-NB_ZERO) matrix with the +* chosen singular value distribution +* in COPYA(1:M,NB_ZERO+1:N). +* + CALL DLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* + SRNAMT = 'DLATMS' +* + IND_OFFSET_GEN = NB_ZERO * LDA +* + CALL DLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA( IND_OFFSET_GEN + 1 ), LDA, + $ WORK, INFO ) +* +* Check error code from DLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M, + $ NB_GEN, -1, -1, -1, IMAT, NFAIL, + $ NERRS, NOUT ) + CYCLE + END IF +* +* 3) Swap the gererated colums from the right side +* NB_GEN-size block in COPYA into correct column +* positions. +* + IF( IMAT.EQ.6 + $ .OR. IMAT.EQ.7 + $ .OR. IMAT.EQ.8 + $ .OR. IMAT.EQ.10 + $ .OR. IMAT.EQ.11 ) THEN +* +* Move by swapping the generated columns +* from the right NB_GEN-size block from +* (NB_ZERO+1:NB_ZERO+JB_ZERO) +* into columns (1:JB_ZERO-1). +* + DO J = 1, JB_ZERO-1, 1 + CALL DSWAP( M, + $ COPYA( ( NB_ZERO+J-1)*LDA+1), 1, + $ COPYA( (J-1)*LDA + 1 ), 1 ) + END DO +* + ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN +* +* ( IMAT = 12, Odd-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the even zero colums in the +* left NB_ZERO-size block. +* +* ( IMAT = 13, Even-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the odd zero colums in the +* left NB_ZERO-size block. +* + DO J = 1, NB_GEN, 1 + IND_OUT = ( NB_ZERO+J-1 )*LDA + 1 + IND_IN = ( J_INC*(J-1)+(J_FIRST_NZ-1) )*LDA + $ + 1 + CALL DSWAP( M, + $ COPYA( IND_OUT ), 1, + $ COPYA( IND_IN ), 1 ) + END DO +* + END IF +* +* 5) Order the singular values generated by +* DLAMTS in decreasing absolute value order and +* add trailing zeros that correspond to zero columns. +* The total number of singular values is MINMN. +* + MINMNB_GEN = MIN( M, NB_GEN ) + CALL DLAORD( 'Decreasing', MINMNB_GEN, S, 1 ) +* + DO I = MINMNB_GEN+1, MINMN + S( I ) = ZERO + END DO +* + ELSE +* +* IF( MINMN.LT.2 .AND. ( IMAT.GE.5 .AND. IMAT.LE.13 ) ) +* skip this size for this matrix type. +* + CYCLE + END IF +* +* End generate COPYA matrix. +* +* Initialize COPYC matrix with zeros. +* + CALL DLASET( 'Full', M, N, ZERO, ZERO, COPYC, LDC ) +* +* Initialize COPYQRC matrix with zeros. +* + CALL DLASET( 'Full', M, N, ZERO, ZERO, COPYQRC, LDQRC ) +* +* Initialize COPYX matrix with zeros. +* + CALL DLASET( 'Full', MINMN, N, ZERO, ZERO, COPYX, LDX ) +* +* Initialize a copy array for pivot IPIV for DGECXX. +* + DO I = 1, M + COPY_IPIV( I ) = 0 + END DO +* +* Initialize a copy array for pivot JPIV for DGECXX. +* + DO J = 1, N + COPY_JPIV( J ) = 0 + END DO +* +* Initialize a copy array COPY_DESEL_ROWS for DGECXX. +* + DO I = 1, M + COPY_DESEL_ROWS( I ) = 0 + END DO +* +* Initialize a copy array COPY_SEL_DESEL_COLS for DGECXX. +* + DO J = 1, N + COPY_SEL_DESEL_COLS( J ) = 0 + END DO +* + DO INB = 1, NNB +* +* Do for each pair of values (NB,NX) in NBVAL and NXVAL. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + NX = NXVAL( INB ) + CALL XLAENV( 3, NX ) +* +* We do MIN(M,N)+1 because we need a test for KMAX > N, +* when KMAX is larger than MIN(M,N), KMAX should be +* KMAX = MIN(M,N) +* + DO KMAXFREE = 0, MIN(M,N)+1 +* +* Get a working copy of COPYA into A( 1:M,1:N ). +* Get a working copy of COPYC into C( 1:M,1:N ). +* Get a working copy of COPYQRC into QRC( 1:M,1:N ). +* Get a working copy of COPYX into X( 1:N,1:N ). +* Get a working copy of COPY_IPIV(1:M) into IPIV(1:M). +* Get a working copy of COPY_JPIV(1:N) into JPIV(1:N). +* Get a working copy of COPY_DESEL_ROWS(1:M) into DESEL_ROWS(1:M). +* Get a working copy of COPY_SEL_DESEL_COLS(1:N) into SEL_DESEL_COLS(1:N). +* + CALL DLACPY( 'All', M, N, COPYA, LDA, A, LDA ) + CALL DLACPY( 'All', M, N, COPYC, LDC, C, LDC ) + CALL DLACPY( 'All', M, N, COPYQRC, LDQRC, QRC, LDQRC ) + CALL DLACPY( 'All', MINMN, N, COPYX, LDX, X, LDX ) + CALL ICOPY( M, COPY_IPIV, 1, IPIV, 1 ) + CALL ICOPY( N, COPY_JPIV, 1, JPIV, 1 ) + CALL ICOPY( M, COPY_DESEL_ROWS, 1, DESEL_ROWS, 1 ) + CALL ICOPY( N, COPY_SEL_DESEL_COLS, 1, + $ SEL_DESEL_COLS, 1 ) +* +* Set test ratios for all tests to zero. +* + DO I = 1, NTESTS + RESULT( I ) = ZERO + END DO +* +* We are not testing with ABSTOL and RELTOL stopping criteria. +* Disable them. +* + FACT = 'C' + USESD = 'N' + ABSTOL = -ONE + RELTOL = -ONE +* +* Compute the QR factorization with pivoting of A +* +* Determine LWORK +* +* NBMAX_ORMQR is hardwired in DORMQR as NBMAX = 64. +* + NBMAX_ORMQR = 64 +* +* a) For DGEQRF inside DGECXX +* + LWORK = MAX( 1, N*NB ) +* +* b) For DORMQR inside DGECXX +* + LWORK = MAX( LWORK, + $ N*MIN(NBMAX_ORMQR,NB)+(NBMAX_ORMQR+1)*NBMAX_ORMQR ) +* +* c) For DGEQP3RK inside DGECXX +* + LWORK = MAX( LWORK, 2*N + NB*( N + 1 ) ) +* +* d) For DGELS inside DGECXX +* + LWORK = MAX( LWORK, MIN(M,N) + N*NB ) +* +* Determine LIWORK +* + LIWORK = MAX( 1, 2*N ) +* +* Compute DGECXX factorization of A. +* + SRNAMT = 'DGECXX' + CALL DGECXX( FACT, USESD, M, N, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ KMAXFREE, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, + $ X, LDX, WORK, LWORK, IWORK, LIWORK, + $ INFO ) +* +* Check an error code from DGECXX. +* + IF( INFO.LT.0 ) + $ CALL ALAERH( PATH, 'DGECXX', INFO, 0, ' ', + $ M, N, NX, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute test 1: +* +* This test in only for the full rank factorization of +* the matrix A. +* +* Array S(1:min(M,N)) contains svd(A) the sigular values +* of the original matrix A in decreasing absolute value +* order. The test computes svd(R), the vector sigular +* values of the upper trapezoid of A(1:M,1:N) that +* contains the factor R, in decreasing order. The test +* returns the ratio: +* +* 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS ) +* + IF( K.EQ.MINMN ) THEN +* + RESULT( 1 ) = DQRT12( M, N, A, LDA, S, WORK, + $ LWKTST ) +* + NRUN = NRUN + 1 +* +* End test 1 +* + END IF +* +* Compute test 2: +* +* The test returns the ratio: +* +* 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS ) +* + RESULT( 2 ) = DQPT01( M, N, K, COPYA, A, LDA, TAU, + $ JPIV, WORK, LWKTST ) +* +* Compute test 3: +* +* The test returns the ratio: +* +* 1-norm( Q**T * Q - I ) / ( M * EPS ) +* + RESULT( 3 ) = DQRT11( M, K, A, LDA, TAU, WORK, + $ LWKTST ) +* + NRUN = NRUN + 2 +* +* Compute test 4: +* +* This test is only for the factorizations with the +* rank greater then 1. +* The elements on the diagonal of R should be non- +* increasing. +* +* The test returns the ratio: +* +* Returns 1.0D+38 if abs(R(j+1,j+1)) > abs(R(j,j)), +* j=1:K-1 +* + IF( MIN(K, MINMN).GT.1 ) THEN +* + DO J = 1, K-1, 1 + + DTEMP = (( ABS( A( (J-1)*LDA+J ) ) - + $ ABS( A( (J)*LDA+J+1 ) ) ) / + $ ABS( A(1) ) ) +* + IF( DTEMP.LT.ZERO ) THEN + RESULT( 4 ) = BIGNUM + END IF +* + END DO +* + NRUN = NRUN + 1 +* +* End test 4. +* + END IF +* +* =============== +* Compute test 5: +* =============== +* This test is only for the factorizations with the +* rank greater than 0. +* For J=1:K, the J-th column of C should be elementwise +* equal (including NaN and Inf) +* to the JPIV(J)-th column of A. +* + RESULT( 5 ) = ZERO +* Disable for now, incomplete test. + IF(.FALSE.) THEN + DO J = 1, K, 1 + DO I = 1, M, 1 + IF( .NOT. (C( (J-1)*LDC+I ) + $ .EQ. A( (JPIV( J )-1)*LDA+I ) ) ) THEN + RESULT( 5 ) = BIGNUM + END IF + END DO + END DO + END IF +* +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'DGECXX', M, N, + $ FACT, USESD, KMAXFREE, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO +* +* END DO KMAX = 1, MIN(M,N)+1 +* + END DO +* +* END DO for INB = 1, NNB +* + END DO +* +* END DO for IMAT = 1, NTYPES +* + END DO +* +* END DO for IN = 1, NN +* + END DO +* +* END DO for IM = 1, NM +* + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, + $ ', FACT = ''', A1, ''', USESD = ''', A1, + $ ''', KMAXFREE =', I5, ', ABSTOL =', G12.5, + $ ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4, + $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) +* +* End of DCHKCXX +* + END diff --git a/lapack-netlib/TESTING/LIN/derrcxx.f b/lapack-netlib/TESTING/LIN/derrcxx.f new file mode 100644 index 0000000000..4c4d670ddf --- /dev/null +++ b/lapack-netlib/TESTING/LIN/derrcxx.f @@ -0,0 +1,1691 @@ +*> \brief \b DERRCXX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DERRCXX( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DERRCXX tests the error exits for DERRCXX that does +*> CX decomposition. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup double_lin +* +* ===================================================================== + SUBROUTINE DERRCXX( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER(LEN=3) PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 5 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J, K + DOUBLE PRECISION MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ NAN, ONE, ZERO +* .. +* .. Local Arrays .. + INTEGER DESEL_ROWS( NMAX ), SEL_DESEL_COLS( NMAX ), + $ IPIV( NMAX ), JPIV( NMAX ), IW( NMAX ) + DOUBLE PRECISION A( NMAX, NMAX ), C( NMAX, NMAX ), + $ QRC( NMAX, NMAX ), X( NMAX, NMAX ), + $ TAU( NMAX ), W( NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, DGECXX +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER(LEN=32) SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, SQRT +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DESEL_ROWS( J ) = 0 + SEL_DESEL_COLS( J ) = 0 + IPIV( J ) = 0 + JPIV( J ) = 0 + TAU( J ) = 1.D+0 / DBLE( J ) + W( J ) = 1.D+0 / DBLE( J ) + IW( J ) = -J + DO I = 1, NMAX + A( I, J ) = 1.D+0 / DBLE( I+J ) + C( I, J ) = 1.D+0 / DBLE( I+J ) + QRC( I, J ) = 1.D+0 / DBLE( I+J ) + X( I, J ) = 1.D+0 / DBLE( I+J ) + END DO + END DO +* +* Create a NaN +* + ONE = 1.0D+0 + ZERO = 0.0D+0 + NAN = SQRT( -ONE ) +* + OK = .TRUE. +* +* Error exits for CX decomposition +* +* DGECXX +* + SRNAMT = 'DGECXX' +* +* ====================== +* Test parameter FACT +* ====================== + INFOT = 1 + CALL DGECXX( '/', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ====================== +* Test parameter USESD +* ====================== +* + INFOT = 2 +* + CALL DGECXX( 'P', '/', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ====================== +* Test parameter M +* ====================== +* + INFOT = 3 +* + CALL DGECXX( 'P', 'A', -1, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter N +* ======================= +* + INFOT = 4 +* + CALL DGECXX( 'P', 'A', 0, -1, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter SEL_DESEL_COLS +* ======================= +* +* NSEL (the number of preselected columns in SEL_DESEL_COLS +* (element value = 1)) cannot be greater then MSUB. +* + INFOT = 6 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + CALL DGECXX( 'P', 'A', 1, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter KMAXFREE +* ======================= +* + INFOT = 7 +* + CALL DGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ -1, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter ABSTOL +* ======================= +* + INFOT = 8 +* + CALL DGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, NAN, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) + +* +* ======================= +* Test parameter RELTOL +* ======================= +* + INFOT = 9 +* + CALL DGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, NAN, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDA +* ======================= +* + INFOT = 11 +* +* min(M,N) = 0 +* + CALL DGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 0, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* + CALL DGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDC +* ======================= +* + INFOT = 20 +* +* min(M,N) = 0 +* + CALL DGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 0, QRC, 1, + $ X, 1, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL DGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 0, QRC, 2, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL DGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 2, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL DGECXX( 'X', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 2, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDQRC +* ======================= +* +* QRC is used only when the matrix X is returned. +* + INFOT = 22 +* +* min(M,N) = 0 +* + CALL DGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 0, + $ X, 1, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL DGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 0, + $ X, 1, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL DGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 0, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL DGECXX( 'X', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 1, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDX +* ======================= +* + INFOT = 24 +* +* min(M,N) = 0 +* + CALL DGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 0, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL DGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 0, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL DGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 0, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL DGECXX( 'X', 'A', 4, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 3, W, 20, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LWORK +* ======================= +* + INFOT = 26 +* +* Test group 1. LWORK test for MIN(M,N) = 0, then LWKMIN => 1 +* ========================================== +* + CALL DGECXX( 'X', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 0, IW, 1, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 2. LWORK tests for USESD = 'N'. +* ========================================== +* if FACT = 'P', LWKMIN = MAX(1, 3*N - 1) +* if FACT = 'C', LWKMIN = MAX(1, 3*N - 1) +* if FACT = 'X', LWKMIN = MAX(1, 3*N - 1, MINMN + N) = MAX(1, 3*N - 1) +* + CALL DGECXX( 'P', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 10, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* + CALL DGECXX( 'C', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 10, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* + CALL DGECXX( 'X', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 10, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) + + + +* +* Test group 3. LWORK tests for USESD = 'R'. +* ========================================== +* if FACT = 'P', LWKMIN = MAX(1, 3*N - 1) +* if FACT = 'C', LWKMIN = MAX(1, 3*N - 1) +* if FACT = 'X', LWKMIN = MAX(1, 3*N - 1, MINMN + N) = MAX(1, 3*N - 1) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL DGECXX( 'P', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL DGECXX( 'C', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL DGECXX( 'X', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 20, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 4. LWORK tests for USESD = 'C'. +* ========================================== +* (a) if FACT = 'P', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +* (b) if FACT = 'C', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +* (c) if FACT = 'X', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1), min(M,N)+N ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a1). Set min(1,MINMNFREE == 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* LWKMIN = (3*N_free - 1) = 11 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'P', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 10, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND N_sub is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* 3*N_free - 1 = 2 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'P', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 2, N = 4, +* M_sub = M = 2, N_sub = N = 4, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 2, +* MINMNFREE = min( M_free, N_free ) = min( 0, 2 ) = 0, +* (3*N_free - 1) = 5 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'P', 'C', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND N_sub is the largest component. +* M = 3, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'P', 'C', 3, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 3, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 3, QRC, 3, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b1). min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* LWKMIN = (3*N_free - 1) = 11 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'C', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 10, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND N_sub is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* 3*N_free - 1 = 2 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'C', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 2, N = 4, +* M_sub = M = 2, N_sub = N = 4, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 2, +* MINMNFREE = min( M_free, N_free ) = min( 0, 2 ) = 0, +* (3*N_free - 1) = 5 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'C', 'C', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND N_sub is the largest component. +* M = 3, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'C', 'C', 3, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 3, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 3, QRC, 3, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c1). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* (min(M,N)+N) = 4 + 4 = 8 +* LWKMIN = (3*N_free - 1) = 11 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'X', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 10, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (min(M,N)+N) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* (3*N_free - 1) = 2 +* (min(M,N)+N) = 4 + 4 = 8 +* LWKMIN = (min(M,N)+N) = 8 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'X', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 7, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 2, N = 5, +* M_sub = M = 2, N_sub = N = 5, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 0, 3 ) = 0, +* (3*N_free - 1) = 8 +* (min(M,N)+N) = 2 + 5 = 7 +* LWKMIN = (min(M,N)+N) = 7 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'X', 'C', 2, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 2, W, 6, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (min(M,N)+N) is the largest component. +* M = 3, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* (min(M,N)+N) = 3+4 = 7 +* LWKMIN = (min(M,N)+N) = 7 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'X', 'C', 3, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 3, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 3, QRC, 3, + $ X, 4, W, 6, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 5. LWORK tests for USESD = 'A'. +* ========================================== +* (a) if FACT = 'P', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +* (b) if FACT = 'C', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +* (c) if FACT = 'X', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1), min(M,N)+N ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a1). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* LWKMIN = (3*N_free - 1) = 11 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'P', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND N_sub is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* 3*N_free - 1 = 2 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'P', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 2, N_sub = N = 4, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 2, +* MINMNFREE = min( M_free, N_free ) = min( 0, 2 ) = 0, +* (3*N_free - 1) = 5 +* LWKMIN = N_sub = 4 + + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'P', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND N_sub is the largest component. +* M = 5, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'P', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'A', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b1). min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* LWKMIN = (3*N_free - 1) = 11 +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'C', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'A', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND N_sub is the largest component. +* M = 5, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* 3*N_free - 1 = 2 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'C', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'A', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 2, N_sub = N = 4, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 2, +* MINMNFREE = min( M_free, N_free ) = min( 0, 2 ) = 0, +* (3*N_free - 1) = 5 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'C', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'A', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND N_sub is the largest component. +* M = 5, N = 4, +* M_sub = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'C', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c1). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* (min(M,N)+N) = 4 + 4 = 8 +* LWKMIN = (3*N_free - 1) = 11 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'X', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (min(M,N)+N) is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* (3*N_free - 1) = 2 +* (min(M,N)+N) = 4 + 4 = 8 +* LWKMIN = (min(M,N)+N) = 8 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'X', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 7, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 5, +* M_sub = 2, N_sub = N = 5, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 0, 3 ) = 0, +* (3*N_free - 1) = 8 +* (min(M,N)+N) = 2 + 5 = 7 +* LWKMIN = (min(M,N)+N) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 6, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (min(M,N)+N) is the largest component. +* M = 5, N = 4, +* M_sub = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* (min(M,N)+N) = 3+4 = 7 +* LWKMIN = (min(M,N)+N) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL DGECXX( 'X', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 6, IW, 10, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LIWORK +* ======================= +* + INFOT = 28 +* +* Test group 1. LIWORK test for MIN(M,N) = 0, then LWKMIN => 1 +* ========================================== +* + CALL DGECXX( 'X', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 0, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 2. LIWORK tests for USESD = 'N' +* ========================================== +* if FACT = 'P', LIWKMIN = MAX(1, N-1) +* if FACT = 'C', LIWKMIN = MAX(1, 2*N) +* if FACT = 'X', LIWKMIN = MAX(1, 2*N) +* + CALL DGECXX( 'P', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, IW, 2, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) + CALL DGECXX( 'C', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, IW, 7, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) + CALL DGECXX( 'X', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, IW, 7, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 3. LIWORK tests for USESD = 'R' +* ========================================== +* if FACT = 'P', LIWKMIN = MAX(1, N-1) +* if FACT = 'C', LIWKMIN = MAX(1, 2*N) +* if FACT = 'X', LIWKMIN = MAX(1, 2*N) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL DGECXX( 'P', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 2, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL DGECXX( 'C', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 7, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL DGECXX( 'X', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 7, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 4. LIWORK tests for USESD = 'C'. +* ========================================== +* (a) if FACT = 'P', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ) +* (b) if FACT = 'C', LIWKMIN = max( 1, 2*N ) +* (c) if FACT = 'X', LIWKMIN = max( 1, 2*N ) +* +* Parameter LIWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g4(a1). Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = (N_free-1) = 4 - 1 = 3 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'P', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 2, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g4(a2). Set min(1,N_sel) = 1 (i.e. enable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 3, +* min(1,N_sel) = 1 +* LIWKMIN = (N_free-1) + N_free = 3 - 1 + 3 = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'P', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 4, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b1). (N_free-1) + min(1,N_sel)*N_free. +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c2). (N_free-1) + min(1,N_sel)*N_free. +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5` +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 5. LIWORK tests for USESD = 'A'. +* ========================================== +* (a) if FACT = 'P', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ) +* (b) if FACT = 'C', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free, N ) +* (c) if FACT = 'X', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free, N ) +* +* Parameter LIWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g5(a1). Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = (N_free-1) = 4 - 1 = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'P', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 2, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g5(a2). Set min(1,N_sel) = 1 (i.e. enable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* min(1,N_sel) = 1 +* LIWKMIN = (N_free-1) + N_free = 3 - 1 + 3 = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'P', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 4, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 2, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 4, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 2, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 4, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL DGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'DGECXX', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of DERRCXX +* + END diff --git a/lapack-netlib/TESTING/LIN/dlatb4.f b/lapack-netlib/TESTING/LIN/dlatb4.f index f3bccd45b2..da9cd0c823 100644 --- a/lapack-netlib/TESTING/LIN/dlatb4.f +++ b/lapack-netlib/TESTING/LIN/dlatb4.f @@ -117,6 +117,7 @@ * ===================================================================== SUBROUTINE DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, $ CNDNUM, DIST ) + IMPLICIT NONE * * -- LAPACK test routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -236,11 +237,115 @@ SUBROUTINE DLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, TYPE = 'N' * * Set DIST, the type of distribution for the random -* number generator. 'S' is +* number generator. 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) * DIST = 'S' * -* Set the lower and upper bandwidths. +* Set the lower bandwidth KL and the upper bandwidth KU. +* + IF( IMAT.EQ.2 ) THEN +* +* 2. Random, Diagonal, CNDNUM = 2 +* + KL = 0 + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.3 ) THEN +* +* 3. Random, Upper triangular, CNDNUM = 2 +* + KL = 0 + KU = MAX( N-1, 0 ) + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.4 ) THEN +* +* 4. Random, Lower triangular, CNDNUM = 2 +* + KL = MAX( M-1, 0 ) + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE +* +* 5.-19. Rectangular matrix +* + KL = MAX( M-1, 0 ) + KU = MAX( N-1, 0 ) +* + IF( IMAT.GE.5 .AND. IMAT.LE.14 ) THEN +* +* 5.-14. Random, CNDNUM = 2. +* + CNDNUM = TWO + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.15 ) THEN +* +* 15. Random, CNDNUM = sqrt(0.1/EPS) +* + CNDNUM = BADC1 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.16 ) THEN +* +* 16. Random, CNDNUM = 0.1/EPS +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.17 ) THEN +* +* 17. Random, CNDNUM = 0.1/EPS, +* one small singular value S(N)=1/CNDNUM +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 2 +* + ELSE IF( IMAT.EQ.18 ) THEN +* +* 18. Random, scaled near underflow +* + CNDNUM = TWO + ANORM = SMALL + MODE = 3 +* + ELSE IF( IMAT.EQ.19 ) THEN +* +* 19. Random, scaled near overflow +* + CNDNUM = TWO + ANORM = LARGE + MODE = 3 +* + END IF +* + END IF +* + ELSE IF( LSAMEN( 2, C2, 'CX' ) ) THEN +* +* xCX: CX factorization +* Set parameters to generate a general +* M x N matrix. +* +* Set TYPE, the type of matrix to be generated. 'N' is nonsymmetric. +* + TYPE = 'N' +* +* Set DIST, the type of distribution for the random +* number generator. 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) +* + DIST = 'S' +* +* Set the lower bandwidth KL and the upper bandwidth KU. * IF( IMAT.EQ.2 ) THEN * diff --git a/lapack-netlib/TESTING/LIN/schkaa.F b/lapack-netlib/TESTING/LIN/schkaa.F index ad6ea87767..25c455d4fa 100644 --- a/lapack-netlib/TESTING/LIN/schkaa.F +++ b/lapack-netlib/TESTING/LIN/schkaa.F @@ -63,7 +63,8 @@ *> SLQ 8 List types on next line if 0 < NTYPES < 8 *> SQL 8 List types on next line if 0 < NTYPES < 8 *> SQP 6 List types on next line if 0 < NTYPES < 6 -*> DQK 19 List types on next line if 0 < NTYPES < 19 +*> SQK 19 List types on next line if 0 < NTYPES < 19 +*> SCX 19 List types on next line if 0 < NTYPES < 19 *> STZ 3 List types on next line if 0 < NTYPES < 3 *> SLS 6 List types on next line if 0 < NTYPES < 6 *> SEQ @@ -144,13 +145,14 @@ PROGRAM SCHKAA * .. * .. Local Arrays .. LOGICAL DOTYPE( MATMAX ) - INTEGER IWORK( 25*NMAX ), MVAL( MAXIN ), + INTEGER MVAL( MAXIN ), $ NBVAL( MAXIN ), NBVAL2( MAXIN ), $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) * .. * .. Allocatable Arrays .. INTEGER AllocateStatus + INTEGER, DIMENSION(:), ALLOCATABLE :: IWORK REAL, DIMENSION(:), ALLOCATABLE :: RWORK, S REAL, DIMENSION(:), ALLOCATABLE :: E REAL, DIMENSION(:,:), ALLOCATABLE :: A, B, WORK @@ -161,15 +163,17 @@ PROGRAM SCHKAA EXTERNAL LSAME, LSAMEN, SECOND, SLAMCH * .. * .. External Subroutines .. - EXTERNAL ALAREQ, SCHKEQ, SCHKGB, SCHKGE, SCHKGT, SCHKLQ, + EXTERNAL ALAREQ, SCHKCXX, + $ SCHKEQ, SCHKGB, SCHKGE, SCHKGT, SCHKLQ, $ SCHKORHR_COL, SCHKPB, SCHKPO, SCHKPS, SCHKPP, $ SCHKPT, SCHKQ3, SCHKQP3RK, SCHKQL, SCHKQR, $ SCHKRQ, SCHKSP, SCHKSY, SCHKSY_ROOK, SCHKSY_RK, $ SCHKSY_AA, SCHKTB, SCHKTP, SCHKTR, SCHKTZ, $ SDRVGB, SDRVGE, SDRVGT, SDRVLS, SDRVPB, SDRVPO, $ SDRVPP, SDRVPT, SDRVSP, SDRVSY, SDRVSY_ROOK, - $ SDRVSY_RK, SDRVSY_AA, ILAVER, SCHKLQTP, SCHKQRT, - $ SCHKQRTP, SCHKLQT, SCHKTSQR + $ SDRVSY_RK, SDRVSY_AA, ILAVER, SCHKLQTP, + $ SCHKQRT, SCHKQRTP, SCHKLQT, SCHKTSQR, + $ SCHKSY_AA_2STAGE, SDRVSY_AA_2STAGE * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -189,7 +193,9 @@ PROGRAM SCHKAA * .. * .. Allocate memory dynamically .. * - ALLOCATE ( A( ( KDMAX+1 )*NMAX, 7 ), STAT = AllocateStatus ) + ALLOCATE ( IWORK( 34*NMAX ), STAT = AllocateStatus ) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( A( ( KDMAX+1 )*NMAX, 8 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE ( B( NMAX*MAXRHS, 4 ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" @@ -200,7 +206,7 @@ PROGRAM SCHKAA ALLOCATE ( S( 2*NMAX ), STAT = AllocateStatus ) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE ( RWORK( 5*NMAX+2*MAXRHS ), STAT = AllocateStatus ) - IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" * .. * .. Executable Statements .. * @@ -942,6 +948,30 @@ PROGRAM SCHKAA ELSE WRITE( NOUT, FMT = 9989 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'CX' ) ) THEN +* +* CX: CX decomposition +* + NTYPES = 19 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL SCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, + $ NNB, NBVAL, NXVAL, THRESH, TSTERR, + $ A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), A( 1, 4 ), + $ A( 1, 5 ), A( 1, 6 ), + $ A( 1, 7 ), A( 1, 8 ), + $ B( 1, 1 ), B( 1, 2 ), + $ IWORK( 1 ), IWORK( 1+2*NMAX ), + $ IWORK(1+4*NMAX), IWORK(1+6*NMAX), + $ IWORK(1+8*NMAX), IWORK(1+10*NMAX), + $ IWORK(1+12*NMAX), IWORK(1+14*NMAX), + $ WORK, IWORK(1+16*NMAX), NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/schkcxx.f b/lapack-netlib/TESTING/LIN/schkcxx.f new file mode 100644 index 0000000000..cb71de9e4c --- /dev/null +++ b/lapack-netlib/TESTING/LIN/schkcxx.f @@ -0,0 +1,978 @@ +*> \brief \b SCHKCXX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, +* $ NNB, NBVAL, NXVAL, THRESH, TSTERR, +* $ A, COPYA, +* $ C, COPYC, QRC, COPYQRC, X, COPYX, S, TAU, +* $ DESEL_ROWS, COPY_DESEL_ROWS, +* $ SEL_DESEL_COLS, COPY_SEL_DESEL_COLS, +* $ IPIV, COPY_IPIV, JPIV, COPY_JPIV, +* $ WORK, IWORK, NOUT ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* REAL THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), +* $ NXVAL( * ), +* $ DESEL_ROWS( * ), COPY_DESEL_ROWS( * ), +* $ SEL_DESEL_COLS( * ), COPY_SEL_DESEL_COLS( * ), +* $ IPIV( * ), COPY_IPIV( * ), +* $ JPIV( * ), COPY_JPIV( * ) +* REAL A( * ), COPYA( * ), C( * ), COPYC( * ), +* $ QRC( * ), COPYQRC( * ), X( * ), COPYX( * ), +* $ S( * ), TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SCHKCXX tests SGECXX. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB and NX contained in the +*> vectors NBVAL and NXVAL. The blocking parameters are used +*> in pairs (NB,NX). +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NNB) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NXVAL +*> \verbatim +*> NXVAL is INTEGER array, dimension (NNB) +*> The values of the crossover point NX. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is REAL +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is REAL array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYA +*> \verbatim +*> COPYA is REAL array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is REAL array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYC +*> \verbatim +*> COPYC is REAL array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] QRC +*> \verbatim +*> QRC is REAL array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYQRC +*> \verbatim +*> COPYQRC is REAL array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is REAL array, dimension (NMAX*NMAX) +*> NMAX is the maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYX +*> \verbatim +*> COPYX is REAL array, dimension (NMAX*NMAX) +*> NMAX is the maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is REAL array, dimension +*> (min(MMAX,NMAX)) +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is REAL array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] DESEL_ROWS +*> \verbatim +*> DESEL_ROWS is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] COPY_DESEL_ROWS +*> \verbatim +*> COPY_DESEL_ROWS is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] SEL_DESEL_COLS +*> \verbatim +*> SEL_DESEL_COLS is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] COPY_SEL_DESEL_COLS +*> \verbatim +*> COPY_SEL_DESEL_COLS is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] COPY_IPIV +*> \verbatim +*> COPY_IPIV is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] COPY_JPIV +*> \verbatim +*> COPY_JPIV is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array. +*> Dimension is the maximum of the following two expressions: +*> (1) Optimal complex workspace dimension for matrix generation +*> and test routines. +*> (MMAX + 6) * max(MMAX,NMAX) +*> This is an upper bound for: +*> a) SLATMS: 3*max(M,N) +*> b) SQRT12: max( M*N + 4*min(M,N) + max(M,N), +*> M*N + 2*min(M,N) + 4*N ) +*> c) SQPT01: M*N + N +*> d) SQRT11: M*M + M +*> +*> (2) Optimal workspace dimension for SGECXX. +*> max( NMAX*NBMAX, \\ for SGEQRF inside +*> NMAX*min(NBMAX_ORMQR,NBMAX) \\ for SORMQR inside +*> + (NBMAX_ORMQR+1)*NBMAX_ORMQR ), +*> 2*NMAX + NBMAX*( NMAX + 1 ), \\ for SGEQP3RK inside +*> min(MMAX,NMAX) + NMAX*NBMAX ), \\ for SGELS inside +*> where NBMAX_ORMQR=64 is hardwired in SORMQR. +*> +*> Assuming MMAX = NMAX, and NBMAX = NMAX, the expressions become: +*> (1) NMAX*NMAX + 6*NMAX +*> (2) NMAX * min(64,NMAX) + 4160 +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> for SGECXX optimal IWORK size. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> for SGECXX optimal IWORK size. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, + $ NNB, NBVAL, NXVAL, THRESH, TSTERR, + $ A, COPYA, + $ C, COPYC, QRC, COPYQRC, X, COPYX, S, TAU, + $ DESEL_ROWS, COPY_DESEL_ROWS, + $ SEL_DESEL_COLS, COPY_SEL_DESEL_COLS, + $ IPIV, COPY_IPIV, JPIV, COPY_JPIV, + $ WORK, IWORK, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + REAL THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), + $ NXVAL( * ), + $ DESEL_ROWS( * ), COPY_DESEL_ROWS( * ), + $ SEL_DESEL_COLS( * ), COPY_SEL_DESEL_COLS( * ), + $ IPIV( * ), COPY_IPIV( * ), + $ JPIV( * ), COPY_JPIV( * ) + REAL A( * ), COPYA( * ), C( * ), COPYC( * ), + $ QRC( * ), COPYQRC( * ), X( * ), COPYX( * ), + $ S( * ), TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTYPES + PARAMETER ( NTYPES = 19 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 5 ) + REAL ONE, ZERO, BIGNUM + PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, + $ BIGNUM = 1.0E+38 ) +* .. +* .. Local Scalars .. + CHARACTER DIST, TYPE, FACT, USESD + CHARACTER*3 PATH + INTEGER I, IM, IMAT, IN, INB, IND_OFFSET_GEN, + $ IND_IN, IND_OUT, INFO, J, J_INC, J_FIRST_NZ, + $ JB_ZERO, K, KL, KMAXFREE, KU, LDA, LDC, + $ LDQRC, LDX, LIWORK, LWORK, LWKTST, + $ M, MINMN, MINMNB_GEN, MODE, N, + $ NB, NBMAX_ORMQR, NB_ZERO, NERRS, NFAIL, + $ NB_GEN, NRUN, NX, T + REAL ANORM, CNDNUM, EPS, ABSTOL, RELTOL, + $ DTEMP, MAXC2NRMK, RELMAXC2NRMK, FNRMK +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ), ISEEDY( 4 ) + REAL RESULT( NTESTS ) +* .. +* .. External Functions .. + REAL SLAMCH, SQPT01, SQRT11, SQRT12 + EXTERNAL SLAMCH, SQPT01, SQRT11, SQRT12 +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, SERRCXX, + $ SGECXX, SLACPY, SLAORD, SLASET, SLATB4, + $ SLATMS, SSWAP, ICOPY, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, MOD +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, IOUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, IOUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Single precision' + PATH( 2: 3 ) = 'CX' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO I = 1, 4 + ISEED( I ) = ISEEDY( I ) + END DO + EPS = SLAMCH( 'Epsilon' ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL SERRCXX( PATH, NOUT ) +* + INFOT = 0 +* + DO IM = 1, NM +* +* Do for each value of M in MVAL. +* + M = MVAL( IM ) + LDA = MAX( 1, M ) + LDC = MAX( 1, M ) + LDQRC = MAX( 1, M ) +* + DO IN = 1, NN +* +* Do for each value of N in NVAL. +* + N = NVAL( IN ) + MINMN = MIN( M, N ) + LDX = MAX( 1, N ) +* +* 1) NOTE: for matrix generation routine SLATMS, the workspace length +* LWKTMS = 3*MAX( M, N ). LWKTMS not used in the code. +* +* 2) Set workspace length for testing routines. +* a) for SQRT12 + LWKTST = MAX( 1, M*N + 4*MINMN + MAX( M, N ), + $ M*N + 2*MINMN + 4*N ) +* +* b) for SQPT01 +* + LWKTST = MAX( LWKTST, M*N + N ) +* +* c) for SQRT11 +* + LWKTST = MAX( LWKTST, M*M + M ) +* + DO IMAT = 1, NTYPES +* +* Do for each value of IMAT in NTYPES. +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ CYCLE +* +* The type of distribution used to generate the random +* eigen-/singular values: +* ( 'S' for symmetric distribution ) => UNIFORM( -1, 1 ) +* +* Do for each type of NON-SYMMETRIC matrix: CNDNUM NORM MODE +* 1. Zero matrix CNDNUM = Inf 0 N/A +* 2. Random, Diagonal CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 3. Random, Upper triangular CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 4. Random, Lower triangular CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 5. Random, First column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 6. Random, Last MINMN column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 7. Random, Last N column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 8. Random, Middle column in MINMN is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 9. Random, First half of MINMN columns are zero, +* zero block size MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 10. Random, Last columns are zero starting from MINMN/2+1 column, +* zero block size N - MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 11. Random, Half of MINMN columns in the middle are zero starting +* from MINMN/2-(MINMN/2)/2+1 column, +* zero block size MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 12. Random, Odd columns are ZERO CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 13. Random, Even columns are ZERO CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 14. Random, CNDNUM = 2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 15. Random, CNDNUM = sqrt(0.1/EPS) CNDNUM = BADC1 = sqrt(0.1/EPS) 1 3 ( geometric distribution of singular values ) +* 16. Random, CNDNUM = 0.1/EPS CNDNUM = BADC2 = 0.1/EPS 1 3 ( geometric distribution of singular values ) +* 17. Random, CNDNUM = 0.1/EPS, one small singular value S(N)=1/CNDNUM CNDNUM = BADC2 = 0.1/EPS 1 2 ( one small singular value, S(N)=1/CNDNUM ) +* 18. Random, CNDNUM = 2, scaled near underflow CNDNUM = 2 SMALL = SAFMIN 3 ( geometric distribution of singular values ) +* 19. Random, CNDNUM = 2, scaled near overflow CNDNUM = 2 LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) ) 3 ( geometric distribution of singular values ) +* +* Generate matrices. +* + IF( IMAT.EQ.1 ) THEN +* +* Matrix 1 (Zero matrix). +* + CALL SLASET( 'Full', M, N, ZERO, ZERO, COPYA, LDA ) +* +* Array S(1:min(M,N)) should contain svd(A), the sigular +* values of the generated matrix A in decreasing absolute +* value order. S in this format will be used later in the test. +* We set the array S explicitly here, since we are not using +* SLATMS (which sets the array S) to generate zero matrix. +* + DO I = 1, MINMN + S( I ) = ZERO + END DO +* + ELSE IF( ( IMAT.EQ.2 .OR. IMAT.EQ.3 .OR. IMAT.EQ.4 ) + $ .OR. ( IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN +* +* Matrix 2 (Diagonal), +* Matrix 3 (Upper triangular), +* Matrix 4 (Lower triangular), +* Matrices 14-19 (Various rectangular random matrices +* without zero columns). +* +* Set up parameters with SLATB4 and generate a test +* matrix with SLATMS. +* + CALL SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'SLATMS' + CALL SLATMS( M, N, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA, LDA, WORK, INFO ) +* +* Check error code from SLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* +* Array S(1:min(M,N)) should contain svd(A), the sigular +* values of the generated matrix A in decreasing absolute +* value order. S in this format will be used later in +* the test. Unordered singular values are returned by +* SLATMS in S. We need to order singular values in S. +* + CALL SLAORD ( 'Decreasing', MINMN, S, 1 ) +* + ELSE IF( MINMN.GE.2 + $ .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN +* +* Matrices 5-13 (Rectangular random matrices that +* contain zero columns). Only for matrices MINMN >= 2. +* +* JB_ZERO is the column index of ZERO block. +* NB_ZERO is the column block size of ZERO block. +* NB_GEN is the column blcok size of the +* generated block. +* J_INC in the non_zero column index increment +* to generate matrix 12 and 13. +* J_FIRS_NZ is the index of the first non-zero +* column to generate matrix 12 and 13. +* + IF( IMAT.EQ.5 ) THEN +* +* Matrix 5. First column is zero. +* + JB_ZERO = 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.6 ) THEN +* +* Matrix 6. Last column MINMN is zero. +* + JB_ZERO = MINMN + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.7 ) THEN +* +* Matrix 7. Last column N is zero. +* + JB_ZERO = N + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.8 ) THEN +* +* MAtrix 8. Middle column in MINMN is zero. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.9 ) THEN +* +* Matrix 9. First half of MINMN columns is zero, zero block size MINMN/2. +* + JB_ZERO = 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.10 ) THEN +* +* Matrix 10. Last columns are zero columns, +* starting from (MINMN / 2 + 1) column,zero block size N - MINMN/2 +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = N - MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.11 ) THEN +* +* Matrix 11. Half of the columns in the middle of first MINMN +* columns is zero, starting from MINMN/2 - (MINMN/2)/2 + 1 column, +* zero block size MINMN/2. +* + JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.12 ) THEN +* +* Matrix 12. Odd-numbered columns are zero, +* + NB_GEN = N / 2 + NB_ZERO = N - NB_GEN + J_INC = 2 + J_FIRST_NZ = 2 +* + ELSE IF( IMAT.EQ.13 ) THEN +* +* Matrix 13. Even-numbered columns are zero. +* + NB_ZERO = N / 2 + NB_GEN = N - NB_ZERO + J_INC = 2 + J_FIRST_NZ = 1 +* + END IF +* +* +* 1) Set the first NB_ZERO columns in COPYA(1:M,1:N) +* to zero. +* + CALL SLASET( 'Full', M, NB_ZERO, ZERO, ZERO, + $ COPYA, LDA ) +* +* 2) Generate an M-by-(N-NB_ZERO) matrix with the +* chosen singular value distribution +* in COPYA(1:M,NB_ZERO+1:N). +* + CALL SLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* + SRNAMT = 'SLATMS' +* + IND_OFFSET_GEN = NB_ZERO * LDA +* + CALL SLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA( IND_OFFSET_GEN + 1 ), LDA, + $ WORK, INFO ) +* +* Check error code from SLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'SLATMS', INFO, 0, ' ', M, + $ NB_GEN, -1, -1, -1, IMAT, NFAIL, + $ NERRS, NOUT ) + CYCLE + END IF +* +* 3) Swap the gererated colums from the right side +* NB_GEN-size block in COPYA into correct column +* positions. +* + IF( IMAT.EQ.6 + $ .OR. IMAT.EQ.7 + $ .OR. IMAT.EQ.8 + $ .OR. IMAT.EQ.10 + $ .OR. IMAT.EQ.11 ) THEN +* +* Move by swapping the generated columns +* from the right NB_GEN-size block from +* (NB_ZERO+1:NB_ZERO+JB_ZERO) +* into columns (1:JB_ZERO-1). +* + DO J = 1, JB_ZERO-1, 1 + CALL SSWAP( M, + $ COPYA( ( NB_ZERO+J-1)*LDA+1), 1, + $ COPYA( (J-1)*LDA + 1 ), 1 ) + END DO +* + ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN +* +* ( IMAT = 12, Odd-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the even zero colums in the +* left NB_ZERO-size block. +* +* ( IMAT = 13, Even-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the odd zero colums in the +* left NB_ZERO-size block. +* + DO J = 1, NB_GEN, 1 + IND_OUT = ( NB_ZERO+J-1 )*LDA + 1 + IND_IN = ( J_INC*(J-1)+(J_FIRST_NZ-1) )*LDA + $ + 1 + CALL SSWAP( M, + $ COPYA( IND_OUT ), 1, + $ COPYA( IND_IN ), 1 ) + END DO +* + END IF +* +* 5) Order the singular values generated by +* DLAMTS in decreasing absolute value order and +* add trailing zeros that correspond to zero columns. +* The total number of singular values is MINMN. +* + MINMNB_GEN = MIN( M, NB_GEN ) + CALL SLAORD ( 'Decreasing', MINMNB_GEN, S, 1 ) +* + DO I = MINMNB_GEN+1, MINMN + S( I ) = ZERO + END DO +* + ELSE +* +* IF( MINMN.LT.2 .AND. ( IMAT.GE.5 .AND. IMAT.LE.13 ) ) +* skip this size for this matrix type. +* + CYCLE + END IF +* +* End generate COPYA matrix. +* +* Initialize COPYC matrix with zeros. +* + CALL SLASET( 'Full', M, N, ZERO, ZERO, COPYC, LDC ) +* +* Initialize COPYQRC matrix with zeros. +* + CALL SLASET( 'Full', M, N, ZERO, ZERO, COPYQRC, LDQRC ) +* +* Initialize COPYX matrix with zeros. +* + CALL SLASET( 'Full', MINMN, N, ZERO, ZERO, COPYX, LDX ) +* +* Initialize a copy array for pivot IPIV for SGECXX. +* + DO I = 1, M + COPY_IPIV( I ) = 0 + END DO +* +* Initialize a copy array for pivot JPIV for SGECXX. +* + DO J = 1, N + COPY_JPIV( J ) = 0 + END DO +* +* Initialize a copy array COPY_DESEL_ROWS for SGECXX. +* + DO I = 1, M + COPY_DESEL_ROWS( I ) = 0 + END DO +* +* Initialize a copy array COPY_SEL_DESEL_COLS for SGECXX. +* + DO J = 1, N + COPY_SEL_DESEL_COLS( J ) = 0 + END DO +* + DO INB = 1, NNB +* +* Do for each pair of values (NB,NX) in NBVAL and NXVAL. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + NX = NXVAL( INB ) + CALL XLAENV( 3, NX ) +* +* We do MIN(M,N)+1 because we need a test for KMAX > N, +* when KMAX is larger than MIN(M,N), KMAX should be +* KMAX = MIN(M,N) +* + DO KMAXFREE = 0, MIN(M,N)+1 +* +* Get a working copy of COPYA into A( 1:M,1:N ). +* Get a working copy of COPYC into C( 1:M,1:N ). +* Get a working copy of COPYQRC into QRC( 1:M,1:N ). +* Get a working copy of COPYX into X( 1:N,1:N ). +* Get a working copy of COPY_IPIV(1:M) into IPIV(1:M). +* Get a working copy of COPY_JPIV(1:N) into JPIV(1:N). +* Get a working copy of COPY_DESEL_ROWS(1:M) into DESEL_ROWS(1:M). +* Get a working copy of COPY_SEL_DESEL_COLS(1:N) into SEL_DESEL_COLS(1:N). +* + CALL SLACPY( 'All', M, N, COPYA, LDA, A, LDA ) + CALL SLACPY( 'All', M, N, COPYC, LDC, C, LDC ) + CALL SLACPY( 'All', M, N, COPYQRC, LDQRC, QRC, LDQRC ) + CALL SLACPY( 'All', MINMN, N, COPYX, LDX, X, LDX ) + CALL ICOPY( M, COPY_IPIV, 1, IPIV, 1 ) + CALL ICOPY( N, COPY_JPIV, 1, JPIV, 1 ) + CALL ICOPY( M, COPY_DESEL_ROWS, 1, DESEL_ROWS, 1 ) + CALL ICOPY( N, COPY_SEL_DESEL_COLS, 1, + $ SEL_DESEL_COLS, 1 ) +* +* Set test ratios for all tests to zero. +* + DO I = 1, NTESTS + RESULT( I ) = ZERO + END DO +* +* We are not testing with ABSTOL and RELTOL stopping criteria. +* Disable them. +* + FACT = 'C' + USESD = 'N' + ABSTOL = -ONE + RELTOL = -ONE +* +* Compute the QR factorization with pivoting of A +* +* Determine LWORK +* +* NBMAX_ORMQR is hardwired in DORMQR as NBMAX = 64. +* + NBMAX_ORMQR = 64 +* +* a) For SGEQRF inside SGECXX +* + LWORK = MAX( 1, N*NB ) +* +* b) For SORMQR inside SGECXX +* + LWORK = MAX( LWORK, + $ N*MIN(NBMAX_ORMQR,NB)+(NBMAX_ORMQR+1)*NBMAX_ORMQR ) +* +* c) For SGEQP3RK inside SGECXX +* + LWORK = MAX( LWORK, 2*N + NB*( N + 1 ) ) +* +* d) For SGELS inside SGECXX +* + LWORK = MAX( LWORK, MIN(M,N) + N*NB ) +* +* Determine LIWORK +* + LIWORK = MAX( 1, 2*N ) +* +* Compute SGECXX factorization of A. +* + SRNAMT = 'SGECXX' + CALL SGECXX( FACT, USESD, M, N, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ KMAXFREE, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, + $ X, LDX, WORK, LWORK, IWORK, LIWORK, + $ INFO ) +* +* Check an error code from SGECXX. +* + IF( INFO.LT.0 ) + $ CALL ALAERH( PATH, 'SGECXX', INFO, 0, ' ', + $ M, N, NX, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute test 1: +* +* This test in only for the full rank factorization of +* the matrix A. +* +* Array S(1:min(M,N)) contains svd(A) the sigular values +* of the original matrix A in decreasing absolute value +* order. The test computes svd(R), the vector sigular +* values of the upper trapezoid of A(1:M,1:N) that +* contains the factor R, in decreasing order. The test +* returns the ratio: +* +* 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS ) +* + IF( K.EQ.MINMN ) THEN +* + RESULT( 1 ) = SQRT12( M, N, A, LDA, S, WORK, + $ LWKTST ) +* + NRUN = NRUN + 1 +* +* End test 1 +* + END IF +* +* Compute test 2: +* +* The test returns the ratio: +* +* 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS ) +* + RESULT( 2 ) = SQPT01( M, N, K, COPYA, A, LDA, TAU, + $ JPIV, WORK, LWKTST ) +* +* Compute test 3: +* +* The test returns the ratio: +* +* 1-norm( Q**T * Q - I ) / ( M * EPS ) +* + RESULT( 3 ) = SQRT11( M, K, A, LDA, TAU, WORK, + $ LWKTST ) +* + NRUN = NRUN + 2 +* +* Compute test 4: +* +* This test is only for the factorizations with the +* rank greater then 1. +* The elements on the diagonal of R should be non- +* increasing. +* +* The test returns the ratio: +* +* Returns 1.0E+38 if abs(R(j+1,j+1)) > abs(R(j,j)), +* j=1:K-1 +* + IF( MIN(K, MINMN).GT.1 ) THEN +* + DO J = 1, K-1, 1 + + DTEMP = (( ABS( A( (J-1)*LDA+J ) ) - + $ ABS( A( (J)*LDA+J+1 ) ) ) / + $ ABS( A(1) ) ) +* + IF( DTEMP.LT.ZERO ) THEN + RESULT( 4 ) = BIGNUM + END IF +* + END DO +* + NRUN = NRUN + 1 +* +* End test 4. +* + END IF +* +* =============== +* Compute test 5: +* =============== +* This test is only for the factorizations with the +* rank greater than 0. +* For J=1:K, the J-th column of C should be elementwise +* equal (including NaN and Inf) +* to the JPIV(J)-th column of A. +* + RESULT( 5 ) = ZERO +* Disable for now, incomplete test. + IF(.FALSE.) THEN + DO J = 1, K, 1 + DO I = 1, M, 1 + IF( .NOT. (C( (J-1)*LDC+I ) + $ .EQ. A( (JPIV( J )-1)*LDA+I ) ) ) THEN + RESULT( 5 ) = BIGNUM + END IF + END DO + END DO + END IF +* +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'SGECXX', M, N, + $ FACT, USESD, KMAXFREE, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO +* +* END DO KMAX = 1, MIN(M,N)+1 +* + END DO +* +* END DO for INB = 1, NNB +* + END DO +* +* END DO for IMAT = 1, NTYPES +* + END DO +* +* END DO for IN = 1, NN +* + END DO +* +* END DO for IM = 1, NM +* + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, + $ ', FACT = ''', A1, ''', USESD = ''', A1, + $ ''', KMAXFREE =', I5, ', ABSTOL =', G12.5, + $ ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4, + $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) +* +* End of SCHKCXX +* + END diff --git a/lapack-netlib/TESTING/LIN/serrcxx.f b/lapack-netlib/TESTING/LIN/serrcxx.f new file mode 100644 index 0000000000..495424b36c --- /dev/null +++ b/lapack-netlib/TESTING/LIN/serrcxx.f @@ -0,0 +1,1691 @@ +*> \brief \b SERRCXX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SERRCXX( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SERRCXX tests the error exits for SERRCXX that does +*> CX decomposition. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup single_lin +* +* ===================================================================== + SUBROUTINE SERRCXX( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER(LEN=3) PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 5 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J, K + REAL MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ NAN, ONE, ZERO +* .. +* .. Local Arrays .. + INTEGER DESEL_ROWS( NMAX ), SEL_DESEL_COLS( NMAX ), + $ IPIV( NMAX ), JPIV( NMAX ), IW( NMAX ) + REAL A( NMAX, NMAX ), C( NMAX, NMAX ), + $ QRC( NMAX, NMAX ), X( NMAX, NMAX ), + $ TAU( NMAX ), W( NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, SGECXX +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER(LEN=32) SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC REAL, SQRT +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DESEL_ROWS( J ) = 0 + SEL_DESEL_COLS( J ) = 0 + IPIV( J ) = 0 + JPIV( J ) = 0 + TAU( J ) = 1.E+0 / REAL( J ) + W( J ) = 1.E+0 / REAL( J ) + IW( J ) = -J + DO I = 1, NMAX + A( I, J ) = 1.E+0 / REAL( I+J ) + C( I, J ) = 1.E+0 / REAL( I+J ) + QRC( I, J ) = 1.E+0 / REAL( I+J ) + X( I, J ) = 1.E+0 / REAL( I+J ) + END DO + END DO +* +* Create a NaN +* + ONE = 1.0E+0 + ZERO = 0.0E+0 + NAN = SQRT( -ONE ) +* + OK = .TRUE. +* +* Error exits for CX decomposition +* +* SGECXX +* + SRNAMT = 'SGECXX' +* +* ====================== +* Test parameter FACT +* ====================== + INFOT = 1 + CALL SGECXX( '/', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ====================== +* Test parameter USESD +* ====================== +* + INFOT = 2 +* + CALL SGECXX( 'P', '/', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ====================== +* Test parameter M +* ====================== +* + INFOT = 3 +* + CALL SGECXX( 'P', 'A', -1, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter N +* ======================= +* + INFOT = 4 +* + CALL SGECXX( 'P', 'A', 0, -1, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter SEL_DESEL_COLS +* ======================= +* +* NSEL (the number of preselected columns in SEL_DESEL_COLS +* (element value = 1)) cannot be greater then MSUB. +* + INFOT = 6 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + CALL SGECXX( 'P', 'A', 1, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter KMAXFREE +* ======================= +* + INFOT = 7 +* + CALL SGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ -1, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter ABSTOL +* ======================= +* + INFOT = 8 +* + CALL SGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, NAN, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) + +* +* ======================= +* Test parameter RELTOL +* ======================= +* + INFOT = 9 +* + CALL SGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, NAN, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDA +* ======================= +* + INFOT = 11 +* +* min(M,N) = 0 +* + CALL SGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 0, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* + CALL SGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDC +* ======================= +* + INFOT = 20 +* +* min(M,N) = 0 +* + CALL SGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 0, QRC, 1, + $ X, 1, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL SGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 0, QRC, 2, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL SGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 2, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL SGECXX( 'X', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 2, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDQRC +* ======================= +* +* QRC is used only when the matrix X is returned. +* + INFOT = 22 +* +* min(M,N) = 0 +* + CALL SGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 0, + $ X, 1, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL SGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 0, + $ X, 1, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL SGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 0, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL SGECXX( 'X', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 1, + $ X, 2, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDX +* ======================= +* + INFOT = 24 +* +* min(M,N) = 0 +* + CALL SGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 0, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL SGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 0, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL SGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 0, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL SGECXX( 'X', 'A', 4, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 3, W, 20, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LWORK +* ======================= +* + INFOT = 26 +* +* Test group 1. LWORK test for MIN(M,N) = 0, then LWKMIN => 1 +* ========================================== +* + CALL SGECXX( 'X', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 0, IW, 1, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 2. LWORK tests for USESD = 'N'. +* ========================================== +* if FACT = 'P', LWKMIN = MAX(1, 3*N - 1) +* if FACT = 'C', LWKMIN = MAX(1, 3*N - 1) +* if FACT = 'X', LWKMIN = MAX(1, 3*N - 1, MINMN + N) = MAX(1, 3*N - 1) +* + CALL SGECXX( 'P', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 10, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* + CALL SGECXX( 'C', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 10, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* + CALL SGECXX( 'X', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 10, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) + + + +* +* Test group 3. LWORK tests for USESD = 'R'. +* ========================================== +* if FACT = 'P', LWKMIN = MAX(1, 3*N - 1) +* if FACT = 'C', LWKMIN = MAX(1, 3*N - 1) +* if FACT = 'X', LWKMIN = MAX(1, 3*N - 1, MINMN + N) = MAX(1, 3*N - 1) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL SGECXX( 'P', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL SGECXX( 'C', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL SGECXX( 'X', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 20, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 4. LWORK tests for USESD = 'C'. +* ========================================== +* (a) if FACT = 'P', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +* (b) if FACT = 'C', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +* (c) if FACT = 'X', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1), min(M,N)+N ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a1). Set min(1,MINMNFREE == 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* LWKMIN = (3*N_free - 1) = 11 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'P', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 10, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND N_sub is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* 3*N_free - 1 = 2 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'P', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 2, N = 4, +* M_sub = M = 2, N_sub = N = 4, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 2, +* MINMNFREE = min( M_free, N_free ) = min( 0, 2 ) = 0, +* (3*N_free - 1) = 5 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'P', 'C', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND N_sub is the largest component. +* M = 3, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'P', 'C', 3, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 3, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 3, QRC, 3, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b1). min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* LWKMIN = (3*N_free - 1) = 11 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'C', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 10, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND N_sub is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* 3*N_free - 1 = 2 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'C', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 2, N = 4, +* M_sub = M = 2, N_sub = N = 4, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 2, +* MINMNFREE = min( M_free, N_free ) = min( 0, 2 ) = 0, +* (3*N_free - 1) = 5 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'C', 'C', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND N_sub is the largest component. +* M = 3, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* LWKMIN = N_sub = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'C', 'C', 3, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 3, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 3, QRC, 3, + $ X, 4, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c1). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* (min(M,N)+N) = 4 + 4 = 8 +* LWKMIN = (3*N_free - 1) = 11 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'X', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 10, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (min(M,N)+N) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* (3*N_free - 1) = 2 +* (min(M,N)+N) = 4 + 4 = 8 +* LWKMIN = (min(M,N)+N) = 8 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'X', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 7, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 2, N = 5, +* M_sub = M = 2, N_sub = N = 5, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 0, 3 ) = 0, +* (3*N_free - 1) = 8 +* (min(M,N)+N) = 2 + 5 = 7 +* LWKMIN = (min(M,N)+N) = 7 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'X', 'C', 2, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 2, W, 6, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (min(M,N)+N) is the largest component. +* M = 3, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* (min(M,N)+N) = 3+4 = 7 +* LWKMIN = (min(M,N)+N) = 7 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'X', 'C', 3, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 3, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 3, QRC, 3, + $ X, 4, W, 6, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 5. LWORK tests for USESD = 'A'. +* ========================================== +* (a) if FACT = 'P', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +* (b) if FACT = 'C', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ) +* (c) if FACT = 'X', LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1), min(M,N)+N ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a1). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* LWKMIN = (3*N_free - 1) = 11 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'P', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND N_sub is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* 3*N_free - 1 = 2 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'P', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 2, N_sub = N = 4, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 2, +* MINMNFREE = min( M_free, N_free ) = min( 0, 2 ) = 0, +* (3*N_free - 1) = 5 +* LWKMIN = N_sub = 4 + + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'P', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(a4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND N_sub is the largest component. +* M = 5, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'P', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'A', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b1). min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* LWKMIN = (3*N_free - 1) = 11 +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'C', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'A', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND N_sub is the largest component. +* M = 5, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* 3*N_free - 1 = 2 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'C', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'A', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 2, N_sub = N = 4, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 2, +* MINMNFREE = min( M_free, N_free ) = min( 0, 2 ) = 0, +* (3*N_free - 1) = 5 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'C', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'A', FACT = 'C', then LWKMIN = max( 1, N_sub, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(b4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND N_sub is the largest component. +* M = 5, N = 4, +* M_sub = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* LWKMIN = N_sub = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'C', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 3, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c1). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (3*N_free - 1) = 11 +* (min(M,N)+N) = 4 + 4 = 8 +* LWKMIN = (3*N_free - 1) = 11 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'X', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 10, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c2). Set min(1,MINMNFREE) = 1 ( i.e. enable (3*N_free-1) ) AND (min(M,N)+N) is the largest component. +* M = 5, N = 4, +* M_sub = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* (3*N_free - 1) = 2 +* (min(M,N)+N) = 4 + 4 = 8 +* LWKMIN = (min(M,N)+N) = 8 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'X', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 7, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c3). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (3*N_free-1) is the largest component. +* M = 5, N = 5, +* M_sub = 2, N_sub = N = 5, +* N_sel = 2, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 0, 3 ) = 0, +* (3*N_free - 1) = 8 +* (min(M,N)+N) = 2 + 5 = 7 +* LWKMIN = (min(M,N)+N) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 6, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N, min(1,MINMNFREE)*(3*N_free-1) ). +* Test g4(c4). Set min(1,MINMNFREE) = 0 ( i.e. disable (3*N_free-1) ) AND (min(M,N)+N) is the largest component. +* M = 5, N = 4, +* M_sub = 3, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 0, 1 ) = 0, +* (3*N_free - 1) = 2 +* (min(M,N)+N) = 3+4 = 7 +* LWKMIN = (min(M,N)+N) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL SGECXX( 'X', 'A', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 6, IW, 10, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LIWORK +* ======================= +* + INFOT = 28 +* +* Test group 1. LIWORK test for MIN(M,N) = 0, then LWKMIN => 1 +* ========================================== +* + CALL SGECXX( 'X', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, IW, 0, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 2. LIWORK tests for USESD = 'N' +* ========================================== +* if FACT = 'P', LIWKMIN = MAX(1, N-1) +* if FACT = 'C', LIWKMIN = MAX(1, 2*N) +* if FACT = 'X', LIWKMIN = MAX(1, 2*N) +* + CALL SGECXX( 'P', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, IW, 2, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) + CALL SGECXX( 'C', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, IW, 7, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) + CALL SGECXX( 'X', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, IW, 7, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 3. LIWORK tests for USESD = 'R' +* ========================================== +* if FACT = 'P', LIWKMIN = MAX(1, N-1) +* if FACT = 'C', LIWKMIN = MAX(1, 2*N) +* if FACT = 'X', LIWKMIN = MAX(1, 2*N) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL SGECXX( 'P', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 2, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL SGECXX( 'C', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 7, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL SGECXX( 'X', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 7, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 4. LIWORK tests for USESD = 'C'. +* ========================================== +* (a) if FACT = 'P', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ) +* (b) if FACT = 'C', LIWKMIN = max( 1, 2*N ) +* (c) if FACT = 'X', LIWKMIN = max( 1, 2*N ) +* +* Parameter LIWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g4(a1). Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = (N_free-1) = 4 - 1 = 3 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'P', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 2, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g4(a2). Set min(1,N_sel) = 1 (i.e. enable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 3, +* min(1,N_sel) = 1 +* LIWKMIN = (N_free-1) + N_free = 3 - 1 + 3 = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'P', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 4, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b1). (N_free-1) + min(1,N_sel)*N_free. +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c2). (N_free-1) + min(1,N_sel)*N_free. +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5` +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 5. LIWORK tests for USESD = 'A'. +* ========================================== +* (a) if FACT = 'P', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ) +* (b) if FACT = 'C', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free, N ) +* (c) if FACT = 'X', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free, N ) +* +* Parameter LIWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g5(a1). Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = (N_free-1) = 4 - 1 = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'P', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 2, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g5(a2). Set min(1,N_sel) = 1 (i.e. enable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* min(1,N_sel) = 1 +* LIWKMIN = (N_free-1) + N_free = 3 - 1 + 3 = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'P', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 4, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 2, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 4, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 2, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 4, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL SGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, IW, 9, INFO ) + CALL CHKXER( 'SGECXX', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of SERRCXX +* + END diff --git a/lapack-netlib/TESTING/LIN/slatb4.f b/lapack-netlib/TESTING/LIN/slatb4.f index 72a3107278..69a33c46b7 100644 --- a/lapack-netlib/TESTING/LIN/slatb4.f +++ b/lapack-netlib/TESTING/LIN/slatb4.f @@ -117,6 +117,7 @@ * ===================================================================== SUBROUTINE SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, $ CNDNUM, DIST ) + IMPLICIT NONE * * -- LAPACK test routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -235,8 +236,8 @@ SUBROUTINE SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, * TYPE = 'N' * -* Set DIST, the type of distribution for the random -* number generator. 'S' is +* Set DIST, the type of distribution for the randomom +* number generator. 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) * DIST = 'S' * @@ -320,6 +321,110 @@ SUBROUTINE SLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, ELSE IF( IMAT.EQ.19 ) THEN * * 19. Random, scaled near overflow +* + CNDNUM = TWO + ANORM = LARGE + MODE = 3 +* + END IF +* + END IF +* + ELSE IF( LSAMEN( 2, C2, 'CX' ) ) THEN +* +* xCX: CX factorization +* Set parameters to generate a general +* M x N matrix. +* +* Set TYPE, the type of matrix to be generated. 'N' is nonsymmetric. +* + TYPE = 'N' +* +* Set DIST, the type of distribution for the random +* number generator. 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) +* + DIST = 'S' +* +* Set the lower bandwidth KL and the upper bandwidth KU. +* + IF( IMAT.EQ.2 ) THEN +* +* 2. Random, Diagonal, CNDNUM = 2 +* + KL = 0 + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.3 ) THEN +* +* 3. Random, Upper triangular, CNDNUM = 2 +* + KL = 0 + KU = MAX( N-1, 0 ) + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.4 ) THEN +* +* 4. Random, Lower triangular, CNDNUM = 2 +* + KL = MAX( M-1, 0 ) + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE +* +* 5.-19. Rectangular matrix +* + KL = MAX( M-1, 0 ) + KU = MAX( N-1, 0 ) +* + IF( IMAT.GE.5 .AND. IMAT.LE.14 ) THEN +* +* 5.-14. Random, CNDNUM = 2. +* + CNDNUM = TWO + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.15 ) THEN +* +* 15. Random, CNDNUM = sqrt(0.1/EPS) +* + CNDNUM = BADC1 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.16 ) THEN +* +* 16. Random, CNDNUM = 0.1/EPS +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.17 ) THEN +* +* 17. Random, CNDNUM = 0.1/EPS, +* one small singular value S(N)=1/CNDNUM +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 2 +* + ELSE IF( IMAT.EQ.18 ) THEN +* +* 18. Random, scaled near underflow +* + CNDNUM = TWO + ANORM = SMALL + MODE = 3 +* + ELSE IF( IMAT.EQ.19 ) THEN +* +* 19. Random, scaled near overflow * CNDNUM = TWO ANORM = LARGE diff --git a/lapack-netlib/TESTING/LIN/zchkaa.F b/lapack-netlib/TESTING/LIN/zchkaa.F index 77a7a6cb31..a86793907d 100644 --- a/lapack-netlib/TESTING/LIN/zchkaa.F +++ b/lapack-netlib/TESTING/LIN/zchkaa.F @@ -70,6 +70,7 @@ *> ZQL 8 List types on next line if 0 < NTYPES < 8 *> ZQP 6 List types on next line if 0 < NTYPES < 6 *> ZQK 19 List types on next line if 0 < NTYPES < 19 +*> ZCX 19 List types on next line if 0 < NTYPES < 19 *> ZTZ 3 List types on next line if 0 < NTYPES < 3 *> ZLS 6 List types on next line if 0 < NTYPES < 6 *> ZEQ @@ -150,13 +151,14 @@ PROGRAM ZCHKAA * .. * .. Local Arrays .. LOGICAL DOTYPE( MATMAX ) - INTEGER IWORK( 25*NMAX ), MVAL( MAXIN ), + INTEGER MVAL( MAXIN ), $ NBVAL( MAXIN ), NBVAL2( MAXIN ), $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ), $ RANKVAL( MAXIN ), PIV( NMAX ) * .. * .. Allocatable Arrays .. INTEGER AllocateStatus + INTEGER, DIMENSION(:), ALLOCATABLE :: IWORK DOUBLE PRECISION, DIMENSION(:), ALLOCATABLE:: RWORK, S COMPLEX*16, DIMENSION(:), ALLOCATABLE :: E COMPLEX*16, DIMENSION(:,:), ALLOCATABLE:: A, B, WORK @@ -167,7 +169,8 @@ PROGRAM ZCHKAA EXTERNAL LSAME, LSAMEN, DLAMCH, DSECND * .. * .. External Subroutines .. - EXTERNAL ALAREQ, ZCHKEQ, ZCHKGB, ZCHKGE, ZCHKGT, ZCHKHE, + EXTERNAL ALAREQ, ZCHKCXX, + $ ZCHKEQ, ZCHKGB, ZCHKGE, ZCHKGT, ZCHKHE, $ ZCHKHE_ROOK, ZCHKHE_RK, ZCHKHE_AA, ZCHKHP, $ ZCHKLQ, ZCHKUNHR_COL, ZCHKPB, ZCHKPO, ZCHKPS, $ ZCHKPP, ZCHKPT, ZCHKQ3, ZCHKQP3RK, ZCHKQL, @@ -179,7 +182,8 @@ PROGRAM ZCHKAA $ ZDRVPO, ZDRVPP, ZDRVPT, ZDRVSP, ZDRVSY, $ ZDRVSY_ROOK, ZDRVSY_RK, ZDRVSY_AA, $ ZDRVSY_AA_2STAGE, ILAVER, ZCHKQRT, ZCHKQRTP, - $ ZCHKLQT, ZCHKLQTP, ZCHKTSQR + $ ZCHKLQT, ZCHKLQTP, ZCHKTSQR, + $ ZCHKHE_AA_2STAGE, ZCHKSY_AA_2STAGE * .. * .. Scalars in Common .. LOGICAL LERR, OK @@ -199,7 +203,9 @@ PROGRAM ZCHKAA * * .. Allocate memory dynamically .. * - ALLOCATE ( A ( (KDMAX+1) * NMAX, 7 ), STAT = AllocateStatus) + ALLOCATE ( IWORK( 34*NMAX ), STAT = AllocateStatus ) + IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" + ALLOCATE ( A ( (KDMAX+1) * NMAX, 8 ), STAT = AllocateStatus) IF (AllocateStatus /= 0) STOP "*** Not enough memory ***" ALLOCATE ( B ( NMAX * MAXRHS, 4 ), STAT = AllocateStatus) IF (AllocateStatus /= 0 ) STOP "*** Not enough memory ***" @@ -1132,6 +1138,30 @@ PROGRAM ZCHKAA ELSE WRITE( NOUT, FMT = 9989 )PATH END IF +* + ELSE IF( LSAMEN( 2, C2, 'CX' ) ) THEN +* +* CX: CX decomposition +* + NTYPES = 19 + CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT ) +* + IF( TSTCHK ) THEN + CALL ZCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, + $ NNB, NBVAL, NXVAL, THRESH, TSTERR, + $ A( 1, 1 ), A( 1, 2 ), + $ A( 1, 3 ), A( 1, 4 ), + $ A( 1, 5 ), A( 1, 6 ), + $ A( 1, 7 ), A( 1, 8 ), + $ S( 1 ), B( 1, 1 ), + $ IWORK( 1 ), IWORK( 1+2*NMAX ), + $ IWORK(1+4*NMAX), IWORK(1+6*NMAX), + $ IWORK(1+8*NMAX), IWORK(1+10*NMAX), + $ IWORK(1+12*NMAX), IWORK(1+14*NMAX), + $ WORK, RWORK, IWORK(1+16*NMAX), NOUT ) + ELSE + WRITE( NOUT, FMT = 9989 )PATH + END IF * ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN * diff --git a/lapack-netlib/TESTING/LIN/zchkcxx.f b/lapack-netlib/TESTING/LIN/zchkcxx.f new file mode 100644 index 0000000000..bfe8e9bc5f --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zchkcxx.f @@ -0,0 +1,1000 @@ +*> \brief \b ZCHKCXX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, +* $ NNB, NBVAL, NXVAL, THRESH, TSTERR, +* $ A, COPYA, +* $ C, COPYC, QRC, COPYQRC, X, COPYX, S, TAU, +* $ DESEL_ROWS, COPY_DESEL_ROWS, +* $ SEL_DESEL_COLS, COPY_SEL_DESEL_COLS, +* $ IPIV, COPY_IPIV, JPIV, COPY_JPIV, +* $ WORK, RWORK, IWORK, NOUT ) +* IMPLICIT NONE +* +* .. Scalar Arguments .. +* LOGICAL TSTERR +* INTEGER NM, NN, NNB, NOUT +* DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. +* LOGICAL DOTYPE( * ) +* INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), +* $ NXVAL( * ), +* $ DESEL_ROWS( * ), COPY_DESEL_ROWS( * ), +* $ SEL_DESEL_COLS( * ), COPY_SEL_DESEL_COLS( * ), +* $ IPIV( * ), COPY_IPIV( * ), +* $ JPIV( * ), COPY_JPIV( * ) +* DOUBLE PRECISION RWORK( * ), S( * ) +* COMPLEX*16 A( * ), COPYA( * ), C( * ), COPYC( * ), +* $ QRC( * ), COPYQRC( * ), X( * ), COPYX( * ), +* $ TAU( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZCHKCXX tests ZGECXX. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] DOTYPE +*> \verbatim +*> DOTYPE is LOGICAL array, dimension (NTYPES) +*> The matrix types to be used for testing. Matrices of type j +*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) = +*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used. +*> \endverbatim +*> +*> \param[in] NM +*> \verbatim +*> NM is INTEGER +*> The number of values of M contained in the vector MVAL. +*> \endverbatim +*> +*> \param[in] MVAL +*> \verbatim +*> MVAL is INTEGER array, dimension (NM) +*> The values of the matrix row dimension M. +*> \endverbatim +*> +*> \param[in] NN +*> \verbatim +*> NN is INTEGER +*> The number of values of N contained in the vector NVAL. +*> \endverbatim +*> +*> \param[in] NVAL +*> \verbatim +*> NVAL is INTEGER array, dimension (NN) +*> The values of the matrix column dimension N. +*> \endverbatim +*> +*> \param[in] NNB +*> \verbatim +*> NNB is INTEGER +*> The number of values of NB and NX contained in the +*> vectors NBVAL and NXVAL. The blocking parameters are used +*> in pairs (NB,NX). +*> \endverbatim +*> +*> \param[in] NBVAL +*> \verbatim +*> NBVAL is INTEGER array, dimension (NNB) +*> The values of the blocksize NB. +*> \endverbatim +*> +*> \param[in] NXVAL +*> \verbatim +*> NXVAL is INTEGER array, dimension (NNB) +*> The values of the crossover point NX. +*> \endverbatim +*> +*> \param[in] THRESH +*> \verbatim +*> THRESH is DOUBLE PRECISION +*> The threshold value for the test ratios. A result is +*> included in the output file if RESULT >= THRESH. To have +*> every test ratio printed, use THRESH = 0. +*> \endverbatim +*> +*> \param[in] TSTERR +*> \verbatim +*> TSTERR is LOGICAL +*> Flag that indicates whether error exits are to be tested. +*> \endverbatim +*> +*> \param[out] A +*> \verbatim +*> A is COMPLEX*16 array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYA +*> \verbatim +*> COPYA is COMPLEX*16 array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] C +*> \verbatim +*> C is COMPLEX*16 array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYC +*> \verbatim +*> COPYC is COMPLEX*16 array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] QRC +*> \verbatim +*> QRC is COMPLEX*16 array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYQRC +*> \verbatim +*> COPYQRC is COMPLEX*16 array, dimension (MMAX*NMAX) +*> where MMAX is the maximum value of M in MVAL and NMAX is the +*> maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] X +*> \verbatim +*> X is COMPLEX*16 array, dimension (NMAX*NMAX) +*> NMAX is the maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] COPYX +*> \verbatim +*> COPYX is COMPLEX*16 array, dimension (NMAX*NMAX) +*> NMAX is the maximum value of N in NVAL. +*> \endverbatim +*> +*> \param[out] S +*> \verbatim +*> S is DOUBLE PRECISION array, dimension +*> (min(MMAX,NMAX)) +*> \endverbatim +*> +*> \param[out] TAU +*> \verbatim +*> TAU is COMPLEX*16 array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] DESEL_ROWS +*> \verbatim +*> DESEL_ROWS is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] COPY_DESEL_ROWS +*> \verbatim +*> COPY_DESEL_ROWS is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] SEL_DESEL_COLS +*> \verbatim +*> SEL_DESEL_COLS is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] COPY_SEL_DESEL_COLS +*> \verbatim +*> COPY_SEL_DESEL_COLS is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] IPIV +*> \verbatim +*> IPIV is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] COPY_IPIV +*> \verbatim +*> COPY_IPIV is INTEGER array, dimension (MMAX) +*> \endverbatim +*> +*> \param[out] JPIV +*> \verbatim +*> JPIV is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] COPY_JPIV +*> \verbatim +*> COPY_JPIV is INTEGER array, dimension (NMAX) +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is COMPLEX*16 array. +*> Dimension is the maximum of the following two expressions: +*> (1) Optimal complex workspace dimension for matrix generation +*> and test routines. +*> (MMAX + 3) * max(MMAX,NMAX) +*> This is an upper bound for: +*> a) ZLATMS: 3*max(M,N) +*> b) ZQRT12: M*N + 2*min(M,N) + max(M,N) +*> c) ZQPT01: M*N + N +*> d) ZQRT11: M*M + M +*> +*> (2) Optimal complex workspace dimension for ZGECXX. +*> max( NMAX*NBMAX, \\ for ZGEQRF inside +*> NMAX*min(NBMAX_UNMQR,NBMAX) \\ for ZUNMQR inside +*> + (NBMAX_UNMQR+1)*NBMAX_UNMQR ), +*> NBMAX*( NMAX + 1 ), \\ for ZGEQP3RK inside +*> min(MMAX,NMAX) + NMAX*NBMAX ) \\ for ZGELS inside +*> where NBMAX_UNMQR=64 is hardwired in ZUNMQR. +*> +*> Assuming MMAX = NMAX, and NBMAX = NMAX, the expressions become: +*> (1) NMAX*NMAX + 3*NMAX +*> (2) NMAX * min(64,NMAX) + 4160 +*> \endverbatim +*> +*> \param[out] RWORK +*> \verbatim +*> RWORK is DOUBLE PRECISION array, dimension (2*NMAX) +*> +*> Dimension is the maximum of the following two expressions: +*> (1) Optimal real workspace dimension for matrix generation and test routines. +*> 2*min(MMAX,NMAX) +*> This is an upper bound for ZQRT12 routine 2*min(M,N). +*> +*> (2) Optimal real workspace dimension for ZGECXX. +*> 2*NMAX +*> This is an upper bound for ZGEQP3RK routine 2*N. +*> +*> Assuming MMAX = NMAX, the expressions (1) anf (2) become 2*NMAX. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (2*NMAX) +*> for ZGECXX optimal IWORK size. +*> \endverbatim +*> +*> \param[in] NOUT +*> \verbatim +*> NOUT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZCHKCXX( DOTYPE, NM, MVAL, NN, NVAL, + $ NNB, NBVAL, NXVAL, THRESH, TSTERR, + $ A, COPYA, + $ C, COPYC, QRC, COPYQRC, X, COPYX, S, TAU, + $ DESEL_ROWS, COPY_DESEL_ROWS, + $ SEL_DESEL_COLS, COPY_SEL_DESEL_COLS, + $ IPIV, COPY_IPIV, JPIV, COPY_JPIV, + $ WORK, RWORK, IWORK, NOUT ) + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + LOGICAL TSTERR + INTEGER NM, NN, NNB, NOUT + DOUBLE PRECISION THRESH +* .. +* .. Array Arguments .. + LOGICAL DOTYPE( * ) + INTEGER IWORK( * ), NBVAL( * ), MVAL( * ), NVAL( * ), + $ NXVAL( * ), + $ DESEL_ROWS( * ), COPY_DESEL_ROWS( * ), + $ SEL_DESEL_COLS( * ), COPY_SEL_DESEL_COLS( * ), + $ IPIV( * ), COPY_IPIV( * ), + $ JPIV( * ), COPY_JPIV( * ) + DOUBLE PRECISION RWORK( * ), S( * ) + COMPLEX*16 A( * ), COPYA( * ), C( * ), COPYC( * ), + $ QRC( * ), COPYQRC( * ), X( * ), COPYX( * ), + $ TAU( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NTYPES + PARAMETER ( NTYPES = 19 ) + INTEGER NTESTS + PARAMETER ( NTESTS = 5 ) + DOUBLE PRECISION ONE, ZERO, BIGNUM + COMPLEX*16 CZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, + $ CZERO = ( 0.0D+0, 0.0D+0 ), + $ BIGNUM = 1.0D+38 ) +* .. +* .. Local Scalars .. + CHARACTER DIST, TYPE, FACT, USESD + CHARACTER*3 PATH + INTEGER I, IM, IMAT, IN, INB, IND_OFFSET_GEN, + $ IND_IN, IND_OUT, INFO, J, J_INC, J_FIRST_NZ, + $ JB_ZERO, K, KL, KMAXFREE, KU, LDA, LDC, + $ LDQRC, LDX, LIWORK, LRWORK, LWORK, LWKTST, + $ M, MINMN, MINMNB_GEN, MODE, N, + $ NB, NBMAX_UNMQR, NB_ZERO, NERRS, NFAIL, + $ NB_GEN, NRUN, NX, T + DOUBLE PRECISION ANORM, CNDNUM, EPS, ABSTOL, RELTOL, + $ DTEMP, MAXC2NRMK, RELMAXC2NRMK, FNRMK +* .. +* .. Local Arrays .. + INTEGER ISEED( 4 ), ISEEDY( 4 ) + DOUBLE PRECISION RESULT( NTESTS ) +* .. +* .. External Functions .. + DOUBLE PRECISION DLAMCH, ZQPT01, ZQRT11, ZQRT12 + EXTERNAL DLAMCH, ZQPT01, ZQRT11, ZQRT12 +* .. +* .. External Subroutines .. + EXTERNAL ALAERH, ALAHD, ALASUM, ZERRCXX, + $ ZGECXX, ZLACPY, DLAORD, ZLASET, + $ ZLATB4, ZLATMS, ZSWAP, ICOPY, XLAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, MOD +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER*32 SRNAMT + INTEGER INFOT, IOUNIT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, IOUNIT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Data statements .. + DATA ISEEDY / 1988, 1989, 1990, 1991 / +* .. +* .. Executable Statements .. +* +* Initialize constants and the random number seed. +* + PATH( 1: 1 ) = 'Zomplex precision' + PATH( 2: 3 ) = 'CX' + NRUN = 0 + NFAIL = 0 + NERRS = 0 + DO I = 1, 4 + ISEED( I ) = ISEEDY( I ) + END DO + EPS = DLAMCH( 'Epsilon' ) +* +* Test the error exits +* + IF( TSTERR ) + $ CALL ZERRCXX( PATH, NOUT ) +* + INFOT = 0 +* + DO IM = 1, NM +* +* Do for each value of M in MVAL. +* + M = MVAL( IM ) + LDA = MAX( 1, M ) + LDC = MAX( 1, M ) + LDQRC = MAX( 1, M ) +* + DO IN = 1, NN +* +* Do for each value of N in NVAL. +* + N = NVAL( IN ) + MINMN = MIN( M, N ) + LDX = MAX( 1, N ) +* +* 1) NOTE: for matrix generation routine ZLATMS, the workspace length +* LWKTMS = 3*MAX( M, N ). LWKTMS not used in the code. +* +* 2) Set workspace length for testing routines. +* a) for ZQRT12, real LRWKTST = 2*MIN(M,N). LRWKTST not used in the code. +* for ZQRT12, complex: +* + LWKTST = MAX( 1, M*N + 2*MINMN + MAX( M, N ) ) +* +* b) for ZQPT01, complex: +* + LWKTST = MAX( LWKTST, M*N + N ) +* +* c) for ZQRT11, complex: +* + LWKTST = MAX( LWKTST, M*M + M ) +* + DO IMAT = 1, NTYPES +* +* Do for each value of IMAT in NTYPES. +* +* Do the tests only if DOTYPE( IMAT ) is true. +* + IF( .NOT.DOTYPE( IMAT ) ) + $ CYCLE +* +* The type of distribution used to generate the random +* eigen-/singular values: +* ( 'S' for symmetric distribution ) => UNIFORM( -1, 1 ) +* +* Do for each type of NON-SYMMETRIC matrix: CNDNUM NORM MODE +* 1. Zero matrix CNDNUM = Inf 0 N/A +* 2. Random, Diagonal CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 3. Random, Upper triangular CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 4. Random, Lower triangular CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 5. Random, First column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 6. Random, Last MINMN column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 7. Random, Last N column is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 8. Random, Middle column in MINMN is zero CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 9. Random, First half of MINMN columns are zero, +* zero block size MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 10. Random, Last columns are zero starting from MINMN/2+1 column, +* zero block size N - MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 11. Random, Half of MINMN columns in the middle are zero starting +* from MINMN/2-(MINMN/2)/2+1 column, +* zero block size MINMN/2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 12. Random, Odd columns are ZERO CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 13. Random, Even columns are ZERO CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 14. Random, CNDNUM = 2 CNDNUM = 2 1 3 ( geometric distribution of singular values ) +* 15. Random, CNDNUM = sqrt(0.1/EPS) CNDNUM = BADC1 = sqrt(0.1/EPS) 1 3 ( geometric distribution of singular values ) +* 16. Random, CNDNUM = 0.1/EPS CNDNUM = BADC2 = 0.1/EPS 1 3 ( geometric distribution of singular values ) +* 17. Random, CNDNUM = 0.1/EPS, one small singular value S(N)=1/CNDNUM CNDNUM = BADC2 = 0.1/EPS 1 2 ( one small singular value, S(N)=1/CNDNUM ) +* 18. Random, CNDNUM = 2, scaled near underflow CNDNUM = 2 SMALL = SAFMIN 3 ( geometric distribution of singular values ) +* 19. Random, CNDNUM = 2, scaled near overflow CNDNUM = 2 LARGE = 1.0/( 0.25 * ( SAFMIN / EPS ) ) 3 ( geometric distribution of singular values ) +* +* Generate matrices. +* + IF( IMAT.EQ.1 ) THEN +* +* Matrix 1 (Zero matrix). +* + CALL ZLASET( 'Full', M, N, CZERO, CZERO, COPYA, LDA ) +* +* Array S(1:min(M,N)) should contain svd(A), the sigular +* values of the generated matrix A in decreasing absolute +* value order. S in this format will be used later in the test. +* We set the array S explicitly here, since we are not using +* ZLATMS (which sets the array S) to generate zero matrix. +* + DO I = 1, MINMN + S( I ) = ZERO + END DO +* + ELSE IF( ( IMAT.EQ.2 .OR. IMAT.EQ.3 .OR. IMAT.EQ.4 ) + $ .OR. ( IMAT.GE.14 .AND. IMAT.LE.19 ) ) THEN +* +* Matrix 2 (Diagonal), +* Matrix 3 (Upper triangular), +* Matrix 4 (Lower triangular), +* Matrices 14-19 (Various rectangular random matrices +* without zero columns). +* +* Set up parameters with ZLATB4 and generate a test +* matrix with ZLATMS. +* + CALL ZLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, + $ MODE, CNDNUM, DIST ) +* + SRNAMT = 'ZLATMS' + CALL ZLATMS( M, N, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA, LDA, WORK, INFO ) +* +* Check error code from ZLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', M, N, + $ -1, -1, -1, IMAT, NFAIL, NERRS, + $ NOUT ) + CYCLE + END IF +* +* Array S(1:min(M,N)) should contain svd(A), the sigular +* values of the generated matrix A in decreasing absolute +* value order. S in this format will be used later in +* the test. Unordered singular values are returned by +* ZLATMS in S. We need to order singular values in S. +* + CALL DLAORD( 'Decreasing', MINMN, S, 1 ) +* + ELSE IF( MINMN.GE.2 + $ .AND. IMAT.GE.5 .AND. IMAT.LE.13 ) THEN +* +* Matrices 5-13 (Rectangular random matrices that +* contain zero columns). Only for matrices MINMN >= 2. +* +* JB_ZERO is the column index of ZERO block. +* NB_ZERO is the column block size of ZERO block. +* NB_GEN is the column blcok size of the +* generated block. +* J_INC in the non_zero column index increment +* to generate matrix 12 and 13. +* J_FIRS_NZ is the index of the first non-zero +* column to generate matrix 12 and 13. +* + IF( IMAT.EQ.5 ) THEN +* +* Matrix 5. First column is zero. +* + JB_ZERO = 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.6 ) THEN +* +* Matrix 6. Last column MINMN is zero. +* + JB_ZERO = MINMN + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.7 ) THEN +* +* Matrix 7. Last column N is zero. +* + JB_ZERO = N + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.8 ) THEN +* +* MAtrix 8. Middle column in MINMN is zero. +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = 1 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.9 ) THEN +* +* Matrix 9. First half of MINMN columns is zero, zero block size MINMN/2. +* + JB_ZERO = 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.10 ) THEN +* +* Matrix 10. Last columns are zero columns, +* starting from (MINMN / 2 + 1) column,zero block size N - MINMN/2 +* + JB_ZERO = MINMN / 2 + 1 + NB_ZERO = N - MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.11 ) THEN +* +* Matrix 11. Half of the columns in the middle of first MINMN +* columns is zero, starting from MINMN/2 - (MINMN/2)/2 + 1 column, +* zero block size MINMN/2. +* + JB_ZERO = MINMN / 2 - (MINMN / 2) / 2 + 1 + NB_ZERO = MINMN / 2 + NB_GEN = N - NB_ZERO +* + ELSE IF( IMAT.EQ.12 ) THEN +* +* Matrix 12. Odd-numbered columns are zero, +* + NB_GEN = N / 2 + NB_ZERO = N - NB_GEN + J_INC = 2 + J_FIRST_NZ = 2 +* + ELSE IF( IMAT.EQ.13 ) THEN +* +* Matrix 13. Even-numbered columns are zero. +* + NB_ZERO = N / 2 + NB_GEN = N - NB_ZERO + J_INC = 2 + J_FIRST_NZ = 1 +* + END IF +* +* +* 1) Set the first NB_ZERO columns in COPYA(1:M,1:N) +* to zero. +* + CALL ZLASET( 'Full', M, NB_ZERO, CZERO, CZERO, + $ COPYA, LDA ) +* +* 2) Generate an M-by-(N-NB_ZERO) matrix with the +* chosen singular value distribution +* in COPYA(1:M,NB_ZERO+1:N). +* + CALL ZLATB4( PATH, IMAT, M, NB_GEN, TYPE, KL, KU, + $ ANORM, MODE, CNDNUM, DIST ) +* + SRNAMT = 'ZLATMS' +* + IND_OFFSET_GEN = NB_ZERO * LDA +* + CALL ZLATMS( M, NB_GEN, DIST, ISEED, TYPE, S, MODE, + $ CNDNUM, ANORM, KL, KU, 'No packing', + $ COPYA( IND_OFFSET_GEN + 1 ), LDA, + $ WORK, INFO ) +* +* Check error code from ZLATMS. +* + IF( INFO.NE.0 ) THEN + CALL ALAERH( PATH, 'ZLATMS', INFO, 0, ' ', M, + $ NB_GEN, -1, -1, -1, IMAT, NFAIL, + $ NERRS, NOUT ) + CYCLE + END IF +* +* 3) Swap the gererated colums from the right side +* NB_GEN-size block in COPYA into correct column +* positions. +* + IF( IMAT.EQ.6 + $ .OR. IMAT.EQ.7 + $ .OR. IMAT.EQ.8 + $ .OR. IMAT.EQ.10 + $ .OR. IMAT.EQ.11 ) THEN +* +* Move by swapping the generated columns +* from the right NB_GEN-size block from +* (NB_ZERO+1:NB_ZERO+JB_ZERO) +* into columns (1:JB_ZERO-1). +* + DO J = 1, JB_ZERO-1, 1 + CALL ZSWAP( M, + $ COPYA( ( NB_ZERO+J-1)*LDA+1), 1, + $ COPYA( (J-1)*LDA + 1 ), 1 ) + END DO +* + ELSE IF( IMAT.EQ.12 .OR. IMAT.EQ.13 ) THEN +* +* ( IMAT = 12, Odd-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the even zero colums in the +* left NB_ZERO-size block. +* +* ( IMAT = 13, Even-numbered ZERO columns. ) +* Swap the generated columns from the right +* NB_GEN-size block into the odd zero colums in the +* left NB_ZERO-size block. +* + DO J = 1, NB_GEN, 1 + IND_OUT = ( NB_ZERO+J-1 )*LDA + 1 + IND_IN = ( J_INC*(J-1)+(J_FIRST_NZ-1) )*LDA + $ + 1 + CALL ZSWAP( M, + $ COPYA( IND_OUT ), 1, + $ COPYA( IND_IN ), 1 ) + END DO +* + END IF +* +* 5) Order the singular values generated by +* DLAMTS in decreasing absolute value order and +* add trailing zeros that correspond to zero columns. +* The total number of singular values is MINMN. +* + MINMNB_GEN = MIN( M, NB_GEN ) + CALL DLAORD( 'Decreasing', MINMNB_GEN, S, 1 ) +* + DO I = MINMNB_GEN+1, MINMN + S( I ) = ZERO + END DO +* + ELSE +* +* IF( MINMN.LT.2 .AND. ( IMAT.GE.5 .AND. IMAT.LE.13 ) ) +* skip this size for this matrix type. +* + CYCLE + END IF +* +* End generate COPYA matrix. +* +* Initialize COPYC matrix with zeros. +* + CALL ZLASET( 'Full', M, N, CZERO, CZERO, + $ COPYC, LDC ) +* +* Initialize COPYQRC matrix with zeros. +* + CALL ZLASET( 'Full', M, N, CZERO, CZERO, + $ COPYQRC, LDQRC ) +* +* Initialize COPYX matrix with zeros. +* + CALL ZLASET( 'Full', MINMN, N, CZERO, CZERO, + $ COPYX, LDX ) +* +* Initialize a copy array for pivot IPIV for ZGECXX. +* + DO I = 1, M + COPY_IPIV( I ) = 0 + END DO +* +* Initialize a copy array for pivot JPIV for ZGECXX. +* + DO J = 1, N + COPY_JPIV( J ) = 0 + END DO +* +* Initialize a copy array COPY_DESEL_ROWS for ZGECXX. +* + DO I = 1, M + COPY_DESEL_ROWS( I ) = 0 + END DO +* +* Initialize a copy array COPY_SEL_DESEL_COLS for ZGECXX. +* + DO J = 1, N + COPY_SEL_DESEL_COLS( J ) = 0 + END DO +* + DO INB = 1, NNB +* +* Do for each pair of values (NB,NX) in NBVAL and NXVAL. +* + NB = NBVAL( INB ) + CALL XLAENV( 1, NB ) + NX = NXVAL( INB ) + CALL XLAENV( 3, NX ) +* +* We do MIN(M,N)+1 because we need a test for KMAX > N, +* when KMAX is larger than MIN(M,N), KMAX should be +* KMAX = MIN(M,N) +* + DO KMAXFREE = 0, MIN(M,N)+1 +* +* Get a working copy of COPYA into A( 1:M,1:N ). +* Get a working copy of COPYC into C( 1:M,1:N ). +* Get a working copy of COPYQRC into QRC( 1:M,1:N ). +* Get a working copy of COPYX into X( 1:N,1:N ). +* Get a working copy of COPY_IPIV(1:M) into IPIV(1:M). +* Get a working copy of COPY_JPIV(1:N) into JPIV(1:N). +* Get a working copy of COPY_DESEL_ROWS(1:M) into DESEL_ROWS(1:M). +* Get a working copy of COPY_SEL_DESEL_COLS(1:N) into SEL_DESEL_COLS(1:N). +* + CALL ZLACPY( 'All', M, N, COPYA, LDA, A, LDA ) + CALL ZLACPY( 'All', M, N, COPYC, LDC, C, LDC ) + CALL ZLACPY( 'All', M, N, COPYQRC, LDQRC, QRC, LDQRC ) + CALL ZLACPY( 'All', MINMN, N, COPYX, LDX, X, LDX ) + CALL ICOPY( M, COPY_IPIV, 1, IPIV, 1 ) + CALL ICOPY( N, COPY_JPIV, 1, JPIV, 1 ) + CALL ICOPY( M, COPY_DESEL_ROWS, 1, DESEL_ROWS, 1 ) + CALL ICOPY( N, COPY_SEL_DESEL_COLS, 1, + $ SEL_DESEL_COLS, 1 ) +* +* Set test ratios for all tests to zero. +* + DO I = 1, NTESTS + RESULT( I ) = ZERO + END DO +* +* We are not testing with ABSTOL and RELTOL stopping criteria. +* Disable them. +* + FACT = 'C' + USESD = 'N' + ABSTOL = -ONE + RELTOL = -ONE +* +* Compute the QR factorization with pivoting of A +* +* Determine LWORK +* +* NBMAX_UNMQR is hardwired in ZUNMQR as NBMAX = 64. +* + NBMAX_UNMQR = 64 +* +* a) For ZGEQRF inside ZGECXX, complex +* + LWORK = MAX( 1, N*NB ) +* +* b) For ZUNMQR inside ZGECXX, complex +* + LWORK = MAX( LWORK, + $ N*MIN(NBMAX_UNMQR,NB)+(NBMAX_UNMQR+1)*NBMAX_UNMQR ) +* +* c1) For ZGEQP3RK inside ZGECXX, complex +* + LWORK = MAX( LWORK, NB*( N + 1 ) ) +* +* c2) For ZGEQP3RK inside ZGECXX, real +* + LRWORK = MAX( 1, 2*N ) +* +* d) For ZGELS inside ZGECXX, complex +* + LWORK = MAX( LWORK, MIN(M,N) + N*NB ) +* +* Determine LIWORK +* + LIWORK = MAX( 1, 2*N ) +* +* Compute ZGECXX factorization of A. +* + SRNAMT = 'ZGECXX' + CALL ZGECXX( FACT, USESD, M, N, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ KMAXFREE, ABSTOL, RELTOL, A, LDA, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, LDC, QRC, LDQRC, + $ X, LDX, WORK, LWORK, RWORK, LRWORK, + $ IWORK, LIWORK, INFO ) +* +* Check an error code from ZGECXX. +* + IF( INFO.LT.0 ) + $ CALL ALAERH( PATH, 'ZGECXX', INFO, 0, ' ', + $ M, N, NX, -1, NB, IMAT, + $ NFAIL, NERRS, NOUT ) +* +* Compute test 1: +* +* This test in only for the full rank factorization of +* the matrix A. +* +* Array S(1:min(M,N)) contains svd(A) the sigular values +* of the original matrix A in decreasing absolute value +* order. The test computes svd(R), the vector sigular +* values of the upper trapezoid of A(1:M,1:N) that +* contains the factor R, in decreasing order. The test +* returns the ratio: +* +* 2-norm(svd(R) - svd(A)) / ( max(M,N) * 2-norm(svd(A)) * EPS ) +* + IF( K.EQ.MINMN ) THEN +* + RESULT( 1 ) = ZQRT12( M, N, A, LDA, S, WORK, + $ LWKTST, RWORK ) +* + NRUN = NRUN + 1 +* +* End test 1 +* + END IF +* +* +* Compute test 2: +* +* The test returns the ratio: +* +* 1-norm( A*P - Q*R ) / ( max(M,N) * 1-norm(A) * EPS ) +* + RESULT( 2 ) = ZQPT01( M, N, K, COPYA, A, LDA, TAU, + $ JPIV, WORK, LWKTST ) +* +* Compute test 3: +* +* The test returns the ratio: +* +* 1-norm( Q**T * Q - I ) / ( M * EPS ) +* + RESULT( 3 ) = ZQRT11( M, K, A, LDA, TAU, WORK, + $ LWKTST ) +* + NRUN = NRUN + 2 +* +* Compute test 4: +* +* This test is only for the factorizations with the +* rank greater then 1. +* The elements on the diagonal of R should be non- +* increasing. +* +* The test returns the ratio: +* +* Returns 1.0D+38 if abs(R(j+1,j+1)) > abs(R(j,j)), +* j=1:K-1 +* + IF( MIN(K, MINMN).GT.1 ) THEN +* + DO J = 1, K-1, 1 + + DTEMP = (( ABS( A( (J-1)*LDA+J ) ) - + $ ABS( A( (J)*LDA+J+1 ) ) ) / + $ ABS( A(1) ) ) +* + IF( DTEMP.LT.ZERO ) THEN + RESULT( 4 ) = BIGNUM + END IF +* + END DO +* + NRUN = NRUN + 1 +* +* End test 4. +* + END IF +* +* =============== +* Compute test 5: +* =============== +* This test is only for the factorizations with the +* rank greater than 0. +* For J=1:K, the J-th column of C should be elementwise +* equal (including NaN and Inf) +* to the JPIV(J)-th column of A. +* + RESULT( 5 ) = ZERO +* Disable for now, incomplete test. + IF(.FALSE.) THEN + DO J = 1, K, 1 + DO I = 1, M, 1 + IF( .NOT. (C( (J-1)*LDC+I ) + $ .EQ. A( (JPIV( J )-1)*LDA+I ) ) ) THEN + RESULT( 5 ) = BIGNUM + END IF + END DO + END DO + END IF +* +* +* Print information about the tests that did not +* pass the threshold. +* + DO T = 1, NTESTS + IF( RESULT( T ).GE.THRESH ) THEN + IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) + $ CALL ALAHD( NOUT, PATH ) + WRITE( NOUT, FMT = 9999 ) 'ZGECXX', M, N, + $ FACT, USESD, KMAXFREE, ABSTOL, RELTOL, + $ NB, NX, IMAT, T, RESULT( T ) + NFAIL = NFAIL + 1 + END IF + END DO +* +* END DO KMAX = 1, MIN(M,N)+1 +* + END DO +* +* END DO for INB = 1, NNB +* + END DO +* +* END DO for IMAT = 1, NTYPES +* + END DO +* +* END DO for IN = 1, NN +* + END DO +* +* END DO for IM = 1, NM +* + END DO +* +* Print a summary of the results. +* + CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS ) +* + 9999 FORMAT( 1X, A, ' M =', I5, ', N =', I5, + $ ', FACT = ''', A1, ''', USESD = ''', A1, + $ ''', KMAXFREE =', I5, ', ABSTOL =', G12.5, + $ ', RELTOL =', G12.5, ', NB =', I4, ', NX =', I4, + $ ', type ', I2, ', test ', I2, ', ratio =', G12.5 ) +* +* End of ZCHKCXX +* + END diff --git a/lapack-netlib/TESTING/LIN/zerrcxx.f b/lapack-netlib/TESTING/LIN/zerrcxx.f new file mode 100644 index 0000000000..6cd79482cf --- /dev/null +++ b/lapack-netlib/TESTING/LIN/zerrcxx.f @@ -0,0 +1,2014 @@ +*> \brief \b ZERRCXX +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE ZERRCXX( PATH, NUNIT ) +* +* .. Scalar Arguments .. +* CHARACTER*3 PATH +* INTEGER NUNIT +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> ZERRCXX tests the error exits for ZERRCXX that does +*> CX decomposition. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] PATH +*> \verbatim +*> PATH is CHARACTER*3 +*> The LAPACK path name for the routines to be tested. +*> \endverbatim +*> +*> \param[in] NUNIT +*> \verbatim +*> NUNIT is INTEGER +*> The unit number for output. +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup complex16_lin +* +* ===================================================================== + SUBROUTINE ZERRCXX( PATH, NUNIT ) + IMPLICIT NONE +* +* -- LAPACK test routine -- +* -- LAPACK is a software package provided by Univ. of Tennessee, -- +* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- +* +* .. Scalar Arguments .. + CHARACTER(LEN=3) PATH + INTEGER NUNIT +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER NMAX + PARAMETER ( NMAX = 5 ) +* .. +* .. Local Scalars .. + INTEGER I, INFO, J, K + DOUBLE PRECISION MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ NAN, ONE, ZERO +* .. +* .. Local Arrays .. + INTEGER DESEL_ROWS( NMAX ), SEL_DESEL_COLS( NMAX ), + $ IPIV( NMAX ), JPIV( NMAX ), IW( NMAX ) + COMPLEx*16 A( NMAX, NMAX ), C( NMAX, NMAX ), + $ QRC( NMAX, NMAX ), X( NMAX, NMAX ), + $ TAU( NMAX ), W( NMAX ) + DOUBLE PRECISION RW( NMAX ) +* .. +* .. External Subroutines .. + EXTERNAL ALAESM, CHKXER, ZGECXX +* .. +* .. Scalars in Common .. + LOGICAL LERR, OK + CHARACTER(LEN=32) SRNAMT + INTEGER INFOT, NOUT +* .. +* .. Common blocks .. + COMMON / INFOC / INFOT, NOUT, OK, LERR + COMMON / SRNAMC / SRNAMT +* .. +* .. Intrinsic Functions .. + INTRINSIC DBLE, DCMPLX, DSQRT +* .. +* .. Executable Statements .. +* + NOUT = NUNIT + WRITE( NOUT, FMT = * ) +* +* Set the variables to innocuous values. +* + DO J = 1, NMAX + DESEL_ROWS( J ) = 0 + SEL_DESEL_COLS( J ) = 0 + IPIV( J ) = 0 + JPIV( J ) = 0 + TAU( J ) = 1.D+0 / DCMPLX( J ) + W( J ) = 1.D+0 / DCMPLX( J ) + RW( J ) = 1.D+0 / DBLE( J ) + IW( J ) = -J + DO I = 1, NMAX + A( I, J ) = 1.D+0 / DCMPLX( I+J ) + C( I, J ) = 1.D+0 / DCMPLX( I+J ) + QRC( I, J ) = 1.D+0 / DCMPLX( I+J ) + X( I, J ) = 1.D+0 / DCMPLX( I+J ) + END DO + END DO +* +* Create a NaN +* + ONE = 1.0D+0 + ZERO = 0.0D+0 + NAN = DSQRT( -ONE ) +* + OK = .TRUE. +* +* Error exits for CX decomposition +* +* ZGECXX +* + SRNAMT = 'ZGECXX' +* +* ====================== +* Test parameter FACT +* ====================== + INFOT = 1 + CALL ZGECXX( '/', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* ====================== +* Test parameter USESD +* ====================== +* + INFOT = 2 +* + CALL ZGECXX( 'P', '/', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* ====================== +* Test parameter M +* ====================== +* + INFOT = 3 +* + CALL ZGECXX( 'P', 'A', -1, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter N +* ======================= +* + INFOT = 4 +* + CALL ZGECXX( 'P', 'A', 0, -1, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter SEL_DESEL_COLS +* ======================= +* +* NSEL (the number of preselected columns in SEL_DESEL_COLS +* (element value = 1)) cannot be greater then MSUB. +* + INFOT = 6 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + CALL ZGECXX( 'P', 'A', 1, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) + + +* +* ======================= +* Test parameter KMAXFREE +* ======================= +* + INFOT = 7 +* + CALL ZGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ -1, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter ABSTOL +* ======================= +* + INFOT = 8 +* + CALL ZGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, NAN, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) + +* +* ======================= +* Test parameter RELTOL +* ======================= +* + INFOT = 9 +* + CALL ZGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, NAN, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDA +* ======================= +* + INFOT = 11 +* +* min(M,N) = 0 +* + CALL ZGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 0, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* + CALL ZGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 2, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDC +* ======================= +* + INFOT = 20 +* +* min(M,N) = 0 +* + CALL ZGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 0, QRC, 1, + $ X, 1, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL ZGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 0, QRC, 2, + $ X, 2, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL ZGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 2, + $ X, 2, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL ZGECXX( 'X', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 2, + $ X, 2, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDQRC +* ======================= +* +* QRC is used only when the matrix X is returned. +* + INFOT = 22 +* +* min(M,N) = 0 +* + CALL ZGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 0, + $ X, 1, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL ZGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 0, + $ X, 1, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL ZGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 0, + $ X, 2, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL ZGECXX( 'X', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 1, + $ X, 2, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LDX +* ======================= +* + INFOT = 24 +* +* min(M,N) = 0 +* + CALL ZGECXX( 'P', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 0, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'P' +* + CALL ZGECXX( 'P', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 0, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'C' +* + CALL ZGECXX( 'C', 'A', 2, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 0, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* FACT = 'X' +* + CALL ZGECXX( 'X', 'A', 4, 2, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 3, W, 20, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LWORK +* ======================= +* + INFOT = 26 +* +* Test group 1. LWORK test for MIN(M,N) = 0, then LWKMIN => 1 +* ========================================== +* + CALL ZGECXX( 'X', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 0, RW, 1, IW, 1, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 2. LWORK tests for USESD = 'N'. +* ========================================== +* if FACT = 'P', LWKMIN = MAX(1, N - 1) +* if FACT = 'C', LWKMIN = MAX(1, N - 1) +* if FACT = 'X', LWKMIN = MAX(1, MINMN + N) +* + CALL ZGECXX( 'P', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* + CALL ZGECXX( 'C', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* + CALL ZGECXX( 'X', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 5, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) + + +* +* Test group 3. LWORK tests for USESD = 'R'. +* ========================================== +* if FACT = 'P', LWKMIN = MAX(1, N - 1) +* if FACT = 'C', LWKMIN = MAX(1, N - 1) +* if FACT = 'X', LWKMIN = MAX(1, MINMN + N) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL ZGECXX( 'P', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL ZGECXX( 'C', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL ZGECXX( 'X', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 7, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 4. LWORK tests for USESD = 'C'. +* ========================================== +* (a) if FACT = 'P', LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ) +* (b) if FACT = 'C', LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ) +* (c) if FACT = 'X', LWKMIN = max( 1, min(M,N)+N ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g4(a1). +* Set N_sel = 0, then min(1,N_sel)*max(N_sel,N_free) = 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND (N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (N_free - 1) = 3 +* LWKMIN = max(1, 0, 3) = 3 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL ZGECXX( 'P', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g4(a2) +* Set N_sel = 3, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND N_sel is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* N_free - 1 = 0 +* LWKMIN = max(1, 3, 0) = 3 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL ZGECXX( 'P', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g4(a3). +* Set N_sel = 1, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND N_free is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 3, 3 ) = 3, +* N_free - 1 = 2 +* LWKMIN = max(1, 3, 2) = 3 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL ZGECXX( 'P', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g4(a4). +* Set N_sel = 4, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 0 ( i.e. disable (N_free-1) ) AND N_free is the largest component. +* M = 4, N = 4, +* M_sub = M = 2, N_sub = N = 4, +* N_sel = 4, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 0, +* MINMNFREE = min( M_free, N_free ) = min( 2, 2 ) = 0, +* N_free - 1 = 1 +* LWKMIN = max(1, 4, 0) = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 +* + CALL ZGECXX( 'P', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 3, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g4(b1). +* Set N_sel = 0, then min(1,N_sel)*max(N_sel,N_free) = 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND (N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (N_free - 1) = 3 +* LWKMIN = max(1, 0, 3) = 3 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL ZGECXX( 'C', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g4(b2) +* Set N_sel = 3, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND N_sel is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* N_free - 1 = 0 +* LWKMIN = max(1, 3, 0) = 3 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + + CALL ZGECXX( 'C', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g4(b3). +* Set N_sel = 1, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND N_free is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 3, 3 ) = 3, +* N_free - 1 = 2 +* LWKMIN = max(1, 3, 2) = 3 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL ZGECXX( 'C', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g4(b4). +* Set N_sel = 4, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 0 ( i.e. disable (N_free-1) ) AND N_free is the largest component. +* M = 4, N = 4, +* M_sub = M = 2, N_sub = N = 4, +* N_sel = 4, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 0, +* MINMNFREE = min( M_free, N_free ) = min( 2, 2 ) = 0, +* N_free - 1 = 1 +* LWKMIN = max(1, 4, 0) = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 +* + CALL ZGECXX( 'C', 'C', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 3, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N ). +* Test g4(c1). +* Set M < N. +* M = 3, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 3, 4 ) = 3, +* (N_free - 1) = 3 +* (min(M,N)+N) = 3 + 4 = 7 +* LWKMIN = (3 + 4) = 7 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL ZGECXX( 'X', 'C', 3, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 6, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g4(c). USESD = 'C', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N ). +* Test g4(c2). +* Set M > N. +* M = 4, N = 3, +* M_sub = M = 4, N_sub = N = 3, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 3, 4 ) = 3, +* (N_free - 1) = 2 +* (min(M,N)+N) = 3 + 3 = 6 +* LWKMIN = (3 + 3) = 6 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL ZGECXX( 'X', 'C', 4, 3, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 5, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 5. LWORK tests for USESD = 'A'. +* ========================================== +* (a) if FACT = 'P', LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ) +* (b) if FACT = 'C', LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ) +* (c) if FACT = 'X', LWKMIN = max( 1, min(M,N)+N ) +* +* Parameter LWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g5(a1). +* Set N_sel = 0, then min(1,N_sel)*max(N_sel,N_free) = 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND (N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (N_free - 1) = 3 +* LWKMIN = max(1, 0, 3) = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL ZGECXX( 'P', 'A', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g5(a2) +* Set N_sel = 3, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND N_sel is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* N_free - 1 = 0 +* LWKMIN = max(1, 3, 0) = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL ZGECXX( 'P', 'A', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g5(a3). +* Set N_sel = 1, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND N_free is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 3, 3 ) = 3, +* N_free - 1 = 2 +* LWKMIN = max(1, 3, 2) = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL ZGECXX( 'P', 'A', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g5(a4). +* Set N_sel = 4, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 0 ( i.e. disable (N_free-1) ) AND N_free is the largest component. +* M = 4, N = 4, +* M_sub = M = 2, N_sub = N = 4, +* N_sel = 4, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 0, +* MINMNFREE = min( M_free, N_free ) = min( 2, 2 ) = 0, +* N_free - 1 = 1 +* LWKMIN = max(1, 4, 0) = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 +* + CALL ZGECXX( 'P', 'A', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 3, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g5(b1). +* Set N_sel = 0, then min(1,N_sel)*max(N_sel,N_free) = 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND (N_free-1) is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 4, 4 ) = 4, +* (N_free - 1) = 3 +* LWKMIN = max(1, 0, 3) = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL ZGECXX( 'C', 'A', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g5(b2) +* Set N_sel = 3, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND N_sel is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* MINMNFREE = min( M_free, N_free ) = min( 1, 1 ) = 1, +* N_free - 1 = 0 +* LWKMIN = max(1, 3, 0) = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + + CALL ZGECXX( 'C', 'A', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g5(b3). +* Set N_sel = 1, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 1 ( i.e. enable (N_free-1) ) AND N_free is the largest component. +* M = 4, N = 4, +* M_sub = M = 4, N_sub = N = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 3, 3 ) = 3, +* N_free - 1 = 2 +* LWKMIN = max(1, 3, 2) = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL ZGECXX( 'C', 'A', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 2, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LWKMIN = max( 1, min(1,N_sel)*max(N_sel,N_free), min(1,MINMNFREE)*(N_free-1) ). +* Test g5(b4). +* Set N_sel = 4, then min(1,N_sel)*max(N_sel,N_free) != 0 +* Set min(1,MINMNFREE = 0 ( i.e. disable (N_free-1) ) AND N_free is the largest component. +* M = 4, N = 4, +* M_sub = M = 2, N_sub = N = 4, +* N_sel = 4, M_free = M_sub - N_sel = 0, N_free = N_sub - N_sel = 0, +* MINMNFREE = min( M_free, N_free ) = min( 2, 2 ) = 0, +* N_free - 1 = 1 +* LWKMIN = max(1, 4, 0) = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 +* + CALL ZGECXX( 'C', 'A', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 3, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N ). +* Test g5(c1). +* Set M < N. +* M = 3, N = 4, +* M_sub = M = 3, N_sub = N = 4, +* N_sel = 0, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 4, +* MINMNFREE = min( M_free, N_free ) = min( 3, 4 ) = 3, +* (N_free - 1) = 3 +* (min(M,N)+N) = 3 + 4 = 7 +* LWKMIN = (3 + 4) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL ZGECXX( 'X', 'A', 3, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 6, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LWORK. +* Case g5(c). USESD = 'A', FACT = 'X', then LWKMIN = max( 1, min(M,N)+N ). +* Test g5(c2). +* Set M > N. +* M = 4, N = 3, +* M_sub = M = 4, N_sub = N = 3, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 3, +* MINMNFREE = min( M_free, N_free ) = min( 3, 4 ) = 3, +* (N_free - 1) = 2 +* (min(M,N)+N) = 3 + 3 = 6 +* LWKMIN = (3 + 3) = 6 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 +* + CALL ZGECXX( 'X', 'A', 4, 3, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 5, RW, 20, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LRWORK +* ======================= +* + INFOT = 28 +* +* Test group 1. LIWORK test for MIN(M,N) = 0, then LRcdWKMIN => 1 +* ========================================== +* + CALL ZGECXX( 'X', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 0, IW, 1, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 2. LRWORK tests for USESD = 'N' +* ========================================== +* For all FACT = 'P', 'C', 'X', LRWKMIN = MAX(1, 2*N) +* + CALL ZGECXX( 'P', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 20, RW, 7, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* + CALL ZGECXX( 'C', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 20, RW, 7, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* + CALL ZGECXX( 'X', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 20, RW, 7, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 3. LRWORK tests for USESD = 'R' +* ========================================== +* For all FACT = 'P', 'C', 'X', LRWKMIN = MAX(1, 2*N) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 +* + CALL ZGECXX( 'P', 'R', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 7, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 +* + CALL ZGECXX( 'C', 'R', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 7, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 +* + CALL ZGECXX( 'X', 'R', 4, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 7, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 4. LRWORK tests for USESD = 'C' +* ========================================== +* For all FACT = 'P', 'C', 'X', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* +* Parameter RWORK. +* Case g4(a). USESD = 'C', FACT = 'P', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g4(a1). Set N_sub < 2*N_free. +* M = 4, N = 5, +* M_sub = M = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 3, +* 2*N_free = 6 +* LRWKMIN = MAX(4, 6) = 6 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = -1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'P', 'C', 4, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 5, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g4(a). USESD = 'C', FACT = 'P', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g4(a2). Set N_sub > 2*N_free. +* M = 4, N = 5, +* M_sub = M = 4, N_sub = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* 2*N_free = 2 +* LRWKMIN = MAX(4, 2) = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = -1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'P', 'C', 4, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 3, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g4(b). USESD = 'C', FACT = 'C', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g4(b1). Set N_sub < 2*N_free. +* M = 4, N = 5, +* M_sub = M = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 3, +* 2*N_free = 6 +* LRWKMIN = MAX(4, 6) = 6 + + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = -1 +* + CALL ZGECXX( 'C', 'C', 4, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 5, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g4(b). USESD = 'C', FACT = 'C', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g4(b2). Set N_sub > 2*N_free. +* M = 4, N = 5, +* M_sub = M = 4, N_sub = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* 2*N_free = 2 +* LRWKMIN = MAX(4, 2) = 4 +* + SEL_DESEL_COLS( 1 ) = -1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'C', 'C', 4, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 3, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g4(c). USESD = 'C', FACT = 'X', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g4(c1). Set N_sub < 2*N_free. +* M = 4, N = 5, +* M_sub = M = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 3, +* 2*N_free = 6 +* LRWKMIN = MAX(4, 6) = 6 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'X', 'C', 4, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 5, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g4(c). USESD = 'C', FACT = 'X', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g4(c2). Set N_sub > 2*N_free. +* M = 4, N = 5, +* M_sub = M = 4, N_sub = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* 2*N_free = 2 +* LRWKMIN = MAX(4, 2) = 4 +* + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = -1 +* + CALL ZGECXX( 'X', 'C', 4, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 4, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 4, QRC, 4, + $ X, 4, W, 20, RW, 3, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 5. LRWORK tests for USESD = 'A' +* ========================================== +* For all FACT = 'P', 'C', 'X', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* +* Parameter RWORK. +* Case g5(a). USESD = 'A', FACT = 'P', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g5(a1). Set N_sub < 2*N_free. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* 2*N_free = 6 +* LRWKMIN = MAX(4, 6) = 6 +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = -1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'P', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 20, RW, 5, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g5(a). USESD = 'A', FACT = 'P', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g5(a2). Set N_sub > 2*N_free. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* 2*N_free = 2 +* LRWKMIN = MAX(4, 2) = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = -1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'P', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 20, RW, 3, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g5(b). USESD = 'A', FACT = 'C', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g5(b1). Set N_sub < 2*N_free. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* 2*N_free = 6 +* LRWKMIN = MAX(4, 6) = 6 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = -1 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 1 +* + CALL ZGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 20, RW, 5, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g5(b). USESD = 'A', FACT = 'C', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g5(b2). Set N_sub > 2*N_free. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* 2*N_free = 2 +* LRWKMIN = MAX(4, 2) = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 1 +* + CALL ZGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 20, RW, 3, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g5(c). USESD = 'A', FACT = 'X', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g5(c1). Set N_sub < 2*N_free. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* 2*N_free = 6 +* LRWKMIN = MAX(4, 6) = 6 +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 1 + SEL_DESEL_COLS( 3 ) = -1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 20, RW, 5, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter RWORK. +* Case g5(c). USESD = 'A', FACT = 'X', LRWKMIN = MAX( 1, max(N_sub,2*N_free) ) +* Test g5(c2). Set N_sub > 2*N_free. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 3, M_free = M_sub - N_sel = 1, N_free = N_sub - N_sel = 1, +* 2*N_free = 2 +* LRWKMIN = MAX(4, 2) = 4 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 1 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = -1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 1 +* + CALL ZGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 20, RW, 3, IW, 20, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* ======================= +* Test parameter LIWORK +* ======================= +* + INFOT = 30 +* +* Test group 1. LIWORK test for MIN(M,N) = 0, then LIWKMIN => 1 +* ========================================== +* + CALL ZGECXX( 'X', 'A', 0, 0, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 1, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 1, QRC, 1, + $ X, 1, W, 1, RW, 1, IW, 0, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 2. LIWORK tests for USESD = 'N' +* ========================================== +* if FACT = 'P', LIWKMIN = MAX(1, N-1) +* if FACT = 'C', LIWKMIN = MAX(1, 2*N) +* if FACT = 'X', LIWKMIN = MAX(1, 2*N) +* + CALL ZGECXX( 'P', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, RW, 20, IW, 2, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) + CALL ZGECXX( 'C', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, RW, 20, IW, 7, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) + CALL ZGECXX( 'X', 'N', 2, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 2, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 2, QRC, 2, + $ X, 4, W, 11, RW, 20, IW, 7, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 3. LIWORK tests for USESD = 'R' +* ========================================== +* if FACT = 'P', LIWKMIN = MAX(1, N-1) +* if FACT = 'C', LIWKMIN = MAX(1, 2*N) +* if FACT = 'X', LIWKMIN = MAX(1, 2*N) +* + DESEL_ROWS( 1 ) = -1 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = -1 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = -1 +* + CALL ZGECXX( 'P', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 2, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL ZGECXX( 'C', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 7, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = -1 + DESEL_ROWS( 5 ) = -1 +* + CALL ZGECXX( 'X', 'R', 5, 4, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 7, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 4. LIWORK tests for USESD = 'C'. +* ========================================== +* (a) if FACT = 'P', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ) +* (b) if FACT = 'C', LIWKMIN = max( 1, 2*N ) +* (c) if FACT = 'X', LIWKMIN = max( 1, 2*N ) +* +* Parameter LIWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g4(a1). Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = (N_free-1) = 4 - 1 = 3 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'P', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 2, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(a). USESD = 'C', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g4(a2). Set min(1,N_sel) = 1 (i.e. enable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 3, +* min(1,N_sel) = 1 +* LIWKMIN = (N_free-1) + N_free = 3 - 1 + 3 = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'P', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20,IW, 4, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b1). (N_free-1) + min(1,N_sel)*N_free. +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(b). USESD = 'C', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g4(b3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'C', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 5, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c2). (N_free-1) + min(1,N_sel)*N_free. +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5` +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g4(c). USESD = 'C', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g4(c3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = M = 5, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'X', 'C', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Test group 5. LIWORK tests for USESD = 'A'. +* ========================================== +* (a) if FACT = 'P', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ) +* (b) if FACT = 'C', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free, N ) +* (c) if FACT = 'X', LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free, N ) +* +* Parameter LIWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g5(a1). Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = (N_free-1) = 4 - 1 = 3 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'P', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 2, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(a). USESD = 'A', if FACT = 'P', then LIWKMIN = max( 1, (N_free-1) + min(1,N_sel)*N_free ). +* Test g5(a2). Set min(1,N_sel) = 1 (i.e. enable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 3, +* min(1,N_sel) = 1 +* LIWKMIN = (N_free-1) + N_free = 3 - 1 + 3 = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'P', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 4, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 2, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(b). USESD = 'A', if FACT = 'C', then LIWKMIN = max( 1, 2*N ) +* Test g5(b3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'C', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c1). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 0 (i.e. disable N_free term). +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 0, M_free = M_sub - N_sel = 4, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 0 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 0 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 4, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c2). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND N is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = 4, +* N_sel = 2, M_free = M_sub - N_sel = 2, N_free = N_sub - N_sel = 2, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (2-1) + 2 = 3 +* LIWKMIN = N = 5 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = -1 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = -1 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 1 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 4, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Parameter LIWORK. +* Case g5(c). USESD = 'A', if FACT = 'X', then LIWKMIN = max( 1, 2*N ) +* Test g5(c3). (N_free-1) + min(1,N_sel)*N_free +* Set min(1,N_sel) = 1 (i.e. enable N_free term) AND ((N_free - 1) + N_free) is the largest component. +* M = 5, N = 5, +* M_sub = 4, N_sub = N = 5, +* N_sel = 1, M_free = M_sub - N_sel = 3, N_free = N_sub - N_sel = 4, +* min(1,N_sel) = 1 +* (N_free - 1) + N_free = (4-1) + 4 = 7 +* LIWKMIN = ((N_free - 1) + N_free) = 7 +* + DESEL_ROWS( 1 ) = 0 + DESEL_ROWS( 2 ) = 0 + DESEL_ROWS( 3 ) = 0 + DESEL_ROWS( 4 ) = 0 + DESEL_ROWS( 5 ) = 0 + SEL_DESEL_COLS( 1 ) = 0 + SEL_DESEL_COLS( 2 ) = 0 + SEL_DESEL_COLS( 3 ) = 1 + SEL_DESEL_COLS( 4 ) = 0 + SEL_DESEL_COLS( 5 ) = 0 +* + CALL ZGECXX( 'X', 'A', 5, 5, + $ DESEL_ROWS, SEL_DESEL_COLS, + $ 0, ONE, ONE, A, 5, + $ K, MAXC2NRMK, RELMAXC2NRMK, FNRMK, + $ IPIV, JPIV, TAU, C, 5, QRC, 5, + $ X, 5, W, 11, RW, 20, IW, 9, INFO ) + CALL CHKXER( 'ZGECXX', INFOT, NOUT, LERR, OK ) +* +* Print a summary line. +* + CALL ALAESM( PATH, OK, NOUT ) +* + RETURN +* +* End of ZERRCXX +* + END diff --git a/lapack-netlib/TESTING/LIN/zlatb4.f b/lapack-netlib/TESTING/LIN/zlatb4.f index a2b19f83d5..04dddb2a4d 100644 --- a/lapack-netlib/TESTING/LIN/zlatb4.f +++ b/lapack-netlib/TESTING/LIN/zlatb4.f @@ -118,6 +118,7 @@ * ===================================================================== SUBROUTINE ZLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, $ CNDNUM, DIST ) + IMPLICIT NONE * * -- LAPACK test routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -237,7 +238,7 @@ SUBROUTINE ZLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, TYPE = 'N' * * Set DIST, the type of distribution for the random -* number generator. 'S' is +* number generator. 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) * DIST = 'S' * @@ -321,6 +322,110 @@ SUBROUTINE ZLATB4( PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, ELSE IF( IMAT.EQ.19 ) THEN * * 19. Random, scaled near overflow +* + CNDNUM = TWO + ANORM = LARGE + MODE = 3 +* + END IF +* + END IF +* + ELSE IF( LSAMEN( 2, C2, 'CX' ) ) THEN +* +* xCX: CX factorization +* Set parameters to generate a general +* M x N matrix. +* +* Set TYPE, the type of matrix to be generated. 'N' is nonsymmetric. +* + TYPE = 'N' +* +* Set DIST, the type of distribution for the random +* number generator. 'S' => UNIFORM( -1, 1 ) ( 'S' for symmetric ) +* + DIST = 'S' +* +* Set the lower bandwidth KL and the upper bandwidth KU. +* + IF( IMAT.EQ.2 ) THEN +* +* 2. Random, Diagonal, CNDNUM = 2 +* + KL = 0 + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.3 ) THEN +* +* 3. Random, Upper triangular, CNDNUM = 2 +* + KL = 0 + KU = MAX( N-1, 0 ) + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE IF( IMAT.EQ.4 ) THEN +* +* 4. Random, Lower triangular, CNDNUM = 2 +* + KL = MAX( M-1, 0 ) + KU = 0 + CNDNUM = TWO + ANORM = ONE + MODE = 3 + ELSE +* +* 5.-19. Rectangular matrix +* + KL = MAX( M-1, 0 ) + KU = MAX( N-1, 0 ) +* + IF( IMAT.GE.5 .AND. IMAT.LE.14 ) THEN +* +* 5.-14. Random, CNDNUM = 2. +* + CNDNUM = TWO + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.15 ) THEN +* +* 15. Random, CNDNUM = sqrt(0.1/EPS) +* + CNDNUM = BADC1 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.16 ) THEN +* +* 16. Random, CNDNUM = 0.1/EPS +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 3 +* + ELSE IF( IMAT.EQ.17 ) THEN +* +* 17. Random, CNDNUM = 0.1/EPS, +* one small singular value S(N)=1/CNDNUM +* + CNDNUM = BADC2 + ANORM = ONE + MODE = 2 +* + ELSE IF( IMAT.EQ.18 ) THEN +* +* 18. Random, scaled near underflow +* + CNDNUM = TWO + ANORM = SMALL + MODE = 3 +* + ELSE IF( IMAT.EQ.19 ) THEN +* +* 19. Random, scaled near overflow * CNDNUM = TWO ANORM = LARGE diff --git a/lapack-netlib/TESTING/ctest.in b/lapack-netlib/TESTING/ctest.in index 74ff31ab8d..4e30224d73 100644 --- a/lapack-netlib/TESTING/ctest.in +++ b/lapack-netlib/TESTING/ctest.in @@ -43,6 +43,7 @@ CLQ 8 List types on next line if 0 < NTYPES < 8 CQL 8 List types on next line if 0 < NTYPES < 8 CQP 6 List types on next line if 0 < NTYPES < 6 CQK 19 List types on next line if 0 < NTYPES < 19 +CCX 19 LIst types on next line if 0 < NTYPES < 19 CTZ 3 List types on next line if 0 < NTYPES < 3 CLS 6 List types on next line if 0 < NTYPES < 6 CEQ diff --git a/lapack-netlib/TESTING/dtest.in b/lapack-netlib/TESTING/dtest.in index 1b6c7bd4a8..cde62db50d 100644 --- a/lapack-netlib/TESTING/dtest.in +++ b/lapack-netlib/TESTING/dtest.in @@ -37,6 +37,7 @@ DLQ 8 List types on next line if 0 < NTYPES < 8 DQL 8 List types on next line if 0 < NTYPES < 8 DQP 6 List types on next line if 0 < NTYPES < 6 DQK 19 LIst types on next line if 0 < NTYPES < 19 +DCX 19 LIst types on next line if 0 < NTYPES < 19 DTZ 3 List types on next line if 0 < NTYPES < 3 DLS 6 List types on next line if 0 < NTYPES < 6 DEQ diff --git a/lapack-netlib/TESTING/stest.in b/lapack-netlib/TESTING/stest.in index 7faa8b7a11..abfd639fda 100644 --- a/lapack-netlib/TESTING/stest.in +++ b/lapack-netlib/TESTING/stest.in @@ -37,6 +37,7 @@ SLQ 8 List types on next line if 0 < NTYPES < 8 SQL 8 List types on next line if 0 < NTYPES < 8 SQP 6 List types on next line if 0 < NTYPES < 6 SQK 19 List types on next line if 0 < NTYPES < 19 +SCX 19 LIst types on next line if 0 < NTYPES < 19 STZ 3 List types on next line if 0 < NTYPES < 3 SLS 6 List types on next line if 0 < NTYPES < 6 SEQ diff --git a/lapack-netlib/TESTING/ztest.in b/lapack-netlib/TESTING/ztest.in index c83e82e456..bf4c9d100b 100644 --- a/lapack-netlib/TESTING/ztest.in +++ b/lapack-netlib/TESTING/ztest.in @@ -43,6 +43,7 @@ ZLQ 8 List types on next line if 0 < NTYPES < 8 ZQL 8 List types on next line if 0 < NTYPES < 8 ZQP 6 List types on next line if 0 < NTYPES < 6 ZQK 19 List types on next line if 0 < NTYPES < 19 +ZCX 19 List types on next line if 0 < NTYPES < 19 ZTZ 3 List types on next line if 0 < NTYPES < 3 ZLS 6 List types on next line if 0 < NTYPES < 6 ZEQ